diff --git a/ConsumePlugin/GeneratedCatamorphism.fs b/ConsumePlugin/GeneratedCatamorphism.fs index 9f5955a..86ac217 100644 --- a/ConsumePlugin/GeneratedCatamorphism.fs +++ b/ConsumePlugin/GeneratedCatamorphism.fs @@ -21,7 +21,7 @@ type TreeBuilderCataCase<'a, 'TreeBuilder, 'Tree> = /// Description of how to combine cases during a fold type TreeCataCase<'a, 'TreeBuilder, 'Tree> = /// How to operate on the Const case - abstract Const : Const -> 'Tree + abstract Const : Const<'a> -> 'Tree /// How to operate on the Pair case abstract Pair : 'Tree -> 'Tree -> PairOpKind -> 'Tree /// How to operate on the Sequential case diff --git a/WoofWare.Myriad.Plugins/CataGenerator.fs b/WoofWare.Myriad.Plugins/CataGenerator.fs index b8f9523..3b54076 100644 --- a/WoofWare.Myriad.Plugins/CataGenerator.fs +++ b/WoofWare.Myriad.Plugins/CataGenerator.fs @@ -35,8 +35,10 @@ module internal CataGenerator = /// The relationship this field has with the parent type (or the /// recursive knot of parent types) Description : FieldDescription - /// Any generic parameters this field consumes - RequiredGenerics : SynType list option + /// 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 @@ -303,14 +305,19 @@ module internal CataGenerator = /// 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 : SynType list option) (ty : SynType) (typeName : LongIdent) = + let dealWithPrimitive (typeArgs : int list option) (ty : SynType) (typeName : LongIdent) = let key = typeName |> List.map _.idText |> String.concat "/" let isKnownUnion = @@ -341,7 +348,7 @@ module internal CataGenerator = RequiredGenerics = typeArgs } - let rec dealWithType (typeArgs : SynType list option) (stripped : SynType) = + let rec dealWithType (typeArgs : int list option) (stripped : SynType) = match stripped with | ListType child -> let gone = go (prefix + "_") None child @@ -382,7 +389,20 @@ module internal CataGenerator = | SynType.App (ty, _, childTypeArgs, _, _, _, _) -> match typeArgs with | Some _ -> failwithf "Nested applications of types not supported in %+A" ty - | None -> dealWithType (Some childTypeArgs) (SynType.stripOptionalParen 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, _) -> { @@ -633,7 +653,26 @@ module internal CataGenerator = [ SynType.Var (generics.[getNameKeyUnion ty], range0) ], true ) - | FieldDescription.NonRecursive ty -> ty + | 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 ( @@ -806,21 +845,18 @@ module internal CataGenerator = prod.Fields |> List.indexed |> List.collect (fun (i, node) -> - let availableGenerics = - match node.Type with - | SynType.App (_, _, vars, _, _, _, _) -> vars - | _ -> [] - match getNameUnion node.Type with | None -> - analyse allRecordTypes allUnionTypes i [ node ] |> List.map CataUnionField.Basic + analyse typars allRecordTypes allUnionTypes i [ node ] + |> List.map CataUnionField.Basic | Some name -> match Map.tryFind (List.last(name).idText) recordTypes with | None -> - analyse allRecordTypes allUnionTypes i [ node ] |> List.map CataUnionField.Basic + analyse typars allRecordTypes allUnionTypes i [ node ] + |> List.map CataUnionField.Basic | Some fields -> - List.zip fields (analyse allRecordTypes allUnionTypes i fields) + List.zip fields (analyse typars allRecordTypes allUnionTypes i fields) |> List.map (fun (field, analysis) -> Option.get field.Name, analysis) |> CataUnionField.Record |> List.singleton