mirror of
https://github.com/Smaug123/WoofWare.Myriad
synced 2025-10-25 05:48:40 +00:00
Compare commits
5 Commits
1e1176bec5
...
1793e9490f
| Author | SHA1 | Date | |
|---|---|---|---|
|
1793e9490f | ||
|
|
a524c1104d | ||
|
|
d651aae6fb | ||
|
|
b7f7db8c11 | ||
|
|
65d2263a6c |
@@ -17,7 +17,7 @@ type Expr =
|
||||
| Sequential of Expr list
|
||||
| Builder of Expr * ExprBuilder
|
||||
|
||||
and [<CreateCatamorphism>] ExprBuilder =
|
||||
and ExprBuilder =
|
||||
| Child of ExprBuilder
|
||||
| Parent of Expr
|
||||
|
||||
@@ -75,7 +75,7 @@ module TailRecCata =
|
||||
| Child
|
||||
| Parent
|
||||
|
||||
let private loop (cata : Cata<_, _>) (instructions : ResizeArray<_>) =
|
||||
let private loop (cata : Cata<_, _>) (instructions : ResizeArray<Instruction>) =
|
||||
let resultsStack = ResizeArray ()
|
||||
let builderResultsStack = ResizeArray ()
|
||||
|
||||
|
||||
@@ -11,29 +11,83 @@ namespace ConsumePlugin
|
||||
|
||||
open WoofWare.Myriad.Plugins
|
||||
|
||||
/// Catamorphism
|
||||
/// Description of how to combine cases during a fold
|
||||
type ExprCata<'Expr, 'ExprBuilder> =
|
||||
/// How to operate on the Const case
|
||||
abstract Const : Const -> 'Expr
|
||||
/// How to operate on the Pair case
|
||||
abstract Pair : 'Expr -> 'Expr -> PairOpKind -> 'Expr
|
||||
/// How to operate on the Sequential case
|
||||
abstract Sequential : 'Expr list -> 'Expr
|
||||
/// How to operate on the Builder case
|
||||
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
|
||||
/// How to operate on the Parent case
|
||||
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>
|
||||
/// TODO: doc
|
||||
ExprBuilder : ExprBuilderCata<'Expr, 'ExprBuilder>
|
||||
}
|
||||
|
||||
/// Methods to perform a catamorphism over the type Expr
|
||||
[<RequireQualifiedAccess>]
|
||||
module ExprCata =
|
||||
[<RequireQualifiedAccess>]
|
||||
type private Instruction =
|
||||
| ProcessExpr of Expr
|
||||
| ProcessExprBuilder of ExprBuilder
|
||||
| ExprPair of PairOpKind
|
||||
| ExprSequential of int
|
||||
| ExprBuilder
|
||||
| ExprBuilderChild
|
||||
| ExprBuilderParent
|
||||
| Process__Expr of Expr
|
||||
| Process__ExprBuilder of ExprBuilder
|
||||
| Expr_Pair of PairOpKind
|
||||
| Expr_Sequential of int
|
||||
| Expr_Builder
|
||||
| ExprBuilder_Child
|
||||
| ExprBuilder_Parent
|
||||
|
||||
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)
|
||||
|
||||
match currentInstruction with
|
||||
| Instruction.Process__Expr x ->
|
||||
match x with
|
||||
| Expr.Const (arg0) -> cata.Expr.Const arg0 |> exprStack.Add
|
||||
| Expr.Pair (arg0, arg1, arg2) -> ()
|
||||
| Expr.Sequential (arg0) -> ()
|
||||
| Expr.Builder (arg0, arg1) -> ()
|
||||
| Instruction.Process__ExprBuilder x ->
|
||||
match x with
|
||||
| ExprBuilder.Child (arg0) -> ()
|
||||
| ExprBuilder.Parent (arg0) -> ()
|
||||
| Instruction.Expr_Pair (arg2) -> ()
|
||||
| Instruction.Expr_Sequential (n) -> ()
|
||||
| Instruction.Expr_Builder -> ()
|
||||
| Instruction.ExprBuilder_Child -> ()
|
||||
| Instruction.ExprBuilder_Parent -> ()
|
||||
|
||||
exprStack, exprBuilderStack
|
||||
|
||||
/// Execute the catamorphism.
|
||||
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
|
||||
instructions.Add (Instruction.Process__Expr 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 ExprRetStack, ExprBuilderRetStack = loop cata instructions
|
||||
Seq.exactlyOne ExprBuilderRetStack
|
||||
instructions.Add (Instruction.Process__ExprBuilder x)
|
||||
let exprRetStack, exprBuilderRetStack = loop cata instructions
|
||||
Seq.exactlyOne exprBuilderRetStack
|
||||
|
||||
@@ -70,6 +70,18 @@ type internal RecordType =
|
||||
Accessibility : SynAccess option
|
||||
}
|
||||
|
||||
type UnionField =
|
||||
{
|
||||
Type : SynType
|
||||
Name : Ident option
|
||||
}
|
||||
|
||||
type UnionCase =
|
||||
{
|
||||
Name : SynIdent
|
||||
Fields : UnionField list
|
||||
}
|
||||
|
||||
[<RequireQualifiedAccess>]
|
||||
module internal AstHelper =
|
||||
|
||||
@@ -383,6 +395,27 @@ module internal AstHelper =
|
||||
Accessibility = accessibility
|
||||
}
|
||||
|
||||
let getUnionCases (SynTypeDefn.SynTypeDefn (_, repr, _, _, _, _)) : UnionCase list =
|
||||
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
|
||||
}
|
||||
)
|
||||
}
|
||||
)
|
||||
| _ -> failwithf "Failed to get union cases for type that was: %+A" repr
|
||||
|
||||
[<AutoOpen>]
|
||||
module internal SynTypePatterns =
|
||||
|
||||
@@ -1,7 +1,6 @@
|
||||
namespace WoofWare.Myriad.Plugins
|
||||
|
||||
open System
|
||||
open System.Text
|
||||
open System.Transactions
|
||||
open Fantomas.FCS.Syntax
|
||||
open Fantomas.FCS.SyntaxTrivia
|
||||
open Fantomas.FCS.Xml
|
||||
@@ -101,7 +100,8 @@ module internal CataGenerator =
|
||||
SynExpr.CreateParen (
|
||||
SynExpr.CreateApp (
|
||||
SynExpr.CreateLongIdent (
|
||||
SynLongIdent.Create [ "Instruction" ; "Process" + relevantTypeName.idText ]
|
||||
SynLongIdent.Create
|
||||
[ "Instruction" ; "Process__" + relevantTypeName.idText ]
|
||||
),
|
||||
SynExpr.CreateLongIdent (SynLongIdent.CreateString "x")
|
||||
)
|
||||
@@ -118,7 +118,9 @@ module internal CataGenerator =
|
||||
false,
|
||||
List.map
|
||||
(fun (t : Ident) ->
|
||||
SynPat.CreateNamed (Ident.Create (t.idText + "Stack"))
|
||||
SynPat.CreateNamed (
|
||||
Ident.Create (t.idText + "Stack") |> Ident.lowerFirstLetter
|
||||
)
|
||||
)
|
||||
allTyparNames,
|
||||
List.replicate (allTypars.Length - 1) range0,
|
||||
@@ -137,7 +139,9 @@ module internal CataGenerator =
|
||||
// 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"))
|
||||
SynExpr.CreateIdent (
|
||||
Ident.Create (relevantTyparName.idText + "Stack") |> Ident.lowerFirstLetter
|
||||
)
|
||||
),
|
||||
range0,
|
||||
{
|
||||
@@ -154,132 +158,158 @@ module internal CataGenerator =
|
||||
),
|
||||
range0,
|
||||
DebugPointAtBinding.NoneAtLet,
|
||||
{
|
||||
LeadingKeyword = SynLeadingKeyword.Let range0
|
||||
InlineKeyword = None
|
||||
EqualsRange = Some range0
|
||||
}
|
||||
SynExpr.synBindingTriviaZero false
|
||||
)
|
||||
|
||||
let getName (ty : SynTypeDefn) : LongIdent =
|
||||
match ty with
|
||||
| SynTypeDefn.SynTypeDefn (SynComponentInfo.SynComponentInfo (_, _, _, id, _, _, _, _), _, _, _, _, _) -> id
|
||||
|
||||
type UnionField =
|
||||
{
|
||||
Type : SynType
|
||||
Name : Ident option
|
||||
}
|
||||
let getNameKey (ty : SynTypeDefn) : string =
|
||||
getName ty |> List.map _.idText |> String.concat "/"
|
||||
|
||||
type UnionCase =
|
||||
let getNameKeyUnion (unionType : SynType) : string =
|
||||
match unionType with
|
||||
| SynType.LongIdent (SynLongIdent.SynLongIdent (name, _, _)) -> name |> List.map _.idText |> String.concat "/"
|
||||
| _ -> failwithf "unrecognised type: %+A" unionType
|
||||
|
||||
type FieldDescription =
|
||||
| ListSelf of SynType
|
||||
/// One of the union types itself
|
||||
| Self of SynType
|
||||
| NonRecursive of SynType
|
||||
|
||||
let analyse (allUnionTypes : SynTypeDefn list) (case : UnionCase) : (Ident option * FieldDescription) list =
|
||||
let rec go (ty : SynType) : FieldDescription =
|
||||
let stripped = SynType.stripOptionalParen ty
|
||||
|
||||
match stripped with
|
||||
| ListType child ->
|
||||
let gone = go child
|
||||
|
||||
match gone with
|
||||
| FieldDescription.NonRecursive ty -> FieldDescription.NonRecursive stripped
|
||||
| FieldDescription.Self ty -> FieldDescription.ListSelf ty
|
||||
| FieldDescription.ListSelf _ -> failwith "Deeply nested lists not currently supported"
|
||||
| PrimitiveType _ -> NonRecursive stripped
|
||||
| SynType.LongIdent (SynLongIdent.SynLongIdent (ty, _, _)) ->
|
||||
let key = ty |> List.map _.idText |> String.concat "/"
|
||||
let isSelf = allUnionTypes |> List.exists (fun unionTy -> getNameKey unionTy = key)
|
||||
|
||||
if isSelf then
|
||||
FieldDescription.Self stripped
|
||||
else
|
||||
FieldDescription.NonRecursive stripped
|
||||
|
||||
| _ -> failwithf "Unrecognised type: %+A" stripped
|
||||
|
||||
case.Fields |> List.map (fun x -> x.Name, go x.Type)
|
||||
|
||||
/// Returns whether this type recursively contains a Self, and the emitted TODO
|
||||
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 : SynIdent
|
||||
Name : Ident
|
||||
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
|
||||
let getInstructionCaseName (thisUnionType : SynTypeDefn) (case : UnionCase) =
|
||||
match case.Name 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.
|
||||
/// TODO: support lists and other compound types.
|
||||
let createInstructionCases (allUnionTypes : SynTypeDefn list) (case : UnionCase) : UnionField list option =
|
||||
/// Stores a list as an int which is "the length of the list".
|
||||
/// TODO: support other compound types.
|
||||
let getRecursiveInstruction
|
||||
(allUnionTypes : SynTypeDefn list)
|
||||
(thisUnionType : SynTypeDefn)
|
||||
(case : UnionCase)
|
||||
: InstructionCase option
|
||||
=
|
||||
let analysed = analyse allUnionTypes case
|
||||
|
||||
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)
|
||||
((false, []), analysed)
|
||||
||> List.fold (fun (hasRecursion, cases) (fieldName, field) ->
|
||||
let newHasRecursion, case = toInstructionCase field
|
||||
|
||||
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)
|
||||
let cases =
|
||||
match case with
|
||||
| None -> cases
|
||||
| Some case -> (fieldName, case) :: cases
|
||||
|
||||
if isSelf then
|
||||
true, cases
|
||||
else
|
||||
hasRecursion, field.Type :: cases
|
||||
| _ -> failwithf "Unrecognised type: %+A" field.Type
|
||||
hasRecursion || newHasRecursion, cases
|
||||
)
|
||||
|
||||
let name = getInstructionCaseName thisUnionType case
|
||||
|
||||
if hasRecursion then
|
||||
cases
|
||||
|> List.rev
|
||||
|> List.map (fun ty ->
|
||||
{
|
||||
Name = None
|
||||
Type = ty
|
||||
}
|
||||
)
|
||||
let fields =
|
||||
cases
|
||||
|> List.rev
|
||||
|> List.map (fun (name, ty) ->
|
||||
{
|
||||
Name = name
|
||||
Type = ty
|
||||
}
|
||||
)
|
||||
|
||||
{
|
||||
Name = name
|
||||
Fields = fields
|
||||
}
|
||||
|> Some
|
||||
else
|
||||
None
|
||||
|
||||
/// 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 (allUnionTypes : SynTypeDefn list) : InstructionCase list =
|
||||
allUnionTypes
|
||||
|> List.map (fun unionType ->
|
||||
let name = getName unionType
|
||||
|
||||
{
|
||||
Name = Ident.Create ("Process__" + (List.last name).idText)
|
||||
Fields =
|
||||
{
|
||||
Name = None
|
||||
Type = SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent (getName unionType))
|
||||
}
|
||||
|> List.singleton
|
||||
}
|
||||
)
|
||||
|
||||
let recursiveCases (allUnionTypes : SynTypeDefn list) : InstructionCase list =
|
||||
allUnionTypes
|
||||
|> List.collect (fun unionType ->
|
||||
AstHelper.getUnionCases unionType
|
||||
|> List.choose (fun case -> getRecursiveInstruction allUnionTypes unionType case)
|
||||
)
|
||||
|
||||
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))
|
||||
]
|
||||
)
|
||||
baseCases allUnionTypes
|
||||
|> List.map (fun unionCase ->
|
||||
SynUnionCase.Create (unionCase.Name, unionCase.Fields |> List.map (fun f -> SynField.Create f.Type))
|
||||
)
|
||||
|
||||
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
|
||||
)
|
||||
recursiveCases allUnionTypes
|
||||
|> List.map (fun case ->
|
||||
SynUnionCase.Create (case.Name, case.Fields |> List.map (fun field -> SynField.Create field.Type))
|
||||
)
|
||||
|
||||
let cases = casesFromProcess @ casesFromCases
|
||||
@@ -306,6 +336,585 @@ module internal CataGenerator =
|
||||
}
|
||||
)
|
||||
|
||||
let createCataStructure (allUnionTypes : SynTypeDefn list) : SynTypeDefn list =
|
||||
let generics =
|
||||
allUnionTypes
|
||||
|> List.map (fun defn ->
|
||||
let name = getName defn |> List.map _.idText |> String.concat "" |> Ident.Create
|
||||
SynTypar.SynTypar (name, TyparStaticReq.None, false)
|
||||
)
|
||||
|
||||
let tyToGenericMap =
|
||||
let names = allUnionTypes |> List.map getNameKey
|
||||
List.zip names generics |> Map.ofList
|
||||
|
||||
allUnionTypes
|
||||
|> List.map (fun unionType ->
|
||||
let name =
|
||||
match getName unionType |> List.rev with
|
||||
| [] -> failwith "empty name"
|
||||
| head :: rest -> Ident.Create (head.idText + "Cata") :: rest |> List.rev
|
||||
|
||||
let componentInfo =
|
||||
let generics = generics |> List.map (fun ty -> SynTyparDecl.SynTyparDecl ([], ty))
|
||||
|
||||
SynComponentInfo.SynComponentInfo (
|
||||
[],
|
||||
Some (SynTyparDecls.PostfixList (generics, [], range0)),
|
||||
[],
|
||||
name,
|
||||
// TODO: better docstring
|
||||
PreXmlDoc.Create " Description of how to combine cases during a fold",
|
||||
false,
|
||||
None,
|
||||
range0
|
||||
)
|
||||
|
||||
let slots =
|
||||
let ourGenericName = tyToGenericMap.[getNameKey unionType]
|
||||
|
||||
let flags =
|
||||
{
|
||||
SynMemberFlags.IsInstance = true
|
||||
SynMemberFlags.IsDispatchSlot = true
|
||||
SynMemberFlags.IsOverrideOrExplicitImpl = false
|
||||
SynMemberFlags.IsFinal = false
|
||||
SynMemberFlags.GetterOrSetterIsCompilerGenerated = false
|
||||
SynMemberFlags.MemberKind = SynMemberKind.Member
|
||||
}
|
||||
|
||||
AstHelper.getUnionCases unionType
|
||||
|> List.map (fun case ->
|
||||
let caseName =
|
||||
match case.Name with
|
||||
| SynIdent.SynIdent (name, _) -> name
|
||||
|
||||
let arity =
|
||||
SynValInfo.SynValInfo (
|
||||
case.Fields |> List.map (fun field -> [ SynArgInfo.Empty ]),
|
||||
SynArgInfo.Empty
|
||||
)
|
||||
|
||||
let ty =
|
||||
// TODO: we should only have called this once; pass the resulting
|
||||
// data structure in, rather than rederiving it
|
||||
let analysed = analyse allUnionTypes case
|
||||
|
||||
(SynType.Var (ourGenericName, range0), List.rev analysed)
|
||||
||> List.fold (fun acc (_name, field) ->
|
||||
let place : SynType =
|
||||
match field with
|
||||
| FieldDescription.Self ty ->
|
||||
SynType.Var (tyToGenericMap.[getNameKeyUnion ty], range0)
|
||||
| FieldDescription.ListSelf ty ->
|
||||
SynType.CreateApp (
|
||||
SynType.CreateLongIdent "list",
|
||||
[ SynType.Var (tyToGenericMap.[getNameKeyUnion ty], range0) ],
|
||||
true
|
||||
)
|
||||
| FieldDescription.NonRecursive ty -> ty
|
||||
|
||||
SynType.Fun (
|
||||
place,
|
||||
acc,
|
||||
range0,
|
||||
{
|
||||
ArrowRange = range0
|
||||
}
|
||||
)
|
||||
)
|
||||
|
||||
let slot =
|
||||
SynValSig.SynValSig (
|
||||
[],
|
||||
case.Name,
|
||||
SynValTyparDecls.SynValTyparDecls (None, true),
|
||||
ty,
|
||||
arity,
|
||||
false,
|
||||
false,
|
||||
PreXmlDoc.Create $" How to operate on the %s{caseName.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
|
||||
}
|
||||
)
|
||||
)
|
||||
|
||||
let createCataRecord (allUnionTypes : SynTypeDefn list) : SynTypeDefn =
|
||||
let nameForDoc = List.last (getName allUnionTypes.[0]) |> _.idText
|
||||
|
||||
let generics =
|
||||
allUnionTypes
|
||||
|> List.map (fun defn ->
|
||||
let name = getName defn |> List.map _.idText |> String.concat "" |> Ident.Create
|
||||
SynTypar.SynTypar (name, TyparStaticReq.None, false)
|
||||
)
|
||||
|
||||
let fields =
|
||||
allUnionTypes
|
||||
|> List.map (fun unionType ->
|
||||
let doc = PreXmlDoc.Create " TODO: doc"
|
||||
let name = getName unionType
|
||||
|
||||
let ty =
|
||||
SynType.App (
|
||||
SynType.CreateLongIdent (SynLongIdent.CreateString (List.last(name).idText + "Cata")),
|
||||
Some range0,
|
||||
generics |> List.map (fun v -> SynType.Var (v, range0)),
|
||||
List.replicate (generics.Length - 1) range0,
|
||||
Some range0,
|
||||
false,
|
||||
range0
|
||||
)
|
||||
|
||||
SynField.SynField (
|
||||
[],
|
||||
false,
|
||||
Some (List.last name),
|
||||
ty,
|
||||
false,
|
||||
doc,
|
||||
None,
|
||||
range0,
|
||||
{
|
||||
LeadingKeyword = None
|
||||
}
|
||||
)
|
||||
)
|
||||
|
||||
let componentInfo =
|
||||
SynComponentInfo.SynComponentInfo (
|
||||
[],
|
||||
Some (
|
||||
SynTyparDecls.PostfixList (
|
||||
generics |> List.map (fun ty -> SynTyparDecl.SynTyparDecl ([], ty)),
|
||||
[],
|
||||
range0
|
||||
)
|
||||
),
|
||||
[],
|
||||
[ Ident.Create "Cata" ], // TODO: better name
|
||||
PreXmlDoc.Create $" Specifies how to perform a fold (catamorphism) over the type %s{nameForDoc}.",
|
||||
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 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 |> Ident.lowerFirstLetter
|
||||
)
|
||||
|
||||
// A clause for each type, splitting it into its cases:
|
||||
let baseMatchClauses =
|
||||
List.zip stackNames allUnionTypes
|
||||
|> List.map (fun (stackName, unionType) ->
|
||||
let cases = AstHelper.getUnionCases 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.
|
||||
// TODO
|
||||
SynExpr.CreateConst SynConst.Unit
|
||||
|
||||
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 : SynMatchClause list =
|
||||
allUnionTypes
|
||||
|> List.collect (fun unionType ->
|
||||
let cases = AstHelper.getUnionCases unionType
|
||||
|
||||
cases
|
||||
|> List.choose (fun case ->
|
||||
let analysis = analyse allUnionTypes case
|
||||
// We already know there is a recursive reference somewhere
|
||||
// in `analysis`.
|
||||
if
|
||||
analysis
|
||||
|> List.exists (fun (_, ty) ->
|
||||
match ty with
|
||||
| NonRecursive _ -> false
|
||||
| _ -> true
|
||||
)
|
||||
then
|
||||
Some (case, analysis)
|
||||
else
|
||||
None
|
||||
)
|
||||
|> List.map (fun (case, analysis) ->
|
||||
let lhsNames =
|
||||
analysis
|
||||
|> Seq.mapi (fun i x -> (i, x))
|
||||
|> Seq.choose (fun (i, (name, desc)) ->
|
||||
match desc with
|
||||
| FieldDescription.NonRecursive _ ->
|
||||
match name with
|
||||
| None -> Ident.Create $"arg%i{i}"
|
||||
| Some name -> name
|
||||
|> SynPat.CreateNamed
|
||||
|> Some
|
||||
| FieldDescription.ListSelf _ -> Ident.Create "n" |> SynPat.CreateNamed |> 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 (
|
||||
SynLongIdent.CreateFromLongIdent
|
||||
[ Ident.Create "Instruction" ; getInstructionCaseName unionType case ],
|
||||
None,
|
||||
None,
|
||||
SynArgPats.Pats lhs,
|
||||
None,
|
||||
range0
|
||||
)
|
||||
|
||||
let body = [ SynExpr.CreateConst SynConst.Unit ] |> SynExpr.CreateSequential
|
||||
|
||||
SynMatchClause.SynMatchClause (
|
||||
pat,
|
||||
None,
|
||||
body,
|
||||
range0,
|
||||
DebugPointAtTarget.Yes,
|
||||
{
|
||||
ArrowRange = Some range0
|
||||
BarRange = Some range0
|
||||
}
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
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.CreateApp (
|
||||
SynExpr.CreateAppInfix (
|
||||
SynExpr.CreateLongIdent (
|
||||
SynLongIdent.SynLongIdent (
|
||||
[ Ident.Create "op_GreaterThan" ],
|
||||
[],
|
||||
[ Some (IdentTrivia.OriginalNotation ">") ]
|
||||
)
|
||||
),
|
||||
SynExpr.CreateLongIdent (SynLongIdent.Create [ "instructions" ; "Count" ])
|
||||
),
|
||||
SynExpr.CreateConst (SynConst.Int32 0)
|
||||
|
||||
),
|
||||
body,
|
||||
range0
|
||||
)
|
||||
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,
|
||||
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)
|
||||
@@ -313,11 +922,8 @@ module internal CataGenerator =
|
||||
(allUnionTypes : SynTypeDefn list)
|
||||
: SynModuleOrNamespace
|
||||
=
|
||||
let moduleName : LongIdent =
|
||||
List.last (getName taggedType)
|
||||
|> fun x -> x.idText + "Cata"
|
||||
|> Ident.Create
|
||||
|> List.singleton
|
||||
let parentName = List.last (getName taggedType) |> _.idText
|
||||
let moduleName : LongIdent = parentName + "Cata" |> Ident.Create |> List.singleton
|
||||
|
||||
let attribs = [ SynAttributeList.Create (SynAttribute.RequireQualifiedAccess ()) ]
|
||||
|
||||
@@ -325,15 +931,14 @@ module internal CataGenerator =
|
||||
SynComponentInfo.Create (
|
||||
moduleName,
|
||||
attributes = attribs,
|
||||
xmldoc = PreXmlDoc.Create " Catamorphism" // TODO: better docstring
|
||||
xmldoc = PreXmlDoc.Create $" Methods to perform a catamorphism over the type {parentName}"
|
||||
)
|
||||
|
||||
let allTypars =
|
||||
allUnionTypes
|
||||
|> List.map (fun unionType ->
|
||||
List.last (getName unionType)
|
||||
|> fun x -> x.idText
|
||||
|> fun s -> s + "Ret"
|
||||
|> fun x -> x.idText + "Ret"
|
||||
|> Ident.Create
|
||||
|> fun x -> SynTypar.SynTypar (x, TyparStaticReq.None, false)
|
||||
|> fun x -> SynType.Var (x, range0)
|
||||
@@ -343,18 +948,28 @@ module internal CataGenerator =
|
||||
List.zip allUnionTypes allTypars
|
||||
|> List.map (fun (unionType, relevantTypar) -> createRunFunction allTypars relevantTypar unionType)
|
||||
|
||||
let cataStructures =
|
||||
createCataStructure allUnionTypes
|
||||
|> List.map (fun repr -> SynModuleDecl.Types ([ repr ], range0))
|
||||
|
||||
let loopFunction = createLoopFunction allUnionTypes
|
||||
|
||||
let cataRecord = SynModuleDecl.Types ([ createCataRecord allUnionTypes ], 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 allUnionTypes ], range0)
|
||||
SynModuleDecl.CreateLet runFunctions
|
||||
SynModuleDecl.CreateLet (loopFunction :: runFunctions)
|
||||
]
|
||||
)
|
||||
]
|
||||
|
||||
@@ -756,12 +756,6 @@ module internal HttpClientGenerator =
|
||||
| _ -> None
|
||||
)
|
||||
|
||||
let lowerFirstLetter (x : Ident) : Ident =
|
||||
let result = StringBuilder x.idText.Length
|
||||
result.Append (Char.ToLowerInvariant x.idText.[0]) |> ignore
|
||||
result.Append x.idText.[1..] |> ignore
|
||||
Ident.Create ((result : StringBuilder).ToString ())
|
||||
|
||||
let createModule
|
||||
(opens : SynOpenDeclTarget list)
|
||||
(ns : LongIdent)
|
||||
@@ -891,7 +885,7 @@ module internal HttpClientGenerator =
|
||||
Some (SynBindingReturnInfo.Create pi.Type),
|
||||
SynExpr.CreateApp (
|
||||
SynExpr.CreateLongIdent (
|
||||
SynLongIdent.CreateFromLongIdent [ lowerFirstLetter pi.Identifier ]
|
||||
SynLongIdent.CreateFromLongIdent [ Ident.lowerFirstLetter pi.Identifier ]
|
||||
),
|
||||
SynExpr.CreateConst SynConst.Unit
|
||||
),
|
||||
@@ -927,7 +921,7 @@ module internal HttpClientGenerator =
|
||||
properties
|
||||
|> List.map (fun (_, pi) ->
|
||||
SynPat.CreateTyped (
|
||||
SynPat.CreateNamed (lowerFirstLetter pi.Identifier),
|
||||
SynPat.CreateNamed (Ident.lowerFirstLetter pi.Identifier),
|
||||
SynType.CreateFun (SynType.CreateLongIdent "unit", pi.Type)
|
||||
)
|
||||
|> SynPat.CreateParen
|
||||
|
||||
14
WoofWare.Myriad.Plugins/Ident.fs
Normal file
14
WoofWare.Myriad.Plugins/Ident.fs
Normal file
@@ -0,0 +1,14 @@
|
||||
namespace WoofWare.Myriad.Plugins
|
||||
|
||||
open System
|
||||
open System.Text
|
||||
open Fantomas.FCS.Syntax
|
||||
open Myriad.Core
|
||||
|
||||
[<RequireQualifiedAccess>]
|
||||
module internal Ident =
|
||||
let lowerFirstLetter (x : Ident) : Ident =
|
||||
let result = StringBuilder x.idText.Length
|
||||
result.Append (Char.ToLowerInvariant x.idText.[0]) |> ignore
|
||||
result.Append x.idText.[1..] |> ignore
|
||||
Ident.Create ((result : StringBuilder).ToString ())
|
||||
@@ -275,3 +275,19 @@ module internal SynExpr =
|
||||
else
|
||||
SynLeadingKeyword.Let range0
|
||||
}
|
||||
|
||||
/// {ident} - {n}
|
||||
let minusN (ident : SynLongIdent) (n : int) : SynExpr =
|
||||
SynExpr.CreateApp (
|
||||
SynExpr.CreateAppInfix (
|
||||
SynExpr.CreateLongIdent (
|
||||
SynLongIdent.SynLongIdent (
|
||||
[ Ident.Create "op_Subtraction" ],
|
||||
[],
|
||||
[ Some (IdentTrivia.OriginalNotation "-") ]
|
||||
)
|
||||
),
|
||||
SynExpr.CreateLongIdent ident
|
||||
),
|
||||
SynExpr.CreateConst (SynConst.Int32 n)
|
||||
)
|
||||
|
||||
@@ -25,6 +25,7 @@
|
||||
|
||||
<ItemGroup>
|
||||
<Compile Include="List.fs"/>
|
||||
<Compile Include="Ident.fs" />
|
||||
<Compile Include="AstHelper.fs"/>
|
||||
<Compile Include="SynExpr.fs"/>
|
||||
<Compile Include="SynType.fs"/>
|
||||
|
||||
Reference in New Issue
Block a user