mirror of
https://github.com/Smaug123/WoofWare.Myriad
synced 2025-10-06 04:28:42 +00:00
Pull out general changes from ArgParser PR (#217)
This commit is contained in:
@@ -3,6 +3,7 @@
|
|||||||
<PropertyGroup>
|
<PropertyGroup>
|
||||||
<TargetFramework>net8.0</TargetFramework>
|
<TargetFramework>net8.0</TargetFramework>
|
||||||
<IsPackable>false</IsPackable>
|
<IsPackable>false</IsPackable>
|
||||||
|
<OtherFlags>--reflectionfree $(OtherFlags)</OtherFlags>
|
||||||
</PropertyGroup>
|
</PropertyGroup>
|
||||||
<ItemGroup>
|
<ItemGroup>
|
||||||
<MyriadSdkGenerator Include="$(MSBuildThisFileDirectory)..\WoofWare.Myriad.Plugins\bin\$(Configuration)\net6.0\WoofWare.Myriad.Plugins.dll"/>
|
<MyriadSdkGenerator Include="$(MSBuildThisFileDirectory)..\WoofWare.Myriad.Plugins\bin\$(Configuration)\net6.0\WoofWare.Myriad.Plugins.dll"/>
|
||||||
@@ -56,9 +57,8 @@
|
|||||||
<ItemGroup>
|
<ItemGroup>
|
||||||
<PackageReference Include="RestEase" Version="1.6.4"/>
|
<PackageReference Include="RestEase" Version="1.6.4"/>
|
||||||
<ProjectReference Include="..\WoofWare.Myriad.Plugins.Attributes\WoofWare.Myriad.Plugins.Attributes.fsproj" />
|
<ProjectReference Include="..\WoofWare.Myriad.Plugins.Attributes\WoofWare.Myriad.Plugins.Attributes.fsproj" />
|
||||||
<ProjectReference Include="..\WoofWare.Myriad.Plugins\WoofWare.Myriad.Plugins.fsproj"/>
|
<ProjectReference Include="..\WoofWare.Myriad.Plugins\WoofWare.Myriad.Plugins.fsproj" PrivateAssets="all" />
|
||||||
<PackageReference Include="Myriad.Sdk" Version="0.8.3"/>
|
<PackageReference Include="Myriad.Sdk" Version="0.8.3" PrivateAssets="all" />
|
||||||
<PackageReference Include="Myriad.Core" Version="0.8.3"/>
|
|
||||||
</ItemGroup>
|
</ItemGroup>
|
||||||
|
|
||||||
</Project>
|
</Project>
|
||||||
|
@@ -30,6 +30,12 @@ type ChocolateType =
|
|||||||
| Milk
|
| Milk
|
||||||
| SeventyPercent
|
| SeventyPercent
|
||||||
|
|
||||||
|
override this.ToString () =
|
||||||
|
match this with
|
||||||
|
| ChocolateType.Dark -> "Dark"
|
||||||
|
| ChocolateType.Milk -> "Milk"
|
||||||
|
| ChocolateType.SeventyPercent -> "SeventyPercent"
|
||||||
|
|
||||||
type Chocolate =
|
type Chocolate =
|
||||||
{
|
{
|
||||||
chocType : ChocolateType
|
chocType : ChocolateType
|
||||||
@@ -43,6 +49,12 @@ type WrappingPaperStyle =
|
|||||||
| HappyHolidays
|
| HappyHolidays
|
||||||
| SolidColor
|
| SolidColor
|
||||||
|
|
||||||
|
override this.ToString () =
|
||||||
|
match this with
|
||||||
|
| WrappingPaperStyle.HappyBirthday -> "HappyBirthday"
|
||||||
|
| WrappingPaperStyle.HappyHolidays -> "HappyHolidays"
|
||||||
|
| WrappingPaperStyle.SolidColor -> "SolidColor"
|
||||||
|
|
||||||
[<CreateCatamorphism "GiftCata">]
|
[<CreateCatamorphism "GiftCata">]
|
||||||
type Gift =
|
type Gift =
|
||||||
| Book of Book
|
| Book of Book
|
||||||
|
@@ -1,9 +1,5 @@
|
|||||||
namespace ConsumePlugin
|
namespace ConsumePlugin
|
||||||
|
|
||||||
type ParseState =
|
|
||||||
| AwaitingKey
|
|
||||||
| AwaitingValue of string
|
|
||||||
|
|
||||||
/// My whatnot
|
/// My whatnot
|
||||||
[<WoofWare.Myriad.Plugins.RemoveOptions>]
|
[<WoofWare.Myriad.Plugins.RemoveOptions>]
|
||||||
type RecordType =
|
type RecordType =
|
||||||
|
@@ -43,7 +43,7 @@ module TestGift =
|
|||||||
member _.WithACard g message =
|
member _.WithACard g message =
|
||||||
$"%s{g} with a card saying '%s{message}'"
|
$"%s{g} with a card saying '%s{message}'"
|
||||||
|
|
||||||
member _.Wrapped g paper = $"%s{g} wrapped in %A{paper} paper"
|
member _.Wrapped g paper = $"%s{g} wrapped in %O{paper} paper"
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@@ -62,13 +62,46 @@ type internal InterfaceType =
|
|||||||
type internal RecordType =
|
type internal RecordType =
|
||||||
{
|
{
|
||||||
Name : Ident
|
Name : Ident
|
||||||
Fields : SynField seq
|
Fields : SynField list
|
||||||
|
/// Any additional members which are not record fields.
|
||||||
Members : SynMemberDefns option
|
Members : SynMemberDefns option
|
||||||
XmlDoc : PreXmlDoc option
|
XmlDoc : PreXmlDoc option
|
||||||
Generics : SynTyparDecls option
|
Generics : SynTyparDecls option
|
||||||
Accessibility : SynAccess option
|
Accessibility : SynAccess option
|
||||||
|
Attributes : SynAttribute list
|
||||||
}
|
}
|
||||||
|
|
||||||
|
/// Parse from the AST.
|
||||||
|
static member OfRecord (record : SynTypeDefn) : RecordType =
|
||||||
|
let sci, sdr, smd, smdo =
|
||||||
|
match record with
|
||||||
|
| SynTypeDefn.SynTypeDefn (sci, sdr, smd, smdo, _, _) -> sci, sdr, smd, smdo
|
||||||
|
|
||||||
|
let synAccessOption, recordFields =
|
||||||
|
match sdr with
|
||||||
|
| SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (sa, fields, _), _) -> sa, fields
|
||||||
|
| _ -> failwith $"expected a record; got: %+A{record}"
|
||||||
|
|
||||||
|
match sci with
|
||||||
|
| SynComponentInfo.SynComponentInfo (attrs, typars, _, longId, doc, _, access, _) ->
|
||||||
|
if access <> synAccessOption then
|
||||||
|
failwith
|
||||||
|
$"TODO what's happened, two different accessibility modifiers: %O{access} and %O{synAccessOption}"
|
||||||
|
|
||||||
|
match smdo with
|
||||||
|
| Some v -> failwith $"TODO what's happened, got a synMemberDefn of %O{v}"
|
||||||
|
| None -> ()
|
||||||
|
|
||||||
|
{
|
||||||
|
Name = List.last longId
|
||||||
|
Fields = recordFields
|
||||||
|
Members = if smd.IsEmpty then None else Some smd
|
||||||
|
XmlDoc = if doc.IsEmpty then None else Some doc
|
||||||
|
Generics = typars
|
||||||
|
Accessibility = synAccessOption
|
||||||
|
Attributes = attrs |> List.collect (fun l -> l.Attributes)
|
||||||
|
}
|
||||||
|
|
||||||
/// Anything that is part of an ADT.
|
/// Anything that is part of an ADT.
|
||||||
/// A record is a product of stuff; this type represents one of those stuffs.
|
/// A record is a product of stuff; this type represents one of those stuffs.
|
||||||
type internal AdtNode =
|
type internal AdtNode =
|
||||||
@@ -101,10 +134,10 @@ module internal AstHelper =
|
|||||||
| SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Enum _, _) -> true
|
| SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Enum _, _) -> true
|
||||||
| _ -> false
|
| _ -> false
|
||||||
|
|
||||||
let instantiateRecord (fields : (RecordFieldName * SynExpr option) list) : SynExpr =
|
let instantiateRecord (fields : (SynLongIdent * SynExpr) list) : SynExpr =
|
||||||
let fields =
|
let fields =
|
||||||
fields
|
fields
|
||||||
|> List.map (fun (rfn, synExpr) -> SynExprRecordField (rfn, Some range0, synExpr, None))
|
|> List.map (fun (rfn, synExpr) -> SynExprRecordField ((rfn, true), Some range0, Some synExpr, None))
|
||||||
|
|
||||||
SynExpr.Record (None, None, fields, range0)
|
SynExpr.Record (None, None, fields, range0)
|
||||||
|
|
||||||
|
@@ -1100,7 +1100,7 @@ module internal CataGenerator =
|
|||||||
let moduleName = parentName + "Cata" |> Ident.create
|
let moduleName = parentName + "Cata" |> Ident.create
|
||||||
|
|
||||||
let modInfo =
|
let modInfo =
|
||||||
SynComponentInfo.create (parentName + "Cata" |> Ident.create)
|
SynComponentInfo.create moduleName
|
||||||
|> SynComponentInfo.withDocString (
|
|> SynComponentInfo.withDocString (
|
||||||
PreXmlDoc.Create $" Methods to perform a catamorphism over the type %s{parentName}"
|
PreXmlDoc.Create $" Methods to perform a catamorphism over the type %s{parentName}"
|
||||||
)
|
)
|
||||||
|
@@ -257,11 +257,7 @@ module internal HttpClientGenerator =
|
|||||||
| Some id -> id
|
| Some id -> id
|
||||||
|
|
||||||
let urlSeparator =
|
let urlSeparator =
|
||||||
// apparent Myriad bug: `IndexOf '?'` gets formatted as `IndexOf ?` which is clearly wrong
|
let questionMark = SynExpr.CreateConst '?'
|
||||||
let questionMark =
|
|
||||||
SynExpr.CreateConst 63
|
|
||||||
|> SynExpr.applyFunction (SynExpr.createIdent "char")
|
|
||||||
|> SynExpr.paren
|
|
||||||
|
|
||||||
let containsQuestion =
|
let containsQuestion =
|
||||||
info.UrlTemplate
|
info.UrlTemplate
|
||||||
@@ -425,21 +421,17 @@ module internal HttpClientGenerator =
|
|||||||
(SynExpr.createIdent' bodyParamName)
|
(SynExpr.createIdent' bodyParamName)
|
||||||
)
|
)
|
||||||
Do (
|
Do (
|
||||||
SynExpr.LongIdentSet (
|
SynExpr.assign
|
||||||
SynLongIdent.createS' [ "httpMessage" ; "Content" ],
|
(SynLongIdent.createS' [ "httpMessage" ; "Content" ])
|
||||||
SynExpr.createIdent "queryParams",
|
(SynExpr.createIdent "queryParams")
|
||||||
range0
|
|
||||||
)
|
|
||||||
)
|
)
|
||||||
]
|
]
|
||||||
| BodyParamMethods.HttpContent ->
|
| BodyParamMethods.HttpContent ->
|
||||||
[
|
[
|
||||||
Do (
|
Do (
|
||||||
SynExpr.LongIdentSet (
|
SynExpr.assign
|
||||||
SynLongIdent.createS' [ "httpMessage" ; "Content" ],
|
(SynLongIdent.createS' [ "httpMessage" ; "Content" ])
|
||||||
SynExpr.createIdent' bodyParamName,
|
(SynExpr.createIdent' bodyParamName)
|
||||||
range0
|
|
||||||
)
|
|
||||||
)
|
)
|
||||||
]
|
]
|
||||||
| BodyParamMethods.Serialise ty ->
|
| BodyParamMethods.Serialise ty ->
|
||||||
@@ -464,11 +456,9 @@ module internal HttpClientGenerator =
|
|||||||
))
|
))
|
||||||
)
|
)
|
||||||
Do (
|
Do (
|
||||||
SynExpr.LongIdentSet (
|
SynExpr.assign
|
||||||
SynLongIdent.createS' [ "httpMessage" ; "Content" ],
|
(SynLongIdent.createS' [ "httpMessage" ; "Content" ])
|
||||||
SynExpr.createIdent "queryParams",
|
(SynExpr.createIdent "queryParams")
|
||||||
range0
|
|
||||||
)
|
|
||||||
)
|
)
|
||||||
]
|
]
|
||||||
|
|
||||||
|
@@ -71,13 +71,13 @@ module internal InterfaceMockGenerator =
|
|||||||
if inherits.Contains KnownInheritance.IDisposable then
|
if inherits.Contains KnownInheritance.IDisposable then
|
||||||
let unitFun = SynExpr.createThunk (SynExpr.CreateConst ())
|
let unitFun = SynExpr.createThunk (SynExpr.CreateConst ())
|
||||||
|
|
||||||
[ (SynLongIdent.createS "Dispose", true), Some unitFun ]
|
[ SynLongIdent.createS "Dispose", unitFun ]
|
||||||
else
|
else
|
||||||
[]
|
[]
|
||||||
|
|
||||||
let nonExtras =
|
let nonExtras =
|
||||||
fields
|
fields
|
||||||
|> List.map (fun field -> (SynLongIdent.createI (getName field), true), Some (failwithFun field))
|
|> List.map (fun field -> SynLongIdent.createI (getName field), failwithFun field)
|
||||||
|
|
||||||
extras @ nonExtras
|
extras @ nonExtras
|
||||||
|
|
||||||
@@ -213,6 +213,7 @@ module internal InterfaceMockGenerator =
|
|||||||
XmlDoc = Some xmlDoc
|
XmlDoc = Some xmlDoc
|
||||||
Generics = interfaceType.Generics
|
Generics = interfaceType.Generics
|
||||||
Accessibility = Some access
|
Accessibility = Some access
|
||||||
|
Attributes = []
|
||||||
}
|
}
|
||||||
|
|
||||||
let typeDecl = AstHelper.defineRecordType record
|
let typeDecl = AstHelper.defineRecordType record
|
||||||
|
@@ -407,9 +407,7 @@ module internal JsonParseGenerator =
|
|||||||
|
|
||||||
let finalConstruction =
|
let finalConstruction =
|
||||||
fields
|
fields
|
||||||
|> List.mapi (fun i fieldData ->
|
|> List.mapi (fun i fieldData -> SynLongIdent.createI fieldData.Ident, SynExpr.createIdent $"arg_%i{i}")
|
||||||
(SynLongIdent.createI fieldData.Ident, true), Some (SynExpr.createIdent $"arg_%i{i}")
|
|
||||||
)
|
|
||||||
|> AstHelper.instantiateRecord
|
|> AstHelper.instantiateRecord
|
||||||
|
|
||||||
(finalConstruction, assignments)
|
(finalConstruction, assignments)
|
||||||
|
@@ -42,6 +42,7 @@ module internal RemoveOptionsGenerator =
|
|||||||
(accessibility : SynAccess option)
|
(accessibility : SynAccess option)
|
||||||
(generics : SynTyparDecls option)
|
(generics : SynTyparDecls option)
|
||||||
(fields : SynField list)
|
(fields : SynField list)
|
||||||
|
: SynModuleDecl
|
||||||
=
|
=
|
||||||
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"
|
||||||
@@ -54,6 +55,7 @@ module internal RemoveOptionsGenerator =
|
|||||||
XmlDoc = xmlDoc
|
XmlDoc = xmlDoc
|
||||||
Generics = generics
|
Generics = generics
|
||||||
Accessibility = accessibility
|
Accessibility = accessibility
|
||||||
|
Attributes = []
|
||||||
}
|
}
|
||||||
|
|
||||||
let typeDecl = AstHelper.defineRecordType record
|
let typeDecl = AstHelper.defineRecordType record
|
||||||
@@ -91,7 +93,7 @@ module internal RemoveOptionsGenerator =
|
|||||||
)
|
)
|
||||||
| _ -> accessor
|
| _ -> accessor
|
||||||
|
|
||||||
(SynLongIdent.createI fieldData.Ident, true), Some body
|
SynLongIdent.createI fieldData.Ident, body
|
||||||
)
|
)
|
||||||
|> AstHelper.instantiateRecord
|
|> AstHelper.instantiateRecord
|
||||||
|
|
||||||
|
15
WoofWare.Myriad.Plugins/SynExpr/SynAttributes.fs
Normal file
15
WoofWare.Myriad.Plugins/SynExpr/SynAttributes.fs
Normal file
@@ -0,0 +1,15 @@
|
|||||||
|
namespace WoofWare.Myriad.Plugins
|
||||||
|
|
||||||
|
open Fantomas.FCS.Syntax
|
||||||
|
open Fantomas.FCS.Text.Range
|
||||||
|
|
||||||
|
[<RequireQualifiedAccess>]
|
||||||
|
module internal SynAttributes =
|
||||||
|
let ofAttrs (attrs : SynAttribute list) : SynAttributes =
|
||||||
|
attrs
|
||||||
|
|> List.map (fun a ->
|
||||||
|
{
|
||||||
|
Attributes = [ a ]
|
||||||
|
Range = range0
|
||||||
|
}
|
||||||
|
)
|
@@ -62,6 +62,35 @@ module internal SynBinding =
|
|||||||
triviaZero false
|
triviaZero false
|
||||||
)
|
)
|
||||||
|
|
||||||
|
let withMutability (mut : bool) (binding : SynBinding) : SynBinding =
|
||||||
|
match binding with
|
||||||
|
| SynBinding (pat, kind, inl, _, attrs, xml, valData, headPat, returnInfo, expr, range, debugPoint, trivia) ->
|
||||||
|
SynBinding (pat, kind, inl, mut, attrs, xml, valData, headPat, returnInfo, expr, range, debugPoint, trivia)
|
||||||
|
|
||||||
|
let withRecursion (isRec : bool) (binding : SynBinding) : SynBinding =
|
||||||
|
match binding with
|
||||||
|
| SynBinding (pat, kind, inl, mut, attrs, xml, valData, headPat, returnInfo, expr, range, debugPoint, trivia) ->
|
||||||
|
let trivia =
|
||||||
|
{ trivia with
|
||||||
|
LeadingKeyword =
|
||||||
|
match trivia.LeadingKeyword with
|
||||||
|
| SynLeadingKeyword.Let _ ->
|
||||||
|
if isRec then
|
||||||
|
SynLeadingKeyword.LetRec (range0, range0)
|
||||||
|
else
|
||||||
|
trivia.LeadingKeyword
|
||||||
|
| SynLeadingKeyword.LetRec _ ->
|
||||||
|
if isRec then
|
||||||
|
trivia.LeadingKeyword
|
||||||
|
else
|
||||||
|
trivia.LeadingKeyword
|
||||||
|
| existing ->
|
||||||
|
failwith
|
||||||
|
$"WoofWare.Myriad doesn't yet let you adjust the recursion modifier on a binding with modifier %O{existing}"
|
||||||
|
}
|
||||||
|
|
||||||
|
SynBinding (pat, kind, inl, mut, attrs, xml, valData, headPat, returnInfo, expr, range, debugPoint, trivia)
|
||||||
|
|
||||||
let withAccessibility (acc : SynAccess option) (binding : SynBinding) : SynBinding =
|
let withAccessibility (acc : SynAccess option) (binding : SynBinding) : SynBinding =
|
||||||
match binding with
|
match binding with
|
||||||
| SynBinding (_, kind, inl, mut, attrs, xml, valData, headPat, returnInfo, expr, range, debugPoint, trivia) ->
|
| SynBinding (_, kind, inl, mut, attrs, xml, valData, headPat, returnInfo, expr, range, debugPoint, trivia) ->
|
||||||
|
@@ -13,6 +13,13 @@ module internal SynExprExtensions =
|
|||||||
|
|
||||||
static member CreateConst () : SynExpr = SynExpr.Const (SynConst.Unit, range0)
|
static member CreateConst () : SynExpr = SynExpr.Const (SynConst.Unit, range0)
|
||||||
|
|
||||||
|
static member CreateConst (b : bool) : SynExpr = SynExpr.Const (SynConst.Bool b, range0)
|
||||||
|
|
||||||
|
static member CreateConst (c : char) : SynExpr =
|
||||||
|
// apparent Myriad bug: `IndexOf '?'` gets formatted as `IndexOf ?` which is clearly wrong
|
||||||
|
SynExpr.CreateApp (SynExpr.Ident (Ident.Create "char"), SynExpr.CreateConst (int c))
|
||||||
|
|> fun e -> SynExpr.Paren (e, range0, Some range0, range0)
|
||||||
|
|
||||||
static member CreateConst (i : int32) : SynExpr =
|
static member CreateConst (i : int32) : SynExpr =
|
||||||
SynExpr.Const (SynConst.Int32 i, range0)
|
SynExpr.Const (SynConst.Int32 i, range0)
|
||||||
|
|
||||||
@@ -138,6 +145,14 @@ module internal SynExpr =
|
|||||||
let inline index (property : SynExpr) (obj : SynExpr) : SynExpr =
|
let inline index (property : SynExpr) (obj : SynExpr) : SynExpr =
|
||||||
SynExpr.DotIndexedGet (obj, property, range0, range0)
|
SynExpr.DotIndexedGet (obj, property, range0, range0)
|
||||||
|
|
||||||
|
let inline arrayIndexRange (start : SynExpr option) (endRange : SynExpr option) (arr : SynExpr) : SynExpr =
|
||||||
|
SynExpr.DotIndexedGet (
|
||||||
|
arr,
|
||||||
|
(SynExpr.IndexRange (start, range0, endRange, range0, range0, range0)),
|
||||||
|
range0,
|
||||||
|
range0
|
||||||
|
)
|
||||||
|
|
||||||
let inline paren (e : SynExpr) : SynExpr =
|
let inline paren (e : SynExpr) : SynExpr =
|
||||||
SynExpr.Paren (e, range0, Some range0, range0)
|
SynExpr.Paren (e, range0, Some range0, range0)
|
||||||
|
|
||||||
@@ -202,6 +217,18 @@ module internal SynExpr =
|
|||||||
|
|
||||||
pipeThroughFunction lambda body
|
pipeThroughFunction lambda body
|
||||||
|
|
||||||
|
let inline createForEach (pat : SynPat) (enumExpr : SynExpr) (body : SynExpr) : SynExpr =
|
||||||
|
SynExpr.ForEach (
|
||||||
|
DebugPointAtFor.No,
|
||||||
|
DebugPointAtInOrTo.No,
|
||||||
|
SeqExprOnly.SeqExprOnly false,
|
||||||
|
true,
|
||||||
|
pat,
|
||||||
|
enumExpr,
|
||||||
|
body,
|
||||||
|
range0
|
||||||
|
)
|
||||||
|
|
||||||
let inline createLet (bindings : SynBinding list) (body : SynExpr) : SynExpr =
|
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)
|
||||||
|
|
||||||
@@ -296,9 +323,37 @@ module internal SynExpr =
|
|||||||
|
|
||||||
/// {y} > {x}
|
/// {y} > {x}
|
||||||
let greaterThan (x : SynExpr) (y : SynExpr) : SynExpr =
|
let greaterThan (x : SynExpr) (y : SynExpr) : SynExpr =
|
||||||
SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.ge, y) |> applyTo x
|
SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.gt, y) |> applyTo x
|
||||||
|
|
||||||
|
/// {y} < {x}
|
||||||
|
let lessThan (x : SynExpr) (y : SynExpr) : SynExpr =
|
||||||
|
SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.lt, y) |> applyTo x
|
||||||
|
|
||||||
/// {y} >= {x}
|
/// {y} >= {x}
|
||||||
let greaterThanOrEqual (x : SynExpr) (y : SynExpr) : SynExpr =
|
let greaterThanOrEqual (x : SynExpr) (y : SynExpr) : SynExpr =
|
||||||
SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.geq, y)
|
SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.geq, y)
|
||||||
|> applyTo x
|
|> applyTo x
|
||||||
|
|
||||||
|
/// {y} <= {x}
|
||||||
|
let lessThanOrEqual (x : SynExpr) (y : SynExpr) : SynExpr =
|
||||||
|
SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.leq, y)
|
||||||
|
|> applyTo x
|
||||||
|
|
||||||
|
/// {x} :: {y}
|
||||||
|
let listCons (x : SynExpr) (y : SynExpr) : SynExpr =
|
||||||
|
SynExpr.CreateAppInfix (
|
||||||
|
SynExpr.LongIdent (
|
||||||
|
false,
|
||||||
|
SynLongIdent.SynLongIdent (
|
||||||
|
[ Ident.create "op_ColonColon" ],
|
||||||
|
[],
|
||||||
|
[ Some (IdentTrivia.OriginalNotation "::") ]
|
||||||
|
),
|
||||||
|
None,
|
||||||
|
range0
|
||||||
|
),
|
||||||
|
tupleNoParen [ x ; y ]
|
||||||
|
)
|
||||||
|
|> paren
|
||||||
|
|
||||||
|
let assign (lhs : SynLongIdent) (rhs : SynExpr) : SynExpr = SynExpr.LongIdentSet (lhs, rhs, range0)
|
||||||
|
@@ -14,9 +14,19 @@ module internal SynLongIdent =
|
|||||||
[ Some (IdentTrivia.OriginalNotation ">=") ]
|
[ Some (IdentTrivia.OriginalNotation ">=") ]
|
||||||
)
|
)
|
||||||
|
|
||||||
let ge =
|
let leq =
|
||||||
|
SynLongIdent.SynLongIdent (
|
||||||
|
[ Ident.create "op_LessThanOrEqual" ],
|
||||||
|
[],
|
||||||
|
[ Some (IdentTrivia.OriginalNotation "<=") ]
|
||||||
|
)
|
||||||
|
|
||||||
|
let gt =
|
||||||
SynLongIdent.SynLongIdent ([ Ident.create "op_GreaterThan" ], [], [ Some (IdentTrivia.OriginalNotation ">") ])
|
SynLongIdent.SynLongIdent ([ Ident.create "op_GreaterThan" ], [], [ Some (IdentTrivia.OriginalNotation ">") ])
|
||||||
|
|
||||||
|
let lt =
|
||||||
|
SynLongIdent.SynLongIdent ([ Ident.create "op_LessThan" ], [], [ Some (IdentTrivia.OriginalNotation "<") ])
|
||||||
|
|
||||||
let sub =
|
let sub =
|
||||||
SynLongIdent.SynLongIdent ([ Ident.create "op_Subtraction" ], [], [ Some (IdentTrivia.OriginalNotation "-") ])
|
SynLongIdent.SynLongIdent ([ Ident.create "op_Subtraction" ], [], [ Some (IdentTrivia.OriginalNotation "-") ])
|
||||||
|
|
||||||
@@ -70,6 +80,12 @@ module internal SynLongIdent =
|
|||||||
// TODO: consider Microsoft.FSharp.Option or whatever it is
|
// TODO: consider Microsoft.FSharp.Option or whatever it is
|
||||||
| _ -> false
|
| _ -> false
|
||||||
|
|
||||||
|
let isChoice (ident : SynLongIdent) : bool =
|
||||||
|
match ident.LongIdent with
|
||||||
|
| [ i ] when System.String.Equals (i.idText, "Choice", System.StringComparison.Ordinal) -> true
|
||||||
|
// TODO: consider Microsoft.FSharp.Choice or whatever it is
|
||||||
|
| _ -> false
|
||||||
|
|
||||||
let isNullable (ident : SynLongIdent) : bool =
|
let isNullable (ident : SynLongIdent) : bool =
|
||||||
match ident.LongIdent |> List.map _.idText with
|
match ident.LongIdent |> List.map _.idText with
|
||||||
| [ "System" ; "Nullable" ]
|
| [ "System" ; "Nullable" ]
|
||||||
|
@@ -14,6 +14,8 @@ module internal SynModuleDecl =
|
|||||||
|
|
||||||
let inline createLet (binding : SynBinding) : SynModuleDecl = createLets [ binding ]
|
let inline createLet (binding : SynBinding) : SynModuleDecl = createLets [ binding ]
|
||||||
|
|
||||||
|
let inline createTypes (tys : SynTypeDefn list) : SynModuleDecl = SynModuleDecl.Types (tys, range0)
|
||||||
|
|
||||||
let nestedModule (info : SynComponentInfo) (decls : SynModuleDecl list) : SynModuleDecl =
|
let nestedModule (info : SynComponentInfo) (decls : SynModuleDecl list) : SynModuleDecl =
|
||||||
SynModuleDecl.NestedModule (
|
SynModuleDecl.NestedModule (
|
||||||
info,
|
info,
|
||||||
|
@@ -33,3 +33,17 @@ module internal SynPat =
|
|||||||
let unit = createConst SynConst.Unit
|
let unit = createConst SynConst.Unit
|
||||||
|
|
||||||
let createNull = SynPat.Null range0
|
let createNull = SynPat.Null range0
|
||||||
|
|
||||||
|
let emptyList = SynPat.ArrayOrList (false, [], range0)
|
||||||
|
|
||||||
|
let listCons (lhs : SynPat) (rhs : SynPat) =
|
||||||
|
SynPat.ListCons (
|
||||||
|
lhs,
|
||||||
|
rhs,
|
||||||
|
range0,
|
||||||
|
{
|
||||||
|
ColonColonRange = range0
|
||||||
|
}
|
||||||
|
)
|
||||||
|
|
||||||
|
let emptyArray = SynPat.ArrayOrList (true, [], range0)
|
||||||
|
@@ -1,56 +1,9 @@
|
|||||||
namespace WoofWare.Myriad.Plugins
|
namespace WoofWare.Myriad.Plugins
|
||||||
|
|
||||||
|
open System
|
||||||
open Fantomas.FCS.Syntax
|
open Fantomas.FCS.Syntax
|
||||||
open Fantomas.FCS.Text.Range
|
open Fantomas.FCS.Text.Range
|
||||||
|
|
||||||
[<RequireQualifiedAccess>]
|
|
||||||
module internal SynType =
|
|
||||||
let rec stripOptionalParen (ty : SynType) : SynType =
|
|
||||||
match ty with
|
|
||||||
| SynType.Paren (ty, _) -> stripOptionalParen 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)
|
|
||||||
|
|
||||||
let unit : SynType = named "unit"
|
|
||||||
let int : SynType = named "int"
|
|
||||||
|
|
||||||
/// Given ['a1, 'a2] and 'ret, returns 'a1 -> 'a2 -> 'ret.
|
|
||||||
let toFun (inputs : SynType list) (ret : SynType) : SynType =
|
|
||||||
(ret, List.rev inputs) ||> List.fold (fun ty input -> funFromDomain input ty)
|
|
||||||
|
|
||||||
[<AutoOpen>]
|
[<AutoOpen>]
|
||||||
module internal SynTypePatterns =
|
module internal SynTypePatterns =
|
||||||
let (|OptionType|_|) (fieldType : SynType) =
|
let (|OptionType|_|) (fieldType : SynType) =
|
||||||
@@ -59,6 +12,11 @@ module internal SynTypePatterns =
|
|||||||
Some innerType
|
Some innerType
|
||||||
| _ -> None
|
| _ -> None
|
||||||
|
|
||||||
|
let (|ChoiceType|_|) (fieldType : SynType) =
|
||||||
|
match fieldType with
|
||||||
|
| SynType.App (SynType.LongIdent ident, _, inner, _, _, _, _) when SynLongIdent.isChoice ident -> Some inner
|
||||||
|
| _ -> None
|
||||||
|
|
||||||
let (|NullableType|_|) (fieldType : SynType) =
|
let (|NullableType|_|) (fieldType : SynType) =
|
||||||
match fieldType with
|
match fieldType with
|
||||||
| SynType.App (SynType.LongIdent ident, _, [ innerType ], _, _, _, _) when SynLongIdent.isNullable ident ->
|
| SynType.App (SynType.LongIdent ident, _, [ innerType ], _, _, _, _) when SynLongIdent.isNullable ident ->
|
||||||
@@ -272,3 +230,169 @@ module internal SynTypePatterns =
|
|||||||
| _ -> failwithf "Expected Task to be applied to exactly one arg, but got: %+A" args
|
| _ -> failwithf "Expected Task to be applied to exactly one arg, but got: %+A" args
|
||||||
| _ -> None
|
| _ -> None
|
||||||
| _ -> None
|
| _ -> None
|
||||||
|
|
||||||
|
let (|DirectoryInfo|_|) (fieldType : SynType) =
|
||||||
|
match fieldType with
|
||||||
|
| SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->
|
||||||
|
match ident |> List.map (fun i -> i.idText) with
|
||||||
|
| [ "System" ; "IO" ; "DirectoryInfo" ]
|
||||||
|
| [ "IO" ; "DirectoryInfo" ]
|
||||||
|
| [ "DirectoryInfo" ] -> Some ()
|
||||||
|
| _ -> None
|
||||||
|
| _ -> None
|
||||||
|
|
||||||
|
let (|FileInfo|_|) (fieldType : SynType) =
|
||||||
|
match fieldType with
|
||||||
|
| SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->
|
||||||
|
match ident |> List.map (fun i -> i.idText) with
|
||||||
|
| [ "System" ; "IO" ; "FileInfo" ]
|
||||||
|
| [ "IO" ; "FileInfo" ]
|
||||||
|
| [ "FileInfo" ] -> Some ()
|
||||||
|
| _ -> None
|
||||||
|
| _ -> None
|
||||||
|
|
||||||
|
[<RequireQualifiedAccess>]
|
||||||
|
module internal SynType =
|
||||||
|
let rec stripOptionalParen (ty : SynType) : SynType =
|
||||||
|
match ty with
|
||||||
|
| SynType.Paren (ty, _) -> stripOptionalParen 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 appPostfix' (name : string list) (arg : SynType) : SynType =
|
||||||
|
SynType.App (createLongIdent' 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)
|
||||||
|
|
||||||
|
let unit : SynType = named "unit"
|
||||||
|
let int : SynType = named "int"
|
||||||
|
|
||||||
|
let anon : SynType = SynType.Anon range0
|
||||||
|
|
||||||
|
let string : SynType = named "string"
|
||||||
|
|
||||||
|
/// Given ['a1, 'a2] and 'ret, returns 'a1 -> 'a2 -> 'ret.
|
||||||
|
let toFun (inputs : SynType list) (ret : SynType) : SynType =
|
||||||
|
(ret, List.rev inputs) ||> List.fold (fun ty input -> funFromDomain input ty)
|
||||||
|
|
||||||
|
/// Guess whether the types are equal. We err on the side of saying "no, they're different".
|
||||||
|
let rec provablyEqual (ty1 : SynType) (ty2 : SynType) : bool =
|
||||||
|
if Object.ReferenceEquals (ty1, ty2) then
|
||||||
|
true
|
||||||
|
else
|
||||||
|
|
||||||
|
match ty1 with
|
||||||
|
| PrimitiveType t1 ->
|
||||||
|
match ty2 with
|
||||||
|
| PrimitiveType t2 -> (t1 |> List.map _.idText) = (t2 |> List.map _.idText)
|
||||||
|
| _ -> false
|
||||||
|
| OptionType t1 ->
|
||||||
|
match ty2 with
|
||||||
|
| OptionType t2 -> provablyEqual t1 t2
|
||||||
|
| _ -> false
|
||||||
|
| NullableType t1 ->
|
||||||
|
match ty2 with
|
||||||
|
| NullableType t2 -> provablyEqual t1 t2
|
||||||
|
| _ -> false
|
||||||
|
| ChoiceType t1 ->
|
||||||
|
match ty2 with
|
||||||
|
| ChoiceType t2 ->
|
||||||
|
t1.Length = t2.Length
|
||||||
|
&& List.forall (fun (a, b) -> provablyEqual a b) (List.zip t1 t2)
|
||||||
|
| _ -> false
|
||||||
|
| DictionaryType (k1, v1) ->
|
||||||
|
match ty2 with
|
||||||
|
| DictionaryType (k2, v2) -> provablyEqual k1 k2 && provablyEqual v1 v2
|
||||||
|
| _ -> false
|
||||||
|
| IDictionaryType (k1, v1) ->
|
||||||
|
match ty2 with
|
||||||
|
| IDictionaryType (k2, v2) -> provablyEqual k1 k2 && provablyEqual v1 v2
|
||||||
|
| _ -> false
|
||||||
|
| IReadOnlyDictionaryType (k1, v1) ->
|
||||||
|
match ty2 with
|
||||||
|
| IReadOnlyDictionaryType (k2, v2) -> provablyEqual k1 k2 && provablyEqual v1 v2
|
||||||
|
| _ -> false
|
||||||
|
| MapType (k1, v1) ->
|
||||||
|
match ty2 with
|
||||||
|
| MapType (k2, v2) -> provablyEqual k1 k2 && provablyEqual v1 v2
|
||||||
|
| _ -> false
|
||||||
|
| ListType t1 ->
|
||||||
|
match ty2 with
|
||||||
|
| ListType t2 -> provablyEqual t1 t2
|
||||||
|
| _ -> false
|
||||||
|
| ArrayType t1 ->
|
||||||
|
match ty2 with
|
||||||
|
| ArrayType t2 -> provablyEqual t1 t2
|
||||||
|
| _ -> false
|
||||||
|
| Task t1 ->
|
||||||
|
match ty2 with
|
||||||
|
| Task t2 -> provablyEqual t1 t2
|
||||||
|
| _ -> false
|
||||||
|
| UnitType ->
|
||||||
|
match ty2 with
|
||||||
|
| UnitType -> true
|
||||||
|
| _ -> false
|
||||||
|
| FileInfo ->
|
||||||
|
match ty2 with
|
||||||
|
| FileInfo -> true
|
||||||
|
| _ -> false
|
||||||
|
| DirectoryInfo ->
|
||||||
|
match ty2 with
|
||||||
|
| DirectoryInfo -> true
|
||||||
|
| _ -> false
|
||||||
|
| Uri ->
|
||||||
|
match ty2 with
|
||||||
|
| Uri -> true
|
||||||
|
| _ -> false
|
||||||
|
| Stream ->
|
||||||
|
match ty2 with
|
||||||
|
| Stream -> true
|
||||||
|
| _ -> false
|
||||||
|
| Guid ->
|
||||||
|
match ty2 with
|
||||||
|
| Guid -> true
|
||||||
|
| _ -> false
|
||||||
|
| BigInt ->
|
||||||
|
match ty2 with
|
||||||
|
| BigInt -> true
|
||||||
|
| _ -> false
|
||||||
|
| DateTimeOffset ->
|
||||||
|
match ty2 with
|
||||||
|
| DateTimeOffset -> true
|
||||||
|
| _ -> false
|
||||||
|
| DateOnly ->
|
||||||
|
match ty2 with
|
||||||
|
| DateOnly -> true
|
||||||
|
| _ -> false
|
||||||
|
| _ -> false
|
||||||
|
@@ -1,6 +1,9 @@
|
|||||||
namespace WoofWare.Myriad.Plugins
|
namespace WoofWare.Myriad.Plugins
|
||||||
|
|
||||||
open Fantomas.FCS.Syntax
|
open Fantomas.FCS.Syntax
|
||||||
|
open Fantomas.FCS.Text.Range
|
||||||
|
open Fantomas.FCS.Xml
|
||||||
|
open Fantomas.FCS.SyntaxTrivia
|
||||||
|
|
||||||
type internal UnionCase<'Ident> =
|
type internal UnionCase<'Ident> =
|
||||||
{
|
{
|
||||||
@@ -39,3 +42,34 @@ module internal SynUnionCase =
|
|||||||
Attrs = attrs
|
Attrs = attrs
|
||||||
Ident = id
|
Ident = id
|
||||||
}
|
}
|
||||||
|
|
||||||
|
let create (case : UnionCase<Ident>) : SynUnionCase =
|
||||||
|
let fields =
|
||||||
|
case.Fields
|
||||||
|
|> List.map (fun field ->
|
||||||
|
SynField.SynField (
|
||||||
|
SynAttributes.ofAttrs field.Attrs,
|
||||||
|
false,
|
||||||
|
Some field.Ident,
|
||||||
|
field.Type,
|
||||||
|
false,
|
||||||
|
PreXmlDoc.Empty,
|
||||||
|
None,
|
||||||
|
range0,
|
||||||
|
{
|
||||||
|
LeadingKeyword = None
|
||||||
|
}
|
||||||
|
)
|
||||||
|
)
|
||||||
|
|
||||||
|
SynUnionCase.SynUnionCase (
|
||||||
|
SynAttributes.ofAttrs case.Attrs,
|
||||||
|
SynIdent.SynIdent (case.Ident, None),
|
||||||
|
SynUnionCaseKind.Fields fields,
|
||||||
|
PreXmlDoc.Empty,
|
||||||
|
None,
|
||||||
|
range0,
|
||||||
|
{
|
||||||
|
BarRange = Some range0
|
||||||
|
}
|
||||||
|
)
|
||||||
|
@@ -1,4 +1,4 @@
|
|||||||
<Project Sdk="Microsoft.NET.Sdk">
|
<Project Sdk="Microsoft.NET.Sdk">
|
||||||
|
|
||||||
<PropertyGroup>
|
<PropertyGroup>
|
||||||
<TargetFramework>net6.0</TargetFramework>
|
<TargetFramework>net6.0</TargetFramework>
|
||||||
@@ -18,7 +18,7 @@
|
|||||||
</PropertyGroup>
|
</PropertyGroup>
|
||||||
|
|
||||||
<ItemGroup>
|
<ItemGroup>
|
||||||
<PackageReference Include="Myriad.Core" Version="0.8.3" PrivateAssets="all"/>
|
<PackageReference Include="Myriad.Core" Version="0.8.3" />
|
||||||
<!-- the lowest version allowed by Myriad.Core -->
|
<!-- the lowest version allowed by Myriad.Core -->
|
||||||
<PackageReference Update="FSharp.Core" Version="6.0.1" PrivateAssets="all"/>
|
<PackageReference Update="FSharp.Core" Version="6.0.1" PrivateAssets="all"/>
|
||||||
</ItemGroup>
|
</ItemGroup>
|
||||||
@@ -26,6 +26,7 @@
|
|||||||
<ItemGroup>
|
<ItemGroup>
|
||||||
<Compile Include="List.fs"/>
|
<Compile Include="List.fs"/>
|
||||||
<Compile Include="Primitives.fs" />
|
<Compile Include="Primitives.fs" />
|
||||||
|
<Compile Include="SynExpr\SynAttributes.fs" />
|
||||||
<Compile Include="SynExpr\PreXmlDoc.fs" />
|
<Compile Include="SynExpr\PreXmlDoc.fs" />
|
||||||
<Compile Include="SynExpr\Ident.fs" />
|
<Compile Include="SynExpr\Ident.fs" />
|
||||||
<Compile Include="SynExpr\SynLongIdent.fs" />
|
<Compile Include="SynExpr\SynLongIdent.fs" />
|
||||||
|
Reference in New Issue
Block a user