patrick/WoofWare.Myriad
1
0
Fork 0
mirror of https://github.com/Smaug123/WoofWare.Myriad synced 2025-10-31 00:29:00 +00:00
Code Issues Packages Projects Releases Wiki Activity

First pass at handling generics in cata

Browse Source
This commit is contained in:
Smaug123
2024-02-18 18:33:23 +00:00
parent 3209372b5b
commit dff2431bc8
6 changed files with 344 additions and 212 deletions
Download Patch File Download Diff File Expand all files Collapse all files

57
WoofWare.Myriad.Plugins/AstHelper.fs
View File

@@ -400,26 +400,47 @@ module internal AstHelper =
Accessibility = accessibility
}
let getUnionCases (SynTypeDefn.SynTypeDefn (_, repr, _, _, _, _)) : AdtProduct list =
let getUnionCases
(SynTypeDefn.SynTypeDefn (info, repr, _, _, _, _))
: AdtProduct list * SynTyparDecl list * SynAccess option
=
let typars, access =
match info with
| SynComponentInfo (_, typars, _, _, _, _, access, _) -> typars, access
let typars =
match typars with
| None -> []
| Some (SynTyparDecls.PrefixList (decls, _)) -> decls
| Some (SynTyparDecls.SinglePrefix (l, _)) -> [ l ]
| Some (SynTyparDecls.PostfixList (decls, constraints, _)) ->
if not constraints.IsEmpty then
failwith "Constrained type parameters not currently supported"
decls
match repr with
| SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (_, cases, _), _) ->
cases
|> List.map (fun (SynUnionCase.SynUnionCase (_, ident, kind, _, _, _, _)) ->
match kind with
| SynUnionCaseKind.FullType _ -> failwith "FullType union cases not supported"
| SynUnionCaseKind.Fields fields ->
{
Name = ident
Fields =
fields
|> List.map (fun (SynField.SynField (_, _, id, ty, _, _, _, _, _)) ->
{
Type = ty
Name = id
}
)
}
)
let cases =
cases
|> List.map (fun (SynUnionCase.SynUnionCase (_, ident, kind, _, _, _, _)) ->
match kind with
| SynUnionCaseKind.FullType _ -> failwith "FullType union cases not supported"
| SynUnionCaseKind.Fields fields ->
{
Name = ident
Fields =
fields
|> List.map (fun (SynField.SynField (_, _, id, ty, _, _, _, _, _)) ->
{
Type = ty
Name = id
}
)
}
)
cases, typars, access
| _ -> failwithf "Failed to get union cases for type that was: %+A" repr
let getRecordFields (SynTypeDefn.SynTypeDefn (_, repr, _, _, _, _)) : AdtNode list =

414
WoofWare.Myriad.Plugins/CataGenerator.fs
View File

@@ -35,6 +35,8 @@ 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
}
type CataUnionRecordField = (Ident * CataUnionBasicField) list
@@ -81,6 +83,8 @@ module internal CataGenerator =
/// 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
@@ -112,7 +116,8 @@ module internal CataGenerator =
/// Seq.exactlyOne {relevantTypar}Stack
let createRunFunction
(cataName : Ident)
(allTypars : SynType list)
(userProvidedTypars : SynTyparDecl list)
(allArtificialTypars : SynType list)
(relevantTypar : SynType)
(unionType : SynTypeDefn)
: SynBinding
@@ -121,19 +126,58 @@ module internal CataGenerator =
match unionType with
| SynTypeDefn.SynTypeDefn (SynComponentInfo.SynComponentInfo (longId = id), _, _, _, _, _) -> List.last id
let allTyparNames =
allTypars
let allArtificialTyparNames =
allArtificialTypars
|> List.map (fun ty ->
match ty with
| SynType.Var (SynTypar.SynTypar (ident = ident), _) -> ident
| _ -> failwith "logic error in generator"
)
let userProvidedTypars =
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,
userProvidedTypars,
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,
userProvidedTypars @ allArtificialTypars,
List.replicate (userProvidedTypars.Length + allArtificialTypars.Length - 1) range0,
Some range0,
false,
range0
)
)
SynBinding.SynBinding (
None,
SynBindingKind.Normal,
@@ -151,28 +195,7 @@ module internal CataGenerator =
),
SynPat.CreateLongIdent (
SynLongIdent.CreateString ("run" + relevantTypeName.idText),
[
SynPat.CreateParen (
SynPat.CreateTyped (
SynPat.CreateNamed (Ident.Create "cata"),
SynType.App (
SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ cataName ]),
Some range0,
allTypars,
List.replicate (allTypars.Length - 1) range0,
Some range0,
false,
range0
)
)
)
SynPat.CreateParen (
SynPat.CreateTyped (
SynPat.CreateNamed (Ident.Create "x"),
SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ relevantTypeName ])
)
)
]
[ SynPat.CreateParen (cataObject) ; SynPat.CreateParen inputObject ]
),
Some (SynBindingReturnInfo.Create relevantTypar),
SynExpr.CreateTyped (
@@ -219,8 +242,8 @@ module internal CataGenerator =
Ident.Create (t.idText + "Stack") |> Ident.lowerFirstLetter
)
)
allTyparNames,
List.replicate (allTypars.Length - 1) range0,
allArtificialTyparNames,
List.replicate (allArtificialTyparNames.Length - 1) range0,
range0
),
expr =
@@ -262,9 +285,10 @@ module internal CataGenerator =
match ty with
| SynTypeDefn.SynTypeDefn (SynComponentInfo.SynComponentInfo (_, _, _, id, _, _, _, _), _, _, _, _, _) -> id
let getNameUnion (unionType : SynType) : LongIdent option =
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 =
@@ -286,44 +310,8 @@ module internal CataGenerator =
: CataUnionBasicField list
=
let rec go (prefix : string) (name : Ident option) (ty : SynType) : CataUnionBasicField =
let stripped = SynType.stripOptionalParen ty
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
}
| FieldDescription.Self ty ->
{
FieldName = name
ArgName =
match name with
| Some n -> Ident.lowerFirstLetter n
| None -> Ident.Create $"arg%s{prefix}"
Description = FieldDescription.ListSelf ty
}
| 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
}
| SynType.LongIdent (SynLongIdent.SynLongIdent (ty, _, _)) ->
let key = ty |> List.map _.idText |> String.concat "/"
let dealWithPrimitive (typeArgs : SynType list option) (ty : SynType) (typeName : LongIdent) =
let key = typeName |> List.map _.idText |> String.concat "/"
let isKnownUnion =
allUnionTypes |> List.exists (fun unionTy -> getNameKey unionTy = key)
@@ -339,7 +327,8 @@ module internal CataGenerator =
match name with
| Some n -> Ident.lowerFirstLetter n
| None -> Ident.Create $"arg%s{prefix}"
Description = FieldDescription.Self stripped
Description = FieldDescription.Self ty
RequiredGenerics = typeArgs
}
else
{
@@ -348,10 +337,68 @@ module internal CataGenerator =
match name with
| Some n -> Ident.lowerFirstLetter n
| None -> Ident.Create $"arg%s{prefix}"
Description = FieldDescription.NonRecursive stripped
Description = FieldDescription.NonRecursive ty
RequiredGenerics = typeArgs
}
| _ -> failwithf "Unrecognised type: %+A" stripped
let rec dealWithType (typeArgs : SynType 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 -> 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)
@@ -432,7 +479,26 @@ module internal CataGenerator =
Fields =
{
Name = None
Type = SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent union.ParentTypeName)
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
)
}
|> List.singleton
}
@@ -461,10 +527,20 @@ module internal CataGenerator =
let cases = casesFromProcess @ casesFromCases
let typars =
// TODO: deduplicate names where we have the same generic across multiple DUs
analysis
|> List.collect _.Typars
|> fun x ->
if x.IsEmpty then
None
else
Some (SynTyparDecls.PostfixList (x, [], range0))
SynTypeDefn.SynTypeDefn (
SynComponentInfo.SynComponentInfo (
[ SynAttributeList.Create [ SynAttribute.RequireQualifiedAccess () ] ],
None,
typars,
[],
[ Ident.Create "Instruction" ],
PreXmlDoc.Empty,
@@ -514,7 +590,7 @@ module internal CataGenerator =
let componentInfo =
SynComponentInfo.SynComponentInfo (
[],
Some (SynTyparDecls.PostfixList (orderedGenerics, [], range0)),
Some (SynTyparDecls.PostfixList (analysis.Typars @ orderedGenerics, [], range0)),
[],
[ analysis.CataTypeName ],
// TODO: better docstring
@@ -625,30 +701,32 @@ module internal CataGenerator =
/// Build a record which contains one of every cata type.
/// That is, define a type Cata<{'ret<U> for U in T}>
/// with one member for each U, namely of type [U]Cata<{'ret<U> for U in T}>.
// TODO: this should take an analysis instead
let createCataRecord (cataName : Ident) (doc : PreXmlDoc) (allUnionTypes : SynTypeDefn list) : SynTypeDefn =
let createCataRecord (cataName : Ident) (doc : PreXmlDoc) (analysis : UnionAnalysis list) : SynTypeDefn =
// An artificial generic for each union type
let generics =
allUnionTypes
|> List.map (fun defn ->
let name = getName defn |> List.map _.idText |> String.concat "" |> Ident.Create
SynTypar.SynTypar (name, TyparStaticReq.None, false)
)
analysis
|> List.map (fun analysis -> SynTypar.SynTypar (analysis.GenericName, TyparStaticReq.None, false))
// A field for each cata
let fields =
allUnionTypes
|> List.map (fun unionType ->
let nameForDoc = List.last (getName unionType) |> _.idText
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 name = getName unionType
let artificialGenerics = generics |> List.map (fun v -> SynType.Var (v, range0))
let userInputGenerics =
analysis.Typars
|> List.map (fun (SynTyparDecl.SynTyparDecl (_, typar)) -> SynType.Var (typar, range0))
let ty =
SynType.App (
SynType.CreateLongIdent (SynLongIdent.CreateString (List.last(name).idText + "CataCase")),
SynType.LongIdent (SynLongIdent.CreateFromLongIdent [ analysis.CataTypeName ]),
Some range0,
generics |> List.map (fun v -> SynType.Var (v, range0)),
userInputGenerics @ artificialGenerics,
List.replicate (generics.Length - 1) range0,
Some range0,
false,
@@ -658,7 +736,7 @@ module internal CataGenerator =
SynField.SynField (
[],
false,
Some (List.last name),
Some (List.last analysis.ParentTypeName),
ty,
false,
doc,
@@ -670,16 +748,21 @@ module internal CataGenerator =
)
)
// A "real" generic for each generic in the user-provided type
let genericsFromUserInput =
analysis
|> List.collect (fun analysis ->
// TODO: deduplicate generics with the same name from different cases
analysis.Typars
)
let genericsFromCata =
generics |> List.map (fun ty -> SynTyparDecl.SynTyparDecl ([], ty))
let componentInfo =
SynComponentInfo.SynComponentInfo (
[],
Some (
SynTyparDecls.PostfixList (
generics |> List.map (fun ty -> SynTyparDecl.SynTyparDecl ([], ty)),
[],
range0
)
),
Some (SynTyparDecls.PostfixList (genericsFromUserInput @ genericsFromCata, [], range0)),
[],
[ cataName ],
doc,
@@ -714,13 +797,20 @@ module internal CataGenerator =
allUnionTypes
|> List.map (fun unionType ->
let cases, typars, access = AstHelper.getUnionCases unionType
let cases =
AstHelper.getUnionCases unionType
cases
|> List.map (fun prod ->
let fields =
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
@@ -742,6 +832,8 @@ module internal CataGenerator =
let unionTypeName = getName unionType
{
Typars = typars
Accessibility = access
StackName =
List.last(getName unionType).idText + "Stack"
|> Ident.Create
@@ -1218,6 +1310,23 @@ module internal CataGenerator =
None
)
// A generic for each DU case, and a generic for each generic in the DU
let genericCount = analysis.Length + (analysis |> List.sumBy _.Typars.Length)
let instructionsArrType =
if genericCount > analysis.Length then
SynType.App (
SynType.CreateLongIdent "Instruction",
Some range0,
List.replicate (genericCount - analysis.Length) (SynType.Anon range0),
List.replicate (genericCount - analysis.Length - 1) range0,
Some range0,
false,
range0
)
else
SynType.CreateLongIdent "Instruction"
let headPat =
SynPat.LongIdent (
SynLongIdent.CreateString "loop",
@@ -1231,8 +1340,8 @@ module internal CataGenerator =
SynType.App (
SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ cataTypeName ]),
Some range0,
List.replicate analysis.Length (SynType.Anon range0),
List.replicate (analysis.Length - 1) range0,
List.replicate genericCount (SynType.Anon range0),
List.replicate (genericCount - 1) range0,
Some range0,
false,
range0
@@ -1245,7 +1354,7 @@ module internal CataGenerator =
SynType.App (
SynType.CreateLongIdent "ResizeArray",
Some range0,
[ SynType.CreateLongIdent "Instruction" ],
[ instructionsArrType ],
[],
Some range0,
false,
@@ -1404,6 +1513,9 @@ module internal CataGenerator =
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 ->
@@ -1414,12 +1526,14 @@ module internal CataGenerator =
|> fun x -> SynType.Var (x, range0)
)
let userProvidedGenerics = analysis |> List.collect (fun x -> x.Typars)
let runFunctions =
List.zip allUnionTypes allTypars
|> List.map (fun (unionType, relevantTypar) -> createRunFunction cataName allTypars relevantTypar unionType)
|> List.map (fun (unionType, relevantTypar) ->
createRunFunction cataName userProvidedGenerics allTypars relevantTypar unionType
)
let cataVarName = Ident.Create "cata"
let analysis = makeUnionAnalyses cataVarName allRecordTypes allUnionTypes
let cataStructures =
createCataStructure analysis
@@ -1432,7 +1546,7 @@ module internal CataGenerator =
$" Specifies how to perform a fold (catamorphism) over the type %s{parentName} and its friends."
let cataRecord =
SynModuleDecl.Types ([ createCataRecord cataName recordDoc allUnionTypes ], range0)
SynModuleDecl.Types ([ createCataRecord cataName recordDoc analysis ], range0)
SynModuleOrNamespace.CreateNamespace (
ns,
@@ -1453,6 +1567,54 @@ module internal CataGenerator =
]
)
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<CreateCatamorphismAttribute> 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.
[<MyriadGenerator("create-catamorphism")>]
type CreateCatamorphismGenerator () =
@@ -1460,52 +1622,4 @@ type CreateCatamorphismGenerator () =
interface IMyriadGenerator with
member _.ValidInputExtensions = [ ".fs" ]
member _.Generate (context : GeneratorContext) =
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<CreateCatamorphismAttribute> 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) ->
CataGenerator.createModule opens ns taggedType unions records
)
Output.Ast modules
member _.Generate (context : GeneratorContext) = CataGenerator.generate context