patrick/WoofWare.Myriad
1
0
Fork 0
mirror of https://github.com/Smaug123/WoofWare.Myriad synced 2025-10-08 13:38:39 +00:00
Code Issues Packages Projects Releases Wiki Activity

Use our DSLs a bit more (#154)

Browse Source
This commit is contained in:
Patrick Stevens
2024-05-31 19:20:28 +01:00
committed by GitHub
parent 8e47f39efc
commit 7b14e52e9d
17 changed files with 359 additions and 460 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
ConsumePlugin/GeneratedMock.fs
View File

@@ -195,7 +195,7 @@ type internal TypeWithInterfaceMock =
/// An implementation where every method throws.
static member Empty : TypeWithInterfaceMock =
{
Dispose = (fun _ -> ())
Dispose = (fun () -> ())
Mem1 = (fun _ -> raise (System.NotImplementedException "Unimplemented mock function"))
Mem2 = (fun _ -> raise (System.NotImplementedException "Unimplemented mock function"))
}

9
WoofWare.Myriad.Plugins.Test/TestJsonSerialize/TestJsonSerde.fs
View File

@@ -193,12 +193,13 @@ module TestJsonSerde =
let decompose = FSharpValue.PreComputeUnionTagReader typeof<FirstDu>
Gen.listOf duGen
|> Gen.eval 100 (StdGen.StdGen (rand.Next (), rand.Next ()))
|> List.iter (fun du ->
let mutable i = 0
while i < 10_000 && Array.exists (fun i -> i = 0) counts do
let du = Gen.eval 10 (StdGen.StdGen (rand.Next (), rand.Next ())) duGen
let tag = decompose du
counts.[tag] <- counts.[tag] + 1
)
i <- i + 1
for i in counts do
i |> shouldBeGreaterThan 0

7
WoofWare.Myriad.Plugins/AstHelper.fs
View File

@@ -3,7 +3,6 @@ namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.Text.Range
open Fantomas.FCS.Xml
open Myriad.Core.AstExtensions
type internal ParameterInfo =
{
@@ -137,12 +136,12 @@ module internal AstHelper =
| SynType.Paren (inner, _) ->
let result, _ = convertSigParam inner
result, true
| SynType.LongIdent ident ->
| SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->
{
Attributes = []
IsOptional = false
Id = None
Type = SynType.CreateLongIdent ident
Type = SynType.createLongIdent ident
},
false
| SynType.SignatureParameter (attrs, opt, id, usedType, _) ->
@@ -191,7 +190,7 @@ module internal AstHelper =
let toFun (inputs : SynType list) (ret : SynType) : SynType =
(ret, List.rev inputs)
||> List.fold (fun ty input -> SynType.CreateFun (input, ty))
||> List.fold (fun ty input -> SynType.funFromDomain input ty)
/// Returns the args (where these are tuple types if curried) in order, and the return type.
let rec getType (ty : SynType) : (SynType * bool) list * SynType =

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

@@ -62,15 +62,15 @@ module internal CataGenerator =
Fields : CataUnionField list
/// The corresponding method of the appropriate cata, fully-qualified as a call
/// into some specific cata
CataMethodName : SynLongIdent
CataMethodName : LongIdent
/// The identifier of the method of the appropriate cata
CataMethodIdent : SynIdent
/// The Instruction case which instructs the state machine to pull anything
/// necessary from the stacks and call into the cata.
AssociatedInstruction : SynLongIdent
AssociatedInstruction : LongIdent
/// Matching on an element of this union type, if you match against this
/// left-hand side (and give appropriate field arguments), you will enter this union case.
Match : SynLongIdent
Match : LongIdent
}
member this.FlattenedFields : CataUnionBasicField list =
@@ -98,7 +98,7 @@ module internal CataGenerator =
/// (i.e. when we enter the loop for the first time).
/// The state machine interprets this instruction as "break me apart and
/// descend recursively if necessary before coming back to me".
AssociatedProcessInstruction : SynLongIdent
AssociatedProcessInstruction : LongIdent
/// Name of the parent type: e.g. in `type Foo = | Blah`, this is `Foo`.
ParentTypeName : LongIdent
/// The name of the generic type parameter we'll use within the cata
@@ -165,7 +165,7 @@ module internal CataGenerator =
)
[
SynExpr.CreateLongIdent analysis.AssociatedProcessInstruction
SynExpr.createLongIdent' analysis.AssociatedProcessInstruction
|> SynExpr.applyTo (SynExpr.createLongIdent [ "x" ])
|> SynExpr.paren
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "instructions" ; "Add" ])
@@ -178,17 +178,11 @@ module internal CataGenerator =
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
SynPat.tupleNoParen (
allArtificialTyparNames
|> List.map (fun (t : Ident) ->
SynPat.namedI (Ident.create (t.idText + "Stack") |> Ident.lowerFirstLetter)
)
),
expr =
SynExpr.applyFunction
@@ -197,17 +191,15 @@ module internal CataGenerator =
)
]
]
|> SynExpr.CreateSequential
|> SynExpr.sequential
|> SynExpr.createLet
[
SynExpr.createIdent "ResizeArray"
|> SynExpr.applyTo (SynExpr.CreateConst ())
|> SynBinding.basic (SynLongIdent.createS "instructions") []
|> SynBinding.basic [ Ident.create "instructions" ] []
]
|> SynExpr.typeAnnotate relevantTypar
|> SynBinding.basic
(SynLongIdent.createS ("run" + List.last(relevantTypeName).idText))
[ cataObject ; inputObject ]
|> SynBinding.basic [ Ident.create ("run" + List.last(relevantTypeName).idText) ] [ cataObject ; inputObject ]
|> SynBinding.withReturnAnnotation relevantTypar
|> SynBinding.withXmlDoc (PreXmlDoc.create "Execute the catamorphism.")
@@ -361,7 +353,7 @@ module internal CataGenerator =
| FieldDescription.Self ty -> true, None
| FieldDescription.ListSelf ty ->
// store the length of the list
true, Some (SynType.Int ())
true, Some SynType.int
type InstructionCase =
{
@@ -423,9 +415,7 @@ module internal CataGenerator =
unions
|> List.map (fun union ->
{
Name =
match union.AssociatedProcessInstruction with
| SynLongIdent.SynLongIdent (i, _, _) -> List.last i
Name = List.last union.AssociatedProcessInstruction
Fields =
{
Name = None
@@ -493,7 +483,7 @@ module internal CataGenerator =
|> List.map (fun (SynTyparDecl.SynTyparDecl (_, SynTypar.SynTypar (ident, _, _))) -> ident.idText)
|> List.distinct
|> List.map (fun i ->
SynTyparDecl.SynTyparDecl ([], SynTypar.SynTypar (Ident.Create i, TyparStaticReq.None, false))
SynTyparDecl.SynTyparDecl ([], SynTypar.SynTypar (Ident.create i, TyparStaticReq.None, false))
)
SynTypeDefnRepr.union cases
@@ -501,7 +491,7 @@ module internal CataGenerator =
SynComponentInfo.create (Ident.create "Instruction")
|> SynComponentInfo.withGenerics typars
|> SynComponentInfo.withAccessibility (SynAccess.Private range0)
|> SynComponentInfo.addAttributes [ SynAttribute.RequireQualifiedAccess () ]
|> SynComponentInfo.addAttributes [ SynAttribute.requireQualifiedAccess ]
)
/// Build the cata interfaces, which a user will instantiate to specify a particular
@@ -577,7 +567,7 @@ module internal CataGenerator =
case.CataMethodIdent
None
arity
(PreXmlDoc.create $"How to operate on the %s{List.last(case.Match.LongIdent).idText} case")
(PreXmlDoc.create $"How to operate on the %s{List.last(case.Match).idText} case")
)
|> SynTypeDefnRepr.interfaceType
|> SynTypeDefn.create componentInfo
@@ -607,7 +597,7 @@ module internal CataGenerator =
analysis.Typars
|> List.map (fun (SynTyparDecl.SynTyparDecl (_, SynTypar.SynTypar (ident, _, _))) -> ident.idText)
|> List.distinct
|> List.map (fun i -> SynType.var (SynTypar.SynTypar (Ident.Create i, TyparStaticReq.None, false)))
|> List.map (fun i -> SynType.var (SynTypar.SynTypar (Ident.create i, TyparStaticReq.None, false)))
let ty =
SynType.app'
@@ -713,20 +703,19 @@ module internal CataGenerator =
InstructionName = instructionName
Fields = analysis
CaseName = name
CataMethodName = SynLongIdent.create (cataVarName :: unionTypeName @ [ unionCaseName ])
CataMethodName = cataVarName :: unionTypeName @ [ unionCaseName ]
CataMethodIdent = SynIdent.SynIdent (unionCaseName, None)
AssociatedInstruction =
SynLongIdent.create [ Ident.create "Instruction" ; instructionName ]
Match = SynLongIdent.create (unionTypeName @ [ unionCaseName ])
AssociatedInstruction = [ Ident.create "Instruction" ; instructionName ]
Match = unionTypeName @ [ unionCaseName ]
}
)
AssociatedProcessInstruction =
SynLongIdent.createS'
[
"Instruction"
// such jank!
"Process__" + List.last(unionTypeName).idText
]
[
"Instruction"
// such jank!
"Process__" + List.last(unionTypeName).idText
]
|> List.map Ident.create
ParentTypeName = getName unionType
GenericName = getName unionType |> List.map _.idText |> String.concat "" |> Ident.create
CataTypeName = List.last(getName unionType).idText + "CataCase" |> Ident.create
@@ -734,9 +723,9 @@ module internal CataGenerator =
)
let callCataAndPushResult (resultStackName : Ident) (unionCase : RenderedUnionCase) : SynExpr =
(SynExpr.CreateLongIdent unionCase.CataMethodName, unionCase.FlattenedFields)
(SynExpr.createLongIdent' unionCase.CataMethodName, unionCase.FlattenedFields)
||> List.fold (fun body caseDesc -> SynExpr.applyFunction body (SynExpr.createIdent' caseDesc.ArgName))
|> SynExpr.pipeThroughFunction (SynExpr.createLongIdent' (resultStackName :: [ Ident.Create "Add" ]))
|> SynExpr.pipeThroughFunction (SynExpr.createLongIdent' (resultStackName :: [ Ident.create "Add" ]))
/// Create the state-machine matches which deal with receiving the instruction
/// to "process one of the user-specified DU cases, pushing recursion instructions onto
@@ -771,7 +760,7 @@ module internal CataGenerator =
// The instruction to process us again once our inputs are ready:
let reprocessCommand =
if selfArgs.Length = unionCase.FlattenedFields.Length then
SynExpr.CreateLongIdent unionCase.AssociatedInstruction
SynExpr.createLongIdent' unionCase.AssociatedInstruction
else
// We need to tell ourselves each non-rec arg, and the length of each input list.
listSelfArgs
@@ -788,8 +777,8 @@ module internal CataGenerator =
)
|> List.sortBy fst
|> List.map snd
|> SynExpr.CreateParenedTuple
|> SynExpr.applyFunction (SynExpr.CreateLongIdent unionCase.AssociatedInstruction)
|> SynExpr.tuple
|> SynExpr.applyFunction (SynExpr.createLongIdent' unionCase.AssociatedInstruction)
|> SynExpr.paren
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "instructions" ; "Add" ])
@@ -815,7 +804,7 @@ module internal CataGenerator =
(SynExpr.createLongIdent [ "instructions" ; "Add" ])
(SynExpr.paren (
SynExpr.applyFunction
(SynExpr.CreateLongIdent analysis.AssociatedProcessInstruction)
(SynExpr.createLongIdent' analysis.AssociatedProcessInstruction)
(SynExpr.createIdent "elt")
)),
range0
@@ -835,66 +824,36 @@ module internal CataGenerator =
|> SynExpr.paren
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "instructions" ; "Add" ])
]
|> SynExpr.CreateSequential
|> SynExpr.sequential
let matchLhs =
if unionCase.Fields.Length > 0 then
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)
)
if not unionCase.Fields.IsEmpty then
unionCase.Fields
|> List.mapi (fun i case ->
match case with
| CataUnionField.Basic case -> SynPat.namedI (Ident.lowerFirstLetter case.ArgName)
| CataUnionField.Record fields ->
let fields =
fields
|> List.map (fun (name, field) ->
([], name), range0, SynPat.namedI (Ident.lowerFirstLetter name)
)
SynPat.Record (fields, range0)
),
List.replicate (unionCase.Fields.Length - 1) range0,
range0
SynPat.Record (fields, range0)
)
|> SynPat.CreateParen
|> SynPat.tuple
|> List.singleton
else
[]
SynMatchClause.SynMatchClause (
SynPat.CreateLongIdent (unionCase.Match, matchLhs),
None,
matchBody,
range0,
DebugPointAtTarget.Yes,
{
ArrowRange = Some range0
BarRange = Some range0
}
)
SynMatchClause.create
(SynPat.CreateLongIdent (SynLongIdent.create unionCase.Match, matchLhs))
matchBody
)
let bodyMatch = SynExpr.createMatch (SynExpr.createIdent "x") matchCases
SynMatchClause.SynMatchClause (
SynPat.LongIdent (
analysis.AssociatedProcessInstruction,
None,
None,
SynArgPats.create [ Ident.create "x" ],
None,
range0
),
None,
bodyMatch,
range0,
DebugPointAtTarget.Yes,
{
ArrowRange = Some range0
BarRange = Some range0
}
SynExpr.createMatch (SynExpr.createIdent "x") matchCases
|> SynMatchClause.create (
SynPat.identWithArgs analysis.AssociatedProcessInstruction (SynArgPats.create [ Ident.create "x" ])
)
/// Create the state-machine matches which deal with receiving the instruction
@@ -927,7 +886,7 @@ module internal CataGenerator =
None
)
|> List.map (fun unionCase ->
let lhsNames =
let pat =
unionCase.FlattenedFields
|> Seq.mapi (fun i x -> (i, x))
|> Seq.choose (fun (i, case) ->
@@ -937,11 +896,8 @@ module internal CataGenerator =
| FieldDescription.Self _ -> None
)
|> Seq.toList
let lhs = SynArgPats.create lhsNames
let pat =
SynPat.LongIdent (unionCase.AssociatedInstruction, None, None, lhs, None, range0)
|> SynArgPats.create
|> SynPat.identWithArgs unionCase.AssociatedInstruction
let populateArgs =
unionCase.FlattenedFields
@@ -970,7 +926,7 @@ module internal CataGenerator =
range0,
range0
)
|> SynBinding.basic (SynLongIdent.createI field.ArgName) []
|> SynBinding.basic [ field.ArgName ] []
]
|> Some
| ListSelf synType ->
@@ -1006,7 +962,7 @@ module internal CataGenerator =
)
|> SynExpr.applyFunction (SynExpr.createIdent "seq")
|> SynExpr.pipeThroughFunction (SynExpr.createLongIdent [ "Seq" ; "toList" ])
|> SynBinding.basic (SynLongIdent.createI field.ArgName) []
|> SynBinding.basic [ field.ArgName ] []
let shadowedIdent = Ident.create (field.ArgName.idText + "_len")
@@ -1016,23 +972,18 @@ module internal CataGenerator =
(SynExpr.createIdent' shadowedIdent)
SynExpr.createIdent' shadowedIdent
]
|> SynExpr.CreateParenedTuple
|> SynExpr.tuple
|> SynExpr.applyFunction (
SynExpr.createLongIdent' [ stackName ; Ident.create "RemoveRange" ]
)
|> SynExpr.createLet [ vals ]
|> SynExpr.createLet
[
SynBinding.basic
(SynLongIdent.createI shadowedIdent)
[]
(SynExpr.createIdent' field.ArgName)
]
[ SynBinding.basic [ shadowedIdent ] [] (SynExpr.createIdent' field.ArgName) ]
|> Some
)
(populateArgs @ [ callCataAndPushResult analysis.StackName unionCase ])
|> SynExpr.CreateSequential
|> SynExpr.sequential
|> SynMatchClause.create pat
)
)
@@ -1082,7 +1033,7 @@ module internal CataGenerator =
(SynExpr.paren (SynExpr.minusN (SynLongIdent.createS' [ "instructions" ; "Count" ]) 1))
matchStatement
]
|> SynExpr.CreateSequential
|> SynExpr.sequential
|> SynExpr.createLet
[
SynExpr.DotIndexedGet (
@@ -1091,11 +1042,11 @@ module internal CataGenerator =
range0,
range0
)
|> SynBinding.basic (SynLongIdent.createS "currentInstruction") []
|> SynBinding.basic [ Ident.create "currentInstruction" ] []
]
let body =
SynExpr.CreateSequential
SynExpr.sequential
[
SynExpr.createWhile
(SynExpr.greaterThan
@@ -1126,11 +1077,11 @@ module internal CataGenerator =
range0
)
|> SynExpr.applyTo (SynExpr.CreateConst ())
|> SynBinding.basic (SynLongIdent.createI unionCase.StackName) []
|> SynBinding.basic [ unionCase.StackName ] []
]
)
SynBinding.basic (SynLongIdent.createS "loop") args body
SynBinding.basic [ Ident.create "loop" ] args body
|> SynBinding.withAccessibility (Some (SynAccess.Private range0))
let createModule
@@ -1154,7 +1105,7 @@ module internal CataGenerator =
|> SynComponentInfo.withDocString (
PreXmlDoc.Create $" Methods to perform a catamorphism over the type %s{parentName}"
)
|> SynComponentInfo.addAttributes [ SynAttribute.RequireQualifiedAccess () ]
|> SynComponentInfo.addAttributes [ SynAttribute.requireQualifiedAccess ]
let cataVarName = Ident.create "cata"
let analysis = makeUnionAnalyses cataVarName allRecordTypes allUnionTypes

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

@@ -82,7 +82,7 @@ module internal HttpClientGenerator =
let matchingAttrs =
attrs
|> List.choose (fun attr ->
match attr.TypeName.AsString with
match SynLongIdent.toString attr.TypeName with
| "Get"
| "GetAttribute"
| "WoofWare.Myriad.Plugins.RestEase.Get"
@@ -144,7 +144,7 @@ module internal HttpClientGenerator =
let extractHeaderInformation (attrs : SynAttribute list) : SynExpr list list =
attrs
|> List.choose (fun attr ->
match attr.TypeName.AsString with
match SynLongIdent.toString attr.TypeName with
| "Header"
| "RestEase.Header"
| "WoofWare.Myriad.Plugins.RestEase.Header" ->
@@ -158,7 +158,7 @@ module internal HttpClientGenerator =
let shouldAllowAnyStatusCode (attrs : SynAttribute list) : bool =
attrs
|> List.exists (fun attr ->
match attr.TypeName.AsString with
match SynLongIdent.toString attr.TypeName with
| "AllowAnyStatusCode"
| "AllowAnyStatusCodeAttribute"
| "RestEase.AllowAnyStatusCode"
@@ -225,25 +225,15 @@ module internal HttpClientGenerator =
| None -> failwith $"expected an optional cancellation token as final arg in %s{info.Identifier.idText}"
| Some (arg, _) -> arg
let argPats =
let args = args |> List.map snd
SynPat.Tuple (false, args, List.replicate (args.Length - 1) range0, range0)
|> SynPat.CreateParen
|> List.singleton
|> SynArgPats.Pats
let headPat =
let thisIdent = if variableHeaders.IsEmpty then "_" else "this"
SynPat.LongIdent (
SynLongIdent.create [ Ident.create thisIdent ; info.Identifier ],
None,
None,
argPats,
None,
range0
)
args
|> List.map snd
|> SynPat.tuple
|> List.singleton
|> SynArgPats.Pats
|> SynPat.identWithArgs [ Ident.create thisIdent ; info.Identifier ]
let requestUriTrailer =
(info.UrlTemplate, info.Args)
@@ -265,10 +255,10 @@ module internal HttpClientGenerator =
template
|> SynExpr.callMethodArg
"Replace"
(SynExpr.CreateParenedTuple
(SynExpr.tuple
[
SynExpr.CreateConst ("{" + substituteId + "}")
SynExpr.callMethod "ToString" (SynExpr.CreateIdent varName)
SynExpr.callMethod "ToString" (SynExpr.createIdent' varName)
|> SynExpr.pipeThroughFunction (
SynExpr.createLongIdent [ "System" ; "Web" ; "HttpUtility" ; "UrlEncode" ]
)
@@ -357,45 +347,37 @@ module internal HttpClientGenerator =
let baseAddress =
[
SynMatchClause.Create (
SynPat.CreateNull,
None,
match info.BaseAddress with
| None ->
[
SynExpr.applyFunction (SynExpr.createIdent "nameof") (SynExpr.paren baseAddress)
SynExpr.CreateConst
"No base address was supplied on the type, and no BaseAddress was on the HttpClient."
]
|> SynExpr.CreateParenedTuple
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "System" ; "ArgumentNullException" ])
|> SynExpr.paren
|> SynExpr.applyFunction (SynExpr.createIdent "raise")
| Some expr -> SynExpr.applyFunction uriIdent expr
)
SynMatchClause.Create (SynPat.named "v", None, SynExpr.createIdent "v")
SynMatchClause.create
SynPat.createNull
(match info.BaseAddress with
| None ->
[
SynExpr.applyFunction (SynExpr.createIdent "nameof") (SynExpr.paren baseAddress)
SynExpr.CreateConst
"No base address was supplied on the type, and no BaseAddress was on the HttpClient."
]
|> SynExpr.tuple
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "System" ; "ArgumentNullException" ])
|> SynExpr.paren
|> SynExpr.applyFunction (SynExpr.createIdent "raise")
| Some expr -> SynExpr.applyFunction uriIdent expr)
SynMatchClause.create (SynPat.named "v") (SynExpr.createIdent "v")
]
|> SynExpr.createMatch baseAddress
|> SynExpr.paren
SynExpr.App (
ExprAtomicFlag.Atomic,
false,
uriIdent,
SynExpr.CreateParenedTuple
[
baseAddress
SynExpr.CreateApp (
uriIdent,
SynExpr.CreateParenedTuple
[
requestUriTrailer
SynExpr.createLongIdent [ "System" ; "UriKind" ; "Relative" ]
]
)
],
range0
)
[
baseAddress
SynExpr.applyFunction
uriIdent
(SynExpr.tuple
[
requestUriTrailer
SynExpr.createLongIdent [ "System" ; "UriKind" ; "Relative" ]
])
]
|> SynExpr.tuple
|> SynExpr.applyFunction uriIdent
let bodyParams =
info.Args
@@ -434,7 +416,7 @@ module internal HttpClientGenerator =
[ "System" ; "Net" ; "Http" ; "HttpMethod" ; httpMethodString info.HttpMethod ])
SynExpr.equals (SynExpr.createIdent "RequestUri") (SynExpr.createIdent "uri")
]
|> SynExpr.CreateTuple
|> SynExpr.tupleNoParen
let returnExpr =
match info.TaskReturnType with
@@ -559,7 +541,7 @@ module internal HttpClientGenerator =
SynExpr.applyFunction
(SynExpr.createLongIdent
[ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ; "ParseAsync" ])
(SynExpr.CreateParenedTuple
(SynExpr.tuple
[
SynExpr.createIdent "responseStream"
SynExpr.equals (SynExpr.createIdent "cancellationToken") (SynExpr.createIdent "ct")
@@ -574,10 +556,10 @@ module internal HttpClientGenerator =
headerName
SynExpr.applyFunction
(SynExpr.createLongIdent'
[ Ident.Create "this" ; callToGetValue ; Ident.Create "ToString" ])
[ Ident.create "this" ; callToGetValue ; Ident.create "ToString" ])
(SynExpr.CreateConst ())
]
|> SynExpr.CreateParenedTuple
|> SynExpr.tuple
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "httpMessage" ; "Headers" ; "Add" ])
|> Do
)
@@ -587,7 +569,7 @@ module internal HttpClientGenerator =
|> List.map (fun (headerName, headerValue) ->
SynExpr.applyFunction
(SynExpr.createLongIdent [ "httpMessage" ; "Headers" ; "Add" ])
(SynExpr.CreateParenedTuple [ headerName ; headerValue ])
(SynExpr.tuple [ headerName ; headerValue ])
|> Do
)
@@ -613,8 +595,7 @@ module internal HttpClientGenerator =
SynExpr.awaitTask (
SynExpr.applyFunction
(SynExpr.createLongIdent [ "client" ; "SendAsync" ])
(SynExpr.CreateParenedTuple
[ SynExpr.createIdent "httpMessage" ; SynExpr.createIdent "ct" ])
(SynExpr.tuple [ SynExpr.createIdent "httpMessage" ; SynExpr.createIdent "ct" ])
)
)
if info.EnsureSuccessHttpCode then
@@ -638,7 +619,7 @@ module internal HttpClientGenerator =
yield jsonNode
]
|> SynExpr.createCompExpr "async" returnExpr
|> SynExpr.startAsTask (SynLongIdent.createI cancellationTokenArg)
|> SynExpr.startAsTask cancellationTokenArg
SynBinding.SynBinding (
None,
@@ -661,7 +642,7 @@ module internal HttpClientGenerator =
let getHttpAttributes (attrs : SynAttribute list) : HttpAttribute list =
attrs
|> List.choose (fun attr ->
match attr.TypeName.AsString with
match SynLongIdent.toString attr.TypeName with
| "RestEase.Query"
| "RestEase.QueryAttribute"
| "WoofWare.Myriad.Plugins.RestEase.Query"
@@ -702,7 +683,7 @@ module internal HttpClientGenerator =
let extractBasePath (attrs : SynAttribute list) : SynExpr option =
attrs
|> List.tryPick (fun attr ->
match attr.TypeName.AsString with
match SynLongIdent.toString attr.TypeName with
| "BasePath"
| "RestEase.BasePath"
| "WoofWare.Myriad.Plugins.RestEase.BasePath"
@@ -715,7 +696,7 @@ module internal HttpClientGenerator =
let extractBaseAddress (attrs : SynAttribute list) : SynExpr option =
attrs
|> List.tryPick (fun attr ->
match attr.TypeName.AsString with
match SynLongIdent.toString attr.TypeName with
| "BaseAddress"
| "RestEase.BaseAddress"
| "WoofWare.Myriad.Plugins.RestEase.BaseAddress"
@@ -947,7 +928,7 @@ module internal HttpClientGenerator =
let createFunc =
if spec.ExtensionMethods then
let binding =
SynBinding.basic (SynLongIdent.createS "make") (headerArgs @ [ clientCreationArg ]) interfaceImpl
SynBinding.basic [ Ident.create "make" ] (headerArgs @ [ clientCreationArg ]) interfaceImpl
|> SynBinding.withXmlDoc xmlDoc
|> SynBinding.withReturnAnnotation returnInfo
|> SynMemberDefn.staticMember
@@ -964,7 +945,7 @@ module internal HttpClientGenerator =
SynModuleDecl.Types ([ containingType ], range0)
else
SynBinding.basic (SynLongIdent.createS "make") (headerArgs @ [ clientCreationArg ]) interfaceImpl
SynBinding.basic [ Ident.create "make" ] (headerArgs @ [ clientCreationArg ]) interfaceImpl
|> SynBinding.withXmlDoc xmlDoc
|> SynBinding.withReturnAnnotation returnInfo
|> List.singleton
@@ -980,10 +961,7 @@ module internal HttpClientGenerator =
if spec.ExtensionMethods then
[ SynAttribute.autoOpen ]
else
[
SynAttribute.compilationRepresentation
SynAttribute.RequireQualifiedAccess ()
]
[ SynAttribute.compilationRepresentation ; SynAttribute.requireQualifiedAccess ]
let modInfo =
SynComponentInfo.create moduleName

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

@@ -49,13 +49,13 @@ module internal InterfaceMockGenerator =
let failwithFun =
SynExpr.createLongIdent [ "System" ; "NotImplementedException" ]
|> SynExpr.applyTo (SynExpr.CreateConst "Unimplemented mock function")
|> SynExpr.CreateParen
|> SynExpr.paren
|> SynExpr.applyFunction (SynExpr.createIdent "raise")
|> SynExpr.createLambda "_"
let constructorReturnType =
match interfaceType.Generics with
| None -> SynType.CreateLongIdent name
| None -> SynType.createLongIdent' [ name ]
| Some generics ->
let generics =
@@ -67,7 +67,7 @@ module internal InterfaceMockGenerator =
let constructorFields =
let extras =
if inherits.Contains KnownInheritance.IDisposable then
let unitFun = SynExpr.createLambda "_" SynExpr.CreateUnit
let unitFun = SynExpr.createThunk (SynExpr.CreateConst ())
[ (SynLongIdent.createS "Dispose", true), Some unitFun ]
else
@@ -81,14 +81,14 @@ module internal InterfaceMockGenerator =
let constructor =
SynBinding.basic
(SynLongIdent.createS "Empty")
[ Ident.create "Empty" ]
(if interfaceType.Generics.IsNone then
[]
else
[ SynPat.CreateConst SynConst.Unit ])
[ SynPat.unit ])
(AstHelper.instantiateRecord constructorFields)
|> SynBinding.makeStaticMember
|> SynBinding.withXmlDoc (PreXmlDoc.Create " An implementation where every method throws.")
|> SynBinding.withXmlDoc (PreXmlDoc.create "An implementation where every method throws.")
|> SynBinding.withReturnAnnotation constructorReturnType
|> fun m -> SynMemberDefn.Member (m, range0)
@@ -97,9 +97,9 @@ module internal InterfaceMockGenerator =
if inherits.Contains KnownInheritance.IDisposable then
[
SynField.Create (
SynType.CreateFun (SynType.CreateUnit, SynType.CreateUnit),
Ident.Create "Dispose",
xmldoc = PreXmlDoc.Create " Implementation of IDisposable.Dispose"
SynType.funFromDomain SynType.unit SynType.unit,
Ident.create "Dispose",
xmldoc = PreXmlDoc.create "Implementation of IDisposable.Dispose"
)
]
else
@@ -159,22 +159,20 @@ module internal InterfaceMockGenerator =
tupledArgs.Args
|> List.mapi (fun j ty ->
match ty.Type with
| UnitType -> SynPat.Const (SynConst.Unit, range0)
| _ -> SynPat.CreateNamed (Ident.Create $"arg_%i{i}_%i{j}")
| UnitType -> SynPat.unit
| _ -> SynPat.named $"arg_%i{i}_%i{j}"
)
match args with
| [] -> failwith "somehow got no args at all"
| [ arg ] -> arg
| args ->
SynPat.Tuple (false, args, List.replicate (args.Length - 1) range0, range0)
|> SynPat.CreateParen
|> fun i -> if tupledArgs.HasParen then SynPat.Paren (i, range0) else i
| args -> SynPat.tuple args
|> fun i -> if tupledArgs.HasParen then SynPat.paren i else i
)
let headPat =
SynPat.LongIdent (
SynLongIdent.create [ Ident.Create "this" ; memberInfo.Identifier ],
SynLongIdent.create [ Ident.create "this" ; memberInfo.Identifier ],
None,
None,
SynArgPats.Pats headArgs,
@@ -192,7 +190,7 @@ module internal InterfaceMockGenerator =
| UnitType -> SynExpr.CreateConst ()
| _ -> SynExpr.createIdent $"arg_%i{i}_%i{j}"
)
|> SynExpr.CreateParenedTuple
|> SynExpr.tuple
)
match tuples |> List.rev with
@@ -200,9 +198,9 @@ module internal InterfaceMockGenerator =
| last :: rest ->
(last, rest)
||> List.fold (fun trail next -> SynExpr.CreateApp (next, trail))
||> List.fold SynExpr.applyTo
|> SynExpr.applyFunction (
SynExpr.createLongIdent' [ Ident.Create "this" ; memberInfo.Identifier ]
SynExpr.createLongIdent' [ Ident.create "this" ; memberInfo.Identifier ]
)
SynMemberDefn.Member (
@@ -261,17 +259,16 @@ module internal InterfaceMockGenerator =
match inheritance with
| KnownInheritance.IDisposable ->
let binding =
SynBinding.basic
(SynLongIdent.createS' [ "this" ; "Dispose" ])
[ SynPat.CreateConst SynConst.Unit ]
(SynExpr.CreateApp (SynExpr.createLongIdent [ "this" ; "Dispose" ], SynExpr.CreateUnit))
|> SynBinding.withReturnAnnotation (SynType.Unit ())
SynExpr.createLongIdent [ "this" ; "Dispose" ]
|> SynExpr.applyTo (SynExpr.CreateConst ())
|> SynBinding.basic [ Ident.create "this" ; Ident.create "Dispose" ] [ SynPat.unit ]
|> SynBinding.withReturnAnnotation SynType.unit
|> SynBinding.makeInstanceMember
let mem = SynMemberDefn.Member (binding, range0)
SynMemberDefn.Interface (
SynType.CreateLongIdent (SynLongIdent.createS' [ "System" ; "IDisposable" ]),
SynType.createLongIdent' [ "System" ; "IDisposable" ],
Some range0,
Some [ mem ],
range0
@@ -281,7 +278,7 @@ module internal InterfaceMockGenerator =
let record =
{
Name = Ident.Create name
Name = Ident.create name
Fields = fields
Members = Some ([ constructor ; interfaceMembers ] @ extraInterfaces)
XmlDoc = Some xmlDoc
@@ -334,7 +331,7 @@ module internal InterfaceMockGenerator =
=
let interfaceType = AstHelper.parseInterface interfaceType
let fields = interfaceType.Members |> List.map constructMember
let docString = PreXmlDoc.Create " Mock record type for an interface"
let docString = PreXmlDoc.create "Mock record type for an interface"
let name =
List.last interfaceType.Name

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

@@ -4,7 +4,6 @@ open System
open System.Text
open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia
open Fantomas.FCS.Xml
open Myriad.Core
type internal JsonParseOutputSpec =
@@ -42,7 +41,7 @@ module internal JsonParseGenerator =
|> SynExpr.applyFunction (SynExpr.createIdent "raise")
[
SynMatchClause.create SynPat.CreateNull raiseExpr
SynMatchClause.create SynPat.createNull raiseExpr
SynMatchClause.create (SynPat.named "v") (SynExpr.createIdent "v")
]
|> SynExpr.createMatch indexed
@@ -104,7 +103,7 @@ module internal JsonParseGenerator =
let body = SynExpr.pipeThroughFunction (SynExpr.createIdent "Some") body
[
SynMatchClause.create SynPat.CreateNull (SynExpr.createIdent "None")
SynMatchClause.create SynPat.createNull (SynExpr.createIdent "None")
SynMatchClause.create (SynPat.named "v") body
]
|> SynExpr.createMatch node
@@ -308,14 +307,14 @@ module internal JsonParseGenerator =
if spec.ExtensionMethods then
let binding =
SynBinding.basic (SynLongIdent.createI functionName) [ arg ] functionBody
SynBinding.basic [ functionName ] [ arg ] functionBody
|> SynBinding.withXmlDoc xmlDoc
|> SynBinding.withReturnAnnotation returnInfo
|> SynMemberDefn.staticMember
let componentInfo =
SynComponentInfo.createLong typeName
|> SynComponentInfo.withDocString (PreXmlDoc.Create " Extension methods for JSON parsing")
|> SynComponentInfo.withDocString (PreXmlDoc.create "Extension methods for JSON parsing")
let containingType =
SynTypeDefnRepr.augmentation ()
@@ -324,7 +323,7 @@ module internal JsonParseGenerator =
SynModuleDecl.Types ([ containingType ], range0)
else
SynBinding.basic (SynLongIdent.createI functionName) [ arg ] functionBody
SynBinding.basic [ functionName ] [ arg ] functionBody
|> SynBinding.withXmlDoc xmlDoc
|> SynBinding.withReturnAnnotation returnInfo
|> List.singleton
@@ -333,7 +332,10 @@ module internal JsonParseGenerator =
let getParseOptions (fieldAttrs : SynAttribute list) =
(JsonParseOption.None, fieldAttrs)
||> List.fold (fun options attr ->
if attr.TypeName.AsString.EndsWith ("JsonNumberHandling", StringComparison.Ordinal) then
if
(SynLongIdent.toString attr.TypeName)
.EndsWith ("JsonNumberHandling", StringComparison.Ordinal)
then
let qualifiedEnumValue =
match SynExpr.stripOptionalParen attr.ArgExpr with
| SynExpr.LongIdent (_, SynLongIdent (ident, _, _), _, _) when isJsonNumberHandling ident ->
@@ -356,15 +358,15 @@ module internal JsonParseGenerator =
options
)
let createRecordMaker (spec : JsonParseOutputSpec) (typeName : LongIdent) (fields : SynFieldData<Ident> list) =
let createRecordMaker (spec : JsonParseOutputSpec) (fields : SynFieldData<Ident> list) =
let assignments =
fields
|> List.mapi (fun i fieldData ->
let propertyNameAttr =
fieldData.Attrs
|> List.tryFind (fun attr ->
attr.TypeName.AsString.EndsWith ("JsonPropertyName", StringComparison.Ordinal)
(SynLongIdent.toString attr.TypeName)
.EndsWith ("JsonPropertyName", StringComparison.Ordinal)
)
let options = getParseOptions fieldData.Attrs
@@ -384,7 +386,7 @@ module internal JsonParseGenerator =
| Some name -> name.ArgExpr
createParseRhs options propertyName fieldData.Type
|> SynBinding.basic (SynLongIdent.createS $"arg_%i{i}") []
|> SynBinding.basic [ Ident.create $"arg_%i{i}" ] []
)
let finalConstruction =
@@ -412,13 +414,13 @@ module internal JsonParseGenerator =
let options = getParseOptions field.Attrs
createParseRhs options propertyName field.Type
)
|> SynExpr.CreateParenedTuple
|> SynExpr.tuple
|> SynExpr.applyFunction (SynExpr.createLongIdent' (typeName @ [ case.Ident ]))
|> SynExpr.createLet
[
SynExpr.index (SynExpr.CreateConst "data") (SynExpr.createIdent "node")
|> assertNotNull (SynExpr.CreateConst "data")
|> SynBinding.basic (SynLongIdent.createS "node") []
|> SynBinding.basic [ Ident.create "node" ] []
]
match propertyName with
@@ -471,7 +473,7 @@ module internal JsonParseGenerator =
"v"
(SynExpr.callGenericMethod "GetValue" [ Ident.create "string" ] (SynExpr.createIdent "v"))
)
|> SynBinding.basic (SynLongIdent.createS "ty") []
|> SynBinding.basic [ Ident.create "ty" ] []
]
let createModule (namespaceId : LongIdent) (spec : JsonParseOutputSpec) (typeDefn : SynTypeDefn) =
@@ -485,10 +487,7 @@ module internal JsonParseGenerator =
if spec.ExtensionMethods then
[ SynAttribute.autoOpen ]
else
[
SynAttribute.RequireQualifiedAccess ()
SynAttribute.compilationRepresentation
]
[ SynAttribute.requireQualifiedAccess ; SynAttribute.compilationRepresentation ]
let xmlDoc =
let fullyQualified = ident |> Seq.map (fun i -> i.idText) |> String.concat "."
@@ -499,8 +498,8 @@ module internal JsonParseGenerator =
else
"methods"
$" Module containing JSON parsing %s{description} for the %s{fullyQualified} type"
|> PreXmlDoc.Create
$"Module containing JSON parsing %s{description} for the %s{fullyQualified} type"
|> PreXmlDoc.create
let moduleName =
if spec.ExtensionMethods then
@@ -525,20 +524,17 @@ module internal JsonParseGenerator =
let decl =
match synTypeDefnRepr with
| SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (_accessibility, fields, _range), _) ->
let fields = fields |> List.map SynField.extractWithIdent
createRecordMaker spec ident fields
fields |> List.map SynField.extractWithIdent |> createRecordMaker spec
| SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (_accessibility, cases, _range), _) ->
let optionGet (i : Ident option) =
match i with
| None -> failwith "WoofWare.Myriad requires union cases to have identifiers on each field."
| Some i -> i
let cases =
cases
|> List.map SynUnionCase.extract
|> List.map (UnionCase.mapIdentFields optionGet)
createUnionMaker spec ident cases
cases
|> List.map SynUnionCase.extract
|> List.map (UnionCase.mapIdentFields optionGet)
|> createUnionMaker spec ident
| _ -> failwithf "Not a record or union type"
let mdl =

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

@@ -3,8 +3,6 @@ namespace WoofWare.Myriad.Plugins
open System
open System.Text
open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia
open Fantomas.FCS.Xml
open Myriad.Core
type internal JsonSerializeOutputSpec =
@@ -40,28 +38,23 @@ module internal JsonSerializeGenerator =
)
| OptionType ty ->
// fun field -> match field with | None -> JsonValue.Create null | Some v -> {serializeNode ty} field
[
SynMatchClause.Create (
SynPat.CreateLongIdent (SynLongIdent.createS "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' [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ]
let noneClause =
// 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' [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ])
|> SynMatchClause.create (SynPat.named "None")
)
let someClause =
SynExpr.applyFunction (serializeNode ty) (SynExpr.createIdent "field")
|> SynExpr.paren
|> SynExpr.upcast' (SynType.createLongIdent' [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ])
|> SynMatchClause.create (
SynPat.CreateLongIdent (SynLongIdent.createS "Some", [ SynPat.named "field" ])
)
SynMatchClause.Create (
SynPat.CreateLongIdent (SynLongIdent.createS "Some", [ SynPat.named "field" ]),
None,
SynExpr.applyFunction (serializeNode ty) (SynExpr.createIdent "field")
|> SynExpr.paren
|> SynExpr.upcast' (SynType.createLongIdent' [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ])
)
]
[ noneClause ; someClause ]
|> SynExpr.createMatch (SynExpr.createIdent "field")
|> SynExpr.createLambda "field"
| ArrayType ty
@@ -79,18 +72,18 @@ module internal JsonSerializeGenerator =
SynPat.named "mem",
SynExpr.createIdent "field",
SynExpr.applyFunction
(SynExpr.CreateLongIdent (SynLongIdent.createS' [ "arr" ; "Add" ]))
(SynExpr.CreateParen (SynExpr.CreateApp (serializeNode ty, SynExpr.createIdent "mem"))),
(SynExpr.createLongIdent [ "arr" ; "Add" ])
(SynExpr.paren (SynExpr.applyFunction (serializeNode ty) (SynExpr.createIdent "mem"))),
range0
)
SynExpr.createIdent "arr"
]
|> SynExpr.CreateSequential
|> SynExpr.sequential
|> SynExpr.createLet
[
SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonArray" ]
|> SynExpr.applyTo (SynExpr.CreateConst ())
|> SynBinding.basic (SynLongIdent.createS "arr") []
|> SynBinding.basic [ Ident.create "arr" ] []
]
|> SynExpr.createLambda "field"
| IDictionaryType (_keyType, valueType)
@@ -108,46 +101,31 @@ module internal JsonSerializeGenerator =
DebugPointAtInOrTo.Yes range0,
SeqExprOnly.SeqExprOnly false,
true,
SynPat.CreateParen (
SynPat.paren (
SynPat.CreateLongIdent (
SynLongIdent.createS "KeyValue",
[
SynPat.CreateParen (
SynPat.Tuple (
false,
[
SynPat.CreateNamed (Ident.Create "key")
SynPat.CreateNamed (Ident.Create "value")
],
[ range0 ],
range0
)
)
]
[ SynPat.tuple [ SynPat.named "key" ; SynPat.named "value" ] ]
)
),
SynExpr.CreateIdent (Ident.Create "field"),
SynExpr.CreateApp (
SynExpr.createLongIdent [ "ret" ; "Add" ],
SynExpr.CreateParenedTuple
SynExpr.createIdent "field",
SynExpr.applyFunction
(SynExpr.createLongIdent [ "ret" ; "Add" ])
(SynExpr.tuple
[
SynExpr.CreateApp (
SynExpr.createLongIdent [ "key" ; "ToString" ],
SynExpr.CreateConst ()
)
SynExpr.CreateApp (serializeNode valueType, SynExpr.createIdent "value")
]
),
SynExpr.createLongIdent [ "key" ; "ToString" ]
|> SynExpr.applyTo (SynExpr.CreateConst ())
SynExpr.applyFunction (serializeNode valueType) (SynExpr.createIdent "value")
]),
range0
)
SynExpr.createIdent "ret"
]
|> SynExpr.CreateSequential
|> SynExpr.sequential
|> SynExpr.createLet
[
SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonObject" ]
|> SynExpr.applyTo (SynExpr.CreateConst ())
|> SynBinding.basic (SynLongIdent.createS "ret") []
|> SynBinding.basic [ Ident.create "ret" ] []
]
|> SynExpr.createLambda "field"
| _ ->
@@ -157,7 +135,7 @@ module internal JsonSerializeGenerator =
| SynType.LongIdent ident -> ident.LongIdent
| _ -> failwith $"Unrecognised type: %+A{fieldType}"
SynExpr.createLongIdent' (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})`
@@ -168,13 +146,16 @@ module internal JsonSerializeGenerator =
(serializeNode fieldType)
(SynExpr.createLongIdent' [ Ident.create "input" ; fieldId ])
]
|> SynExpr.CreateParenedTuple
|> SynExpr.tuple
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "node" ; "Add" ])
let getPropertyName (fieldId : Ident) (attrs : SynAttribute list) : SynExpr =
let propertyNameAttr =
attrs
|> List.tryFind (fun attr -> attr.TypeName.AsString.EndsWith ("JsonPropertyName", StringComparison.Ordinal))
|> List.tryFind (fun attr ->
(SynLongIdent.toString attr.TypeName)
.EndsWith ("JsonPropertyName", StringComparison.Ordinal)
)
match propertyNameAttr with
| None ->
@@ -213,12 +194,12 @@ module internal JsonSerializeGenerator =
populateNode
SynExpr.Upcast (SynExpr.createIdent "node", SynType.Anon range0, range0)
]
|> SynExpr.CreateSequential
|> SynExpr.sequential
|> SynExpr.createLet
[
SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonObject" ]
|> SynExpr.applyTo (SynExpr.CreateConst ())
|> SynBinding.basic (SynLongIdent.createS "node") []
|> SynBinding.basic [ Ident.create "node" ] []
]
let pattern =
@@ -228,11 +209,11 @@ module internal JsonSerializeGenerator =
if spec.ExtensionMethods then
let componentInfo =
SynComponentInfo.createLong typeName
|> SynComponentInfo.withDocString (PreXmlDoc.Create " Extension methods for JSON parsing")
|> SynComponentInfo.withDocString (PreXmlDoc.create "Extension methods for JSON parsing")
let memberDef =
assignments
|> SynBinding.basic (SynLongIdent.createI functionName) [ pattern ]
|> SynBinding.basic [ functionName ] [ pattern ]
|> SynBinding.withXmlDoc xmlDoc
|> SynBinding.withReturnAnnotation returnInfo
|> SynMemberDefn.staticMember
@@ -246,7 +227,7 @@ module internal JsonSerializeGenerator =
else
let binding =
assignments
|> SynBinding.basic (SynLongIdent.createI functionName) [ pattern ]
|> SynBinding.basic [ functionName ] [ pattern ]
|> SynBinding.withReturnAnnotation returnInfo
|> SynBinding.withXmlDoc xmlDoc
@@ -261,7 +242,7 @@ module internal JsonSerializeGenerator =
let propertyName = getPropertyName fieldData.Ident fieldData.Attrs
createSerializeRhsRecord propertyName fieldData.Ident fieldData.Type
)
|> SynExpr.CreateSequential
|> SynExpr.sequential
|> fun expr -> SynExpr.Do (expr, range0)
|> scaffolding spec typeName inputArg
@@ -294,7 +275,7 @@ module internal JsonSerializeGenerator =
(SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonValue" ; "Create" ])
propertyName
]
|> SynExpr.CreateParenedTuple
|> SynExpr.tuple
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "node" ; "Add" ])
let dataNode =
@@ -316,17 +297,17 @@ module internal JsonSerializeGenerator =
SynExpr.applyFunction (serializeNode fieldData.Type) (SynExpr.createIdent' caseName)
[ propertyName ; node ]
|> SynExpr.CreateParenedTuple
|> SynExpr.tuple
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "dataNode" ; "Add" ])
)
let assignToNode =
[ SynExpr.CreateConst "data" ; SynExpr.createIdent "dataNode" ]
|> SynExpr.CreateParenedTuple
|> SynExpr.tuple
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "node" ; "Add" ])
let dataNode =
SynExpr.CreateSequential (dataBindings @ [ assignToNode ])
SynExpr.sequential (dataBindings @ [ assignToNode ])
|> SynExpr.createLet [ dataNode ]
let action =
@@ -335,7 +316,7 @@ module internal JsonSerializeGenerator =
if not dataBindings.IsEmpty then
yield dataNode
]
|> SynExpr.CreateSequential
|> SynExpr.sequential
SynMatchClause.create pattern action
)
@@ -358,10 +339,7 @@ module internal JsonSerializeGenerator =
if spec.ExtensionMethods then
[ SynAttribute.autoOpen ]
else
[
SynAttribute.RequireQualifiedAccess ()
SynAttribute.compilationRepresentation
]
[ SynAttribute.requireQualifiedAccess ; SynAttribute.compilationRepresentation ]
let xmlDoc =
let fullyQualified = ident |> Seq.map (fun i -> i.idText) |> String.concat "."

29
WoofWare.Myriad.Plugins/RemoveOptionsGenerator.fs
View File

@@ -1,9 +1,7 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia
open Fantomas.FCS.Xml
open Myriad.Core
[<RequireQualifiedAccess>]
module internal RemoveOptionsGenerator =
@@ -83,26 +81,15 @@ module internal RemoveOptionsGenerator =
let body =
match fieldData.Type with
| OptionType _ ->
SynExpr.applyFunction
(SynExpr.CreateAppInfix (
SynExpr.LongIdent (
false,
SynLongIdent.SynLongIdent (
[ Ident.Create "op_PipeRight" ],
[],
[ Some (IdentTrivia.OriginalNotation "|>") ]
),
None,
range0
),
accessor
))
(SynExpr.applyFunction
accessor
|> SynExpr.pipeThroughFunction (
SynExpr.applyFunction
(SynExpr.createLongIdent [ "Option" ; "defaultWith" ])
(SynExpr.createLongIdent' (
withoutOptionsType
@ [ Ident.create (sprintf "Default%s" fieldData.Ident.idText) ]
)))
))
)
| _ -> accessor
(SynLongIdent.createI fieldData.Ident, true), Some body
@@ -111,7 +98,7 @@ module internal RemoveOptionsGenerator =
let binding =
SynBinding.basic
(SynLongIdent.createI functionName)
[ functionName ]
[
SynPat.named inputArg.idText
|> SynPat.annotateType (SynType.LongIdent (SynLongIdent.create withoutOptionsType))
@@ -150,13 +137,15 @@ module internal RemoveOptionsGenerator =
SynComponentInfo.createLong recordId
|> SynComponentInfo.withDocString xmlDoc
|> SynComponentInfo.addAttributes [ SynAttribute.compilationRepresentation ]
|> SynComponentInfo.addAttributes [ SynAttribute.RequireQualifiedAccess () ]
|> SynComponentInfo.addAttributes [ SynAttribute.requireQualifiedAccess ]
let mdl = SynModuleDecl.CreateNestedModule (info, decls)
SynModuleOrNamespace.CreateNamespace (namespaceId, decls = [ mdl ])
| _ -> failwithf "Not a record type"
open Myriad.Core
/// Myriad generator that stamps out a record with option types stripped
/// from the fields at the top level.
[<MyriadGenerator("remove-options")>]

6
WoofWare.Myriad.Plugins/SynExpr/SynArgPats.fs
View File

@@ -1,7 +1,6 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
module internal SynArgPats =
@@ -11,8 +10,7 @@ module internal SynArgPats =
else
caseNames
|> List.map (fun ident -> SynPat.Named (SynIdent.SynIdent (ident, None), false, None, range0))
|> fun ps -> SynPat.Tuple (false, ps, List.replicate (ps.Length - 1) range0, range0)
|> fun p -> SynPat.Paren (p, range0)
|> List.map (fun i -> SynPat.named i.idText)
|> SynPat.tuple
|> List.singleton
|> SynArgPats.Pats

21
WoofWare.Myriad.Plugins/SynExpr/SynAttribute.fs
View File

@@ -2,7 +2,6 @@ namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.Text.Range
open Myriad.Core
[<RequireQualifiedAccess>]
module internal SynAttribute =
@@ -10,12 +9,18 @@ module internal SynAttribute =
{
TypeName = SynLongIdent.createS "CompilationRepresentation"
ArgExpr =
SynExpr.CreateLongIdent (
false,
SynLongIdent.createS' [ "CompilationRepresentationFlags" ; "ModuleSuffix" ],
None
)
|> SynExpr.CreateParen
[ "CompilationRepresentationFlags" ; "ModuleSuffix" ]
|> SynExpr.createLongIdent
|> SynExpr.paren
Target = None
AppliesToGetterAndSetter = false
Range = range0
}
let internal requireQualifiedAccess : SynAttribute =
{
TypeName = SynLongIdent.createS "RequireQualifiedAccess"
ArgExpr = SynExpr.CreateConst ()
Target = None
AppliesToGetterAndSetter = false
Range = range0
@@ -24,7 +29,7 @@ module internal SynAttribute =
let internal autoOpen : SynAttribute =
{
TypeName = SynLongIdent.createS "AutoOpen"
ArgExpr = SynExpr.CreateConst SynConst.Unit
ArgExpr = SynExpr.CreateConst ()
Target = None
AppliesToGetterAndSetter = false
Range = range0

4
WoofWare.Myriad.Plugins/SynExpr/SynBinding.fs
View File

@@ -36,7 +36,7 @@ module internal SynBinding =
SynLeadingKeyword.Let range0
}
let basic (name : SynLongIdent) (args : SynPat list) (body : SynExpr) : SynBinding =
let basic (name : LongIdent) (args : SynPat list) (body : SynExpr) : SynBinding =
let valInfo : SynValInfo =
args
|> List.map (fun pat -> [ SynArgInfo.SynArgInfo (SynAttributes.Empty, false, getName pat) ])
@@ -50,7 +50,7 @@ module internal SynBinding =
[],
PreXmlDoc.Empty,
SynValData.SynValData (None, valInfo, None),
SynPat.LongIdent (name, None, None, SynArgPats.Pats args, None, range0),
SynPat.identWithArgs name (SynArgPats.Pats args),
None,
body,
range0,

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

@@ -23,20 +23,11 @@ module internal SynExpr =
let applyFunction (f : SynExpr) (x : SynExpr) : SynExpr = SynExpr.CreateApp (f, x)
/// {f} {x}
let applyTo (x : SynExpr) (f : SynExpr) : SynExpr = SynExpr.CreateApp (f, x)
let inline applyTo (x : SynExpr) (f : SynExpr) : SynExpr = applyFunction f x
/// {expr} |> {func}
let pipeThroughFunction (func : SynExpr) (expr : SynExpr) : SynExpr =
SynExpr.CreateAppInfix (
SynExpr.CreateLongIdent (
SynLongIdent.SynLongIdent (
[ Ident.Create "op_PipeRight" ],
[],
[ Some (IdentTrivia.OriginalNotation "|>") ]
)
),
expr
)
SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.pipe, expr)
|> applyTo func
/// if {cond} then {trueBranch} else {falseBranch}
@@ -80,17 +71,7 @@ module internal SynExpr =
/// {a} = {b}
let equals (a : SynExpr) (b : SynExpr) =
SynExpr.CreateAppInfix (
SynExpr.CreateLongIdent (
SynLongIdent.SynLongIdent (
Ident.CreateLong "op_Equality",
[],
[ Some (IdentTrivia.OriginalNotation "=") ]
)
),
a
)
|> applyTo b
SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.eq, a) |> applyTo b
/// {a} + {b}
let plus (a : SynExpr) (b : SynExpr) =
@@ -116,7 +97,7 @@ module internal SynExpr =
SynExpr.DotGet (
obj,
range0,
SynLongIdent.SynLongIdent (id = [ Ident.Create meth ], dotRanges = [], trivia = [ None ]),
SynLongIdent.SynLongIdent (id = [ Ident.create meth ], dotRanges = [], trivia = [ None ]),
range0
)
|> applyTo arg
@@ -142,7 +123,7 @@ module internal SynExpr =
SynExpr.TypeApp (
SynExpr.DotGet (obj, range0, SynLongIdent.createS meth, range0),
range0,
[ SynType.CreateLongIdent ty ],
[ SynType.createLongIdent' [ ty ] ],
[],
Some range0,
range0,
@@ -150,9 +131,12 @@ module internal SynExpr =
)
|> applyTo (SynExpr.CreateConst ())
let index (property : SynExpr) (obj : SynExpr) : SynExpr =
let inline index (property : SynExpr) (obj : SynExpr) : SynExpr =
SynExpr.DotIndexedGet (obj, property, range0, range0)
let inline paren (e : SynExpr) : SynExpr =
SynExpr.Paren (e, range0, Some range0, range0)
/// (fun {varName} -> {body})
let createLambda (varName : string) (body : SynExpr) : SynExpr =
let parsedDataPat = [ SynPat.named varName ]
@@ -168,59 +152,68 @@ module internal SynExpr =
ArrowRange = Some range0
}
)
|> SynExpr.CreateParen
|> paren
let createThunk (body : SynExpr) : SynExpr =
let parsedDataPat = [ SynPat.Const (SynConst.Unit, range0) ]
SynExpr.Lambda (
false,
false,
SynSimplePats.Create [],
body,
Some (parsedDataPat, body),
Some ([ SynPat.unit ], body),
range0,
{
ArrowRange = Some range0
}
)
|> SynExpr.CreateParen
/// {body} |> fun a -> Async.StartAsTask (a, ?cancellationToken=ct)
let startAsTask (ct : SynLongIdent) (body : SynExpr) =
let lambda =
[
SynExpr.CreateLongIdent (SynLongIdent.createS "a")
equals
(SynExpr.LongIdent (true, SynLongIdent.createS "cancellationToken", None, range0))
(SynExpr.CreateLongIdent ct)
]
|> SynExpr.CreateParenedTuple
|> applyFunction (SynExpr.CreateLongIdent (SynLongIdent.createS' [ "Async" ; "StartAsTask" ]))
|> createLambda "a"
pipeThroughFunction lambda body
|> paren
let inline createIdent (s : string) : SynExpr = SynExpr.Ident (Ident (s, range0))
let inline createIdent' (i : Ident) : SynExpr = SynExpr.Ident i
let inline createLongIdent (ident : string list) : SynExpr =
SynExpr.CreateLongIdent (SynLongIdent.createS' ident)
let inline createLongIdent' (ident : Ident list) : SynExpr =
SynExpr.CreateLongIdent (SynLongIdent.create ident)
SynExpr.LongIdent (false, SynLongIdent.create ident, None, range0)
let inline createLongIdent (ident : string list) : SynExpr =
createLongIdent' (ident |> List.map Ident.create)
let tupleNoParen (args : SynExpr list) : SynExpr =
SynExpr.Tuple (false, args, List.replicate (args.Length - 1) range0, range0)
let inline tuple (args : SynExpr list) = args |> tupleNoParen |> paren
/// {body} |> fun a -> Async.StartAsTask (a, ?cancellationToken=ct)
let startAsTask (ct : Ident) (body : SynExpr) =
let lambda =
[
createIdent "a"
equals
(SynExpr.LongIdent (true, SynLongIdent.createS "cancellationToken", None, range0))
(createIdent' ct)
]
|> tuple
|> applyFunction (createLongIdent [ "Async" ; "StartAsTask" ])
|> createLambda "a"
pipeThroughFunction lambda body
let inline createLet (bindings : SynBinding list) (body : SynExpr) : SynExpr =
SynExpr.LetOrUse (false, false, bindings, body, range0, SynExprLetOrUseTrivia.empty)
let inline createMatch (matchOn : SynExpr) (cases : SynMatchClause list) : SynExpr =
SynExpr.CreateMatch (matchOn, cases)
SynExpr.Match (
DebugPointAtBinding.Yes range0,
matchOn,
cases,
range0,
{
MatchKeyword = range0
WithKeyword = range0
}
)
let typeAnnotate (ty : SynType) (expr : SynExpr) : SynExpr = SynExpr.CreateTyped (expr, ty)
let inline paren (e : SynExpr) : SynExpr =
SynExpr.Paren (e, range0, Some range0, range0)
let typeAnnotate (ty : SynType) (expr : SynExpr) : SynExpr = SynExpr.Typed (expr, ty, range0)
let inline createNew (ty : SynType) (args : SynExpr) : SynExpr =
SynExpr.New (false, ty, paren args, range0)
@@ -228,8 +221,14 @@ module internal SynExpr =
let inline createWhile (cond : SynExpr) (body : SynExpr) : SynExpr =
SynExpr.While (DebugPointAtWhile.Yes range0, cond, body, range0)
let inline createNull () : SynExpr = SynExpr.Null range0
let reraise : SynExpr = createIdent "reraise" |> applyTo (SynExpr.CreateConst ())
let sequential (exprs : SynExpr list) : SynExpr =
exprs
|> List.reduce (fun a b -> SynExpr.Sequential (DebugPointAtSequential.SuppressNeither, false, a, b, range0))
/// {compExpr} { {lets} ; return {ret} }
let createCompExpr (compExpr : string) (retBody : SynExpr) (lets : CompExprBinding list) : SynExpr =
let retStatement = SynExpr.YieldOrReturn ((false, true), retBody, range0)
@@ -252,25 +251,22 @@ module internal SynExpr =
EqualsRange = Some range0
}
)
| Let (lhs, rhs) -> createLet [ SynBinding.basic (SynLongIdent.createS lhs) [] rhs ] state
| Let (lhs, rhs) -> createLet [ SynBinding.basic [ Ident.create lhs ] [] rhs ] state
| Use (lhs, rhs) ->
SynExpr.LetOrUse (
false,
true,
[ SynBinding.basic (SynLongIdent.createS lhs) [] rhs ],
[ SynBinding.basic [ Ident.create lhs ] [] rhs ],
state,
range0,
{
SynExprLetOrUseTrivia.InKeyword = None
}
)
| Do body -> SynExpr.CreateSequential [ SynExpr.Do (body, range0) ; state ]
| Do body -> sequential [ SynExpr.Do (body, range0) ; state ]
)
SynExpr.CreateApp (
SynExpr.CreateIdent (Ident.Create compExpr),
SynExpr.ComputationExpr (false, contents, range0)
)
applyFunction (createIdent compExpr) (SynExpr.ComputationExpr (false, contents, range0))
/// {expr} |> Async.AwaitTask
let awaitTask (expr : SynExpr) : SynExpr =
@@ -288,49 +284,17 @@ module internal SynExpr =
/// {ident} - {rhs}
let minus (ident : SynLongIdent) (rhs : SynExpr) : SynExpr =
SynExpr.CreateApp (
SynExpr.CreateAppInfix (
SynExpr.CreateLongIdent (
SynLongIdent.SynLongIdent (
[ Ident.Create "op_Subtraction" ],
[],
[ Some (IdentTrivia.OriginalNotation "-") ]
)
),
SynExpr.CreateLongIdent ident
),
rhs
)
SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.sub, SynExpr.CreateLongIdent ident)
|> applyTo rhs
/// {ident} - {n}
let minusN (ident : SynLongIdent) (n : int) : SynExpr = minus ident (SynExpr.CreateConst n)
/// {y} > {x}
let greaterThan (x : SynExpr) (y : SynExpr) : SynExpr =
SynExpr.CreateApp (
SynExpr.CreateAppInfix (
SynExpr.CreateLongIdent (
SynLongIdent.SynLongIdent (
[ Ident.Create "op_GreaterThan" ],
[],
[ Some (IdentTrivia.OriginalNotation ">") ]
)
),
y
),
x
)
SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.ge, y) |> applyTo x
/// {y} >= {x}
let greaterThanOrEqual (x : SynExpr) (y : SynExpr) : SynExpr =
SynExpr.CreateAppInfix (
SynExpr.CreateLongIdent (
SynLongIdent.SynLongIdent (
[ Ident.Create "op_GreaterThanOrEqual" ],
[],
[ Some (IdentTrivia.OriginalNotation ">=") ]
)
),
y
)
SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.geq, y)
|> applyTo x

23
WoofWare.Myriad.Plugins/SynExpr/SynLongIdent.fs
View File

@@ -1,11 +1,34 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.SyntaxTrivia
open Fantomas.FCS.Text.Range
open Fantomas.FCS.Syntax
[<RequireQualifiedAccess>]
module internal SynLongIdent =
let geq =
SynLongIdent.SynLongIdent (
[ Ident.create "op_GreaterThanOrEqual" ],
[],
[ Some (IdentTrivia.OriginalNotation ">=") ]
)
let ge =
SynLongIdent.SynLongIdent ([ Ident.create "op_GreaterThan" ], [], [ Some (IdentTrivia.OriginalNotation ">") ])
let sub =
SynLongIdent.SynLongIdent ([ Ident.create "op_Subtraction" ], [], [ Some (IdentTrivia.OriginalNotation "-") ])
let eq =
SynLongIdent.SynLongIdent ([ Ident.create "op_Equality" ], [], [ Some (IdentTrivia.OriginalNotation "=") ])
let pipe =
SynLongIdent.SynLongIdent ([ Ident.create "op_PipeRight" ], [], [ Some (IdentTrivia.OriginalNotation "|>") ])
let toString (sli : SynLongIdent) : string =
sli.LongIdent |> List.map _.idText |> String.concat "."
let create (ident : LongIdent) : SynLongIdent =
let commas =
match ident with

23
WoofWare.Myriad.Plugins/SynExpr/SynPat.fs
View File

@@ -6,11 +6,28 @@ open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
module internal SynPat =
let annotateType (ty : SynType) (pat : SynPat) =
let inline annotateType (ty : SynType) (pat : SynPat) =
SynPat.Paren (SynPat.Typed (pat, ty, range0), range0)
let named (s : string) : SynPat =
let inline named (s : string) : SynPat =
SynPat.Named (SynIdent.SynIdent (Ident (s, range0), None), false, None, range0)
let namedI (i : Ident) : SynPat =
let inline namedI (i : Ident) : SynPat =
SynPat.Named (SynIdent.SynIdent (i, None), false, None, range0)
let inline identWithArgs (i : LongIdent) (args : SynArgPats) : SynPat =
SynPat.LongIdent (SynLongIdent.create i, None, None, args, None, range0)
let inline tupleNoParen (elements : SynPat list) : SynPat =
match elements with
| [] -> failwith "Can't tuple no elements in a pattern"
| [ p ] -> p
| elements -> SynPat.Tuple (false, elements, List.replicate (elements.Length - 1) range0, range0)
let inline paren (pat : SynPat) : SynPat = SynPat.Paren (pat, range0)
let inline tuple (elements : SynPat list) : SynPat = tupleNoParen elements |> paren
let unit = SynPat.Const (SynConst.Unit, range0)
let createNull = SynPat.Null range0

3
WoofWare.Myriad.Plugins/SynExpr/SynType.fs
View File

@@ -44,6 +44,9 @@ module internal SynType =
let inline var (ty : SynTypar) : SynType = SynType.Var (ty, range0)
let unit : SynType = named "unit"
let int : SynType = named "int"
[<AutoOpen>]
module internal SynTypePatterns =
let (|OptionType|_|) (fieldType : SynType) =

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

@@ -30,13 +30,12 @@
<Compile Include="SynExpr\Ident.fs" />
<Compile Include="SynExpr\SynLongIdent.fs" />
<Compile Include="SynExpr\SynExprLetOrUseTrivia.fs" />
<Compile Include="SynExpr\SynPat.fs" />
<Compile Include="SynExpr\SynBinding.fs" />
<Compile Include="SynExpr\SynType.fs" />
<Compile Include="SynExpr\SynMatchClause.fs" />
<Compile Include="SynExpr\SynPat.fs" />
<Compile Include="SynExpr\CompExpr.fs" />
<Compile Include="SynExpr\SynExpr.fs" />
<Compile Include="SynExpr\SynAttribute.fs" />
<Compile Include="SynExpr\SynArgPats.fs" />
<Compile Include="SynExpr\SynField.fs" />
<Compile Include="SynExpr\SynUnionCase.fs" />
@@ -44,6 +43,7 @@
<Compile Include="SynExpr\SynTypeDefn.fs" />
<Compile Include="SynExpr\SynComponentInfo.fs" />
<Compile Include="SynExpr\SynMemberDefn.fs" />
<Compile Include="SynExpr\SynAttribute.fs" />
<Compile Include="AstHelper.fs" />
<Compile Include="RemoveOptionsGenerator.fs"/>
<Compile Include="InterfaceMockGenerator.fs"/>