Compare commits

...

3 Commits

Author SHA1 Message Date
Patrick Stevens
8e47f39efc Make more extensive use of our own DSLs (#153) 2024-05-31 16:54:05 +00:00
Patrick Stevens
6942ba42b9 Update changelog (#152) 2024-05-30 22:37:05 +01:00
Patrick Stevens
b98080690d Finish DU parsing (#151) 2024-05-30 22:27:15 +01:00
32 changed files with 1557 additions and 1403 deletions

View File

@@ -1,5 +1,14 @@
Notable changes are recorded here. Notable changes are recorded here.
# WoofWare.Myriad.Plugins 2.1.33
`JsonParse` can now deserialize the discriminated unions which `JsonSerialize` wrote out.
# WoofWare.Myriad.Plugins 2.1.32, WoofWare.Myriad.Plugins.Attributes 3.1.4
`JsonSerialize` can now serialize many discriminated unions.
(This operation is inherently opinionated, because JSON does not model discriminated unions.)
# WoofWare.Myriad.Plugins 2.1.20, WoofWare.Myriad.Plugins.Attributes 3.0.1 # WoofWare.Myriad.Plugins 2.1.20, WoofWare.Myriad.Plugins.Attributes 3.0.1
We now bundle copies of the RestEase attributes in `WoofWare.Myriad.Plugins.Attributes`, in case you don't want to take a dependency on RestEase. We now bundle copies of the RestEase attributes in `WoofWare.Myriad.Plugins.Attributes`, in case you don't want to take a dependency on RestEase.

View File

@@ -8,8 +8,7 @@
namespace ConsumePlugin namespace ConsumePlugin
/// Module containing JSON parsing methods for the InnerType type /// Module containing JSON parsing methods for the InnerType type
[<RequireQualifiedAccess>] [<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module InnerType = module InnerType =
/// Parse from a JSON node. /// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : InnerType = let jsonParse (node : System.Text.Json.Nodes.JsonNode) : InnerType =
@@ -31,8 +30,7 @@ module InnerType =
namespace ConsumePlugin namespace ConsumePlugin
/// Module containing JSON parsing methods for the JsonRecordType type /// Module containing JSON parsing methods for the JsonRecordType type
[<RequireQualifiedAccess>] [<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module JsonRecordType = module JsonRecordType =
/// Parse from a JSON node. /// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : JsonRecordType = let jsonParse (node : System.Text.Json.Nodes.JsonNode) : JsonRecordType =

View File

@@ -41,8 +41,7 @@ module MemberJsonSerializeExtension =
namespace PureGym namespace PureGym
/// Module containing JSON parsing methods for the GymOpeningHours type /// Module containing JSON parsing methods for the GymOpeningHours type
[<RequireQualifiedAccess>] [<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module GymOpeningHours = module GymOpeningHours =
/// Parse from a JSON node. /// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : GymOpeningHours = let jsonParse (node : System.Text.Json.Nodes.JsonNode) : GymOpeningHours =
@@ -78,8 +77,7 @@ module GymOpeningHours =
namespace PureGym namespace PureGym
/// Module containing JSON parsing methods for the GymAccessOptions type /// Module containing JSON parsing methods for the GymAccessOptions type
[<RequireQualifiedAccess>] [<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module GymAccessOptions = module GymAccessOptions =
/// Parse from a JSON node. /// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : GymAccessOptions = let jsonParse (node : System.Text.Json.Nodes.JsonNode) : GymAccessOptions =
@@ -114,8 +112,7 @@ module GymAccessOptions =
namespace PureGym namespace PureGym
/// Module containing JSON parsing methods for the GymLocation type /// Module containing JSON parsing methods for the GymLocation type
[<RequireQualifiedAccess>] [<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module GymLocation = module GymLocation =
/// Parse from a JSON node. /// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : GymLocation = let jsonParse (node : System.Text.Json.Nodes.JsonNode) : GymLocation =
@@ -192,8 +189,7 @@ module GymLocation =
namespace PureGym namespace PureGym
/// Module containing JSON parsing methods for the GymAddress type /// Module containing JSON parsing methods for the GymAddress type
[<RequireQualifiedAccess>] [<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module GymAddress = module GymAddress =
/// Parse from a JSON node. /// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : GymAddress = let jsonParse (node : System.Text.Json.Nodes.JsonNode) : GymAddress =
@@ -259,8 +255,7 @@ module GymAddress =
namespace PureGym namespace PureGym
/// Module containing JSON parsing methods for the Gym type /// Module containing JSON parsing methods for the Gym type
[<RequireQualifiedAccess>] [<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module Gym = module Gym =
/// Parse from a JSON node. /// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : Gym = let jsonParse (node : System.Text.Json.Nodes.JsonNode) : Gym =
@@ -620,8 +615,7 @@ module MemberJsonParseExtension =
namespace PureGym namespace PureGym
/// Module containing JSON parsing methods for the GymAttendance type /// Module containing JSON parsing methods for the GymAttendance type
[<RequireQualifiedAccess>] [<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module GymAttendance = module GymAttendance =
/// Parse from a JSON node. /// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : GymAttendance = let jsonParse (node : System.Text.Json.Nodes.JsonNode) : GymAttendance =
@@ -743,8 +737,7 @@ module GymAttendance =
namespace PureGym namespace PureGym
/// Module containing JSON parsing methods for the MemberActivityDto type /// Module containing JSON parsing methods for the MemberActivityDto type
[<RequireQualifiedAccess>] [<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module MemberActivityDto = module MemberActivityDto =
/// Parse from a JSON node. /// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : MemberActivityDto = let jsonParse (node : System.Text.Json.Nodes.JsonNode) : MemberActivityDto =
@@ -832,8 +825,7 @@ module MemberActivityDto =
namespace PureGym namespace PureGym
/// Module containing JSON parsing methods for the SessionsAggregate type /// Module containing JSON parsing methods for the SessionsAggregate type
[<RequireQualifiedAccess>] [<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module SessionsAggregate = module SessionsAggregate =
/// Parse from a JSON node. /// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : SessionsAggregate = let jsonParse (node : System.Text.Json.Nodes.JsonNode) : SessionsAggregate =
@@ -881,8 +873,7 @@ module SessionsAggregate =
namespace PureGym namespace PureGym
/// Module containing JSON parsing methods for the VisitGym type /// Module containing JSON parsing methods for the VisitGym type
[<RequireQualifiedAccess>] [<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module VisitGym = module VisitGym =
/// Parse from a JSON node. /// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : VisitGym = let jsonParse (node : System.Text.Json.Nodes.JsonNode) : VisitGym =
@@ -930,8 +921,7 @@ module VisitGym =
namespace PureGym namespace PureGym
/// Module containing JSON parsing methods for the Visit type /// Module containing JSON parsing methods for the Visit type
[<RequireQualifiedAccess>] [<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module Visit = module Visit =
/// Parse from a JSON node. /// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : Visit = let jsonParse (node : System.Text.Json.Nodes.JsonNode) : Visit =
@@ -993,8 +983,7 @@ module Visit =
namespace PureGym namespace PureGym
/// Module containing JSON parsing methods for the SessionsSummary type /// Module containing JSON parsing methods for the SessionsSummary type
[<RequireQualifiedAccess>] [<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module SessionsSummary = module SessionsSummary =
/// Parse from a JSON node. /// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : SessionsSummary = let jsonParse (node : System.Text.Json.Nodes.JsonNode) : SessionsSummary =
@@ -1029,8 +1018,7 @@ module SessionsSummary =
namespace PureGym namespace PureGym
/// Module containing JSON parsing methods for the Sessions type /// Module containing JSON parsing methods for the Sessions type
[<RequireQualifiedAccess>] [<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module Sessions = module Sessions =
/// Parse from a JSON node. /// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : Sessions = let jsonParse (node : System.Text.Json.Nodes.JsonNode) : Sessions =
@@ -1066,8 +1054,7 @@ module Sessions =
namespace PureGym namespace PureGym
/// Module containing JSON parsing methods for the UriThing type /// Module containing JSON parsing methods for the UriThing type
[<RequireQualifiedAccess>] [<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module UriThing = module UriThing =
/// Parse from a JSON node. /// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : UriThing = let jsonParse (node : System.Text.Json.Nodes.JsonNode) : UriThing =

View File

@@ -17,8 +17,7 @@ open System.Net.Http
open RestEase open RestEase
/// Module for constructing a REST client. /// Module for constructing a REST client.
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>] [<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix) ; RequireQualifiedAccess>]
[<RequireQualifiedAccess>]
module PureGymApi = module PureGymApi =
/// Create a REST client. /// Create a REST client.
let make (client : System.Net.Http.HttpClient) : IPureGymApi = let make (client : System.Net.Http.HttpClient) : IPureGymApi =
@@ -1055,8 +1054,7 @@ open System.Net.Http
open RestEase open RestEase
/// Module for constructing a REST client. /// Module for constructing a REST client.
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>] [<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix) ; RequireQualifiedAccess>]
[<RequireQualifiedAccess>]
module internal ApiWithoutBaseAddress = module internal ApiWithoutBaseAddress =
/// Create a REST client. /// Create a REST client.
let make (client : System.Net.Http.HttpClient) : IApiWithoutBaseAddress = let make (client : System.Net.Http.HttpClient) : IApiWithoutBaseAddress =
@@ -1107,8 +1105,7 @@ open System.Net.Http
open RestEase open RestEase
/// Module for constructing a REST client. /// Module for constructing a REST client.
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>] [<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix) ; RequireQualifiedAccess>]
[<RequireQualifiedAccess>]
module ApiWithBasePath = module ApiWithBasePath =
/// Create a REST client. /// Create a REST client.
let make (client : System.Net.Http.HttpClient) : IApiWithBasePath = let make (client : System.Net.Http.HttpClient) : IApiWithBasePath =
@@ -1159,8 +1156,7 @@ open System.Net.Http
open RestEase open RestEase
/// Module for constructing a REST client. /// Module for constructing a REST client.
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>] [<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix) ; RequireQualifiedAccess>]
[<RequireQualifiedAccess>]
module ApiWithBasePathAndAddress = module ApiWithBasePathAndAddress =
/// Create a REST client. /// Create a REST client.
let make (client : System.Net.Http.HttpClient) : IApiWithBasePathAndAddress = let make (client : System.Net.Http.HttpClient) : IApiWithBasePathAndAddress =
@@ -1205,8 +1201,7 @@ open System.Net.Http
open RestEase open RestEase
/// Module for constructing a REST client. /// Module for constructing a REST client.
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>] [<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix) ; RequireQualifiedAccess>]
[<RequireQualifiedAccess>]
module ApiWithHeaders = module ApiWithHeaders =
/// Create a REST client. The input functions will be re-evaluated on every HTTP request to obtain the required values for the corresponding header properties. /// Create a REST client. The input functions will be re-evaluated on every HTTP request to obtain the required values for the corresponding header properties.
let make let make
@@ -1268,8 +1263,7 @@ open System.Net.Http
open RestEase open RestEase
/// Module for constructing a REST client. /// Module for constructing a REST client.
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>] [<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix) ; RequireQualifiedAccess>]
[<RequireQualifiedAccess>]
module ApiWithHeaders2 = module ApiWithHeaders2 =
/// Create a REST client. The input functions will be re-evaluated on every HTTP request to obtain the required values for the corresponding header properties. /// Create a REST client. The input functions will be re-evaluated on every HTTP request to obtain the required values for the corresponding header properties.
let make let make

View File

@@ -378,3 +378,83 @@ module JsonRecordTypeWithBothJsonParseExtension =
E = arg_4 E = arg_4
F = arg_5 F = arg_5
} }
namespace ConsumePlugin
/// Module containing JSON parsing extension members for the FirstDu type
[<AutoOpen>]
module FirstDuJsonParseExtension =
/// Extension methods for JSON parsing
type FirstDu with
/// Parse from a JSON node.
static member jsonParse (node : System.Text.Json.Nodes.JsonNode) : FirstDu =
let ty =
(match node.["type"] with
| null ->
raise (
System.Collections.Generic.KeyNotFoundException (
sprintf "Required key '%s' not found on JSON object" ("type")
)
)
| v -> v)
|> (fun v -> v.GetValue<string> ())
match ty with
| "emptyCase" -> FirstDu.EmptyCase
| "case1" ->
let node =
(match node.["data"] with
| null ->
raise (
System.Collections.Generic.KeyNotFoundException (
sprintf "Required key '%s' not found on JSON object" ("data")
)
)
| v -> v)
FirstDu.Case1 (
(match node.["data"] with
| null ->
raise (
System.Collections.Generic.KeyNotFoundException (
sprintf "Required key '%s' not found on JSON object" ("data")
)
)
| v -> v)
.AsValue()
.GetValue<string> ()
)
| "case2" ->
let node =
(match node.["data"] with
| null ->
raise (
System.Collections.Generic.KeyNotFoundException (
sprintf "Required key '%s' not found on JSON object" ("data")
)
)
| v -> v)
FirstDu.Case2 (
JsonRecordTypeWithBoth.jsonParse (
match node.["record"] with
| null ->
raise (
System.Collections.Generic.KeyNotFoundException (
sprintf "Required key '%s' not found on JSON object" ("record")
)
)
| v -> v
),
(match node.["i"] with
| null ->
raise (
System.Collections.Generic.KeyNotFoundException (
sprintf "Required key '%s' not found on JSON object" ("i")
)
)
| v -> v)
.AsValue()
.GetValue<int> ()
)
| v -> failwith ("Unrecognised 'type' field value: " + v)

View File

@@ -8,8 +8,7 @@
namespace ConsumePlugin namespace ConsumePlugin
/// Module containing JSON parsing methods for the JwtVaultAuthResponse type /// Module containing JSON parsing methods for the JwtVaultAuthResponse type
[<RequireQualifiedAccess>] [<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module JwtVaultAuthResponse = module JwtVaultAuthResponse =
/// Parse from a JSON node. /// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : JwtVaultAuthResponse = let jsonParse (node : System.Text.Json.Nodes.JsonNode) : JwtVaultAuthResponse =
@@ -164,8 +163,7 @@ module JwtVaultAuthResponse =
namespace ConsumePlugin namespace ConsumePlugin
/// Module containing JSON parsing methods for the JwtVaultResponse type /// Module containing JSON parsing methods for the JwtVaultResponse type
[<RequireQualifiedAccess>] [<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module JwtVaultResponse = module JwtVaultResponse =
/// Parse from a JSON node. /// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : JwtVaultResponse = let jsonParse (node : System.Text.Json.Nodes.JsonNode) : JwtVaultResponse =
@@ -239,8 +237,7 @@ module JwtVaultResponse =
namespace ConsumePlugin namespace ConsumePlugin
/// Module containing JSON parsing methods for the JwtSecretResponse type /// Module containing JSON parsing methods for the JwtSecretResponse type
[<RequireQualifiedAccess>] [<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module JwtSecretResponse = module JwtSecretResponse =
/// Parse from a JSON node. /// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : JwtSecretResponse = let jsonParse (node : System.Text.Json.Nodes.JsonNode) : JwtSecretResponse =
@@ -455,8 +452,7 @@ open System.Threading.Tasks
open RestEase open RestEase
/// Module for constructing a REST client. /// Module for constructing a REST client.
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>] [<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix) ; RequireQualifiedAccess>]
[<RequireQualifiedAccess>]
module VaultClient = module VaultClient =
/// Create a REST client. /// Create a REST client.
let make (client : System.Net.Http.HttpClient) : IVaultClient = let make (client : System.Net.Http.HttpClient) : IVaultClient =
@@ -553,8 +549,7 @@ open System.Threading.Tasks
open RestEase open RestEase
/// Module for constructing a REST client. /// Module for constructing a REST client.
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>] [<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix) ; RequireQualifiedAccess>]
[<RequireQualifiedAccess>]
module VaultClientNonExtensionMethod = module VaultClientNonExtensionMethod =
/// Create a REST client. /// Create a REST client.
let make (client : System.Net.Http.HttpClient) : IVaultClientNonExtensionMethod = let make (client : System.Net.Http.HttpClient) : IVaultClientNonExtensionMethod =

View File

@@ -29,6 +29,7 @@ type JsonRecordTypeWithBoth =
} }
[<WoofWare.Myriad.Plugins.JsonSerialize true>] [<WoofWare.Myriad.Plugins.JsonSerialize true>]
[<WoofWare.Myriad.Plugins.JsonParse true>]
type FirstDu = type FirstDu =
| EmptyCase | EmptyCase
| Case1 of data : string | Case1 of data : string

View File

@@ -2,10 +2,9 @@ namespace WoofWare.Myriad.Plugins.Test
open System open System
open System.Collections.Generic open System.Collections.Generic
open System.IO
open System.Text
open System.Text.Json
open System.Text.Json.Nodes open System.Text.Json.Nodes
open FsCheck.Random
open Microsoft.FSharp.Reflection
open NUnit.Framework open NUnit.Framework
open FsCheck open FsCheck
open FsUnitTyped open FsUnitTyped
@@ -124,3 +123,82 @@ module TestJsonSerde =
|> shouldEqual ( |> shouldEqual (
sprintf """{"it\u0027s-a-me":"%s","map":{},"readOnlyDict":{},"dict":{},"concreteDict":{}}""" guidStr sprintf """{"it\u0027s-a-me":"%s","map":{},"readOnlyDict":{},"dict":{},"concreteDict":{}}""" guidStr
) )
type Generators =
static member TestCase () =
{ new Arbitrary<InnerTypeWithBoth>() with
override x.Generator = innerGen 5
}
let sanitiseInner (r : InnerTypeWithBoth) : InnerTypeWithBoth =
{
Thing = r.Thing
Map = r.Map
ReadOnlyDict = r.ReadOnlyDict
Dict = r.Dict
ConcreteDict = r.ConcreteDict
}
let sanitiseRec (r : JsonRecordTypeWithBoth) : JsonRecordTypeWithBoth =
{
A = r.A
B = if isNull r.B then "<null>" else r.B
C =
if Object.ReferenceEquals (r.C, (null : obj)) then
[]
else
r.C
D = sanitiseInner r.D
E = if isNull r.E then [||] else r.E
F =
if Object.ReferenceEquals (r.F, (null : obj)) then
[||]
else
r.F
}
let duGen =
gen {
let! case = Gen.choose (0, 2)
match case with
| 0 -> return FirstDu.EmptyCase
| 1 ->
let! s = Arb.generate<NonNull<string>>
return FirstDu.Case1 s.Get
| 2 ->
let! i = Arb.generate<int>
let! record = outerGen
return FirstDu.Case2 (record, i)
| _ -> return failwith $"unexpected: %i{case}"
}
[<Test>]
let ``Discriminated union works`` () =
let property (du : FirstDu) : unit =
du
|> FirstDu.toJsonNode
|> fun s -> s.ToJsonString ()
|> JsonNode.Parse
|> FirstDu.jsonParse
|> shouldEqual du
property |> Prop.forAll (Arb.fromGen duGen) |> Check.QuickThrowOnFailure
[<Test>]
let ``DU generator covers all cases`` () =
let rand = Random ()
let cases = FSharpType.GetUnionCases typeof<FirstDu>
let counts = Array.zeroCreate<int> cases.Length
let decompose = FSharpValue.PreComputeUnionTagReader typeof<FirstDu>
Gen.listOf duGen
|> Gen.eval 100 (StdGen.StdGen (rand.Next (), rand.Next ()))
|> List.iter (fun du ->
let tag = decompose du
counts.[tag] <- counts.[tag] + 1
)
for i in counts do
i |> shouldBeGreaterThan 0

View File

@@ -1,7 +1,6 @@
namespace WoofWare.Myriad.Plugins namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia
open Fantomas.FCS.Text.Range open Fantomas.FCS.Text.Range
open Fantomas.FCS.Xml open Fantomas.FCS.Xml
open Myriad.Core.AstExtensions open Myriad.Core.AstExtensions
@@ -98,30 +97,6 @@ type internal AdtProduct =
[<RequireQualifiedAccess>] [<RequireQualifiedAccess>]
module internal AstHelper = module internal AstHelper =
/// Given e.g. "byte", returns "System.Byte".
let qualifyPrimitiveType (typeName : string) : LongIdent option =
match typeName with
| "float32"
| "single" -> [ "System" ; "Single" ] |> Some
| "float"
| "double" -> [ "System" ; "Double" ] |> Some
| "byte"
| "uint8" -> [ "System" ; "Byte" ] |> Some
| "sbyte"
| "int8" -> [ "System" ; "SByte" ] |> Some
| "int16" -> [ "System" ; "Int16" ] |> Some
| "int"
| "int32" -> [ "System" ; "Int32" ] |> Some
| "int64" -> [ "System" ; "Int64" ] |> Some
| "uint16" -> [ "System" ; "UInt16" ] |> Some
| "uint"
| "uint32" -> [ "System" ; "UInt32" ] |> Some
| "uint64" -> [ "System" ; "UInt64" ] |> Some
| "char" -> [ "System" ; "Char" ] |> Some
| "decimal" -> [ "System" ; "Decimal" ] |> Some
| _ -> None
|> Option.map (List.map Ident.Create)
let instantiateRecord (fields : (RecordFieldName * SynExpr option) list) : SynExpr = let instantiateRecord (fields : (RecordFieldName * SynExpr option) list) : SynExpr =
let fields = let fields =
fields fields
@@ -130,86 +105,17 @@ module internal AstHelper =
SynExpr.Record (None, None, fields, range0) SynExpr.Record (None, None, fields, range0)
let defineRecordType (record : RecordType) : SynTypeDefn = let defineRecordType (record : RecordType) : SynTypeDefn =
let repr =
SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (None, Seq.toList record.Fields, range0), range0)
let name = let name =
SynComponentInfo.Create ( SynComponentInfo.create record.Name
[ record.Name ], |> SynComponentInfo.setAccessibility record.Accessibility
?xmldoc = record.XmlDoc, |> match record.XmlDoc with
?parameters = record.Generics, | None -> id
access = record.Accessibility | Some doc -> SynComponentInfo.withDocString doc
) |> SynComponentInfo.setGenerics record.Generics
let trivia : SynTypeDefnTrivia = SynTypeDefnRepr.record (Seq.toList record.Fields)
{ |> SynTypeDefn.create name
LeadingKeyword = SynTypeDefnLeadingKeyword.Type range0 |> SynTypeDefn.withMemberDefns (defaultArg record.Members SynMemberDefns.Empty)
EqualsRange = Some range0
WithKeyword = Some range0
}
SynTypeDefn (name, repr, defaultArg record.Members SynMemberDefns.Empty, None, range0, trivia)
let isOptionIdent (ident : SynLongIdent) : bool =
match ident.LongIdent with
| [ i ] when System.String.Equals (i.idText, "option", System.StringComparison.OrdinalIgnoreCase) -> true
// TODO: consider Microsoft.FSharp.Option or whatever it is
| _ -> false
let isUnitIdent (ident : SynLongIdent) : bool =
match ident.LongIdent with
| [ i ] when System.String.Equals (i.idText, "unit", System.StringComparison.OrdinalIgnoreCase) -> true
| _ -> false
let isListIdent (ident : SynLongIdent) : bool =
match ident.LongIdent with
| [ i ] when System.String.Equals (i.idText, "list", System.StringComparison.OrdinalIgnoreCase) -> true
// TODO: consider FSharpList or whatever it is
| _ -> false
let isArrayIdent (ident : SynLongIdent) : bool =
match ident.LongIdent with
| [ i ] when
System.String.Equals (i.idText, "array", System.StringComparison.OrdinalIgnoreCase)
|| System.String.Equals (i.idText, "[]", System.StringComparison.Ordinal)
->
true
| _ -> false
let isResponseIdent (ident : SynLongIdent) : bool =
match ident.LongIdent |> List.map _.idText with
| [ "Response" ]
| [ "RestEase" ; "Response" ] -> true
| _ -> false
let isMapIdent (ident : SynLongIdent) : bool =
match ident.LongIdent |> List.map _.idText with
| [ "Map" ] -> true
| _ -> false
let isReadOnlyDictionaryIdent (ident : SynLongIdent) : bool =
match ident.LongIdent |> List.map _.idText with
| [ "IReadOnlyDictionary" ]
| [ "Generic" ; "IReadOnlyDictionary" ]
| [ "Collections" ; "Generic" ; "IReadOnlyDictionary" ]
| [ "System" ; "Collections" ; "Generic" ; "IReadOnlyDictionary" ] -> true
| _ -> false
let isDictionaryIdent (ident : SynLongIdent) : bool =
match ident.LongIdent |> List.map _.idText with
| [ "Dictionary" ]
| [ "Generic" ; "Dictionary" ]
| [ "Collections" ; "Generic" ; "Dictionary" ]
| [ "System" ; "Collections" ; "Generic" ; "Dictionary" ] -> true
| _ -> false
let isIDictionaryIdent (ident : SynLongIdent) : bool =
match ident.LongIdent |> List.map _.idText with
| [ "IDictionary" ]
| [ "Generic" ; "IDictionary" ]
| [ "Collections" ; "Generic" ; "IDictionary" ]
| [ "System" ; "Collections" ; "Generic" ; "IDictionary" ] -> true
| _ -> false
let rec private extractOpensFromDecl (moduleDecls : SynModuleDecl list) : SynOpenDeclTarget list = let rec private extractOpensFromDecl (moduleDecls : SynModuleDecl list) : SynOpenDeclTarget list =
moduleDecls moduleDecls
@@ -254,7 +160,7 @@ module internal AstHelper =
Attributes = [] Attributes = []
IsOptional = false IsOptional = false
Id = None Id = None
Type = SynType.Var (typar, range0) Type = SynType.var typar
}, },
false false
| _ -> failwithf "expected SignatureParameter, got: %+A" ty | _ -> failwithf "expected SignatureParameter, got: %+A" ty
@@ -356,7 +262,7 @@ module internal AstHelper =
Attributes = [] Attributes = []
IsOptional = false IsOptional = false
Id = None Id = None
Type = SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent ident) Type = SynType.createLongIdent ident
} }
|> List.singleton |> List.singleton
} }
@@ -368,7 +274,7 @@ module internal AstHelper =
Attributes = [] Attributes = []
IsOptional = false IsOptional = false
Id = None Id = None
Type = SynType.Var (typar, range0) Type = SynType.var typar
} }
|> List.singleton |> List.singleton
} }
@@ -522,190 +428,3 @@ module internal AstHelper =
} }
) )
| _ -> failwithf "Failed to get record elements for type that was: %+A" repr | _ -> failwithf "Failed to get record elements for type that was: %+A" repr
[<AutoOpen>]
module internal SynTypePatterns =
let (|OptionType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ innerType ], _, _, _, _) when AstHelper.isOptionIdent ident ->
Some innerType
| _ -> None
let (|UnitType|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident when AstHelper.isUnitIdent ident -> Some ()
| _ -> None
let (|ListType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ innerType ], _, _, _, _) when AstHelper.isListIdent ident ->
Some innerType
| _ -> None
let (|ArrayType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ innerType ], _, _, _, _) when AstHelper.isArrayIdent ident ->
Some innerType
| SynType.Array (1, innerType, _) -> Some innerType
| _ -> None
let (|RestEaseResponseType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ innerType ], _, _, _, _) when AstHelper.isResponseIdent ident ->
Some innerType
| _ -> None
let (|DictionaryType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ key ; value ], _, _, _, _) when AstHelper.isDictionaryIdent ident ->
Some (key, value)
| _ -> None
let (|IDictionaryType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ key ; value ], _, _, _, _) when AstHelper.isIDictionaryIdent ident ->
Some (key, value)
| _ -> None
let (|IReadOnlyDictionaryType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ key ; value ], _, _, _, _) when
AstHelper.isReadOnlyDictionaryIdent ident
->
Some (key, value)
| _ -> None
let (|MapType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ key ; value ], _, _, _, _) when AstHelper.isMapIdent ident ->
Some (key, value)
| _ -> None
let (|BigInt|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent |> List.map _.idText with
| [ "bigint" ]
| [ "BigInteger" ]
| [ "Numerics" ; "BigInteger" ]
| [ "System" ; "Numerics" ; "BigInteger" ] -> Some ()
| _ -> None
| _ -> None
/// Returns the type, qualified as in e.g. `System.Boolean`.
let (|PrimitiveType|_|) (fieldType : SynType) : LongIdent option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent with
| [ i ] -> AstHelper.qualifyPrimitiveType i.idText
| _ -> None
| _ -> None
let (|String|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent with
| [ i ] ->
[ "string" ]
|> List.tryFind (fun s -> s = i.idText)
|> Option.map ignore<string>
| _ -> None
| _ -> None
let (|Byte|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent with
| [ i ] -> [ "byte" ] |> List.tryFind (fun s -> s = i.idText) |> Option.map ignore<string>
| _ -> None
| _ -> None
let (|Guid|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent |> List.map (fun i -> i.idText) with
| [ "System" ; "Guid" ]
| [ "Guid" ] -> Some ()
| _ -> None
| _ -> None
let (|HttpResponseMessage|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent |> List.map (fun i -> i.idText) with
| [ "System" ; "Net" ; "Http" ; "HttpResponseMessage" ]
| [ "Net" ; "Http" ; "HttpResponseMessage" ]
| [ "Http" ; "HttpResponseMessage" ]
| [ "HttpResponseMessage" ] -> Some ()
| _ -> None
| _ -> None
let (|HttpContent|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent |> List.map (fun i -> i.idText) with
| [ "System" ; "Net" ; "Http" ; "HttpContent" ]
| [ "Net" ; "Http" ; "HttpContent" ]
| [ "Http" ; "HttpContent" ]
| [ "HttpContent" ] -> Some ()
| _ -> None
| _ -> None
let (|Stream|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent |> List.map (fun i -> i.idText) with
| [ "System" ; "IO" ; "Stream" ]
| [ "IO" ; "Stream" ]
| [ "Stream" ] -> Some ()
| _ -> None
| _ -> None
let (|NumberType|_|) (fieldType : SynType) =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent with
| [ i ] -> [ "string" ; "float" ; "int" ; "bool" ] |> List.tryFind (fun s -> s = i.idText)
| _ -> None
| _ -> None
let (|DateOnly|_|) (fieldType : SynType) =
match fieldType with
| SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->
match ident |> List.map (fun i -> i.idText) with
| [ "System" ; "DateOnly" ]
| [ "DateOnly" ] -> Some ()
| _ -> None
| _ -> None
let (|DateTime|_|) (fieldType : SynType) =
match fieldType with
| SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->
match ident |> List.map (fun i -> i.idText) with
| [ "System" ; "DateTime" ]
| [ "DateTime" ] -> Some ()
| _ -> None
| _ -> None
let (|Uri|_|) (fieldType : SynType) =
match fieldType with
| SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->
match ident |> List.map (fun i -> i.idText) with
| [ "System" ; "Uri" ]
| [ "Uri" ] -> Some ()
| _ -> None
| _ -> None
let (|Task|_|) (fieldType : SynType) : SynType option =
match fieldType with
| SynType.App (SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)), _, args, _, _, _, _) ->
match ident |> List.map (fun i -> i.idText) with
| [ "Task" ]
| [ "Tasks" ; "Task" ]
| [ "Threading" ; "Tasks" ; "Task" ]
| [ "System" ; "Threading" ; "Tasks" ; "Task" ] ->
match args with
| [ arg ] -> Some arg
| _ -> failwithf "Expected Task to be applied to exactly one arg, but got: %+A" args
| _ -> None
| _ -> None

View File

@@ -136,11 +136,11 @@ module internal CataGenerator =
let userProvidedTyparsForCase = let userProvidedTyparsForCase =
analysis.Typars analysis.Typars
|> List.map (fun (SynTyparDecl.SynTyparDecl (_, ty)) -> SynType.Var (ty, range0)) |> List.map (fun (SynTyparDecl.SynTyparDecl (_, ty)) -> SynType.var ty)
let userProvidedTyparsForCata = let userProvidedTyparsForCata =
userProvidedTypars userProvidedTypars
|> List.map (fun (SynTyparDecl.SynTyparDecl (_, ty)) -> SynType.Var (ty, range0)) |> List.map (fun (SynTyparDecl.SynTyparDecl (_, ty)) -> SynType.var ty)
let relevantTyparName = let relevantTyparName =
match relevantTypar with match relevantTypar with
@@ -148,48 +148,30 @@ module internal CataGenerator =
| _ -> failwith "logic error in generator" | _ -> failwith "logic error in generator"
let inputObjectType = let inputObjectType =
let baseType = let baseType = SynType.createLongIdent relevantTypeName
SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent relevantTypeName)
if userProvidedTypars.Length = 0 then if userProvidedTypars.Length = 0 then
baseType baseType
else else
SynType.App ( SynType.app' baseType userProvidedTyparsForCase
baseType,
Some range0,
userProvidedTyparsForCase,
List.replicate (userProvidedTypars.Length - 1) range0,
Some range0,
false,
range0
)
// The object on which we'll run the cata // The object on which we'll run the cata
let inputObject = let inputObject = SynPat.named "x" |> SynPat.annotateType inputObjectType
SynPat.CreateTyped (SynPat.CreateNamed (Ident.Create "x"), inputObjectType)
let cataObject = let cataObject =
SynPat.CreateTyped ( SynPat.named "cata"
SynPat.CreateNamed (Ident.Create "cata"), |> SynPat.annotateType (
SynType.App ( SynType.app' (SynType.createLongIdent [ cataName ]) (userProvidedTyparsForCata @ allArtificialTypars)
SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ cataName ]),
Some range0,
userProvidedTyparsForCata @ allArtificialTypars,
List.replicate (userProvidedTypars.Length + allArtificialTypars.Length - 1) range0,
Some range0,
false,
range0
)
) )
[ [
SynExpr.CreateLongIdent analysis.AssociatedProcessInstruction SynExpr.CreateLongIdent analysis.AssociatedProcessInstruction
|> SynExpr.applyTo (SynExpr.CreateLongIdent (SynLongIdent.CreateString "x")) |> SynExpr.applyTo (SynExpr.createLongIdent [ "x" ])
|> SynExpr.CreateParen |> SynExpr.paren
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "instructions" ; "Add" ]) |> SynExpr.applyFunction (SynExpr.createLongIdent [ "instructions" ; "Add" ])
// TODO: add the "all other stacks are empty" sanity checks // TODO: add the "all other stacks are empty" sanity checks
SynExpr.CreateIdent (Ident.Create (relevantTyparName.idText + "Stack") |> Ident.lowerFirstLetter) SynExpr.createIdent' (Ident.create (relevantTyparName.idText + "Stack") |> Ident.lowerFirstLetter)
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "Seq" ; "exactlyOne" ]) |> SynExpr.applyFunction (SynExpr.createLongIdent [ "Seq" ; "exactlyOne" ])
|> SynExpr.createLet |> SynExpr.createLet
[ [
@@ -209,26 +191,25 @@ module internal CataGenerator =
range0 range0
), ),
expr = expr =
SynExpr.CreateApp ( SynExpr.applyFunction
SynExpr.CreateApp (SynExpr.CreateIdentString "loop", SynExpr.CreateIdentString "cata"), (SynExpr.applyFunction (SynExpr.createIdent "loop") (SynExpr.createIdent "cata"))
SynExpr.CreateIdentString "instructions" (SynExpr.createIdent "instructions")
)
) )
] ]
] ]
|> SynExpr.CreateSequential |> SynExpr.CreateSequential
|> SynExpr.createLet |> SynExpr.createLet
[ [
SynExpr.CreateIdentString "ResizeArray" SynExpr.createIdent "ResizeArray"
|> SynExpr.applyTo (SynExpr.CreateConst SynConst.Unit) |> SynExpr.applyTo (SynExpr.CreateConst ())
|> SynBinding.basic (SynLongIdent.CreateString "instructions") [] |> SynBinding.basic (SynLongIdent.createS "instructions") []
] ]
|> SynExpr.typeAnnotate relevantTypar |> SynExpr.typeAnnotate relevantTypar
|> SynBinding.basic |> SynBinding.basic
(SynLongIdent.CreateString ("run" + List.last(relevantTypeName).idText)) (SynLongIdent.createS ("run" + List.last(relevantTypeName).idText))
[ SynPat.CreateParen cataObject ; SynPat.CreateParen inputObject ] [ cataObject ; inputObject ]
|> SynBinding.withReturnAnnotation relevantTypar |> SynBinding.withReturnAnnotation relevantTypar
|> SynBinding.withXmlDoc (PreXmlDoc.Create " Execute the catamorphism.") |> SynBinding.withXmlDoc (PreXmlDoc.create "Execute the catamorphism.")
let getName (ty : SynTypeDefn) : LongIdent = let getName (ty : SynTypeDefn) : LongIdent =
match ty with match ty with
@@ -280,7 +261,7 @@ module internal CataGenerator =
ArgName = ArgName =
match name with match name with
| Some n -> Ident.lowerFirstLetter n | Some n -> Ident.lowerFirstLetter n
| None -> Ident.Create $"arg%s{prefix}" | None -> Ident.create $"arg%s{prefix}"
Description = FieldDescription.Self ty Description = FieldDescription.Self ty
RequiredGenerics = typeArgs RequiredGenerics = typeArgs
} }
@@ -290,7 +271,7 @@ module internal CataGenerator =
ArgName = ArgName =
match name with match name with
| Some n -> Ident.lowerFirstLetter n | Some n -> Ident.lowerFirstLetter n
| None -> Ident.Create $"arg%s{prefix}" | None -> Ident.create $"arg%s{prefix}"
Description = FieldDescription.NonRecursive ty Description = FieldDescription.NonRecursive ty
RequiredGenerics = typeArgs RequiredGenerics = typeArgs
} }
@@ -308,7 +289,7 @@ module internal CataGenerator =
ArgName = ArgName =
match name with match name with
| Some n -> Ident.lowerFirstLetter n | Some n -> Ident.lowerFirstLetter n
| None -> Ident.Create $"arg%s{prefix}" | None -> Ident.create $"arg%s{prefix}"
Description = FieldDescription.NonRecursive stripped Description = FieldDescription.NonRecursive stripped
RequiredGenerics = typeArgs RequiredGenerics = typeArgs
} }
@@ -318,7 +299,7 @@ module internal CataGenerator =
ArgName = ArgName =
match name with match name with
| Some n -> Ident.lowerFirstLetter n | Some n -> Ident.lowerFirstLetter n
| None -> Ident.Create $"arg%s{prefix}" | None -> Ident.create $"arg%s{prefix}"
Description = FieldDescription.ListSelf ty Description = FieldDescription.ListSelf ty
RequiredGenerics = typeArgs RequiredGenerics = typeArgs
} }
@@ -329,7 +310,7 @@ module internal CataGenerator =
ArgName = ArgName =
match name with match name with
| Some n -> Ident.lowerFirstLetter n | Some n -> Ident.lowerFirstLetter n
| None -> Ident.Create $"arg%s{prefix}" | None -> Ident.create $"arg%s{prefix}"
Description = FieldDescription.NonRecursive stripped Description = FieldDescription.NonRecursive stripped
RequiredGenerics = typeArgs RequiredGenerics = typeArgs
} }
@@ -357,7 +338,7 @@ module internal CataGenerator =
ArgName = ArgName =
match name with match name with
| Some n -> Ident.lowerFirstLetter n | Some n -> Ident.lowerFirstLetter n
| None -> Ident.Create $"arg%s{prefix}" | None -> Ident.create $"arg%s{prefix}"
Description = FieldDescription.NonRecursive ty Description = FieldDescription.NonRecursive ty
RequiredGenerics = typeArgs RequiredGenerics = typeArgs
} }
@@ -391,7 +372,7 @@ module internal CataGenerator =
let getInstructionCaseName (thisUnionType : SynTypeDefn) (caseName : SynIdent) : Ident = let getInstructionCaseName (thisUnionType : SynTypeDefn) (caseName : SynIdent) : Ident =
match caseName with match caseName with
| SynIdent.SynIdent (ident, _) -> | SynIdent.SynIdent (ident, _) ->
(List.last (getName thisUnionType)).idText + "_" + ident.idText |> Ident.Create (List.last (getName thisUnionType)).idText + "_" + ident.idText |> Ident.create
/// Given the input `| Pair of Expr * Expr * PairOpKind`, /// Given the input `| Pair of Expr * Expr * PairOpKind`,
/// strips out any members which contain recursive calls. /// strips out any members which contain recursive calls.
@@ -449,25 +430,15 @@ module internal CataGenerator =
{ {
Name = None Name = None
Type = Type =
let name = let name = SynType.createLongIdent union.ParentTypeName
SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent union.ParentTypeName)
match union.Typars with match union.Typars with
| [] -> name | [] -> name
| typars -> | typars ->
let typars = let typars = typars |> List.map (fun (SynTyparDecl (_, typar)) -> SynType.var typar)
typars
|> List.map (fun (SynTyparDecl (_, typar)) -> SynType.Var (typar, range0)) SynType.app' name typars
SynType.App (
name,
Some range0,
typars,
List.replicate (typars.Length - 1) range0,
Some range0,
false,
range0
)
GenericsOfParent = union.Typars GenericsOfParent = union.Typars
} }
|> List.singleton |> List.singleton
@@ -487,7 +458,7 @@ module internal CataGenerator =
|> List.map (fun (SynTyparDecl.SynTyparDecl (_, SynTypar.SynTypar (ident, _, _))) -> ident.idText) |> List.map (fun (SynTyparDecl.SynTyparDecl (_, SynTypar.SynTypar (ident, _, _))) -> ident.idText)
|> List.distinct |> List.distinct
|> List.map (fun i -> |> List.map (fun i ->
SynTyparDecl.SynTyparDecl ([], SynTypar.SynTypar (Ident.Create i, TyparStaticReq.None, false)) SynTyparDecl.SynTyparDecl ([], SynTypar.SynTypar (Ident.create i, TyparStaticReq.None, false))
) )
// One union case for each union type, and then // One union case for each union type, and then
@@ -514,13 +485,9 @@ module internal CataGenerator =
let cases = casesFromProcess @ casesFromCases let cases = casesFromProcess @ casesFromCases
let typars = let typars =
let count = analysis |> List.map (fun x -> List.length x.Typars) |> List.max
if analysis |> List.forall (fun x -> x.Typars.IsEmpty) then if analysis |> List.forall (fun x -> x.Typars.IsEmpty) then
None []
else else
let typars =
analysis analysis
|> List.collect _.Typars |> List.collect _.Typars
|> List.map (fun (SynTyparDecl.SynTyparDecl (_, SynTypar.SynTypar (ident, _, _))) -> ident.idText) |> List.map (fun (SynTyparDecl.SynTyparDecl (_, SynTypar.SynTypar (ident, _, _))) -> ident.idText)
@@ -529,28 +496,12 @@ module internal CataGenerator =
SynTyparDecl.SynTyparDecl ([], SynTypar.SynTypar (Ident.Create i, TyparStaticReq.None, false)) SynTyparDecl.SynTyparDecl ([], SynTypar.SynTypar (Ident.Create i, TyparStaticReq.None, false))
) )
Some (SynTyparDecls.PostfixList (typars, [], range0)) SynTypeDefnRepr.union cases
|> SynTypeDefn.create (
SynTypeDefn.SynTypeDefn ( SynComponentInfo.create (Ident.create "Instruction")
SynComponentInfo.SynComponentInfo ( |> SynComponentInfo.withGenerics typars
[ SynAttributeList.Create [ SynAttribute.RequireQualifiedAccess () ] ], |> SynComponentInfo.withAccessibility (SynAccess.Private range0)
typars, |> SynComponentInfo.addAttributes [ SynAttribute.RequireQualifiedAccess () ]
[],
[ Ident.Create "Instruction" ],
PreXmlDoc.Empty,
false,
Some (SynAccess.Private range0),
range0
),
SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (None, cases, range0), range0),
[],
None,
range0,
{
LeadingKeyword = SynTypeDefnLeadingKeyword.Type range0
EqualsRange = Some range0
WithKeyword = None
}
) )
/// Build the cata interfaces, which a user will instantiate to specify a particular /// Build the cata interfaces, which a user will instantiate to specify a particular
@@ -582,133 +533,54 @@ module internal CataGenerator =
analyses analyses
|> List.map (fun analysis -> |> List.map (fun analysis ->
let componentInfo = let componentInfo =
SynComponentInfo.SynComponentInfo ( SynComponentInfo.create analysis.CataTypeName
[], // TODO: better docstring
Some (SynTyparDecls.PostfixList (analysis.Typars @ orderedGenerics, [], range0)), |> SynComponentInfo.withDocString (
[], PreXmlDoc.create "Description of how to combine cases during a fold"
[ analysis.CataTypeName ],
// TODO: better docstring
PreXmlDoc.Create " Description of how to combine cases during a fold",
false,
None,
range0
) )
|> SynComponentInfo.withGenerics (analysis.Typars @ orderedGenerics)
let slots = analysis.UnionCases
let ourGenericName = generics.[analysis.GenericName.idText] |> List.map (fun case ->
let arity =
let flags = SynValInfo.SynValInfo (
{ case.Fields |> List.map (fun field -> [ SynArgInfo.Empty ]),
SynMemberFlags.IsInstance = true SynArgInfo.Empty
SynMemberFlags.IsDispatchSlot = true
SynMemberFlags.IsOverrideOrExplicitImpl = false
SynMemberFlags.IsFinal = false
SynMemberFlags.GetterOrSetterIsCompilerGenerated = false
SynMemberFlags.MemberKind = SynMemberKind.Member
}
analysis.UnionCases
|> List.map (fun case ->
let arity =
SynValInfo.SynValInfo (
case.Fields |> List.map (fun field -> [ SynArgInfo.Empty ]),
SynArgInfo.Empty
)
let ty =
(SynType.Var (ourGenericName, range0), List.rev case.FlattenedFields)
||> List.fold (fun acc field ->
let place : SynType =
match field.Description with
| FieldDescription.Self ty -> SynType.Var (generics.[getNameKeyUnion ty], range0)
| FieldDescription.ListSelf ty ->
SynType.CreateApp (
SynType.CreateLongIdent "list",
[ SynType.Var (generics.[getNameKeyUnion ty], range0) ],
true
)
| FieldDescription.NonRecursive ty ->
match field.RequiredGenerics with
| None -> ty
| Some generics ->
let generics =
generics
|> List.map (fun i ->
let (SynTyparDecl.SynTyparDecl (_, typar)) = analysis.Typars.[i]
SynType.Var (typar, range0)
)
SynType.App (
ty,
Some range0,
generics,
List.replicate (generics.Length - 1) range0,
Some range0,
false,
range0
)
SynType.Fun (
SynType.SignatureParameter (
[],
false,
field.FieldName |> Option.map Ident.lowerFirstLetter,
place,
range0
),
acc,
range0,
{
ArrowRange = range0
}
)
)
let slot =
SynValSig.SynValSig (
[],
case.CataMethodIdent,
SynValTyparDecls.SynValTyparDecls (None, true),
ty,
arity,
false,
false,
PreXmlDoc.Create $" How to operate on the %s{List.last(case.Match.LongIdent).idText} case",
None,
None,
range0,
{
EqualsRange = None
WithKeyword = None
InlineKeyword = None
LeadingKeyword = SynLeadingKeyword.Abstract range0
}
)
SynMemberDefn.AbstractSlot (
slot,
flags,
range0,
{
GetSetKeywords = None
}
) )
(SynType.var generics.[analysis.GenericName.idText], List.rev case.FlattenedFields)
||> List.fold (fun acc field ->
let place : SynType =
match field.Description with
| FieldDescription.Self ty -> SynType.var generics.[getNameKeyUnion ty]
| FieldDescription.ListSelf ty ->
SynType.var generics.[getNameKeyUnion ty] |> SynType.appPostfix "list"
| FieldDescription.NonRecursive ty ->
match field.RequiredGenerics with
| None -> ty
| Some generics ->
generics
|> List.map (fun i ->
let (SynTyparDecl.SynTyparDecl (_, typar)) = analysis.Typars.[i]
SynType.var typar
)
|> SynType.app' ty
let domain =
field.FieldName
|> Option.map Ident.lowerFirstLetter
|> SynType.signatureParamOfType place
acc |> SynType.funFromDomain domain
) )
|> SynMemberDefn.abstractMember
let repr = SynTypeDefnRepr.ObjectModel (SynTypeDefnKind.Unspecified, slots, range0) case.CataMethodIdent
None
SynTypeDefn.SynTypeDefn ( arity
componentInfo, (PreXmlDoc.create $"How to operate on the %s{List.last(case.Match.LongIdent).idText} case")
repr,
[],
None,
range0,
{
LeadingKeyword = SynTypeDefnLeadingKeyword.Type range0
EqualsRange = Some range0
WithKeyword = None
}
) )
|> SynTypeDefnRepr.interfaceType
|> SynTypeDefn.create componentInfo
) )
/// Build a record which contains one of every cata type. /// Build a record which contains one of every cata type.
@@ -727,28 +599,20 @@ module internal CataGenerator =
let nameForDoc = List.last(analysis.ParentTypeName).idText let nameForDoc = List.last(analysis.ParentTypeName).idText
let doc = let doc =
PreXmlDoc.Create $" How to perform a fold (catamorphism) over the type %s{nameForDoc}" PreXmlDoc.create $"How to perform a fold (catamorphism) over the type %s{nameForDoc}"
let artificialGenerics = generics |> List.map (fun v -> SynType.Var (v, range0)) let artificialGenerics = generics |> List.map SynType.var
let userInputGenerics = let userInputGenerics =
analysis.Typars analysis.Typars
|> List.map (fun (SynTyparDecl.SynTyparDecl (_, SynTypar.SynTypar (ident, _, _))) -> ident.idText) |> List.map (fun (SynTyparDecl.SynTyparDecl (_, SynTypar.SynTypar (ident, _, _))) -> ident.idText)
|> List.distinct |> List.distinct
|> List.map (fun i -> |> List.map (fun i -> SynType.var (SynTypar.SynTypar (Ident.Create i, TyparStaticReq.None, false)))
SynType.Var (SynTypar.SynTypar (Ident.Create i, TyparStaticReq.None, false), range0)
)
let ty = let ty =
SynType.App ( SynType.app'
SynType.LongIdent (SynLongIdent.CreateFromLongIdent [ analysis.CataTypeName ]), (SynType.createLongIdent [ analysis.CataTypeName ])
Some range0, (userInputGenerics @ artificialGenerics)
userInputGenerics @ artificialGenerics,
List.replicate (generics.Length - 1) range0,
Some range0,
false,
range0
)
SynField.SynField ( SynField.SynField (
[], [],
@@ -772,36 +636,18 @@ module internal CataGenerator =
|> List.map (fun (SynTyparDecl.SynTyparDecl (_, SynTypar.SynTypar (ident, _, _))) -> ident.idText) |> List.map (fun (SynTyparDecl.SynTyparDecl (_, SynTypar.SynTypar (ident, _, _))) -> ident.idText)
|> List.distinct |> List.distinct
|> List.map (fun i -> |> List.map (fun i ->
SynTyparDecl.SynTyparDecl ([], SynTypar.SynTypar (Ident.Create i, TyparStaticReq.None, false)) SynTyparDecl.SynTyparDecl ([], SynTypar.SynTypar (Ident.create i, TyparStaticReq.None, false))
) )
let genericsFromCata = let genericsFromCata =
generics |> List.map (fun ty -> SynTyparDecl.SynTyparDecl ([], ty)) generics |> List.map (fun ty -> SynTyparDecl.SynTyparDecl ([], ty))
let componentInfo = let componentInfo =
SynComponentInfo.SynComponentInfo ( SynComponentInfo.create cataName
[], |> SynComponentInfo.withGenerics (genericsFromUserInput @ genericsFromCata)
Some (SynTyparDecls.PostfixList (genericsFromUserInput @ genericsFromCata, [], range0)), |> SynComponentInfo.withDocString doc
[],
[ cataName ],
doc,
false,
None,
range0
)
SynTypeDefn.SynTypeDefn ( SynTypeDefnRepr.record fields |> SynTypeDefn.create componentInfo
componentInfo,
SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (None, fields, range0), range0),
[],
None,
range0,
{
LeadingKeyword = SynTypeDefnLeadingKeyword.Type range0
WithKeyword = None
EqualsRange = Some range0
}
)
let makeUnionAnalyses let makeUnionAnalyses
(cataVarName : Ident) (cataVarName : Ident)
@@ -852,7 +698,7 @@ module internal CataGenerator =
Accessibility = access Accessibility = access
StackName = StackName =
List.last(getName unionType).idText + "Stack" List.last(getName unionType).idText + "Stack"
|> Ident.Create |> Ident.create
|> Ident.lowerFirstLetter |> Ident.lowerFirstLetter
UnionCases = UnionCases =
cases cases
@@ -867,33 +713,30 @@ module internal CataGenerator =
InstructionName = instructionName InstructionName = instructionName
Fields = analysis Fields = analysis
CaseName = name CaseName = name
CataMethodName = CataMethodName = SynLongIdent.create (cataVarName :: unionTypeName @ [ unionCaseName ])
SynLongIdent.CreateFromLongIdent (cataVarName :: unionTypeName @ [ unionCaseName ])
CataMethodIdent = SynIdent.SynIdent (unionCaseName, None) CataMethodIdent = SynIdent.SynIdent (unionCaseName, None)
AssociatedInstruction = AssociatedInstruction =
SynLongIdent.CreateFromLongIdent [ Ident.Create "Instruction" ; instructionName ] SynLongIdent.create [ Ident.create "Instruction" ; instructionName ]
Match = SynLongIdent.CreateFromLongIdent (unionTypeName @ [ unionCaseName ]) Match = SynLongIdent.create (unionTypeName @ [ unionCaseName ])
} }
) )
AssociatedProcessInstruction = AssociatedProcessInstruction =
SynLongIdent.Create SynLongIdent.createS'
[ [
"Instruction" "Instruction"
// such jank! // such jank!
"Process__" + List.last(unionTypeName).idText "Process__" + List.last(unionTypeName).idText
] ]
ParentTypeName = getName unionType ParentTypeName = getName unionType
GenericName = getName unionType |> List.map _.idText |> String.concat "" |> Ident.Create GenericName = getName unionType |> List.map _.idText |> String.concat "" |> Ident.create
CataTypeName = List.last(getName unionType).idText + "CataCase" |> Ident.Create CataTypeName = List.last(getName unionType).idText + "CataCase" |> Ident.create
} }
) )
let callCataAndPushResult (resultStackName : Ident) (unionCase : RenderedUnionCase) : SynExpr = let callCataAndPushResult (resultStackName : Ident) (unionCase : RenderedUnionCase) : SynExpr =
(SynExpr.CreateLongIdent unionCase.CataMethodName, unionCase.FlattenedFields) (SynExpr.CreateLongIdent unionCase.CataMethodName, unionCase.FlattenedFields)
||> List.fold (fun body caseDesc -> SynExpr.CreateApp (body, SynExpr.CreateIdent caseDesc.ArgName)) ||> List.fold (fun body caseDesc -> SynExpr.applyFunction body (SynExpr.createIdent' caseDesc.ArgName))
|> SynExpr.pipeThroughFunction ( |> SynExpr.pipeThroughFunction (SynExpr.createLongIdent' (resultStackName :: [ Ident.Create "Add" ]))
SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent (resultStackName :: [ Ident.Create "Add" ]))
)
/// Create the state-machine matches which deal with receiving the instruction /// Create the state-machine matches which deal with receiving the instruction
/// to "process one of the user-specified DU cases, pushing recursion instructions onto /// to "process one of the user-specified DU cases, pushing recursion instructions onto
@@ -934,21 +777,20 @@ module internal CataGenerator =
listSelfArgs listSelfArgs
|> List.map (fun (i, argName, _) -> |> List.map (fun (i, argName, _) ->
i, i,
SynExpr.CreateParen ( SynExpr.paren (
SynExpr.CreateApp ( SynExpr.applyFunction
SynExpr.CreateLongIdent (SynLongIdent.Create [ "List" ; "length" ]), (SynExpr.createLongIdent [ "List" ; "length" ])
SynExpr.CreateIdent argName (SynExpr.createIdent' argName)
)
) )
) )
|> List.append ( |> List.append (
nonRecursiveArgs |> List.map (fun (i, arg, _) -> i, SynExpr.CreateIdent arg) nonRecursiveArgs |> List.map (fun (i, arg, _) -> i, SynExpr.createIdent' arg)
) )
|> List.sortBy fst |> List.sortBy fst
|> List.map snd |> List.map snd
|> SynExpr.CreateParenedTuple |> SynExpr.CreateParenedTuple
|> SynExpr.applyFunction (SynExpr.CreateLongIdent unionCase.AssociatedInstruction) |> SynExpr.applyFunction (SynExpr.CreateLongIdent unionCase.AssociatedInstruction)
|> SynExpr.CreateParen |> SynExpr.paren
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "instructions" ; "Add" ]) |> SynExpr.applyFunction (SynExpr.createLongIdent [ "instructions" ; "Add" ])
[ [
@@ -967,34 +809,30 @@ module internal CataGenerator =
DebugPointAtInOrTo.Yes range0, DebugPointAtInOrTo.Yes range0,
SeqExprOnly.SeqExprOnly false, SeqExprOnly.SeqExprOnly false,
true, true,
SynPat.CreateNamed (SynIdent.SynIdent (Ident.Create "elt", None)), SynPat.named "elt",
SynExpr.CreateIdent caseDesc.ArgName, SynExpr.createIdent' caseDesc.ArgName,
SynExpr.CreateApp ( SynExpr.applyFunction
SynExpr.CreateLongIdent (SynLongIdent.Create [ "instructions" ; "Add" ]), (SynExpr.createLongIdent [ "instructions" ; "Add" ])
SynExpr.CreateParen ( (SynExpr.paren (
SynExpr.CreateApp ( SynExpr.applyFunction
SynExpr.CreateLongIdent analysis.AssociatedProcessInstruction, (SynExpr.CreateLongIdent analysis.AssociatedProcessInstruction)
SynExpr.CreateIdentString "elt" (SynExpr.createIdent "elt")
) )),
)
),
range0 range0
) )
| Self synType -> | Self synType ->
// And push the instruction to process each recursive call // And push the instruction to process each recursive call
// onto the stack. // onto the stack.
yield yield
SynExpr.CreateLongIdent ( // TODO: use an AssociatedProcessInstruction instead
// TODO: use an AssociatedProcessInstruction instead SynExpr.createLongIdent
SynLongIdent.Create [
[ "Instruction"
"Instruction" // TODO wonky domain
// TODO wonky domain "Process" + "__" + List.last(getNameUnion(synType).Value).idText
"Process" + "__" + List.last(getNameUnion(synType).Value).idText ]
] |> SynExpr.applyTo (SynExpr.createIdent' caseDesc.ArgName)
) |> SynExpr.paren
|> SynExpr.applyTo (SynExpr.CreateIdent caseDesc.ArgName)
|> SynExpr.CreateParen
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "instructions" ; "Add" ]) |> SynExpr.applyFunction (SynExpr.createLongIdent [ "instructions" ; "Add" ])
] ]
|> SynExpr.CreateSequential |> SynExpr.CreateSequential
@@ -1038,14 +876,14 @@ module internal CataGenerator =
) )
) )
let bodyMatch = SynExpr.CreateMatch (SynExpr.CreateIdentString "x", matchCases) let bodyMatch = SynExpr.createMatch (SynExpr.createIdent "x") matchCases
SynMatchClause.SynMatchClause ( SynMatchClause.SynMatchClause (
SynPat.LongIdent ( SynPat.LongIdent (
analysis.AssociatedProcessInstruction, analysis.AssociatedProcessInstruction,
None, None,
None, None,
SynArgPats.create [ Ident.Create "x" ], SynArgPats.create [ Ident.create "x" ],
None, None,
range0 range0
), ),
@@ -1119,22 +957,20 @@ module internal CataGenerator =
// TODO: this is jank // TODO: this is jank
let stackName = inputStacks.[List.last(getNameUnion(synType).Value).idText] let stackName = inputStacks.[List.last(getNameUnion(synType).Value).idText]
SynExpr.minusN (SynLongIdent.CreateFromLongIdent [ stackName ; Ident.Create "Count" ]) 1 SynExpr.minusN (SynLongIdent.create [ stackName ; Ident.create "Count" ]) 1
|> SynExpr.CreateParen |> SynExpr.paren
|> SynExpr.applyFunction ( |> SynExpr.applyFunction (
SynExpr.createLongIdent' [ stackName ; Ident.Create "RemoveAt" ] SynExpr.createLongIdent' [ stackName ; Ident.create "RemoveAt" ]
) )
|> SynExpr.createLet |> SynExpr.createLet
[ [
SynExpr.DotIndexedGet ( SynExpr.DotIndexedGet (
SynExpr.CreateIdent stackName, SynExpr.createIdent' stackName,
SynExpr.minusN SynExpr.minusN (SynLongIdent.create [ stackName ; Ident.create "Count" ]) 1,
(SynLongIdent.CreateFromLongIdent [ stackName ; Ident.Create "Count" ])
1,
range0, range0,
range0 range0
) )
|> SynBinding.basic (SynLongIdent.CreateFromLongIdent [ field.ArgName ]) [] |> SynBinding.basic (SynLongIdent.createI field.ArgName) []
] ]
|> Some |> Some
| ListSelf synType -> | ListSelf synType ->
@@ -1147,20 +983,18 @@ module internal CataGenerator =
SynExpr.For ( SynExpr.For (
DebugPointAtFor.Yes range0, DebugPointAtFor.Yes range0,
DebugPointAtInOrTo.Yes range0, DebugPointAtInOrTo.Yes range0,
Ident.Create "i", Ident.create "i",
Some range0, Some range0,
SynExpr.minusN SynExpr.minusN (SynLongIdent.create [ stackName ; Ident.create "Count" ]) 1,
(SynLongIdent.CreateFromLongIdent [ stackName ; Ident.Create "Count" ])
1,
false, false,
SynExpr.minus SynExpr.minus
(SynLongIdent.CreateFromLongIdent [ stackName ; Ident.Create "Count" ]) (SynLongIdent.create [ stackName ; Ident.create "Count" ])
(SynExpr.CreateIdent field.ArgName), (SynExpr.createIdent' field.ArgName),
SynExpr.YieldOrReturn ( SynExpr.YieldOrReturn (
(true, false), (true, false),
SynExpr.DotIndexedGet ( SynExpr.DotIndexedGet (
SynExpr.CreateIdent stackName, SynExpr.createIdent' stackName,
SynExpr.CreateIdentString "i", SynExpr.createIdent "i",
range0, range0,
range0 range0
), ),
@@ -1170,44 +1004,36 @@ module internal CataGenerator =
), ),
range0 range0
) )
|> SynExpr.applyFunction (SynExpr.CreateIdentString "seq") |> SynExpr.applyFunction (SynExpr.createIdent "seq")
|> SynExpr.pipeThroughFunction (SynExpr.createLongIdent [ "Seq" ; "toList" ]) |> SynExpr.pipeThroughFunction (SynExpr.createLongIdent [ "Seq" ; "toList" ])
|> SynBinding.basic (SynLongIdent.CreateFromLongIdent [ field.ArgName ]) [] |> SynBinding.basic (SynLongIdent.createI field.ArgName) []
let shadowedIdent = Ident.Create (field.ArgName.idText + "_len") let shadowedIdent = Ident.create (field.ArgName.idText + "_len")
[ [
SynExpr.minus SynExpr.minus
(SynLongIdent.CreateFromLongIdent [ stackName ; Ident.Create "Count" ]) (SynLongIdent.create [ stackName ; Ident.create "Count" ])
(SynExpr.CreateIdent shadowedIdent) (SynExpr.createIdent' shadowedIdent)
SynExpr.CreateIdent shadowedIdent SynExpr.createIdent' shadowedIdent
] ]
|> SynExpr.CreateParenedTuple |> SynExpr.CreateParenedTuple
|> SynExpr.applyFunction ( |> SynExpr.applyFunction (
SynExpr.createLongIdent' [ stackName ; Ident.Create "RemoveRange" ] SynExpr.createLongIdent' [ stackName ; Ident.create "RemoveRange" ]
) )
|> SynExpr.createLet [ vals ] |> SynExpr.createLet [ vals ]
|> SynExpr.createLet |> SynExpr.createLet
[ [
SynBinding.basic SynBinding.basic
(SynLongIdent.CreateFromLongIdent [ shadowedIdent ]) (SynLongIdent.createI shadowedIdent)
[] []
(SynExpr.CreateIdent field.ArgName) (SynExpr.createIdent' field.ArgName)
] ]
|> Some |> Some
) )
SynMatchClause.SynMatchClause ( (populateArgs @ [ callCataAndPushResult analysis.StackName unionCase ])
pat, |> SynExpr.CreateSequential
None, |> SynMatchClause.create pat
SynExpr.CreateSequential (populateArgs @ [ callCataAndPushResult analysis.StackName unionCase ]),
range0,
DebugPointAtTarget.Yes,
{
ArrowRange = Some range0
BarRange = Some range0
}
)
) )
) )
@@ -1217,60 +1043,29 @@ module internal CataGenerator =
|> List.collect _.Typars |> List.collect _.Typars
|> List.map (fun (SynTyparDecl.SynTyparDecl (_, SynTypar.SynTypar (ident, _, _))) -> ident.idText) |> List.map (fun (SynTyparDecl.SynTyparDecl (_, SynTypar.SynTypar (ident, _, _))) -> ident.idText)
|> List.distinct |> List.distinct
|> List.map (fun i -> SynTypar.SynTypar (Ident.Create i, TyparStaticReq.None, false)) |> List.map (fun i -> SynTypar.SynTypar (Ident.create i, TyparStaticReq.None, false))
let instructionsArrType = let instructionsArrType =
if not userSuppliedGenerics.IsEmpty then if not userSuppliedGenerics.IsEmpty then
SynType.App ( userSuppliedGenerics |> List.map SynType.var |> SynType.app "Instruction"
SynType.CreateLongIdent "Instruction",
Some range0,
userSuppliedGenerics |> List.map (fun x -> SynType.Var (x, range0)),
List.replicate (userSuppliedGenerics.Length - 1) range0,
Some range0,
false,
range0
)
else else
SynType.CreateLongIdent "Instruction" SynType.named "Instruction"
let cataGenerics = let cataGenerics =
[ [
for generic in userSuppliedGenerics do for generic in userSuppliedGenerics do
yield SynType.Var (generic, range0) yield SynType.var generic
for case in analysis do for case in analysis do
yield SynType.Var (SynTypar.SynTypar (case.GenericName, TyparStaticReq.None, false), range0) yield SynType.var (SynTypar.SynTypar (case.GenericName, TyparStaticReq.None, false))
] ]
let args = let args =
[ [
SynPat.CreateParen ( SynPat.namedI cataVarName
SynPat.CreateTyped ( |> SynPat.annotateType (SynType.app' (SynType.createLongIdent [ cataTypeName ]) cataGenerics)
SynPat.CreateNamed cataVarName,
SynType.App ( SynPat.named "instructions"
SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ cataTypeName ]), |> SynPat.annotateType (SynType.app "ResizeArray" [ instructionsArrType ])
Some range0,
cataGenerics,
List.replicate (cataGenerics.Length - 1) range0,
Some range0,
false,
range0
)
)
)
SynPat.CreateParen (
SynPat.CreateTyped (
SynPat.CreateNamed (Ident.Create "instructions"),
SynType.App (
SynType.CreateLongIdent "ResizeArray",
Some range0,
[ instructionsArrType ],
[],
Some range0,
false,
range0
)
)
)
] ]
let baseMatchClauses = analysis |> List.map createBaseMatchClause let baseMatchClauses = analysis |> List.map createBaseMatchClause
@@ -1278,39 +1073,35 @@ module internal CataGenerator =
let recMatchClauses = createRecursiveMatchClauses analysis let recMatchClauses = createRecursiveMatchClauses analysis
let matchStatement = let matchStatement =
SynExpr.CreateMatch (SynExpr.CreateIdentString "currentInstruction", baseMatchClauses @ recMatchClauses) SynExpr.createMatch (SynExpr.createIdent "currentInstruction") (baseMatchClauses @ recMatchClauses)
let body = let body =
[ [
SynExpr.CreateApp ( SynExpr.applyFunction
SynExpr.createLongIdent [ "instructions" ; "RemoveAt" ], (SynExpr.createLongIdent [ "instructions" ; "RemoveAt" ])
SynExpr.CreateParen (SynExpr.minusN (SynLongIdent.Create [ "instructions" ; "Count" ]) 1) (SynExpr.paren (SynExpr.minusN (SynLongIdent.createS' [ "instructions" ; "Count" ]) 1))
)
matchStatement matchStatement
] ]
|> SynExpr.CreateSequential |> SynExpr.CreateSequential
|> SynExpr.createLet |> SynExpr.createLet
[ [
SynExpr.DotIndexedGet ( SynExpr.DotIndexedGet (
SynExpr.CreateIdentString "instructions", SynExpr.createIdent "instructions",
SynExpr.minusN (SynLongIdent.Create [ "instructions" ; "Count" ]) 1, SynExpr.minusN (SynLongIdent.createS' [ "instructions" ; "Count" ]) 1,
range0, range0,
range0 range0
) )
|> SynBinding.basic (SynLongIdent.CreateString "currentInstruction") [] |> SynBinding.basic (SynLongIdent.createS "currentInstruction") []
] ]
let body = let body =
SynExpr.CreateSequential SynExpr.CreateSequential
[ [
SynExpr.While ( SynExpr.createWhile
DebugPointAtWhile.Yes range0, (SynExpr.greaterThan
SynExpr.greaterThan (SynExpr.CreateConst 0)
(SynExpr.CreateConst (SynConst.Int32 0)) (SynExpr.createLongIdent [ "instructions" ; "Count" ]))
(SynExpr.createLongIdent [ "instructions" ; "Count" ]), body
body,
range0
)
SynExpr.CreateTuple ( SynExpr.CreateTuple (
analysis analysis
|> List.map (fun unionAnalysis -> [ unionAnalysis.StackName ] |> SynExpr.createLongIdent') |> List.map (fun unionAnalysis -> [ unionAnalysis.StackName ] |> SynExpr.createLongIdent')
@@ -1324,25 +1115,22 @@ module internal CataGenerator =
|> SynExpr.createLet |> SynExpr.createLet
[ [
SynExpr.TypeApp ( SynExpr.TypeApp (
SynExpr.CreateIdent (Ident.Create "ResizeArray"), SynExpr.createIdent "ResizeArray",
range0, range0,
[ [
SynType.Var ( SynType.var (SynTypar.SynTypar (unionCase.GenericName, TyparStaticReq.None, false))
SynTypar.SynTypar (unionCase.GenericName, TyparStaticReq.None, false),
range0
)
], ],
[], [],
Some range0, Some range0,
range0, range0,
range0 range0
) )
|> SynExpr.applyTo (SynExpr.CreateConst SynConst.Unit) |> SynExpr.applyTo (SynExpr.CreateConst ())
|> SynBinding.basic (SynLongIdent.CreateFromLongIdent [ unionCase.StackName ]) [] |> SynBinding.basic (SynLongIdent.createI unionCase.StackName) []
] ]
) )
SynBinding.basic (SynLongIdent.CreateString "loop") args body SynBinding.basic (SynLongIdent.createS "loop") args body
|> SynBinding.withAccessibility (Some (SynAccess.Private range0)) |> SynBinding.withAccessibility (Some (SynAccess.Private range0))
let createModule let createModule
@@ -1355,22 +1143,20 @@ module internal CataGenerator =
= =
let cataName = let cataName =
match cataName |> SynExpr.stripOptionalParen with match cataName |> SynExpr.stripOptionalParen with
| SynExpr.Const (SynConst.String (name, _, _), _) -> Ident.Create name | SynExpr.Const (SynConst.String (name, _, _), _) -> Ident.create name
| _ -> failwith "Cata name in attribute must be literally a string, sorry" | _ -> failwith "Cata name in attribute must be literally a string, sorry"
let parentName = List.last (getName taggedType) |> _.idText let parentName = List.last (getName taggedType) |> _.idText
let moduleName : LongIdent = parentName + "Cata" |> Ident.Create |> List.singleton let moduleName = parentName + "Cata" |> Ident.create
let attribs = [ SynAttributeList.Create (SynAttribute.RequireQualifiedAccess ()) ]
let modInfo = let modInfo =
SynComponentInfo.Create ( SynComponentInfo.create (parentName + "Cata" |> Ident.create)
moduleName, |> SynComponentInfo.withDocString (
attributes = attribs, PreXmlDoc.Create $" Methods to perform a catamorphism over the type %s{parentName}"
xmldoc = PreXmlDoc.Create $" Methods to perform a catamorphism over the type %s{parentName}"
) )
|> SynComponentInfo.addAttributes [ SynAttribute.RequireQualifiedAccess () ]
let cataVarName = Ident.Create "cata" let cataVarName = Ident.create "cata"
let analysis = makeUnionAnalyses cataVarName allRecordTypes allUnionTypes let analysis = makeUnionAnalyses cataVarName allRecordTypes allUnionTypes
let allTypars = let allTypars =
@@ -1378,9 +1164,9 @@ module internal CataGenerator =
|> List.map (fun unionType -> |> List.map (fun unionType ->
List.last (getName unionType) List.last (getName unionType)
|> fun x -> x.idText + "Ret" |> fun x -> x.idText + "Ret"
|> Ident.Create |> Ident.create
|> fun x -> SynTypar.SynTypar (x, TyparStaticReq.None, false) |> fun x -> SynTypar.SynTypar (x, TyparStaticReq.None, false)
|> fun x -> SynType.Var (x, range0) |> SynType.var
) )
let userProvidedGenerics = let userProvidedGenerics =
@@ -1389,7 +1175,7 @@ module internal CataGenerator =
|> List.map (fun (SynTyparDecl (_, SynTypar.SynTypar (ident, _, _))) -> ident.idText) |> List.map (fun (SynTyparDecl (_, SynTypar.SynTypar (ident, _, _))) -> ident.idText)
|> List.distinct |> List.distinct
|> List.map (fun x -> |> List.map (fun x ->
SynTyparDecl.SynTyparDecl ([], SynTypar.SynTypar (Ident.Create x, TyparStaticReq.None, false)) SynTyparDecl.SynTyparDecl ([], SynTypar.SynTypar (Ident.create x, TyparStaticReq.None, false))
) )
let runFunctions = let runFunctions =
@@ -1405,8 +1191,8 @@ module internal CataGenerator =
let loopFunction = createLoopFunction cataName cataVarName analysis let loopFunction = createLoopFunction cataName cataVarName analysis
let recordDoc = let recordDoc =
PreXmlDoc.Create PreXmlDoc.create
$" Specifies how to perform a fold (catamorphism) over the type %s{parentName} and its friends." $"Specifies how to perform a fold (catamorphism) over the type %s{parentName} and its friends."
let cataRecord = let cataRecord =
SynModuleDecl.Types ([ createCataRecord cataName recordDoc analysis ], range0) SynModuleDecl.Types ([ createCataRecord cataName recordDoc analysis ], range0)

View File

@@ -213,11 +213,7 @@ module internal HttpClientGenerator =
let argType = let argType =
if arg.IsOptional then if arg.IsOptional then
SynType.CreateApp ( SynType.appPostfix "option" arg.Type
SynType.CreateLongIdent (SynLongIdent.CreateString "option"),
[ arg.Type ],
isPostfix = true
)
else else
arg.Type arg.Type
@@ -241,7 +237,7 @@ module internal HttpClientGenerator =
let thisIdent = if variableHeaders.IsEmpty then "_" else "this" let thisIdent = if variableHeaders.IsEmpty then "_" else "this"
SynPat.LongIdent ( SynPat.LongIdent (
SynLongIdent.CreateFromLongIdent [ Ident.Create thisIdent ; info.Identifier ], SynLongIdent.create [ Ident.create thisIdent ; info.Identifier ],
None, None,
None, None,
argPats, argPats,
@@ -271,7 +267,7 @@ module internal HttpClientGenerator =
"Replace" "Replace"
(SynExpr.CreateParenedTuple (SynExpr.CreateParenedTuple
[ [
SynExpr.CreateConstString ("{" + substituteId + "}") SynExpr.CreateConst ("{" + substituteId + "}")
SynExpr.callMethod "ToString" (SynExpr.CreateIdent varName) SynExpr.callMethod "ToString" (SynExpr.CreateIdent varName)
|> SynExpr.pipeThroughFunction ( |> SynExpr.pipeThroughFunction (
SynExpr.createLongIdent [ "System" ; "Web" ; "HttpUtility" ; "UrlEncode" ] SynExpr.createLongIdent [ "System" ; "Web" ; "HttpUtility" ; "UrlEncode" ]
@@ -314,30 +310,27 @@ module internal HttpClientGenerator =
let urlSeparator = let urlSeparator =
// apparent Myriad bug: `IndexOf '?'` gets formatted as `IndexOf ?` which is clearly wrong // apparent Myriad bug: `IndexOf '?'` gets formatted as `IndexOf ?` which is clearly wrong
let questionMark = let questionMark =
SynExpr.CreateConst (SynConst.Int32 63) SynExpr.CreateConst 63
|> SynExpr.applyFunction (SynExpr.CreateIdentString "char") |> SynExpr.applyFunction (SynExpr.createIdent "char")
|> SynExpr.CreateParen |> SynExpr.paren
let containsQuestion = let containsQuestion =
info.UrlTemplate info.UrlTemplate
|> SynExpr.callMethodArg "IndexOf" questionMark |> SynExpr.callMethodArg "IndexOf" questionMark
|> SynExpr.greaterThanOrEqual (SynExpr.CreateConst (SynConst.Int32 0)) |> SynExpr.greaterThanOrEqual (SynExpr.CreateConst 0)
SynExpr.ifThenElse SynExpr.ifThenElse containsQuestion (SynExpr.CreateConst "?") (SynExpr.CreateConst "&")
containsQuestion |> SynExpr.paren
(SynExpr.CreateConst (SynConst.CreateString "?"))
(SynExpr.CreateConst (SynConst.CreateString "&"))
|> SynExpr.CreateParen
let prefix = let prefix =
SynExpr.CreateIdent firstValueId SynExpr.createIdent' firstValueId
|> SynExpr.toString firstValue.Type |> SynExpr.toString firstValue.Type
|> SynExpr.CreateParen |> SynExpr.paren
|> SynExpr.pipeThroughFunction ( |> SynExpr.pipeThroughFunction (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "Web" ; "HttpUtility" ; "UrlEncode" ]) SynExpr.createLongIdent [ "System" ; "Web" ; "HttpUtility" ; "UrlEncode" ]
) )
|> SynExpr.CreateParen |> SynExpr.paren
|> SynExpr.plus (SynExpr.plus urlSeparator (SynExpr.CreateConstString (firstKey + "="))) |> SynExpr.plus (SynExpr.plus urlSeparator (SynExpr.CreateConst (firstKey + "=")))
(prefix, queryParams) (prefix, queryParams)
||> List.fold (fun uri (paramKey, paramValue) -> ||> List.fold (fun uri (paramKey, paramValue) ->
@@ -346,16 +339,16 @@ module internal HttpClientGenerator =
| None -> failwith "Unable to get parameter variable name from anonymous parameter" | None -> failwith "Unable to get parameter variable name from anonymous parameter"
| Some id -> id | Some id -> id
SynExpr.toString paramValue.Type (SynExpr.CreateIdent paramValueId) SynExpr.toString paramValue.Type (SynExpr.createIdent' paramValueId)
|> SynExpr.CreateParen |> SynExpr.paren
|> SynExpr.pipeThroughFunction ( |> SynExpr.pipeThroughFunction (
SynExpr.createLongIdent [ "System" ; "Web" ; "HttpUtility" ; "UrlEncode" ] SynExpr.createLongIdent [ "System" ; "Web" ; "HttpUtility" ; "UrlEncode" ]
) )
|> SynExpr.CreateParen |> SynExpr.paren
|> SynExpr.plus (SynExpr.plus uri (SynExpr.CreateConstString ("&" + paramKey + "="))) |> SynExpr.plus (SynExpr.plus uri (SynExpr.CreateConst ("&" + paramKey + "=")))
) )
|> SynExpr.plus requestUriTrailer |> SynExpr.plus requestUriTrailer
|> SynExpr.CreateParen |> SynExpr.paren
let requestUri = let requestUri =
let uriIdent = SynExpr.createLongIdent [ "System" ; "Uri" ] let uriIdent = SynExpr.createLongIdent [ "System" ; "Uri" ]
@@ -370,20 +363,20 @@ module internal HttpClientGenerator =
match info.BaseAddress with match info.BaseAddress with
| None -> | None ->
[ [
SynExpr.CreateApp (SynExpr.CreateIdentString "nameof", SynExpr.CreateParen baseAddress) SynExpr.applyFunction (SynExpr.createIdent "nameof") (SynExpr.paren baseAddress)
SynExpr.CreateConstString SynExpr.CreateConst
"No base address was supplied on the type, and no BaseAddress was on the HttpClient." "No base address was supplied on the type, and no BaseAddress was on the HttpClient."
] ]
|> SynExpr.CreateParenedTuple |> SynExpr.CreateParenedTuple
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "System" ; "ArgumentNullException" ]) |> SynExpr.applyFunction (SynExpr.createLongIdent [ "System" ; "ArgumentNullException" ])
|> SynExpr.CreateParen |> SynExpr.paren
|> SynExpr.applyFunction (SynExpr.CreateIdentString "raise") |> SynExpr.applyFunction (SynExpr.createIdent "raise")
| Some expr -> SynExpr.CreateApp (uriIdent, expr) | Some expr -> SynExpr.applyFunction uriIdent expr
) )
SynMatchClause.Create (SynPat.CreateNamed (Ident.Create "v"), None, SynExpr.CreateIdentString "v") SynMatchClause.Create (SynPat.named "v", None, SynExpr.createIdent "v")
] ]
|> SynExpr.createMatch baseAddress |> SynExpr.createMatch baseAddress
|> SynExpr.CreateParen |> SynExpr.paren
SynExpr.App ( SynExpr.App (
ExprAtomicFlag.Atomic, ExprAtomicFlag.Atomic,
@@ -436,56 +429,43 @@ module internal HttpClientGenerator =
let httpReqMessageConstructor = let httpReqMessageConstructor =
[ [
SynExpr.equals SynExpr.equals
(SynExpr.CreateIdentString "Method") (SynExpr.createIdent "Method")
(SynExpr.createLongIdent (SynExpr.createLongIdent
[ "System" ; "Net" ; "Http" ; "HttpMethod" ; httpMethodString info.HttpMethod ]) [ "System" ; "Net" ; "Http" ; "HttpMethod" ; httpMethodString info.HttpMethod ])
SynExpr.equals (SynExpr.CreateIdentString "RequestUri") (SynExpr.CreateIdentString "uri") SynExpr.equals (SynExpr.createIdent "RequestUri") (SynExpr.createIdent "uri")
] ]
|> SynExpr.CreateParenedTuple |> SynExpr.CreateTuple
let returnExpr = let returnExpr =
match info.TaskReturnType with match info.TaskReturnType with
| HttpResponseMessage -> SynExpr.CreateIdentString "response" | HttpResponseMessage -> SynExpr.createIdent "response"
| String -> SynExpr.CreateIdentString "responseString" | String -> SynExpr.createIdent "responseString"
| Stream -> SynExpr.CreateIdentString "responseStream" | Stream -> SynExpr.createIdent "responseStream"
| RestEaseResponseType contents -> | RestEaseResponseType contents ->
let deserialiser = let deserialiser =
SynExpr.CreateLambda ( JsonParseGenerator.parseNode
[ SynPat.CreateConst SynConst.Unit ], None
SynExpr.CreateParen ( JsonParseGenerator.JsonParseOption.None
JsonParseGenerator.parseNode contents
None (SynExpr.createIdent "jsonNode")
JsonParseGenerator.JsonParseOption.None |> SynExpr.paren
contents |> SynExpr.createThunk
(SynExpr.CreateIdentString "jsonNode")
)
)
// new RestEase.Response (content : string, response : HttpResponseMessage, deserialiser : unit -> 'T) // new RestEase.Response (content : string, response : HttpResponseMessage, deserialiser : unit -> 'T)
SynExpr.New ( SynExpr.createNew
false, (SynType.app' (SynType.createLongIdent' [ "RestEase" ; "Response" ]) [ SynType.Anon range0 ])
SynType.App ( (SynExpr.CreateTuple
SynType.CreateLongIdent (SynLongIdent.Create [ "RestEase" ; "Response" ]),
Some range0,
[ SynType.Anon range0 ],
[],
Some range0,
false,
range0
),
SynExpr.CreateParenedTuple
[ [
SynExpr.CreateIdentString "responseString" SynExpr.createIdent "responseString"
SynExpr.CreateIdentString "response" SynExpr.createIdent "response"
SynExpr.CreateParen deserialiser deserialiser
], ])
range0
)
| retType -> | retType ->
JsonParseGenerator.parseNode JsonParseGenerator.parseNode
None None
JsonParseGenerator.JsonParseOption.None JsonParseGenerator.JsonParseOption.None
retType retType
(SynExpr.CreateIdentString "jsonNode") (SynExpr.createIdent "jsonNode")
let handleBodyParams = let handleBodyParams =
match bodyParam with match bodyParam with
@@ -498,20 +478,15 @@ module internal HttpClientGenerator =
[ [
Let ( Let (
"queryParams", "queryParams",
SynExpr.New ( SynExpr.createNew
false, (SynType.createLongIdent'
SynType.CreateLongIdent ( [ "System" ; "Net" ; "Http" ; (bodyParamType : BodyParamMethods).ToString () ])
SynLongIdent.Create (SynExpr.createIdent' bodyParamName)
[ "System" ; "Net" ; "Http" ; (bodyParamType : BodyParamMethods).ToString () ]
),
SynExpr.CreateParen (SynExpr.CreateIdent bodyParamName),
range0
)
) )
Do ( Do (
SynExpr.LongIdentSet ( SynExpr.LongIdentSet (
SynLongIdent.Create [ "httpMessage" ; "Content" ], SynLongIdent.createS' [ "httpMessage" ; "Content" ],
SynExpr.CreateIdentString "queryParams", SynExpr.createIdent "queryParams",
range0 range0
) )
) )
@@ -520,8 +495,8 @@ module internal HttpClientGenerator =
[ [
Do ( Do (
SynExpr.LongIdentSet ( SynExpr.LongIdentSet (
SynLongIdent.Create [ "httpMessage" ; "Content" ], SynLongIdent.createS' [ "httpMessage" ; "Content" ],
SynExpr.CreateIdent bodyParamName, SynExpr.createIdent' bodyParamName,
range0 range0
) )
) )
@@ -530,38 +505,27 @@ module internal HttpClientGenerator =
[ [
Let ( Let (
"queryParams", "queryParams",
SynExpr.New ( SynExpr.createNew
false, (SynType.createLongIdent' [ "System" ; "Net" ; "Http" ; "StringContent" ])
SynType.CreateLongIdent ( (SynExpr.createIdent' bodyParamName
SynLongIdent.Create [ "System" ; "Net" ; "Http" ; "StringContent" ] |> SynExpr.pipeThroughFunction (JsonSerializeGenerator.serializeNode ty)
), |> SynExpr.pipeThroughFunction (
SynExpr.CreateParen ( SynExpr.createLambda
SynExpr.CreateIdent bodyParamName "node"
|> SynExpr.pipeThroughFunction (JsonSerializeGenerator.serializeNode ty) (SynExpr.ifThenElse
|> SynExpr.pipeThroughFunction ( (SynExpr.applyFunction
SynExpr.createLambda (SynExpr.createIdent "isNull")
"node" (SynExpr.createIdent "node"))
(SynExpr.ifThenElse (SynExpr.applyFunction
(SynExpr.CreateApp ( (SynExpr.createLongIdent [ "node" ; "ToJsonString" ])
SynExpr.CreateIdentString "isNull", (SynExpr.CreateConst ()))
SynExpr.CreateIdentString "node" (SynExpr.CreateConst "null"))
)) ))
(SynExpr.CreateApp (
SynExpr.CreateLongIdent (
SynLongIdent.Create [ "node" ; "ToJsonString" ]
),
SynExpr.CreateConst SynConst.Unit
))
(SynExpr.CreateConst (SynConst.CreateString "null")))
)
),
range0
)
) )
Do ( Do (
SynExpr.LongIdentSet ( SynExpr.LongIdentSet (
SynLongIdent.Create [ "httpMessage" ; "Content" ], SynLongIdent.createS' [ "httpMessage" ; "Content" ],
SynExpr.CreateIdent (Ident.Create "queryParams"), SynExpr.createIdent "queryParams",
range0 range0
) )
) )
@@ -572,10 +536,9 @@ module internal HttpClientGenerator =
LetBang ( LetBang (
"responseString", "responseString",
SynExpr.awaitTask ( SynExpr.awaitTask (
SynExpr.CreateApp ( SynExpr.applyFunction
SynExpr.createLongIdent [ "response" ; "Content" ; "ReadAsStringAsync" ], (SynExpr.createLongIdent [ "response" ; "Content" ; "ReadAsStringAsync" ])
SynExpr.CreateIdentString "ct" (SynExpr.createIdent "ct")
)
) )
) )
@@ -583,10 +546,9 @@ module internal HttpClientGenerator =
LetBang ( LetBang (
"responseStream", "responseStream",
SynExpr.awaitTask ( SynExpr.awaitTask (
SynExpr.CreateApp ( SynExpr.applyFunction
SynExpr.createLongIdent [ "response" ; "Content" ; "ReadAsStreamAsync" ], (SynExpr.createLongIdent [ "response" ; "Content" ; "ReadAsStreamAsync" ])
SynExpr.CreateIdentString "ct" (SynExpr.createIdent "ct")
)
) )
) )
@@ -594,47 +556,39 @@ module internal HttpClientGenerator =
LetBang ( LetBang (
"jsonNode", "jsonNode",
SynExpr.awaitTask ( SynExpr.awaitTask (
SynExpr.CreateApp ( SynExpr.applyFunction
SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ; "ParseAsync" ], (SynExpr.createLongIdent
SynExpr.CreateParenedTuple [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ; "ParseAsync" ])
(SynExpr.CreateParenedTuple
[ [
SynExpr.CreateIdentString "responseStream" SynExpr.createIdent "responseStream"
SynExpr.equals SynExpr.equals (SynExpr.createIdent "cancellationToken") (SynExpr.createIdent "ct")
(SynExpr.CreateIdentString "cancellationToken") ])
(SynExpr.CreateIdentString "ct")
]
)
) )
) )
let setVariableHeaders = let setVariableHeaders =
variableHeaders variableHeaders
|> List.map (fun (headerName, callToGetValue) -> |> List.map (fun (headerName, callToGetValue) ->
Do ( [
SynExpr.CreateApp ( headerName
SynExpr.createLongIdent [ "httpMessage" ; "Headers" ; "Add" ], SynExpr.applyFunction
SynExpr.CreateParenedTuple (SynExpr.createLongIdent'
[ [ Ident.Create "this" ; callToGetValue ; Ident.Create "ToString" ])
headerName (SynExpr.CreateConst ())
SynExpr.CreateApp ( ]
SynExpr.createLongIdent' |> SynExpr.CreateParenedTuple
[ Ident.Create "this" ; callToGetValue ; Ident.Create "ToString" ], |> SynExpr.applyFunction (SynExpr.createLongIdent [ "httpMessage" ; "Headers" ; "Add" ])
SynExpr.CreateConst SynConst.Unit |> Do
)
]
)
)
) )
let setConstantHeaders = let setConstantHeaders =
constantHeaders constantHeaders
|> List.map (fun (headerName, headerValue) -> |> List.map (fun (headerName, headerValue) ->
Do ( SynExpr.applyFunction
SynExpr.CreateApp ( (SynExpr.createLongIdent [ "httpMessage" ; "Headers" ; "Add" ])
SynExpr.createLongIdent [ "httpMessage" ; "Headers" ; "Add" ], (SynExpr.CreateParenedTuple [ headerName ; headerValue ])
SynExpr.CreateParenedTuple [ headerName ; headerValue ] |> Do
)
)
) )
[ [
@@ -643,14 +597,9 @@ module internal HttpClientGenerator =
yield yield
Use ( Use (
"httpMessage", "httpMessage",
SynExpr.New ( SynExpr.createNew
false, (SynType.createLongIdent' [ "System" ; "Net" ; "Http" ; "HttpRequestMessage" ])
SynType.CreateLongIdent ( httpReqMessageConstructor
SynLongIdent.Create [ "System" ; "Net" ; "Http" ; "HttpRequestMessage" ]
),
httpReqMessageConstructor,
range0
)
) )
yield! handleBodyParams yield! handleBodyParams
@@ -662,21 +611,19 @@ module internal HttpClientGenerator =
LetBang ( LetBang (
"response", "response",
SynExpr.awaitTask ( SynExpr.awaitTask (
SynExpr.CreateApp ( SynExpr.applyFunction
SynExpr.createLongIdent [ "client" ; "SendAsync" ], (SynExpr.createLongIdent [ "client" ; "SendAsync" ])
SynExpr.CreateParenedTuple (SynExpr.CreateParenedTuple
[ SynExpr.CreateIdentString "httpMessage" ; SynExpr.CreateIdentString "ct" ] [ SynExpr.createIdent "httpMessage" ; SynExpr.createIdent "ct" ])
)
) )
) )
if info.EnsureSuccessHttpCode then if info.EnsureSuccessHttpCode then
yield yield
Let ( Let (
"response", "response",
SynExpr.CreateApp ( SynExpr.applyFunction
SynExpr.createLongIdent [ "response" ; "EnsureSuccessStatusCode" ], (SynExpr.createLongIdent [ "response" ; "EnsureSuccessStatusCode" ])
SynExpr.CreateConst SynConst.Unit (SynExpr.CreateConst ())
)
) )
match info.TaskReturnType with match info.TaskReturnType with
| HttpResponseMessage -> () | HttpResponseMessage -> ()
@@ -691,7 +638,7 @@ module internal HttpClientGenerator =
yield jsonNode yield jsonNode
] ]
|> SynExpr.createCompExpr "async" returnExpr |> SynExpr.createCompExpr "async" returnExpr
|> SynExpr.startAsTask (SynLongIdent.CreateFromLongIdent [ cancellationTokenArg ]) |> SynExpr.startAsTask (SynLongIdent.createI cancellationTokenArg)
SynBinding.SynBinding ( SynBinding.SynBinding (
None, None,
@@ -904,15 +851,11 @@ module internal HttpClientGenerator =
SynValInfo.SynValInfo ([ [ SynArgInfo.Empty ] ; [] ], SynArgInfo.Empty), SynValInfo.SynValInfo ([ [ SynArgInfo.Empty ] ; [] ], SynArgInfo.Empty),
None None
), ),
SynPat.CreateLongIdent ( SynPat.CreateLongIdent (SynLongIdent.create [ Ident.create "_" ; pi.Identifier ], []),
SynLongIdent.CreateFromLongIdent [ Ident.Create "_" ; pi.Identifier ],
[]
),
Some (SynBindingReturnInfo.Create pi.Type), Some (SynBindingReturnInfo.Create pi.Type),
SynExpr.CreateApp ( SynExpr.applyFunction
SynExpr.createLongIdent' [ Ident.lowerFirstLetter pi.Identifier ], (SynExpr.createLongIdent' [ Ident.lowerFirstLetter pi.Identifier ])
SynExpr.CreateConst SynConst.Unit (SynExpr.CreateConst ()),
),
range0, range0,
DebugPointAtBinding.Yes range0, DebugPointAtBinding.Yes range0,
{ {
@@ -932,12 +875,12 @@ module internal HttpClientGenerator =
"Extension methods" "Extension methods"
else else
"Module") "Module")
|> sprintf " %s for constructing a REST client." |> sprintf "%s for constructing a REST client."
|> PreXmlDoc.Create |> PreXmlDoc.create
let interfaceImpl = let interfaceImpl =
SynExpr.ObjExpr ( SynExpr.ObjExpr (
SynType.LongIdent (SynLongIdent.CreateFromLongIdent interfaceType.Name), SynType.createLongIdent interfaceType.Name,
None, None,
Some range0, Some range0,
[], [],
@@ -950,28 +893,22 @@ module internal HttpClientGenerator =
let headerArgs = let headerArgs =
properties properties
|> List.map (fun (_, pi) -> |> List.map (fun (_, pi) ->
SynPat.CreateTyped ( SynPat.namedI (Ident.lowerFirstLetter pi.Identifier)
SynPat.CreateNamed (Ident.lowerFirstLetter pi.Identifier), |> SynPat.annotateType (SynType.funFromDomain (SynType.named "unit") pi.Type)
SynType.CreateFun (SynType.CreateLongIdent "unit", pi.Type)
)
|> SynPat.CreateParen
) )
let clientCreationArg = let clientCreationArg =
SynPat.CreateTyped ( SynPat.named "client"
SynPat.CreateNamed (Ident.Create "client"), |> SynPat.annotateType (SynType.createLongIdent' [ "System" ; "Net" ; "Http" ; "HttpClient" ])
SynType.CreateLongIdent (SynLongIdent.Create [ "System" ; "Net" ; "Http" ; "HttpClient" ])
)
|> SynPat.CreateParen
let xmlDoc = let xmlDoc =
if properties.IsEmpty then if properties.IsEmpty then
" Create a REST client." "Create a REST client."
else else
" Create a REST client. The input functions will be re-evaluated on every HTTP request to obtain the required values for the corresponding header properties." "Create a REST client. The input functions will be re-evaluated on every HTTP request to obtain the required values for the corresponding header properties."
|> PreXmlDoc.Create |> PreXmlDoc.create
let functionName = Ident.Create "client" let functionName = Ident.create "client"
let valData = let valData =
let memberFlags = let memberFlags =
@@ -994,10 +931,9 @@ module internal HttpClientGenerator =
None None
) )
let pattern = SynLongIdent.CreateString "make" let pattern = SynLongIdent.createS "make"
let returnInfo = let returnInfo = SynType.createLongIdent interfaceType.Name
SynType.LongIdent (SynLongIdent.CreateFromLongIdent interfaceType.Name)
let nameWithoutLeadingI = let nameWithoutLeadingI =
List.last interfaceType.Name List.last interfaceType.Name
@@ -1011,64 +947,49 @@ module internal HttpClientGenerator =
let createFunc = let createFunc =
if spec.ExtensionMethods then if spec.ExtensionMethods then
let binding = let binding =
SynBinding.basic SynBinding.basic (SynLongIdent.createS "make") (headerArgs @ [ clientCreationArg ]) interfaceImpl
(SynLongIdent.CreateString "make")
(headerArgs @ [ clientCreationArg ])
interfaceImpl
|> SynBinding.withXmlDoc xmlDoc |> SynBinding.withXmlDoc xmlDoc
|> SynBinding.makeStaticMember
|> SynBinding.withReturnAnnotation returnInfo |> SynBinding.withReturnAnnotation returnInfo
|> SynMemberDefn.staticMember
let mem = SynMemberDefn.Member (binding, range0) let componentInfo =
SynComponentInfo.create (Ident.create nameWithoutLeadingI)
|> SynComponentInfo.withDocString (PreXmlDoc.create "Extension methods for HTTP clients")
let containingType = let containingType =
SynTypeDefn.SynTypeDefn ( SynTypeDefnRepr.augmentation ()
SynComponentInfo.Create ( |> SynTypeDefn.create componentInfo
[ Ident.Create nameWithoutLeadingI ], |> SynTypeDefn.withMemberDefns [ binding ]
xmldoc = PreXmlDoc.Create " Extension methods for HTTP clients"
),
SynTypeDefnRepr.ObjectModel (SynTypeDefnKind.Augmentation range0, [], range0),
[ mem ],
None,
range0,
{
LeadingKeyword = SynTypeDefnLeadingKeyword.Type range0
EqualsRange = None
WithKeyword = None
}
)
SynModuleDecl.Types ([ containingType ], range0) SynModuleDecl.Types ([ containingType ], range0)
else else
SynBinding.basic (SynLongIdent.CreateString "make") (headerArgs @ [ clientCreationArg ]) interfaceImpl SynBinding.basic (SynLongIdent.createS "make") (headerArgs @ [ clientCreationArg ]) interfaceImpl
|> SynBinding.withXmlDoc xmlDoc |> SynBinding.withXmlDoc xmlDoc
|> SynBinding.withReturnAnnotation returnInfo |> SynBinding.withReturnAnnotation returnInfo
|> List.singleton |> List.singleton
|> SynModuleDecl.CreateLet |> SynModuleDecl.CreateLet
let moduleName : LongIdent = let moduleName =
if spec.ExtensionMethods then if spec.ExtensionMethods then
[ Ident.Create (nameWithoutLeadingI + "HttpClientExtension") ] Ident.create (nameWithoutLeadingI + "HttpClientExtension")
else else
[ Ident.Create nameWithoutLeadingI ] Ident.create nameWithoutLeadingI
let attribs = let attribs =
if spec.ExtensionMethods then if spec.ExtensionMethods then
[ SynAttributeList.Create SynAttribute.autoOpen ] [ SynAttribute.autoOpen ]
else else
[ [
SynAttributeList.Create SynAttribute.compilationRepresentation SynAttribute.compilationRepresentation
SynAttributeList.Create (SynAttribute.RequireQualifiedAccess ()) SynAttribute.RequireQualifiedAccess ()
] ]
let modInfo = let modInfo =
SynComponentInfo.Create ( SynComponentInfo.create moduleName
moduleName, |> SynComponentInfo.withDocString docString
attributes = attribs, |> SynComponentInfo.addAttributes attribs
xmldoc = docString, |> SynComponentInfo.setAccessibility interfaceType.Accessibility
access = interfaceType.Accessibility
)
SynModuleOrNamespace.CreateNamespace ( SynModuleOrNamespace.CreateNamespace (
ns, ns,

View File

@@ -48,9 +48,9 @@ module internal InterfaceMockGenerator =
let failwithFun = let failwithFun =
SynExpr.createLongIdent [ "System" ; "NotImplementedException" ] SynExpr.createLongIdent [ "System" ; "NotImplementedException" ]
|> SynExpr.applyTo (SynExpr.CreateConstString "Unimplemented mock function") |> SynExpr.applyTo (SynExpr.CreateConst "Unimplemented mock function")
|> SynExpr.CreateParen |> SynExpr.CreateParen
|> SynExpr.applyFunction (SynExpr.CreateIdentString "raise") |> SynExpr.applyFunction (SynExpr.createIdent "raise")
|> SynExpr.createLambda "_" |> SynExpr.createLambda "_"
let constructorReturnType = let constructorReturnType =
@@ -60,38 +60,28 @@ module internal InterfaceMockGenerator =
let generics = let generics =
generics.TyparDecls generics.TyparDecls
|> List.map (fun (SynTyparDecl (_, typar)) -> SynType.Var (typar, range0)) |> List.map (fun (SynTyparDecl (_, typar)) -> SynType.var typar)
SynType.App ( SynType.app name generics
SynType.CreateLongIdent name,
Some range0,
generics,
List.replicate (generics.Length - 1) range0,
Some range0,
false,
range0
)
let constructorFields = let constructorFields =
let extras = let extras =
if inherits.Contains KnownInheritance.IDisposable then if inherits.Contains KnownInheritance.IDisposable then
let unitFun = SynExpr.createLambda "_" SynExpr.CreateUnit let unitFun = SynExpr.createLambda "_" SynExpr.CreateUnit
[ [ (SynLongIdent.createS "Dispose", true), Some unitFun ]
(SynLongIdent.CreateFromLongIdent [ Ident.Create "Dispose" ], true), Some unitFun
]
else else
[] []
let nonExtras = let nonExtras =
fields fields
|> List.map (fun field -> (SynLongIdent.CreateFromLongIdent [ getName field ], true), Some failwithFun) |> List.map (fun field -> (SynLongIdent.createI (getName field), true), Some failwithFun)
extras @ nonExtras extras @ nonExtras
let constructor = let constructor =
SynBinding.basic SynBinding.basic
(SynLongIdent.CreateString "Empty") (SynLongIdent.createS "Empty")
(if interfaceType.Generics.IsNone then (if interfaceType.Generics.IsNone then
[] []
else else
@@ -184,7 +174,7 @@ module internal InterfaceMockGenerator =
let headPat = let headPat =
SynPat.LongIdent ( SynPat.LongIdent (
SynLongIdent.CreateFromLongIdent [ Ident.Create "this" ; memberInfo.Identifier ], SynLongIdent.create [ Ident.Create "this" ; memberInfo.Identifier ],
None, None,
None, None,
SynArgPats.Pats headArgs, SynArgPats.Pats headArgs,
@@ -199,8 +189,8 @@ module internal InterfaceMockGenerator =
args.Args args.Args
|> List.mapi (fun j arg -> |> List.mapi (fun j arg ->
match arg.Type with match arg.Type with
| UnitType -> SynExpr.CreateConst SynConst.Unit | UnitType -> SynExpr.CreateConst ()
| _ -> SynExpr.CreateIdentString $"arg_%i{i}_%i{j}" | _ -> SynExpr.createIdent $"arg_%i{i}_%i{j}"
) )
|> SynExpr.CreateParenedTuple |> SynExpr.CreateParenedTuple
) )
@@ -240,8 +230,7 @@ module internal InterfaceMockGenerator =
) )
let interfaceName = let interfaceName =
let baseName = let baseName = SynType.createLongIdent interfaceType.Name
SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent interfaceType.Name)
match interfaceType.Generics with match interfaceType.Generics with
| None -> baseName | None -> baseName
@@ -251,17 +240,9 @@ module internal InterfaceMockGenerator =
| SynTyparDecls.PostfixList (decls, _, _) -> decls | SynTyparDecls.PostfixList (decls, _, _) -> decls
| SynTyparDecls.PrefixList (decls, _) -> decls | SynTyparDecls.PrefixList (decls, _) -> decls
| SynTyparDecls.SinglePrefix (decl, _) -> [ decl ] | SynTyparDecls.SinglePrefix (decl, _) -> [ decl ]
|> List.map (fun (SynTyparDecl (_, typar)) -> SynType.Var (typar, range0)) |> List.map (fun (SynTyparDecl (_, typar)) -> SynType.var typar)
SynType.App ( SynType.app' baseName generics
baseName,
Some range0,
generics,
List.replicate (generics.Length - 1) range0,
Some range0,
false,
range0
)
SynMemberDefn.Interface (interfaceName, Some range0, Some members, range0) SynMemberDefn.Interface (interfaceName, Some range0, Some members, range0)
@@ -281,7 +262,7 @@ module internal InterfaceMockGenerator =
| KnownInheritance.IDisposable -> | KnownInheritance.IDisposable ->
let binding = let binding =
SynBinding.basic SynBinding.basic
(SynLongIdent.CreateFromLongIdent [ Ident.Create "this" ; Ident.Create "Dispose" ]) (SynLongIdent.createS' [ "this" ; "Dispose" ])
[ SynPat.CreateConst SynConst.Unit ] [ SynPat.CreateConst SynConst.Unit ]
(SynExpr.CreateApp (SynExpr.createLongIdent [ "this" ; "Dispose" ], SynExpr.CreateUnit)) (SynExpr.CreateApp (SynExpr.createLongIdent [ "this" ; "Dispose" ], SynExpr.CreateUnit))
|> SynBinding.withReturnAnnotation (SynType.Unit ()) |> SynBinding.withReturnAnnotation (SynType.Unit ())
@@ -290,7 +271,7 @@ module internal InterfaceMockGenerator =
let mem = SynMemberDefn.Member (binding, range0) let mem = SynMemberDefn.Member (binding, range0)
SynMemberDefn.Interface ( SynMemberDefn.Interface (
SynType.CreateLongIdent (SynLongIdent.Create [ "System" ; "IDisposable" ]), SynType.CreateLongIdent (SynLongIdent.createS' [ "System" ; "IDisposable" ]),
Some range0, Some range0,
Some [ mem ], Some [ mem ],
range0 range0
@@ -314,7 +295,7 @@ module internal InterfaceMockGenerator =
let private buildType (x : ParameterInfo) : SynType = let private buildType (x : ParameterInfo) : SynType =
if x.IsOptional then if x.IsOptional then
SynType.App (SynType.CreateLongIdent "option", Some range0, [ x.Type ], [], Some range0, false, range0) SynType.app "option" [ x.Type ]
else else
x.Type x.Type

View File

@@ -30,30 +30,23 @@ module internal JsonParseGenerator =
/// (match {indexed} with | null -> raise (System.Collections.Generic.KeyNotFoundException ()) | v -> v) /// (match {indexed} with | null -> raise (System.Collections.Generic.KeyNotFoundException ()) | v -> v)
let assertNotNull (propertyName : SynExpr) (indexed : SynExpr) = let assertNotNull (propertyName : SynExpr) (indexed : SynExpr) =
let raiseExpr = let raiseExpr =
SynExpr.CreateApp ( SynExpr.applyFunction
SynExpr.CreateApp ( (SynExpr.createIdent "sprintf")
SynExpr.CreateIdentString "sprintf", (SynExpr.CreateConst "Required key '%s' not found on JSON object")
SynExpr.CreateConstString "Required key '%s' not found on JSON object" |> SynExpr.applyTo (SynExpr.paren propertyName)
), |> SynExpr.paren
SynExpr.CreateParen propertyName
)
|> SynExpr.CreateParen
|> SynExpr.applyFunction ( |> SynExpr.applyFunction (
SynExpr.CreateLongIdent ( SynExpr.createLongIdent [ "System" ; "Collections" ; "Generic" ; "KeyNotFoundException" ]
SynLongIdent.Create [ "System" ; "Collections" ; "Generic" ; "KeyNotFoundException" ]
)
) )
|> SynExpr.CreateParen |> SynExpr.paren
|> SynExpr.applyFunction (SynExpr.CreateIdentString "raise") |> SynExpr.applyFunction (SynExpr.createIdent "raise")
SynExpr.CreateMatch ( [
indexed, SynMatchClause.create SynPat.CreateNull raiseExpr
[ SynMatchClause.create (SynPat.named "v") (SynExpr.createIdent "v")
SynMatchClause.Create (SynPat.CreateNull, None, raiseExpr) ]
SynMatchClause.Create (SynPat.CreateNamed (Ident.Create "v"), None, SynExpr.CreateIdentString "v") |> SynExpr.createMatch indexed
] |> SynExpr.paren
)
|> SynExpr.CreateParen
/// {node}.AsValue().GetValue<{typeName}> () /// {node}.AsValue().GetValue<{typeName}> ()
/// If `propertyName` is Some, uses `assertNotNull {node}` instead of `{node}`. /// If `propertyName` is Some, uses `assertNotNull {node}` instead of `{node}`.
@@ -81,10 +74,8 @@ module internal JsonParseGenerator =
/// {type}.jsonParse {node} /// {type}.jsonParse {node}
let typeJsonParse (typeName : LongIdent) (node : SynExpr) : SynExpr = let typeJsonParse (typeName : LongIdent) (node : SynExpr) : SynExpr =
SynExpr.CreateApp ( node
SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent (typeName @ [ Ident.Create "jsonParse" ])), |> SynExpr.applyFunction (SynExpr.createLongIdent' (typeName @ [ Ident.create "jsonParse" ]))
node
)
/// collectionType is e.g. "List"; we'll be calling `ofSeq` on it. /// collectionType is e.g. "List"; we'll be calling `ofSeq` on it.
/// body is the body of a lambda which takes a parameter `elt`. /// body is the body of a lambda which takes a parameter `elt`.
@@ -103,51 +94,40 @@ module internal JsonParseGenerator =
| Some propertyName -> assertNotNull propertyName node | Some propertyName -> assertNotNull propertyName node
|> SynExpr.callMethod "AsArray" |> SynExpr.callMethod "AsArray"
|> SynExpr.pipeThroughFunction ( |> SynExpr.pipeThroughFunction (
SynExpr.CreateApp ( SynExpr.applyFunction (SynExpr.createLongIdent [ "Seq" ; "map" ]) (SynExpr.createLambda "elt" body)
SynExpr.CreateLongIdent (SynLongIdent.Create [ "Seq" ; "map" ]),
SynExpr.createLambda "elt" body
)
) )
|> SynExpr.pipeThroughFunction (SynExpr.CreateLongIdent (SynLongIdent.Create [ collectionType ; "ofSeq" ])) |> SynExpr.pipeThroughFunction (SynExpr.createLongIdent [ collectionType ; "ofSeq" ])
/// match {node} with | null -> None | v -> {body} |> Some /// match {node} with | null -> None | v -> {body} |> Some
/// Use the variable `v` to get access to the `Some`. /// Use the variable `v` to get access to the `Some`.
let createParseLineOption (node : SynExpr) (body : SynExpr) : SynExpr = let createParseLineOption (node : SynExpr) (body : SynExpr) : SynExpr =
let body = SynExpr.pipeThroughFunction (SynExpr.CreateIdentString "Some") body let body = SynExpr.pipeThroughFunction (SynExpr.createIdent "Some") body
SynExpr.CreateMatch ( [
node, SynMatchClause.create SynPat.CreateNull (SynExpr.createIdent "None")
[ SynMatchClause.create (SynPat.named "v") body
SynMatchClause.Create (SynPat.CreateNull, None, SynExpr.CreateIdent (Ident.Create "None")) ]
SynMatchClause.Create (SynPat.CreateNamed (Ident.Create "v"), None, body) |> SynExpr.createMatch node
]
)
/// Given e.g. "float", returns "System.Double.Parse" /// Given e.g. "float", returns "System.Double.Parse"
let parseFunction (typeName : string) : LongIdent = let parseFunction (typeName : string) : LongIdent =
let qualified = let qualified =
match AstHelper.qualifyPrimitiveType typeName with match Primitives.qualifyType typeName with
| Some x -> x | Some x -> x
| None -> failwith $"Could not recognise type %s{typeName} as a primitive." | None -> failwith $"Could not recognise type %s{typeName} as a primitive."
List.append qualified [ Ident.Create "Parse" ] List.append qualified [ Ident.create "Parse" ]
/// fun kvp -> let key = {key(kvp)} in let value = {value(kvp)} in (key, value)) /// fun kvp -> let key = {key(kvp)} in let value = {value(kvp)} in (key, value))
/// The inputs will be fed with appropriate SynExprs to apply them to the `kvp.Key` and `kvp.Value` args. /// The inputs will be fed with appropriate SynExprs to apply them to the `kvp.Key` and `kvp.Value` args.
let dictionaryMapper (key : SynExpr -> SynExpr) (value : SynExpr -> SynExpr) : SynExpr = let dictionaryMapper (key : SynExpr -> SynExpr) (value : SynExpr -> SynExpr) : SynExpr =
let keyArg = SynExpr.createLongIdent [ "kvp" ; "Key" ] |> SynExpr.CreateParen let keyArg = SynExpr.createLongIdent [ "kvp" ; "Key" ] |> SynExpr.paren
let valueArg = SynExpr.createLongIdent [ "kvp" ; "Value" ] |> SynExpr.CreateParen let valueArg = SynExpr.createLongIdent [ "kvp" ; "Value" ] |> SynExpr.paren
SynExpr.CreateTuple [ SynExpr.CreateIdentString "key" ; SynExpr.CreateIdentString "value" ] SynExpr.CreateTuple [ SynExpr.createIdent "key" ; SynExpr.createIdent "value" ]
|> SynExpr.createLet |> SynExpr.createLet [ SynBinding.Let (pattern = SynPat.named "value", expr = value valueArg) ]
[ |> SynExpr.createLet [ SynBinding.Let (pattern = SynPat.named "key", expr = key keyArg) ]
SynBinding.Let (pattern = SynPat.CreateNamed (Ident.Create "value"), expr = value valueArg)
]
|> SynExpr.createLet
[
SynBinding.Let (pattern = SynPat.CreateNamed (Ident.Create "key"), expr = key keyArg)
]
|> SynExpr.createLambda "kvp" |> SynExpr.createLambda "kvp"
/// A conforming JSON object has only strings as keys. But it would be reasonable to allow the user /// A conforming JSON object has only strings as keys. But it would be reasonable to allow the user
@@ -157,7 +137,7 @@ module internal JsonParseGenerator =
| String -> key | String -> key
| Uri -> | Uri ->
key key
|> SynExpr.pipeThroughFunction (SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "Uri" ])) |> SynExpr.pipeThroughFunction (SynExpr.createLongIdent [ "System" ; "Uri" ])
| _ -> | _ ->
failwithf failwithf
$"Unable to parse the key type %+A{desiredType} of a JSON object. Keys are strings, and this plugin does not know how to convert to that from a string." $"Unable to parse the key type %+A{desiredType} of a JSON object. Keys are strings, and this plugin does not know how to convert to that from a string."
@@ -197,15 +177,8 @@ module internal JsonParseGenerator =
| None -> basic | None -> basic
| Some option -> | Some option ->
let cond = let cond =
SynExpr.DotGet ( SynExpr.DotGet (SynExpr.createIdent "exc", range0, SynLongIdent.createS "Message", range0)
SynExpr.CreateIdentString "exc", |> SynExpr.callMethodArg "Contains" (SynExpr.CreateConst "cannot be converted to")
range0,
SynLongIdent.CreateString "Message",
range0
)
|> SynExpr.callMethodArg
"Contains"
(SynExpr.CreateConst (SynConst.CreateString "cannot be converted to"))
let handler = let handler =
asValueGetValue propertyName "string" node asValueGetValue propertyName "string" node
@@ -213,91 +186,82 @@ module internal JsonParseGenerator =
|> SynExpr.ifThenElse |> SynExpr.ifThenElse
(SynExpr.equals (SynExpr.equals
option option
(SynExpr.CreateLongIdent ( (SynExpr.createLongIdent
SynLongIdent.Create [
[ "System"
"System" "Text"
"Text" "Json"
"Json" "Serialization"
"Serialization" "JsonNumberHandling"
"JsonNumberHandling" "AllowReadingFromString"
"AllowReadingFromString" ]))
]
)))
SynExpr.reraise SynExpr.reraise
|> SynExpr.ifThenElse cond SynExpr.reraise |> SynExpr.ifThenElse cond SynExpr.reraise
basic basic
|> SynExpr.pipeThroughTryWith |> SynExpr.pipeThroughTryWith
(SynPat.IsInst ( (SynPat.IsInst (
SynType.LongIdent (SynLongIdent.Create [ "System" ; "InvalidOperationException" ]), SynType.LongIdent (SynLongIdent.createS' [ "System" ; "InvalidOperationException" ]),
range0 range0
)) ))
handler handler
| PrimitiveType typeName -> asValueGetValueIdent propertyName typeName node | PrimitiveType typeName -> asValueGetValueIdent propertyName typeName node
| OptionType ty -> | OptionType ty ->
parseNode None options ty (SynExpr.CreateIdentString "v") parseNode None options ty (SynExpr.createIdent "v")
|> createParseLineOption node |> createParseLineOption node
| ListType ty -> | ListType ty ->
parseNode None options ty (SynExpr.CreateLongIdent (SynLongIdent.CreateString "elt")) parseNode None options ty (SynExpr.createIdent "elt")
|> asArrayMapped propertyName "List" node |> asArrayMapped propertyName "List" node
| ArrayType ty -> | ArrayType ty ->
parseNode None options ty (SynExpr.CreateLongIdent (SynLongIdent.CreateString "elt")) parseNode None options ty (SynExpr.createIdent "elt")
|> asArrayMapped propertyName "Array" node |> asArrayMapped propertyName "Array" node
| IDictionaryType (keyType, valueType) -> | IDictionaryType (keyType, valueType) ->
node node
|> asObject propertyName |> asObject propertyName
|> SynExpr.pipeThroughFunction ( |> SynExpr.pipeThroughFunction (
SynExpr.CreateApp ( SynExpr.applyFunction
SynExpr.CreateLongIdent (SynLongIdent.Create [ "Seq" ; "map" ]), (SynExpr.createLongIdent [ "Seq" ; "map" ])
dictionaryMapper (parseKeyString keyType) (parseNode None options valueType) (dictionaryMapper (parseKeyString keyType) (parseNode None options valueType))
)
) )
|> SynExpr.pipeThroughFunction (SynExpr.CreateLongIdent (SynLongIdent.Create [ "dict" ])) |> SynExpr.pipeThroughFunction (SynExpr.createIdent "dict")
| DictionaryType (keyType, valueType) -> | DictionaryType (keyType, valueType) ->
node node
|> asObject propertyName |> asObject propertyName
|> SynExpr.pipeThroughFunction ( |> SynExpr.pipeThroughFunction (
SynExpr.CreateApp ( SynExpr.applyFunction
SynExpr.CreateLongIdent (SynLongIdent.Create [ "Seq" ; "map" ]), (SynExpr.createLongIdent [ "Seq" ; "map" ])
dictionaryMapper (parseKeyString keyType) (parseNode None options valueType) (dictionaryMapper (parseKeyString keyType) (parseNode None options valueType))
)
) )
|> SynExpr.pipeThroughFunction ( |> SynExpr.pipeThroughFunction (
SynExpr.CreateApp ( SynExpr.applyFunction
SynExpr.CreateLongIdent (SynLongIdent.Create [ "Seq" ; "map" ]), (SynExpr.createLongIdent [ "Seq" ; "map" ])
SynExpr.CreateLongIdent ( (SynExpr.createLongIdent [ "System" ; "Collections" ; "Generic" ; "KeyValuePair" ])
SynLongIdent.Create [ "System" ; "Collections" ; "Generic" ; "KeyValuePair" ]
)
)
) )
|> SynExpr.pipeThroughFunction ( |> SynExpr.pipeThroughFunction (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "Collections" ; "Generic" ; "Dictionary" ]) SynExpr.createLongIdent [ "System" ; "Collections" ; "Generic" ; "Dictionary" ]
) )
| IReadOnlyDictionaryType (keyType, valueType) -> | IReadOnlyDictionaryType (keyType, valueType) ->
node node
|> asObject propertyName |> asObject propertyName
|> SynExpr.pipeThroughFunction ( |> SynExpr.pipeThroughFunction (
SynExpr.CreateApp ( SynExpr.applyFunction
SynExpr.CreateLongIdent (SynLongIdent.Create [ "Seq" ; "map" ]), (SynExpr.createLongIdent [ "Seq" ; "map" ])
dictionaryMapper (parseKeyString keyType) (parseNode None options valueType) (dictionaryMapper (parseKeyString keyType) (parseNode None options valueType))
)
) )
|> SynExpr.pipeThroughFunction (SynExpr.CreateLongIdent (SynLongIdent.Create [ "readOnlyDict" ])) |> SynExpr.pipeThroughFunction (SynExpr.createIdent "readOnlyDict")
| MapType (keyType, valueType) -> | MapType (keyType, valueType) ->
node node
|> asObject propertyName |> asObject propertyName
|> SynExpr.pipeThroughFunction ( |> SynExpr.pipeThroughFunction (
SynExpr.CreateApp ( SynExpr.applyFunction
SynExpr.CreateLongIdent (SynLongIdent.Create [ "Seq" ; "map" ]), (SynExpr.createLongIdent [ "Seq" ; "map" ])
dictionaryMapper (parseKeyString keyType) (parseNode None options valueType) (dictionaryMapper (parseKeyString keyType) (parseNode None options valueType))
)
) )
|> SynExpr.pipeThroughFunction (SynExpr.CreateLongIdent (SynLongIdent.Create [ "Map" ; "ofSeq" ])) |> SynExpr.pipeThroughFunction (SynExpr.createLongIdent [ "Map" ; "ofSeq" ])
| BigInt -> | BigInt ->
node node
|> SynExpr.callMethod "ToJsonString" |> SynExpr.callMethod "ToJsonString"
|> SynExpr.CreateParen |> SynExpr.paren
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "System" ; "Numerics" ; "BigInteger" ; "Parse" ]) |> SynExpr.applyFunction (SynExpr.createLongIdent [ "System" ; "Numerics" ; "BigInteger" ; "Parse" ])
| _ -> | _ ->
// Let's just hope that we've also got our own type annotation! // Let's just hope that we've also got our own type annotation!
@@ -314,9 +278,8 @@ module internal JsonParseGenerator =
/// propertyName is probably a string literal, but it could be a [<Literal>] variable /// propertyName is probably a string literal, but it could be a [<Literal>] variable
/// The result of this function is the body of a let-binding (not including the LHS of that let-binding). /// The result of this function is the body of a let-binding (not including the LHS of that let-binding).
let createParseRhs (options : JsonParseOption) (propertyName : SynExpr) (fieldType : SynType) : SynExpr = let createParseRhs (options : JsonParseOption) (propertyName : SynExpr) (fieldType : SynType) : SynExpr =
SynExpr.CreateIdentString "node" let objectToParse = SynExpr.createIdent "node" |> SynExpr.index propertyName
|> SynExpr.index propertyName parseNode (Some propertyName) options fieldType objectToParse
|> parseNode (Some propertyName) options fieldType
let isJsonNumberHandling (literal : LongIdent) : bool = let isJsonNumberHandling (literal : LongIdent) : bool =
match List.rev literal |> List.map (fun ident -> ident.idText) with match List.rev literal |> List.map (fun ident -> ident.idText) with
@@ -332,51 +295,69 @@ module internal JsonParseGenerator =
/// That is, we give you access to a `JsonNode` called `node`, /// That is, we give you access to a `JsonNode` called `node`,
/// and you must return a `typeName`. /// and you must return a `typeName`.
let scaffolding (spec : JsonParseOutputSpec) (typeName : LongIdent) (functionBody : SynExpr) : SynModuleDecl = let scaffolding (spec : JsonParseOutputSpec) (typeName : LongIdent) (functionBody : SynExpr) : SynModuleDecl =
let xmlDoc = PreXmlDoc.Create " Parse from a JSON node." let xmlDoc = PreXmlDoc.create "Parse from a JSON node."
let returnInfo = SynType.LongIdent (SynLongIdent.CreateFromLongIdent typeName) let returnInfo = SynType.createLongIdent typeName
let inputArg = Ident.Create "node" let inputArg = "node"
let functionName = Ident.Create "jsonParse" let functionName = Ident.create "jsonParse"
let arg = let arg =
SynPat.CreateNamed inputArg SynPat.named inputArg
|> SynPat.annotateType ( |> SynPat.annotateType (SynType.createLongIdent' [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ])
SynType.LongIdent (SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ])
)
if spec.ExtensionMethods then if spec.ExtensionMethods then
let binding = let binding =
SynBinding.basic (SynLongIdent.CreateFromLongIdent [ functionName ]) [ arg ] functionBody SynBinding.basic (SynLongIdent.createI functionName) [ arg ] functionBody
|> SynBinding.makeStaticMember
|> SynBinding.withXmlDoc xmlDoc |> SynBinding.withXmlDoc xmlDoc
|> SynBinding.withReturnAnnotation returnInfo |> SynBinding.withReturnAnnotation returnInfo
|> SynMemberDefn.staticMember
let mem = SynMemberDefn.Member (binding, range0) let componentInfo =
SynComponentInfo.createLong typeName
|> SynComponentInfo.withDocString (PreXmlDoc.Create " Extension methods for JSON parsing")
let containingType = let containingType =
SynTypeDefn.SynTypeDefn ( SynTypeDefnRepr.augmentation ()
SynComponentInfo.Create (typeName, xmldoc = PreXmlDoc.Create " Extension methods for JSON parsing"), |> SynTypeDefn.create componentInfo
SynTypeDefnRepr.ObjectModel (SynTypeDefnKind.Augmentation range0, [], range0), |> SynTypeDefn.withMemberDefns [ binding ]
[ mem ],
None,
range0,
{
LeadingKeyword = SynTypeDefnLeadingKeyword.Type range0
EqualsRange = None
WithKeyword = None
}
)
SynModuleDecl.Types ([ containingType ], range0) SynModuleDecl.Types ([ containingType ], range0)
else else
SynBinding.basic (SynLongIdent.CreateFromLongIdent [ functionName ]) [ arg ] functionBody SynBinding.basic (SynLongIdent.createI functionName) [ arg ] functionBody
|> SynBinding.withXmlDoc xmlDoc |> SynBinding.withXmlDoc xmlDoc
|> SynBinding.withReturnAnnotation returnInfo |> SynBinding.withReturnAnnotation returnInfo
|> List.singleton |> List.singleton
|> SynModuleDecl.CreateLet |> SynModuleDecl.CreateLet
let createMaker (spec : JsonParseOutputSpec) (typeName : LongIdent) (fields : SynFieldData<Ident> list) = let getParseOptions (fieldAttrs : SynAttribute list) =
(JsonParseOption.None, fieldAttrs)
||> List.fold (fun options attr ->
if attr.TypeName.AsString.EndsWith ("JsonNumberHandling", StringComparison.Ordinal) then
let qualifiedEnumValue =
match SynExpr.stripOptionalParen attr.ArgExpr with
| SynExpr.LongIdent (_, SynLongIdent (ident, _, _), _, _) when isJsonNumberHandling ident ->
// Make sure it's fully qualified
SynExpr.createLongIdent
[
"System"
"Text"
"Json"
"Serialization"
"JsonNumberHandling"
"AllowReadingFromString"
]
| _ -> attr.ArgExpr
{
JsonNumberHandlingArg = Some qualifiedEnumValue
}
else
options
)
let createRecordMaker (spec : JsonParseOutputSpec) (typeName : LongIdent) (fields : SynFieldData<Ident> list) =
let assignments = let assignments =
fields fields
|> List.mapi (fun i fieldData -> |> List.mapi (fun i fieldData ->
@@ -386,79 +367,112 @@ module internal JsonParseGenerator =
attr.TypeName.AsString.EndsWith ("JsonPropertyName", StringComparison.Ordinal) attr.TypeName.AsString.EndsWith ("JsonPropertyName", StringComparison.Ordinal)
) )
let options = let options = getParseOptions fieldData.Attrs
(JsonParseOption.None, fieldData.Attrs)
||> List.fold (fun options attr ->
if attr.TypeName.AsString.EndsWith ("JsonNumberHandling", StringComparison.Ordinal) then
let qualifiedEnumValue =
match SynExpr.stripOptionalParen attr.ArgExpr with
| SynExpr.LongIdent (_, SynLongIdent (ident, _, _), _, _) when
isJsonNumberHandling ident
->
// Make sure it's fully qualified
SynExpr.createLongIdent
[
"System"
"Text"
"Json"
"Serialization"
"JsonNumberHandling"
"AllowReadingFromString"
]
| _ -> attr.ArgExpr
{
JsonNumberHandlingArg = Some qualifiedEnumValue
}
else
options
)
let propertyName = let propertyName =
match propertyNameAttr with match propertyNameAttr with
| None -> | None ->
let sb = StringBuilder fieldData.Ident.idText.Length let sb = StringBuilder fieldData.Ident.idText.Length
sb.Append (Char.ToLowerInvariant fieldData.Ident.idText.[0]) |> ignore
sb.Append (Char.ToLowerInvariant fieldData.Ident.idText.[0])
|> ignore<StringBuilder>
if fieldData.Ident.idText.Length > 1 then if fieldData.Ident.idText.Length > 1 then
sb.Append fieldData.Ident.idText.[1..] |> ignore sb.Append (fieldData.Ident.idText.Substring 1) |> ignore<StringBuilder>
sb.ToString () |> SynConst.CreateString |> SynExpr.CreateConst sb.ToString () |> SynExpr.CreateConst
| Some name -> name.ArgExpr | Some name -> name.ArgExpr
createParseRhs options propertyName fieldData.Type createParseRhs options propertyName fieldData.Type
|> SynBinding.basic (SynLongIdent.CreateString $"arg_%i{i}") [] |> SynBinding.basic (SynLongIdent.createS $"arg_%i{i}") []
) )
let finalConstruction = let finalConstruction =
fields fields
|> List.mapi (fun i fieldData -> |> List.mapi (fun i fieldData ->
(SynLongIdent.CreateFromLongIdent [ fieldData.Ident ], true), (SynLongIdent.createI fieldData.Ident, true), Some (SynExpr.createIdent $"arg_%i{i}")
Some (SynExpr.CreateLongIdent (SynLongIdent.CreateString $"arg_%i{i}"))
) )
|> AstHelper.instantiateRecord |> AstHelper.instantiateRecord
let assignments = (finalConstruction, assignments)
(finalConstruction, assignments) ||> List.fold (fun final assignment -> SynExpr.createLet [ assignment ] final)
||> List.fold (fun final assignment -> SynExpr.createLet [ assignment ] final)
assignments |> scaffolding spec typeName let createUnionMaker (spec : JsonParseOutputSpec) (typeName : LongIdent) (fields : UnionCase<Ident> list) =
fields
|> List.map (fun case ->
let propertyName = JsonSerializeGenerator.getPropertyName case.Ident case.Attrs
(* let body =
if case.Fields.IsEmpty then
SynExpr.createLongIdent' (typeName @ [ case.Ident ])
else
case.Fields
|> List.map (fun field ->
let propertyName = JsonSerializeGenerator.getPropertyName field.Ident field.Attrs
let options = getParseOptions field.Attrs
createParseRhs options propertyName field.Type
)
|> SynExpr.CreateParenedTuple
|> SynExpr.applyFunction (SynExpr.createLongIdent' (typeName @ [ case.Ident ]))
|> SynExpr.createLet
[
SynExpr.index (SynExpr.CreateConst "data") (SynExpr.createIdent "node")
|> assertNotNull (SynExpr.CreateConst "data")
|> SynBinding.basic (SynLongIdent.createS "node") []
]
static member jsonParse (node : System.Text.Json.Nodes.JsonNode) : FirstDu = match propertyName with
let ty = | SynExpr.Const (synConst, _) ->
match node.["type"] with SynMatchClause.SynMatchClause (
| null -> raise (System.Collections.Generic.KeyNotFoundException ()) SynPat.CreateConst synConst,
| v -> v.GetValue<string> () None,
match ty with body,
| "emptyCase" -> FirstDu.EmptyCase range0,
| "case1" -> DebugPointAtTarget.Yes,
FirstDu.Case1 {
| "case2" -> FirstDu.Case2 ArrowRange = Some range0
| _ -> failwithf "Unrecognised case name: %s" ty BarRange = Some range0
*) }
)
| _ ->
SynMatchClause.create (SynPat.named "x") body
|> SynMatchClause.withWhere (SynExpr.equals (SynExpr.createIdent "x") propertyName)
)
|> fun l ->
l
@ [
let fail =
SynExpr.plus (SynExpr.CreateConst "Unrecognised 'type' field value: ") (SynExpr.createIdent "v")
|> SynExpr.paren
|> SynExpr.applyFunction (SynExpr.createIdent "failwith")
SynMatchClause.SynMatchClause (
SynPat.named "v",
None,
fail,
range0,
DebugPointAtTarget.Yes,
{
ArrowRange = Some range0
BarRange = Some range0
}
)
]
|> SynExpr.createMatch (SynExpr.createIdent "ty")
|> SynExpr.createLet
[
let property = SynExpr.CreateConst "type"
SynExpr.createIdent "node"
|> SynExpr.index property
|> assertNotNull property
|> SynExpr.pipeThroughFunction (
SynExpr.createLambda
"v"
(SynExpr.callGenericMethod "GetValue" [ Ident.create "string" ] (SynExpr.createIdent "v"))
)
|> SynBinding.basic (SynLongIdent.createS "ty") []
]
let createModule (namespaceId : LongIdent) (spec : JsonParseOutputSpec) (typeDefn : SynTypeDefn) = let createModule (namespaceId : LongIdent) (spec : JsonParseOutputSpec) (typeDefn : SynTypeDefn) =
let (SynTypeDefn (synComponentInfo, synTypeDefnRepr, _members, _implicitCtor, _, _)) = let (SynTypeDefn (synComponentInfo, synTypeDefnRepr, _members, _implicitCtor, _, _)) =
@@ -469,11 +483,11 @@ module internal JsonParseGenerator =
let attributes = let attributes =
if spec.ExtensionMethods then if spec.ExtensionMethods then
[ SynAttributeList.Create SynAttribute.autoOpen ] [ SynAttribute.autoOpen ]
else else
[ [
SynAttributeList.Create (SynAttribute.RequireQualifiedAccess ()) SynAttribute.RequireQualifiedAccess ()
SynAttributeList.Create SynAttribute.compilationRepresentation SynAttribute.compilationRepresentation
] ]
let xmlDoc = let xmlDoc =
@@ -497,27 +511,39 @@ module internal JsonParseGenerator =
List.last ident List.last ident
|> fun i -> i.idText |> fun i -> i.idText
|> fun s -> s + "JsonParseExtension" |> fun s -> s + "JsonParseExtension"
|> Ident.Create |> Ident.create
List.take (List.length ident - 1) ident @ [ expanded ] List.take (List.length ident - 1) ident @ [ expanded ]
else else
ident ident
let info = let info =
SynComponentInfo.Create (moduleName, attributes = attributes, xmldoc = xmlDoc) SynComponentInfo.createLong moduleName
|> SynComponentInfo.withDocString xmlDoc
|> SynComponentInfo.addAttributes attributes
let decls = let decl =
match synTypeDefnRepr with match synTypeDefnRepr with
| SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (_accessibility, fields, _range), _) -> | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (_accessibility, fields, _range), _) ->
let fields = fields |> List.map SynField.extractWithIdent let fields = fields |> List.map SynField.extractWithIdent
[ createMaker spec ident fields ] createRecordMaker spec ident fields
| SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (_accessibility, cases, _range), _) -> | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (_accessibility, cases, _range), _) ->
let cases = cases |> List.map SynUnionCase.extract let optionGet (i : Ident option) =
// [ createMaker spec ident cases ] match i with
failwith "Unions are not yet supported" | None -> failwith "WoofWare.Myriad requires union cases to have identifiers on each field."
| Some i -> i
let cases =
cases
|> List.map SynUnionCase.extract
|> List.map (UnionCase.mapIdentFields optionGet)
createUnionMaker spec ident cases
| _ -> failwithf "Not a record or union type" | _ -> failwithf "Not a record or union type"
let mdl = SynModuleDecl.CreateNestedModule (info, decls) let mdl =
[ scaffolding spec ident decl ]
|> fun d -> SynModuleDecl.CreateNestedModule (info, d)
SynModuleOrNamespace.CreateNamespace (namespaceId, decls = [ mdl ]) SynModuleOrNamespace.CreateNamespace (namespaceId, decls = [ mdl ])

View File

@@ -42,35 +42,27 @@ module internal JsonSerializeGenerator =
// fun field -> match field with | None -> JsonValue.Create null | Some v -> {serializeNode ty} field // fun field -> match field with | None -> JsonValue.Create null | Some v -> {serializeNode ty} field
[ [
SynMatchClause.Create ( SynMatchClause.Create (
SynPat.CreateLongIdent (SynLongIdent.CreateString "None", []), SynPat.CreateLongIdent (SynLongIdent.createS "None", []),
None, None,
// The absolutely galaxy-brained implementation of JsonValue has `JsonValue.Parse "null"` // The absolutely galaxy-brained implementation of JsonValue has `JsonValue.Parse "null"`
// identically equal to null. We have to work around this later, but we might as well just // identically equal to null. We have to work around this later, but we might as well just
// be efficient here and whip up the null directly. // be efficient here and whip up the null directly.
SynExpr.CreateNull SynExpr.CreateNull
|> SynExpr.upcast' ( |> SynExpr.upcast' (
SynType.CreateLongIdent ( SynType.createLongIdent' [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ]
SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ]
)
) )
) )
SynMatchClause.Create ( SynMatchClause.Create (
SynPat.CreateLongIdent ( SynPat.CreateLongIdent (SynLongIdent.createS "Some", [ SynPat.named "field" ]),
SynLongIdent.CreateString "Some",
[ SynPat.CreateNamed (Ident.Create "field") ]
),
None, None,
SynExpr.CreateApp (serializeNode ty, SynExpr.CreateIdentString "field") SynExpr.applyFunction (serializeNode ty) (SynExpr.createIdent "field")
|> SynExpr.CreateParen |> SynExpr.paren
|> SynExpr.upcast' ( |> SynExpr.upcast' (SynType.createLongIdent' [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ])
SynType.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ]
)
)
) )
] ]
|> SynExpr.createMatch (SynExpr.CreateIdentString "field") |> SynExpr.createMatch (SynExpr.createIdent "field")
|> SynExpr.createLambda "field" |> SynExpr.createLambda "field"
| ArrayType ty | ArrayType ty
| ListType ty -> | ListType ty ->
@@ -84,22 +76,21 @@ module internal JsonSerializeGenerator =
DebugPointAtInOrTo.Yes range0, DebugPointAtInOrTo.Yes range0,
SeqExprOnly.SeqExprOnly false, SeqExprOnly.SeqExprOnly false,
true, true,
SynPat.CreateNamed (Ident.Create "mem"), SynPat.named "mem",
SynExpr.CreateIdent (Ident.Create "field"), SynExpr.createIdent "field",
SynExpr.CreateApp ( SynExpr.applyFunction
SynExpr.CreateLongIdent (SynLongIdent.Create [ "arr" ; "Add" ]), (SynExpr.CreateLongIdent (SynLongIdent.createS' [ "arr" ; "Add" ]))
SynExpr.CreateParen (SynExpr.CreateApp (serializeNode ty, SynExpr.CreateIdentString "mem")) (SynExpr.CreateParen (SynExpr.CreateApp (serializeNode ty, SynExpr.createIdent "mem"))),
),
range0 range0
) )
SynExpr.CreateIdentString "arr" SynExpr.createIdent "arr"
] ]
|> SynExpr.CreateSequential |> SynExpr.CreateSequential
|> SynExpr.createLet |> SynExpr.createLet
[ [
SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonArray" ] SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonArray" ]
|> SynExpr.applyTo (SynExpr.CreateConst SynConst.Unit) |> SynExpr.applyTo (SynExpr.CreateConst ())
|> SynBinding.basic (SynLongIdent.CreateString "arr") [] |> SynBinding.basic (SynLongIdent.createS "arr") []
] ]
|> SynExpr.createLambda "field" |> SynExpr.createLambda "field"
| IDictionaryType (_keyType, valueType) | IDictionaryType (_keyType, valueType)
@@ -119,7 +110,7 @@ module internal JsonSerializeGenerator =
true, true,
SynPat.CreateParen ( SynPat.CreateParen (
SynPat.CreateLongIdent ( SynPat.CreateLongIdent (
SynLongIdent.CreateString "KeyValue", SynLongIdent.createS "KeyValue",
[ [
SynPat.CreateParen ( SynPat.CreateParen (
SynPat.Tuple ( SynPat.Tuple (
@@ -142,21 +133,21 @@ module internal JsonSerializeGenerator =
[ [
SynExpr.CreateApp ( SynExpr.CreateApp (
SynExpr.createLongIdent [ "key" ; "ToString" ], SynExpr.createLongIdent [ "key" ; "ToString" ],
SynExpr.CreateConst SynConst.Unit SynExpr.CreateConst ()
) )
SynExpr.CreateApp (serializeNode valueType, SynExpr.CreateIdentString "value") SynExpr.CreateApp (serializeNode valueType, SynExpr.createIdent "value")
] ]
), ),
range0 range0
) )
SynExpr.CreateIdentString "ret" SynExpr.createIdent "ret"
] ]
|> SynExpr.CreateSequential |> SynExpr.CreateSequential
|> SynExpr.createLet |> SynExpr.createLet
[ [
SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonObject" ] SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonObject" ]
|> SynExpr.applyTo (SynExpr.CreateConst SynConst.Unit) |> SynExpr.applyTo (SynExpr.CreateConst ())
|> SynBinding.basic (SynLongIdent.CreateString "ret") [] |> SynBinding.basic (SynLongIdent.createS "ret") []
] ]
|> SynExpr.createLambda "field" |> SynExpr.createLambda "field"
| _ -> | _ ->
@@ -173,7 +164,9 @@ module internal JsonSerializeGenerator =
let createSerializeRhsRecord (propertyName : SynExpr) (fieldId : Ident) (fieldType : SynType) : SynExpr = let createSerializeRhsRecord (propertyName : SynExpr) (fieldId : Ident) (fieldType : SynType) : SynExpr =
[ [
propertyName propertyName
SynExpr.CreateApp (serializeNode fieldType, SynExpr.createLongIdent' [ Ident.Create "input" ; fieldId ]) SynExpr.applyFunction
(serializeNode fieldType)
(SynExpr.createLongIdent' [ Ident.create "input" ; fieldId ])
] ]
|> SynExpr.CreateParenedTuple |> SynExpr.CreateParenedTuple
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "node" ; "Add" ]) |> SynExpr.applyFunction (SynExpr.createLongIdent [ "node" ; "Add" ])
@@ -191,7 +184,7 @@ module internal JsonSerializeGenerator =
if fieldId.idText.Length > 1 then if fieldId.idText.Length > 1 then
sb.Append fieldId.idText.[1..] |> ignore sb.Append fieldId.idText.[1..] |> ignore
sb.ToString () |> SynConst.CreateString |> SynExpr.CreateConst sb.ToString () |> SynExpr.CreateConst
| Some name -> name.ArgExpr | Some name -> name.ArgExpr
/// `populateNode` will be inserted before we return the `node` variable. /// `populateNode` will be inserted before we return the `node` variable.
@@ -207,67 +200,60 @@ module internal JsonSerializeGenerator =
(populateNode : SynExpr) (populateNode : SynExpr)
: SynModuleDecl : SynModuleDecl
= =
let xmlDoc = PreXmlDoc.Create " Serialize to a JSON node" let xmlDoc = PreXmlDoc.create "Serialize to a JSON node"
let returnInfo = let returnInfo =
SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ] SynLongIdent.createS' [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ]
|> SynType.LongIdent |> SynType.LongIdent
let functionName = Ident.Create "toJsonNode" let functionName = Ident.create "toJsonNode"
let assignments = let assignments =
[ [
populateNode populateNode
SynExpr.Upcast (SynExpr.CreateIdentString "node", SynType.Anon range0, range0) SynExpr.Upcast (SynExpr.createIdent "node", SynType.Anon range0, range0)
] ]
|> SynExpr.CreateSequential |> SynExpr.CreateSequential
|> SynExpr.createLet |> SynExpr.createLet
[ [
SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonObject" ] SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonObject" ]
|> SynExpr.applyTo (SynExpr.CreateConst SynConst.Unit) |> SynExpr.applyTo (SynExpr.CreateConst ())
|> SynBinding.basic (SynLongIdent.CreateString "node") [] |> SynBinding.basic (SynLongIdent.createS "node") []
] ]
let pattern = let pattern =
SynPat.CreateNamed inputArgName SynPat.CreateNamed inputArgName
|> SynPat.annotateType (SynType.LongIdent (SynLongIdent.CreateFromLongIdent typeName)) |> SynPat.annotateType (SynType.LongIdent (SynLongIdent.create typeName))
if spec.ExtensionMethods then if spec.ExtensionMethods then
let binding = let componentInfo =
SynComponentInfo.createLong typeName
|> SynComponentInfo.withDocString (PreXmlDoc.Create " Extension methods for JSON parsing")
let memberDef =
assignments assignments
|> SynBinding.basic (SynLongIdent.CreateFromLongIdent [ functionName ]) [ pattern ] |> SynBinding.basic (SynLongIdent.createI functionName) [ pattern ]
|> SynBinding.withXmlDoc xmlDoc |> SynBinding.withXmlDoc xmlDoc
|> SynBinding.withReturnAnnotation returnInfo |> SynBinding.withReturnAnnotation returnInfo
|> SynBinding.makeStaticMember |> SynMemberDefn.staticMember
let mem = SynMemberDefn.Member (binding, range0)
let containingType = let containingType =
SynTypeDefn.SynTypeDefn ( SynTypeDefnRepr.augmentation ()
SynComponentInfo.Create (typeName, xmldoc = PreXmlDoc.Create " Extension methods for JSON parsing"), |> SynTypeDefn.create componentInfo
SynTypeDefnRepr.ObjectModel (SynTypeDefnKind.Augmentation range0, [], range0), |> SynTypeDefn.withMemberDefns [ memberDef ]
[ mem ],
None,
range0,
{
LeadingKeyword = SynTypeDefnLeadingKeyword.Type range0
EqualsRange = None
WithKeyword = None
}
)
SynModuleDecl.Types ([ containingType ], range0) SynModuleDecl.Types ([ containingType ], range0)
else else
let binding = let binding =
assignments assignments
|> SynBinding.basic (SynLongIdent.CreateFromLongIdent [ functionName ]) [ pattern ] |> SynBinding.basic (SynLongIdent.createI functionName) [ pattern ]
|> SynBinding.withReturnAnnotation returnInfo |> SynBinding.withReturnAnnotation returnInfo
|> SynBinding.withXmlDoc xmlDoc |> SynBinding.withXmlDoc xmlDoc
SynModuleDecl.CreateLet [ binding ] SynModuleDecl.CreateLet [ binding ]
let recordModule (spec : JsonSerializeOutputSpec) (typeName : LongIdent) (fields : SynField list) = let recordModule (spec : JsonSerializeOutputSpec) (typeName : LongIdent) (fields : SynField list) =
let inputArg = Ident.Create "input" let inputArg = Ident.create "input"
let fields = fields |> List.map SynField.extractWithIdent let fields = fields |> List.map SynField.extractWithIdent
fields fields
@@ -280,20 +266,20 @@ module internal JsonSerializeGenerator =
|> scaffolding spec typeName inputArg |> scaffolding spec typeName inputArg
let unionModule (spec : JsonSerializeOutputSpec) (typeName : LongIdent) (cases : SynUnionCase list) = let unionModule (spec : JsonSerializeOutputSpec) (typeName : LongIdent) (cases : SynUnionCase list) =
let inputArg = Ident.Create "input" let inputArg = Ident.create "input"
let fields = cases |> List.map SynUnionCase.extract let fields = cases |> List.map SynUnionCase.extract
fields fields
|> List.map (fun unionCase -> |> List.map (fun unionCase ->
let propertyName = getPropertyName unionCase.Ident unionCase.Attrs let propertyName = getPropertyName unionCase.Ident unionCase.Attrs
let caseNames = unionCase.Fields |> List.mapi (fun i _ -> Ident.Create $"arg%i{i}") let caseNames = unionCase.Fields |> List.mapi (fun i _ -> Ident.create $"arg%i{i}")
let argPats = SynArgPats.create caseNames let argPats = SynArgPats.create caseNames
let pattern = let pattern =
SynPat.LongIdent ( SynPat.LongIdent (
SynLongIdent.CreateFromLongIdent (typeName @ [ unionCase.Ident ]), SynLongIdent.create (typeName @ [ unionCase.Ident ]),
None, None,
None, None,
argPats, argPats,
@@ -303,25 +289,21 @@ module internal JsonSerializeGenerator =
let typeLine = let typeLine =
[ [
SynExpr.CreateConstString "type" SynExpr.CreateConst "type"
SynExpr.CreateApp ( SynExpr.applyFunction
SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonValue" ; "Create" ], (SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonValue" ; "Create" ])
propertyName propertyName
)
] ]
|> SynExpr.CreateParenedTuple |> SynExpr.CreateParenedTuple
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "node" ; "Add" ]) |> SynExpr.applyFunction (SynExpr.createLongIdent [ "node" ; "Add" ])
let dataNode = let dataNode =
SynBinding.Let ( SynBinding.Let (
pattern = SynPat.CreateNamed (Ident.Create "dataNode"), pattern = SynPat.named "dataNode",
expr = expr =
SynExpr.CreateApp ( SynExpr.applyFunction
SynExpr.CreateLongIdent ( (SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonObject" ])
SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonObject" ] (SynExpr.CreateConst ())
),
SynExpr.CreateConst SynConst.Unit
)
) )
let dataBindings = let dataBindings =
@@ -331,7 +313,7 @@ module internal JsonSerializeGenerator =
let propertyName = getPropertyName (Option.get fieldData.Ident) fieldData.Attrs let propertyName = getPropertyName (Option.get fieldData.Ident) fieldData.Attrs
let node = let node =
SynExpr.CreateApp (serializeNode fieldData.Type, SynExpr.CreateIdent caseName) SynExpr.applyFunction (serializeNode fieldData.Type) (SynExpr.createIdent' caseName)
[ propertyName ; node ] [ propertyName ; node ]
|> SynExpr.CreateParenedTuple |> SynExpr.CreateParenedTuple
@@ -339,7 +321,7 @@ module internal JsonSerializeGenerator =
) )
let assignToNode = let assignToNode =
[ SynExpr.CreateConstString "data" ; SynExpr.CreateIdentString "dataNode" ] [ SynExpr.CreateConst "data" ; SynExpr.createIdent "dataNode" ]
|> SynExpr.CreateParenedTuple |> SynExpr.CreateParenedTuple
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "node" ; "Add" ]) |> SynExpr.applyFunction (SynExpr.createLongIdent [ "node" ; "Add" ])
@@ -355,9 +337,9 @@ module internal JsonSerializeGenerator =
] ]
|> SynExpr.CreateSequential |> SynExpr.CreateSequential
SynMatchClause.Create (pattern, None, action) SynMatchClause.create pattern action
) )
|> fun clauses -> SynExpr.CreateMatch (SynExpr.CreateIdent inputArg, clauses) |> SynExpr.createMatch (SynExpr.createIdent' inputArg)
|> scaffolding spec typeName inputArg |> scaffolding spec typeName inputArg
let createModule let createModule
@@ -374,11 +356,11 @@ module internal JsonSerializeGenerator =
let attributes = let attributes =
if spec.ExtensionMethods then if spec.ExtensionMethods then
[ SynAttributeList.Create SynAttribute.autoOpen ] [ SynAttribute.autoOpen ]
else else
[ [
SynAttributeList.Create (SynAttribute.RequireQualifiedAccess ()) SynAttribute.RequireQualifiedAccess ()
SynAttributeList.Create SynAttribute.compilationRepresentation SynAttribute.compilationRepresentation
] ]
let xmlDoc = let xmlDoc =
@@ -390,8 +372,8 @@ module internal JsonSerializeGenerator =
else else
"methods" "methods"
$" Module containing JSON serializing %s{description} for the %s{fullyQualified} type" $"Module containing JSON serializing %s{description} for the %s{fullyQualified} type"
|> PreXmlDoc.Create |> PreXmlDoc.create
let moduleName = let moduleName =
if spec.ExtensionMethods then if spec.ExtensionMethods then
@@ -402,14 +384,16 @@ module internal JsonSerializeGenerator =
List.last ident List.last ident
|> fun i -> i.idText |> fun i -> i.idText
|> fun s -> s + "JsonSerializeExtension" |> fun s -> s + "JsonSerializeExtension"
|> Ident.Create |> Ident.create
List.take (List.length ident - 1) ident @ [ expanded ] List.take (List.length ident - 1) ident @ [ expanded ]
else else
ident ident
let info = let info =
SynComponentInfo.Create (moduleName, attributes = attributes, xmldoc = xmlDoc) SynComponentInfo.createLong moduleName
|> SynComponentInfo.addAttributes attributes
|> SynComponentInfo.withDocString xmlDoc
let decls = let decls =
match synTypeDefnRepr with match synTypeDefnRepr with

View File

@@ -0,0 +1,30 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
module internal Primitives =
/// Given e.g. "byte", returns "System.Byte".
let qualifyType (typeName : string) : LongIdent option =
match typeName with
| "float32"
| "single" -> [ "System" ; "Single" ] |> Some
| "float"
| "double" -> [ "System" ; "Double" ] |> Some
| "byte"
| "uint8" -> [ "System" ; "Byte" ] |> Some
| "sbyte"
| "int8" -> [ "System" ; "SByte" ] |> Some
| "int16" -> [ "System" ; "Int16" ] |> Some
| "int"
| "int32" -> [ "System" ; "Int32" ] |> Some
| "int64" -> [ "System" ; "Int64" ] |> Some
| "uint16" -> [ "System" ; "UInt16" ] |> Some
| "uint"
| "uint32" -> [ "System" ; "UInt32" ] |> Some
| "uint64" -> [ "System" ; "UInt64" ] |> Some
| "char" -> [ "System" ; "Char" ] |> Some
| "decimal" -> [ "System" ; "Decimal" ] |> Some
| _ -> None
|> Option.map (List.map (fun i -> (Ident (i, range0))))

View File

@@ -47,7 +47,7 @@ module internal RemoveOptionsGenerator =
(fields : SynField list) (fields : SynField list)
= =
let fields : SynField list = fields |> List.map removeOption let fields : SynField list = fields |> List.map removeOption
let name = Ident.Create "Short" let name = Ident.create "Short"
let record = let record =
{ {
@@ -64,20 +64,10 @@ module internal RemoveOptionsGenerator =
SynModuleDecl.Types ([ typeDecl ], range0) SynModuleDecl.Types ([ typeDecl ], range0)
let createMaker (withOptionsType : LongIdent) (withoutOptionsType : LongIdent) (fields : SynFieldData<Ident> list) = let createMaker (withOptionsType : LongIdent) (withoutOptionsType : LongIdent) (fields : SynFieldData<Ident> list) =
let xmlDoc = PreXmlDoc.Create " Remove the optional members of the input." let xmlDoc = PreXmlDoc.create "Remove the optional members of the input."
let returnInfo = let inputArg = Ident.create "input"
SynBindingReturnInfo.Create (SynType.LongIdent (SynLongIdent.CreateFromLongIdent withOptionsType)) let functionName = Ident.create "shorten"
let inputArg = Ident.Create "input"
let functionName = Ident.Create "shorten"
let inputVal =
SynValData.SynValData (
None,
SynValInfo.SynValInfo ([ [ SynArgInfo.CreateId functionName ] ], SynArgInfo.Empty),
Some inputArg
)
let body = let body =
fields fields
@@ -93,8 +83,8 @@ module internal RemoveOptionsGenerator =
let body = let body =
match fieldData.Type with match fieldData.Type with
| OptionType _ -> | OptionType _ ->
SynExpr.CreateApp ( SynExpr.applyFunction
SynExpr.CreateAppInfix ( (SynExpr.CreateAppInfix (
SynExpr.LongIdent ( SynExpr.LongIdent (
false, false,
SynLongIdent.SynLongIdent ( SynLongIdent.SynLongIdent (
@@ -106,50 +96,29 @@ module internal RemoveOptionsGenerator =
range0 range0
), ),
accessor accessor
), ))
SynExpr.CreateApp ( (SynExpr.applyFunction
SynExpr.CreateLongIdent (SynLongIdent.CreateString "Option.defaultWith"), (SynExpr.createLongIdent [ "Option" ; "defaultWith" ])
SynExpr.CreateLongIdent ( (SynExpr.createLongIdent' (
SynLongIdent.CreateFromLongIdent ( withoutOptionsType
withoutOptionsType @ [ Ident.create (sprintf "Default%s" fieldData.Ident.idText) ]
@ [ Ident.Create (sprintf "Default%s" fieldData.Ident.idText) ] )))
)
)
)
)
| _ -> accessor | _ -> accessor
(SynLongIdent.CreateFromLongIdent [ fieldData.Ident ], true), Some body (SynLongIdent.createI fieldData.Ident, true), Some body
) )
|> AstHelper.instantiateRecord |> AstHelper.instantiateRecord
let pattern =
SynPat.LongIdent (
SynLongIdent.CreateFromLongIdent [ functionName ],
None,
None,
SynArgPats.Pats
[
SynPat.CreateTyped (
SynPat.CreateNamed inputArg,
SynType.LongIdent (SynLongIdent.CreateFromLongIdent withoutOptionsType)
)
|> SynPat.CreateParen
],
None,
range0
)
let binding = let binding =
SynBinding.Let ( SynBinding.basic
isInline = false, (SynLongIdent.createI functionName)
isMutable = false, [
xmldoc = xmlDoc, SynPat.named inputArg.idText
returnInfo = returnInfo, |> SynPat.annotateType (SynType.LongIdent (SynLongIdent.create withoutOptionsType))
expr = body, ]
valData = inputVal, body
pattern = pattern |> SynBinding.withXmlDoc xmlDoc
) |> SynBinding.withReturnAnnotation (SynType.LongIdent (SynLongIdent.create withOptionsType))
SynModuleDecl.CreateLet [ binding ] SynModuleDecl.CreateLet [ binding ]
@@ -167,24 +136,21 @@ module internal RemoveOptionsGenerator =
let decls = let decls =
[ [
createType (Some doc) accessibility typeParams fields createType (Some doc) accessibility typeParams fields
createMaker [ Ident.Create "Short" ] recordId fieldData createMaker [ Ident.create "Short" ] recordId fieldData
]
let attributes =
[
SynAttributeList.Create (SynAttribute.RequireQualifiedAccess ())
SynAttributeList.Create SynAttribute.compilationRepresentation
] ]
let xmlDoc = let xmlDoc =
recordId recordId
|> Seq.map (fun i -> i.idText) |> Seq.map (fun i -> i.idText)
|> String.concat "." |> String.concat "."
|> sprintf " Module containing an option-truncated version of the %s type" |> sprintf "Module containing an option-truncated version of the %s type"
|> PreXmlDoc.Create |> PreXmlDoc.create
let info = let info =
SynComponentInfo.Create (recordId, attributes = attributes, xmldoc = xmlDoc) SynComponentInfo.createLong recordId
|> SynComponentInfo.withDocString xmlDoc
|> SynComponentInfo.addAttributes [ SynAttribute.compilationRepresentation ]
|> SynComponentInfo.addAttributes [ SynAttribute.RequireQualifiedAccess () ]
let mdl = SynModuleDecl.CreateNestedModule (info, decls) let mdl = SynModuleDecl.CreateNestedModule (info, decls)

View File

@@ -0,0 +1,49 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
type internal CompExprBinding =
| LetBang of varName : string * rhs : SynExpr
| Let of varName : string * rhs : SynExpr
| Use of varName : string * rhs : SynExpr
| Do of body : SynExpr
(*
Potential API!
type internal CompExprBindings =
private
{
/// These are stored in reverse.
Bindings : CompExprBinding list
CompExprName : string
}
[<RequireQualifiedAccess>]
module internal CompExprBindings =
let make (name : string) : CompExprBindings =
{
Bindings = []
CompExprName = name
}
let thenDo (body : SynExpr) (bindings : CompExprBindings) =
{ bindings with
Bindings = (Do body :: bindings.Bindings)
}
let thenLet (varName : string) (value : SynExpr) (bindings : CompExprBindings) =
{ bindings with
Bindings = (Let (varName, value) :: bindings.Bindings)
}
let thenLetBang (varName : string) (value : SynExpr) (bindings : CompExprBindings) =
{ bindings with
Bindings = (LetBang (varName, value) :: bindings.Bindings)
}
let thenUse (varName : string) (value : SynExpr) (bindings : CompExprBindings) =
{ bindings with
Bindings = (LetBang (varName, value) :: bindings.Bindings)
}
*)

View File

@@ -3,12 +3,14 @@ namespace WoofWare.Myriad.Plugins
open System open System
open System.Text open System.Text
open Fantomas.FCS.Syntax open Fantomas.FCS.Syntax
open Myriad.Core open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>] [<RequireQualifiedAccess>]
module internal Ident = module internal Ident =
let inline create (s : string) = Ident (s, range0)
let lowerFirstLetter (x : Ident) : Ident = let lowerFirstLetter (x : Ident) : Ident =
let result = StringBuilder x.idText.Length let result = StringBuilder x.idText.Length
result.Append (Char.ToLowerInvariant x.idText.[0]) |> ignore result.Append (Char.ToLowerInvariant x.idText.[0]) |> ignore
result.Append x.idText.[1..] |> ignore result.Append x.idText.[1..] |> ignore
Ident.Create ((result : StringBuilder).ToString ()) create ((result : StringBuilder).ToString ())

View File

@@ -0,0 +1,9 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Xml
open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
module internal PreXmlDoc =
let create (s : string) : PreXmlDoc =
PreXmlDoc.Create ([| " " + s |], range0)

View File

@@ -8,11 +8,11 @@ open Myriad.Core
module internal SynAttribute = module internal SynAttribute =
let internal compilationRepresentation : SynAttribute = let internal compilationRepresentation : SynAttribute =
{ {
TypeName = SynLongIdent.CreateString "CompilationRepresentation" TypeName = SynLongIdent.createS "CompilationRepresentation"
ArgExpr = ArgExpr =
SynExpr.CreateLongIdent ( SynExpr.CreateLongIdent (
false, false,
SynLongIdent.Create [ "CompilationRepresentationFlags" ; "ModuleSuffix" ], SynLongIdent.createS' [ "CompilationRepresentationFlags" ; "ModuleSuffix" ],
None None
) )
|> SynExpr.CreateParen |> SynExpr.CreateParen
@@ -23,7 +23,7 @@ module internal SynAttribute =
let internal autoOpen : SynAttribute = let internal autoOpen : SynAttribute =
{ {
TypeName = SynLongIdent.CreateString "AutoOpen" TypeName = SynLongIdent.createS "AutoOpen"
ArgExpr = SynExpr.CreateConst SynConst.Unit ArgExpr = SynExpr.CreateConst SynConst.Unit
Target = None Target = None
AppliesToGetterAndSetter = false AppliesToGetterAndSetter = false

View File

@@ -0,0 +1,50 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.Xml
open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
module internal SynComponentInfo =
let inline createLong (name : LongIdent) =
SynComponentInfo.SynComponentInfo ([], None, [], name, PreXmlDoc.Empty, false, None, range0)
let inline create (name : Ident) = createLong [ name ]
let inline withDocString (doc : PreXmlDoc) (i : SynComponentInfo) : SynComponentInfo =
match i with
| SynComponentInfo.SynComponentInfo (attrs, typars, constraints, name, _, postfix, access, range) ->
SynComponentInfo (attrs, typars, constraints, name, doc, postfix, access, range)
let inline setGenerics (typars : SynTyparDecls option) (i : SynComponentInfo) : SynComponentInfo =
match i with
| SynComponentInfo.SynComponentInfo (attrs, _, constraints, name, doc, postfix, access, range) ->
SynComponentInfo (attrs, typars, constraints, name, doc, postfix, access, range)
let inline withGenerics (typars : SynTyparDecl list) (i : SynComponentInfo) : SynComponentInfo =
let inner =
if typars.IsEmpty then
None
else
Some (SynTyparDecls.PostfixList (typars, [], range0))
setGenerics inner i
let inline setAccessibility (acc : SynAccess option) (i : SynComponentInfo) : SynComponentInfo =
match i with
| SynComponentInfo.SynComponentInfo (attrs, typars, constraints, name, doc, postfix, _, range) ->
SynComponentInfo.SynComponentInfo (attrs, typars, constraints, name, doc, postfix, acc, range)
let inline withAccessibility (acc : SynAccess) (i : SynComponentInfo) : SynComponentInfo =
setAccessibility (Some acc) i
let inline addAttributes (attrs : SynAttribute list) (i : SynComponentInfo) : SynComponentInfo =
match i with
| SynComponentInfo.SynComponentInfo (oldAttrs, typars, constraints, name, doc, postfix, acc, range) ->
let attrs =
{
SynAttributeList.Attributes = attrs
SynAttributeList.Range = range0
}
SynComponentInfo.SynComponentInfo ((attrs :: oldAttrs), typars, constraints, name, doc, postfix, acc, range)

View File

@@ -3,14 +3,18 @@ namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia open Fantomas.FCS.SyntaxTrivia
open Myriad.Core open Myriad.Core
open Myriad.Core.Ast
open Fantomas.FCS.Text.Range open Fantomas.FCS.Text.Range
type internal CompExprBinding = [<AutoOpen>]
| LetBang of varName : string * rhs : SynExpr module internal SynExprExtensions =
| Let of varName : string * rhs : SynExpr type SynExpr with
| Use of varName : string * rhs : SynExpr static member CreateConst (s : string) : SynExpr =
| Do of body : SynExpr SynExpr.Const (SynConst.String (s, SynStringKind.Regular, range0), range0)
static member CreateConst () : SynExpr = SynExpr.Const (SynConst.Unit, range0)
static member CreateConst (i : int32) : SynExpr =
SynExpr.Const (SynConst.Int32 i, range0)
[<RequireQualifiedAccess>] [<RequireQualifiedAccess>]
module internal SynExpr = module internal SynExpr =
@@ -58,7 +62,7 @@ module internal SynExpr =
/// try {body} with | {exc} as exc -> {handler} /// try {body} with | {exc} as exc -> {handler}
let pipeThroughTryWith (exc : SynPat) (handler : SynExpr) (body : SynExpr) : SynExpr = let pipeThroughTryWith (exc : SynPat) (handler : SynExpr) (body : SynExpr) : SynExpr =
let clause = let clause =
SynMatchClause.Create (SynPat.As (exc, SynPat.CreateNamed (Ident.Create "exc"), range0), None, handler) SynMatchClause.create (SynPat.As (exc, SynPat.named "exc", range0)) handler
SynExpr.TryWith ( SynExpr.TryWith (
body, body,
@@ -119,24 +123,24 @@ module internal SynExpr =
/// {obj}.{meth}() /// {obj}.{meth}()
let callMethod (meth : string) (obj : SynExpr) : SynExpr = let callMethod (meth : string) (obj : SynExpr) : SynExpr =
callMethodArg meth (SynExpr.CreateConst SynConst.Unit) obj callMethodArg meth (SynExpr.CreateConst ()) obj
let callGenericMethod (meth : string) (ty : LongIdent) (obj : SynExpr) : SynExpr = let callGenericMethod (meth : string) (ty : LongIdent) (obj : SynExpr) : SynExpr =
SynExpr.TypeApp ( SynExpr.TypeApp (
SynExpr.DotGet (obj, range0, SynLongIdent.Create [ meth ], range0), SynExpr.DotGet (obj, range0, SynLongIdent.createS meth, range0),
range0, range0,
[ SynType.LongIdent (SynLongIdent.CreateFromLongIdent ty) ], [ SynType.LongIdent (SynLongIdent.create ty) ],
[], [],
Some range0, Some range0,
range0, range0,
range0 range0
) )
|> applyTo (SynExpr.CreateConst SynConst.Unit) |> applyTo (SynExpr.CreateConst ())
/// {obj}.{meth}<ty>() /// {obj}.{meth}<ty>()
let callGenericMethod' (meth : string) (ty : string) (obj : SynExpr) : SynExpr = let callGenericMethod' (meth : string) (ty : string) (obj : SynExpr) : SynExpr =
SynExpr.TypeApp ( SynExpr.TypeApp (
SynExpr.DotGet (obj, range0, SynLongIdent.Create [ meth ], range0), SynExpr.DotGet (obj, range0, SynLongIdent.createS meth, range0),
range0, range0,
[ SynType.CreateLongIdent ty ], [ SynType.CreateLongIdent ty ],
[], [],
@@ -144,14 +148,14 @@ module internal SynExpr =
range0, range0,
range0 range0
) )
|> applyTo (SynExpr.CreateConst SynConst.Unit) |> applyTo (SynExpr.CreateConst ())
let index (property : SynExpr) (obj : SynExpr) : SynExpr = let index (property : SynExpr) (obj : SynExpr) : SynExpr =
SynExpr.DotIndexedGet (obj, property, range0, range0) SynExpr.DotIndexedGet (obj, property, range0, range0)
/// (fun {varName} -> {body}) /// (fun {varName} -> {body})
let createLambda (varName : string) (body : SynExpr) : SynExpr = let createLambda (varName : string) (body : SynExpr) : SynExpr =
let parsedDataPat = [ SynPat.CreateNamed (Ident.Create varName) ] let parsedDataPat = [ SynPat.named varName ]
SynExpr.Lambda ( SynExpr.Lambda (
false, false,
@@ -166,38 +170,66 @@ module internal SynExpr =
) )
|> SynExpr.CreateParen |> SynExpr.CreateParen
let reraise : SynExpr = let createThunk (body : SynExpr) : SynExpr =
SynExpr.CreateIdent (Ident.Create "reraise") let parsedDataPat = [ SynPat.Const (SynConst.Unit, range0) ]
|> applyTo (SynExpr.CreateConst SynConst.Unit)
SynExpr.Lambda (
false,
false,
SynSimplePats.Create [],
body,
Some (parsedDataPat, body),
range0,
{
ArrowRange = Some range0
}
)
|> SynExpr.CreateParen
/// {body} |> fun a -> Async.StartAsTask (a, ?cancellationToken=ct) /// {body} |> fun a -> Async.StartAsTask (a, ?cancellationToken=ct)
let startAsTask (ct : SynLongIdent) (body : SynExpr) = let startAsTask (ct : SynLongIdent) (body : SynExpr) =
let lambda = let lambda =
[ [
SynExpr.CreateLongIdent (SynLongIdent.CreateString "a") SynExpr.CreateLongIdent (SynLongIdent.createS "a")
equals equals
(SynExpr.LongIdent (true, SynLongIdent.CreateString "cancellationToken", None, range0)) (SynExpr.LongIdent (true, SynLongIdent.createS "cancellationToken", None, range0))
(SynExpr.CreateLongIdent ct) (SynExpr.CreateLongIdent ct)
] ]
|> SynExpr.CreateParenedTuple |> SynExpr.CreateParenedTuple
|> applyFunction (SynExpr.CreateLongIdent (SynLongIdent.Create [ "Async" ; "StartAsTask" ])) |> applyFunction (SynExpr.CreateLongIdent (SynLongIdent.createS' [ "Async" ; "StartAsTask" ]))
|> createLambda "a" |> createLambda "a"
pipeThroughFunction lambda body pipeThroughFunction lambda body
let createLongIdent (ident : string list) : SynExpr = let inline createIdent (s : string) : SynExpr = SynExpr.Ident (Ident (s, range0))
SynExpr.CreateLongIdent (SynLongIdent.Create ident)
let createLongIdent' (ident : Ident list) : SynExpr = let inline createIdent' (i : Ident) : SynExpr = SynExpr.Ident i
SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent ident)
let createLet (bindings : SynBinding list) (body : SynExpr) : SynExpr = let inline createLongIdent (ident : string list) : SynExpr =
SynExpr.CreateLongIdent (SynLongIdent.createS' ident)
let inline createLongIdent' (ident : Ident list) : SynExpr =
SynExpr.CreateLongIdent (SynLongIdent.create ident)
let inline createLet (bindings : SynBinding list) (body : SynExpr) : SynExpr =
SynExpr.LetOrUse (false, false, bindings, body, range0, SynExprLetOrUseTrivia.empty) SynExpr.LetOrUse (false, false, bindings, body, range0, SynExprLetOrUseTrivia.empty)
let createMatch (matchOn : SynExpr) (cases : SynMatchClause list) : SynExpr = SynExpr.CreateMatch (matchOn, cases) let inline createMatch (matchOn : SynExpr) (cases : SynMatchClause list) : SynExpr =
SynExpr.CreateMatch (matchOn, cases)
let typeAnnotate (ty : SynType) (expr : SynExpr) : SynExpr = SynExpr.CreateTyped (expr, ty) let typeAnnotate (ty : SynType) (expr : SynExpr) : SynExpr = SynExpr.CreateTyped (expr, ty)
let inline paren (e : SynExpr) : SynExpr =
SynExpr.Paren (e, range0, Some range0, range0)
let inline createNew (ty : SynType) (args : SynExpr) : SynExpr =
SynExpr.New (false, ty, paren args, range0)
let inline createWhile (cond : SynExpr) (body : SynExpr) : SynExpr =
SynExpr.While (DebugPointAtWhile.Yes range0, cond, body, range0)
let reraise : SynExpr = createIdent "reraise" |> applyTo (SynExpr.CreateConst ())
/// {compExpr} { {lets} ; return {ret} } /// {compExpr} { {lets} ; return {ret} }
let createCompExpr (compExpr : string) (retBody : SynExpr) (lets : CompExprBinding list) : SynExpr = let createCompExpr (compExpr : string) (retBody : SynExpr) (lets : CompExprBinding list) : SynExpr =
let retStatement = SynExpr.YieldOrReturn ((false, true), retBody, range0) let retStatement = SynExpr.YieldOrReturn ((false, true), retBody, range0)
@@ -211,7 +243,7 @@ module internal SynExpr =
DebugPointAtBinding.Yes range0, DebugPointAtBinding.Yes range0,
false, false,
true, true,
SynPat.CreateNamed (Ident.Create lhs), SynPat.named lhs,
rhs, rhs,
[], [],
state, state,
@@ -220,13 +252,12 @@ module internal SynExpr =
EqualsRange = Some range0 EqualsRange = Some range0
} }
) )
| Let (lhs, rhs) -> | Let (lhs, rhs) -> createLet [ SynBinding.basic (SynLongIdent.createS lhs) [] rhs ] state
createLet [ SynBinding.Let (pattern = SynPat.CreateNamed (Ident.Create lhs), expr = rhs) ] state
| Use (lhs, rhs) -> | Use (lhs, rhs) ->
SynExpr.LetOrUse ( SynExpr.LetOrUse (
false, false,
true, true,
[ SynBinding.Let (pattern = SynPat.CreateNamed (Ident.Create lhs), expr = rhs) ], [ SynBinding.basic (SynLongIdent.createS lhs) [] rhs ],
state, state,
range0, range0,
{ {
@@ -243,17 +274,14 @@ module internal SynExpr =
/// {expr} |> Async.AwaitTask /// {expr} |> Async.AwaitTask
let awaitTask (expr : SynExpr) : SynExpr = let awaitTask (expr : SynExpr) : SynExpr =
expr expr |> pipeThroughFunction (createLongIdent [ "Async" ; "AwaitTask" ])
|> pipeThroughFunction (SynExpr.CreateLongIdent (SynLongIdent.Create [ "Async" ; "AwaitTask" ]))
/// {ident}.ToString () /// {ident}.ToString ()
/// with special casing for some types like DateTime /// with special casing for some types like DateTime
let toString (ty : SynType) (ident : SynExpr) = let toString (ty : SynType) (ident : SynExpr) =
match ty with match ty with
| DateOnly -> ident |> callMethodArg "ToString" (SynExpr.CreateConstString "yyyy-MM-dd") | DateOnly -> ident |> callMethodArg "ToString" (SynExpr.CreateConst "yyyy-MM-dd")
| DateTime -> | DateTime -> ident |> callMethodArg "ToString" (SynExpr.CreateConst "yyyy-MM-ddTHH:mm:ss")
ident
|> callMethodArg "ToString" (SynExpr.CreateConstString "yyyy-MM-ddTHH:mm:ss")
| _ -> callMethod "ToString" ident | _ -> callMethod "ToString" ident
let upcast' (ty : SynType) (e : SynExpr) = SynExpr.Upcast (e, ty, range0) let upcast' (ty : SynType) (e : SynExpr) = SynExpr.Upcast (e, ty, range0)
@@ -275,8 +303,7 @@ module internal SynExpr =
) )
/// {ident} - {n} /// {ident} - {n}
let minusN (ident : SynLongIdent) (n : int) : SynExpr = let minusN (ident : SynLongIdent) (n : int) : SynExpr = minus ident (SynExpr.CreateConst n)
minus ident (SynExpr.CreateConst (SynConst.Int32 n))
/// {y} > {x} /// {y} > {x}
let greaterThan (x : SynExpr) (y : SynExpr) : SynExpr = let greaterThan (x : SynExpr) (y : SynExpr) : SynExpr =

View File

@@ -0,0 +1,83 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Text.Range
open Fantomas.FCS.Syntax
[<RequireQualifiedAccess>]
module internal SynLongIdent =
let create (ident : LongIdent) : SynLongIdent =
let commas =
match ident with
| [] -> []
| _ :: commas -> commas |> List.map (fun _ -> range0)
SynLongIdent.SynLongIdent (ident, commas, List.replicate ident.Length None)
let inline createI (i : Ident) : SynLongIdent = create [ i ]
let inline createS (s : string) : SynLongIdent = createI (Ident (s, range0))
let inline createS' (s : string list) : SynLongIdent =
create (s |> List.map (fun i -> Ident (i, range0)))
let isUnit (ident : SynLongIdent) : bool =
match ident.LongIdent with
| [ i ] when System.String.Equals (i.idText, "unit", System.StringComparison.OrdinalIgnoreCase) -> true
| _ -> false
let isList (ident : SynLongIdent) : bool =
match ident.LongIdent with
| [ i ] when System.String.Equals (i.idText, "list", System.StringComparison.OrdinalIgnoreCase) -> true
// TODO: consider FSharpList or whatever it is
| _ -> false
let isArray (ident : SynLongIdent) : bool =
match ident.LongIdent with
| [ i ] when
System.String.Equals (i.idText, "array", System.StringComparison.OrdinalIgnoreCase)
|| System.String.Equals (i.idText, "[]", System.StringComparison.Ordinal)
->
true
| _ -> false
let isOption (ident : SynLongIdent) : bool =
match ident.LongIdent with
| [ i ] when System.String.Equals (i.idText, "option", System.StringComparison.OrdinalIgnoreCase) -> true
// TODO: consider Microsoft.FSharp.Option or whatever it is
| _ -> false
let isResponse (ident : SynLongIdent) : bool =
match ident.LongIdent |> List.map _.idText with
| [ "Response" ]
| [ "RestEase" ; "Response" ] -> true
| _ -> false
let isMap (ident : SynLongIdent) : bool =
match ident.LongIdent |> List.map _.idText with
| [ "Map" ] -> true
| _ -> false
let isReadOnlyDictionary (ident : SynLongIdent) : bool =
match ident.LongIdent |> List.map _.idText with
| [ "IReadOnlyDictionary" ]
| [ "Generic" ; "IReadOnlyDictionary" ]
| [ "Collections" ; "Generic" ; "IReadOnlyDictionary" ]
| [ "System" ; "Collections" ; "Generic" ; "IReadOnlyDictionary" ] -> true
| _ -> false
let isDictionary (ident : SynLongIdent) : bool =
match ident.LongIdent |> List.map _.idText with
| [ "Dictionary" ]
| [ "Generic" ; "Dictionary" ]
| [ "Collections" ; "Generic" ; "Dictionary" ]
| [ "System" ; "Collections" ; "Generic" ; "Dictionary" ] -> true
| _ -> false
let isIDictionary (ident : SynLongIdent) : bool =
match ident.LongIdent |> List.map _.idText with
| [ "IDictionary" ]
| [ "Generic" ; "IDictionary" ]
| [ "Collections" ; "Generic" ; "IDictionary" ]
| [ "System" ; "Collections" ; "Generic" ; "IDictionary" ] -> true
| _ -> false

View File

@@ -0,0 +1,24 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
module internal SynMatchClause =
let create (lhs : SynPat) (rhs : SynExpr) : SynMatchClause =
SynMatchClause.SynMatchClause (
lhs,
None,
rhs,
range0,
DebugPointAtTarget.Yes,
{
ArrowRange = Some range0
BarRange = Some range0
}
)
let withWhere (where : SynExpr) (m : SynMatchClause) : SynMatchClause =
match m with
| SynMatchClause (synPat, _, resultExpr, range, debugPointAtTarget, synMatchClauseTrivia) ->
SynMatchClause (synPat, Some where, resultExpr, range, debugPointAtTarget, synMatchClauseTrivia)

View File

@@ -0,0 +1,61 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia
open Fantomas.FCS.Text.Range
open Fantomas.FCS.Xml
[<RequireQualifiedAccess>]
module internal SynMemberDefn =
let private interfaceMemberSlotFlags =
{
SynMemberFlags.IsInstance = true
SynMemberFlags.IsDispatchSlot = true
SynMemberFlags.IsOverrideOrExplicitImpl = false
SynMemberFlags.IsFinal = false
SynMemberFlags.GetterOrSetterIsCompilerGenerated = false
SynMemberFlags.MemberKind = SynMemberKind.Member
}
let abstractMember
(ident : SynIdent)
(typars : SynTyparDecls option)
(arity : SynValInfo)
(xmlDoc : PreXmlDoc)
(returnType : SynType)
: SynMemberDefn
=
let slot =
SynValSig.SynValSig (
[],
ident,
SynValTyparDecls.SynValTyparDecls (typars, true),
returnType,
arity,
false,
false,
xmlDoc,
None,
None,
range0,
{
EqualsRange = None
WithKeyword = None
InlineKeyword = None
LeadingKeyword = SynLeadingKeyword.Abstract range0
}
)
SynMemberDefn.AbstractSlot (
slot,
interfaceMemberSlotFlags,
range0,
{
GetSetKeywords = None
}
)
let staticMember (binding : SynBinding) : SynMemberDefn =
let binding = SynBinding.makeStaticMember binding
SynMemberDefn.Member (binding, range0)

View File

@@ -8,3 +8,9 @@ module internal SynPat =
let annotateType (ty : SynType) (pat : SynPat) = let annotateType (ty : SynType) (pat : SynPat) =
SynPat.Paren (SynPat.Typed (pat, ty, range0), range0) SynPat.Paren (SynPat.Typed (pat, ty, range0), range0)
let named (s : string) : SynPat =
SynPat.Named (SynIdent.SynIdent (Ident (s, range0), None), false, None, range0)
let namedI (i : Ident) : SynPat =
SynPat.Named (SynIdent.SynIdent (i, None), false, None, range0)

View File

@@ -1,6 +1,7 @@
namespace WoofWare.Myriad.Plugins namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax open Fantomas.FCS.Syntax
open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>] [<RequireQualifiedAccess>]
module internal SynType = module internal SynType =
@@ -8,3 +9,224 @@ module internal SynType =
match ty with match ty with
| SynType.Paren (ty, _) -> stripOptionalParen ty | SynType.Paren (ty, _) -> stripOptionalParen ty
| ty -> ty | ty -> ty
let inline createLongIdent (ident : LongIdent) : SynType =
SynType.LongIdent (SynLongIdent.create ident)
let inline createLongIdent' (ident : string list) : SynType =
SynType.LongIdent (SynLongIdent.createS' ident)
let inline named (name : string) = createLongIdent' [ name ]
let inline app' (name : SynType) (args : SynType list) : SynType =
if args.IsEmpty then
failwith "Type cannot be applied to no arguments"
SynType.App (name, Some range0, args, List.replicate (args.Length - 1) range0, Some range0, false, range0)
let inline app (name : string) (args : SynType list) : SynType = app' (named name) args
let inline appPostfix (name : string) (arg : SynType) : SynType =
SynType.App (named name, None, [ arg ], [], None, true, range0)
let inline funFromDomain (domain : SynType) (range : SynType) : SynType =
SynType.Fun (
domain,
range,
range0,
{
ArrowRange = range0
}
)
let inline signatureParamOfType (ty : SynType) (name : Ident option) : SynType =
SynType.SignatureParameter ([], false, name, ty, range0)
let inline var (ty : SynTypar) : SynType = SynType.Var (ty, range0)
[<AutoOpen>]
module internal SynTypePatterns =
let (|OptionType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ innerType ], _, _, _, _) when SynLongIdent.isOption ident ->
Some innerType
| _ -> None
let (|UnitType|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident when SynLongIdent.isUnit ident -> Some ()
| _ -> None
let (|ListType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ innerType ], _, _, _, _) when SynLongIdent.isList ident ->
Some innerType
| _ -> None
let (|ArrayType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ innerType ], _, _, _, _) when SynLongIdent.isArray ident ->
Some innerType
| SynType.Array (1, innerType, _) -> Some innerType
| _ -> None
let (|RestEaseResponseType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ innerType ], _, _, _, _) when SynLongIdent.isResponse ident ->
Some innerType
| _ -> None
let (|DictionaryType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ key ; value ], _, _, _, _) when SynLongIdent.isDictionary ident ->
Some (key, value)
| _ -> None
let (|IDictionaryType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ key ; value ], _, _, _, _) when SynLongIdent.isIDictionary ident ->
Some (key, value)
| _ -> None
let (|IReadOnlyDictionaryType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ key ; value ], _, _, _, _) when
SynLongIdent.isReadOnlyDictionary ident
->
Some (key, value)
| _ -> None
let (|MapType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ key ; value ], _, _, _, _) when SynLongIdent.isMap ident ->
Some (key, value)
| _ -> None
let (|BigInt|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent |> List.map _.idText with
| [ "bigint" ]
| [ "BigInteger" ]
| [ "Numerics" ; "BigInteger" ]
| [ "System" ; "Numerics" ; "BigInteger" ] -> Some ()
| _ -> None
| _ -> None
/// Returns the type, qualified as in e.g. `System.Boolean`.
let (|PrimitiveType|_|) (fieldType : SynType) : LongIdent option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent with
| [ i ] -> Primitives.qualifyType i.idText
| _ -> None
| _ -> None
let (|String|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent with
| [ i ] ->
[ "string" ]
|> List.tryFind (fun s -> s = i.idText)
|> Option.map ignore<string>
| _ -> None
| _ -> None
let (|Byte|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent with
| [ i ] -> [ "byte" ] |> List.tryFind (fun s -> s = i.idText) |> Option.map ignore<string>
| _ -> None
| _ -> None
let (|Guid|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent |> List.map (fun i -> i.idText) with
| [ "System" ; "Guid" ]
| [ "Guid" ] -> Some ()
| _ -> None
| _ -> None
let (|HttpResponseMessage|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent |> List.map (fun i -> i.idText) with
| [ "System" ; "Net" ; "Http" ; "HttpResponseMessage" ]
| [ "Net" ; "Http" ; "HttpResponseMessage" ]
| [ "Http" ; "HttpResponseMessage" ]
| [ "HttpResponseMessage" ] -> Some ()
| _ -> None
| _ -> None
let (|HttpContent|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent |> List.map (fun i -> i.idText) with
| [ "System" ; "Net" ; "Http" ; "HttpContent" ]
| [ "Net" ; "Http" ; "HttpContent" ]
| [ "Http" ; "HttpContent" ]
| [ "HttpContent" ] -> Some ()
| _ -> None
| _ -> None
let (|Stream|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent |> List.map (fun i -> i.idText) with
| [ "System" ; "IO" ; "Stream" ]
| [ "IO" ; "Stream" ]
| [ "Stream" ] -> Some ()
| _ -> None
| _ -> None
let (|NumberType|_|) (fieldType : SynType) =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent with
| [ i ] -> [ "string" ; "float" ; "int" ; "bool" ] |> List.tryFind (fun s -> s = i.idText)
| _ -> None
| _ -> None
let (|DateOnly|_|) (fieldType : SynType) =
match fieldType with
| SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->
match ident |> List.map (fun i -> i.idText) with
| [ "System" ; "DateOnly" ]
| [ "DateOnly" ] -> Some ()
| _ -> None
| _ -> None
let (|DateTime|_|) (fieldType : SynType) =
match fieldType with
| SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->
match ident |> List.map (fun i -> i.idText) with
| [ "System" ; "DateTime" ]
| [ "DateTime" ] -> Some ()
| _ -> None
| _ -> None
let (|Uri|_|) (fieldType : SynType) =
match fieldType with
| SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->
match ident |> List.map (fun i -> i.idText) with
| [ "System" ; "Uri" ]
| [ "Uri" ] -> Some ()
| _ -> None
| _ -> None
let (|Task|_|) (fieldType : SynType) : SynType option =
match fieldType with
| SynType.App (SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)), _, args, _, _, _, _) ->
match ident |> List.map (fun i -> i.idText) with
| [ "Task" ]
| [ "Tasks" ; "Task" ]
| [ "Threading" ; "Tasks" ; "Task" ]
| [ "System" ; "Threading" ; "Tasks" ; "Task" ] ->
match args with
| [ arg ] -> Some arg
| _ -> failwithf "Expected Task to be applied to exactly one arg, but got: %+A" args
| _ -> None
| _ -> None

View File

@@ -0,0 +1,27 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia
open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
module internal SynTypeDefn =
let inline create (componentInfo : SynComponentInfo) (repr : SynTypeDefnRepr) : SynTypeDefn =
SynTypeDefn.SynTypeDefn (
componentInfo,
repr,
[],
None,
range0,
{
LeadingKeyword = SynTypeDefnLeadingKeyword.Type range0
EqualsRange = Some range0
WithKeyword = None
}
)
let inline withMemberDefns (members : SynMemberDefn list) (r : SynTypeDefn) : SynTypeDefn =
match r with
| SynTypeDefn (typeInfo, typeRepr, _, ctor, range, trivia) ->
SynTypeDefn.SynTypeDefn (typeInfo, typeRepr, members, ctor, range, trivia)

View File

@@ -0,0 +1,20 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
module internal SynTypeDefnRepr =
let inline interfaceType (mems : SynMemberDefns) : SynTypeDefnRepr =
SynTypeDefnRepr.ObjectModel (SynTypeDefnKind.Unspecified, mems, range0)
/// Indicates the body of a `type Foo with {body}` extension type declaration.
let inline augmentation () : SynTypeDefnRepr =
SynTypeDefnRepr.ObjectModel (SynTypeDefnKind.Augmentation range0, [], range0)
let inline union (cases : SynUnionCase list) : SynTypeDefnRepr =
SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (None, cases, range0), range0)
let inline record (fields : SynField list) : SynTypeDefnRepr =
SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (None, fields, range0), range0)

View File

@@ -9,6 +9,15 @@ type internal UnionCase<'Ident> =
Ident : Ident Ident : Ident
} }
[<RequireQualifiedAccess>]
module internal UnionCase =
let mapIdentFields<'a, 'b> (f : 'a -> 'b) (unionCase : UnionCase<'a>) : UnionCase<'b> =
{
Fields = unionCase.Fields |> List.map (SynField.mapIdent f)
Attrs = unionCase.Attrs
Ident = unionCase.Ident
}
[<RequireQualifiedAccess>] [<RequireQualifiedAccess>]
module internal SynUnionCase = module internal SynUnionCase =
let extract (SynUnionCase (attrs, id, caseType, _, _, _, _)) : UnionCase<Ident option> = let extract (SynUnionCase (attrs, id, caseType, _, _, _, _)) : UnionCase<Ident option> =

View File

@@ -25,17 +25,26 @@
<ItemGroup> <ItemGroup>
<Compile Include="List.fs"/> <Compile Include="List.fs"/>
<Compile Include="Ident.fs" /> <Compile Include="Primitives.fs" />
<Compile Include="AstHelper.fs"/> <Compile Include="SynExpr\PreXmlDoc.fs" />
<Compile Include="SynExpr\Ident.fs" />
<Compile Include="SynExpr\SynLongIdent.fs" />
<Compile Include="SynExpr\SynExprLetOrUseTrivia.fs" /> <Compile Include="SynExpr\SynExprLetOrUseTrivia.fs" />
<Compile Include="SynExpr\SynBinding.fs" /> <Compile Include="SynExpr\SynBinding.fs" />
<Compile Include="SynExpr\SynExpr.fs" />
<Compile Include="SynExpr\SynType.fs" /> <Compile Include="SynExpr\SynType.fs" />
<Compile Include="SynExpr\SynMatchClause.fs" />
<Compile Include="SynExpr\SynPat.fs" />
<Compile Include="SynExpr\CompExpr.fs" />
<Compile Include="SynExpr\SynExpr.fs" />
<Compile Include="SynExpr\SynAttribute.fs" /> <Compile Include="SynExpr\SynAttribute.fs" />
<Compile Include="SynExpr\SynArgPats.fs" /> <Compile Include="SynExpr\SynArgPats.fs" />
<Compile Include="SynExpr\SynField.fs" /> <Compile Include="SynExpr\SynField.fs" />
<Compile Include="SynExpr\SynUnionCase.fs" /> <Compile Include="SynExpr\SynUnionCase.fs" />
<Compile Include="SynExpr\SynPat.fs" /> <Compile Include="SynExpr\SynTypeDefnRepr.fs" />
<Compile Include="SynExpr\SynTypeDefn.fs" />
<Compile Include="SynExpr\SynComponentInfo.fs" />
<Compile Include="SynExpr\SynMemberDefn.fs" />
<Compile Include="AstHelper.fs" />
<Compile Include="RemoveOptionsGenerator.fs"/> <Compile Include="RemoveOptionsGenerator.fs"/>
<Compile Include="InterfaceMockGenerator.fs"/> <Compile Include="InterfaceMockGenerator.fs"/>
<Compile Include="JsonSerializeGenerator.fs"/> <Compile Include="JsonSerializeGenerator.fs"/>

View File

@@ -7,6 +7,7 @@
":/", ":/",
":^WoofWare.Myriad.Plugins.Test/", ":^WoofWare.Myriad.Plugins.Test/",
":^WoofWare.Myriad.Plugins.Attributes/Test/", ":^WoofWare.Myriad.Plugins.Attributes/Test/",
":^/.github/" ":^/.github/",
":^/CHANGELOG.md"
] ]
} }