mirror of
https://github.com/Smaug123/WoofWare.Myriad
synced 2025-10-31 00:29:00 +00:00
1662 lines
74 KiB
Forth
1662 lines
74 KiB
Forth
namespace WoofWare.Myriad.Plugins
|
|
|
|
open Fantomas.FCS.Syntax
|
|
open Fantomas.FCS.SyntaxTrivia
|
|
open Fantomas.FCS.Xml
|
|
open Myriad.Core
|
|
|
|
[<RequireQualifiedAccess>]
|
|
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
|
|
|
|
[<RequireQualifiedAccess>]
|
|
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)
|
|
(unionType : SynTypeDefn)
|
|
: SynBinding
|
|
=
|
|
let relevantTypeName =
|
|
match unionType with
|
|
| SynTypeDefn.SynTypeDefn (SynComponentInfo.SynComponentInfo (longId = id), _, _, _, _, _) -> List.last id
|
|
|
|
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,
|
|
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" + 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 (
|
|
SynLongIdent.Create
|
|
[ "Instruction" ; "Process__" + relevantTypeName.idText ]
|
|
),
|
|
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
|
|
}
|
|
)
|
|
|
|
{
|
|
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
|
|
)
|
|
}
|
|
|> 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 =
|
|
// 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 ->
|
|
SynUnionCase.Create (unionCase.Name, unionCase.Fields |> List.map (fun f -> SynField.Create f.Type))
|
|
)
|
|
|
|
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 =
|
|
// 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 () ] ],
|
|
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<U>.
|
|
/// For each U:
|
|
/// * Define the type [U]Cata, generic on all the parameters {'ret<U> : U in T}.
|
|
/// * For each DU case C in type U:
|
|
/// * create a method in [U]Cata, whose return value is 'ret<U> 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<V>
|
|
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<U> for U in T}>
|
|
/// with one member for each U, namely of type [U]Cata<{'ret<U> 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 (_, typar)) -> SynType.Var (typar, 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 (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 (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.Pats [ SynPat.CreateNamed (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 _ -> SynPat.CreateNamed case.ArgName |> Some
|
|
| FieldDescription.ListSelf _ -> SynPat.CreateNamed case.ArgName |> Some
|
|
| FieldDescription.Self _ -> None
|
|
)
|
|
|> Seq.toList
|
|
|
|
let lhs =
|
|
match lhsNames with
|
|
| [] -> []
|
|
| lhsNames ->
|
|
SynPat.Tuple (false, lhsNames, List.replicate (lhsNames.Length - 1) range0, range0)
|
|
|> SynPat.CreateParen
|
|
|> List.singleton
|
|
|
|
let pat =
|
|
SynPat.LongIdent (unionCase.AssociatedInstruction, None, None, SynArgPats.Pats 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
|
|
)
|
|
|
|
// 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",
|
|
None,
|
|
None,
|
|
SynArgPats.Pats
|
|
[
|
|
SynPat.CreateParen (
|
|
SynPat.CreateTyped (
|
|
SynPat.CreateNamed cataVarName,
|
|
SynType.App (
|
|
SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ cataTypeName ]),
|
|
Some range0,
|
|
List.replicate genericCount (SynType.Anon range0),
|
|
List.replicate (genericCount - 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.CreateLongIdent (SynLongIdent.CreateString "ResizeArray"),
|
|
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 (fun x -> x.Typars)
|
|
|
|
let runFunctions =
|
|
List.zip allUnionTypes allTypars
|
|
|> List.map (fun (unionType, relevantTypar) ->
|
|
createRunFunction cataName userProvidedGenerics allTypars relevantTypar unionType
|
|
)
|
|
|
|
|
|
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<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 () =
|
|
|
|
interface IMyriadGenerator with
|
|
member _.ValidInputExtensions = [ ".fs" ]
|
|
|
|
member _.Generate (context : GeneratorContext) = CataGenerator.generate context
|