From 1e1176bec5536674e17858bf16cabda2fc324fb1 Mon Sep 17 00:00:00 2001 From: Smaug123 Date: Fri, 16 Feb 2024 11:31:30 +0000 Subject: [PATCH] Generate instruction DU --- ConsumePlugin/GeneratedCatamorphism.fs | 14 +- WoofWare.Myriad.Plugins/CataGenerator.fs | 174 +++++++++++++++++++++-- 2 files changed, 175 insertions(+), 13 deletions(-) diff --git a/ConsumePlugin/GeneratedCatamorphism.fs b/ConsumePlugin/GeneratedCatamorphism.fs index e4b6c63..09be3fb 100644 --- a/ConsumePlugin/GeneratedCatamorphism.fs +++ b/ConsumePlugin/GeneratedCatamorphism.fs @@ -14,15 +14,25 @@ open WoofWare.Myriad.Plugins /// Catamorphism [] module ExprCata = + [] + type private Instruction = + | ProcessExpr of Expr + | ProcessExprBuilder of ExprBuilder + | ExprPair of PairOpKind + | ExprSequential of int + | ExprBuilder + | ExprBuilderChild + | ExprBuilderParent + /// Execute the catamorphism. - let runExpr (cata : Cata<'ExprRet, 'ExprBuilderRet>) : 'ExprRet = + let runExpr (cata : Cata<'ExprRet, 'ExprBuilderRet>) (x : Expr) : 'ExprRet = let instructions = ResizeArray () instructions.Add (Instruction.ProcessExpr x) let ExprRetStack, ExprBuilderRetStack = loop cata instructions Seq.exactlyOne ExprRetStack /// Execute the catamorphism. - let runExprBuilder (cata : Cata<'ExprRet, 'ExprBuilderRet>) : 'ExprBuilderRet = + let runExprBuilder (cata : Cata<'ExprRet, 'ExprBuilderRet>) (x : ExprBuilder) : 'ExprBuilderRet = let instructions = ResizeArray () instructions.Add (Instruction.ProcessExprBuilder x) let ExprRetStack, ExprBuilderRetStack = loop cata instructions diff --git a/WoofWare.Myriad.Plugins/CataGenerator.fs b/WoofWare.Myriad.Plugins/CataGenerator.fs index 959e5f4..5eea966 100644 --- a/WoofWare.Myriad.Plugins/CataGenerator.fs +++ b/WoofWare.Myriad.Plugins/CataGenerator.fs @@ -70,6 +70,12 @@ module internal CataGenerator = ) ) ) + SynPat.CreateParen ( + SynPat.CreateTyped ( + SynPat.CreateNamed (Ident.Create "x"), + SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ relevantTypeName ]) + ) + ) ] ), Some (SynBindingReturnInfo.Create relevantTypar), @@ -155,15 +161,160 @@ module internal CataGenerator = } ) + let getName (ty : SynTypeDefn) : LongIdent = + match ty with + | SynTypeDefn.SynTypeDefn (SynComponentInfo.SynComponentInfo (_, _, _, id, _, _, _, _), _, _, _, _, _) -> id + + type UnionField = + { + Type : SynType + Name : Ident option + } + + type UnionCase = + { + Name : SynIdent + Fields : UnionField list + } + + let getCases (SynTypeDefn.SynTypeDefn (_, repr, _, _, _, _)) : UnionCase list = + match repr with + | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (_, cases, _), range0) -> + 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 + } + ) + } + ) + | _ -> failwithf "Failed to get union cases for type that was: %+A" repr + + /// Given the input `| Pair of Expr * Expr * PairOpKind`, + /// strips out any members which contain recursive calls. + /// TODO: support lists and other compound types. + let createInstructionCases (allUnionTypes : SynTypeDefn list) (case : UnionCase) : UnionField list option = + let hasRecursion, cases = + ((false, []), case.Fields) + ||> List.fold (fun (hasRecursion, cases) field -> + match SynType.stripOptionalParen field.Type with + | ListType ty -> + match ty with + | SynType.LongIdent (SynLongIdent.SynLongIdent (ty, _, _)) -> + let isListOfSelf = + allUnionTypes + |> List.exists (fun unionTy -> List.last(getName unionTy).idText = List.last(ty).idText) + + if isListOfSelf then + // store an int which is the length of the list + true, SynType.Int () :: cases + else + hasRecursion, field.Type :: cases + | _ -> hasRecursion, field.Type :: cases + | PrimitiveType _ -> hasRecursion, field.Type :: cases + | SynType.LongIdent (SynLongIdent.SynLongIdent (ty, _, _)) -> + let isSelf = + allUnionTypes + |> List.exists (fun unionTy -> List.last(getName unionTy).idText = List.last(ty).idText) + + if isSelf then + true, cases + else + hasRecursion, field.Type :: cases + | _ -> failwithf "Unrecognised type: %+A" field.Type + ) + + if hasRecursion then + cases + |> List.rev + |> List.map (fun ty -> + { + Name = None + Type = ty + } + ) + |> Some + else + None + + let createInstructionType (allUnionTypes : SynTypeDefn 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 = + allUnionTypes + |> List.map (fun unionType -> + let name = getName unionType + + SynUnionCase.Create ( + Ident.Create ("Process" + (List.last name).idText), + [ + SynField.Create (SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent name)) + ] + ) + ) + + let casesFromCases = + allUnionTypes + |> List.collect (fun unionType -> + getCases unionType + |> List.choose (fun case -> + let fields = createInstructionCases allUnionTypes case + + match fields with + | None -> None + | Some fields -> + let name = + match case.Name with + | SynIdent.SynIdent (ident, _) -> + (List.last (getName unionType)).idText + ident.idText |> Ident.Create + + SynUnionCase.Create (name, fields |> List.map (fun field -> SynField.Create field.Type)) + |> Some + ) + ) + + let cases = casesFromProcess @ casesFromCases + + SynTypeDefn.SynTypeDefn ( + SynComponentInfo.SynComponentInfo ( + [ SynAttributeList.Create [ SynAttribute.RequireQualifiedAccess () ] ], + None, + [], + [ 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 + } + ) + let createModule (opens : SynOpenDeclTarget list) (ns : LongIdent) - (SynTypeDefn.SynTypeDefn (SynComponentInfo.SynComponentInfo (_, _, _, taggedType, _, _, _, _), _, _, _, _, _)) + (taggedType : SynTypeDefn) (allUnionTypes : SynTypeDefn list) : SynModuleOrNamespace = let moduleName : LongIdent = - List.last taggedType + List.last (getName taggedType) |> fun x -> x.idText + "Cata" |> Ident.Create |> List.singleton @@ -179,14 +330,8 @@ module internal CataGenerator = let allTypars = allUnionTypes - |> List.map (fun - (SynTypeDefn.SynTypeDefn (SynComponentInfo.SynComponentInfo (_, _, _, id, _, _, _, _), - _, - _, - _, - _, - _)) -> - List.last id + |> List.map (fun unionType -> + List.last (getName unionType) |> fun x -> x.idText |> fun s -> s + "Ret" |> Ident.Create @@ -204,7 +349,14 @@ module internal CataGenerator = [ for openStatement in opens do yield SynModuleDecl.CreateOpen openStatement - yield SynModuleDecl.CreateNestedModule (modInfo, [ SynModuleDecl.CreateLet runFunctions ]) + yield + SynModuleDecl.CreateNestedModule ( + modInfo, + [ + SynModuleDecl.Types ([ createInstructionType allUnionTypes ], range0) + SynModuleDecl.CreateLet runFunctions + ] + ) ] )