diff --git a/ConsumePlugin/GeneratedCatamorphism.fs b/ConsumePlugin/GeneratedCatamorphism.fs index 1acef92..4d280ee 100644 --- a/ConsumePlugin/GeneratedCatamorphism.fs +++ b/ConsumePlugin/GeneratedCatamorphism.fs @@ -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 = diff --git a/ConsumePlugin/GeneratedFileSystem.fs b/ConsumePlugin/GeneratedFileSystem.fs index 62c2e8e..26932d9 100644 --- a/ConsumePlugin/GeneratedFileSystem.fs +++ b/ConsumePlugin/GeneratedFileSystem.fs @@ -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 diff --git a/ConsumePlugin/GeneratedSerde.fs b/ConsumePlugin/GeneratedSerde.fs index e2635dc..104819a 100644 --- a/ConsumePlugin/GeneratedSerde.fs +++ b/ConsumePlugin/GeneratedSerde.fs @@ -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 arg0) diff --git a/ConsumePlugin/ListCata.fs b/ConsumePlugin/ListCata.fs index 0a7ecb3..91c01f8 100644 --- a/ConsumePlugin/ListCata.fs +++ b/ConsumePlugin/ListCata.fs @@ -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 diff --git a/WoofWare.Myriad.Plugins/AstHelper.fs b/WoofWare.Myriad.Plugins/AstHelper.fs index 5869213..4321cf4 100644 --- a/WoofWare.Myriad.Plugins/AstHelper.fs +++ b/WoofWare.Myriad.Plugins/AstHelper.fs @@ -188,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.funFromDomain input ty) - /// Returns the args (where these are tuple types if curried) in order, and the return type. let rec getType (ty : SynType) : (SynType * bool) list * SynType = match ty with @@ -204,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 = diff --git a/WoofWare.Myriad.Plugins/CataGenerator.fs b/WoofWare.Myriad.Plugins/CataGenerator.fs index 16bc6a3..411fe71 100644 --- a/WoofWare.Myriad.Plugins/CataGenerator.fs +++ b/WoofWare.Myriad.Plugins/CataGenerator.fs @@ -460,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) @@ -1148,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, _ = diff --git a/WoofWare.Myriad.Plugins/HttpClientGenerator.fs b/WoofWare.Myriad.Plugins/HttpClientGenerator.fs index 8239a43..e7e51f1 100644 --- a/WoofWare.Myriad.Plugins/HttpClientGenerator.fs +++ b/WoofWare.Myriad.Plugins/HttpClientGenerator.fs @@ -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 = [] module internal HttpClientGenerator = open Fantomas.FCS.Text.Range - open Myriad.Core.Ast [] type PathSpec = @@ -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,16 +194,6 @@ module internal HttpClientGenerator = | None -> failwith $"expected an optional cancellation token as final arg in %s{info.Identifier.idText}" | Some (arg, _) -> arg - let headPat = - let thisIdent = if variableHeaders.IsEmpty then "_" else "this" - - args - |> List.map snd - |> SynPat.tuple - |> List.singleton - |> SynArgPats.Pats - |> SynPat.identWithArgs [ Ident.create thisIdent ; info.Identifier ] - let requestUriTrailer = (info.UrlTemplate, info.Args) ||> List.fold (fun template arg -> @@ -436,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" @@ -621,23 +580,15 @@ module internal HttpClientGenerator = |> SynExpr.createCompExpr "async" returnExpr |> 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 @@ -811,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 @@ -891,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 @@ -948,8 +849,7 @@ module internal HttpClientGenerator = 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 @@ -969,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. [] diff --git a/WoofWare.Myriad.Plugins/InterfaceMockGenerator.fs b/WoofWare.Myriad.Plugins/InterfaceMockGenerator.fs index afe7d16..cbc86c1 100644 --- a/WoofWare.Myriad.Plugins/InterfaceMockGenerator.fs +++ b/WoofWare.Myriad.Plugins/InterfaceMockGenerator.fs @@ -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 = [] module internal InterfaceMockGenerator = open Fantomas.FCS.Text.Range - open Myriad.Core.Ast let private getName (SynField (_, _, id, _, _, _, _, _, _)) = match id with @@ -87,21 +84,21 @@ module internal InterfaceMockGenerator = else [ SynPat.unit ]) (AstHelper.instantiateRecord constructorFields) - |> SynBinding.makeStaticMember |> SynBinding.withXmlDoc (PreXmlDoc.create "An implementation where every method throws.") |> SynBinding.withReturnAnnotation constructorReturnType - |> fun m -> SynMemberDefn.Member (m, range0) + |> SynMemberDefn.staticMember let fields = let extras = if inherits.Contains KnownInheritance.IDisposable then - [ - SynField.Create ( - SynType.funFromDomain SynType.unit SynType.unit, - 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 -> @@ -170,16 +126,6 @@ module internal InterfaceMockGenerator = |> fun i -> if tupledArgs.HasParen then SynPat.paren i else i ) - let headPat = - SynPat.LongIdent ( - SynLongIdent.create [ Ident.create "this" ; memberInfo.Identifier ], - None, - None, - SynArgPats.Pats headArgs, - None, - range0 - ) - let body = let tuples = memberInfo.Args @@ -203,28 +149,8 @@ module internal InterfaceMockGenerator = 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 = @@ -258,14 +184,12 @@ module internal InterfaceMockGenerator = |> Seq.map (fun inheritance -> match inheritance with | KnownInheritance.IDisposable -> - let binding = + let mem = SynExpr.createLongIdent [ "this" ; "Dispose" ] |> SynExpr.applyTo (SynExpr.CreateConst ()) |> SynBinding.basic [ Ident.create "this" ; Ident.create "Dispose" ] [ SynPat.unit ] |> SynBinding.withReturnAnnotation SynType.unit - |> SynBinding.makeInstanceMember - - let mem = SynMemberDefn.Member (binding, range0) + |> SynMemberDefn.memberImplementation SynMemberDefn.Interface ( SynType.createLongIdent' [ "System" ; "IDisposable" ], @@ -309,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) @@ -345,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. diff --git a/WoofWare.Myriad.Plugins/JsonParseGenerator.fs b/WoofWare.Myriad.Plugins/JsonParseGenerator.fs index 048780f..17071fc 100644 --- a/WoofWare.Myriad.Plugins/JsonParseGenerator.fs +++ b/WoofWare.Myriad.Plugins/JsonParseGenerator.fs @@ -4,7 +4,6 @@ open System open System.Text open Fantomas.FCS.Syntax open Fantomas.FCS.SyntaxTrivia -open Myriad.Core type internal JsonParseOutputSpec = { @@ -14,7 +13,6 @@ type internal JsonParseOutputSpec = [] module internal JsonParseGenerator = open Fantomas.FCS.Text.Range - open Myriad.Core.Ast type JsonParseOption = { @@ -124,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 @@ -326,8 +325,7 @@ module internal JsonParseGenerator = 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) @@ -426,7 +424,7 @@ module internal JsonParseGenerator = match propertyName with | SynExpr.Const (synConst, _) -> SynMatchClause.SynMatchClause ( - SynPat.CreateConst synConst, + SynPat.createConst synConst, None, body, range0, @@ -537,11 +535,12 @@ module internal JsonParseGenerator = |> 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. diff --git a/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs b/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs index 189cdcd..c2d50b3 100644 --- a/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs +++ b/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs @@ -3,7 +3,6 @@ namespace WoofWare.Myriad.Plugins open System open System.Text open Fantomas.FCS.Syntax -open Myriad.Core type internal JsonSerializeOutputSpec = { @@ -13,7 +12,6 @@ type internal JsonSerializeOutputSpec = [] 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)`. @@ -51,7 +49,7 @@ module internal JsonSerializeGenerator = |> SynExpr.paren |> SynExpr.upcast' (SynType.createLongIdent' [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ]) |> SynMatchClause.create ( - SynPat.CreateLongIdent (SynLongIdent.createS "Some", [ SynPat.named "field" ]) + SynPat.identWithArgs [ Ident.create "Some" ] (SynArgPats.create [ Ident.create "field" ]) ) [ noneClause ; someClause ] @@ -102,10 +100,9 @@ module internal JsonSerializeGenerator = SeqExprOnly.SeqExprOnly false, true, SynPat.paren ( - SynPat.CreateLongIdent ( - SynLongIdent.createS "KeyValue", - [ SynPat.tuple [ SynPat.named "key" ; SynPat.named "value" ] ] - ) + SynPat.identWithArgs + [ Ident.create "KeyValue" ] + (SynArgPats.create [ Ident.create "key" ; Ident.create "value" ]) ), SynExpr.createIdent "field", SynExpr.applyFunction @@ -203,7 +200,7 @@ module internal JsonSerializeGenerator = ] let pattern = - SynPat.CreateNamed inputArgName + SynPat.namedI inputArgName |> SynPat.annotateType (SynType.LongIdent (SynLongIdent.create typeName)) if spec.ExtensionMethods then @@ -225,13 +222,11 @@ module internal JsonSerializeGenerator = SynModuleDecl.Types ([ containingType ], range0) else - let binding = - assignments - |> SynBinding.basic [ 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" @@ -279,13 +274,9 @@ module internal JsonSerializeGenerator = |> 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) @@ -381,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. diff --git a/WoofWare.Myriad.Plugins/RemoveOptionsGenerator.fs b/WoofWare.Myriad.Plugins/RemoveOptionsGenerator.fs index ed8f428..31825ae 100644 --- a/WoofWare.Myriad.Plugins/RemoveOptionsGenerator.fs +++ b/WoofWare.Myriad.Plugins/RemoveOptionsGenerator.fs @@ -6,7 +6,6 @@ open Fantomas.FCS.Xml [] module internal RemoveOptionsGenerator = open Fantomas.FCS.Text.Range - open Myriad.Core.Ast let private removeOption (s : SynField) : SynField = let (SynField.SynField (synAttributeLists, @@ -96,18 +95,16 @@ module internal RemoveOptionsGenerator = ) |> AstHelper.instantiateRecord - let 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 [ 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, _, _)) = @@ -139,9 +136,9 @@ module internal RemoveOptionsGenerator = |> SynComponentInfo.addAttributes [ SynAttribute.compilationRepresentation ] |> 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 diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynArgPats.fs b/WoofWare.Myriad.Plugins/SynExpr/SynArgPats.fs index 950074f..0bf66a4 100644 --- a/WoofWare.Myriad.Plugins/SynExpr/SynArgPats.fs +++ b/WoofWare.Myriad.Plugins/SynExpr/SynArgPats.fs @@ -5,12 +5,12 @@ open Fantomas.FCS.Syntax [] module internal SynArgPats = let create (caseNames : Ident list) : SynArgPats = - if caseNames.IsEmpty then - SynArgPats.Pats [] - else - - caseNames - |> List.map (fun i -> SynPat.named i.idText) - |> SynPat.tuple - |> 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 diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynBinding.fs b/WoofWare.Myriad.Plugins/SynExpr/SynBinding.fs index 2a9f771..a1f4404 100644 --- a/WoofWare.Myriad.Plugins/SynExpr/SynBinding.fs +++ b/WoofWare.Myriad.Plugins/SynExpr/SynBinding.fs @@ -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) = { @@ -39,7 +43,7 @@ module internal 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 ( @@ -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 = { diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynField.fs b/WoofWare.Myriad.Plugins/SynExpr/SynField.fs index 257e124..6286787 100644 --- a/WoofWare.Myriad.Plugins/SynExpr/SynField.fs +++ b/WoofWare.Myriad.Plugins/SynExpr/SynField.fs @@ -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) : 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) diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynMemberDefn.fs b/WoofWare.Myriad.Plugins/SynExpr/SynMemberDefn.fs index 95eb7d7..6b10344 100644 --- a/WoofWare.Myriad.Plugins/SynExpr/SynMemberDefn.fs +++ b/WoofWare.Myriad.Plugins/SynExpr/SynMemberDefn.fs @@ -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) diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynModuleDecl.fs b/WoofWare.Myriad.Plugins/SynExpr/SynModuleDecl.fs new file mode 100644 index 0000000..a637bfd --- /dev/null +++ b/WoofWare.Myriad.Plugins/SynExpr/SynModuleDecl.fs @@ -0,0 +1,28 @@ +namespace WoofWare.Myriad.Plugins + +open Fantomas.FCS.Syntax +open Fantomas.FCS.SyntaxTrivia +open Fantomas.FCS.Text.Range + +[] +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 + } + ) diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynModuleOrNamespace.fs b/WoofWare.Myriad.Plugins/SynExpr/SynModuleOrNamespace.fs new file mode 100644 index 0000000..d17fc74 --- /dev/null +++ b/WoofWare.Myriad.Plugins/SynExpr/SynModuleOrNamespace.fs @@ -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 + +[] +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 + } + ) diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynPat.fs b/WoofWare.Myriad.Plugins/SynExpr/SynPat.fs index d1cd2d6..3988f16 100644 --- a/WoofWare.Myriad.Plugins/SynExpr/SynPat.fs +++ b/WoofWare.Myriad.Plugins/SynExpr/SynPat.fs @@ -5,9 +5,11 @@ open Fantomas.FCS.Text.Range [] module internal SynPat = + let inline paren (pat : SynPat) : SynPat = SynPat.Paren (pat, range0) + + let inline annotateTypeNoParen (ty : SynType) (pat : SynPat) = SynPat.Typed (pat, ty, range0) - let inline annotateType (ty : SynType) (pat : SynPat) = - SynPat.Paren (SynPat.Typed (pat, ty, range0), range0) + 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) @@ -24,10 +26,10 @@ module internal SynPat = | [ p ] -> p | elements -> SynPat.Tuple (false, elements, List.replicate (elements.Length - 1) range0, range0) - let inline paren (pat : SynPat) : SynPat = SynPat.Paren (pat, range0) - let inline tuple (elements : SynPat list) : SynPat = tupleNoParen elements |> paren - let unit = SynPat.Const (SynConst.Unit, range0) + let inline createConst (c : SynConst) = SynPat.Const (c, range0) + + let unit = createConst SynConst.Unit let createNull = SynPat.Null range0 diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynType.fs b/WoofWare.Myriad.Plugins/SynExpr/SynType.fs index 3c60f4b..7f273fe 100644 --- a/WoofWare.Myriad.Plugins/SynExpr/SynType.fs +++ b/WoofWare.Myriad.Plugins/SynExpr/SynType.fs @@ -47,6 +47,10 @@ module internal SynType = 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) + [] module internal SynTypePatterns = let (|OptionType|_|) (fieldType : SynType) = diff --git a/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj b/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj index 65041b4..b0a90a0 100644 --- a/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj +++ b/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj @@ -44,6 +44,8 @@ + +