Compare commits

...

4 Commits

Author SHA1 Message Date
Smaug123
3d8e453f19 Put spaces back in test name 2024-06-02 20:43:15 +01:00
Patrick Stevens
adf497c5db Tidy up a bit more (#156) 2024-06-01 15:57:53 +01:00
Patrick Stevens
04ecbe6002 Simplify flake (#155) 2024-05-31 21:58:33 +01:00
Patrick Stevens
7b14e52e9d Use our DSLs a bit more (#154) 2024-05-31 19:20:28 +01:00
28 changed files with 625 additions and 996 deletions

View File

@@ -60,7 +60,7 @@ module TreeCata =
instructions.RemoveAt (instructions.Count - 1)
match currentInstruction with
| Instruction.Process__TreeBuilder (x) ->
| Instruction.Process__TreeBuilder x ->
match x with
| TreeBuilder.Child (arg0_0) ->
instructions.Add Instruction.TreeBuilder_Child
@@ -68,7 +68,7 @@ module TreeCata =
| TreeBuilder.Parent (arg0_0) ->
instructions.Add Instruction.TreeBuilder_Parent
instructions.Add (Instruction.Process__Tree arg0_0)
| Instruction.Process__Tree (x) ->
| Instruction.Process__Tree x ->
match x with
| Tree.Const (arg0_0, arg1_0) -> cata.Tree.Const arg0_0 arg1_0 |> treeStack.Add
| Tree.Pair (arg0_0, arg1_0, arg2_0) ->
@@ -92,13 +92,13 @@ module TreeCata =
let arg0_0 = treeStack.[treeStack.Count - 1]
treeStack.RemoveAt (treeStack.Count - 1)
cata.TreeBuilder.Parent arg0_0 |> treeBuilderStack.Add
| Instruction.Tree_Pair (arg2_0) ->
| Instruction.Tree_Pair arg2_0 ->
let arg0_0 = treeStack.[treeStack.Count - 1]
treeStack.RemoveAt (treeStack.Count - 1)
let arg1_0 = treeStack.[treeStack.Count - 1]
treeStack.RemoveAt (treeStack.Count - 1)
cata.Tree.Pair arg0_0 arg1_0 arg2_0 |> treeStack.Add
| Instruction.Tree_Sequential (arg0_0) ->
| Instruction.Tree_Sequential arg0_0 ->
let arg0_0_len = arg0_0
let arg0_0 =

View File

@@ -41,7 +41,7 @@ module FileSystemItemCata =
instructions.RemoveAt (instructions.Count - 1)
match currentInstruction with
| Instruction.Process__FileSystemItem (x) ->
| Instruction.Process__FileSystemItem x ->
match x with
| FileSystemItem.Directory ({
Name = name
@@ -116,7 +116,7 @@ module GiftCata =
instructions.RemoveAt (instructions.Count - 1)
match currentInstruction with
| Instruction.Process__Gift (x) ->
| Instruction.Process__Gift x ->
match x with
| Gift.Book (arg0_0) -> cata.Gift.Book arg0_0 |> giftStack.Add
| Gift.Chocolate (arg0_0) -> cata.Gift.Chocolate arg0_0 |> giftStack.Add
@@ -129,7 +129,7 @@ module GiftCata =
| Gift.WithACard (arg0_0, message) ->
instructions.Add (Instruction.Gift_WithACard (message))
instructions.Add (Instruction.Process__Gift arg0_0)
| Instruction.Gift_Wrapped (arg1_0) ->
| Instruction.Gift_Wrapped arg1_0 ->
let arg0_0 = giftStack.[giftStack.Count - 1]
giftStack.RemoveAt (giftStack.Count - 1)
cata.Gift.Wrapped arg0_0 arg1_0 |> giftStack.Add
@@ -137,7 +137,7 @@ module GiftCata =
let arg0_0 = giftStack.[giftStack.Count - 1]
giftStack.RemoveAt (giftStack.Count - 1)
cata.Gift.Boxed arg0_0 |> giftStack.Add
| Instruction.Gift_WithACard (message) ->
| Instruction.Gift_WithACard message ->
let arg0_0 = giftStack.[giftStack.Count - 1]
giftStack.RemoveAt (giftStack.Count - 1)
cata.Gift.WithACard arg0_0 message |> giftStack.Add

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"))
}

View File

@@ -167,7 +167,7 @@ module FirstDuJsonSerializeExtension =
match input with
| FirstDu.EmptyCase -> node.Add ("type", System.Text.Json.Nodes.JsonValue.Create "emptyCase")
| FirstDu.Case1 (arg0) ->
| FirstDu.Case1 arg0 ->
node.Add ("type", System.Text.Json.Nodes.JsonValue.Create "case1")
let dataNode = System.Text.Json.Nodes.JsonObject ()
dataNode.Add ("data", System.Text.Json.Nodes.JsonValue.Create<string> arg0)

View File

@@ -41,7 +41,7 @@ module MyListCata =
instructions.RemoveAt (instructions.Count - 1)
match currentInstruction with
| Instruction.Process__MyList (x) ->
| Instruction.Process__MyList x ->
match x with
| MyList.Nil -> cata.MyList.Nil |> myListStack.Add
| MyList.Cons ({
@@ -50,7 +50,7 @@ module MyListCata =
}) ->
instructions.Add (Instruction.MyList_Cons (head))
instructions.Add (Instruction.Process__MyList tail)
| Instruction.MyList_Cons (head) ->
| Instruction.MyList_Cons head ->
let tail = myListStack.[myListStack.Count - 1]
myListStack.RemoveAt (myListStack.Count - 1)
cata.MyList.Cons head tail |> myListStack.Add
@@ -97,13 +97,13 @@ module MyList2Cata =
instructions.RemoveAt (instructions.Count - 1)
match currentInstruction with
| Instruction.Process__MyList2 (x) ->
| Instruction.Process__MyList2 x ->
match x with
| MyList2.Nil -> cata.MyList2.Nil |> myList2Stack.Add
| MyList2.Cons (arg0_0, arg1_0) ->
instructions.Add (Instruction.MyList2_Cons (arg0_0))
instructions.Add (Instruction.Process__MyList2 arg1_0)
| Instruction.MyList2_Cons (arg0_0) ->
| Instruction.MyList2_Cons arg0_0 ->
let arg1_0 = myList2Stack.[myList2Stack.Count - 1]
myList2Stack.RemoveAt (myList2Stack.Count - 1)
cata.MyList2.Cons arg0_0 arg1_0 |> myList2Stack.Add

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

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, _) ->
@@ -189,10 +188,6 @@ module internal AstHelper =
}
| _ -> failwithf "Didn't have alternating type-and-star in interface member definition: %+A" tupleType
let toFun (inputs : SynType list) (ret : SynType) : SynType =
(ret, List.rev inputs)
||> List.fold (fun ty input -> SynType.CreateFun (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 =
match ty with
@@ -205,7 +200,7 @@ module internal AstHelper =
| SynType.Paren (argType, _) -> getType argType, true
| _ -> getType argType, false
((toFun (List.map fst inputArgs) inputRet), hasParen) :: args, ret
((SynType.toFun (List.map fst inputArgs) inputRet), hasParen) :: args, ret
| _ -> [], ty
let private parseMember (slotSig : SynValSig) (flags : SynMemberFlags) : Choice<MemberInfo, PropertyInfo> =

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
@@ -470,7 +460,12 @@ module internal CataGenerator =
unionCase.Fields
|> List.map (fun field ->
// TODO: adjust type parameters
SynField.Create field.Type
{
SynFieldData.Type = field.Type
Attrs = []
Ident = None
}
|> SynField.make
)
SynUnionCase.Create (unionCase.Name, fields)
@@ -493,7 +488,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 +496,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 +572,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 +602,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 +708,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 +728,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 +765,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 +782,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 +809,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 +829,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 +891,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 +901,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 +931,7 @@ module internal CataGenerator =
range0,
range0
)
|> SynBinding.basic (SynLongIdent.createI field.ArgName) []
|> SynBinding.basic [ field.ArgName ] []
]
|> Some
| ListSelf synType ->
@@ -1006,7 +967,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 +977,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 +1038,7 @@ module internal CataGenerator =
(SynExpr.paren (SynExpr.minusN (SynLongIdent.createS' [ "instructions" ; "Count" ]) 1))
matchStatement
]
|> SynExpr.CreateSequential
|> SynExpr.sequential
|> SynExpr.createLet
[
SynExpr.DotIndexedGet (
@@ -1091,11 +1047,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 +1082,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 +1110,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
@@ -1197,24 +1153,19 @@ module internal CataGenerator =
let cataRecord =
SynModuleDecl.Types ([ createCataRecord cataName recordDoc analysis ], range0)
SynModuleOrNamespace.CreateNamespace (
ns,
decls =
[
for openStatement in opens do
yield SynModuleDecl.CreateOpen openStatement
yield! cataStructures
yield cataRecord
yield
[
for openStatement in opens do
yield SynModuleDecl.CreateOpen openStatement
yield! cataStructures
yield cataRecord
yield
SynModuleDecl.CreateNestedModule (
modInfo,
[
SynModuleDecl.Types ([ createInstructionType analysis ], range0)
SynModuleDecl.CreateLet (loopFunction :: runFunctions)
]
)
SynModuleDecl.Types ([ createInstructionType analysis ], range0)
SynModuleDecl.createLets (loopFunction :: runFunctions)
]
)
|> SynModuleDecl.nestedModule modInfo
]
|> SynModuleOrNamespace.createNamespace ns
let generate (context : GeneratorContext) : Output =
let ast, _ =

View File

@@ -2,9 +2,6 @@ namespace WoofWare.Myriad.Plugins
open System.Net.Http
open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia
open Fantomas.FCS.Xml
open Myriad.Core
type internal HttpClientGeneratorOutputSpec =
{
@@ -14,7 +11,6 @@ type internal HttpClientGeneratorOutputSpec =
[<RequireQualifiedAccess>]
module internal HttpClientGenerator =
open Fantomas.FCS.Text.Range
open Myriad.Core.Ast
[<RequireQualifiedAccess>]
type PathSpec =
@@ -82,7 +78,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 +140,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 +154,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"
@@ -174,35 +170,6 @@ module internal HttpClientGenerator =
(info : MemberInfo)
: SynMemberDefn
=
let valInfo =
SynValInfo.SynValInfo (
[
[ SynArgInfo.Empty ]
[
for arg in info.Args do
match arg.Id with
| None -> yield SynArgInfo.CreateIdString (failwith "TODO: create an arg name")
| Some id -> yield SynArgInfo.CreateId id
]
],
SynArgInfo.Empty
)
let valData =
SynValData (
Some
{
IsInstance = true
IsDispatchSlot = false
IsOverrideOrExplicitImpl = true
IsFinal = false
GetterOrSetterIsCompilerGenerated = false
MemberKind = SynMemberKind.Member
},
valInfo,
None
)
let args =
info.Args
|> List.map (fun arg ->
@@ -217,7 +184,9 @@ module internal HttpClientGenerator =
else
arg.Type
argName, SynPat.CreateTyped (SynPat.CreateNamed argName, argType)
// We'll be tupling these up anyway, so don't need the parens
// around the type annotations.
argName, SynPat.annotateTypeNoParen argType (SynPat.namedI argName)
)
let cancellationTokenArg =
@@ -225,26 +194,6 @@ 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
)
let requestUriTrailer =
(info.UrlTemplate, info.Args)
||> List.fold (fun template arg ->
@@ -265,10 +214,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 +306,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 +375,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
@@ -454,7 +395,7 @@ module internal HttpClientGenerator =
// new RestEase.Response (content : string, response : HttpResponseMessage, deserialiser : unit -> 'T)
SynExpr.createNew
(SynType.app' (SynType.createLongIdent' [ "RestEase" ; "Response" ]) [ SynType.Anon range0 ])
(SynExpr.CreateTuple
(SynExpr.tupleNoParen
[
SynExpr.createIdent "responseString"
SynExpr.createIdent "response"
@@ -559,7 +500,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 +515,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 +528,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 +554,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,30 +578,22 @@ module internal HttpClientGenerator =
yield jsonNode
]
|> SynExpr.createCompExpr "async" returnExpr
|> SynExpr.startAsTask (SynLongIdent.createI cancellationTokenArg)
|> SynExpr.startAsTask cancellationTokenArg
SynBinding.SynBinding (
None,
SynBindingKind.Normal,
false,
false,
[],
PreXmlDoc.Empty,
valData,
headPat,
None,
implementation,
range0,
DebugPointAtBinding.Yes range0,
SynBinding.triviaZero true
)
let thisIdent =
if variableHeaders.IsEmpty then "_" else "this"
|> Ident.create
let args = args |> List.map snd |> SynPat.tuple |> List.singleton
SynBinding.basic [ thisIdent ; info.Identifier ] args implementation
|> SynBinding.withAccessibility info.Accessibility
|> fun b -> SynMemberDefn.Member (b, range0)
|> SynMemberDefn.memberImplementation
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 +634,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 +647,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"
@@ -830,42 +762,13 @@ module internal HttpClientGenerator =
let propertyMembers =
properties
|> List.map (fun (_, pi) ->
SynMemberDefn.Member (
SynBinding.SynBinding (
pi.Accessibility,
SynBindingKind.Normal,
pi.IsInline,
false,
[],
PreXmlDoc.Empty,
SynValData.SynValData (
Some
{
IsInstance = true
IsDispatchSlot = false
IsOverrideOrExplicitImpl = true
IsFinal = false
GetterOrSetterIsCompilerGenerated = false
MemberKind = SynMemberKind.Member
},
SynValInfo.SynValInfo ([ [ SynArgInfo.Empty ] ; [] ], SynArgInfo.Empty),
None
),
SynPat.CreateLongIdent (SynLongIdent.create [ Ident.create "_" ; pi.Identifier ], []),
Some (SynBindingReturnInfo.Create pi.Type),
SynExpr.applyFunction
(SynExpr.createLongIdent' [ Ident.lowerFirstLetter pi.Identifier ])
(SynExpr.CreateConst ()),
range0,
DebugPointAtBinding.Yes range0,
{
LeadingKeyword = SynLeadingKeyword.Member range0
InlineKeyword = if pi.IsInline then Some range0 else None
EqualsRange = Some range0
}
),
range0
)
SynExpr.createLongIdent' [ Ident.lowerFirstLetter pi.Identifier ]
|> SynExpr.applyTo (SynExpr.CreateConst ())
|> SynBinding.basic [ Ident.create "_" ; pi.Identifier ] []
|> SynBinding.withReturnAnnotation pi.Type
|> SynBinding.setInline pi.IsInline
|> SynBinding.withAccessibility pi.Accessibility
|> SynMemberDefn.memberImplementation
)
let members = propertyMembers @ nonPropertyMembers
@@ -910,27 +813,6 @@ module internal HttpClientGenerator =
let functionName = Ident.create "client"
let valData =
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
SynValData.SynValData (
memberFlags,
SynValInfo.SynValInfo ([ [ SynArgInfo.SynArgInfo ([], false, Some functionName) ] ], SynArgInfo.Empty),
None
)
let pattern = SynLongIdent.createS "make"
let returnInfo = SynType.createLongIdent interfaceType.Name
@@ -947,7 +829,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,11 +846,10 @@ 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
|> SynModuleDecl.CreateLet
|> SynModuleDecl.createLet
let moduleName =
if spec.ExtensionMethods then
@@ -980,10 +861,7 @@ module internal HttpClientGenerator =
if spec.ExtensionMethods then
[ SynAttribute.autoOpen ]
else
[
SynAttribute.compilationRepresentation
SynAttribute.RequireQualifiedAccess ()
]
[ SynAttribute.compilationRepresentation ; SynAttribute.requireQualifiedAccess ]
let modInfo =
SynComponentInfo.create moduleName
@@ -991,15 +869,14 @@ module internal HttpClientGenerator =
|> SynComponentInfo.addAttributes attribs
|> SynComponentInfo.setAccessibility interfaceType.Accessibility
SynModuleOrNamespace.CreateNamespace (
ns,
decls =
[
for openStatement in opens do
yield SynModuleDecl.CreateOpen openStatement
yield SynModuleDecl.CreateNestedModule (modInfo, [ createFunc ])
]
)
[
for openStatement in opens do
yield SynModuleDecl.openAny openStatement
yield SynModuleDecl.nestedModule modInfo [ createFunc ]
]
|> SynModuleOrNamespace.createNamespace ns
open Myriad.Core
/// Myriad generator that provides an HTTP client for an interface type using RestEase annotations.
[<MyriadGenerator("http-client")>]

View File

@@ -2,9 +2,7 @@ namespace WoofWare.Myriad.Plugins
open System
open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia
open Fantomas.FCS.Xml
open Myriad.Core
type internal GenerateMockOutputSpec =
{
@@ -14,7 +12,6 @@ type internal GenerateMockOutputSpec =
[<RequireQualifiedAccess>]
module internal InterfaceMockGenerator =
open Fantomas.FCS.Text.Range
open Myriad.Core.Ast
let private getName (SynField (_, _, id, _, _, _, _, _, _)) =
match id with
@@ -49,13 +46,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 +64,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,27 +78,27 @@ 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)
|> SynMemberDefn.staticMember
let fields =
let extras =
if inherits.Contains KnownInheritance.IDisposable then
[
SynField.Create (
SynType.CreateFun (SynType.CreateUnit, SynType.CreateUnit),
Ident.Create "Dispose",
xmldoc = PreXmlDoc.Create " Implementation of IDisposable.Dispose"
)
]
{
Attrs = []
Ident = Some (Ident.create "Dispose")
Type = SynType.funFromDomain SynType.unit SynType.unit
}
|> SynField.make
|> SynField.withDocString (PreXmlDoc.create "Implementation of IDisposable.Dispose")
|> List.singleton
else
[]
@@ -111,47 +108,6 @@ module internal InterfaceMockGenerator =
let members =
interfaceType.Members
|> List.map (fun memberInfo ->
let synValData =
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
)
]
yield!
memberInfo.Args
|> List.mapi (fun i arg ->
arg.Args
|> List.mapi (fun j arg ->
match arg.Type with
| UnitType -> SynArgInfo.SynArgInfo ([], false, None)
| _ -> SynArgInfo.CreateIdString $"arg_%i{i}_%i{j}"
)
)
],
returnInfo =
SynArgInfo.SynArgInfo (attributes = [], optional = false, ident = None)
),
thisIdOpt = None
)
let headArgs =
memberInfo.Args
|> List.mapi (fun i tupledArgs ->
@@ -159,27 +115,15 @@ 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
)
let headPat =
SynPat.LongIdent (
SynLongIdent.create [ Ident.Create "this" ; memberInfo.Identifier ],
None,
None,
SynArgPats.Pats headArgs,
None,
range0
| args -> SynPat.tuple args
|> fun i -> if tupledArgs.HasParen then SynPat.paren i else i
)
let body =
@@ -192,7 +136,7 @@ module internal InterfaceMockGenerator =
| UnitType -> SynExpr.CreateConst ()
| _ -> SynExpr.createIdent $"arg_%i{i}_%i{j}"
)
|> SynExpr.CreateParenedTuple
|> SynExpr.tuple
)
match tuples |> List.rev with
@@ -200,33 +144,13 @@ 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 (
SynBinding.SynBinding (
None,
SynBindingKind.Normal,
false,
false,
[],
PreXmlDoc.Empty,
synValData,
headPat,
None,
body,
range0,
DebugPointAtBinding.Yes range0,
{
LeadingKeyword = SynLeadingKeyword.Member range0
InlineKeyword = None
EqualsRange = Some range0
}
),
range0
)
SynBinding.basic [ Ident.create "this" ; memberInfo.Identifier ] headArgs body
|> SynMemberDefn.memberImplementation
)
let interfaceName =
@@ -260,18 +184,15 @@ module internal InterfaceMockGenerator =
|> Seq.map (fun inheritance ->
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 ())
|> SynBinding.makeInstanceMember
let mem = SynMemberDefn.Member (binding, range0)
let mem =
SynExpr.createLongIdent [ "this" ; "Dispose" ]
|> SynExpr.applyTo (SynExpr.CreateConst ())
|> SynBinding.basic [ Ident.create "this" ; Ident.create "Dispose" ] [ SynPat.unit ]
|> SynBinding.withReturnAnnotation SynType.unit
|> SynMemberDefn.memberImplementation
SynMemberDefn.Interface (
SynType.CreateLongIdent (SynLongIdent.createS' [ "System" ; "IDisposable" ]),
SynType.createLongIdent' [ "System" ; "IDisposable" ],
Some range0,
Some [ mem ],
range0
@@ -281,7 +202,7 @@ module internal InterfaceMockGenerator =
let record =
{
Name = Ident.Create name
Name = Ident.create name
Fields = fields
Members = Some ([ constructor ; interfaceMembers ] @ extraInterfaces)
XmlDoc = Some xmlDoc
@@ -312,19 +233,15 @@ module internal InterfaceMockGenerator =
let constructMember (mem : MemberInfo) : SynField =
let inputType = mem.Args |> List.map constructMemberSinglePlace
let funcType = AstHelper.toFun inputType mem.ReturnType
let funcType = SynType.toFun inputType mem.ReturnType
SynField.SynField (
[],
false,
Some mem.Identifier,
funcType,
false,
mem.XmlDoc |> Option.defaultValue PreXmlDoc.Empty,
None,
range0,
SynFieldTrivia.Zero
)
{
Type = funcType
Attrs = []
Ident = Some mem.Identifier
}
|> SynField.make
|> SynField.withDocString (mem.XmlDoc |> Option.defaultValue PreXmlDoc.Empty)
let createRecord
(namespaceId : LongIdent)
@@ -334,7 +251,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
@@ -348,10 +265,10 @@ module internal InterfaceMockGenerator =
let typeDecl = createType spec name interfaceType docString fields
SynModuleOrNamespace.CreateNamespace (
namespaceId,
decls = (opens |> List.map SynModuleDecl.CreateOpen) @ [ typeDecl ]
)
[ yield! opens |> List.map SynModuleDecl.openAny ; yield typeDecl ]
|> SynModuleOrNamespace.createNamespace namespaceId
open Myriad.Core
/// Myriad generator that creates a record which implements the given interface,
/// but with every field mocked out.

View File

@@ -4,8 +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 =
{
@@ -15,7 +13,6 @@ type internal JsonParseOutputSpec =
[<RequireQualifiedAccess>]
module internal JsonParseGenerator =
open Fantomas.FCS.Text.Range
open Myriad.Core.Ast
type JsonParseOption =
{
@@ -42,7 +39,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 +101,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
@@ -125,9 +122,10 @@ module internal JsonParseGenerator =
let valueArg = SynExpr.createLongIdent [ "kvp" ; "Value" ] |> SynExpr.paren
SynExpr.CreateTuple [ SynExpr.createIdent "key" ; SynExpr.createIdent "value" ]
|> SynExpr.createLet [ SynBinding.Let (pattern = SynPat.named "value", expr = value valueArg) ]
|> SynExpr.createLet [ SynBinding.Let (pattern = SynPat.named "key", expr = key keyArg) ]
// No need to paren here, we're on the LHS of a `let`
SynExpr.tupleNoParen [ SynExpr.createIdent "key" ; SynExpr.createIdent "value" ]
|> SynExpr.createLet [ SynBinding.basic [ Ident.create "value" ] [] (value valueArg) ]
|> SynExpr.createLet [ SynBinding.basic [ Ident.create "key" ] [] (key keyArg) ]
|> SynExpr.createLambda "kvp"
/// A conforming JSON object has only strings as keys. But it would be reasonable to allow the user
@@ -308,14 +306,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,16 +322,18 @@ 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
|> SynModuleDecl.CreateLet
|> SynModuleDecl.createLet
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 +356,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 +384,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,19 +412,19 @@ 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
| SynExpr.Const (synConst, _) ->
SynMatchClause.SynMatchClause (
SynPat.CreateConst synConst,
SynPat.createConst synConst,
None,
body,
range0,
@@ -471,7 +471,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 +485,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 +496,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,27 +522,25 @@ 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 =
[ scaffolding spec ident decl ]
|> fun d -> SynModuleDecl.CreateNestedModule (info, d)
[ scaffolding spec ident decl ]
|> SynModuleDecl.nestedModule info
|> List.singleton
|> SynModuleOrNamespace.createNamespace namespaceId
SynModuleOrNamespace.CreateNamespace (namespaceId, decls = [ mdl ])
open Myriad.Core
/// Myriad generator that provides a method (possibly an extension method) for a record type,
/// containing a JSON parse function.

View File

@@ -3,9 +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 =
{
@@ -15,7 +12,6 @@ type internal JsonSerializeOutputSpec =
[<RequireQualifiedAccess>]
module internal JsonSerializeGenerator =
open Fantomas.FCS.Text.Range
open Myriad.Core.Ast
/// Given `input.Ident`, for example, choose how to add it to the ambient `node`.
/// The result is a line like `(fun ident -> InnerType.toJsonNode ident)` or `(fun ident -> JsonValue.Create ident)`.
@@ -40,28 +36,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.identWithArgs [ Ident.create "Some" ] (SynArgPats.create [ Ident.create "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 +70,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 +99,30 @@ module internal JsonSerializeGenerator =
DebugPointAtInOrTo.Yes range0,
SeqExprOnly.SeqExprOnly false,
true,
SynPat.CreateParen (
SynPat.CreateLongIdent (
SynLongIdent.createS "KeyValue",
[
SynPat.CreateParen (
SynPat.Tuple (
false,
[
SynPat.CreateNamed (Ident.Create "key")
SynPat.CreateNamed (Ident.Create "value")
],
[ range0 ],
range0
)
)
]
)
SynPat.paren (
SynPat.identWithArgs
[ Ident.create "KeyValue" ]
(SynArgPats.create [ Ident.create "key" ; Ident.create "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 +132,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 +143,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,26 +191,26 @@ 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 =
SynPat.CreateNamed inputArgName
SynPat.namedI inputArgName
|> SynPat.annotateType (SynType.LongIdent (SynLongIdent.create typeName))
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
@@ -244,13 +222,11 @@ module internal JsonSerializeGenerator =
SynModuleDecl.Types ([ containingType ], range0)
else
let binding =
assignments
|> SynBinding.basic (SynLongIdent.createI functionName) [ pattern ]
|> SynBinding.withReturnAnnotation returnInfo
|> SynBinding.withXmlDoc xmlDoc
SynModuleDecl.CreateLet [ binding ]
assignments
|> SynBinding.basic [ functionName ] [ pattern ]
|> SynBinding.withReturnAnnotation returnInfo
|> SynBinding.withXmlDoc xmlDoc
|> SynModuleDecl.createLet
let recordModule (spec : JsonSerializeOutputSpec) (typeName : LongIdent) (fields : SynField list) =
let inputArg = Ident.create "input"
@@ -261,7 +237,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,17 +270,13 @@ module internal JsonSerializeGenerator =
(SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonValue" ; "Create" ])
propertyName
]
|> SynExpr.CreateParenedTuple
|> SynExpr.tuple
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "node" ; "Add" ])
let dataNode =
SynBinding.Let (
pattern = SynPat.named "dataNode",
expr =
SynExpr.applyFunction
(SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonObject" ])
(SynExpr.CreateConst ())
)
SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonObject" ]
|> SynExpr.applyTo (SynExpr.CreateConst ())
|> SynBinding.basic [ Ident.create "dataNode" ] []
let dataBindings =
(unionCase.Fields, caseNames)
@@ -316,17 +288,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 +307,7 @@ module internal JsonSerializeGenerator =
if not dataBindings.IsEmpty then
yield dataNode
]
|> SynExpr.CreateSequential
|> SynExpr.sequential
SynMatchClause.create pattern action
)
@@ -358,10 +330,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 "."
@@ -403,12 +372,13 @@ module internal JsonSerializeGenerator =
[ unionModule spec ident unionFields ]
| _ -> failwithf "Only record types currently supported."
let mdl = SynModuleDecl.CreateNestedModule (info, decls)
[
yield! opens |> List.map SynModuleDecl.openAny
yield SynModuleDecl.nestedModule info decls
]
|> SynModuleOrNamespace.createNamespace namespaceId
SynModuleOrNamespace.CreateNamespace (
namespaceId,
decls = (opens |> List.map SynModuleDecl.CreateOpen) @ [ mdl ]
)
open Myriad.Core
/// Myriad generator that provides a method (possibly an extension method) for a record type,
/// containing a JSON serialization function.

View File

@@ -1,14 +1,11 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia
open Fantomas.FCS.Xml
open Myriad.Core
[<RequireQualifiedAccess>]
module internal RemoveOptionsGenerator =
open Fantomas.FCS.Text.Range
open Myriad.Core.Ast
let private removeOption (s : SynField) : SynField =
let (SynField.SynField (synAttributeLists,
@@ -83,44 +80,31 @@ 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
)
|> AstHelper.instantiateRecord
let binding =
SynBinding.basic
(SynLongIdent.createI functionName)
[
SynPat.named inputArg.idText
|> SynPat.annotateType (SynType.LongIdent (SynLongIdent.create withoutOptionsType))
]
body
|> SynBinding.withXmlDoc xmlDoc
|> SynBinding.withReturnAnnotation (SynType.LongIdent (SynLongIdent.create withOptionsType))
SynModuleDecl.CreateLet [ binding ]
SynBinding.basic
[ functionName ]
[
SynPat.named inputArg.idText
|> SynPat.annotateType (SynType.LongIdent (SynLongIdent.create withoutOptionsType))
]
body
|> SynBinding.withXmlDoc xmlDoc
|> SynBinding.withReturnAnnotation (SynType.LongIdent (SynLongIdent.create withOptionsType))
|> SynModuleDecl.createLet
let createRecordModule (namespaceId : LongIdent) (typeDefn : SynTypeDefn) =
let (SynTypeDefn (synComponentInfo, synTypeDefnRepr, _members, _implicitCtor, _, _)) =
@@ -150,13 +134,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 ])
SynModuleDecl.nestedModule info decls
|> List.singleton
|> SynModuleOrNamespace.createNamespace namespaceId
| _ -> 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")>]

View File

@@ -1,18 +1,16 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
module internal SynArgPats =
let create (caseNames : Ident list) : SynArgPats =
if caseNames.IsEmpty then
SynArgPats.Pats []
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.singleton
|> SynArgPats.Pats
match caseNames.Length with
| 0 -> SynArgPats.Pats []
| 1 -> [ SynPat.named caseNames.[0].idText ] |> SynArgPats.Pats
| _ ->
caseNames
|> List.map (fun i -> SynPat.named i.idText)
|> SynPat.tuple
|> List.singleton
|> SynArgPats.Pats

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

View File

@@ -16,14 +16,18 @@ module internal SynBinding =
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
| _ -> None
let private getArgInfo (pat : SynPat) : SynArgInfo list =
// TODO: this only copes with one layer of tupling
match stripParen pat with
| SynPat.Tuple (_, pats, _, _) -> pats |> List.map (fun pat -> SynArgInfo.SynArgInfo ([], false, getName pat))
| pat -> [ SynArgInfo.SynArgInfo (SynAttributes.Empty, false, getName pat) ]
let triviaZero (isMember : bool) =
{
@@ -36,10 +40,10 @@ 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) ])
|> List.map getArgInfo
|> fun x -> SynValInfo.SynValInfo (x, SynArgInfo.SynArgInfo ([], false, None))
SynBinding.SynBinding (
@@ -50,7 +54,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,
@@ -103,7 +107,7 @@ module internal SynBinding =
trivia
)
let makeInline (binding : SynBinding) : SynBinding =
let inline makeInline (binding : SynBinding) : SynBinding =
match binding with
| SynBinding (acc, kind, _, mut, attrs, doc, valData, headPat, ret, expr, range, debugPoint, trivia) ->
SynBinding (
@@ -124,6 +128,33 @@ module internal SynBinding =
}
)
let inline makeNotInline (binding : SynBinding) : SynBinding =
match binding with
| SynBinding (acc, kind, _, mut, attrs, doc, valData, headPat, ret, expr, range, debugPoint, trivia) ->
SynBinding (
acc,
kind,
false,
mut,
attrs,
doc,
valData,
headPat,
ret,
expr,
range,
debugPoint,
{ trivia with
InlineKeyword = None
}
)
let inline setInline (isInline : bool) (binding : SynBinding) : SynBinding =
if isInline then
makeInline binding
else
makeNotInline binding
let makeStaticMember (binding : SynBinding) : SynBinding =
let memberFlags =
{

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

View File

@@ -1,6 +1,9 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Text.Range
open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia
open Fantomas.FCS.Xml
type internal SynFieldData<'Ident> =
{
@@ -37,3 +40,30 @@ module internal SynField =
| None -> failwith "expected field identifier to have a value, but it did not"
| Some i -> i
)
let make (data : SynFieldData<Ident option>) : SynField =
let attrs : SynAttributeList list =
data.Attrs
|> List.map (fun l ->
{
Attributes = [ l ]
Range = range0
}
)
SynField.SynField (
attrs,
false,
data.Ident,
data.Type,
false,
PreXmlDoc.Empty,
None,
range0,
SynFieldTrivia.Zero
)
let withDocString (doc : PreXmlDoc) (f : SynField) : SynField =
match f with
| SynField (attributes, isStatic, idOpt, fieldType, isMutable, _, accessibility, range, trivia) ->
SynField (attributes, isStatic, idOpt, fieldType, isMutable, doc, accessibility, range, trivia)

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

View File

@@ -59,3 +59,7 @@ module internal SynMemberDefn =
let staticMember (binding : SynBinding) : SynMemberDefn =
let binding = SynBinding.makeStaticMember binding
SynMemberDefn.Member (binding, range0)
let memberImplementation (binding : SynBinding) : SynMemberDefn =
let binding = SynBinding.makeInstanceMember binding
SynMemberDefn.Member (binding, range0)

View File

@@ -0,0 +1,28 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia
open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
module internal SynModuleDecl =
let inline openAny (ident : SynOpenDeclTarget) : SynModuleDecl = SynModuleDecl.Open (ident, range0)
let inline createLets (bindings : SynBinding list) : SynModuleDecl =
SynModuleDecl.Let (false, bindings, range0)
let inline createLet (binding : SynBinding) : SynModuleDecl = createLets [ binding ]
let nestedModule (info : SynComponentInfo) (decls : SynModuleDecl list) : SynModuleDecl =
SynModuleDecl.NestedModule (
info,
false,
decls,
false,
range0,
{
ModuleKeyword = Some range0
EqualsRange = Some range0
}
)

View File

@@ -0,0 +1,24 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia
open Fantomas.FCS.Xml
open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
module internal SynModuleOrNamespace =
let createNamespace (name : LongIdent) (decls : SynModuleDecl list) =
SynModuleOrNamespace.SynModuleOrNamespace (
name,
false,
SynModuleOrNamespaceKind.DeclaredNamespace,
decls,
PreXmlDoc.Empty,
[],
None,
range0,
{
LeadingKeyword = SynModuleOrNamespaceLeadingKeyword.Namespace range0
}
)

View File

@@ -5,12 +5,31 @@ open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
module internal SynPat =
let inline paren (pat : SynPat) : SynPat = SynPat.Paren (pat, range0)
let annotateType (ty : SynType) (pat : SynPat) =
SynPat.Paren (SynPat.Typed (pat, ty, range0), range0)
let inline annotateTypeNoParen (ty : SynType) (pat : SynPat) = SynPat.Typed (pat, ty, range0)
let named (s : string) : SynPat =
let inline annotateType (ty : SynType) (pat : SynPat) = paren (annotateTypeNoParen ty pat)
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 tuple (elements : SynPat list) : SynPat = tupleNoParen elements |> paren
let inline createConst (c : SynConst) = SynPat.Const (c, range0)
let unit = createConst SynConst.Unit
let createNull = SynPat.Null range0

View File

@@ -44,6 +44,13 @@ module internal SynType =
let inline var (ty : SynTypar) : SynType = SynType.Var (ty, range0)
let unit : SynType = named "unit"
let int : SynType = named "int"
/// Given ['a1, 'a2] and 'ret, returns 'a1 -> 'a2 -> 'ret.
let toFun (inputs : SynType list) (ret : SynType) : SynType =
(ret, List.rev inputs) ||> List.fold (fun ty input -> funFromDomain input ty)
[<AutoOpen>]
module internal SynTypePatterns =
let (|OptionType|_|) (fieldType : SynType) =

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,9 @@
<Compile Include="SynExpr\SynTypeDefn.fs" />
<Compile Include="SynExpr\SynComponentInfo.fs" />
<Compile Include="SynExpr\SynMemberDefn.fs" />
<Compile Include="SynExpr\SynAttribute.fs" />
<Compile Include="SynExpr\SynModuleDecl.fs" />
<Compile Include="SynExpr\SynModuleOrNamespace.fs" />
<Compile Include="AstHelper.fs" />
<Compile Include="RemoveOptionsGenerator.fs"/>
<Compile Include="InterfaceMockGenerator.fs"/>

View File

@@ -45,44 +45,19 @@
packages = {
fantomas = dotnetTool null "fantomas" (builtins.fromJSON (builtins.readFile ./.config/dotnet-tools.json)).tools.fantomas.version (builtins.head (builtins.filter (elem: elem.pname == "fantomas") ((import ./nix/deps.nix) {fetchNuGet = x: x;}))).sha256;
fsharp-analyzers = dotnetTool "FSharp.Analyzers.Cli" "fsharp-analyzers" (builtins.fromJSON (builtins.readFile ./.config/dotnet-tools.json)).tools.fsharp-analyzers.version (builtins.head (builtins.filter (elem: elem.pname == "fsharp-analyzers") ((import ./nix/deps.nix) {fetchNuGet = x: x;}))).sha256;
fetchDeps = let
flags = [];
runtimeIds = ["win-x64"] ++ map (system: pkgs.dotnetCorePackages.systemToDotnetRid system) dotnet-sdk.meta.platforms;
in
pkgs.writeShellScriptBin "fetch-${pname}-deps" (builtins.readFile (pkgs.substituteAll {
src = ./nix/fetchDeps.sh;
pname = pname;
binPath = pkgs.lib.makeBinPath [pkgs.coreutils dotnet-sdk (pkgs.nuget-to-nix.override {inherit dotnet-sdk;})];
projectFiles = toString ["./WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj" "./ConsumePlugin/ConsumePlugin.fsproj" "./WoofWare.Myriad.Plugins.Attributes/WoofWare.Myriad.Plugins.Attributes.fsproj"];
testProjectFiles = ["./WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj" "./WoofWare.Myriad.Plugins.Attributes/Test/Woofware.Myriad.Plugins.Attributes.Test.fsproj"];
rids = pkgs.lib.concatStringsSep "\" \"" runtimeIds;
packages = dotnet-sdk.packages;
storeSrc = pkgs.srcOnly {
src = ./.;
pname = pname;
version = version;
};
}));
default = pkgs.buildDotnetModule {
pname = pname;
inherit pname version dotnet-sdk dotnet-runtime;
name = "WoofWare.Myriad.Plugins";
version = version;
src = ./.;
projectFile = "./WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj";
nugetDeps = ./nix/deps.nix;
testProjectFile = "./WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj";
disabledTests = ["WoofWare.Myriad.Plugins.Test.TestSurface.CheckVersionAgainstRemote"];
nugetDeps = ./nix/deps.nix; # `nix build .#default.passthru.fetch-deps && ./result` and put the result here
doCheck = true;
dotnet-sdk = dotnet-sdk;
dotnet-runtime = dotnet-runtime;
};
};
devShell = pkgs.mkShell {
buildInputs = with pkgs; [
(with dotnetCorePackages;
combinePackages [
dotnet-sdk_8
dotnetPackages.Nuget
])
];
buildInputs = [dotnet-sdk];
packages = [
pkgs.alejandra
pkgs.nodePackages.markdown-link-check

View File

@@ -1,21 +1,16 @@
# This file was automatically generated by passthru.fetch-deps.
# Please don't edit it manually, your changes might get overwritten!
# Please dont edit it manually, your changes might get overwritten!
{fetchNuGet}: [
(fetchNuGet {
pname = "fsharp-analyzers";
version = "0.26.0";
sha256 = "sha256-60Bl36LOb/zVNdH2SBSuQ5O41lP9dKTNZbs5vvYs+3U=";
})
(fetchNuGet {
pname = "fantomas";
version = "6.3.4";
sha256 = "sha256-1aWqZynBkQoznenGoP0sbf1PcUXAbcHiWyECuv89xa0=";
})
(fetchNuGet {
pname = "ApiSurface";
version = "4.0.40";
sha256 = "1c9z0b6minlripwrjmv4yd5w8zj4lcpak4x41izh7ygx8kgmbvx0";
})
(fetchNuGet {
pname = "fantomas";
version = "6.3.4";
sha256 = "1bf57pzvl0i1bgic2vf08mqlzzbd5kys1ip9klrhm4f155ksm9fm";
})
(fetchNuGet {
pname = "Fantomas.Core";
version = "6.1.1";
@@ -31,6 +26,11 @@
version = "2.16.6";
sha256 = "176rwky6b5rk8dzldiz4068p7m9c5y9ygzbhadrs14jkl94pc56n";
})
(fetchNuGet {
pname = "fsharp-analyzers";
version = "0.26.0";
sha256 = "0xgv5kvbwfdvcp6s8x7xagbbi4s3mqa4ixni6pazqvyflbgnah7b";
})
(fetchNuGet {
pname = "FSharp.Core";
version = "4.3.4";
@@ -56,61 +56,26 @@
version = "6.0.26";
sha256 = "1d8nkz24vsm0iy2xm8y5ak2q1w1p99dxyz0y26acs6sfk2na0vm6";
})
(fetchNuGet {
pname = "Microsoft.AspNetCore.App.Ref";
version = "8.0.1";
sha256 = "0yaaiqq7mi6sclyrb1v0fyncanbx0ifmnnhv9whynqj8439jsdwh";
})
(fetchNuGet {
pname = "Microsoft.AspNetCore.App.Runtime.linux-arm64";
version = "6.0.26";
sha256 = "1za8lc52m4z54d68wd64c2nhzy05g3gx171k5cdlx73fbymiys9z";
})
(fetchNuGet {
pname = "Microsoft.AspNetCore.App.Runtime.linux-arm64";
version = "8.0.1";
sha256 = "0dsdgqg7566qximmjfza4x9if3icy4kskq698ddj5apdia88h2mw";
})
(fetchNuGet {
pname = "Microsoft.AspNetCore.App.Runtime.linux-x64";
version = "6.0.26";
sha256 = "1zpbmz6z8758gwywzg0bac8kx9x39sxxc9j4a4r2jl74l9ssw4vm";
})
(fetchNuGet {
pname = "Microsoft.AspNetCore.App.Runtime.linux-x64";
version = "8.0.1";
sha256 = "1gjz379y61ag9whi78qxx09bwkwcznkx2mzypgycibxk61g11da1";
})
(fetchNuGet {
pname = "Microsoft.AspNetCore.App.Runtime.osx-arm64";
version = "6.0.26";
sha256 = "1i8ydlwjzk7j0mzvn0rpljxfp1h50zwaqalnyvfxai1fwgigzgw5";
})
(fetchNuGet {
pname = "Microsoft.AspNetCore.App.Runtime.osx-arm64";
version = "8.0.1";
sha256 = "0w3mrs4zdl9mfanl1j81759xwwrzmicsjxn6yfxv5yrxbxzq695n";
})
(fetchNuGet {
pname = "Microsoft.AspNetCore.App.Runtime.osx-x64";
version = "6.0.26";
sha256 = "02src68hd3213sd1a2ms1my7i92knfmdxclvv90il9cky2zsq8kw";
})
(fetchNuGet {
pname = "Microsoft.AspNetCore.App.Runtime.osx-x64";
version = "8.0.1";
sha256 = "0a9aljr4fy4haq6ndz2y723liv5hbfpss1rn45s88nmgcp27m15m";
})
(fetchNuGet {
pname = "Microsoft.AspNetCore.App.Runtime.win-x64";
version = "6.0.26";
sha256 = "1gxlmfdkfzmhw9pac5jiv674nn6i1zymcp2hj81irjwhhjk01mf5";
})
(fetchNuGet {
pname = "Microsoft.AspNetCore.App.Runtime.win-x64";
version = "8.0.1";
sha256 = "01kzndyqmsvcq49i2jrv7ymfp0l71yxfylv1cy3nhkdbprqz8ipx";
})
(fetchNuGet {
pname = "Microsoft.Build.Tasks.Git";
version = "8.0.0";
@@ -131,111 +96,46 @@
version = "6.0.26";
sha256 = "19y6c6v20bgf7x7rrh4rx9y7s5fy8vp5m4j9b6gi1wp4rpb5mza4";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Host.linux-arm64";
version = "8.0.1";
sha256 = "0dhpdlcdz7adcfh9w01fc867051m35fqaxnvj3fqvqhgcm2n3143";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Host.linux-x64";
version = "6.0.26";
sha256 = "0p7hhidaa3mnyiwnsijwy8578v843x8hh99255s69qwwyld6falv";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Host.linux-x64";
version = "8.0.1";
sha256 = "1aw6mc7zcmzs1grxz2wa9cw9kfj8pz7zpj417xnp1a9n4ix1bxgr";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Host.osx-arm64";
version = "6.0.26";
sha256 = "1mq11xsv9g1vsasp6k80y7xlvwi9hrpk5dgm773fvy8538s01gfv";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Host.osx-arm64";
version = "8.0.1";
sha256 = "1dzg3prng9zfdzz7gcgywjdbwzhwm85j89z0jahynxx4q2dra4b9";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Host.osx-x64";
version = "6.0.26";
sha256 = "1chac9b4424ihrrnlzvc7qz6j4ymfjyv4kzyazzzw19yhymdkh2s";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Host.osx-x64";
version = "8.0.1";
sha256 = "010f8wn15s2kv7yyzgys3pv9i1mxw20hpv1ig2zhybjxs8lpj8jj";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Host.win-x64";
version = "6.0.26";
sha256 = "0i7g9fsqjnbh9rc6807m57r2idg5pkcw6xjfwhnxkcpgqm96258v";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Host.win-x64";
version = "8.0.1";
sha256 = "1ssj1cyam3nfidm8q82kvh4i3fzm2lzb3bxw6ck09hwhvwh909z4";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Ref";
version = "6.0.26";
sha256 = "12gb52dhg5h9hgnyqh1zgj2w46paxv2pfh33pphl9ajhrdr7hlsb";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Ref";
version = "8.0.1";
sha256 = "02r4jg4ha0qksix9v6s3cpmvavmz54gkawkxy9bvknw5ynxhhl1l";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Runtime.linux-arm64";
version = "6.0.26";
sha256 = "164hfrwqz5dxcbb441lridk4mzcqmarb0b7ckgvqhsvpawyjw88v";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Runtime.linux-arm64";
version = "8.0.1";
sha256 = "0353whnjgz3sqhzsfrviad3a3db4pk7hl7m4wwppv5mqdg9i9ri5";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Runtime.linux-x64";
version = "6.0.26";
sha256 = "0islayddpnflviqpbq4djc4f3v9nhsa2y76k5x6il3csq5vdw2hq";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Runtime.linux-x64";
version = "8.0.1";
sha256 = "1g5b30f4l8a1zjjr3b8pk9mcqxkxqwa86362f84646xaj4iw3a4d";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Runtime.osx-arm64";
version = "6.0.26";
sha256 = "1acn5zw1pxzmcg3c0pbf9hal36fbdh9mvbsiwra7simrk7hzqpdc";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Runtime.osx-arm64";
version = "8.0.1";
sha256 = "0cdrpdaq5sl3602anfx1p0z0ncx2sjjvl6mgsd6y38g47n7f95jc";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Runtime.osx-x64";
version = "6.0.26";
sha256 = "00f9l9dkdz0zv5csaw8fkm6s8ckrj5n9k3ygz12daa22l3bcn6ii";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Runtime.osx-x64";
version = "8.0.1";
sha256 = "1fk1flqp6ji0l4c2gvh83ykndpx7a2nkkgrgkgql3c75j1k2v1s9";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Runtime.win-x64";
version = "6.0.26";
sha256 = "0i2p356phfc5y6qnr3vyrzjfi1mrbwfb6g85k4q37bbyxjfp7zl9";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Runtime.win-x64";
version = "8.0.1";
sha256 = "198576cdkl72xs29zznff9ls763p8pfr0zji7b74dqxd5ga0s3bd";
})
(fetchNuGet {
pname = "Microsoft.NETCore.Platforms";
version = "1.1.0";

View File

@@ -1,73 +0,0 @@
#!/bin/bash
# This file was adapted from
# https://github.com/NixOS/nixpkgs/blob/b981d811453ab84fb3ea593a9b33b960f1ab9147/pkgs/build-support/dotnet/build-dotnet-module/default.nix#L173
set -euo pipefail
export PATH="@binPath@"
for arg in "$@"; do
case "$arg" in
--keep-sources|-k)
keepSources=1
shift
;;
--help|-h)
echo "usage: $0 [--keep-sources] [--help] <output path>"
echo " <output path> The path to write the lockfile to. A temporary file is used if this is not set"
echo " --keep-sources Don't remove temporary directories upon exit, useful for debugging"
echo " --help Show this help message"
exit
;;
esac
done
tmp=$(mktemp -td "@pname@-tmp-XXXXXX")
export tmp
HOME=$tmp/home
exitTrap() {
test -n "${ranTrap-}" && return
ranTrap=1
if test -n "${keepSources-}"; then
echo -e "Path to the source: $tmp/src\nPath to the fake home: $tmp/home"
else
rm -rf "$tmp"
fi
# Since mktemp is used this will be empty if the script didnt succesfully complete
if ! test -s "$depsFile"; then
rm -rf "$depsFile"
fi
}
trap exitTrap EXIT INT TERM
dotnetRestore() {
local -r project="${1-}"
local -r rid="$2"
dotnet restore "${project-}" \
-p:ContinuousIntegrationBuild=true \
-p:Deterministic=true \
--packages "$tmp/nuget_pkgs" \
--runtime "$rid" \
--no-cache \
--force
}
declare -a projectFiles=( @projectFiles@ )
declare -a testProjectFiles=( @testProjectFiles@ )
export DOTNET_NOLOGO=1
export DOTNET_CLI_TELEMETRY_OPTOUT=1
depsFile=$(realpath "${1:-$(mktemp -t "@pname@-deps-XXXXXX.nix")}")
mkdir -p "$tmp/nuget_pkgs"
storeSrc="@storeSrc@"
src="$tmp/src"
cp -rT "$storeSrc" "$src"
chmod -R +w "$src"
cd "$src"
echo "Restoring project..."
rids=("@rids@")
for rid in "${rids[@]}"; do
(( ${#projectFiles[@]} == 0 )) && dotnetRestore "" "$rid"
for project in "${projectFiles[@]-}" "${testProjectFiles[@]-}"; do
dotnetRestore "$project" "$rid"
done
done
echo "Successfully restored project"
echo "Writing lockfile..."
echo -e "# This file was automatically generated by passthru.fetch-deps.\n# Please don't edit it manually, your changes might get overwritten!\n" > "$depsFile"
nuget-to-nix "$tmp/nuget_pkgs" "@packages@" >> "$depsFile"
echo "Successfully wrote lockfile to $depsFile"