mirror of
https://github.com/Smaug123/WoofWare.Myriad
synced 2025-10-06 20:48:40 +00:00
Stamp out records corresponding to interfaces (#56)
This commit is contained in:
Patrick Stevens
GitHub
@@ -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
|
||||
}
|
||||
|
||||
[<RequireQualifiedAccess>]
|
||||
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<foo>` 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
|
||||
}
|
||||
|
||||
|
||||
[<AutoOpen>]
|
||||
module internal SynTypePatterns =
|
||||
let (|OptionType|_|) (fieldType : SynType) =
|
||||
|
||||
@@ -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<foo>` 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.
|
||||
[<MyriadGenerator("http-client")>]
|
||||
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
|
||||
|
||||
326
WoofWare.Myriad.Plugins/InterfaceMockGenerator.fs
Normal file
326
WoofWare.Myriad.Plugins/InterfaceMockGenerator.fs
Normal file
@@ -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 ()
|
||||
|
||||
[<RequireQualifiedAccess>]
|
||||
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.
|
||||
[<MyriadGenerator("interface-mock")>]
|
||||
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<GenerateMockAttribute> 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
|
||||
@@ -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)
|
||||
|
||||
@@ -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
|
||||
]
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
}
|
||||
|
||||
@@ -28,6 +28,7 @@
|
||||
<Compile Include="SynExpr.fs"/>
|
||||
<Compile Include="SynAttribute.fs"/>
|
||||
<Compile Include="RemoveOptionsGenerator.fs"/>
|
||||
<Compile Include="InterfaceMockGenerator.fs" />
|
||||
<Compile Include="JsonParseGenerator.fs"/>
|
||||
<Compile Include="HttpClientGenerator.fs"/>
|
||||
<EmbeddedResource Include="version.json"/>
|
||||
|
||||
@@ -1,5 +1,5 @@
|
||||
{
|
||||
"version": "1.1",
|
||||
"version": "1.2",
|
||||
"publicReleaseRefSpec": [
|
||||
"^refs/heads/main$"
|
||||
],
|
||||
|
||||
Reference in New Issue
Block a user