From ff2c08d54f65da3c0e63d04e9bd5c7dd0d9303cc Mon Sep 17 00:00:00 2001 From: Patrick Stevens <3138005+Smaug123@users.noreply.github.com> Date: Sat, 30 Dec 2023 23:41:27 +0000 Subject: [PATCH] Stamp out records corresponding to interfaces (#56) --- ConsumePlugin/AssemblyInfo.fs | 5 + ConsumePlugin/ConsumePlugin.fsproj | 17 +- ConsumePlugin/GeneratedJson.fs | 1 + ConsumePlugin/GeneratedMock.fs | 74 ++++ ConsumePlugin/GeneratedPureGymDto.fs | 1 + ConsumePlugin/GeneratedRestClient.fs | 1 + ConsumePlugin/MockExample.fs | 22 ++ README.md | 46 +++ .../TestMockGenerator/TestMockGenerator.fs | 21 ++ .../WoofWare.Myriad.Plugins.Test.fsproj | 3 +- WoofWare.Myriad.Plugins/AstHelper.fs | 237 +++++++++++-- .../HttpClientGenerator.fs | 291 +++++----------- .../InterfaceMockGenerator.fs | 326 ++++++++++++++++++ WoofWare.Myriad.Plugins/JsonParseGenerator.fs | 4 +- .../RemoveOptionsGenerator.fs | 31 +- WoofWare.Myriad.Plugins/SurfaceBaseline.txt | 4 + WoofWare.Myriad.Plugins/SynExpr.fs | 11 + .../WoofWare.Myriad.Plugins.fsproj | 1 + WoofWare.Myriad.Plugins/version.json | 2 +- 19 files changed, 852 insertions(+), 246 deletions(-) create mode 100644 ConsumePlugin/AssemblyInfo.fs create mode 100644 ConsumePlugin/GeneratedMock.fs create mode 100644 ConsumePlugin/MockExample.fs create mode 100644 WoofWare.Myriad.Plugins.Test/TestMockGenerator/TestMockGenerator.fs create mode 100644 WoofWare.Myriad.Plugins/InterfaceMockGenerator.fs diff --git a/ConsumePlugin/AssemblyInfo.fs b/ConsumePlugin/AssemblyInfo.fs new file mode 100644 index 0000000..af862b4 --- /dev/null +++ b/ConsumePlugin/AssemblyInfo.fs @@ -0,0 +1,5 @@ +namespace ConsumePlugin.AssemblyInfo + +[] + +do () diff --git a/ConsumePlugin/ConsumePlugin.fsproj b/ConsumePlugin/ConsumePlugin.fsproj index 808c436..518896a 100644 --- a/ConsumePlugin/ConsumePlugin.fsproj +++ b/ConsumePlugin/ConsumePlugin.fsproj @@ -10,21 +10,26 @@ + - - RecordFile.fs + + RecordFile.fs - - JsonRecord.fs + + JsonRecord.fs - PureGymDto.fs + PureGymDto.fs - RestApiExample.fs + RestApiExample.fs + + + + MockExample.fs runmyriad.sh diff --git a/ConsumePlugin/GeneratedJson.fs b/ConsumePlugin/GeneratedJson.fs index c51e2f5..16f4e36 100644 --- a/ConsumePlugin/GeneratedJson.fs +++ b/ConsumePlugin/GeneratedJson.fs @@ -3,6 +3,7 @@ // Changes to this file will be lost when the code is regenerated. //------------------------------------------------------------------------------ + namespace ConsumePlugin /// Module containing JSON parsing methods for the InnerType type diff --git a/ConsumePlugin/GeneratedMock.fs b/ConsumePlugin/GeneratedMock.fs new file mode 100644 index 0000000..918d11b --- /dev/null +++ b/ConsumePlugin/GeneratedMock.fs @@ -0,0 +1,74 @@ +//------------------------------------------------------------------------------ +// This code was generated by myriad. +// Changes to this file will be lost when the code is regenerated. +//------------------------------------------------------------------------------ + +namespace SomeNamespace + +/// Mock record type for an interface +type internal PublicTypeMock = + { + Mem1 : string * int -> string list + Mem2 : string -> int + } + + static member Empty : PublicTypeMock = + { + Mem1 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function")) + Mem2 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function")) + } + + interface IPublicType with + member this.Mem1 (arg0, arg1) = this.Mem1 (arg0, arg1) + member this.Mem2 (arg0) = this.Mem2 (arg0) +namespace SomeNamespace + +/// Mock record type for an interface +type internal InternalTypeMock = + { + Mem1 : string * int -> unit + Mem2 : string -> int + } + + static member Empty : InternalTypeMock = + { + Mem1 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function")) + Mem2 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function")) + } + + interface InternalType with + member this.Mem1 (arg0, arg1) = this.Mem1 (arg0, arg1) + member this.Mem2 (arg0) = this.Mem2 (arg0) +namespace SomeNamespace + +/// Mock record type for an interface +type private PrivateTypeMock = + { + Mem1 : string * int -> unit + Mem2 : string -> int + } + + static member Empty : PrivateTypeMock = + { + Mem1 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function")) + Mem2 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function")) + } + + interface PrivateType with + member this.Mem1 (arg0, arg1) = this.Mem1 (arg0, arg1) + member this.Mem2 (arg0) = this.Mem2 (arg0) +namespace SomeNamespace + +/// Mock record type for an interface +type internal VeryPublicTypeMock<'a, 'b> = + { + Mem1 : 'a -> 'b + } + + static member Empty<'a, 'b> () : VeryPublicTypeMock<'a, 'b> = + { + Mem1 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function")) + } + + interface VeryPublicType<'a, 'b> with + member this.Mem1 (arg0) = this.Mem1 (arg0) diff --git a/ConsumePlugin/GeneratedPureGymDto.fs b/ConsumePlugin/GeneratedPureGymDto.fs index d97aa14..7fc1049 100644 --- a/ConsumePlugin/GeneratedPureGymDto.fs +++ b/ConsumePlugin/GeneratedPureGymDto.fs @@ -3,6 +3,7 @@ // Changes to this file will be lost when the code is regenerated. //------------------------------------------------------------------------------ + namespace PureGym /// Module containing JSON parsing methods for the GymOpeningHours type diff --git a/ConsumePlugin/GeneratedRestClient.fs b/ConsumePlugin/GeneratedRestClient.fs index 6071063..1c3262f 100644 --- a/ConsumePlugin/GeneratedRestClient.fs +++ b/ConsumePlugin/GeneratedRestClient.fs @@ -4,6 +4,7 @@ //------------------------------------------------------------------------------ + namespace PureGym open System diff --git a/ConsumePlugin/MockExample.fs b/ConsumePlugin/MockExample.fs new file mode 100644 index 0000000..569fe9f --- /dev/null +++ b/ConsumePlugin/MockExample.fs @@ -0,0 +1,22 @@ +namespace SomeNamespace + +open WoofWare.Myriad.Plugins + +[] +type IPublicType = + abstract Mem1 : string * int -> string list + abstract Mem2 : string -> int + +[] +type internal InternalType = + abstract Mem1 : string * int -> unit + abstract Mem2 : string -> int + +[] +type private PrivateType = + abstract Mem1 : string * int -> unit + abstract Mem2 : string -> int + +[] +type VeryPublicType<'a, 'b> = + abstract Mem1 : 'a -> 'b diff --git a/README.md b/README.md index 60d62a6..020c95b 100644 --- a/README.md +++ b/README.md @@ -16,6 +16,7 @@ Currently implemented: * `JsonParse` (to stamp out `jsonParse : JsonNode -> 'T` methods); * `RemoveOptions` (to strip `option` modifiers from a type). * `HttpClient` (to stamp out a [RestEase](https://github.com/canton7/RestEase)-style HTTP client). +* `GenerateMock` (to stamp out a record type corresponding to an interface). ## `JsonParse` @@ -219,6 +220,51 @@ There are also some design decisions: * Every function must take an optional `CancellationToken` (which is good practice anyway); so arguments are forced to be tupled. +## `GenerateMock` + +Takes a type like this: + +```fsharp +[] +type IPublicType = + abstract Mem1 : string * int -> string list + abstract Mem2 : string -> int +``` + +and stamps out a type like this: + +```fsharp +/// Mock record type for an interface +type internal PublicTypeMock = + { + Mem1 : string * int -> string list + Mem2 : string -> int + } + + static member Empty : PublicTypeMock = + { + Mem1 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function")) + Mem2 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function")) + } + + interface IPublicType with + member this.Mem1 (arg0, arg1) = this.Mem1 (arg0, arg1) + member this.Mem2 (arg0) = this.Mem2 (arg0) +``` + +### What's the point? + +Reflective mocking libraries like [Foq](https://github.com/fsprojects/Foq) in my experience are a rich source of flaky tests. +The [Grug-brained developer](https://grugbrain.dev/) would prefer to do this without reflection, and this reduces the rate of strange one-in-ten-thousand "failed to generate IL" errors. +But since F# does not let you partially update an interface definition, we instead stamp out a record, +thereby allowing the programmer to use F#'s record-update syntax. + +### Limitations + +* We currently only support interfaces with tupled arguments. +* We make the resulting record type at most internal (never public), since this is intended only to be used in tests. + You will therefore need an `AssemblyInfo.fs` file [like the one in WoofWare.Myriad's own tests](./ConsumePlugin/AssemblyInfo.fs). + # Detailed examples See the tests. diff --git a/WoofWare.Myriad.Plugins.Test/TestMockGenerator/TestMockGenerator.fs b/WoofWare.Myriad.Plugins.Test/TestMockGenerator/TestMockGenerator.fs new file mode 100644 index 0000000..9511801 --- /dev/null +++ b/WoofWare.Myriad.Plugins.Test/TestMockGenerator/TestMockGenerator.fs @@ -0,0 +1,21 @@ +namespace WoofWare.Myriad.Plugins.Test + +open System +open SomeNamespace +open NUnit.Framework +open FsUnitTyped + +[] +module TestMockGenerator = + + [] + let ``Example of use: IPublicType`` () = + let mock = + { PublicTypeMock.Empty with + Mem1 = fun (s, count) -> List.replicate count s + } + + let _ = + Assert.Throws (fun () -> mock.Mem2 "hi" |> ignore) + + mock.Mem1 ("hi", 3) |> shouldEqual [ "hi" ; "hi" ; "hi" ] diff --git a/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj b/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj index 98be32c..a4c81e6 100644 --- a/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj +++ b/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj @@ -17,8 +17,9 @@ - + + diff --git a/WoofWare.Myriad.Plugins/AstHelper.fs b/WoofWare.Myriad.Plugins/AstHelper.fs index 1418deb..dd6f196 100644 --- a/WoofWare.Myriad.Plugins/AstHelper.fs +++ b/WoofWare.Myriad.Plugins/AstHelper.fs @@ -6,26 +6,64 @@ open Fantomas.FCS.Text.Range open Fantomas.FCS.Xml open Myriad.Core.AstExtensions +type internal ParameterInfo = + { + Attributes : SynAttribute list + IsOptional : bool + Id : Ident option + Type : SynType + } + +type internal MemberInfo = + { + ReturnType : SynType + Arity : SynArgInfo list + Args : ParameterInfo list + Identifier : Ident + Attributes : SynAttribute list + XmlDoc : PreXmlDoc option + } + +type internal InterfaceType = + { + Attributes : SynAttribute list + Name : LongIdent + Members : MemberInfo list + Generics : SynTyparDecls option + Accessibility : SynAccess option + } + +type internal RecordType = + { + Name : Ident + Fields : SynField seq + Members : SynMemberDefns option + XmlDoc : PreXmlDoc option + Generics : SynTyparDecls option + Accessibility : SynAccess option + } + [] module internal AstHelper = - let constructRecord (fields : (RecordFieldName * SynExpr option) list) : SynExpr = + let instantiateRecord (fields : (RecordFieldName * SynExpr option) list) : SynExpr = let fields = fields |> List.map (fun (rfn, synExpr) -> SynExprRecordField (rfn, Some range0, synExpr, None)) SynExpr.Record (None, None, fields, range0) - let private createRecordType - ( - name : Ident, - repr : SynTypeDefnRepr, - members : SynMemberDefns, - xmldoc : PreXmlDoc - ) - : SynTypeDefn - = - let name = SynComponentInfo.Create ([ name ], xmldoc = xmldoc) + let defineRecordType (record : RecordType) : SynTypeDefn = + let repr = + SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (None, Seq.toList record.Fields, range0), range0) + + let name = + SynComponentInfo.Create ( + [ record.Name ], + ?xmldoc = record.XmlDoc, + ?parameters = record.Generics, + access = record.Accessibility + ) let trivia : SynTypeDefnTrivia = { @@ -34,21 +72,7 @@ module internal AstHelper = WithKeyword = Some range0 } - SynTypeDefn (name, repr, members, None, range0, trivia) - - let defineRecordType - ( - name : Ident, - fields : SynField seq, - members : SynMemberDefns option, - xmldoc : PreXmlDoc option - ) - : SynTypeDefn - = - let repr = - SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (None, Seq.toList fields, range0), range0) - - createRecordType (name, repr, defaultArg members SynMemberDefns.Empty, defaultArg xmldoc PreXmlDoc.Empty) + SynTypeDefn (name, repr, defaultArg record.Members SynMemberDefns.Empty, None, range0, trivia) let isOptionIdent (ident : SynLongIdent) : bool = match ident.LongIdent with @@ -75,6 +99,167 @@ module internal AstHelper = false | _ -> false + let rec private extractOpensFromDecl (moduleDecls : SynModuleDecl list) : SynOpenDeclTarget list = + moduleDecls + |> List.choose (fun moduleDecl -> + match moduleDecl with + | SynModuleDecl.Open (target, _) -> Some target + | _ -> None + ) + + let extractOpens (ast : ParsedInput) : SynOpenDeclTarget list = + match ast with + | ParsedInput.ImplFile (ParsedImplFileInput (_, _, _, _, _, modules, _, _, _)) -> + modules + |> List.collect (fun (SynModuleOrNamespace (_, _, _, decls, _, _, _, _, _)) -> extractOpensFromDecl decls) + | _ -> [] + + let rec convertSigParam (ty : SynType) : ParameterInfo = + match ty with + | SynType.Paren (inner, _) -> convertSigParam inner + | SynType.LongIdent ident -> + { + Attributes = [] + IsOptional = false + Id = None + Type = SynType.CreateLongIdent ident + } + | SynType.SignatureParameter (attrs, opt, id, usedType, _) -> + let attrs = attrs |> List.collect (fun attrs -> attrs.Attributes) + + { + Attributes = attrs + IsOptional = opt + Id = id + Type = usedType + } + | _ -> failwithf "expected SignatureParameter, got: %+A" ty + + let rec extractTupledTypes (tupleType : SynTupleTypeSegment list) : ParameterInfo list = + match tupleType with + | [] -> [] + | [ SynTupleTypeSegment.Type param ] -> [ convertSigParam param ] + | SynTupleTypeSegment.Type param :: SynTupleTypeSegment.Star _ :: rest -> + convertSigParam param :: extractTupledTypes rest + | _ -> failwithf "Didn't have alternating type-and-star in interface member definition: %+A" tupleType + + /// Assumes that the input type is an ObjectModel, i.e. a `type Foo = member ...` + let parseInterface (interfaceType : SynTypeDefn) : InterfaceType = + let (SynTypeDefn (SynComponentInfo (attrs, typars, _, interfaceName, _, _, accessibility, _), + synTypeDefnRepr, + _, + _, + _, + _)) = + interfaceType + + let attrs = attrs |> List.collect (fun s -> s.Attributes) + + let members = + match synTypeDefnRepr with + | SynTypeDefnRepr.ObjectModel (_kind, members, _) -> + members + |> List.map (fun defn -> + match defn with + | SynMemberDefn.AbstractSlot (slotSig, flags, _, _) -> + match flags.MemberKind with + | SynMemberKind.Member -> () + | kind -> failwithf "Unrecognised member kind: %+A" kind + + if not flags.IsInstance then + failwith "member was not an instance member" + + match slotSig with + | SynValSig (attrs, + SynIdent.SynIdent (ident, _), + _typeParams, + synType, + arity, + isInline, + isMutable, + xmlDoc, + accessibility, + synExpr, + _, + _) -> + if isInline then + failwith "inline members not supported" + + if isMutable then + failwith "mutable members not supported" + + match accessibility with + | Some (SynAccess.Internal _) + | Some (SynAccess.Private _) -> failwith "only public members are supported" + | _ -> () + + match synExpr with + | Some _ -> failwith "literal members are not supported" + | None -> () + + let arity = + match arity with + | SynValInfo ([ curriedArgs ], SynArgInfo ([], false, _)) -> curriedArgs + | SynValInfo (curriedArgs, SynArgInfo ([], false, _)) -> + failwithf "only tupled arguments are currently supported, but got: %+A" curriedArgs + | SynValInfo (_, info) -> + failwithf + "only bare return values like `Task` are supported, but got: %+A" + info + + let attrs = attrs |> List.collect (fun attr -> attr.Attributes) + + let args, ret = + match synType with + | SynType.Fun (argType, returnType, _, _) -> argType, returnType + | _ -> + failwithf + "Expected a return type of a generic Task; bad signature was: %+A" + synType + + let args = + match args with + | SynType.SignatureParameter _ -> [ convertSigParam args ] + | SynType.Tuple (false, path, _) -> extractTupledTypes path + | SynType.LongIdent (SynLongIdent (ident, _, _)) -> + { + Attributes = [] + IsOptional = false + Id = None + Type = SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent ident) + } + |> List.singleton + | SynType.Var (typar, _) -> + { + Attributes = [] + IsOptional = false + Id = None + Type = SynType.Var (typar, range0) + } + |> List.singleton + | _ -> failwithf "Unrecognised args in interface method declaration: %+A" args + + { + ReturnType = ret + Arity = arity + Args = args + Identifier = ident + Attributes = attrs + XmlDoc = Some xmlDoc + } + | _ -> failwithf "Unrecognised member definition: %+A" defn + ) + | _ -> failwithf "Unrecognised SynTypeDefnRepr for an interface type: %+A" synTypeDefnRepr + + { + Members = members + Name = interfaceName + Attributes = attrs + Generics = typars + Accessibility = accessibility + } + + [] module internal SynTypePatterns = let (|OptionType|_|) (fieldType : SynType) = diff --git a/WoofWare.Myriad.Plugins/HttpClientGenerator.fs b/WoofWare.Myriad.Plugins/HttpClientGenerator.fs index eefa2eb..3adcc7b 100644 --- a/WoofWare.Myriad.Plugins/HttpClientGenerator.fs +++ b/WoofWare.Myriad.Plugins/HttpClientGenerator.fs @@ -9,6 +9,8 @@ open Myriad.Core /// Attribute indicating a record type to which the "create HTTP client" Myriad /// generator should apply during build. +/// This generator is intended to replicate much of the functionality of RestEase, +/// i.e. to stamp out HTTP REST clients from interfaces defining the API. type HttpClientAttribute () = inherit Attribute () @@ -47,24 +49,13 @@ module internal HttpClientGenerator = | BodyParamMethods.StreamContent -> "StreamContent" | BodyParamMethods.HttpContent -> "HttpContent" - let synBindingTriviaZero (isMember : bool) = - { - SynBindingTrivia.EqualsRange = Some range0 - InlineKeyword = None - LeadingKeyword = - if isMember then - SynLeadingKeyword.Member range0 - else - SynLeadingKeyword.Let range0 - } - type MemberInfo = { /// E.g. HttpMethod.Get HttpMethod : HttpMethod /// E.g. "v1/gyms/{gym_id}/attendance" UrlTemplate : string - ReturnType : SynType + TaskReturnType : SynType Arity : SynArgInfo list Args : Parameter list Identifier : Ident @@ -408,15 +399,15 @@ module internal HttpClientGenerator = |> SynExpr.CreateParenedTuple let returnExpr = - match info.ReturnType with + match info.TaskReturnType with | HttpResponseMessage | String | Stream -> SynExpr.CreateIdentString "node" - | _ -> + | retType -> JsonParseGenerator.parseNode None JsonParseGenerator.JsonParseOption.None - info.ReturnType + retType (SynExpr.CreateIdentString "node") let handleBodyParams = @@ -523,7 +514,7 @@ module internal HttpClientGenerator = SynExpr.CreateConst SynConst.Unit ) ) - match info.ReturnType with + match info.TaskReturnType with | HttpResponseMessage -> yield Let ("node", SynExpr.CreateIdentString "response") | String -> yield @@ -602,91 +593,58 @@ module internal HttpClientGenerator = implementation, range0, DebugPointAtBinding.Yes range0, - synBindingTriviaZero true + SynExpr.synBindingTriviaZero true ), range0 ) - let rec convertSigParam (ty : SynType) : Parameter = - match ty with - | SynType.Paren (inner, _) -> convertSigParam inner - | SynType.SignatureParameter (attrs, opt, id, usedType, _) -> - let attrs = - attrs - |> List.collect (fun attrs -> - attrs.Attributes - |> List.choose (fun attr -> - match attr.TypeName.AsString with - | "Query" - | "QueryAttribute" -> - match attr.ArgExpr with - | SynExpr.Const (SynConst.Unit, _) -> Some (HttpAttribute.Query None) - | SynExpr.Const (SynConst.String (s, SynStringKind.Regular, _), _) -> - Some (HttpAttribute.Query (Some s)) - | SynExpr.Const (a, _) -> - failwithf "unrecognised constant arg to the Query attribute: %+A" a - | _ -> None - | "Path" - | "PathAttribute" -> - match attr.ArgExpr with - | SynExpr.Const (SynConst.String (s, SynStringKind.Regular, _), _) -> - Some (HttpAttribute.Path s) - | SynExpr.Const (a, _) -> - failwithf "unrecognised constant arg to the Path attribute: %+A" a - | _ -> None - | "Body" - | "BodyAttribute" -> - match attr.ArgExpr with - | SynExpr.Const (SynConst.Unit, _) -> Some (HttpAttribute.Body) - | SynExpr.Const (a, _) -> - failwithf "unrecognised constant arg to the Body attribute: %+A" a - | _ -> None - | _ -> None - ) - ) - - { - Attributes = attrs - IsOptional = opt - Id = id - Type = usedType - } - | _ -> failwithf "expected SignatureParameter, got: %+A" ty - - let rec extractTypes (tupleType : SynTupleTypeSegment list) : Parameter list = - match tupleType with - | [] -> [] - | [ SynTupleTypeSegment.Type param ] -> [ convertSigParam param ] - | SynTupleTypeSegment.Type param :: SynTupleTypeSegment.Star _ :: rest -> - convertSigParam param :: extractTypes rest - | _ -> failwithf "Didn't have alternating type-and-star in interface member definition: %+A" tupleType - - let extractBasePath (attrs : SynAttributes) : SynExpr option = + let getHttpAttributes (attrs : SynAttribute list) : HttpAttribute list = attrs - |> List.tryPick (fun attr -> - attr.Attributes - |> List.tryPick (fun attr -> - match attr.TypeName.AsString with - | "BasePath" - | "RestEase.BasePath" - | "BasePathAttribute" - | "RestEase.BasePathAttribute" -> Some attr.ArgExpr + |> List.choose (fun attr -> + match attr.TypeName.AsString with + | "Query" + | "QueryAttribute" -> + match attr.ArgExpr with + | SynExpr.Const (SynConst.Unit, _) -> Some (HttpAttribute.Query None) + | SynExpr.Const (SynConst.String (s, SynStringKind.Regular, _), _) -> + Some (HttpAttribute.Query (Some s)) + | SynExpr.Const (a, _) -> failwithf "unrecognised constant arg to the Query attribute: %+A" a | _ -> None - ) + | "Path" + | "PathAttribute" -> + match attr.ArgExpr with + | SynExpr.Const (SynConst.String (s, SynStringKind.Regular, _), _) -> Some (HttpAttribute.Path s) + | SynExpr.Const (a, _) -> failwithf "unrecognised constant arg to the Path attribute: %+A" a + | _ -> None + | "Body" + | "BodyAttribute" -> + match attr.ArgExpr with + | SynExpr.Const (SynConst.Unit, _) -> Some (HttpAttribute.Body) + | SynExpr.Const (a, _) -> failwithf "unrecognised constant arg to the Body attribute: %+A" a + | _ -> None + | _ -> None ) - let extractBaseAddress (attrs : SynAttributes) : SynExpr option = + let extractBasePath (attrs : SynAttribute list) : SynExpr option = attrs |> List.tryPick (fun attr -> - attr.Attributes - |> List.tryPick (fun attr -> - match attr.TypeName.AsString with - | "BaseAddress" - | "RestEase.BaseAddress" - | "BaseAddressAttribute" - | "RestEase.BaseAddressAttribute" -> Some attr.ArgExpr - | _ -> None - ) + match attr.TypeName.AsString with + | "BasePath" + | "RestEase.BasePath" + | "BasePathAttribute" + | "RestEase.BasePathAttribute" -> Some attr.ArgExpr + | _ -> None + ) + + let extractBaseAddress (attrs : SynAttribute list) : SynExpr option = + attrs + |> List.tryPick (fun attr -> + match attr.TypeName.AsString with + | "BaseAddress" + | "RestEase.BaseAddress" + | "BaseAddressAttribute" + | "RestEase.BaseAddressAttribute" -> Some attr.ArgExpr + | _ -> None ) let createModule @@ -695,105 +653,51 @@ module internal HttpClientGenerator = (interfaceType : SynTypeDefn) : SynModuleOrNamespace = - let (SynTypeDefn (SynComponentInfo (attrs, _, _, interfaceName, _, _, _, _), synTypeDefnRepr, _, _, _, _)) = - interfaceType + let interfaceType = AstHelper.parseInterface interfaceType - let baseAddress = extractBaseAddress attrs - let basePath = extractBasePath attrs + let baseAddress = extractBaseAddress interfaceType.Attributes + let basePath = extractBasePath interfaceType.Attributes let members = - match synTypeDefnRepr with - | SynTypeDefnRepr.ObjectModel (_kind, members, _) -> - members - |> List.map (fun defn -> - match defn with - | SynMemberDefn.AbstractSlot (slotSig, flags, _, _) -> - match flags.MemberKind with - | SynMemberKind.Member -> () - | kind -> failwithf "Unrecognised member kind: %+A" kind + interfaceType.Members + |> List.map (fun mem -> + let httpMethod, url = extractHttpInformation mem.Attributes - if not flags.IsInstance then - failwith "member was not an instance member" + let shouldEnsureSuccess = not (shouldAllowAnyStatusCode mem.Attributes) - match slotSig with - | SynValSig (attrs, - SynIdent.SynIdent (ident, _), - _typeParams, - synType, - arity, - isInline, - isMutable, - _xmlDoc, - accessibility, - synExpr, - _, - _) -> - if isInline then - failwith "inline members not supported" - - if isMutable then - failwith "mutable members not supported" - - match accessibility with - | Some (SynAccess.Internal _) - | Some (SynAccess.Private _) -> failwith "only public members are supported" - | _ -> () - - match synExpr with - | Some _ -> failwith "literal members are not supported" - | None -> () - - let attrs = attrs |> List.collect (fun a -> a.Attributes) - - let arity = - match arity with - | SynValInfo ([ curriedArgs ], SynArgInfo ([], false, _)) -> curriedArgs - | SynValInfo (curriedArgs, SynArgInfo ([], false, _)) -> - failwithf "only tupled arguments are supported, but got: %+A" curriedArgs - | SynValInfo (_, info) -> - failwithf - "only bare return values like `Task` are supported, but got: %+A" - info - - let args, ret = - match synType with - | SynType.Fun (argType, Task returnType, _, _) -> argType, returnType - | _ -> - failwithf - "Expected a return type of a generic Task; bad signature was: %+A" - synType - - let args = - match args with - | SynType.SignatureParameter _ -> [ convertSigParam args ] - | SynType.Tuple (false, path, _) -> extractTypes path - | _ -> failwithf "Unrecognised args in interface method declaration: %+A" args - - let httpMethod, url = extractHttpInformation attrs - - let shouldEnsureSuccess = not (shouldAllowAnyStatusCode attrs) + let returnType = + match mem.ReturnType with + | Task ty -> ty + | a -> failwith $"Method must return a generic Task; returned %+A{a}" + { + HttpMethod = httpMethod + UrlTemplate = url + TaskReturnType = returnType + Arity = mem.Arity + Args = + mem.Args + |> List.map (fun arg -> { - HttpMethod = httpMethod - UrlTemplate = url - ReturnType = ret - Arity = arity - Args = args - Identifier = ident - EnsureSuccessHttpCode = shouldEnsureSuccess - BaseAddress = baseAddress - BasePath = basePath + Attributes = arg.Attributes |> getHttpAttributes + IsOptional = arg.IsOptional + Id = arg.Id + Type = arg.Type } - | _ -> failwithf "Unrecognised member definition: %+A" defn - ) - | _ -> failwithf "Unrecognised SynTypeDefnRepr: %+A" synTypeDefnRepr + ) + Identifier = mem.Identifier + EnsureSuccessHttpCode = shouldEnsureSuccess + BaseAddress = baseAddress + BasePath = basePath + } + ) let constructed = members |> List.map constructMember let docString = PreXmlDoc.Create " Module for constructing a REST client." let interfaceImpl = SynExpr.ObjExpr ( - SynType.LongIdent (SynLongIdent.CreateFromLongIdent interfaceName), + SynType.LongIdent (SynLongIdent.CreateFromLongIdent interfaceType.Name), None, Some range0, [], @@ -832,17 +736,21 @@ module internal HttpClientGenerator = ) ] ), - Some (SynBindingReturnInfo.Create (SynType.LongIdent (SynLongIdent.CreateFromLongIdent interfaceName))), + Some ( + SynBindingReturnInfo.Create ( + SynType.LongIdent (SynLongIdent.CreateFromLongIdent interfaceType.Name) + ) + ), interfaceImpl, range0, DebugPointAtBinding.NoneAtLet, - synBindingTriviaZero false + SynExpr.synBindingTriviaZero false ) |> List.singleton |> SynModuleDecl.CreateLet let moduleName : LongIdent = - List.last interfaceName + List.last interfaceType.Name |> fun ident -> ident.idText |> fun s -> if s.StartsWith 'I' then @@ -871,14 +779,6 @@ module internal HttpClientGenerator = ] ) - let rec extractOpens (moduleDecls : SynModuleDecl list) : SynOpenDeclTarget list = - moduleDecls - |> List.choose (fun moduleDecl -> - match moduleDecl with - | SynModuleDecl.Open (target, _) -> Some target - | other -> None - ) - /// Myriad generator that provides an HTTP client for an interface type using RestEase annotations. [] type HttpClientGenerator () = @@ -892,14 +792,7 @@ type HttpClientGenerator () = let types = Ast.extractTypeDefn ast - let opens = - match ast with - | ParsedInput.ImplFile (ParsedImplFileInput (_, _, _, _, _, modules, _, _, _)) -> - modules - |> List.collect (fun (SynModuleOrNamespace (nsId, _, _, decls, _, _, _, _, _)) -> - HttpClientGenerator.extractOpens decls - ) - | _ -> [] + let opens = AstHelper.extractOpens ast let namespaceAndTypes = types @@ -911,12 +804,6 @@ type HttpClientGenerator () = let modules = namespaceAndTypes - |> List.collect (fun (ns, types) -> - types - |> List.map (fun interfaceType -> - let clientModule = HttpClientGenerator.createModule opens ns interfaceType - clientModule - ) - ) + |> List.collect (fun (ns, types) -> types |> List.map (HttpClientGenerator.createModule opens ns)) Output.Ast modules diff --git a/WoofWare.Myriad.Plugins/InterfaceMockGenerator.fs b/WoofWare.Myriad.Plugins/InterfaceMockGenerator.fs new file mode 100644 index 0000000..b48bfd0 --- /dev/null +++ b/WoofWare.Myriad.Plugins/InterfaceMockGenerator.fs @@ -0,0 +1,326 @@ +namespace WoofWare.Myriad.Plugins + +open System +open Fantomas.FCS.Syntax +open Fantomas.FCS.SyntaxTrivia +open Fantomas.FCS.Xml +open Myriad.Core + +/// Attribute indicating an interface type for which the "Generate Mock" Myriad +/// generator should apply during build. +/// This generator creates a record which implements the interface, +/// but where each method is represented as a record field, so you can use +/// record update syntax to easily specify partially-implemented mock objects. +type GenerateMockAttribute () = + inherit Attribute () + +[] +module internal InterfaceMockGenerator = + open Fantomas.FCS.Text.Range + open Myriad.Core.Ast + + let private getName (SynField (_, _, id, _, _, _, _, _, _)) = + match id with + | None -> failwith "Expected record field to have a name, but it was somehow anonymous" + | Some id -> id + + let createType + (name : string) + (interfaceType : InterfaceType) + (xmlDoc : PreXmlDoc) + (fields : SynField list) + : SynModuleDecl + = + let synValData = + { + SynMemberFlags.IsInstance = false + SynMemberFlags.IsDispatchSlot = false + SynMemberFlags.IsOverrideOrExplicitImpl = false + SynMemberFlags.IsFinal = false + SynMemberFlags.GetterOrSetterIsCompilerGenerated = false + SynMemberFlags.MemberKind = SynMemberKind.Member + } + + let failwithFun = + SynExpr.createLambda + "x" + (SynExpr.CreateApp ( + SynExpr.CreateIdentString "raise", + SynExpr.CreateParen ( + SynExpr.CreateApp ( + SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "NotImplementedException" ]), + SynExpr.CreateConstString "Unimplemented mock function" + ) + ) + )) + + let constructorIdent = + let generics = + interfaceType.Generics + |> Option.map (fun generics -> SynValTyparDecls (Some generics, false)) + + SynPat.LongIdent ( + SynLongIdent.CreateString "Empty", + None, + generics, + SynArgPats.Pats ( + if generics.IsNone then + [] + else + [ SynPat.CreateParen (SynPat.CreateConst SynConst.Unit) ] + ), + None, + range0 + ) + + let constructorReturnType = + match interfaceType.Generics with + | None -> SynType.CreateLongIdent name + | Some generics -> + let generics = + generics.TyparDecls + |> List.map (fun (SynTyparDecl (_, typar)) -> SynType.Var (typar, range0)) + + SynType.App ( + SynType.CreateLongIdent name, + Some range0, + generics, + List.replicate (generics.Length - 1) range0, + Some range0, + false, + range0 + ) + |> SynBindingReturnInfo.Create + + let constructor = + SynMemberDefn.Member ( + SynBinding.SynBinding ( + None, + SynBindingKind.Normal, + false, + false, + [], + PreXmlDoc.Empty, + SynValData.SynValData (Some synValData, SynValInfo.Empty, None), + constructorIdent, + Some constructorReturnType, + AstHelper.instantiateRecord ( + fields + |> List.map (fun field -> + ((SynLongIdent.CreateFromLongIdent [ getName field ], true), Some failwithFun) + ) + ), + range0, + DebugPointAtBinding.Yes range0, + { SynExpr.synBindingTriviaZero true with + LeadingKeyword = SynLeadingKeyword.StaticMember (range0, range0) + } + ), + range0 + ) + + let interfaceMembers = + 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 = + [ + [ SynArgInfo.SynArgInfo (attributes = [], optional = false, ident = None) ] + [] + ], + returnInfo = + SynArgInfo.SynArgInfo (attributes = [], optional = false, ident = None) + ), + thisIdOpt = None + ) + + let headArgs = + SynPat.Tuple ( + false, + memberInfo.Args + |> List.mapi (fun i _arg -> SynPat.CreateNamed (Ident.Create $"arg%i{i}")), + List.replicate (memberInfo.Args.Length - 1) range0, + range0 + ) + |> SynPat.CreateParen + + let headPat = + SynPat.LongIdent ( + SynLongIdent.CreateFromLongIdent [ Ident.Create "this" ; memberInfo.Identifier ], + None, + None, + SynArgPats.Pats [ headArgs ], + None, + range0 + ) + + SynMemberDefn.Member ( + SynBinding.SynBinding ( + None, + SynBindingKind.Normal, + false, + false, + [], + PreXmlDoc.Empty, + synValData, + headPat, + None, + SynExpr.CreateApp ( + SynExpr.CreateLongIdent ( + SynLongIdent.CreateFromLongIdent [ Ident.Create "this" ; memberInfo.Identifier ] + ), + SynExpr.CreateParen ( + memberInfo.Args + |> List.mapi (fun i _arg -> SynExpr.CreateIdentString $"arg%i{i}") + |> SynExpr.CreateTuple + ) + ), + range0, + DebugPointAtBinding.Yes range0, + { + LeadingKeyword = SynLeadingKeyword.Member range0 + InlineKeyword = None + EqualsRange = Some range0 + } + ), + range0 + ) + ) + + let interfaceName = + let baseName = + SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent interfaceType.Name) + + match interfaceType.Generics with + | None -> baseName + | Some generics -> + let generics = + match generics with + | SynTyparDecls.PostfixList (decls, _, _) -> decls + | SynTyparDecls.PrefixList (decls, _) -> decls + | SynTyparDecls.SinglePrefix (decl, _) -> [ decl ] + |> List.map (fun (SynTyparDecl (_, typar)) -> SynType.Var (typar, range0)) + + SynType.App ( + baseName, + Some range0, + generics, + List.replicate (generics.Length - 1) range0, + Some range0, + false, + range0 + ) + + SynMemberDefn.Interface (interfaceName, Some range0, Some members, range0) + + // TODO: allow an arg to the attribute, specifying a custom visibility + let access = + match interfaceType.Accessibility with + | Some (SynAccess.Public _) + | Some (SynAccess.Internal _) + | None -> SynAccess.Internal range0 + | Some (SynAccess.Private _) -> SynAccess.Private range0 + + let record = + { + Name = Ident.Create name + Fields = fields + Members = Some [ constructor ; interfaceMembers ] + XmlDoc = Some xmlDoc + Generics = interfaceType.Generics + Accessibility = Some access + } + + let typeDecl = AstHelper.defineRecordType record + + SynModuleDecl.Types ([ typeDecl ], range0) + + let constructMember (mem : MemberInfo) : SynField = + let inputType = + match mem.Args |> List.map (fun pi -> pi.Type) |> List.rev with + | [] -> failwith "no-arg functions not supported yet" + | [ x ] -> x + | last :: rest -> + ([ SynTupleTypeSegment.Type last ], rest) + ||> List.fold (fun ty nextArg -> + SynTupleTypeSegment.Type nextArg :: SynTupleTypeSegment.Star range0 :: ty + ) + |> fun segs -> SynType.Tuple (false, segs, range0) + + let funcType = SynType.CreateFun (inputType, mem.ReturnType) + + SynField.SynField ( + [], + true, + Some mem.Identifier, + funcType, + false, + mem.XmlDoc |> Option.defaultValue PreXmlDoc.Empty, + None, + range0, + SynFieldTrivia.Zero + ) + + let createRecord (namespaceId : LongIdent) (interfaceType : SynTypeDefn) : SynModuleOrNamespace = + let interfaceType = AstHelper.parseInterface interfaceType + let fields = interfaceType.Members |> List.map constructMember + let docString = PreXmlDoc.Create " Mock record type for an interface" + + let name = + List.last interfaceType.Name + |> fun s -> s.idText + |> fun s -> + if s.StartsWith 'I' && s.Length > 1 && Char.IsUpper s.[1] then + s.[1..] + else + s + |> fun s -> s + "Mock" + + let typeDecl = createType name interfaceType docString fields + + SynModuleOrNamespace.CreateNamespace (namespaceId, decls = [ typeDecl ]) + +/// Myriad generator that creates a record which implements the given interface, +/// but with every field mocked out. +[] +type InterfaceMockGenerator () = + + interface IMyriadGenerator with + member _.ValidInputExtensions = [ ".fs" ] + + member _.Generate (context : GeneratorContext) = + let ast, _ = + Ast.fromFilename context.InputFilename |> Async.RunSynchronously |> Array.head + + let types = Ast.extractTypeDefn ast + + let namespaceAndInterfaces = + types + |> List.choose (fun (ns, types) -> + match types |> List.filter Ast.hasAttribute with + | [] -> None + | types -> Some (ns, types) + ) + + let opens = AstHelper.extractOpens ast + + let modules = + namespaceAndInterfaces + |> List.collect (fun (ns, records) -> records |> List.map (InterfaceMockGenerator.createRecord ns)) + + Output.Ast modules diff --git a/WoofWare.Myriad.Plugins/JsonParseGenerator.fs b/WoofWare.Myriad.Plugins/JsonParseGenerator.fs index d861d72..c55d4b8 100644 --- a/WoofWare.Myriad.Plugins/JsonParseGenerator.fs +++ b/WoofWare.Myriad.Plugins/JsonParseGenerator.fs @@ -9,6 +9,8 @@ open Myriad.Core /// Attribute indicating a record type to which the "Add JSON parse" Myriad /// generator should apply during build. +/// The purpose of this generator is to create methods of the form +/// `{TypeName}.jsonParse : System.Text.Json.Nodes.JsonNode -> {TypeName}`. type JsonParseAttribute () = inherit Attribute () @@ -325,7 +327,7 @@ module internal JsonParseGenerator = (SynLongIdent.CreateFromLongIdent [ id ], true), Some (SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ id ])) ) - |> AstHelper.constructRecord + |> AstHelper.instantiateRecord let assignments = (finalConstruction, assignments) diff --git a/WoofWare.Myriad.Plugins/RemoveOptionsGenerator.fs b/WoofWare.Myriad.Plugins/RemoveOptionsGenerator.fs index 699718b..6d04e91 100644 --- a/WoofWare.Myriad.Plugins/RemoveOptionsGenerator.fs +++ b/WoofWare.Myriad.Plugins/RemoveOptionsGenerator.fs @@ -8,6 +8,7 @@ open Myriad.Core /// Attribute indicating a record type to which the "Remove Options" Myriad /// generator should apply during build. +/// The purpose of this generator is to strip the `option` modifier from types. type RemoveOptionsAttribute () = inherit Attribute () @@ -46,14 +47,26 @@ module internal RemoveOptionsGenerator = ) // TODO: this option seems a bit odd - let createType (xmlDoc : PreXmlDoc option) (fields : SynField list) = + let createType + (xmlDoc : PreXmlDoc option) + (accessibility : SynAccess option) + (generics : SynTyparDecls option) + (fields : SynField list) + = let fields : SynField list = fields |> List.map removeOption let name = Ident.Create "Short" - let typeDecl : SynTypeDefn = - match xmlDoc with - | None -> AstHelper.defineRecordType (name, fields, None, None) - | Some xmlDoc -> AstHelper.defineRecordType (name, fields, None, Some xmlDoc) + let record = + { + Name = name + Fields = fields + Members = None + XmlDoc = xmlDoc + Generics = generics + Accessibility = accessibility + } + + let typeDecl = AstHelper.defineRecordType record SynModuleDecl.Types ([ typeDecl ], range0) @@ -114,7 +127,7 @@ module internal RemoveOptionsGenerator = (SynLongIdent.CreateFromLongIdent [ id ], true), Some body ) - |> AstHelper.constructRecord + |> AstHelper.instantiateRecord let pattern = SynPat.LongIdent ( @@ -150,15 +163,15 @@ module internal RemoveOptionsGenerator = let (SynTypeDefn (synComponentInfo, synTypeDefnRepr, _members, _implicitCtor, _, _)) = typeDefn - let (SynComponentInfo (_attributes, _typeParams, _constraints, recordId, doc, _preferPostfix, _access, _)) = + let (SynComponentInfo (_attributes, typeParams, _constraints, recordId, doc, _preferPostfix, _access, _)) = synComponentInfo match synTypeDefnRepr with - | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (_accessibility, recordFields, _recordRange), _) -> + | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (accessibility, recordFields, _recordRange), _) -> let decls = [ - createType (Some doc) recordFields + createType (Some doc) accessibility typeParams recordFields createMaker [ Ident.Create "Short" ] recordId recordFields ] diff --git a/WoofWare.Myriad.Plugins/SurfaceBaseline.txt b/WoofWare.Myriad.Plugins/SurfaceBaseline.txt index 4c171fc..a035237 100644 --- a/WoofWare.Myriad.Plugins/SurfaceBaseline.txt +++ b/WoofWare.Myriad.Plugins/SurfaceBaseline.txt @@ -1,7 +1,11 @@ +WoofWare.Myriad.Plugins.GenerateMockAttribute inherit System.Attribute +WoofWare.Myriad.Plugins.GenerateMockAttribute..ctor [constructor]: unit WoofWare.Myriad.Plugins.HttpClientAttribute inherit System.Attribute WoofWare.Myriad.Plugins.HttpClientAttribute..ctor [constructor]: unit WoofWare.Myriad.Plugins.HttpClientGenerator inherit obj, implements Myriad.Core.IMyriadGenerator WoofWare.Myriad.Plugins.HttpClientGenerator..ctor [constructor]: unit +WoofWare.Myriad.Plugins.InterfaceMockGenerator inherit obj, implements Myriad.Core.IMyriadGenerator +WoofWare.Myriad.Plugins.InterfaceMockGenerator..ctor [constructor]: unit WoofWare.Myriad.Plugins.JsonParseAttribute inherit System.Attribute WoofWare.Myriad.Plugins.JsonParseAttribute..ctor [constructor]: unit WoofWare.Myriad.Plugins.JsonParseGenerator inherit obj, implements Myriad.Core.IMyriadGenerator diff --git a/WoofWare.Myriad.Plugins/SynExpr.fs b/WoofWare.Myriad.Plugins/SynExpr.fs index 6f0cf28..968f397 100644 --- a/WoofWare.Myriad.Plugins/SynExpr.fs +++ b/WoofWare.Myriad.Plugins/SynExpr.fs @@ -262,3 +262,14 @@ module internal SynExpr = ident |> callMethodArg "ToString" (SynExpr.CreateConstString "yyyy-MM-ddTHH:mm:ss") | _ -> callMethod "ToString" ident + + let synBindingTriviaZero (isMember : bool) = + { + SynBindingTrivia.EqualsRange = Some range0 + InlineKeyword = None + LeadingKeyword = + if isMember then + SynLeadingKeyword.Member range0 + else + SynLeadingKeyword.Let range0 + } diff --git a/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj b/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj index 8c71f92..5f0fa5b 100644 --- a/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj +++ b/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj @@ -28,6 +28,7 @@ + diff --git a/WoofWare.Myriad.Plugins/version.json b/WoofWare.Myriad.Plugins/version.json index 6b85091..63f3e25 100644 --- a/WoofWare.Myriad.Plugins/version.json +++ b/WoofWare.Myriad.Plugins/version.json @@ -1,5 +1,5 @@ { - "version": "1.1", + "version": "1.2", "publicReleaseRefSpec": [ "^refs/heads/main$" ],