namespace WoofWare.Myriad.Plugins open Fantomas.FCS.Syntax open Fantomas.FCS.SyntaxTrivia open Fantomas.FCS.Xml open Myriad.Core [] module internal CataGenerator = open Fantomas.FCS.Text.Range open Myriad.Core.Ast /// The user-provided DU contains cases, each of which contains fields. /// We have a hard-coded set of things we know how to deal with as field contents. type FieldDescription = /// type Thing = | Case of Thing list * whatever | ListSelf of SynType /// type Thing = | Case of Thing * whatever | Self of SynType /// type Thing = | Case of int * whatever | NonRecursive of SynType /// Within a union case, there are several fields. This is a field. /// (The name is "CataUnionField" merely to distinguish it from the more general /// `UnionField` notion we already have in this library; it's got more information /// in it that is unique to this source generator.) type CataUnionBasicField = { /// The name of this field as the user originally wrote, if available. /// For example, `| Foo of blah : int` would give `Some "blah"`. FieldName : Ident option /// The name we will use when accessing this field. /// This is FieldName if available, or otherwise an autogenerated name. ArgName : Ident /// The relationship this field has with the parent type (or the /// recursive knot of parent types) Description : FieldDescription /// Any generic parameters this field consumes. /// This only makes sense in the context of a UnionAnalysis: /// it is an index into the parent Union's collection of generic parameters. RequiredGenerics : int list option } type CataUnionRecordField = (Ident * CataUnionBasicField) list [] type CataUnionField = | Record of CataUnionRecordField | Basic of CataUnionBasicField /// Everything we'll need to know about a single union case within the /// user-provided DU. type RenderedUnionCase = { /// The name of the case within the `Instruction` state-machine DU /// which indicates "all the recursive calls are now resolved; you may proceed /// to pull recursive results from the stack and execute the cata directly" InstructionName : Ident /// This user-provided DU case CaseName : SynIdent /// The fields of this user-provided DU Fields : CataUnionField list /// The corresponding method of the appropriate cata, fully-qualified as a call /// into some specific cata CataMethodName : SynLongIdent /// The identifier of the method of the appropriate cata CataMethodIdent : SynIdent /// The Instruction case which instructs the state machine to pull anything /// necessary from the stacks and call into the cata. AssociatedInstruction : SynLongIdent /// Matching on an element of this union type, if you match against this /// left-hand side (and give appropriate field arguments), you will enter this union case. Match : SynLongIdent } member this.FlattenedFields : CataUnionBasicField list = this.Fields |> List.collect (fun f -> match f with | CataUnionField.Basic x -> [ x ] | CataUnionField.Record r -> r |> List.map snd ) /// For a single user-provided DU (which is possibly one of several within a /// recursive knot), this is everything we need to know about it for the cata. type UnionAnalysis = { Accessibility : SynAccess option Typars : SynTyparDecl list /// The name of the stack we'll use for the results /// of returning from a descent into this union type, /// when performing the cata StackName : Ident /// The cases of this DU UnionCases : RenderedUnionCase list /// The Process instruction case which contains one of this union type. /// For example, the very first instruction processed will be one of these /// (i.e. when we enter the loop for the first time). /// The state machine interprets this instruction as "break me apart and /// descend recursively if necessary before coming back to me". AssociatedProcessInstruction : SynLongIdent /// Name of the parent type: e.g. in `type Foo = | Blah`, this is `Foo`. ParentTypeName : LongIdent /// The name of the generic type parameter we'll use within the cata /// to represent the result of cata'ing on this type. GenericName : Ident /// The name of the Cata type which represents "operate on this union case". CataTypeName : Ident } /// Returns a function: /// let run{Case} (cata : {cataName}<{typars}>) (x : {Case}) : {TyPar} = /// let instructions = ResizeArray () /// instructions.Add (Instruction.Process{Case} e) /// let {typar1}Results, {typar2}Results, ... = loop cata instructions /// { for all non-relevant typars: } /// if {typar}Results.Count > 0 then failwith "logic error" /// Seq.exactlyOne {relevantTypar}Stack let createRunFunction (cataName : Ident) (userProvidedTypars : SynTyparDecl list) (allArtificialTypars : SynType list) (relevantTypar : SynType) (analysis : UnionAnalysis) : SynBinding = let relevantTypeName = analysis.ParentTypeName let allArtificialTyparNames = allArtificialTypars |> List.map (fun ty -> match ty with | SynType.Var (SynTypar.SynTypar (ident = ident), _) -> ident | _ -> failwith "logic error in generator" ) let userProvidedTyparsForCase = analysis.Typars |> List.map (fun (SynTyparDecl.SynTyparDecl (_, ty)) -> SynType.Var (ty, range0)) let userProvidedTyparsForCata = userProvidedTypars |> List.map (fun (SynTyparDecl.SynTyparDecl (_, ty)) -> SynType.Var (ty, range0)) let relevantTyparName = match relevantTypar with | SynType.Var (SynTypar.SynTypar (ident = ident), _) -> ident | _ -> failwith "logic error in generator" let inputObjectType = let baseType = SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent relevantTypeName) if userProvidedTypars.Length = 0 then baseType else SynType.App ( baseType, Some range0, userProvidedTyparsForCase, List.replicate (userProvidedTypars.Length - 1) range0, Some range0, false, range0 ) // The object on which we'll run the cata let inputObject = SynPat.CreateTyped (SynPat.CreateNamed (Ident.Create "x"), inputObjectType) let cataObject = SynPat.CreateTyped ( SynPat.CreateNamed (Ident.Create "cata"), SynType.App ( SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ cataName ]), Some range0, userProvidedTyparsForCata @ allArtificialTypars, List.replicate (userProvidedTypars.Length + allArtificialTypars.Length - 1) range0, Some range0, false, range0 ) ) SynBinding.SynBinding ( None, SynBindingKind.Normal, false, false, [], PreXmlDoc.Create " Execute the catamorphism.", SynValData.SynValData ( None, SynValInfo.SynValInfo ( [ [ SynArgInfo.CreateIdString "cata" ] ; [ SynArgInfo.CreateIdString "x" ] ], SynArgInfo.SynArgInfo ([], false, None) ), None ), SynPat.CreateLongIdent ( SynLongIdent.CreateString ("run" + List.last(relevantTypeName).idText), [ SynPat.CreateParen cataObject ; SynPat.CreateParen inputObject ] ), Some (SynBindingReturnInfo.Create relevantTypar), SynExpr.CreateTyped ( SynExpr.LetOrUse ( false, false, [ SynBinding.Let ( valData = SynValData.SynValData (None, SynValInfo.Empty, None), pattern = SynPat.CreateNamed (Ident.Create "instructions"), expr = SynExpr.CreateApp ( SynExpr.CreateIdentString "ResizeArray", SynExpr.CreateConst SynConst.Unit ) ) ], SynExpr.CreateSequential [ SynExpr.CreateApp ( SynExpr.CreateLongIdent (SynLongIdent.Create [ "instructions" ; "Add" ]), SynExpr.CreateParen ( SynExpr.CreateApp ( SynExpr.CreateLongIdent analysis.AssociatedProcessInstruction, SynExpr.CreateLongIdent (SynLongIdent.CreateString "x") ) ) ) SynExpr.LetOrUse ( false, false, [ SynBinding.Let ( valData = SynValData.SynValData (None, SynValInfo.Empty, None), pattern = SynPat.Tuple ( false, List.map (fun (t : Ident) -> SynPat.CreateNamed ( Ident.Create (t.idText + "Stack") |> Ident.lowerFirstLetter ) ) allArtificialTyparNames, List.replicate (allArtificialTyparNames.Length - 1) range0, range0 ), expr = SynExpr.CreateApp ( SynExpr.CreateApp ( SynExpr.CreateIdentString "loop", SynExpr.CreateIdentString "cata" ), SynExpr.CreateIdentString "instructions" ) ) ], // TODO: add the "all other stacks are empty" sanity checks SynExpr.CreateApp ( SynExpr.CreateLongIdent (SynLongIdent.Create [ "Seq" ; "exactlyOne" ]), SynExpr.CreateIdent ( Ident.Create (relevantTyparName.idText + "Stack") |> Ident.lowerFirstLetter ) ), range0, { SynExprLetOrUseTrivia.InKeyword = None } ) ], range0, { InKeyword = None } ), relevantTypar ), range0, DebugPointAtBinding.NoneAtLet, SynExpr.synBindingTriviaZero false ) let getName (ty : SynTypeDefn) : LongIdent = match ty with | SynTypeDefn.SynTypeDefn (SynComponentInfo.SynComponentInfo (_, _, _, id, _, _, _, _), _, _, _, _, _) -> id let rec getNameUnion (unionType : SynType) : LongIdent option = match unionType with | SynType.LongIdent (SynLongIdent.SynLongIdent (name, _, _)) -> Some name | SynType.App (ty, _, _, _, _, _, _) -> getNameUnion ty | _ -> None let getNameKey (ty : SynTypeDefn) : string = getName ty |> List.map _.idText |> String.concat "/" // TODO: get rid of this function; it's causing some very spooky coupling at a distance let getNameKeyUnion (unionType : SynType) : string = match unionType with | SynType.LongIdent (SynLongIdent.SynLongIdent (name, _, _)) -> name |> List.map _.idText |> String.concat "/" | _ -> failwithf "unrecognised type: %+A" unionType /// Get the fields of this particular union case, and describe their relation to the /// recursive knot of user-provided DUs for which we are creating a cata. let analyse (availableGenerics : SynTyparDecl list) (allRecordTypes : SynTypeDefn list) (allUnionTypes : SynTypeDefn list) (argIndex : int) (fields : AdtNode list) : CataUnionBasicField list = let availableGenerics = availableGenerics |> List.map (fun (SynTyparDecl.SynTyparDecl (_, SynTypar.SynTypar (ident, _, _))) -> ident) let rec go (prefix : string) (name : Ident option) (ty : SynType) : CataUnionBasicField = let dealWithPrimitive (typeArgs : int list option) (ty : SynType) (typeName : LongIdent) = let key = typeName |> List.map _.idText |> String.concat "/" let isKnownUnion = allUnionTypes |> List.exists (fun unionTy -> getNameKey unionTy = key) let knownRecord = allRecordTypes |> List.tryPick (fun recordTy -> if getNameKey recordTy = key then Some recordTy else None) if isKnownUnion then { FieldName = name ArgName = match name with | Some n -> Ident.lowerFirstLetter n | None -> Ident.Create $"arg%s{prefix}" Description = FieldDescription.Self ty RequiredGenerics = typeArgs } else { FieldName = name ArgName = match name with | Some n -> Ident.lowerFirstLetter n | None -> Ident.Create $"arg%s{prefix}" Description = FieldDescription.NonRecursive ty RequiredGenerics = typeArgs } let rec dealWithType (typeArgs : int list option) (stripped : SynType) = match stripped with | ListType child -> let gone = go (prefix + "_") None child match gone.Description with | FieldDescription.NonRecursive ty -> // Great, no recursion, just treat it as atomic { FieldName = name ArgName = match name with | Some n -> Ident.lowerFirstLetter n | None -> Ident.Create $"arg%s{prefix}" Description = FieldDescription.NonRecursive stripped RequiredGenerics = typeArgs } | FieldDescription.Self ty -> { FieldName = name ArgName = match name with | Some n -> Ident.lowerFirstLetter n | None -> Ident.Create $"arg%s{prefix}" Description = FieldDescription.ListSelf ty RequiredGenerics = typeArgs } | FieldDescription.ListSelf _ -> failwith "Deeply nested lists not currently supported" | PrimitiveType _ -> { FieldName = name ArgName = match name with | Some n -> Ident.lowerFirstLetter n | None -> Ident.Create $"arg%s{prefix}" Description = FieldDescription.NonRecursive stripped RequiredGenerics = typeArgs } | SynType.App (ty, _, childTypeArgs, _, _, _, _) -> match typeArgs with | Some _ -> failwithf "Nested applications of types not supported in %+A" ty | None -> let childTypeArgs = childTypeArgs |> List.map (fun generic -> let generic = match generic with | SynType.Var (SynTypar.SynTypar (name, _, _), _) -> name | _ -> failwithf "Unrecognised generic arg: %+A" generic availableGenerics |> List.findIndex (fun knownGeneric -> knownGeneric.idText = generic.idText) ) dealWithType (Some childTypeArgs) (SynType.stripOptionalParen ty) | SynType.LongIdent (SynLongIdent.SynLongIdent (ty, _, _)) -> dealWithPrimitive typeArgs stripped ty | SynType.Var (typar, _) -> { FieldName = name ArgName = match name with | Some n -> Ident.lowerFirstLetter n | None -> Ident.Create $"arg%s{prefix}" Description = FieldDescription.NonRecursive ty RequiredGenerics = typeArgs } | _ -> failwithf "Unrecognised type: %+A" stripped let stripped = SynType.stripOptionalParen ty dealWithType None stripped fields |> List.mapi (fun i x -> go $"%i{argIndex}_%i{i}" x.Name x.Type) /// Returns whether this type recursively contains a Self, and the type which /// the Instruction case is going to have to store to obtain this field. /// (For example, a `self list` will need to store an int, namely the number /// of recursive results to pull from the stack just before we feed them /// into the cata.) let rec toInstructionCase (field : FieldDescription) : bool * SynType option = match field with | FieldDescription.NonRecursive ty -> false, Some ty | FieldDescription.Self ty -> true, None | FieldDescription.ListSelf ty -> // store the length of the list true, Some (SynType.Int ()) type InstructionCase = { Name : Ident Fields : AdtNode list } let getInstructionCaseName (thisUnionType : SynTypeDefn) (caseName : SynIdent) : Ident = match caseName with | SynIdent.SynIdent (ident, _) -> (List.last (getName thisUnionType)).idText + "_" + ident.idText |> Ident.Create /// Given the input `| Pair of Expr * Expr * PairOpKind`, /// strips out any members which contain recursive calls. /// Stores a list as an int which is "the length of the list". /// TODO: support other compound types. let getRecursiveInstruction (case : RenderedUnionCase) : InstructionCase option = let hasRecursion, cases = ((false, []), case.FlattenedFields) ||> List.fold (fun (hasRecursion, cases) field -> let newHasRecursion, case = toInstructionCase field.Description let cases = match case with | None -> cases | Some case -> (field.FieldName, case) :: cases hasRecursion || newHasRecursion, cases ) if not hasRecursion then // No recursive instructions required; we'll be feeding the data // straight into the cata without any stack manipulation. None else let fields = cases |> List.rev |> List.map (fun (name, ty) -> { Name = name |> Option.map Ident.lowerFirstLetter Type = ty // TODO this is definitely wrong GenericsOfParent = [] } ) { Name = case.InstructionName Fields = fields } |> Some /// The instruction to "process an Expr"; the loop will have to descend /// into this Expr and break it down to discover what recursive calls /// and calls to the cata this will imply making. let baseCases (unions : UnionAnalysis list) : InstructionCase list = unions |> List.map (fun union -> { Name = match union.AssociatedProcessInstruction with | SynLongIdent.SynLongIdent (i, _, _) -> List.last i Fields = { Name = None Type = let name = SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent union.ParentTypeName) match union.Typars with | [] -> name | typars -> let typars = typars |> List.map (fun (SynTyparDecl (_, typar)) -> SynType.Var (typar, range0)) SynType.App ( name, Some range0, typars, List.replicate (typars.Length - 1) range0, Some range0, false, range0 ) GenericsOfParent = union.Typars } |> List.singleton } ) /// The instruction to "pull recursive results from the stack, and then call into the cata". let recursiveCases (allUnionTypes : UnionAnalysis list) : InstructionCase list = allUnionTypes |> List.collect (fun union -> union.UnionCases |> List.choose getRecursiveInstruction) /// Build the DU which defines the states our state machine can be in. let createInstructionType (analysis : UnionAnalysis list) : SynTypeDefn = let parentGenerics = analysis |> List.collect _.Typars |> List.map (fun (SynTyparDecl.SynTyparDecl (_, SynTypar.SynTypar (ident, _, _))) -> ident.idText) |> List.distinct |> List.map (fun i -> SynTyparDecl.SynTyparDecl ([], SynTypar.SynTypar (Ident.Create i, TyparStaticReq.None, false)) ) // One union case for each union type, and then // a union case for each union case which contains a recursive reference. let casesFromProcess : SynUnionCase list = baseCases analysis |> List.map (fun unionCase -> let fields = unionCase.Fields |> List.map (fun field -> // TODO: adjust type parameters SynField.Create field.Type ) SynUnionCase.Create (unionCase.Name, fields) ) let casesFromCases = recursiveCases analysis |> List.map (fun case -> SynUnionCase.Create (case.Name, case.Fields |> List.map (fun field -> SynField.Create field.Type)) ) let cases = casesFromProcess @ casesFromCases let typars = let count = analysis |> List.map (fun x -> List.length x.Typars) |> List.max if analysis |> List.forall (fun x -> x.Typars.IsEmpty) then None else let typars = analysis |> List.collect _.Typars |> List.map (fun (SynTyparDecl.SynTyparDecl (_, SynTypar.SynTypar (ident, _, _))) -> ident.idText) |> List.distinct |> List.map (fun i -> SynTyparDecl.SynTyparDecl ([], SynTypar.SynTypar (Ident.Create i, TyparStaticReq.None, false)) ) Some (SynTyparDecls.PostfixList (typars, [], range0)) SynTypeDefn.SynTypeDefn ( SynComponentInfo.SynComponentInfo ( [ SynAttributeList.Create [ SynAttribute.RequireQualifiedAccess () ] ], typars, [], [ Ident.Create "Instruction" ], PreXmlDoc.Empty, false, Some (SynAccess.Private range0), range0 ), SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (None, cases, range0), range0), [], None, range0, { LeadingKeyword = SynTypeDefnLeadingKeyword.Type range0 EqualsRange = Some range0 WithKeyword = None } ) /// Build the cata interfaces, which a user will instantiate to specify a particular /// catamorphism. This produces one interface per input union type. /// /// Say that CreateCatamorphism-tagged types form the set T. /// Assert that each U in T is a discriminated union. /// For each type U in T, assign a generic parameter 'ret. /// For each U: /// * Define the type [U]Cata, generic on all the parameters {'ret : U in T}. /// * For each DU case C in type U: /// * create a method in [U]Cata, whose return value is 'ret and whose args are the fields of the case C /// * any occurrence in a field of an input value of type equal to any element of T (say type V) is replaced by 'ret let createCataStructure (analyses : UnionAnalysis list) : SynTypeDefn list = // Obtain the generic parameter for a UnionAnalysis by dotting into this // with `case.GenericName.idText`. // Remember that this is essentially unordered! let generics = analyses |> List.map (fun case -> case.GenericName.idText, SynTypar.SynTypar (case.GenericName, TyparStaticReq.None, false) ) |> Map.ofList let orderedGenerics = analyses |> List.map (fun case -> SynTyparDecl.SynTyparDecl ([], generics.[case.GenericName.idText])) analyses |> List.map (fun analysis -> let componentInfo = SynComponentInfo.SynComponentInfo ( [], Some (SynTyparDecls.PostfixList (analysis.Typars @ orderedGenerics, [], range0)), [], [ analysis.CataTypeName ], // TODO: better docstring PreXmlDoc.Create " Description of how to combine cases during a fold", false, None, range0 ) let slots = let ourGenericName = generics.[analysis.GenericName.idText] let flags = { SynMemberFlags.IsInstance = true SynMemberFlags.IsDispatchSlot = true SynMemberFlags.IsOverrideOrExplicitImpl = false SynMemberFlags.IsFinal = false SynMemberFlags.GetterOrSetterIsCompilerGenerated = false SynMemberFlags.MemberKind = SynMemberKind.Member } analysis.UnionCases |> List.map (fun case -> let arity = SynValInfo.SynValInfo ( case.Fields |> List.map (fun field -> [ SynArgInfo.Empty ]), SynArgInfo.Empty ) let ty = (SynType.Var (ourGenericName, range0), List.rev case.FlattenedFields) ||> List.fold (fun acc field -> let place : SynType = match field.Description with | FieldDescription.Self ty -> SynType.Var (generics.[getNameKeyUnion ty], range0) | FieldDescription.ListSelf ty -> SynType.CreateApp ( SynType.CreateLongIdent "list", [ SynType.Var (generics.[getNameKeyUnion ty], range0) ], true ) | FieldDescription.NonRecursive ty -> match field.RequiredGenerics with | None -> ty | Some generics -> let generics = generics |> List.map (fun i -> let (SynTyparDecl.SynTyparDecl (_, typar)) = analysis.Typars.[i] SynType.Var (typar, range0) ) SynType.App ( ty, Some range0, generics, List.replicate (generics.Length - 1) range0, Some range0, false, range0 ) SynType.Fun ( SynType.SignatureParameter ( [], false, field.FieldName |> Option.map Ident.lowerFirstLetter, place, range0 ), acc, range0, { ArrowRange = range0 } ) ) let slot = SynValSig.SynValSig ( [], case.CataMethodIdent, SynValTyparDecls.SynValTyparDecls (None, true), ty, arity, false, false, PreXmlDoc.Create $" How to operate on the %s{List.last(case.Match.LongIdent).idText} case", None, None, range0, { EqualsRange = None WithKeyword = None InlineKeyword = None LeadingKeyword = SynLeadingKeyword.Abstract range0 } ) SynMemberDefn.AbstractSlot ( slot, flags, range0, { GetSetKeywords = None } ) ) let repr = SynTypeDefnRepr.ObjectModel (SynTypeDefnKind.Unspecified, slots, range0) SynTypeDefn.SynTypeDefn ( componentInfo, repr, [], None, range0, { LeadingKeyword = SynTypeDefnLeadingKeyword.Type range0 EqualsRange = Some range0 WithKeyword = None } ) ) /// Build a record which contains one of every cata type. /// That is, define a type Cata<{'ret for U in T}> /// with one member for each U, namely of type [U]Cata<{'ret for U in T}>. let createCataRecord (cataName : Ident) (doc : PreXmlDoc) (analysis : UnionAnalysis list) : SynTypeDefn = // An artificial generic for each union type let generics = analysis |> List.map (fun analysis -> SynTypar.SynTypar (analysis.GenericName, TyparStaticReq.None, false)) // A field for each cata let fields = analysis |> List.map (fun analysis -> let nameForDoc = List.last(analysis.ParentTypeName).idText let doc = PreXmlDoc.Create $" How to perform a fold (catamorphism) over the type %s{nameForDoc}" let artificialGenerics = generics |> List.map (fun v -> SynType.Var (v, range0)) let userInputGenerics = analysis.Typars |> List.map (fun (SynTyparDecl.SynTyparDecl (_, SynTypar.SynTypar (ident, _, _))) -> ident.idText) |> List.distinct |> List.map (fun i -> SynType.Var (SynTypar.SynTypar (Ident.Create i, TyparStaticReq.None, false), range0) ) let ty = SynType.App ( SynType.LongIdent (SynLongIdent.CreateFromLongIdent [ analysis.CataTypeName ]), Some range0, userInputGenerics @ artificialGenerics, List.replicate (generics.Length - 1) range0, Some range0, false, range0 ) SynField.SynField ( [], false, Some (List.last analysis.ParentTypeName), ty, false, doc, None, range0, { LeadingKeyword = None } ) ) // A "real" generic for each generic in the user-provided type let genericsFromUserInput = analysis |> List.collect _.Typars |> List.map (fun (SynTyparDecl.SynTyparDecl (_, SynTypar.SynTypar (ident, _, _))) -> ident.idText) |> List.distinct |> List.map (fun i -> SynTyparDecl.SynTyparDecl ([], SynTypar.SynTypar (Ident.Create i, TyparStaticReq.None, false)) ) let genericsFromCata = generics |> List.map (fun ty -> SynTyparDecl.SynTyparDecl ([], ty)) let componentInfo = SynComponentInfo.SynComponentInfo ( [], Some (SynTyparDecls.PostfixList (genericsFromUserInput @ genericsFromCata, [], range0)), [], [ cataName ], doc, false, None, range0 ) SynTypeDefn.SynTypeDefn ( componentInfo, SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (None, fields, range0), range0), [], None, range0, { LeadingKeyword = SynTypeDefnLeadingKeyword.Type range0 WithKeyword = None EqualsRange = Some range0 } ) let makeUnionAnalyses (cataVarName : Ident) (allRecordTypes : SynTypeDefn list) (allUnionTypes : SynTypeDefn list) : UnionAnalysis list = let recordTypes = allRecordTypes |> List.map (fun ty -> List.last(getName ty).idText, AstHelper.getRecordFields ty) |> Map.ofList allUnionTypes |> List.map (fun unionType -> let cases, typars, access = AstHelper.getUnionCases unionType let cases = cases |> List.map (fun prod -> let fields = prod.Fields |> List.indexed |> List.collect (fun (i, node) -> match getNameUnion node.Type with | None -> analyse typars allRecordTypes allUnionTypes i [ node ] |> List.map CataUnionField.Basic | Some name -> match Map.tryFind (List.last(name).idText) recordTypes with | None -> analyse typars allRecordTypes allUnionTypes i [ node ] |> List.map CataUnionField.Basic | Some fields -> List.zip fields (analyse typars allRecordTypes allUnionTypes i fields) |> List.map (fun (field, analysis) -> Option.get field.Name, analysis) |> CataUnionField.Record |> List.singleton ) prod.Name, fields ) let unionTypeName = getName unionType { Typars = typars Accessibility = access StackName = List.last(getName unionType).idText + "Stack" |> Ident.Create |> Ident.lowerFirstLetter UnionCases = cases |> List.map (fun (name, analysis) -> let instructionName = getInstructionCaseName unionType name let unionCaseName = match name with | SynIdent (ident, _) -> ident { InstructionName = instructionName Fields = analysis CaseName = name CataMethodName = SynLongIdent.CreateFromLongIdent (cataVarName :: unionTypeName @ [ unionCaseName ]) CataMethodIdent = SynIdent.SynIdent (unionCaseName, None) AssociatedInstruction = SynLongIdent.CreateFromLongIdent [ Ident.Create "Instruction" ; instructionName ] Match = SynLongIdent.CreateFromLongIdent (unionTypeName @ [ unionCaseName ]) } ) AssociatedProcessInstruction = SynLongIdent.Create [ "Instruction" // such jank! "Process__" + List.last(unionTypeName).idText ] ParentTypeName = getName unionType GenericName = getName unionType |> List.map _.idText |> String.concat "" |> Ident.Create CataTypeName = List.last(getName unionType).idText + "CataCase" |> Ident.Create } ) let callCataAndPushResult (resultStackName : Ident) (unionCase : RenderedUnionCase) : SynExpr = (SynExpr.CreateLongIdent unionCase.CataMethodName, unionCase.FlattenedFields) ||> List.fold (fun body caseDesc -> SynExpr.CreateApp (body, SynExpr.CreateIdent caseDesc.ArgName)) |> SynExpr.pipeThroughFunction ( SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent (resultStackName :: [ Ident.Create "Add" ])) ) /// Create the state-machine matches which deal with receiving the instruction /// to "process one of the user-specified DU cases, pushing recursion instructions onto /// the instruction stack". /// It very rarely involves invoking the cata; that happens only if there's no recursion. let createBaseMatchClause (analysis : UnionAnalysis) : SynMatchClause = let matchCases = analysis.UnionCases |> List.map (fun unionCase -> let name = match unionCase.CaseName with | SynIdent (ident, _) -> ident let _, nonRecursiveArgs, selfArgs, listSelfArgs = ((0, [], [], []), unionCase.FlattenedFields) ||> List.fold (fun (i, nonRec, self, listSelf) caseDesc -> match caseDesc.Description with | FieldDescription.NonRecursive ty -> i + 1, (i, caseDesc.ArgName, ty) :: nonRec, self, listSelf | FieldDescription.Self ty -> i + 1, nonRec, (i, caseDesc.ArgName, ty) :: self, listSelf | FieldDescription.ListSelf ty -> i + 1, nonRec, self, (i, caseDesc.ArgName, ty) :: listSelf ) let matchBody = if nonRecursiveArgs.Length = unionCase.FlattenedFields.Length then // directly call the cata callCataAndPushResult analysis.StackName unionCase else // There's a recursive type in here, so we'll have to make some calls // and then come back. // The instruction to process us again once our inputs are ready: let reprocessCommand = SynExpr.CreateApp ( SynExpr.CreateLongIdent (SynLongIdent.Create [ "instructions" ; "Add" ]), if selfArgs.Length = unionCase.FlattenedFields.Length then SynExpr.CreateLongIdent unionCase.AssociatedInstruction else // We need to tell ourselves each non-rec arg, and the length of each input list. SynExpr.CreateApp ( SynExpr.CreateLongIdent unionCase.AssociatedInstruction, SynExpr.CreateParenedTuple ( listSelfArgs |> List.map (fun (i, argName, _) -> i, SynExpr.CreateParen ( SynExpr.CreateApp ( SynExpr.CreateLongIdent ( SynLongIdent.Create [ "List" ; "length" ] ), SynExpr.CreateIdent argName ) ) ) |> List.append ( nonRecursiveArgs |> List.map (fun (i, arg, _) -> i, SynExpr.CreateIdent arg) ) |> List.sortBy fst |> List.map snd ) ) |> SynExpr.CreateParen ) [ yield reprocessCommand for i, caseDesc in Seq.indexed unionCase.FlattenedFields do match caseDesc.Description with | NonRecursive synType -> // Nothing to do, because we're not calling the cata yet () | ListSelf synType -> // Tell our future self to process the list elements first. yield SynExpr.ForEach ( DebugPointAtFor.Yes range0, DebugPointAtInOrTo.Yes range0, SeqExprOnly.SeqExprOnly false, true, SynPat.CreateNamed (SynIdent.SynIdent (Ident.Create "elt", None)), SynExpr.CreateIdent caseDesc.ArgName, SynExpr.CreateApp ( SynExpr.CreateLongIdent (SynLongIdent.Create [ "instructions" ; "Add" ]), SynExpr.CreateParen ( SynExpr.CreateApp ( SynExpr.CreateLongIdent analysis.AssociatedProcessInstruction, SynExpr.CreateIdentString "elt" ) ) ), range0 ) | Self synType -> // And push the instruction to process each recursive call // onto the stack. yield SynExpr.CreateApp ( SynExpr.CreateLongIdent (SynLongIdent.Create [ "instructions" ; "Add" ]), SynExpr.CreateParen ( SynExpr.CreateApp ( SynExpr.CreateLongIdent ( // TODO: use an AssociatedProcessInstruction instead SynLongIdent.Create [ "Instruction" // TODO wonky domain "Process" + "__" + List.last(getNameUnion(synType).Value).idText ] ), SynExpr.CreateIdent caseDesc.ArgName ) ) ) ] |> SynExpr.CreateSequential let matchLhs = if unionCase.Fields.Length > 0 then SynPat.CreateParen ( SynPat.Tuple ( false, unionCase.Fields |> List.mapi (fun i case -> match case with | CataUnionField.Basic case -> SynPat.CreateNamed (Ident.lowerFirstLetter case.ArgName) | CataUnionField.Record fields -> let fields = fields |> List.map (fun (name, field) -> ([], name), range0, SynPat.CreateNamed (Ident.lowerFirstLetter name) ) SynPat.Record (fields, range0) ), List.replicate (unionCase.Fields.Length - 1) range0, range0 ) ) |> List.singleton else [] SynMatchClause.SynMatchClause ( SynPat.CreateLongIdent (unionCase.Match, matchLhs), None, matchBody, range0, DebugPointAtTarget.Yes, { ArrowRange = Some range0 BarRange = Some range0 } ) ) let bodyMatch = SynExpr.CreateMatch (SynExpr.CreateIdentString "x", matchCases) SynMatchClause.SynMatchClause ( SynPat.LongIdent ( analysis.AssociatedProcessInstruction, None, None, SynArgPats.create [ Ident.Create "x" ], None, range0 ), None, bodyMatch, range0, DebugPointAtTarget.Yes, { ArrowRange = Some range0 BarRange = Some range0 } ) /// Create the state-machine matches which deal with receiving the instruction /// to "pull recursive results from the result stacks, and invoke the cata". let createRecursiveMatchClauses (analyses : UnionAnalysis list) : SynMatchClause list = let inputStacks = analyses |> Seq.map (fun a -> // TODO this is jank (List.last a.ParentTypeName).idText, a.StackName ) |> Map.ofSeq analyses |> List.collect (fun analysis -> analysis.UnionCases |> List.choose (fun unionCase -> // We already know there is a recursive reference somewhere // in `analysis`. if unionCase.FlattenedFields |> List.exists (fun case -> match case.Description with | NonRecursive _ -> false | _ -> true ) then Some unionCase else None ) |> List.map (fun unionCase -> let lhsNames = unionCase.FlattenedFields |> Seq.mapi (fun i x -> (i, x)) |> Seq.choose (fun (i, case) -> match case.Description with | FieldDescription.NonRecursive _ -> case.ArgName |> Some | FieldDescription.ListSelf _ -> case.ArgName |> Some | FieldDescription.Self _ -> None ) |> Seq.toList let lhs = SynArgPats.create lhsNames let pat = SynPat.LongIdent (unionCase.AssociatedInstruction, None, None, lhs, None, range0) let populateArgs = unionCase.FlattenedFields |> List.choose (fun field -> match field.Description with | NonRecursive _ -> // this was passed in already in the match None | Self synType -> // pull the one entry from the stack // let {field.ArgName} = {appropriateStack}.[SynExpr.minusN {appropriateStack.Count} 1] // {appropriateStack}.RemoveRange (SynExpr.minusN {appropriateStack.Count} 1) // TODO: this is jank let stackName = inputStacks.[List.last(getNameUnion(synType).Value).idText] SynExpr.LetOrUse ( false, false, [ SynBinding.SynBinding ( None, SynBindingKind.Normal, false, false, [], PreXmlDoc.Empty, SynValData.SynValData (None, SynValInfo.Empty, None), SynPat.CreateNamed field.ArgName, None, SynExpr.DotIndexedGet ( SynExpr.CreateIdent stackName, SynExpr.minusN (SynLongIdent.CreateFromLongIdent [ stackName ; Ident.Create "Count" ]) 1, range0, range0 ), range0, DebugPointAtBinding.Yes range0, SynExpr.synBindingTriviaZero false ) ], SynExpr.CreateApp ( SynExpr.CreateLongIdent ( SynLongIdent.CreateFromLongIdent [ stackName ; Ident.Create "RemoveAt" ] ), SynExpr.CreateParen ( SynExpr.minusN (SynLongIdent.CreateFromLongIdent [ stackName ; Ident.Create "Count" ]) 1 ) ), range0, { InKeyword = None } ) |> Some | ListSelf synType -> // TODO: also jank let stackName = inputStacks.[List.last(getNameUnion(synType).Value).idText] let vals = SynBinding.SynBinding ( None, SynBindingKind.Normal, false, false, [], PreXmlDoc.Empty, SynValData.SynValData (None, SynValInfo.Empty, None), SynPat.CreateNamed field.ArgName, None, SynExpr.pipeThroughFunction (SynExpr.CreateLongIdent (SynLongIdent.Create [ "Seq" ; "toList" ])) (SynExpr.CreateApp ( SynExpr.CreateIdentString "seq", SynExpr.ComputationExpr ( false, SynExpr.For ( DebugPointAtFor.Yes range0, DebugPointAtInOrTo.Yes range0, Ident.Create "i", Some range0, SynExpr.minusN (SynLongIdent.CreateFromLongIdent [ stackName ; Ident.Create "Count" ]) 1, false, SynExpr.minus (SynLongIdent.CreateFromLongIdent [ stackName ; Ident.Create "Count" ]) (SynExpr.CreateIdent field.ArgName), SynExpr.YieldOrReturn ( (true, false), SynExpr.DotIndexedGet ( SynExpr.CreateIdent stackName, SynExpr.CreateIdentString "i", range0, range0 ), range0 ), range0 ), range0 ) )), range0, DebugPointAtBinding.Yes range0, SynExpr.synBindingTriviaZero false ) let shadowedIdent = Ident.Create (field.ArgName.idText + "_len") SynExpr.LetOrUse ( false, false, [ SynBinding.SynBinding ( None, SynBindingKind.Normal, false, false, [], PreXmlDoc.Empty, SynValData.SynValData (None, SynValInfo.Empty, None), SynPat.CreateNamed shadowedIdent, None, SynExpr.CreateIdent field.ArgName, range0, DebugPointAtBinding.Yes range0, SynExpr.synBindingTriviaZero false ) ], SynExpr.CreateSequential [ SynExpr.LetOrUse ( false, false, [ vals ], SynExpr.CreateApp ( SynExpr.CreateLongIdent ( SynLongIdent.CreateFromLongIdent [ stackName ; Ident.Create "RemoveRange" ] ), SynExpr.CreateParenedTuple [ SynExpr.minus (SynLongIdent.CreateFromLongIdent [ stackName ; Ident.Create "Count" ]) (SynExpr.CreateIdent shadowedIdent) SynExpr.CreateIdent shadowedIdent ] ), range0, { InKeyword = None } ) ], range0, { InKeyword = None } ) |> Some ) SynMatchClause.SynMatchClause ( pat, None, SynExpr.CreateSequential (populateArgs @ [ callCataAndPushResult analysis.StackName unionCase ]), range0, DebugPointAtTarget.Yes, { ArrowRange = Some range0 BarRange = Some range0 } ) ) ) let createLoopFunction (cataTypeName : Ident) (cataVarName : Ident) (analysis : UnionAnalysis list) : SynBinding = let valData = SynValData.SynValData ( None, SynValInfo.SynValInfo ( [ [ SynArgInfo.SynArgInfo ([], false, Some cataVarName) ] [ SynArgInfo.SynArgInfo ([], false, Some (Ident.Create "instructions")) ] ], SynArgInfo.Empty ), None ) let userSuppliedGenerics = analysis |> List.collect _.Typars |> List.map (fun (SynTyparDecl.SynTyparDecl (_, SynTypar.SynTypar (ident, _, _))) -> ident.idText) |> List.distinct |> List.map (fun i -> SynTypar.SynTypar (Ident.Create i, TyparStaticReq.None, false)) let instructionsArrType = if not userSuppliedGenerics.IsEmpty then SynType.App ( SynType.CreateLongIdent "Instruction", Some range0, userSuppliedGenerics |> List.map (fun x -> SynType.Var (x, range0)), List.replicate (userSuppliedGenerics.Length - 1) range0, Some range0, false, range0 ) else SynType.CreateLongIdent "Instruction" let cataGenerics = [ for generic in userSuppliedGenerics do yield SynType.Var (generic, range0) for case in analysis do yield SynType.Var (SynTypar.SynTypar (case.GenericName, TyparStaticReq.None, false), range0) ] let headPat = SynPat.LongIdent ( SynLongIdent.CreateString "loop", None, None, SynArgPats.Pats [ SynPat.CreateParen ( SynPat.CreateTyped ( SynPat.CreateNamed cataVarName, SynType.App ( SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ cataTypeName ]), Some range0, cataGenerics, List.replicate (cataGenerics.Length - 1) range0, Some range0, false, range0 ) ) ) SynPat.CreateParen ( SynPat.CreateTyped ( SynPat.CreateNamed (Ident.Create "instructions"), SynType.App ( SynType.CreateLongIdent "ResizeArray", Some range0, [ instructionsArrType ], [], Some range0, false, range0 ) ) ) ], Some (SynAccess.Private range0), range0 ) let baseMatchClauses = analysis |> List.map createBaseMatchClause let recMatchClauses = createRecursiveMatchClauses analysis let matchStatement = SynExpr.CreateMatch (SynExpr.CreateIdentString "currentInstruction", baseMatchClauses @ recMatchClauses) let body = SynExpr.CreateSequential [ SynExpr.CreateApp ( SynExpr.CreateLongIdent (SynLongIdent.Create [ "instructions" ; "RemoveAt" ]), SynExpr.CreateParen (SynExpr.minusN (SynLongIdent.Create [ "instructions" ; "Count" ]) 1) ) matchStatement ] let body = SynExpr.LetOrUse ( false, false, [ SynBinding.SynBinding ( None, SynBindingKind.Normal, false, false, [], PreXmlDoc.Empty, SynValData.SynValData (None, SynValInfo.SynValInfo ([], SynArgInfo.Empty), None), SynPat.CreateNamed (Ident.Create "currentInstruction"), None, SynExpr.DotIndexedGet ( SynExpr.CreateIdentString "instructions", SynExpr.minusN (SynLongIdent.Create [ "instructions" ; "Count" ]) 1, range0, range0 ), range0, DebugPointAtBinding.Yes range0, SynExpr.synBindingTriviaZero false ) ], body, range0, { InKeyword = None } ) let body = SynExpr.CreateSequential [ SynExpr.While ( DebugPointAtWhile.Yes range0, SynExpr.greaterThan (SynExpr.CreateConst (SynConst.Int32 0)) (SynExpr.CreateLongIdent (SynLongIdent.Create [ "instructions" ; "Count" ])), body, range0 ) SynExpr.CreateTuple ( analysis |> List.map (fun unionAnalysis -> [ unionAnalysis.StackName ] |> SynLongIdent.CreateFromLongIdent |> SynExpr.CreateLongIdent ) ) ] let body = (body, analysis) ||> List.fold (fun body unionCase -> SynExpr.LetOrUse ( false, false, [ SynBinding.SynBinding ( None, SynBindingKind.Normal, false, false, [], PreXmlDoc.Empty, SynValData.SynValData (None, SynValInfo.Empty, None), SynPat.Named (SynIdent.SynIdent (unionCase.StackName, None), false, None, range0), None, SynExpr.CreateApp ( SynExpr.TypeApp ( SynExpr.CreateIdent (Ident.Create "ResizeArray"), range0, [ SynType.Var ( SynTypar.SynTypar (unionCase.GenericName, TyparStaticReq.None, false), range0 ) ], [], Some range0, range0, range0 ), SynExpr.CreateConst SynConst.Unit ), range0, DebugPointAtBinding.Yes range0, SynExpr.synBindingTriviaZero false ) ], body, range0, { SynExprLetOrUseTrivia.InKeyword = None } ) ) SynBinding.SynBinding ( Some (SynAccess.Private range0), SynBindingKind.Normal, false, false, [], PreXmlDoc.Empty, valData, headPat, None, body, range0, DebugPointAtBinding.NoneAtLet, trivia = SynExpr.synBindingTriviaZero false ) let createModule (opens : SynOpenDeclTarget list) (ns : LongIdent) (cataName : SynExpr, taggedType : SynTypeDefn) (allUnionTypes : SynTypeDefn list) (allRecordTypes : SynTypeDefn list) : SynModuleOrNamespace = let cataName = match cataName |> SynExpr.stripOptionalParen with | SynExpr.Const (SynConst.String (name, _, _), _) -> Ident.Create name | _ -> failwith "Cata name in attribute must be literally a string, sorry" let parentName = List.last (getName taggedType) |> _.idText let moduleName : LongIdent = parentName + "Cata" |> Ident.Create |> List.singleton let attribs = [ SynAttributeList.Create (SynAttribute.RequireQualifiedAccess ()) ] let modInfo = SynComponentInfo.Create ( moduleName, attributes = attribs, xmldoc = PreXmlDoc.Create $" Methods to perform a catamorphism over the type %s{parentName}" ) let cataVarName = Ident.Create "cata" let analysis = makeUnionAnalyses cataVarName allRecordTypes allUnionTypes let allTypars = allUnionTypes |> List.map (fun unionType -> List.last (getName unionType) |> fun x -> x.idText + "Ret" |> Ident.Create |> fun x -> SynTypar.SynTypar (x, TyparStaticReq.None, false) |> fun x -> SynType.Var (x, range0) ) let userProvidedGenerics = analysis |> List.collect _.Typars |> List.map (fun (SynTyparDecl (_, SynTypar.SynTypar (ident, _, _))) -> ident.idText) |> List.distinct |> List.map (fun x -> SynTyparDecl.SynTyparDecl ([], SynTypar.SynTypar (Ident.Create x, TyparStaticReq.None, false)) ) let runFunctions = List.zip analysis allTypars |> List.map (fun (analysis, relevantTypar) -> createRunFunction cataName userProvidedGenerics allTypars relevantTypar analysis ) let cataStructures = createCataStructure analysis |> List.map (fun repr -> SynModuleDecl.Types ([ repr ], range0)) let loopFunction = createLoopFunction cataName cataVarName analysis let recordDoc = PreXmlDoc.Create $" Specifies how to perform a fold (catamorphism) over the type %s{parentName} and its friends." let cataRecord = SynModuleDecl.Types ([ createCataRecord cataName recordDoc analysis ], range0) SynModuleOrNamespace.CreateNamespace ( ns, decls = [ for openStatement in opens do yield SynModuleDecl.CreateOpen openStatement yield! cataStructures yield cataRecord yield SynModuleDecl.CreateNestedModule ( modInfo, [ SynModuleDecl.Types ([ createInstructionType analysis ], range0) SynModuleDecl.CreateLet (loopFunction :: runFunctions) ] ) ] ) let generate (context : GeneratorContext) : Output = let ast, _ = Ast.fromFilename context.InputFilename |> Async.RunSynchronously |> Array.head let types = Ast.extractTypeDefn ast let opens = AstHelper.extractOpens ast let namespaceAndTypes = types |> List.choose (fun (ns, types) -> let typeWithAttr = types |> List.tryPick (fun ty -> match Ast.getAttribute ty with | None -> None | Some attr -> Some (attr.ArgExpr, ty) ) match typeWithAttr with | Some taggedType -> let unions, records, others = (([], [], []), types) ||> List.fold (fun (unions, records, others) (SynTypeDefn.SynTypeDefn (_, repr, _, _, _, _) as ty) -> match repr with | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union _, _) -> ty :: unions, records, others | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record _, _) -> unions, ty :: records, others | _ -> unions, records, ty :: others ) if not others.IsEmpty then failwith $"Error: all types recursively defined together with a CreateCatamorphism type must be discriminated unions or records. %+A{others}" Some (ns, taggedType, unions, records) | _ -> None ) let modules = namespaceAndTypes |> List.map (fun (ns, taggedType, unions, records) -> createModule opens ns taggedType unions records) Output.Ast modules /// Myriad generator that provides a catamorphism for an algebraic data type. [] type CreateCatamorphismGenerator () = interface IMyriadGenerator with member _.ValidInputExtensions = [ ".fs" ] member _.Generate (context : GeneratorContext) = CataGenerator.generate context