patrick/WoofWare.Myriad
1
0
Fork 0
mirror of https://github.com/Smaug123/WoofWare.Myriad synced 2025-10-06 04:28:42 +00:00
Code Issues Packages Projects Releases Wiki Activity

Another grand refactor (#150)

Browse Source
This commit is contained in:
Patrick Stevens
2024-05-30 20:34:53 +01:00
committed by GitHub
parent 94b88a4143
commit 81b7e5361d
14 changed files with 1138 additions and 1587 deletions
Download Patch File Download Diff File Expand all files Collapse all files

666
WoofWare.Myriad.Plugins/CataGenerator.fs
View File

@@ -182,105 +182,53 @@ module internal CataGenerator =
)
)
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" + List.last(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.CreateLongIdent analysis.AssociatedProcessInstruction
|> SynExpr.applyTo (SynExpr.CreateLongIdent (SynLongIdent.CreateString "x"))
|> SynExpr.CreateParen
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "instructions" ; "Add" ])
// TODO: add the "all other stacks are empty" sanity checks
SynExpr.CreateIdent (Ident.Create (relevantTyparName.idText + "Stack") |> Ident.lowerFirstLetter)
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "Seq" ; "exactlyOne" ])
|> SynExpr.createLet
[
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.CreateLongIdent (SynLongIdent.Create [ "instructions" ; "Add" ]),
SynExpr.CreateParen (
SynExpr.CreateApp (
SynExpr.CreateLongIdent analysis.AssociatedProcessInstruction,
SynExpr.CreateLongIdent (SynLongIdent.CreateString "x")
)
)
SynExpr.CreateApp (SynExpr.CreateIdentString "loop", SynExpr.CreateIdentString "cata"),
SynExpr.CreateIdentString "instructions"
)
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
)
)
]
]
|> SynExpr.CreateSequential
|> SynExpr.createLet
[
SynExpr.CreateIdentString "ResizeArray"
|> SynExpr.applyTo (SynExpr.CreateConst SynConst.Unit)
|> SynBinding.basic (SynLongIdent.CreateString "instructions") []
]
|> SynExpr.typeAnnotate relevantTypar
|> SynBinding.basic
(SynLongIdent.CreateString ("run" + List.last(relevantTypeName).idText))
[ SynPat.CreateParen cataObject ; SynPat.CreateParen inputObject ]
|> SynBinding.withReturnAnnotation relevantTypar
|> SynBinding.withXmlDoc (PreXmlDoc.Create " Execute the catamorphism.")
let getName (ty : SynTypeDefn) : LongIdent =
match ty with
@@ -979,37 +927,29 @@ module internal CataGenerator =
// 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
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.
listSelfArgs
|> List.map (fun (i, argName, _) ->
i,
SynExpr.CreateParen (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "List" ; "length" ]),
SynExpr.CreateIdent argName
)
)
|> SynExpr.CreateParen
)
)
|> List.append (
nonRecursiveArgs |> List.map (fun (i, arg, _) -> i, SynExpr.CreateIdent arg)
)
|> List.sortBy fst
|> List.map snd
|> SynExpr.CreateParenedTuple
|> SynExpr.applyFunction (SynExpr.CreateLongIdent unionCase.AssociatedInstruction)
|> SynExpr.CreateParen
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "instructions" ; "Add" ])
[
yield reprocessCommand
@@ -1044,51 +984,43 @@ module internal CataGenerator =
// 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.CreateLongIdent (
// TODO: use an AssociatedProcessInstruction instead
SynLongIdent.Create
[
"Instruction"
// TODO wonky domain
"Process" + "__" + List.last(getNameUnion(synType).Value).idText
]
)
|> SynExpr.applyTo (SynExpr.CreateIdent caseDesc.ArgName)
|> SynExpr.CreateParen
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "instructions" ; "Add" ])
]
|> 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.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
)
SynPat.Record (fields, range0)
),
List.replicate (unionCase.Fields.Length - 1) range0,
range0
)
|> SynPat.CreateParen
|> List.singleton
else
[]
@@ -1187,160 +1119,81 @@ module internal CataGenerator =
// TODO: this is jank
let stackName = inputStacks.[List.last(getNameUnion(synType).Value).idText]
SynExpr.LetOrUse (
false,
false,
SynExpr.minusN (SynLongIdent.CreateFromLongIdent [ stackName ; Ident.Create "Count" ]) 1
|> SynExpr.CreateParen
|> SynExpr.applyFunction (
SynExpr.createLongIdent' [ stackName ; Ident.Create "RemoveAt" ]
)
|> SynExpr.createLet
[
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.DotIndexedGet (
SynExpr.CreateIdent stackName,
SynExpr.minusN
(SynLongIdent.CreateFromLongIdent [ stackName ; Ident.Create "Count" ])
1
1,
range0,
range0
)
),
range0,
{
InKeyword = None
}
)
|> SynBinding.basic (SynLongIdent.CreateFromLongIdent [ field.ArgName ]) []
]
|> Some
| ListSelf synType ->
// TODO: also jank
let stackName = inputStacks.[List.last(getNameUnion(synType).Value).idText]
let vals =
SynBinding.SynBinding (
None,
SynBindingKind.Normal,
SynExpr.ComputationExpr (
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
),
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,
DebugPointAtBinding.Yes range0,
SynExpr.synBindingTriviaZero false
),
range0
),
range0
),
range0
)
|> SynExpr.applyFunction (SynExpr.CreateIdentString "seq")
|> SynExpr.pipeThroughFunction (SynExpr.createLongIdent [ "Seq" ; "toList" ])
|> SynBinding.basic (SynLongIdent.CreateFromLongIdent [ field.ArgName ]) []
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
}
[
SynExpr.minus
(SynLongIdent.CreateFromLongIdent [ stackName ; Ident.Create "Count" ])
(SynExpr.CreateIdent shadowedIdent)
SynExpr.CreateIdent shadowedIdent
]
|> SynExpr.CreateParenedTuple
|> SynExpr.applyFunction (
SynExpr.createLongIdent' [ stackName ; Ident.Create "RemoveRange" ]
)
|> SynExpr.createLet [ vals ]
|> SynExpr.createLet
[
SynBinding.basic
(SynLongIdent.CreateFromLongIdent [ shadowedIdent ])
[]
(SynExpr.CreateIdent field.ArgName)
]
|> Some
)
@@ -1359,19 +1212,6 @@ module internal CataGenerator =
)
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
)
let userSuppliedGenerics =
analysis
|> List.collect _.Typars
@@ -1401,45 +1241,37 @@ module internal CataGenerator =
yield SynType.Var (SynTypar.SynTypar (case.GenericName, TyparStaticReq.None, false), range0)
]
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,
cataGenerics,
List.replicate (cataGenerics.Length - 1) range0,
Some range0,
false,
range0
)
)
let args =
[
SynPat.CreateParen (
SynPat.CreateTyped (
SynPat.CreateNamed cataVarName,
SynType.App (
SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ cataTypeName ]),
Some range0,
cataGenerics,
List.replicate (cataGenerics.Length - 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
)
)
)
)
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
@@ -1449,47 +1281,24 @@ module internal CataGenerator =
SynExpr.CreateMatch (SynExpr.CreateIdentString "currentInstruction", baseMatchClauses @ recMatchClauses)
let body =
SynExpr.CreateSequential
[
SynExpr.CreateApp (
SynExpr.createLongIdent [ "instructions" ; "RemoveAt" ],
SynExpr.CreateParen (SynExpr.minusN (SynLongIdent.Create [ "instructions" ; "Count" ]) 1)
)
matchStatement
]
|> SynExpr.CreateSequential
|> SynExpr.createLet
[
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
),
SynExpr.DotIndexedGet (
SynExpr.CreateIdentString "instructions",
SynExpr.minusN (SynLongIdent.Create [ "instructions" ; "Count" ]) 1,
range0,
DebugPointAtBinding.Yes range0,
SynExpr.synBindingTriviaZero false
range0
)
],
body,
range0,
{
InKeyword = None
}
)
|> SynBinding.basic (SynLongIdent.CreateString "currentInstruction") []
]
let body =
SynExpr.CreateSequential
@@ -1498,82 +1307,43 @@ module internal CataGenerator =
DebugPointAtWhile.Yes range0,
SynExpr.greaterThan
(SynExpr.CreateConst (SynConst.Int32 0))
(SynExpr.CreateLongIdent (SynLongIdent.Create [ "instructions" ; "Count" ])),
(SynExpr.createLongIdent [ "instructions" ; "Count" ]),
body,
range0
)
SynExpr.CreateTuple (
analysis
|> List.map (fun unionAnalysis ->
[ unionAnalysis.StackName ]
|> SynLongIdent.CreateFromLongIdent
|> SynExpr.CreateLongIdent
)
|> List.map (fun unionAnalysis -> [ unionAnalysis.StackName ] |> SynExpr.createLongIdent')
)
]
let body =
(body, analysis)
||> List.fold (fun body unionCase ->
SynExpr.LetOrUse (
false,
false,
body
|> SynExpr.createLet
[
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.TypeApp (
SynExpr.CreateIdent (Ident.Create "ResizeArray"),
range0,
[
SynType.Var (
SynTypar.SynTypar (unionCase.GenericName, TyparStaticReq.None, false),
range0
)
],
[],
Some range0,
range0,
range0
),
SynExpr.CreateConst SynConst.Unit
),
SynExpr.TypeApp (
SynExpr.CreateIdent (Ident.Create "ResizeArray"),
range0,
DebugPointAtBinding.Yes range0,
SynExpr.synBindingTriviaZero false
[
SynType.Var (
SynTypar.SynTypar (unionCase.GenericName, TyparStaticReq.None, false),
range0
)
],
[],
Some range0,
range0,
range0
)
],
body,
range0,
{
SynExprLetOrUseTrivia.InKeyword = None
}
)
|> SynExpr.applyTo (SynExpr.CreateConst SynConst.Unit)
|> SynBinding.basic (SynLongIdent.CreateFromLongIdent [ unionCase.StackName ]) []
]
)
SynBinding.SynBinding (
Some (SynAccess.Private range0),
SynBindingKind.Normal,
false,
false,
[],
PreXmlDoc.Empty,
valData,
headPat,
None,
body,
range0,
DebugPointAtBinding.NoneAtLet,
trivia = SynExpr.synBindingTriviaZero false
)
SynBinding.basic (SynLongIdent.CreateString "loop") args body
|> SynBinding.withAccessibility (Some (SynAccess.Private range0))
let createModule
(opens : SynOpenDeclTarget list)

204
WoofWare.Myriad.Plugins/HttpClientGenerator.fs
View File

@@ -274,9 +274,7 @@ module internal HttpClientGenerator =
SynExpr.CreateConstString ("{" + substituteId + "}")
SynExpr.callMethod "ToString" (SynExpr.CreateIdent varName)
|> SynExpr.pipeThroughFunction (
SynExpr.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Web" ; "HttpUtility" ; "UrlEncode" ]
)
SynExpr.createLongIdent [ "System" ; "Web" ; "HttpUtility" ; "UrlEncode" ]
)
])
| _ -> template
@@ -316,12 +314,9 @@ module internal HttpClientGenerator =
let urlSeparator =
// apparent Myriad bug: `IndexOf '?'` gets formatted as `IndexOf ?` which is clearly wrong
let questionMark =
SynExpr.CreateParen (
SynExpr.CreateApp (
SynExpr.CreateIdentString "char",
SynExpr.CreateConst (SynConst.Int32 63)
)
)
SynExpr.CreateConst (SynConst.Int32 63)
|> SynExpr.applyFunction (SynExpr.CreateIdentString "char")
|> SynExpr.CreateParen
let containsQuestion =
info.UrlTemplate
@@ -354,9 +349,7 @@ module internal HttpClientGenerator =
SynExpr.toString paramValue.Type (SynExpr.CreateIdent paramValueId)
|> SynExpr.CreateParen
|> SynExpr.pipeThroughFunction (
SynExpr.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Web" ; "HttpUtility" ; "UrlEncode" ]
)
SynExpr.createLongIdent [ "System" ; "Web" ; "HttpUtility" ; "UrlEncode" ]
)
|> SynExpr.CreateParen
|> SynExpr.plus (SynExpr.plus uri (SynExpr.CreateConstString ("&" + paramKey + "=")))
@@ -365,48 +358,31 @@ module internal HttpClientGenerator =
|> SynExpr.CreateParen
let requestUri =
let uriIdent = SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "Uri" ])
let uriIdent = SynExpr.createLongIdent [ "System" ; "Uri" ]
let baseAddress = SynExpr.createLongIdent [ "client" ; "BaseAddress" ]
let baseAddress =
SynExpr.CreateLongIdent (SynLongIdent.Create [ "client" ; "BaseAddress" ])
let baseAddress =
SynExpr.CreateMatch (
baseAddress,
[
SynMatchClause.Create (
SynPat.CreateNull,
None,
match info.BaseAddress with
| None ->
SynExpr.CreateApp (
SynExpr.CreateIdentString "raise",
SynExpr.CreateParen (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (
SynLongIdent.Create [ "System" ; "ArgumentNullException" ]
),
SynExpr.CreateParenedTuple
[
SynExpr.CreateApp (
SynExpr.CreateIdentString "nameof",
SynExpr.CreateParen baseAddress
)
SynExpr.CreateConstString
"No base address was supplied on the type, and no BaseAddress was on the HttpClient."
]
)
)
)
| Some expr -> SynExpr.CreateApp (uriIdent, expr)
)
SynMatchClause.Create (
SynPat.CreateNamed (Ident.Create "v"),
None,
SynExpr.CreateIdentString "v"
)
]
)
[
SynMatchClause.Create (
SynPat.CreateNull,
None,
match info.BaseAddress with
| None ->
[
SynExpr.CreateApp (SynExpr.CreateIdentString "nameof", SynExpr.CreateParen baseAddress)
SynExpr.CreateConstString
"No base address was supplied on the type, and no BaseAddress was on the HttpClient."
]
|> SynExpr.CreateParenedTuple
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "System" ; "ArgumentNullException" ])
|> SynExpr.CreateParen
|> SynExpr.applyFunction (SynExpr.CreateIdentString "raise")
| Some expr -> SynExpr.CreateApp (uriIdent, expr)
)
SynMatchClause.Create (SynPat.CreateNamed (Ident.Create "v"), None, SynExpr.CreateIdentString "v")
]
|> SynExpr.createMatch baseAddress
|> SynExpr.CreateParen
SynExpr.App (
@@ -421,7 +397,7 @@ module internal HttpClientGenerator =
SynExpr.CreateParenedTuple
[
requestUriTrailer
SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "UriKind" ; "Relative" ])
SynExpr.createLongIdent [ "System" ; "UriKind" ; "Relative" ]
]
)
],
@@ -461,10 +437,8 @@ module internal HttpClientGenerator =
[
SynExpr.equals
(SynExpr.CreateIdentString "Method")
(SynExpr.CreateLongIdent (
SynLongIdent.Create
[ "System" ; "Net" ; "Http" ; "HttpMethod" ; httpMethodString info.HttpMethod ]
))
(SynExpr.createLongIdent
[ "System" ; "Net" ; "Http" ; "HttpMethod" ; httpMethodString info.HttpMethod ])
SynExpr.equals (SynExpr.CreateIdentString "RequestUri") (SynExpr.CreateIdentString "uri")
]
|> SynExpr.CreateParenedTuple
@@ -599,9 +573,7 @@ module internal HttpClientGenerator =
"responseString",
SynExpr.awaitTask (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (
SynLongIdent.Create [ "response" ; "Content" ; "ReadAsStringAsync" ]
),
SynExpr.createLongIdent [ "response" ; "Content" ; "ReadAsStringAsync" ],
SynExpr.CreateIdentString "ct"
)
)
@@ -612,9 +584,7 @@ module internal HttpClientGenerator =
"responseStream",
SynExpr.awaitTask (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (
SynLongIdent.Create [ "response" ; "Content" ; "ReadAsStreamAsync" ]
),
SynExpr.createLongIdent [ "response" ; "Content" ; "ReadAsStreamAsync" ],
SynExpr.CreateIdentString "ct"
)
)
@@ -625,9 +595,7 @@ module internal HttpClientGenerator =
"jsonNode",
SynExpr.awaitTask (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ; "ParseAsync" ]
),
SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ; "ParseAsync" ],
SynExpr.CreateParenedTuple
[
SynExpr.CreateIdentString "responseStream"
@@ -644,15 +612,13 @@ module internal HttpClientGenerator =
|> List.map (fun (headerName, callToGetValue) ->
Do (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "httpMessage" ; "Headers" ; "Add" ]),
SynExpr.createLongIdent [ "httpMessage" ; "Headers" ; "Add" ],
SynExpr.CreateParenedTuple
[
headerName
SynExpr.CreateApp (
SynExpr.CreateLongIdent (
SynLongIdent.CreateFromLongIdent
[ Ident.Create "this" ; callToGetValue ; Ident.Create "ToString" ]
),
SynExpr.createLongIdent'
[ Ident.Create "this" ; callToGetValue ; Ident.Create "ToString" ],
SynExpr.CreateConst SynConst.Unit
)
]
@@ -665,14 +631,14 @@ module internal HttpClientGenerator =
|> List.map (fun (headerName, headerValue) ->
Do (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "httpMessage" ; "Headers" ; "Add" ]),
SynExpr.createLongIdent [ "httpMessage" ; "Headers" ; "Add" ],
SynExpr.CreateParenedTuple [ headerName ; headerValue ]
)
)
)
[
yield LetBang ("ct", SynExpr.CreateLongIdent (SynLongIdent.Create [ "Async" ; "CancellationToken" ]))
yield LetBang ("ct", SynExpr.createLongIdent [ "Async" ; "CancellationToken" ])
yield Let ("uri", requestUri)
yield
Use (
@@ -697,7 +663,7 @@ module internal HttpClientGenerator =
"response",
SynExpr.awaitTask (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "client" ; "SendAsync" ]),
SynExpr.createLongIdent [ "client" ; "SendAsync" ],
SynExpr.CreateParenedTuple
[ SynExpr.CreateIdentString "httpMessage" ; SynExpr.CreateIdentString "ct" ]
)
@@ -708,7 +674,7 @@ module internal HttpClientGenerator =
Let (
"response",
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "response" ; "EnsureSuccessStatusCode" ]),
SynExpr.createLongIdent [ "response" ; "EnsureSuccessStatusCode" ],
SynExpr.CreateConst SynConst.Unit
)
)
@@ -727,24 +693,23 @@ module internal HttpClientGenerator =
|> SynExpr.createCompExpr "async" returnExpr
|> SynExpr.startAsTask (SynLongIdent.CreateFromLongIdent [ cancellationTokenArg ])
SynMemberDefn.Member (
SynBinding.SynBinding (
info.Accessibility,
SynBindingKind.Normal,
false,
false,
[],
PreXmlDoc.Empty,
valData,
headPat,
None,
implementation,
range0,
DebugPointAtBinding.Yes range0,
SynExpr.synBindingTriviaZero true
),
range0
SynBinding.SynBinding (
None,
SynBindingKind.Normal,
false,
false,
[],
PreXmlDoc.Empty,
valData,
headPat,
None,
implementation,
range0,
DebugPointAtBinding.Yes range0,
SynBinding.triviaZero true
)
|> SynBinding.withAccessibility info.Accessibility
|> fun b -> SynMemberDefn.Member (b, range0)
let getHttpAttributes (attrs : SynAttribute list) : HttpAttribute list =
attrs
@@ -945,9 +910,7 @@ module internal HttpClientGenerator =
),
Some (SynBindingReturnInfo.Create pi.Type),
SynExpr.CreateApp (
SynExpr.CreateLongIdent (
SynLongIdent.CreateFromLongIdent [ Ident.lowerFirstLetter pi.Identifier ]
),
SynExpr.createLongIdent' [ Ident.lowerFirstLetter pi.Identifier ],
SynExpr.CreateConst SynConst.Unit
),
range0,
@@ -1031,43 +994,30 @@ module internal HttpClientGenerator =
None
)
let pattern =
SynPat.CreateLongIdent (SynLongIdent.CreateString "make", headerArgs @ [ clientCreationArg ])
let pattern = SynLongIdent.CreateString "make"
let returnInfo =
SynBindingReturnInfo.Create (SynType.LongIdent (SynLongIdent.CreateFromLongIdent interfaceType.Name))
SynType.LongIdent (SynLongIdent.CreateFromLongIdent interfaceType.Name)
let nameWithoutLeadingI =
List.last interfaceType.Name
|> _.idText
|> fun s ->
if s.StartsWith 'I' then
s.[1..]
s.Substring 1
else
failwith $"Expected interface type to start with 'I', but was: %s{s}"
let createFunc =
if spec.ExtensionMethods then
let binding =
SynBinding.SynBinding (
None,
SynBindingKind.Normal,
false,
false,
[],
xmlDoc,
valData,
pattern,
Some returnInfo,
interfaceImpl,
range0,
DebugPointAtBinding.NoneAtInvisible,
{
LeadingKeyword = SynLeadingKeyword.StaticMember (range0, range0)
InlineKeyword = None
EqualsRange = Some range0
}
)
SynBinding.basic
(SynLongIdent.CreateString "make")
(headerArgs @ [ clientCreationArg ])
interfaceImpl
|> SynBinding.withXmlDoc xmlDoc
|> SynBinding.makeStaticMember
|> SynBinding.withReturnAnnotation returnInfo
let mem = SynMemberDefn.Member (binding, range0)
@@ -1091,21 +1041,9 @@ module internal HttpClientGenerator =
SynModuleDecl.Types ([ containingType ], range0)
else
SynBinding.SynBinding (
None,
SynBindingKind.Normal,
false,
false,
[],
xmlDoc,
valData,
pattern,
Some returnInfo,
interfaceImpl,
range0,
DebugPointAtBinding.NoneAtLet,
SynExpr.synBindingTriviaZero false
)
SynBinding.basic (SynLongIdent.CreateString "make") (headerArgs @ [ clientCreationArg ]) interfaceImpl
|> SynBinding.withXmlDoc xmlDoc
|> SynBinding.withReturnAnnotation returnInfo
|> List.singleton
|> SynModuleDecl.CreateLet

191
WoofWare.Myriad.Plugins/InterfaceMockGenerator.fs
View File

@@ -46,66 +46,31 @@ module internal InterfaceMockGenerator =
)
|> Set.ofSeq
let synValData =
{
SynMemberFlags.IsInstance = false
SynMemberFlags.IsDispatchSlot = false
SynMemberFlags.IsOverrideOrExplicitImpl = false
SynMemberFlags.IsFinal = false
SynMemberFlags.GetterOrSetterIsCompilerGenerated = false
SynMemberFlags.MemberKind = SynMemberKind.Member
}
let failwithFun =
SynExpr.createLambda
"x"
(SynExpr.CreateApp (
SynExpr.CreateIdentString "raise",
SynExpr.CreateParen (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "NotImplementedException" ]),
SynExpr.CreateConstString "Unimplemented mock function"
)
)
))
let constructorIdent =
let generics =
interfaceType.Generics
|> Option.map (fun generics -> SynValTyparDecls (Some generics, false))
SynPat.LongIdent (
SynLongIdent.CreateString "Empty",
None,
None, // no generics on the "Empty", only on the return type
SynArgPats.Pats (
if generics.IsNone then
[]
else
[ SynPat.CreateParen (SynPat.CreateConst SynConst.Unit) ]
),
None,
range0
)
SynExpr.createLongIdent [ "System" ; "NotImplementedException" ]
|> SynExpr.applyTo (SynExpr.CreateConstString "Unimplemented mock function")
|> SynExpr.CreateParen
|> SynExpr.applyFunction (SynExpr.CreateIdentString "raise")
|> SynExpr.createLambda "_"
let constructorReturnType =
match interfaceType.Generics with
| None -> SynType.CreateLongIdent name
| Some generics ->
let generics =
generics.TyparDecls
|> List.map (fun (SynTyparDecl (_, typar)) -> SynType.Var (typar, range0))
SynType.App (
SynType.CreateLongIdent name,
Some range0,
generics,
List.replicate (generics.Length - 1) range0,
Some range0,
false,
range0
)
|> SynBindingReturnInfo.Create
let generics =
generics.TyparDecls
|> List.map (fun (SynTyparDecl (_, typar)) -> SynType.Var (typar, range0))
SynType.App (
SynType.CreateLongIdent name,
Some range0,
generics,
List.replicate (generics.Length - 1) range0,
Some range0,
false,
range0
)
let constructorFields =
let extras =
@@ -125,26 +90,17 @@ module internal InterfaceMockGenerator =
extras @ nonExtras
let constructor =
SynMemberDefn.Member (
SynBinding.SynBinding (
None,
SynBindingKind.Normal,
false,
false,
[],
PreXmlDoc.Create " An implementation where every method throws.",
SynValData.SynValData (Some synValData, SynValInfo.Empty, None),
constructorIdent,
Some constructorReturnType,
AstHelper.instantiateRecord constructorFields,
range0,
DebugPointAtBinding.Yes range0,
{ SynExpr.synBindingTriviaZero true with
LeadingKeyword = SynLeadingKeyword.StaticMember (range0, range0)
}
),
range0
)
SynBinding.basic
(SynLongIdent.CreateString "Empty")
(if interfaceType.Generics.IsNone then
[]
else
[ SynPat.CreateConst SynConst.Unit ])
(AstHelper.instantiateRecord constructorFields)
|> SynBinding.makeStaticMember
|> SynBinding.withXmlDoc (PreXmlDoc.Create " An implementation where every method throws.")
|> SynBinding.withReturnAnnotation constructorReturnType
|> fun m -> SynMemberDefn.Member (m, range0)
let fields =
let extras =
@@ -255,13 +211,9 @@ module internal InterfaceMockGenerator =
(last, rest)
||> List.fold (fun trail next -> SynExpr.CreateApp (next, trail))
|> fun args ->
SynExpr.CreateApp (
SynExpr.CreateLongIdent (
SynLongIdent.CreateFromLongIdent [ Ident.Create "this" ; memberInfo.Identifier ]
),
args
)
|> SynExpr.applyFunction (
SynExpr.createLongIdent' [ Ident.Create "this" ; memberInfo.Identifier ]
)
SynMemberDefn.Member (
SynBinding.SynBinding (
@@ -327,78 +279,13 @@ module internal InterfaceMockGenerator =
|> Seq.map (fun inheritance ->
match inheritance with
| KnownInheritance.IDisposable ->
let valData =
SynValData.SynValData (
Some
{
IsInstance = true
IsDispatchSlot = false
IsOverrideOrExplicitImpl = true
IsFinal = false
GetterOrSetterIsCompilerGenerated = false
MemberKind = SynMemberKind.Member
},
valInfo =
SynValInfo.SynValInfo (
curriedArgInfos =
[
yield
[
SynArgInfo.SynArgInfo (
attributes = [],
optional = false,
ident = None
)
]
],
returnInfo =
SynArgInfo.SynArgInfo (attributes = [], optional = false, ident = None)
),
thisIdOpt = None
)
let headArgs = [ SynPat.Const (SynConst.Unit, range0) ]
let headPat =
SynPat.LongIdent (
SynLongIdent.CreateFromLongIdent [ Ident.Create "this" ; Ident.Create "Dispose" ],
None,
None,
SynArgPats.Pats headArgs,
None,
range0
)
let binding =
SynBinding.SynBinding (
None,
SynBindingKind.Normal,
false,
false,
[],
PreXmlDoc.Empty,
valData,
headPat,
Some (
SynBindingReturnInfo.SynBindingReturnInfo (
SynType.Unit (),
range0,
[],
SynBindingReturnInfoTrivia.Zero
)
),
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "this" ; "Dispose" ]),
SynExpr.CreateUnit
),
range0,
DebugPointAtBinding.Yes range0,
{
LeadingKeyword = SynLeadingKeyword.Member range0
InlineKeyword = None
EqualsRange = Some range0
}
)
SynBinding.basic
(SynLongIdent.CreateFromLongIdent [ Ident.Create "this" ; Ident.Create "Dispose" ])
[ SynPat.CreateConst SynConst.Unit ]
(SynExpr.CreateApp (SynExpr.createLongIdent [ "this" ; "Dispose" ], SynExpr.CreateUnit))
|> SynBinding.withReturnAnnotation (SynType.Unit ())
|> SynBinding.makeInstanceMember
let mem = SynMemberDefn.Member (binding, range0)
@@ -473,7 +360,7 @@ module internal InterfaceMockGenerator =
|> _.idText
|> fun s ->
if s.StartsWith 'I' && s.Length > 1 && Char.IsUpper s.[1] then
s.[1..]
s.Substring 1
else
s
|> fun s -> s + "Mock"

297
WoofWare.Myriad.Plugins/JsonParseGenerator.fs
View File

@@ -31,24 +31,20 @@ module internal JsonParseGenerator =
let assertNotNull (propertyName : SynExpr) (indexed : SynExpr) =
let raiseExpr =
SynExpr.CreateApp (
SynExpr.CreateIdentString "raise",
SynExpr.CreateParen (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Collections" ; "Generic" ; "KeyNotFoundException" ]
),
SynExpr.CreateParen (
SynExpr.CreateApp (
SynExpr.CreateApp (
SynExpr.CreateIdentString "sprintf",
SynExpr.CreateConstString "Required key '%s' not found on JSON object"
),
SynExpr.CreateParen propertyName
)
)
)
SynExpr.CreateApp (
SynExpr.CreateIdentString "sprintf",
SynExpr.CreateConstString "Required key '%s' not found on JSON object"
),
SynExpr.CreateParen propertyName
)
|> SynExpr.CreateParen
|> SynExpr.applyFunction (
SynExpr.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Collections" ; "Generic" ; "KeyNotFoundException" ]
)
)
|> SynExpr.CreateParen
|> SynExpr.applyFunction (SynExpr.CreateIdentString "raise")
SynExpr.CreateMatch (
indexed,
@@ -139,37 +135,19 @@ module internal JsonParseGenerator =
/// fun kvp -> let key = {key(kvp)} in let value = {value(kvp)} in (key, value))
/// The inputs will be fed with appropriate SynExprs to apply them to the `kvp.Key` and `kvp.Value` args.
let dictionaryMapper (key : SynExpr -> SynExpr) (value : SynExpr -> SynExpr) : SynExpr =
let keyArg =
SynExpr.CreateLongIdent (SynLongIdent.Create [ "kvp" ; "Key" ])
|> SynExpr.CreateParen
let keyArg = SynExpr.createLongIdent [ "kvp" ; "Key" ] |> SynExpr.CreateParen
let valueArg =
SynExpr.CreateLongIdent (SynLongIdent.Create [ "kvp" ; "Value" ])
|> SynExpr.CreateParen
let valueArg = SynExpr.createLongIdent [ "kvp" ; "Value" ] |> SynExpr.CreateParen
SynExpr.LetOrUse (
false,
false,
SynExpr.CreateTuple [ SynExpr.CreateIdentString "key" ; SynExpr.CreateIdentString "value" ]
|> SynExpr.createLet
[
SynBinding.Let (pattern = SynPat.CreateNamed (Ident.Create "value"), expr = value valueArg)
]
|> SynExpr.createLet
[
SynBinding.Let (pattern = SynPat.CreateNamed (Ident.Create "key"), expr = key keyArg)
],
SynExpr.LetOrUse (
false,
false,
[
SynBinding.Let (pattern = SynPat.CreateNamed (Ident.Create "value"), expr = value valueArg)
],
SynExpr.CreateTuple [ SynExpr.CreateIdentString "key" ; SynExpr.CreateIdentString "value" ],
range0,
{
InKeyword = None
}
),
range0,
{
InKeyword = None
}
)
]
|> SynExpr.createLambda "kvp"
/// A conforming JSON object has only strings as keys. But it would be reasonable to allow the user
@@ -199,25 +177,19 @@ module internal JsonParseGenerator =
| DateOnly ->
node
|> asValueGetValue propertyName "string"
|> SynExpr.pipeThroughFunction (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "DateOnly" ; "Parse" ])
)
|> SynExpr.pipeThroughFunction (SynExpr.createLongIdent [ "System" ; "DateOnly" ; "Parse" ])
| Uri ->
node
|> asValueGetValue propertyName "string"
|> SynExpr.pipeThroughFunction (SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "Uri" ]))
|> SynExpr.pipeThroughFunction (SynExpr.createLongIdent [ "System" ; "Uri" ])
| Guid ->
node
|> asValueGetValue propertyName "string"
|> SynExpr.pipeThroughFunction (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "Guid" ; "Parse" ])
)
|> SynExpr.pipeThroughFunction (SynExpr.createLongIdent [ "System" ; "Guid" ; "Parse" ])
| DateTime ->
node
|> asValueGetValue propertyName "string"
|> SynExpr.pipeThroughFunction (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "DateTime" ; "Parse" ])
)
|> SynExpr.pipeThroughFunction (SynExpr.createLongIdent [ "System" ; "DateTime" ; "Parse" ])
| NumberType typeName ->
let basic = asValueGetValue propertyName typeName node
@@ -237,9 +209,7 @@ module internal JsonParseGenerator =
let handler =
asValueGetValue propertyName "string" node
|> SynExpr.pipeThroughFunction (
SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent (parseFunction typeName))
)
|> SynExpr.pipeThroughFunction (SynExpr.createLongIdent' (parseFunction typeName))
|> SynExpr.ifThenElse
(SynExpr.equals
option
@@ -325,10 +295,10 @@ module internal JsonParseGenerator =
)
|> SynExpr.pipeThroughFunction (SynExpr.CreateLongIdent (SynLongIdent.Create [ "Map" ; "ofSeq" ]))
| BigInt ->
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "Numerics" ; "BigInteger" ; "Parse" ]),
SynExpr.CreateParen (node |> SynExpr.callMethod "ToJsonString")
)
node
|> SynExpr.callMethod "ToJsonString"
|> SynExpr.CreateParen
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "System" ; "Numerics" ; "BigInteger" ; "Parse" ])
| _ ->
// Let's just hope that we've also got our own type annotation!
let typeName =
@@ -357,41 +327,59 @@ module internal JsonParseGenerator =
| [ _ ; "JsonNumberHandling" ; "Serialization" ; "Json" ; "Text" ; "System" ] -> true
| _ -> false
let createMaker (spec : JsonParseOutputSpec) (typeName : LongIdent) (fields : SynFieldData<Ident> list) =
/// `populateNode` will be inserted before we return the `node` variable.
///
/// That is, we give you access to a `JsonNode` called `node`,
/// and you must return a `typeName`.
let scaffolding (spec : JsonParseOutputSpec) (typeName : LongIdent) (functionBody : SynExpr) : SynModuleDecl =
let xmlDoc = PreXmlDoc.Create " Parse from a JSON node."
let returnInfo =
SynBindingReturnInfo.Create (SynType.LongIdent (SynLongIdent.CreateFromLongIdent typeName))
let returnInfo = SynType.LongIdent (SynLongIdent.CreateFromLongIdent typeName)
let inputArg = Ident.Create "node"
let functionName = Ident.Create "jsonParse"
let inputVal =
let memberFlags =
if spec.ExtensionMethods then
{
SynMemberFlags.IsInstance = false
SynMemberFlags.IsDispatchSlot = false
SynMemberFlags.IsOverrideOrExplicitImpl = false
SynMemberFlags.IsFinal = false
SynMemberFlags.GetterOrSetterIsCompilerGenerated = false
SynMemberFlags.MemberKind = SynMemberKind.Member
}
|> Some
else
None
let thisIdOpt = if spec.ExtensionMethods then None else Some inputArg
SynValData.SynValData (
memberFlags,
SynValInfo.SynValInfo ([ [ SynArgInfo.CreateId functionName ] ], SynArgInfo.Empty),
thisIdOpt
let arg =
SynPat.CreateNamed inputArg
|> SynPat.annotateType (
SynType.LongIdent (SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ])
)
if spec.ExtensionMethods then
let binding =
SynBinding.basic (SynLongIdent.CreateFromLongIdent [ functionName ]) [ arg ] functionBody
|> SynBinding.makeStaticMember
|> SynBinding.withXmlDoc xmlDoc
|> SynBinding.withReturnAnnotation returnInfo
let mem = SynMemberDefn.Member (binding, range0)
let containingType =
SynTypeDefn.SynTypeDefn (
SynComponentInfo.Create (typeName, xmldoc = PreXmlDoc.Create " Extension methods for JSON parsing"),
SynTypeDefnRepr.ObjectModel (SynTypeDefnKind.Augmentation range0, [], range0),
[ mem ],
None,
range0,
{
LeadingKeyword = SynTypeDefnLeadingKeyword.Type range0
EqualsRange = None
WithKeyword = None
}
)
SynModuleDecl.Types ([ containingType ], range0)
else
SynBinding.basic (SynLongIdent.CreateFromLongIdent [ functionName ]) [ arg ] functionBody
|> SynBinding.withXmlDoc xmlDoc
|> SynBinding.withReturnAnnotation returnInfo
|> List.singleton
|> SynModuleDecl.CreateLet
let createMaker (spec : JsonParseOutputSpec) (typeName : LongIdent) (fields : SynFieldData<Ident> list) =
let assignments =
fields
|> List.map (fun fieldData ->
|> List.mapi (fun i fieldData ->
let propertyNameAttr =
fieldData.Attrs
|> List.tryFind (fun attr ->
@@ -408,17 +396,15 @@ module internal JsonParseGenerator =
isJsonNumberHandling ident
->
// Make sure it's fully qualified
SynExpr.CreateLongIdent (
SynLongIdent.Create
[
"System"
"Text"
"Json"
"Serialization"
"JsonNumberHandling"
"AllowReadingFromString"
]
)
SynExpr.createLongIdent
[
"System"
"Text"
"Json"
"Serialization"
"JsonNumberHandling"
"AllowReadingFromString"
]
| _ -> attr.ArgExpr
{
@@ -440,119 +426,39 @@ module internal JsonParseGenerator =
sb.ToString () |> SynConst.CreateString |> SynExpr.CreateConst
| Some name -> name.ArgExpr
let pattern =
SynPat.LongIdent (
SynLongIdent.CreateFromLongIdent [ fieldData.Ident ],
None,
None,
SynArgPats.Empty,
None,
range0
)
SynBinding.Let (
isInline = false,
isMutable = false,
expr = createParseRhs options propertyName fieldData.Type,
valData = inputVal,
pattern = pattern
)
createParseRhs options propertyName fieldData.Type
|> SynBinding.basic (SynLongIdent.CreateString $"arg_%i{i}") []
)
let finalConstruction =
fields
|> List.map (fun fieldData ->
|> List.mapi (fun i fieldData ->
(SynLongIdent.CreateFromLongIdent [ fieldData.Ident ], true),
Some (SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ fieldData.Ident ]))
Some (SynExpr.CreateLongIdent (SynLongIdent.CreateString $"arg_%i{i}"))
)
|> AstHelper.instantiateRecord
let assignments =
(finalConstruction, assignments)
||> List.fold (fun final assignment ->
SynExpr.LetOrUse (
false,
false,
[ assignment ],
final,
range0,
{
InKeyword = None
}
)
)
||> List.fold (fun final assignment -> SynExpr.createLet [ assignment ] final)
let pattern =
SynPat.LongIdent (
SynLongIdent.CreateFromLongIdent [ functionName ],
None,
None,
SynArgPats.Pats
[
SynPat.CreateTyped (
SynPat.CreateNamed inputArg,
SynType.LongIdent (
SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ]
)
)
|> SynPat.CreateParen
],
None,
range0
)
assignments |> scaffolding spec typeName
if spec.ExtensionMethods then
let binding =
SynBinding.SynBinding (
None,
SynBindingKind.Normal,
false,
false,
[],
xmlDoc,
inputVal,
pattern,
Some returnInfo,
assignments,
range0,
DebugPointAtBinding.NoneAtInvisible,
{
LeadingKeyword = SynLeadingKeyword.StaticMember (range0, range0)
InlineKeyword = None
EqualsRange = Some range0
}
)
(*
let mem = SynMemberDefn.Member (binding, range0)
static member jsonParse (node : System.Text.Json.Nodes.JsonNode) : FirstDu =
let ty =
match node.["type"] with
| null -> raise (System.Collections.Generic.KeyNotFoundException ())
| v -> v.GetValue<string> ()
match ty with
| "emptyCase" -> FirstDu.EmptyCase
| "case1" ->
FirstDu.Case1
| "case2" -> FirstDu.Case2
| _ -> failwithf "Unrecognised case name: %s" ty
*)
let containingType =
SynTypeDefn.SynTypeDefn (
SynComponentInfo.Create (typeName, xmldoc = PreXmlDoc.Create " Extension methods for JSON parsing"),
SynTypeDefnRepr.ObjectModel (SynTypeDefnKind.Augmentation range0, [], range0),
[ mem ],
None,
range0,
{
LeadingKeyword = SynTypeDefnLeadingKeyword.Type range0
EqualsRange = None
WithKeyword = None
}
)
SynModuleDecl.Types ([ containingType ], range0)
else
let binding =
SynBinding.Let (
isInline = false,
isMutable = false,
xmldoc = xmlDoc,
returnInfo = returnInfo,
expr = assignments,
valData = inputVal,
pattern = pattern
)
SynModuleDecl.CreateLet [ binding ]
let createModule (namespaceId : LongIdent) (spec : JsonParseOutputSpec) (typeDefn : SynTypeDefn) =
let (SynTypeDefn (synComponentInfo, synTypeDefnRepr, _members, _implicitCtor, _, _)) =
@@ -606,6 +512,7 @@ module internal JsonParseGenerator =
let fields = fields |> List.map SynField.extractWithIdent
[ createMaker spec ident fields ]
| SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (_accessibility, cases, _range), _) ->
let cases = cases |> List.map SynUnionCase.extract
// [ createMaker spec ident cases ]
failwith "Unions are not yet supported"
| _ -> failwithf "Not a record or union type"

402
WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs
View File

@@ -30,9 +30,7 @@ module internal JsonSerializeGenerator =
| Uri ->
// JsonValue.Create<type>
SynExpr.TypeApp (
SynExpr.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonValue" ; "Create" ]
),
SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonValue" ; "Create" ],
range0,
[ fieldType ],
[],
@@ -42,39 +40,37 @@ module internal JsonSerializeGenerator =
)
| OptionType ty ->
// fun field -> match field with | None -> JsonValue.Create null | Some v -> {serializeNode ty} field
SynExpr.CreateMatch (
SynExpr.CreateIdentString "field",
[
SynMatchClause.Create (
SynPat.CreateLongIdent (SynLongIdent.CreateString "None", []),
None,
// The absolutely galaxy-brained implementation of JsonValue has `JsonValue.Parse "null"`
// identically equal to null. We have to work around this later, but we might as well just
// be efficient here and whip up the null directly.
SynExpr.CreateNull
|> SynExpr.upcast' (
SynType.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ]
)
[
SynMatchClause.Create (
SynPat.CreateLongIdent (SynLongIdent.CreateString "None", []),
None,
// The absolutely galaxy-brained implementation of JsonValue has `JsonValue.Parse "null"`
// identically equal to null. We have to work around this later, but we might as well just
// be efficient here and whip up the null directly.
SynExpr.CreateNull
|> SynExpr.upcast' (
SynType.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ]
)
)
)
SynMatchClause.Create (
SynPat.CreateLongIdent (
SynLongIdent.CreateString "Some",
[ SynPat.CreateNamed (Ident.Create "field") ]
),
None,
SynExpr.CreateApp (serializeNode ty, SynExpr.CreateIdentString "field")
|> SynExpr.CreateParen
|> SynExpr.upcast' (
SynType.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ]
)
SynMatchClause.Create (
SynPat.CreateLongIdent (
SynLongIdent.CreateString "Some",
[ SynPat.CreateNamed (Ident.Create "field") ]
),
None,
SynExpr.CreateApp (serializeNode ty, SynExpr.CreateIdentString "field")
|> SynExpr.CreateParen
|> SynExpr.upcast' (
SynType.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ]
)
)
]
)
)
]
|> SynExpr.createMatch (SynExpr.CreateIdentString "field")
|> SynExpr.createLambda "field"
| ArrayType ty
| ListType ty ->
@@ -82,43 +78,29 @@ module internal JsonSerializeGenerator =
// let arr = JsonArray ()
// for mem in field do arr.Add ({serializeNode} mem)
// arr
SynExpr.LetOrUse (
false,
false,
[
SynExpr.ForEach (
DebugPointAtFor.Yes range0,
DebugPointAtInOrTo.Yes range0,
SeqExprOnly.SeqExprOnly false,
true,
SynPat.CreateNamed (Ident.Create "mem"),
SynExpr.CreateIdent (Ident.Create "field"),
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "arr" ; "Add" ]),
SynExpr.CreateParen (SynExpr.CreateApp (serializeNode ty, SynExpr.CreateIdentString "mem"))
),
range0
)
SynExpr.CreateIdentString "arr"
]
|> SynExpr.CreateSequential
|> SynExpr.createLet
[
SynBinding.Let (
pattern = SynPat.CreateNamed (Ident.Create "arr"),
expr =
SynExpr.CreateApp (
SynExpr.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonArray" ]
),
SynExpr.CreateConst SynConst.Unit
)
)
],
SynExpr.CreateSequential
[
SynExpr.ForEach (
DebugPointAtFor.Yes range0,
DebugPointAtInOrTo.Yes range0,
SeqExprOnly.SeqExprOnly false,
true,
SynPat.CreateNamed (Ident.Create "mem"),
SynExpr.CreateIdent (Ident.Create "field"),
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "arr" ; "Add" ]),
SynExpr.CreateParen (
SynExpr.CreateApp (serializeNode ty, SynExpr.CreateIdentString "mem")
)
),
range0
)
SynExpr.CreateIdentString "arr"
],
range0,
SynExprLetOrUseTrivia.empty
)
SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonArray" ]
|> SynExpr.applyTo (SynExpr.CreateConst SynConst.Unit)
|> SynBinding.basic (SynLongIdent.CreateString "arr") []
]
|> SynExpr.createLambda "field"
| IDictionaryType (_keyType, valueType)
| DictionaryType (_keyType, valueType)
@@ -129,65 +111,53 @@ module internal JsonSerializeGenerator =
// for (KeyValue(key, value)) in field do
// ret.Add (key.ToString (), {serializeNode} value)
// ret
SynExpr.LetOrUse (
false,
false,
[
SynBinding.Let (
pattern = SynPat.CreateNamed (Ident.Create "ret"),
expr =
SynExpr.CreateApp (
SynExpr.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonObject" ]
),
SynExpr.CreateConst SynConst.Unit
)
)
],
SynExpr.CreateSequential
[
SynExpr.ForEach (
DebugPointAtFor.Yes range0,
DebugPointAtInOrTo.Yes range0,
SeqExprOnly.SeqExprOnly false,
true,
SynPat.CreateParen (
SynPat.CreateLongIdent (
SynLongIdent.CreateString "KeyValue",
[
SynPat.CreateParen (
SynPat.Tuple (
false,
[
SynPat.CreateNamed (Ident.Create "key")
SynPat.CreateNamed (Ident.Create "value")
],
[ range0 ],
range0
)
)
]
[
SynExpr.ForEach (
DebugPointAtFor.Yes range0,
DebugPointAtInOrTo.Yes range0,
SeqExprOnly.SeqExprOnly false,
true,
SynPat.CreateParen (
SynPat.CreateLongIdent (
SynLongIdent.CreateString "KeyValue",
[
SynPat.CreateParen (
SynPat.Tuple (
false,
[
SynPat.CreateNamed (Ident.Create "key")
SynPat.CreateNamed (Ident.Create "value")
],
[ range0 ],
range0
)
)
),
SynExpr.CreateIdent (Ident.Create "field"),
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "ret" ; "Add" ]),
SynExpr.CreateParenedTuple
[
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "key" ; "ToString" ]),
SynExpr.CreateConst SynConst.Unit
)
SynExpr.CreateApp (serializeNode valueType, SynExpr.CreateIdentString "value")
]
),
range0
]
)
SynExpr.CreateIdentString "ret"
],
range0,
SynExprLetOrUseTrivia.empty
)
),
SynExpr.CreateIdent (Ident.Create "field"),
SynExpr.CreateApp (
SynExpr.createLongIdent [ "ret" ; "Add" ],
SynExpr.CreateParenedTuple
[
SynExpr.CreateApp (
SynExpr.createLongIdent [ "key" ; "ToString" ],
SynExpr.CreateConst SynConst.Unit
)
SynExpr.CreateApp (serializeNode valueType, SynExpr.CreateIdentString "value")
]
),
range0
)
SynExpr.CreateIdentString "ret"
]
|> SynExpr.CreateSequential
|> SynExpr.createLet
[
SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonObject" ]
|> SynExpr.applyTo (SynExpr.CreateConst SynConst.Unit)
|> SynBinding.basic (SynLongIdent.CreateString "ret") []
]
|> SynExpr.createLambda "field"
| _ ->
// {type}.toJsonNode
@@ -196,24 +166,17 @@ module internal JsonSerializeGenerator =
| SynType.LongIdent ident -> ident.LongIdent
| _ -> failwith $"Unrecognised type: %+A{fieldType}"
SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent (typeName @ [ Ident.Create "toJsonNode" ]))
SynExpr.createLongIdent' (typeName @ [ Ident.Create "toJsonNode" ])
/// propertyName is probably a string literal, but it could be a [<Literal>] variable
/// `node.Add ({propertyName}, {toJsonNode})`
let createSerializeRhsRecord (propertyName : SynExpr) (fieldId : Ident) (fieldType : SynType) : SynExpr =
let func = SynExpr.CreateLongIdent (SynLongIdent.Create [ "node" ; "Add" ])
let args =
[
propertyName
SynExpr.CreateApp (
serializeNode fieldType,
SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ Ident.Create "input" ; fieldId ])
)
]
|> SynExpr.CreateParenedTuple
SynExpr.CreateApp (func, args)
[
propertyName
SynExpr.CreateApp (serializeNode fieldType, SynExpr.createLongIdent' [ Ident.Create "input" ; fieldId ])
]
|> SynExpr.CreateParenedTuple
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "node" ; "Add" ])
let getPropertyName (fieldId : Ident) (attrs : SynAttribute list) : SynExpr =
let propertyNameAttr =
@@ -247,98 +210,35 @@ module internal JsonSerializeGenerator =
let xmlDoc = PreXmlDoc.Create " Serialize to a JSON node"
let returnInfo =
SynBindingReturnInfo.Create (
SynType.LongIdent (SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ])
)
SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ]
|> SynType.LongIdent
let functionName = Ident.Create "toJsonNode"
let inputVal =
let memberFlags =
if spec.ExtensionMethods then
{
SynMemberFlags.IsInstance = false
SynMemberFlags.IsDispatchSlot = false
SynMemberFlags.IsOverrideOrExplicitImpl = false
SynMemberFlags.IsFinal = false
SynMemberFlags.GetterOrSetterIsCompilerGenerated = false
SynMemberFlags.MemberKind = SynMemberKind.Member
}
|> Some
else
None
let thisIdOpt = if spec.ExtensionMethods then None else Some inputArgName
SynValData.SynValData (
memberFlags,
SynValInfo.SynValInfo ([ [ SynArgInfo.CreateId functionName ] ], SynArgInfo.Empty),
thisIdOpt
)
let assignments =
SynExpr.LetOrUse (
false,
false,
[
populateNode
SynExpr.Upcast (SynExpr.CreateIdentString "node", SynType.Anon range0, range0)
]
|> SynExpr.CreateSequential
|> SynExpr.createLet
[
SynBinding.Let (
pattern = SynPat.CreateNamed (Ident.Create "node"),
expr =
SynExpr.CreateApp (
SynExpr.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonObject" ]
),
SynExpr.CreateConst SynConst.Unit
)
)
],
SynExpr.CreateSequential
[
populateNode
SynExpr.Upcast (SynExpr.CreateIdentString "node", SynType.Anon range0, range0)
],
range0,
SynExprLetOrUseTrivia.empty
)
SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonObject" ]
|> SynExpr.applyTo (SynExpr.CreateConst SynConst.Unit)
|> SynBinding.basic (SynLongIdent.CreateString "node") []
]
let pattern =
SynPat.LongIdent (
SynLongIdent.CreateFromLongIdent [ functionName ],
None,
None,
SynArgPats.Pats
[
SynPat.CreateTyped (
SynPat.CreateNamed inputArgName,
SynType.LongIdent (SynLongIdent.CreateFromLongIdent typeName)
)
|> SynPat.CreateParen
],
None,
range0
)
SynPat.CreateNamed inputArgName
|> SynPat.annotateType (SynType.LongIdent (SynLongIdent.CreateFromLongIdent typeName))
if spec.ExtensionMethods then
let binding =
SynBinding.SynBinding (
None,
SynBindingKind.Normal,
false,
false,
[],
xmlDoc,
inputVal,
pattern,
Some returnInfo,
assignments,
range0,
DebugPointAtBinding.NoneAtInvisible,
{
LeadingKeyword = SynLeadingKeyword.StaticMember (range0, range0)
InlineKeyword = None
EqualsRange = Some range0
}
)
assignments
|> SynBinding.basic (SynLongIdent.CreateFromLongIdent [ functionName ]) [ pattern ]
|> SynBinding.withXmlDoc xmlDoc
|> SynBinding.withReturnAnnotation returnInfo
|> SynBinding.makeStaticMember
let mem = SynMemberDefn.Member (binding, range0)
@@ -359,15 +259,10 @@ module internal JsonSerializeGenerator =
SynModuleDecl.Types ([ containingType ], range0)
else
let binding =
SynBinding.Let (
isInline = false,
isMutable = false,
xmldoc = xmlDoc,
returnInfo = returnInfo,
expr = assignments,
valData = inputVal,
pattern = pattern
)
assignments
|> SynBinding.basic (SynLongIdent.CreateFromLongIdent [ functionName ]) [ pattern ]
|> SynBinding.withReturnAnnotation returnInfo
|> SynBinding.withXmlDoc xmlDoc
SynModuleDecl.CreateLet [ binding ]
@@ -407,21 +302,15 @@ module internal JsonSerializeGenerator =
)
let typeLine =
let func = SynExpr.CreateLongIdent (SynLongIdent.Create [ "node" ; "Add" ])
let args =
SynExpr.CreateParenedTuple
[
SynExpr.CreateConstString "type"
SynExpr.CreateApp (
SynExpr.CreateLongIdent (
SynLongIdent.CreateString "System.Text.Json.Nodes.JsonValue.Create"
),
propertyName
)
]
SynExpr.CreateApp (func, args)
[
SynExpr.CreateConstString "type"
SynExpr.CreateApp (
SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonValue" ; "Create" ],
propertyName
)
]
|> SynExpr.CreateParenedTuple
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "node" ; "Add" ])
let dataNode =
SynBinding.Let (
@@ -440,32 +329,23 @@ module internal JsonSerializeGenerator =
||> List.zip
|> List.map (fun (fieldData, caseName) ->
let propertyName = getPropertyName (Option.get fieldData.Ident) fieldData.Attrs
let func = SynExpr.CreateLongIdent (SynLongIdent.Create [ "dataNode" ; "Add" ])
let node =
SynExpr.CreateApp (serializeNode fieldData.Type, SynExpr.CreateIdent caseName)
SynExpr.CreateApp (func, SynExpr.CreateParenedTuple [ propertyName ; node ])
[ propertyName ; node ]
|> SynExpr.CreateParenedTuple
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "dataNode" ; "Add" ])
)
let assignToNode =
let func = SynExpr.CreateLongIdent (SynLongIdent.Create [ "node" ; "Add" ])
let args =
SynExpr.CreateParenedTuple
[ SynExpr.CreateConstString "data" ; SynExpr.CreateIdentString "dataNode" ]
SynExpr.CreateApp (func, args)
[ SynExpr.CreateConstString "data" ; SynExpr.CreateIdentString "dataNode" ]
|> SynExpr.CreateParenedTuple
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "node" ; "Add" ])
let dataNode =
SynExpr.LetOrUse (
false,
false,
[ dataNode ],
SynExpr.CreateSequential (dataBindings @ [ assignToNode ]),
range0,
SynExprLetOrUseTrivia.empty
)
SynExpr.CreateSequential (dataBindings @ [ assignToNode ])
|> SynExpr.createLet [ dataNode ]
let action =
[

173
WoofWare.Myriad.Plugins/SynExpr/SynBinding.fs Normal file
View File

@@ -0,0 +1,173 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia
open Fantomas.FCS.Xml
open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
module internal SynBinding =
let rec private stripParen (pat : SynPat) =
match pat with
| SynPat.Paren (p, _) -> stripParen p
| _ -> pat
let rec private getName (pat : SynPat) : Ident option =
match stripParen pat with
| SynPat.Named (SynIdent.SynIdent (name, _), _, _, _) -> Some name
| SynPat.Wild _ -> None
| SynPat.Typed (pat, _, _) -> getName pat
| SynPat.Const _ -> None
| SynPat.LongIdent (SynLongIdent.SynLongIdent (longIdent, _, _), _, _, _, _, _) ->
match longIdent with
| [ x ] -> Some x
| _ -> failwithf "got long ident %O ; can only get the name of a long ident with one component" longIdent
| _ -> failwithf "unrecognised pattern: %+A" pat
let triviaZero (isMember : bool) =
{
SynBindingTrivia.EqualsRange = Some range0
InlineKeyword = None
LeadingKeyword =
if isMember then
SynLeadingKeyword.Member range0
else
SynLeadingKeyword.Let range0
}
let basic (name : SynLongIdent) (args : SynPat list) (body : SynExpr) : SynBinding =
let valInfo : SynValInfo =
args
|> List.map (fun pat -> [ SynArgInfo.SynArgInfo (SynAttributes.Empty, false, getName pat) ])
|> fun x -> SynValInfo.SynValInfo (x, SynArgInfo.SynArgInfo ([], false, None))
SynBinding.SynBinding (
None,
SynBindingKind.Normal,
false,
false,
[],
PreXmlDoc.Empty,
SynValData.SynValData (None, valInfo, None),
SynPat.LongIdent (name, None, None, SynArgPats.Pats args, None, range0),
None,
body,
range0,
DebugPointAtBinding.Yes range0,
triviaZero false
)
let withAccessibility (acc : SynAccess option) (binding : SynBinding) : SynBinding =
match binding with
| SynBinding (_, kind, inl, mut, attrs, xml, valData, headPat, returnInfo, expr, range, debugPoint, trivia) ->
let headPat =
match headPat with
| SynPat.LongIdent (ident, extra, options, argPats, _, range) ->
SynPat.LongIdent (ident, extra, options, argPats, acc, range)
| _ -> failwithf "unrecognised head pattern: %O" headPat
SynBinding (acc, kind, inl, mut, attrs, xml, valData, headPat, returnInfo, expr, range, debugPoint, trivia)
let withXmlDoc (doc : PreXmlDoc) (binding : SynBinding) : SynBinding =
match binding with
| SynBinding (acc, kind, inl, mut, attrs, _, valData, headPat, returnInfo, expr, range, debugPoint, trivia) ->
SynBinding (acc, kind, inl, mut, attrs, doc, valData, headPat, returnInfo, expr, range, debugPoint, trivia)
let withReturnAnnotation (ty : SynType) (binding : SynBinding) : SynBinding =
match binding with
| SynBinding (acc, kind, inl, mut, attrs, doc, valData, headPat, _, expr, range, debugPoint, trivia) ->
let retInfo =
SynBindingReturnInfo.SynBindingReturnInfo (
ty,
range0,
[],
{
ColonRange = Some range0
}
)
SynBinding (
acc,
kind,
inl,
mut,
attrs,
doc,
valData,
headPat,
Some retInfo,
expr,
range,
debugPoint,
trivia
)
let makeInline (binding : SynBinding) : SynBinding =
match binding with
| SynBinding (acc, kind, _, mut, attrs, doc, valData, headPat, ret, expr, range, debugPoint, trivia) ->
SynBinding (
acc,
kind,
true,
mut,
attrs,
doc,
valData,
headPat,
ret,
expr,
range,
debugPoint,
{ trivia with
InlineKeyword = Some range0
}
)
let makeStaticMember (binding : SynBinding) : SynBinding =
let memberFlags =
{
SynMemberFlags.IsInstance = false
SynMemberFlags.IsDispatchSlot = false
SynMemberFlags.IsOverrideOrExplicitImpl = false
SynMemberFlags.IsFinal = false
SynMemberFlags.GetterOrSetterIsCompilerGenerated = false
SynMemberFlags.MemberKind = SynMemberKind.Member
}
match binding with
| SynBinding (acc, kind, inl, mut, attrs, doc, valData, headPat, ret, expr, range, debugPoint, trivia) ->
let valData =
match valData with
| SynValData.SynValData (_, valInfo, _) -> SynValData.SynValData (Some memberFlags, valInfo, None)
let trivia =
{ trivia with
LeadingKeyword = SynLeadingKeyword.StaticMember (range0, range0)
}
SynBinding (acc, kind, inl, mut, attrs, doc, valData, headPat, ret, expr, range, debugPoint, trivia)
let makeInstanceMember (binding : SynBinding) : SynBinding =
let memberFlags =
{
SynMemberFlags.IsInstance = true
SynMemberFlags.IsDispatchSlot = false
SynMemberFlags.IsOverrideOrExplicitImpl = true
SynMemberFlags.IsFinal = false
SynMemberFlags.GetterOrSetterIsCompilerGenerated = false
SynMemberFlags.MemberKind = SynMemberKind.Member
}
match binding with
| SynBinding (acc, kind, inl, mut, attrs, doc, valData, headPat, ret, expr, range, debugPoint, trivia) ->
let valData =
match valData with
| SynValData.SynValData (_, valInfo, _) -> SynValData.SynValData (Some memberFlags, valInfo, None)
let trivia =
{ trivia with
LeadingKeyword = SynLeadingKeyword.Member range0
}
SynBinding (acc, kind, inl, mut, attrs, doc, valData, headPat, ret, expr, range, debugPoint, trivia)

196
WoofWare.Myriad.Plugins/SynExpr/SynExpr.fs
View File

@@ -15,21 +15,25 @@ type internal CompExprBinding =
[<RequireQualifiedAccess>]
module internal SynExpr =
/// {f} {x}
let applyFunction (f : SynExpr) (x : SynExpr) : SynExpr = SynExpr.CreateApp (f, x)
/// {f} {x}
let applyTo (x : SynExpr) (f : SynExpr) : SynExpr = SynExpr.CreateApp (f, x)
/// {expr} |> {func}
let pipeThroughFunction (func : SynExpr) (expr : SynExpr) : SynExpr =
SynExpr.CreateApp (
SynExpr.CreateAppInfix (
SynExpr.CreateLongIdent (
SynLongIdent.SynLongIdent (
[ Ident.Create "op_PipeRight" ],
[],
[ Some (IdentTrivia.OriginalNotation "|>") ]
)
),
expr
SynExpr.CreateAppInfix (
SynExpr.CreateLongIdent (
SynLongIdent.SynLongIdent (
[ Ident.Create "op_PipeRight" ],
[],
[ Some (IdentTrivia.OriginalNotation "|>") ]
)
),
func
expr
)
|> applyTo func
/// if {cond} then {trueBranch} else {falseBranch}
/// Note that this function puts the trueBranch last, for pipelining convenience:
@@ -72,35 +76,31 @@ module internal SynExpr =
/// {a} = {b}
let equals (a : SynExpr) (b : SynExpr) =
SynExpr.CreateApp (
SynExpr.CreateAppInfix (
SynExpr.CreateLongIdent (
SynLongIdent.SynLongIdent (
Ident.CreateLong "op_Equality",
[],
[ Some (IdentTrivia.OriginalNotation "=") ]
)
),
a
SynExpr.CreateAppInfix (
SynExpr.CreateLongIdent (
SynLongIdent.SynLongIdent (
Ident.CreateLong "op_Equality",
[],
[ Some (IdentTrivia.OriginalNotation "=") ]
)
),
b
a
)
|> applyTo b
/// {a} + {b}
let plus (a : SynExpr) (b : SynExpr) =
SynExpr.CreateApp (
SynExpr.CreateAppInfix (
SynExpr.CreateLongIdent (
SynLongIdent.SynLongIdent (
Ident.CreateLong "op_Addition",
[],
[ Some (IdentTrivia.OriginalNotation "+") ]
)
),
a
SynExpr.CreateAppInfix (
SynExpr.CreateLongIdent (
SynLongIdent.SynLongIdent (
Ident.CreateLong "op_Addition",
[],
[ Some (IdentTrivia.OriginalNotation "+") ]
)
),
b
a
)
|> applyTo b
let rec stripOptionalParen (expr : SynExpr) : SynExpr =
match expr with
@@ -109,48 +109,42 @@ module internal SynExpr =
/// {obj}.{meth} {arg}
let callMethodArg (meth : string) (arg : SynExpr) (obj : SynExpr) : SynExpr =
SynExpr.CreateApp (
SynExpr.DotGet (
obj,
range0,
SynLongIdent.SynLongIdent (id = [ Ident.Create meth ], dotRanges = [], trivia = [ None ]),
range0
),
arg
SynExpr.DotGet (
obj,
range0,
SynLongIdent.SynLongIdent (id = [ Ident.Create meth ], dotRanges = [], trivia = [ None ]),
range0
)
|> applyTo arg
/// {obj}.{meth}()
let callMethod (meth : string) (obj : SynExpr) : SynExpr =
callMethodArg meth (SynExpr.CreateConst SynConst.Unit) obj
let callGenericMethod (meth : string) (ty : LongIdent) (obj : SynExpr) : SynExpr =
SynExpr.CreateApp (
SynExpr.TypeApp (
SynExpr.DotGet (obj, range0, SynLongIdent.Create [ meth ], range0),
range0,
[ SynType.LongIdent (SynLongIdent.CreateFromLongIdent ty) ],
[],
Some range0,
range0,
range0
),
SynExpr.CreateConst SynConst.Unit
SynExpr.TypeApp (
SynExpr.DotGet (obj, range0, SynLongIdent.Create [ meth ], range0),
range0,
[ SynType.LongIdent (SynLongIdent.CreateFromLongIdent ty) ],
[],
Some range0,
range0,
range0
)
|> applyTo (SynExpr.CreateConst SynConst.Unit)
/// {obj}.{meth}<ty>()
let callGenericMethod' (meth : string) (ty : string) (obj : SynExpr) : SynExpr =
SynExpr.CreateApp (
SynExpr.TypeApp (
SynExpr.DotGet (obj, range0, SynLongIdent.Create [ meth ], range0),
range0,
[ SynType.CreateLongIdent ty ],
[],
Some range0,
range0,
range0
),
SynExpr.CreateConst SynConst.Unit
SynExpr.TypeApp (
SynExpr.DotGet (obj, range0, SynLongIdent.Create [ meth ], range0),
range0,
[ SynType.CreateLongIdent ty ],
[],
Some range0,
range0,
range0
)
|> applyTo (SynExpr.CreateConst SynConst.Unit)
let index (property : SynExpr) (obj : SynExpr) : SynExpr =
SynExpr.DotIndexedGet (obj, property, range0, range0)
@@ -173,25 +167,37 @@ module internal SynExpr =
|> SynExpr.CreateParen
let reraise : SynExpr =
SynExpr.CreateApp (SynExpr.CreateIdent (Ident.Create "reraise"), SynExpr.CreateConst SynConst.Unit)
SynExpr.CreateIdent (Ident.Create "reraise")
|> applyTo (SynExpr.CreateConst SynConst.Unit)
/// {body} |> fun a -> Async.StartAsTask (a, ?cancellationToken=ct)
let startAsTask (ct : SynLongIdent) (body : SynExpr) =
let lambda =
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "Async" ; "StartAsTask" ]),
SynExpr.CreateParenedTuple
[
SynExpr.CreateLongIdent (SynLongIdent.CreateString "a")
equals
(SynExpr.LongIdent (true, SynLongIdent.CreateString "cancellationToken", None, range0))
(SynExpr.CreateLongIdent ct)
]
)
[
SynExpr.CreateLongIdent (SynLongIdent.CreateString "a")
equals
(SynExpr.LongIdent (true, SynLongIdent.CreateString "cancellationToken", None, range0))
(SynExpr.CreateLongIdent ct)
]
|> SynExpr.CreateParenedTuple
|> applyFunction (SynExpr.CreateLongIdent (SynLongIdent.Create [ "Async" ; "StartAsTask" ]))
|> createLambda "a"
pipeThroughFunction lambda body
let createLongIdent (ident : string list) : SynExpr =
SynExpr.CreateLongIdent (SynLongIdent.Create ident)
let createLongIdent' (ident : Ident list) : SynExpr =
SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent ident)
let createLet (bindings : SynBinding list) (body : SynExpr) : SynExpr =
SynExpr.LetOrUse (false, false, bindings, body, range0, SynExprLetOrUseTrivia.empty)
let createMatch (matchOn : SynExpr) (cases : SynMatchClause list) : SynExpr = SynExpr.CreateMatch (matchOn, cases)
let typeAnnotate (ty : SynType) (expr : SynExpr) : SynExpr = SynExpr.CreateTyped (expr, ty)
/// {compExpr} { {lets} ; return {ret} }
let createCompExpr (compExpr : string) (retBody : SynExpr) (lets : CompExprBinding list) : SynExpr =
let retStatement = SynExpr.YieldOrReturn ((false, true), retBody, range0)
@@ -215,16 +221,7 @@ module internal SynExpr =
}
)
| Let (lhs, rhs) ->
SynExpr.LetOrUse (
false,
false,
[ SynBinding.Let (pattern = SynPat.CreateNamed (Ident.Create lhs), expr = rhs) ],
state,
range0,
{
SynExprLetOrUseTrivia.InKeyword = None
}
)
createLet [ SynBinding.Let (pattern = SynPat.CreateNamed (Ident.Create lhs), expr = rhs) ] state
| Use (lhs, rhs) ->
SynExpr.LetOrUse (
false,
@@ -261,17 +258,6 @@ module internal SynExpr =
let upcast' (ty : SynType) (e : SynExpr) = SynExpr.Upcast (e, ty, range0)
let synBindingTriviaZero (isMember : bool) =
{
SynBindingTrivia.EqualsRange = Some range0
InlineKeyword = None
LeadingKeyword =
if isMember then
SynLeadingKeyword.Member range0
else
SynLeadingKeyword.Let range0
}
/// {ident} - {rhs}
let minus (ident : SynLongIdent) (rhs : SynExpr) : SynExpr =
SynExpr.CreateApp (
@@ -310,16 +296,14 @@ module internal SynExpr =
/// {y} >= {x}
let greaterThanOrEqual (x : SynExpr) (y : SynExpr) : SynExpr =
SynExpr.CreateApp (
SynExpr.CreateAppInfix (
SynExpr.CreateLongIdent (
SynLongIdent.SynLongIdent (
[ Ident.Create "op_GreaterThanOrEqual" ],
[],
[ Some (IdentTrivia.OriginalNotation ">=") ]
)
),
y
SynExpr.CreateAppInfix (
SynExpr.CreateLongIdent (
SynLongIdent.SynLongIdent (
[ Ident.Create "op_GreaterThanOrEqual" ],
[],
[ Some (IdentTrivia.OriginalNotation ">=") ]
)
),
x
y
)
|> applyTo x

10
WoofWare.Myriad.Plugins/SynExpr/SynPat.fs Normal file
View File

@@ -0,0 +1,10 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
module internal SynPat =
let annotateType (ty : SynType) (pat : SynPat) =
SynPat.Paren (SynPat.Typed (pat, ty, range0), range0)

4
WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj
View File

@@ -27,13 +27,15 @@
<Compile Include="List.fs"/>
<Compile Include="Ident.fs" />
<Compile Include="AstHelper.fs"/>
<Compile Include="SynExpr\SynExprLetOrUseTrivia.fs" />
<Compile Include="SynExpr\SynBinding.fs" />
<Compile Include="SynExpr\SynExpr.fs" />
<Compile Include="SynExpr\SynType.fs" />
<Compile Include="SynExpr\SynAttribute.fs" />
<Compile Include="SynExpr\SynArgPats.fs" />
<Compile Include="SynExpr\SynExprLetOrUseTrivia.fs" />
<Compile Include="SynExpr\SynField.fs" />
<Compile Include="SynExpr\SynUnionCase.fs" />
<Compile Include="SynExpr\SynPat.fs" />
<Compile Include="RemoveOptionsGenerator.fs"/>
<Compile Include="InterfaceMockGenerator.fs"/>
<Compile Include="JsonSerializeGenerator.fs"/>