From b7f7db8c1159d54e69afd497158442b78ebc4af0 Mon Sep 17 00:00:00 2001 From: Smaug123 Date: Fri, 16 Feb 2024 14:07:15 +0000 Subject: [PATCH] Generate outside of loop --- ConsumePlugin/Catamorphism.fs | 2 +- ConsumePlugin/GeneratedCatamorphism.fs | 7 +- WoofWare.Myriad.Plugins/CataGenerator.fs | 135 ++++++++++++++++++++++- 3 files changed, 141 insertions(+), 3 deletions(-) diff --git a/ConsumePlugin/Catamorphism.fs b/ConsumePlugin/Catamorphism.fs index 7adbc12..835ef35 100644 --- a/ConsumePlugin/Catamorphism.fs +++ b/ConsumePlugin/Catamorphism.fs @@ -75,7 +75,7 @@ module TailRecCata = | Child | Parent - let private loop (cata : Cata<_, _>) (instructions : ResizeArray<_>) = + let private loop (cata : Cata<_, _>) (instructions : ResizeArray) = let resultsStack = ResizeArray () let builderResultsStack = ResizeArray () diff --git a/ConsumePlugin/GeneratedCatamorphism.fs b/ConsumePlugin/GeneratedCatamorphism.fs index bfa08f4..bb8336a 100644 --- a/ConsumePlugin/GeneratedCatamorphism.fs +++ b/ConsumePlugin/GeneratedCatamorphism.fs @@ -38,7 +38,7 @@ type Cata<'Expr, 'ExprBuilder> = ExprBuilder : ExprBuilderCata<'Expr, 'ExprBuilder> } -/// Catamorphism +/// Methods to perform a catamorphism over the type Expr [] module ExprCata = [] @@ -51,6 +51,11 @@ module ExprCata = | ExprBuilderChild | ExprBuilderParent + let private loop (cata : Cata<_, _>) (instructions : ResizeArray) = + let ExprBuilderStack = ResizeArray () + let ExprStack = ResizeArray () + ExprStack, ExprBuilderStack + /// Execute the catamorphism. let runExpr (cata : Cata<'ExprRet, 'ExprBuilderRet>) (x : Expr) : 'ExprRet = let instructions = ResizeArray () diff --git a/WoofWare.Myriad.Plugins/CataGenerator.fs b/WoofWare.Myriad.Plugins/CataGenerator.fs index aa72830..07cc4ed 100644 --- a/WoofWare.Myriad.Plugins/CataGenerator.fs +++ b/WoofWare.Myriad.Plugins/CataGenerator.fs @@ -1,5 +1,6 @@ namespace WoofWare.Myriad.Plugins +open System.Transactions open Fantomas.FCS.Syntax open Fantomas.FCS.SyntaxTrivia open Fantomas.FCS.Xml @@ -545,6 +546,136 @@ module internal CataGenerator = } ) + let createLoopFunction (allUnionTypes : SynTypeDefn list) : SynBinding = + let valData = + SynValData.SynValData ( + None, + SynValInfo.SynValInfo ( + [ + [ SynArgInfo.SynArgInfo ([], false, Some (Ident.Create "cata")) ] + [ SynArgInfo.SynArgInfo ([], false, Some (Ident.Create "instructions")) ] + ], + SynArgInfo.Empty + ), + None + ) + + let headPat = + SynPat.LongIdent ( + SynLongIdent.CreateString "loop", + None, + None, + SynArgPats.Pats + [ + SynPat.CreateParen ( + SynPat.CreateTyped ( + SynPat.CreateNamed (Ident.Create "cata"), + SynType.App ( + // TODO: better type name + SynType.CreateLongIdent "Cata", + Some range0, + List.replicate allUnionTypes.Length (SynType.Anon range0), + List.replicate (allUnionTypes.Length - 1) range0, + Some range0, + false, + range0 + ) + ) + ) + SynPat.CreateParen ( + SynPat.CreateTyped ( + SynPat.CreateNamed (Ident.Create "instructions"), + SynType.App ( + SynType.CreateLongIdent "ResizeArray", + Some range0, + [ SynType.CreateLongIdent "Instruction" ], + [], + Some range0, + false, + range0 + ) + ) + ) + ], + Some (SynAccess.Private range0), + range0 + ) + + let stackNames = + allUnionTypes + |> List.map (fun ty -> + // TODO this is jank + List.last(getName ty).idText + "Stack" |> Ident.Create + ) + + let body = + SynExpr.CreateSequential + [ + SynExpr.CreateTuple ( + stackNames + |> List.map (List.singleton >> SynLongIdent.CreateFromLongIdent >> SynExpr.CreateLongIdent) + ) + ] + + let body = + (body, List.zip stackNames allUnionTypes) + ||> List.fold (fun body (stackName, unionType) -> + SynExpr.LetOrUse ( + false, + false, + [ + SynBinding.SynBinding ( + None, + SynBindingKind.Normal, + false, + false, + [], + PreXmlDoc.Empty, + SynValData.SynValData (None, SynValInfo.Empty, None), + SynPat.Named (SynIdent.SynIdent (stackName, None), false, None, range0), + None, + SynExpr.CreateApp ( + SynExpr.CreateLongIdent (SynLongIdent.CreateString "ResizeArray"), + SynExpr.CreateConst SynConst.Unit + ), + range0, + DebugPointAtBinding.Yes range0, + { + LeadingKeyword = SynLeadingKeyword.Let range0 + InlineKeyword = None + EqualsRange = Some range0 + } + ) + ], + 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 = + { + LeadingKeyword = SynLeadingKeyword.Let range0 + InlineKeyword = None + EqualsRange = Some range0 + } + ) + let createModule (opens : SynOpenDeclTarget list) (ns : LongIdent) @@ -582,6 +713,8 @@ module internal CataGenerator = createCataStructure allUnionTypes |> List.map (fun repr -> SynModuleDecl.Types ([ repr ], range0)) + let loopFunction = createLoopFunction allUnionTypes + let cataRecord = SynModuleDecl.Types ([ createCataRecord allUnionTypes ], range0) SynModuleOrNamespace.CreateNamespace ( @@ -597,7 +730,7 @@ module internal CataGenerator = modInfo, [ SynModuleDecl.Types ([ createInstructionType allUnionTypes ], range0) - SynModuleDecl.CreateLet runFunctions + SynModuleDecl.CreateLet (loopFunction :: runFunctions) ] ) ]