mirror of
https://github.com/Smaug123/WoofWare.Myriad
synced 2025-10-25 05:48:40 +00:00
Bit more
This commit is contained in:
Smaug123
@@ -14,28 +14,28 @@ open WoofWare.Myriad.Plugins
|
||||
/// Description of how to combine cases during a fold
|
||||
type ExprCata<'Expr, 'ExprBuilder> =
|
||||
/// How to operate on the Const case
|
||||
abstract Const: Const -> 'Expr
|
||||
abstract Const : Const -> 'Expr
|
||||
/// How to operate on the Pair case
|
||||
abstract Pair: 'Expr -> 'Expr -> PairOpKind -> 'Expr
|
||||
abstract Pair : 'Expr -> 'Expr -> PairOpKind -> 'Expr
|
||||
/// How to operate on the Sequential case
|
||||
abstract Sequential: 'Expr list -> 'Expr
|
||||
abstract Sequential : 'Expr list -> 'Expr
|
||||
/// How to operate on the Builder case
|
||||
abstract Builder: 'Expr -> 'ExprBuilder -> 'Expr
|
||||
abstract Builder : 'Expr -> 'ExprBuilder -> 'Expr
|
||||
|
||||
/// Description of how to combine cases during a fold
|
||||
type ExprBuilderCata<'Expr, 'ExprBuilder> =
|
||||
/// How to operate on the Child case
|
||||
abstract Child: 'ExprBuilder -> 'ExprBuilder
|
||||
abstract Child : 'ExprBuilder -> 'ExprBuilder
|
||||
/// How to operate on the Parent case
|
||||
abstract Parent: 'Expr -> 'ExprBuilder
|
||||
abstract Parent : 'Expr -> 'ExprBuilder
|
||||
|
||||
/// Specifies how to perform a fold (catamorphism) over the type Expr.
|
||||
type Cata<'Expr, 'ExprBuilder> =
|
||||
{
|
||||
/// TODO: doc
|
||||
Expr: ExprCata<'Expr, 'ExprBuilder>
|
||||
Expr : ExprCata<'Expr, 'ExprBuilder>
|
||||
/// TODO: doc
|
||||
ExprBuilder: ExprBuilderCata<'Expr, 'ExprBuilder>
|
||||
ExprBuilder : ExprBuilderCata<'Expr, 'ExprBuilder>
|
||||
}
|
||||
|
||||
/// Methods to perform a catamorphism over the type Expr
|
||||
@@ -51,30 +51,38 @@ module ExprCata =
|
||||
| ExprBuilderChild
|
||||
| ExprBuilderParent
|
||||
|
||||
let private loop (cata: Cata<_, _>) (instructions: ResizeArray<Instruction>) =
|
||||
let ExprBuilderStack = ResizeArray()
|
||||
let ExprStack = ResizeArray()
|
||||
let private loop (cata : Cata<_, _>) (instructions : ResizeArray<Instruction>) =
|
||||
let ExprBuilderStack = ResizeArray ()
|
||||
let ExprStack = ResizeArray ()
|
||||
|
||||
while instructions.Count > 0 do
|
||||
let currentInstruction = instructions.[instructions.Count - 1]
|
||||
instructions.RemoveAt(instructions.Count - 1)
|
||||
instructions.RemoveAt (instructions.Count - 1)
|
||||
|
||||
match currentInstruction with
|
||||
|
||||
| Instruction.ProcessExpr x ->
|
||||
match x with
|
||||
| Expr.Const (arg0) -> ()
|
||||
| Expr.Pair (arg0, arg1, arg2) -> ()
|
||||
| Expr.Sequential (arg0) -> ()
|
||||
| Expr.Builder (arg0, arg1) -> ()
|
||||
| Instruction.ProcessExprBuilder x ->
|
||||
match x with
|
||||
| ExprBuilder.Child (arg0) -> ()
|
||||
| ExprBuilder.Parent (arg0) -> ()
|
||||
|
||||
ExprStack, ExprBuilderStack
|
||||
|
||||
/// Execute the catamorphism.
|
||||
let runExpr (cata: Cata<'ExprRet, 'ExprBuilderRet>) (x: Expr) : 'ExprRet =
|
||||
let instructions = ResizeArray()
|
||||
instructions.Add(Instruction.ProcessExpr x)
|
||||
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>) (x: ExprBuilder) : 'ExprBuilderRet =
|
||||
let instructions = ResizeArray()
|
||||
instructions.Add(Instruction.ProcessExprBuilder x)
|
||||
let runExprBuilder (cata : Cata<'ExprRet, 'ExprBuilderRet>) (x : ExprBuilder) : 'ExprBuilderRet =
|
||||
let instructions = ResizeArray ()
|
||||
instructions.Add (Instruction.ProcessExprBuilder x)
|
||||
let ExprRetStack, ExprBuilderRetStack = loop cata instructions
|
||||
Seq.exactlyOne ExprBuilderRetStack
|
||||
|
||||
|
||||
@@ -623,8 +623,120 @@ module internal CataGenerator =
|
||||
List.last(getName ty).idText + "Stack" |> Ident.Create
|
||||
)
|
||||
|
||||
// A clause for each type, splitting it into its cases:
|
||||
let baseMatchClauses =
|
||||
List.zip stackNames allUnionTypes
|
||||
|> List.map (fun (stackName, unionType) ->
|
||||
let cases = getCases unionType
|
||||
|
||||
let bodyMatch =
|
||||
SynExpr.CreateMatch (
|
||||
SynExpr.CreateIdentString "x",
|
||||
cases
|
||||
|> List.map (fun case ->
|
||||
let name =
|
||||
match case.Name with
|
||||
| SynIdent (ident, _) -> ident
|
||||
|
||||
let analysis = analyse allUnionTypes case
|
||||
|
||||
let matchBody =
|
||||
if
|
||||
analysis
|
||||
|> List.forall (
|
||||
function
|
||||
| FieldDescription.NonRecursive ty -> true
|
||||
| _ -> false
|
||||
)
|
||||
then
|
||||
// directly call the cata
|
||||
((0,
|
||||
SynExpr.CreateLongIdent (
|
||||
SynLongIdent.CreateFromLongIdent (
|
||||
Ident.Create "cata" :: getName unionType @ [ name ]
|
||||
)
|
||||
)),
|
||||
List.rev case.Fields)
|
||||
||> List.fold (fun (i, body) field ->
|
||||
let fieldName =
|
||||
match field.Name with
|
||||
| Some n -> n
|
||||
| None -> Ident.Create $"arg%i{i}"
|
||||
|
||||
let body = SynExpr.CreateApp (body, SynExpr.CreateIdent fieldName)
|
||||
(i + 1, body)
|
||||
)
|
||||
|> snd
|
||||
|> SynExpr.pipeThroughFunction (
|
||||
SynExpr.CreateLongIdent (
|
||||
SynLongIdent.CreateFromLongIdent (stackName :: [ Ident.Create "Add" ])
|
||||
)
|
||||
)
|
||||
else
|
||||
// there's a recursive type in here, so we'll have to make some calls
|
||||
// and then come back.
|
||||
failwith "TODO"
|
||||
|
||||
SynMatchClause.SynMatchClause (
|
||||
SynPat.CreateLongIdent (
|
||||
SynLongIdent.CreateFromLongIdent (getName unionType @ [ name ]),
|
||||
[
|
||||
SynPat.CreateParen (
|
||||
SynPat.Tuple (
|
||||
false,
|
||||
case.Fields
|
||||
|> List.mapi (fun i field ->
|
||||
let name =
|
||||
match field.Name with
|
||||
| None -> Ident.Create $"arg%i{i}"
|
||||
| Some n -> n
|
||||
|
||||
SynPat.CreateNamed name
|
||||
),
|
||||
List.replicate (case.Fields.Length - 1) range0,
|
||||
range0
|
||||
)
|
||||
)
|
||||
]
|
||||
),
|
||||
None,
|
||||
matchBody,
|
||||
range0,
|
||||
DebugPointAtTarget.Yes,
|
||||
{
|
||||
ArrowRange = Some range0
|
||||
BarRange = Some range0
|
||||
}
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
SynMatchClause.SynMatchClause (
|
||||
SynPat.LongIdent (
|
||||
// TODO this is also jank; should unify with DU generator
|
||||
SynLongIdent.Create [ "Instruction" ; "Process" + (List.last (getName unionType)).idText ],
|
||||
None,
|
||||
None,
|
||||
SynArgPats.Pats [ SynPat.CreateNamed (Ident.Create "x") ],
|
||||
None,
|
||||
range0
|
||||
),
|
||||
None,
|
||||
bodyMatch,
|
||||
range0,
|
||||
DebugPointAtTarget.Yes,
|
||||
{
|
||||
ArrowRange = Some range0
|
||||
BarRange = Some range0
|
||||
}
|
||||
)
|
||||
)
|
||||
|
||||
// And a clause for each case with a recursive reference.
|
||||
let recMatchClauses = []
|
||||
|
||||
let matchStatement =
|
||||
SynExpr.CreateMatch (SynExpr.CreateIdentString "currentInstruction", [])
|
||||
SynExpr.CreateMatch (SynExpr.CreateIdentString "currentInstruction", baseMatchClauses @ recMatchClauses)
|
||||
|
||||
let body =
|
||||
SynExpr.CreateSequential
|
||||
|
||||
Reference in New Issue
Block a user