mirror of
https://github.com/Smaug123/WoofWare.Myriad
synced 2025-10-12 23:48:42 +00:00
Add ability to mock out curried functions (#58)
This commit is contained in:
Patrick Stevens
GitHub
@@ -14,14 +14,23 @@ type internal ParameterInfo =
|
||||
Type : SynType
|
||||
}
|
||||
|
||||
type internal TupledArg =
|
||||
{
|
||||
HasParen : bool
|
||||
Args : ParameterInfo list
|
||||
}
|
||||
|
||||
type internal MemberInfo =
|
||||
{
|
||||
ReturnType : SynType
|
||||
Arity : SynArgInfo list
|
||||
Args : ParameterInfo list
|
||||
Accessibility : SynAccess option
|
||||
/// Each element of this list is a list of args in a tuple, or just one arg if not a tuple.
|
||||
Args : TupledArg list
|
||||
Identifier : Ident
|
||||
Attributes : SynAttribute list
|
||||
XmlDoc : PreXmlDoc option
|
||||
IsInline : bool
|
||||
IsMutable : bool
|
||||
}
|
||||
|
||||
type internal InterfaceType =
|
||||
@@ -114,16 +123,19 @@ module internal AstHelper =
|
||||
|> List.collect (fun (SynModuleOrNamespace (_, _, _, decls, _, _, _, _, _)) -> extractOpensFromDecl decls)
|
||||
| _ -> []
|
||||
|
||||
let rec convertSigParam (ty : SynType) : ParameterInfo =
|
||||
let rec convertSigParam (ty : SynType) : ParameterInfo * bool =
|
||||
match ty with
|
||||
| SynType.Paren (inner, _) -> convertSigParam inner
|
||||
| SynType.Paren (inner, _) ->
|
||||
let result, _ = convertSigParam inner
|
||||
result, true
|
||||
| SynType.LongIdent ident ->
|
||||
{
|
||||
Attributes = []
|
||||
IsOptional = false
|
||||
Id = None
|
||||
Type = SynType.CreateLongIdent ident
|
||||
}
|
||||
},
|
||||
false
|
||||
| SynType.SignatureParameter (attrs, opt, id, usedType, _) ->
|
||||
let attrs = attrs |> List.collect (fun attrs -> attrs.Attributes)
|
||||
|
||||
@@ -132,17 +144,61 @@ module internal AstHelper =
|
||||
IsOptional = opt
|
||||
Id = id
|
||||
Type = usedType
|
||||
}
|
||||
},
|
||||
false
|
||||
| SynType.Var (typar, _) ->
|
||||
{
|
||||
Attributes = []
|
||||
IsOptional = false
|
||||
Id = None
|
||||
Type = SynType.Var (typar, range0)
|
||||
},
|
||||
false
|
||||
| _ -> failwithf "expected SignatureParameter, got: %+A" ty
|
||||
|
||||
let rec extractTupledTypes (tupleType : SynTupleTypeSegment list) : ParameterInfo list =
|
||||
let rec extractTupledTypes (tupleType : SynTupleTypeSegment list) : TupledArg =
|
||||
match tupleType with
|
||||
| [] -> []
|
||||
| [ SynTupleTypeSegment.Type param ] -> [ convertSigParam param ]
|
||||
| [] ->
|
||||
{
|
||||
HasParen = false
|
||||
Args = []
|
||||
}
|
||||
| [ SynTupleTypeSegment.Type param ] ->
|
||||
let converted, hasParen = convertSigParam param
|
||||
|
||||
{
|
||||
HasParen = hasParen
|
||||
Args = [ converted ]
|
||||
}
|
||||
| SynTupleTypeSegment.Type param :: SynTupleTypeSegment.Star _ :: rest ->
|
||||
convertSigParam param :: extractTupledTypes rest
|
||||
let rest = extractTupledTypes rest
|
||||
let converted, _ = convertSigParam param
|
||||
|
||||
{
|
||||
HasParen = false
|
||||
Args = converted :: rest.Args
|
||||
}
|
||||
| _ -> failwithf "Didn't have alternating type-and-star in interface member definition: %+A" tupleType
|
||||
|
||||
let toFun (inputs : SynType list) (ret : SynType) : SynType =
|
||||
(ret, List.rev inputs)
|
||||
||> List.fold (fun ty input -> SynType.CreateFun (input, ty))
|
||||
|
||||
/// Returns the args (where these are tuple types if curried) in order, and the return type.
|
||||
let rec getType (ty : SynType) : (SynType * bool) list * SynType =
|
||||
match ty with
|
||||
| SynType.Paren (ty, _) -> getType ty
|
||||
| SynType.Fun (argType, returnType, _, _) ->
|
||||
let args, ret = getType returnType
|
||||
// TODO this code is clearly wrong
|
||||
let (inputArgs, inputRet), hasParen =
|
||||
match argType with
|
||||
| SynType.Paren (argType, _) -> getType argType, true
|
||||
| _ -> getType argType, false
|
||||
|
||||
((toFun (List.map fst inputArgs) inputRet), hasParen) :: args, ret
|
||||
| _ -> [], ty
|
||||
|
||||
/// 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, _),
|
||||
@@ -182,74 +238,74 @@ module internal AstHelper =
|
||||
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, ret = getType 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
|
||||
args
|
||||
|> List.map (fun (args, hasParen) ->
|
||||
match args with
|
||||
| SynType.Tuple (false, path, _) -> extractTupledTypes path
|
||||
| SynType.SignatureParameter _ ->
|
||||
let arg, hasParen = convertSigParam args
|
||||
|
||||
{
|
||||
HasParen = hasParen
|
||||
Args = [ arg ]
|
||||
}
|
||||
| SynType.LongIdent (SynLongIdent (ident, _, _)) ->
|
||||
{
|
||||
HasParen = false
|
||||
Args =
|
||||
{
|
||||
Attributes = []
|
||||
IsOptional = false
|
||||
Id = None
|
||||
Type =
|
||||
SynType.CreateLongIdent (
|
||||
SynLongIdent.CreateFromLongIdent ident
|
||||
)
|
||||
}
|
||||
|> List.singleton
|
||||
}
|
||||
| SynType.Var (typar, _) ->
|
||||
{
|
||||
HasParen = false
|
||||
Args =
|
||||
{
|
||||
Attributes = []
|
||||
IsOptional = false
|
||||
Id = None
|
||||
Type = SynType.Var (typar, range0)
|
||||
}
|
||||
|> List.singleton
|
||||
}
|
||||
| _ -> failwith $"Unrecognised args in interface method declaration: %+A{args}"
|
||||
|> fun ty ->
|
||||
{ ty with
|
||||
HasParen = ty.HasParen || hasParen
|
||||
}
|
||||
)
|
||||
|
||||
{
|
||||
ReturnType = ret
|
||||
Arity = arity
|
||||
Args = args
|
||||
Identifier = ident
|
||||
Attributes = attrs
|
||||
XmlDoc = Some xmlDoc
|
||||
Accessibility = accessibility
|
||||
IsInline = isInline
|
||||
IsMutable = isMutable
|
||||
}
|
||||
| _ -> failwithf "Unrecognised member definition: %+A" defn
|
||||
| _ -> failwith $"Unrecognised member definition: %+A{defn}"
|
||||
)
|
||||
| _ -> failwithf "Unrecognised SynTypeDefnRepr for an interface type: %+A" synTypeDefnRepr
|
||||
| _ -> failwith $"Unrecognised SynTypeDefnRepr for an interface type: %+A{synTypeDefnRepr}"
|
||||
|
||||
{
|
||||
Members = members
|
||||
|
||||
@@ -3,7 +3,6 @@ namespace WoofWare.Myriad.Plugins
|
||||
open System
|
||||
open System.Net.Http
|
||||
open Fantomas.FCS.Syntax
|
||||
open Fantomas.FCS.SyntaxTrivia
|
||||
open Fantomas.FCS.Xml
|
||||
open Myriad.Core
|
||||
|
||||
@@ -56,12 +55,12 @@ module internal HttpClientGenerator =
|
||||
/// E.g. "v1/gyms/{gym_id}/attendance"
|
||||
UrlTemplate : string
|
||||
TaskReturnType : SynType
|
||||
Arity : SynArgInfo list
|
||||
Args : Parameter list
|
||||
Identifier : Ident
|
||||
EnsureSuccessHttpCode : bool
|
||||
BaseAddress : SynExpr option
|
||||
BasePath : SynExpr option
|
||||
Accessibility : SynAccess option
|
||||
}
|
||||
|
||||
let httpMethodString (m : HttpMethod) : string =
|
||||
@@ -121,10 +120,10 @@ module internal HttpClientGenerator =
|
||||
match arg with
|
||||
| SynExpr.Const (SynConst.String (text, SynStringKind.Regular, _), _) -> meth, text
|
||||
| arg ->
|
||||
failwithf "Unrecognised AST member in attribute argument. Only regular strings are supported: %+A" arg
|
||||
failwith $"Unrecognised AST member in attribute argument. Only regular strings are supported: %+A{arg}"
|
||||
| [] -> failwith "Required exactly one recognised RestEase attribute on member, but got none"
|
||||
| matchingAttrs ->
|
||||
failwithf "Required exactly one recognised RestEase attribute on member, but got %i" matchingAttrs.Length
|
||||
failwith $"Required exactly one recognised RestEase attribute on member, but got %i{matchingAttrs.Length}"
|
||||
|
||||
let shouldAllowAnyStatusCode (attrs : SynAttribute list) : bool =
|
||||
attrs
|
||||
@@ -581,7 +580,7 @@ module internal HttpClientGenerator =
|
||||
|
||||
SynMemberDefn.Member (
|
||||
SynBinding.SynBinding (
|
||||
None,
|
||||
info.Accessibility,
|
||||
SynBindingKind.Normal,
|
||||
false,
|
||||
false,
|
||||
@@ -608,19 +607,19 @@ module internal HttpClientGenerator =
|
||||
| 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
|
||||
| SynExpr.Const (a, _) -> failwith $"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
|
||||
| SynExpr.Const (a, _) -> failwith $"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
|
||||
| SynExpr.Const (SynConst.Unit, _) -> Some HttpAttribute.Body
|
||||
| SynExpr.Const (a, _) -> failwith $"unrecognised constant arg to the Body attribute: %+A{a}"
|
||||
| _ -> None
|
||||
| _ -> None
|
||||
)
|
||||
@@ -670,13 +669,16 @@ module internal HttpClientGenerator =
|
||||
| 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
|
||||
if mem.IsMutable then
|
||||
failwith $"mutable methods not supported (identifier: %+A{mem.Identifier})"
|
||||
|
||||
if mem.IsInline then
|
||||
failwith $"inline methods not supported (identifier: %+A{mem.Identifier})"
|
||||
|
||||
let args =
|
||||
match mem.Args with
|
||||
| [ args ] ->
|
||||
args.Args
|
||||
|> List.map (fun arg ->
|
||||
{
|
||||
Attributes = arg.Attributes |> getHttpAttributes
|
||||
@@ -685,10 +687,21 @@ module internal HttpClientGenerator =
|
||||
Type = arg.Type
|
||||
}
|
||||
)
|
||||
| [] -> failwith $"Expected %+A{mem.Identifier} to have tupled args, but it had no args."
|
||||
| _ ->
|
||||
failwith
|
||||
$"Expected %+A{mem.Identifier} to have tupled args, but it was curried: %+A{mem.Args}."
|
||||
|
||||
{
|
||||
HttpMethod = httpMethod
|
||||
UrlTemplate = url
|
||||
TaskReturnType = returnType
|
||||
Args = args
|
||||
Identifier = mem.Identifier
|
||||
EnsureSuccessHttpCode = shouldEnsureSuccess
|
||||
BaseAddress = baseAddress
|
||||
BasePath = basePath
|
||||
Accessibility = mem.Accessibility
|
||||
}
|
||||
)
|
||||
|
||||
@@ -756,7 +769,7 @@ module internal HttpClientGenerator =
|
||||
if s.StartsWith 'I' then
|
||||
s.[1..]
|
||||
else
|
||||
failwithf "Expected interface type to start with 'I', but was: %s" s
|
||||
failwith $"Expected interface type to start with 'I', but was: %s{s}"
|
||||
|> Ident.Create
|
||||
|> List.singleton
|
||||
|
||||
@@ -767,7 +780,12 @@ module internal HttpClientGenerator =
|
||||
]
|
||||
|
||||
let modInfo =
|
||||
SynComponentInfo.Create (moduleName, attributes = attribs, xmldoc = docString)
|
||||
SynComponentInfo.Create (
|
||||
moduleName,
|
||||
attributes = attribs,
|
||||
xmldoc = docString,
|
||||
access = interfaceType.Accessibility
|
||||
)
|
||||
|
||||
SynModuleOrNamespace.CreateNamespace (
|
||||
ns,
|
||||
|
||||
@@ -62,7 +62,7 @@ module internal InterfaceMockGenerator =
|
||||
SynPat.LongIdent (
|
||||
SynLongIdent.CreateString "Empty",
|
||||
None,
|
||||
generics,
|
||||
None, // no generics on the "Empty", only on the return type
|
||||
SynArgPats.Pats (
|
||||
if generics.IsNone then
|
||||
[]
|
||||
@@ -126,7 +126,7 @@ module internal InterfaceMockGenerator =
|
||||
|
||||
let synValData =
|
||||
SynValData.SynValData (
|
||||
Some (
|
||||
Some
|
||||
{
|
||||
IsInstance = true
|
||||
IsDispatchSlot = false
|
||||
@@ -134,14 +134,27 @@ module internal InterfaceMockGenerator =
|
||||
IsFinal = false
|
||||
GetterOrSetterIsCompilerGenerated = false
|
||||
MemberKind = SynMemberKind.Member
|
||||
}
|
||||
),
|
||||
},
|
||||
valInfo =
|
||||
SynValInfo.SynValInfo (
|
||||
curriedArgInfos =
|
||||
[
|
||||
[ SynArgInfo.SynArgInfo (attributes = [], optional = false, ident = None) ]
|
||||
[]
|
||||
yield
|
||||
[
|
||||
SynArgInfo.SynArgInfo (
|
||||
attributes = [],
|
||||
optional = false,
|
||||
ident = None
|
||||
)
|
||||
]
|
||||
yield!
|
||||
memberInfo.Args
|
||||
|> List.mapi (fun i arg ->
|
||||
arg.Args
|
||||
|> List.mapi (fun j arg ->
|
||||
SynArgInfo.CreateIdString $"arg_%i{i}_%i{j}"
|
||||
)
|
||||
)
|
||||
],
|
||||
returnInfo =
|
||||
SynArgInfo.SynArgInfo (attributes = [], optional = false, ident = None)
|
||||
@@ -150,25 +163,50 @@ module internal InterfaceMockGenerator =
|
||||
)
|
||||
|
||||
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
|
||||
memberInfo.Args
|
||||
|> List.mapi (fun i tupledArgs ->
|
||||
let args =
|
||||
tupledArgs.Args
|
||||
|> List.mapi (fun j _ -> SynPat.CreateNamed (Ident.Create $"arg_%i{i}_%i{j}"))
|
||||
|
||||
SynPat.Tuple (false, args, List.replicate (args.Length - 1) range0, range0)
|
||||
|> SynPat.CreateParen
|
||||
|> fun i -> if tupledArgs.HasParen then SynPat.Paren (i, range0) else i
|
||||
)
|
||||
|> SynPat.CreateParen
|
||||
|
||||
let headPat =
|
||||
SynPat.LongIdent (
|
||||
SynLongIdent.CreateFromLongIdent [ Ident.Create "this" ; memberInfo.Identifier ],
|
||||
None,
|
||||
None,
|
||||
SynArgPats.Pats [ headArgs ],
|
||||
SynArgPats.Pats headArgs,
|
||||
None,
|
||||
range0
|
||||
)
|
||||
|
||||
let body =
|
||||
let tuples =
|
||||
memberInfo.Args
|
||||
|> List.mapi (fun i args ->
|
||||
args.Args
|
||||
|> List.mapi (fun j args -> SynExpr.CreateIdentString $"arg_%i{i}_%i{j}")
|
||||
|> SynExpr.CreateParenedTuple
|
||||
)
|
||||
|
||||
match tuples |> List.rev with
|
||||
| [] -> failwith "expected args but got none"
|
||||
| last :: rest ->
|
||||
|
||||
(last, rest)
|
||||
||> List.fold (fun trail next -> SynExpr.CreateApp (next, trail))
|
||||
|> fun args ->
|
||||
SynExpr.CreateApp (
|
||||
SynExpr.CreateLongIdent (
|
||||
SynLongIdent.CreateFromLongIdent [ Ident.Create "this" ; memberInfo.Identifier ]
|
||||
),
|
||||
args
|
||||
)
|
||||
|
||||
SynMemberDefn.Member (
|
||||
SynBinding.SynBinding (
|
||||
None,
|
||||
@@ -180,16 +218,7 @@ module internal InterfaceMockGenerator =
|
||||
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
|
||||
)
|
||||
),
|
||||
body,
|
||||
range0,
|
||||
DebugPointAtBinding.Yes range0,
|
||||
{
|
||||
@@ -250,23 +279,30 @@ module internal InterfaceMockGenerator =
|
||||
|
||||
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 private buildType (x : ParameterInfo) : SynType =
|
||||
if x.IsOptional then
|
||||
SynType.App (SynType.CreateLongIdent "option", Some range0, [ x.Type ], [], Some range0, false, range0)
|
||||
else
|
||||
x.Type
|
||||
|
||||
let funcType = SynType.CreateFun (inputType, mem.ReturnType)
|
||||
let private constructMemberSinglePlace (tuple : TupledArg) : SynType =
|
||||
match tuple.Args |> List.rev |> List.map buildType 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)
|
||||
|> fun ty -> if tuple.HasParen then SynType.Paren (ty, range0) else ty
|
||||
|
||||
let constructMember (mem : MemberInfo) : SynField =
|
||||
let inputType = mem.Args |> List.map constructMemberSinglePlace
|
||||
|
||||
let funcType = AstHelper.toFun inputType mem.ReturnType
|
||||
|
||||
SynField.SynField (
|
||||
[],
|
||||
true,
|
||||
false,
|
||||
Some mem.Identifier,
|
||||
funcType,
|
||||
false,
|
||||
|
||||
Reference in New Issue
Block a user