Compare commits

..

9 Commits

Author SHA1 Message Date
Patrick Stevens
09b7109c84 Extract some utilities from http-client branch (#260) 2024-09-14 22:02:32 +00:00
Patrick Stevens
693b95106a Also pipe through parser in PositionalArgs true (#259) 2024-09-13 16:11:53 +00:00
Patrick Stevens
49ecfbf5e5 Fix includeFlagLike when arg doesn't have an equals (#257) 2024-09-12 22:10:08 +00:00
Patrick Stevens
5748ac3d5b Allow consuming *all* args as positionals, not just ones which look like --foo (#255) 2024-09-11 19:00:04 +00:00
Patrick Stevens
913959a740 Make arg parser more AOT-friendly (#253) 2024-09-10 22:16:43 +01:00
dependabot[bot]
93ffc065cd Bump Microsoft.NET.Test.Sdk from 17.11.0 to 17.11.1 (#248)
* Bump Microsoft.NET.Test.Sdk from 17.11.0 to 17.11.1

Bumps [Microsoft.NET.Test.Sdk](https://github.com/microsoft/vstest) from 17.11.0 to 17.11.1.
- [Release notes](https://github.com/microsoft/vstest/releases)
- [Changelog](https://github.com/microsoft/vstest/blob/main/docs/releases.md)
- [Commits](https://github.com/microsoft/vstest/compare/v17.11.0...v17.11.1)

---
updated-dependencies:
- dependency-name: Microsoft.NET.Test.Sdk
  dependency-type: direct:production
  update-type: version-update:semver-patch
...

Signed-off-by: dependabot[bot] <support@github.com>

* Bump fantomas from 6.3.11 to 6.3.12

Bumps [fantomas](https://github.com/fsprojects/fantomas) from 6.3.11 to 6.3.12.
- [Release notes](https://github.com/fsprojects/fantomas/releases)
- [Changelog](https://github.com/fsprojects/fantomas/blob/main/CHANGELOG.md)
- [Commits](https://github.com/fsprojects/fantomas/compare/v6.3.11...v6.3.12)

---
updated-dependencies:
- dependency-name: fantomas
  dependency-type: direct:production
  update-type: version-update:semver-patch
...

Signed-off-by: dependabot[bot] <support@github.com>

* Deps

---------

Signed-off-by: dependabot[bot] <support@github.com>
Co-authored-by: dependabot[bot] <49699333+dependabot[bot]@users.noreply.github.com>
Co-authored-by: Smaug123 <3138005+Smaug123@users.noreply.github.com>
2024-09-09 19:33:39 +00:00
dependabot[bot]
d14efba7e7 Bump actions/attest-build-provenance from 1.4.2 to 1.4.3 (#247) 2024-09-09 12:42:12 +01:00
patrick-conscriptus[bot]
f5cf0b79dd Automated commit (#246)
Co-authored-by: patrick-conscriptus[bot] <175414948+patrick-conscriptus[bot]@users.noreply.github.com>
2024-09-08 01:20:34 +00:00
Patrick Stevens
029e3746bb Fix record/union impl accessibility (#245) 2024-09-07 08:49:28 +00:00
29 changed files with 1694 additions and 376 deletions

View File

@@ -3,7 +3,7 @@
"isRoot": true, "isRoot": true,
"tools": { "tools": {
"fantomas": { "fantomas": {
"version": "6.3.11", "version": "6.3.12",
"commands": [ "commands": [
"fantomas" "fantomas"
] ]

View File

@@ -241,7 +241,7 @@ jobs:
name: nuget-package-attribute name: nuget-package-attribute
path: packed path: packed
- name: Attest Build Provenance - name: Attest Build Provenance
uses: actions/attest-build-provenance@6149ea5740be74af77f260b9db67e633f6b0a9a1 # v1.4.2 uses: actions/attest-build-provenance@1c608d11d69870c2092266b3f9a6f3abbf17002c # v1.4.3
with: with:
subject-path: "packed/*.nupkg" subject-path: "packed/*.nupkg"
@@ -260,7 +260,7 @@ jobs:
name: nuget-package-plugin name: nuget-package-plugin
path: packed path: packed
- name: Attest Build Provenance - name: Attest Build Provenance
uses: actions/attest-build-provenance@6149ea5740be74af77f260b9db67e633f6b0a9a1 # v1.4.2 uses: actions/attest-build-provenance@1c608d11d69870c2092266b3f9a6f3abbf17002c # v1.4.3
with: with:
subject-path: "packed/*.nupkg" subject-path: "packed/*.nupkg"

View File

@@ -190,3 +190,48 @@ type ManyLongForms =
[<ArgumentLongForm "dont-turn-it-off">] [<ArgumentLongForm "dont-turn-it-off">]
SomeFlag : bool SomeFlag : bool
} }
[<RequireQualifiedAccess>]
type private IrrelevantDu =
| Foo
| Bar
[<ArgParser true>]
type FlagsIntoPositionalArgs =
{
A : string
[<PositionalArgs true>]
GrabEverything : string list
}
[<ArgParser true>]
type FlagsIntoPositionalArgsChoice =
{
A : string
[<PositionalArgs true>]
GrabEverything : Choice<string, string> list
}
[<ArgParser true>]
type FlagsIntoPositionalArgsInt =
{
A : string
[<PositionalArgs true>]
GrabEverything : int list
}
[<ArgParser true>]
type FlagsIntoPositionalArgsIntChoice =
{
A : string
[<PositionalArgs true>]
GrabEverything : Choice<int, int> list
}
[<ArgParser true>]
type FlagsIntoPositionalArgs' =
{
A : string
[<PositionalArgs false>]
DontGrabEverything : string list
}

File diff suppressed because it is too large Load Diff

View File

@@ -19,9 +19,22 @@ type ArgParserAttribute (isExtensionMethod : bool) =
/// Attribute indicating that this field shall accumulate all unmatched args, /// Attribute indicating that this field shall accumulate all unmatched args,
/// as well as any that appear after a bare `--`. /// as well as any that appear after a bare `--`.
type PositionalArgsAttribute () = ///
/// Set `includeFlagLike = true` to include args that begin `--` in the
/// positional args.
/// (By default, `includeFlagLike = false` and we throw when encountering
/// an argument which looks like a flag but which we don't recognise.)
/// We will still interpret `--help` as requesting help, unless it comes after
/// a standalone `--` separator.
type PositionalArgsAttribute (includeFlagLike : bool) =
inherit Attribute () inherit Attribute ()
/// The default value of `isExtensionMethod`, the optional argument to the ArgParserAttribute constructor.
static member DefaultIncludeFlagLike = false
/// Shorthand for the "includeFlagLike = false" constructor; see documentation there for details.
new () = PositionalArgsAttribute PositionalArgsAttribute.DefaultIncludeFlagLike
/// Attribute indicating that this field shall have a default value derived /// Attribute indicating that this field shall have a default value derived
/// from calling an appropriately named static method on the type. /// from calling an appropriately named static method on the type.
/// ///

View File

@@ -40,7 +40,10 @@ WoofWare.Myriad.Plugins.JsonSerializeAttribute.get_DefaultIsExtensionMethod [sta
WoofWare.Myriad.Plugins.ParseExactAttribute inherit System.Attribute WoofWare.Myriad.Plugins.ParseExactAttribute inherit System.Attribute
WoofWare.Myriad.Plugins.ParseExactAttribute..ctor [constructor]: string WoofWare.Myriad.Plugins.ParseExactAttribute..ctor [constructor]: string
WoofWare.Myriad.Plugins.PositionalArgsAttribute inherit System.Attribute WoofWare.Myriad.Plugins.PositionalArgsAttribute inherit System.Attribute
WoofWare.Myriad.Plugins.PositionalArgsAttribute..ctor [constructor]: bool
WoofWare.Myriad.Plugins.PositionalArgsAttribute..ctor [constructor]: unit WoofWare.Myriad.Plugins.PositionalArgsAttribute..ctor [constructor]: unit
WoofWare.Myriad.Plugins.PositionalArgsAttribute.DefaultIncludeFlagLike [static property]: [read-only] bool
WoofWare.Myriad.Plugins.PositionalArgsAttribute.get_DefaultIncludeFlagLike [static method]: unit -> bool
WoofWare.Myriad.Plugins.RemoveOptionsAttribute inherit System.Attribute WoofWare.Myriad.Plugins.RemoveOptionsAttribute inherit System.Attribute
WoofWare.Myriad.Plugins.RemoveOptionsAttribute..ctor [constructor]: unit WoofWare.Myriad.Plugins.RemoveOptionsAttribute..ctor [constructor]: unit
WoofWare.Myriad.Plugins.RestEase inherit obj WoofWare.Myriad.Plugins.RestEase inherit obj

View File

@@ -18,7 +18,7 @@
<ItemGroup> <ItemGroup>
<PackageReference Include="ApiSurface" Version="4.1.5" /> <PackageReference Include="ApiSurface" Version="4.1.5" />
<PackageReference Include="Microsoft.NET.Test.Sdk" Version="17.11.0"/> <PackageReference Include="Microsoft.NET.Test.Sdk" Version="17.11.1"/>
<PackageReference Include="NUnit" Version="4.2.2"/> <PackageReference Include="NUnit" Version="4.2.2"/>
<PackageReference Include="NUnit3TestAdapter" Version="4.6.0"/> <PackageReference Include="NUnit3TestAdapter" Version="4.6.0"/>
</ItemGroup> </ItemGroup>

View File

@@ -1,5 +1,5 @@
{ {
"version": "3.4", "version": "3.5",
"publicReleaseRefSpec": [ "publicReleaseRefSpec": [
"^refs/heads/main$" "^refs/heads/main$"
], ],

View File

@@ -618,3 +618,89 @@ Required argument '--exact' received no value"""
"""Help text requested. """Help text requested.
--do-something-else / --anotherarg string --do-something-else / --anotherarg string
--turn-it-on / --dont-turn-it-off bool""" --turn-it-on / --dont-turn-it-off bool"""
[<Test>]
let ``Can collect *all* non-help args into positional args with includeFlagLike`` () =
let getEnvVar (_ : string) = failwith "do not call"
FlagsIntoPositionalArgs.parse' getEnvVar [ "--a" ; "foo" ; "--b=false" ; "--c" ; "hi" ; "--" ; "--help" ]
|> shouldEqual
{
A = "foo"
GrabEverything = [ "--b=false" ; "--c" ; "hi" ; "--help" ]
}
// Users might consider this eccentric!
// But we're only a simple arg parser; we don't look around to see whether this is "almost"
// a valid parse.
FlagsIntoPositionalArgs.parse' getEnvVar [ "--a" ; "--b=false" ; "--c" ; "hi" ; "--" ; "--help" ]
|> shouldEqual
{
A = "--b=false"
GrabEverything = [ "--c" ; "hi" ; "--help" ]
}
[<Test>]
let ``Can collect non-help args into positional args with Choice`` () =
let getEnvVar (_ : string) = failwith "do not call"
FlagsIntoPositionalArgsChoice.parse' getEnvVar [ "--a" ; "foo" ; "--b=false" ; "--c" ; "hi" ; "--" ; "--help" ]
|> shouldEqual
{
A = "foo"
GrabEverything =
[
Choice1Of2 "--b=false"
Choice1Of2 "--c"
Choice1Of2 "hi"
Choice2Of2 "--help"
]
}
[<Test>]
let ``Can collect non-help args into positional args, and we parse on the way`` () =
let getEnvVar (_ : string) = failwith "do not call"
FlagsIntoPositionalArgsInt.parse' getEnvVar [ "3" ; "--a" ; "foo" ; "5" ; "--" ; "98" ]
|> shouldEqual
{
A = "foo"
GrabEverything = [ 3 ; 5 ; 98 ]
}
[<Test>]
let ``Can collect non-help args into positional args with Choice, and we parse on the way`` () =
let getEnvVar (_ : string) = failwith "do not call"
FlagsIntoPositionalArgsIntChoice.parse' getEnvVar [ "3" ; "--a" ; "foo" ; "5" ; "--" ; "98" ]
|> shouldEqual
{
A = "foo"
GrabEverything = [ Choice1Of2 3 ; Choice1Of2 5 ; Choice2Of2 98 ]
}
[<Test>]
let ``Can refuse to collect non-help args with PositionalArgs false`` () =
let getEnvVar (_ : string) = failwith "do not call"
let exc =
Assert.Throws<exn> (fun () ->
FlagsIntoPositionalArgs'.parse'
getEnvVar
[ "--a" ; "foo" ; "--b=false" ; "--c" ; "hi" ; "--" ; "--help" ]
|> ignore<FlagsIntoPositionalArgs'>
)
exc.Message
|> shouldEqual """Unable to process argument --b=false as key --b and value false"""
let exc =
Assert.Throws<exn> (fun () ->
FlagsIntoPositionalArgs'.parse' getEnvVar [ "--a" ; "--b=false" ; "--c=hi" ; "--" ; "--help" ]
|> ignore<FlagsIntoPositionalArgs'>
)
// Again perhaps eccentric!
// Again, we don't try to detect that the user has missed out the desired argument to `--a`.
exc.Message
|> shouldEqual """Unable to process argument --c=hi as key --c and value hi"""

View File

@@ -42,7 +42,7 @@
<PackageReference Include="ApiSurface" Version="4.1.5"/> <PackageReference Include="ApiSurface" Version="4.1.5"/>
<PackageReference Include="FsCheck" Version="2.16.6"/> <PackageReference Include="FsCheck" Version="2.16.6"/>
<PackageReference Include="FsUnit" Version="6.0.0"/> <PackageReference Include="FsUnit" Version="6.0.0"/>
<PackageReference Include="Microsoft.NET.Test.Sdk" Version="17.11.0"/> <PackageReference Include="Microsoft.NET.Test.Sdk" Version="17.11.1"/>
<PackageReference Include="NUnit" Version="4.2.2"/> <PackageReference Include="NUnit" Version="4.2.2"/>
<PackageReference Include="NUnit3TestAdapter" Version="4.6.0"/> <PackageReference Include="NUnit3TestAdapter" Version="4.6.0"/>
</ItemGroup> </ItemGroup>

View File

@@ -85,8 +85,8 @@ type private ParseFunction<'acc> =
[<RequireQualifiedAccess>] [<RequireQualifiedAccess>]
type private ChoicePositional = type private ChoicePositional =
| Normal | Normal of includeFlagLike : SynExpr option
| Choice | Choice of includeFlagLike : SynExpr option
type private ParseFunctionPositional = ParseFunction<ChoicePositional> type private ParseFunctionPositional = ParseFunction<ChoicePositional>
type private ParseFunctionNonPositional = ParseFunction<Accumulation<ArgumentDefaultSpec>> type private ParseFunctionNonPositional = ParseFunction<Accumulation<ArgumentDefaultSpec>>
@@ -506,11 +506,14 @@ module internal ArgParserGenerator =
let positionalArgAttr = let positionalArgAttr =
attrs attrs
|> List.tryFind (fun a -> |> List.tryPick (fun a ->
match (List.last a.TypeName.LongIdent).idText with match (List.last a.TypeName.LongIdent).idText with
| "PositionalArgsAttribute" | "PositionalArgsAttribute"
| "PositionalArgs" -> true | "PositionalArgs" ->
| _ -> false match a.ArgExpr with
| SynExpr.Const (SynConst.Unit, _) -> Some None
| a -> Some (Some a)
| _ -> None
) )
let parseExactModifier = let parseExactModifier =
@@ -580,7 +583,7 @@ module internal ArgParserGenerator =
| None -> | None ->
match positionalArgAttr with match positionalArgAttr with
| Some _ -> | Some includeFlagLike ->
let getChoice (spec : ArgumentDefaultSpec option) : unit = let getChoice (spec : ArgumentDefaultSpec option) : unit =
match spec with match spec with
| Some _ -> | Some _ ->
@@ -607,7 +610,7 @@ module internal ArgParserGenerator =
FieldName = ident FieldName = ident
Parser = parser Parser = parser
TargetVariable = Ident.create $"arg_%i{counter}" TargetVariable = Ident.create $"arg_%i{counter}"
Accumulation = ChoicePositional.Choice Accumulation = ChoicePositional.Choice includeFlagLike
TargetType = parseTy TargetType = parseTy
ArgForm = longForms ArgForm = longForms
Help = helpText Help = helpText
@@ -619,7 +622,7 @@ module internal ArgParserGenerator =
FieldName = ident FieldName = ident
Parser = parser Parser = parser
TargetVariable = Ident.create $"arg_%i{counter}" TargetVariable = Ident.create $"arg_%i{counter}"
Accumulation = ChoicePositional.Normal Accumulation = ChoicePositional.Normal includeFlagLike
TargetType = parseTy TargetType = parseTy
ArgForm = longForms ArgForm = longForms
Help = helpText Help = helpText
@@ -723,7 +726,10 @@ module internal ArgParserGenerator =
] ]
|> SynExpr.createMatch (SynExpr.callMethod var.idText (SynExpr.createIdent' typeName)) |> SynExpr.createMatch (SynExpr.callMethod var.idText (SynExpr.createIdent' typeName))
|> SynExpr.pipeThroughFunction ( |> SynExpr.pipeThroughFunction (
SynExpr.applyFunction (SynExpr.createIdent "sprintf") (SynExpr.CreateConst " (default value: %O)") SynExpr.createLambda "x" (SynExpr.callMethod "ToString" (SynExpr.createIdent "x"))
)
|> SynExpr.pipeThroughFunction (
SynExpr.applyFunction (SynExpr.createIdent "sprintf") (SynExpr.CreateConst " (default value: %s)")
) )
|> SynExpr.paren |> SynExpr.paren
| Accumulation.List _ -> SynExpr.CreateConst " (can be repeated)" | Accumulation.List _ -> SynExpr.CreateConst " (can be repeated)"
@@ -786,10 +792,12 @@ module internal ArgParserGenerator =
| Accumulation.Optional -> | Accumulation.Optional ->
let multipleErrorMessage = let multipleErrorMessage =
SynExpr.createIdent "sprintf" SynExpr.createIdent "sprintf"
|> SynExpr.applyTo (SynExpr.CreateConst "Argument '%s' was supplied multiple times: %O and %O") |> SynExpr.applyTo (SynExpr.CreateConst "Argument '%s' was supplied multiple times: %s and %s")
|> SynExpr.applyTo arg.HumanReadableArgForm |> SynExpr.applyTo arg.HumanReadableArgForm
|> SynExpr.applyTo (SynExpr.createIdent "x") |> SynExpr.applyTo (SynExpr.createIdent "x" |> SynExpr.callMethod "ToString" |> SynExpr.paren)
|> SynExpr.applyTo (SynExpr.createIdent "value") |> SynExpr.applyTo (
SynExpr.createIdent "value" |> SynExpr.callMethod "ToString" |> SynExpr.paren
)
let performAssignment = let performAssignment =
[ [
@@ -850,8 +858,9 @@ module internal ArgParserGenerator =
|> SynExpr.pipeThroughFunction pos.Parser |> SynExpr.pipeThroughFunction pos.Parser
|> fun p -> |> fun p ->
match pos.Accumulation with match pos.Accumulation with
| ChoicePositional.Choice -> p |> SynExpr.pipeThroughFunction (SynExpr.createIdent "Choice1Of2") | ChoicePositional.Choice _ ->
| ChoicePositional.Normal -> p p |> SynExpr.pipeThroughFunction (SynExpr.createIdent "Choice1Of2")
| ChoicePositional.Normal _ -> p
|> SynExpr.pipeThroughFunction ( |> SynExpr.pipeThroughFunction (
SynExpr.createLongIdent' [ pos.TargetVariable ; Ident.create "Add" ] SynExpr.createLongIdent' [ pos.TargetVariable ; Ident.create "Add" ]
) )
@@ -995,6 +1004,50 @@ module internal ArgParserGenerator =
|> SynExpr.applyTo (SynExpr.createIdent "key") |> SynExpr.applyTo (SynExpr.createIdent "key")
|> SynExpr.applyTo (SynExpr.createIdent "value") |> SynExpr.applyTo (SynExpr.createIdent "value")
let processAsPositional =
SynExpr.sequential
[
SynExpr.createIdent "arg"
|> SynExpr.pipeThroughFunction leftoverArgParser
|> fun p ->
match leftoverArgAcc with
| ChoicePositional.Normal _ -> p
| ChoicePositional.Choice _ ->
p |> SynExpr.pipeThroughFunction (SynExpr.createIdent "Choice1Of2")
|> SynExpr.pipeThroughFunction (SynExpr.createLongIdent' [ leftoverArgs ; Ident.create "Add" ])
recurseKey
]
let posAttr =
match leftoverArgAcc with
| ChoicePositional.Choice a
| ChoicePositional.Normal a -> a
let notMatched =
let handleFailure =
[
SynMatchClause.create (SynPat.named "None") fail
SynMatchClause.create
(SynPat.nameWithArgs "Some" [ SynPat.named "msg" ])
(SynExpr.sequential
[
SynExpr.createIdent "sprintf"
|> SynExpr.applyTo (SynExpr.CreateConst "%s (at arg %s)")
|> SynExpr.applyTo (SynExpr.createIdent "msg")
|> SynExpr.applyTo (SynExpr.createIdent "arg")
|> SynExpr.pipeThroughFunction (SynExpr.dotGet "Add" (SynExpr.createIdent' errorAcc))
recurseKey
])
]
|> SynExpr.createMatch (SynExpr.createIdent "x")
match posAttr with
| None -> handleFailure
| Some posAttr -> SynExpr.ifThenElse posAttr handleFailure processAsPositional
let argStartsWithDashes = let argStartsWithDashes =
SynExpr.createIdent "arg" SynExpr.createIdent "arg"
|> SynExpr.callMethodArg |> SynExpr.callMethodArg
@@ -1008,19 +1061,7 @@ module internal ArgParserGenerator =
let processKey = let processKey =
SynExpr.ifThenElse SynExpr.ifThenElse
argStartsWithDashes argStartsWithDashes
(SynExpr.sequential processAsPositional
[
SynExpr.createIdent "arg"
|> SynExpr.pipeThroughFunction leftoverArgParser
|> fun p ->
match leftoverArgAcc with
| ChoicePositional.Normal -> p
| ChoicePositional.Choice ->
p |> SynExpr.pipeThroughFunction (SynExpr.createIdent "Choice1Of2")
|> SynExpr.pipeThroughFunction (SynExpr.createLongIdent' [ leftoverArgs ; Ident.create "Add" ])
recurseKey
])
(SynExpr.ifThenElse (SynExpr.ifThenElse
(SynExpr.equals (SynExpr.createIdent "arg") (SynExpr.CreateConst "--help")) (SynExpr.equals (SynExpr.createIdent "arg") (SynExpr.CreateConst "--help"))
(SynExpr.createLet (SynExpr.createLet
@@ -1056,23 +1097,9 @@ module internal ArgParserGenerator =
[ [
SynMatchClause.create (SynPat.nameWithArgs "Ok" [ SynPat.unit ]) recurseKey SynMatchClause.create (SynPat.nameWithArgs "Ok" [ SynPat.unit ]) recurseKey
SynMatchClause.create (SynPat.nameWithArgs "Error" [ SynPat.named "None" ]) fail
SynMatchClause.create SynMatchClause.create
(SynPat.nameWithArgs (SynPat.nameWithArgs "Error" [ SynPat.named "x" ])
"Error" notMatched
[ SynPat.nameWithArgs "Some" [ SynPat.named "msg" ] |> SynPat.paren ])
(SynExpr.sequential
[
SynExpr.createIdent "sprintf"
|> SynExpr.applyTo (SynExpr.CreateConst "%s (at arg %s)")
|> SynExpr.applyTo (SynExpr.createIdent "msg")
|> SynExpr.applyTo (SynExpr.createIdent "arg")
|> SynExpr.pipeThroughFunction (
SynExpr.dotGet "Add" (SynExpr.createIdent' errorAcc)
)
recurseKey
])
])) ]))
(SynExpr.createIdent "args" |> SynExpr.pipeThroughFunction recurseValue))) (SynExpr.createIdent "args" |> SynExpr.pipeThroughFunction recurseValue)))
(SynExpr.createIdent "helpText" (SynExpr.createIdent "helpText"
@@ -1086,6 +1113,8 @@ module internal ArgParserGenerator =
let processValue = let processValue =
// During failure, we've received an optional exception message that happened when we tried to parse // During failure, we've received an optional exception message that happened when we tried to parse
// the value; it's in the variable `exc`. // the value; it's in the variable `exc`.
// `fail` is for the case where we're genuinely emitting an error.
// If we're in `PositionalArgs true` mode, though, we won't call `fail`.
let fail = let fail =
[ [
SynExpr.createIdent "failwithf" SynExpr.createIdent "failwithf"
@@ -1105,6 +1134,27 @@ module internal ArgParserGenerator =
] ]
|> SynExpr.createMatch (SynExpr.createIdent "exc") |> SynExpr.createMatch (SynExpr.createIdent "exc")
let onFailure =
match posAttr with
| None -> fail
| Some includeFlagLike ->
[
SynExpr.createIdent "key"
|> SynExpr.pipeThroughFunction leftoverArgParser
|> fun i ->
match leftoverArgAcc with
| ChoicePositional.Choice _ ->
i |> SynExpr.pipeThroughFunction (SynExpr.createIdent "Choice1Of2")
| ChoicePositional.Normal _ -> i
|> SynExpr.pipeThroughFunction (SynExpr.createLongIdent' [ leftoverArgs ; Ident.create "Add" ])
SynExpr.createIdent "go"
|> SynExpr.applyTo (SynExpr.createLongIdent' [ parseState ; Ident.create "AwaitingKey" ])
|> SynExpr.applyTo (SynExpr.listCons (SynExpr.createIdent "arg") (SynExpr.createIdent "args"))
]
|> SynExpr.sequential
|> SynExpr.ifThenElse includeFlagLike fail
[ [
SynMatchClause.create SynMatchClause.create
(SynPat.nameWithArgs "Ok" [ SynPat.unit ]) (SynPat.nameWithArgs "Ok" [ SynPat.unit ])
@@ -1117,7 +1167,7 @@ module internal ArgParserGenerator =
(SynPat.nameWithArgs "Error" [ SynPat.named "exc" ]) (SynPat.nameWithArgs "Error" [ SynPat.named "exc" ])
(SynExpr.ifThenElse (SynExpr.ifThenElse
(SynExpr.applyFunction (SynExpr.createIdent "setFlagValue") (SynExpr.createIdent "key")) (SynExpr.applyFunction (SynExpr.createIdent "setFlagValue") (SynExpr.createIdent "key"))
fail onFailure
(SynExpr.createIdent "go" (SynExpr.createIdent "go"
|> SynExpr.applyTo (SynExpr.createLongIdent' [ parseState ; Ident.create "AwaitingKey" ]) |> SynExpr.applyTo (SynExpr.createLongIdent' [ parseState ; Ident.create "AwaitingKey" ])
|> SynExpr.applyTo (SynExpr.listCons (SynExpr.createIdent "arg") (SynExpr.createIdent "args")))) |> SynExpr.applyTo (SynExpr.listCons (SynExpr.createIdent "arg") (SynExpr.createIdent "args"))))
@@ -1184,8 +1234,8 @@ module internal ArgParserGenerator =
) )
|> fun p -> |> fun p ->
match leftoverArgAcc with match leftoverArgAcc with
| ChoicePositional.Normal -> p | ChoicePositional.Normal _ -> p
| ChoicePositional.Choice -> | ChoicePositional.Choice _ ->
p p
|> SynExpr.pipeThroughFunction ( |> SynExpr.pipeThroughFunction (
SynExpr.applyFunction SynExpr.applyFunction
@@ -1257,9 +1307,9 @@ module internal ArgParserGenerator =
SynType.string SynType.string
| Some pf -> | Some pf ->
match pf.Accumulation with match pf.Accumulation with
| ChoicePositional.Choice -> | ChoicePositional.Choice _ ->
pf.TargetVariable, pf.Parser, SynType.app "Choice" [ pf.TargetType ; pf.TargetType ] pf.TargetVariable, pf.Parser, SynType.app "Choice" [ pf.TargetType ; pf.TargetType ]
| ChoicePositional.Normal -> pf.TargetVariable, pf.Parser, pf.TargetType | ChoicePositional.Normal _ -> pf.TargetVariable, pf.Parser, pf.TargetType
let bindings = let bindings =
SynExpr.createIdent "ResizeArray" SynExpr.createIdent "ResizeArray"
@@ -1487,7 +1537,7 @@ module internal ArgParserGenerator =
let leftoverArgAcc = let leftoverArgAcc =
match pos with match pos with
| None -> ChoicePositional.Normal | None -> ChoicePositional.Normal None
| Some pos -> pos.Accumulation | Some pos -> pos.Accumulation
[ [
@@ -1521,53 +1571,54 @@ module internal ArgParserGenerator =
|> List.choose (fun ty -> |> List.choose (fun ty ->
match ty.Cases with match ty.Cases with
| [ c1 ; c2 ] -> | [ c1 ; c2 ] ->
let c1Attr =
c1.Attributes
|> List.tryPick (fun attr ->
match attr.TypeName with
| SynLongIdent.SynLongIdent (id, _, _) ->
match id |> List.last |> _.idText with
| "ArgumentFlagAttribute"
| "ArgumentFlag" -> Some (SynExpr.stripOptionalParen attr.ArgExpr)
| _ -> None
)
let c2Attr =
c2.Attributes
|> List.tryPick (fun attr ->
match attr.TypeName with
| SynLongIdent.SynLongIdent (id, _, _) ->
match id |> List.last |> _.idText with
| "ArgumentFlagAttribute"
| "ArgumentFlag" -> Some (SynExpr.stripOptionalParen attr.ArgExpr)
| _ -> None
)
match c1Attr, c2Attr with
| Some _, None
| None, Some _ ->
failwith
"[<ArgumentFlag>] must be placed on both cases of a two-case discriminated union, with opposite argument values on each case."
| None, None -> None
| Some c1Attr, Some c2Attr ->
// Sanity check where possible
match c1Attr, c2Attr with
| SynExpr.Const (SynConst.Bool b1, _), SynExpr.Const (SynConst.Bool b2, _) ->
if b1 = b2 then
failwith
"[<ArgumentFlag>] must have opposite argument values on each case in a two-case discriminated union."
| _, _ -> ()
match c1.Fields, c2.Fields with match c1.Fields, c2.Fields with
| [], [] -> | [], [] ->
let c1Attr = {
c1.Attributes Name = ty.Name
|> List.tryPick (fun attr -> Case1Name = c1.Name
match attr.TypeName with Case1Arg = c1Attr
| SynLongIdent.SynLongIdent (id, _, _) -> Case2Name = c2.Name
match id |> List.last |> _.idText with Case2Arg = c2Attr
| "ArgumentFlagAttribute" }
| "ArgumentFlag" -> Some (SynExpr.stripOptionalParen attr.ArgExpr) |> Some
| _ -> None
)
let c2Attr =
c2.Attributes
|> List.tryPick (fun attr ->
match attr.TypeName with
| SynLongIdent.SynLongIdent (id, _, _) ->
match id |> List.last |> _.idText with
| "ArgumentFlagAttribute"
| "ArgumentFlag" -> Some (SynExpr.stripOptionalParen attr.ArgExpr)
| _ -> None
)
match c1Attr, c2Attr with
| Some c1Attr, Some c2Attr ->
// Sanity check where possible
match c1Attr, c2Attr with
| SynExpr.Const (SynConst.Bool b1, _), SynExpr.Const (SynConst.Bool b2, _) ->
if b1 = b2 then
failwith
"[<ArgumentFlag>] must have opposite argument values on each case in a two-case discriminated union."
| _, _ -> ()
{
Name = ty.Name
Case1Name = c1.Name
Case1Arg = c1Attr
Case2Name = c2.Name
Case2Arg = c2Attr
}
|> Some
| Some _, None
| None, Some _ ->
failwith
"[<ArgumentFlag>] must be placed on both cases of a two-case discriminated union, with opposite argument values on each case."
| _, _ -> None
| _, _ -> | _, _ ->
failwith "[<ArgumentFlag>] may only be placed on discriminated union members with no data." failwith "[<ArgumentFlag>] may only be placed on discriminated union members with no data."
| _ -> None | _ -> None

View File

@@ -67,7 +67,8 @@ type internal RecordType =
Members : SynMemberDefns option Members : SynMemberDefns option
XmlDoc : PreXmlDoc option XmlDoc : PreXmlDoc option
Generics : SynTyparDecls option Generics : SynTyparDecls option
Accessibility : SynAccess option TypeAccessibility : SynAccess option
ImplAccessibility : SynAccess option
Attributes : SynAttribute list Attributes : SynAttribute list
} }
@@ -80,17 +81,15 @@ type internal RecordType =
: RecordType : RecordType
= =
match sci with match sci with
| SynComponentInfo.SynComponentInfo (attrs, typars, _, longId, doc, _, access2, _) -> | SynComponentInfo.SynComponentInfo (attrs, typars, _, longId, doc, _, implAccess, _) ->
if access <> access2 then
failwith $"TODO what's happened, two different accessibility modifiers: %O{access} and %O{access2}"
{ {
Name = List.last longId Name = List.last longId
Fields = recordFields Fields = recordFields
Members = if smd.IsEmpty then None else Some smd Members = if smd.IsEmpty then None else Some smd
XmlDoc = if doc.IsEmpty then None else Some doc XmlDoc = if doc.IsEmpty then None else Some doc
Generics = typars Generics = typars
Accessibility = access ImplAccessibility = implAccess
TypeAccessibility = access
Attributes = attrs |> List.collect (fun l -> l.Attributes) Attributes = attrs |> List.collect (fun l -> l.Attributes)
} }
@@ -144,7 +143,9 @@ type internal UnionType =
/// Attributes of the DU (not its cases): `[<Attr>] type Foo = | ...` /// Attributes of the DU (not its cases): `[<Attr>] type Foo = | ...`
Attributes : SynAttribute list Attributes : SynAttribute list
/// Accessibility modifier of the DU: `type private Foo = ...` /// Accessibility modifier of the DU: `type private Foo = ...`
Accessibility : SynAccess option TypeAccessibility : SynAccess option
/// Accessibility modifier of the DU's implementation: `type Foo = private | ...`
ImplAccessibility : SynAccess option
/// The actual DU cases themselves. /// The actual DU cases themselves.
Cases : UnionCase<Ident option> list Cases : UnionCase<Ident option> list
} }
@@ -157,17 +158,15 @@ type internal UnionType =
: UnionType : UnionType
= =
match sci with match sci with
| SynComponentInfo.SynComponentInfo (attrs, typars, _, longId, doc, _, access2, _) -> | SynComponentInfo.SynComponentInfo (attrs, typars, _, longId, doc, _, implAccess, _) ->
if access <> access2 then
failwith $"TODO what's happened, two different accessibility modifiers: %O{access} and %O{access2}"
{ {
Name = List.last longId Name = List.last longId
Members = if smd.IsEmpty then None else Some smd Members = if smd.IsEmpty then None else Some smd
XmlDoc = if doc.IsEmpty then None else Some doc XmlDoc = if doc.IsEmpty then None else Some doc
Generics = typars Generics = typars
Attributes = attrs |> List.collect (fun l -> l.Attributes) Attributes = attrs |> List.collect (fun l -> l.Attributes)
Accessibility = access TypeAccessibility = access
ImplAccessibility = implAccess
Cases = cases |> List.map UnionCase.ofSynUnionCase Cases = cases |> List.map UnionCase.ofSynUnionCase
} }
@@ -213,13 +212,13 @@ module internal AstHelper =
let defineRecordType (record : RecordType) : SynTypeDefn = let defineRecordType (record : RecordType) : SynTypeDefn =
let name = let name =
SynComponentInfo.create record.Name SynComponentInfo.create record.Name
|> SynComponentInfo.setAccessibility record.Accessibility |> SynComponentInfo.setAccessibility record.TypeAccessibility
|> match record.XmlDoc with |> match record.XmlDoc with
| None -> id | None -> id
| Some doc -> SynComponentInfo.withDocString doc | Some doc -> SynComponentInfo.withDocString doc
|> SynComponentInfo.setGenerics record.Generics |> SynComponentInfo.setGenerics record.Generics
SynTypeDefnRepr.record (Seq.toList record.Fields) SynTypeDefnRepr.recordWithAccess record.ImplAccessibility (Seq.toList record.Fields)
|> SynTypeDefn.create name |> SynTypeDefn.create name
|> SynTypeDefn.withMemberDefns (defaultArg record.Members SynMemberDefns.Empty) |> SynTypeDefn.withMemberDefns (defaultArg record.Members SynMemberDefns.Empty)

View File

@@ -564,11 +564,12 @@ module internal CataGenerator =
let domain = let domain =
field.FieldName field.FieldName
|> Option.map Ident.lowerFirstLetter |> Option.map Ident.lowerFirstLetter
|> SynType.signatureParamOfType place |> SynType.signatureParamOfType [] place false
acc |> SynType.funFromDomain domain acc |> SynType.funFromDomain domain
) )
|> SynMemberDefn.abstractMember |> SynMemberDefn.abstractMember
[]
case.CataMethodIdent case.CataMethodIdent
None None
arity arity

View File

@@ -212,7 +212,8 @@ module internal InterfaceMockGenerator =
Members = Some ([ constructor ; interfaceMembers ] @ extraInterfaces) Members = Some ([ constructor ; interfaceMembers ] @ extraInterfaces)
XmlDoc = Some xmlDoc XmlDoc = Some xmlDoc
Generics = interfaceType.Generics Generics = interfaceType.Generics
Accessibility = Some access TypeAccessibility = Some access
ImplAccessibility = None
Attributes = [] Attributes = []
} }
@@ -227,14 +228,11 @@ module internal InterfaceMockGenerator =
x.Type x.Type
let private constructMemberSinglePlace (tuple : TupledArg) : SynType = let private constructMemberSinglePlace (tuple : TupledArg) : SynType =
match tuple.Args |> List.rev |> List.map buildType with tuple.Args
| [] -> failwith "no-arg functions not supported yet" |> List.map buildType
| [ x ] -> x |> SynType.tupleNoParen
| last :: rest -> |> Option.defaultWith (fun () -> failwith "no-arg functions not supported yet")
([ SynTupleTypeSegment.Type last ], rest) |> if tuple.HasParen then SynType.paren else id
||> List.fold (fun ty nextArg -> SynTupleTypeSegment.Type nextArg :: SynTupleTypeSegment.Star range0 :: ty)
|> fun segs -> SynType.Tuple (false, segs, range0)
|> fun ty -> if tuple.HasParen then SynType.Paren (ty, range0) else ty
let constructMember (mem : MemberInfo) : SynField = let constructMember (mem : MemberInfo) : SynField =
let inputType = mem.Args |> List.map constructMemberSinglePlace let inputType = mem.Args |> List.map constructMemberSinglePlace

View File

@@ -36,7 +36,6 @@ module internal RemoveOptionsGenerator =
trivia trivia
) )
// TODO: this option seems a bit odd
let createType let createType
(xmlDoc : PreXmlDoc option) (xmlDoc : PreXmlDoc option)
(accessibility : SynAccess option) (accessibility : SynAccess option)
@@ -54,7 +53,8 @@ module internal RemoveOptionsGenerator =
Members = None Members = None
XmlDoc = xmlDoc XmlDoc = xmlDoc
Generics = generics Generics = generics
Accessibility = accessibility TypeAccessibility = accessibility
ImplAccessibility = None
Attributes = [] Attributes = []
} }
@@ -62,7 +62,7 @@ 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 : Ident) (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 inputArg = Ident.create "input" let inputArg = Ident.create "input"
@@ -87,7 +87,7 @@ module internal RemoveOptionsGenerator =
SynExpr.applyFunction SynExpr.applyFunction
(SynExpr.createLongIdent [ "Option" ; "defaultWith" ]) (SynExpr.createLongIdent [ "Option" ; "defaultWith" ])
(SynExpr.createLongIdent' ( (SynExpr.createLongIdent' (
withoutOptionsType [ withoutOptionsType ]
@ [ Ident.create (sprintf "Default%s" fieldData.Ident.idText) ] @ [ Ident.create (sprintf "Default%s" fieldData.Ident.idText) ]
)) ))
) )
@@ -101,47 +101,35 @@ module internal RemoveOptionsGenerator =
[ functionName ] [ functionName ]
[ [
SynPat.named inputArg.idText SynPat.named inputArg.idText
|> SynPat.annotateType (SynType.LongIdent (SynLongIdent.create withoutOptionsType)) |> SynPat.annotateType (SynType.LongIdent (SynLongIdent.createI withoutOptionsType))
] ]
body body
|> SynBinding.withXmlDoc xmlDoc |> SynBinding.withXmlDoc xmlDoc
|> SynBinding.withReturnAnnotation (SynType.LongIdent (SynLongIdent.create withOptionsType)) |> SynBinding.withReturnAnnotation (SynType.LongIdent (SynLongIdent.create withOptionsType))
|> SynModuleDecl.createLet |> SynModuleDecl.createLet
let createRecordModule (namespaceId : LongIdent) (typeDefn : SynTypeDefn) = let createRecordModule (namespaceId : LongIdent) (typeDefn : RecordType) =
let (SynTypeDefn (synComponentInfo, synTypeDefnRepr, _members, _implicitCtor, _, _)) = let fieldData = typeDefn.Fields |> List.map SynField.extractWithIdent
typeDefn
let (SynComponentInfo (_attributes, typeParams, _constraints, recordId, doc, _preferPostfix, _access, _)) = let decls =
synComponentInfo [
createType typeDefn.XmlDoc typeDefn.TypeAccessibility typeDefn.Generics typeDefn.Fields
createMaker [ Ident.create "Short" ] typeDefn.Name fieldData
]
match synTypeDefnRepr with let xmlDoc =
| SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (accessibility, fields, _range), _) -> sprintf "Module containing an option-truncated version of the %s type" typeDefn.Name.idText
let fieldData = fields |> List.map SynField.extractWithIdent |> PreXmlDoc.create
let decls = let info =
[ SynComponentInfo.create typeDefn.Name
createType (Some doc) accessibility typeParams fields |> SynComponentInfo.withDocString xmlDoc
createMaker [ Ident.create "Short" ] recordId fieldData |> SynComponentInfo.addAttributes [ SynAttribute.compilationRepresentation ]
] |> SynComponentInfo.addAttributes [ SynAttribute.requireQualifiedAccess ]
let xmlDoc = SynModuleDecl.nestedModule info decls
recordId |> List.singleton
|> Seq.map (fun i -> i.idText) |> SynModuleOrNamespace.createNamespace namespaceId
|> String.concat "."
|> sprintf "Module containing an option-truncated version of the %s type"
|> PreXmlDoc.create
let info =
SynComponentInfo.createLong recordId
|> SynComponentInfo.withDocString xmlDoc
|> SynComponentInfo.addAttributes [ SynAttribute.compilationRepresentation ]
|> SynComponentInfo.addAttributes [ SynAttribute.requireQualifiedAccess ]
SynModuleDecl.nestedModule info decls
|> List.singleton
|> SynModuleOrNamespace.createNamespace namespaceId
| _ -> failwithf "Not a record type"
open Myriad.Core open Myriad.Core
@@ -164,7 +152,24 @@ type RemoveOptionsGenerator () =
|> List.choose (fun (ns, types) -> |> List.choose (fun (ns, types) ->
match types |> List.filter Ast.hasAttribute<RemoveOptionsAttribute> with match types |> List.filter Ast.hasAttribute<RemoveOptionsAttribute> with
| [] -> None | [] -> None
| types -> Some (ns, types) | types ->
let types =
types
|> List.map (fun ty ->
match ty with
| SynTypeDefn.SynTypeDefn (sci,
SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (access,
fields,
_),
_),
smd,
smdo,
_,
_) -> RecordType.OfRecord sci smd access fields
| _ -> failwith "unexpectedly not a record"
)
Some (ns, types)
) )
let modules = let modules =

View File

@@ -2,6 +2,7 @@ namespace WoofWare.Myriad.Plugins
open System open System
open System.Text open System.Text
open System.Text.RegularExpressions
open Fantomas.FCS.Syntax open Fantomas.FCS.Syntax
open Fantomas.FCS.Text.Range open Fantomas.FCS.Text.Range
@@ -9,6 +10,53 @@ open Fantomas.FCS.Text.Range
module internal Ident = module internal Ident =
let inline create (s : string) = Ident (s, range0) let inline create (s : string) = Ident (s, range0)
/// Fantomas bug, perhaps? "type" is not rendered as ``type``, although the ASTs are identical
/// apart from the ranges?
/// Awful hack: here is a function that does this sort of thing.
let createSanitisedParamName (s : string) =
match s with
| "type" -> create "type'"
| _ ->
let result = StringBuilder ()
for i = 0 to s.Length - 1 do
if Char.IsLetter s.[i] then
result.Append s.[i] |> ignore<StringBuilder>
elif Char.IsNumber s.[i] then
if result.Length > 0 then
result.Append s.[i] |> ignore<StringBuilder>
elif s.[i] = '_' || s.[i] = '-' then
result.Append '_' |> ignore<StringBuilder>
else
failwith $"could not convert to ident: %s{s}"
create (result.ToString ())
let private alnum = Regex @"^[a-zA-Z][a-zA-Z0-9]*$"
let createSanitisedTypeName (s : string) =
let result = StringBuilder ()
let mutable capitalize = true
for i = 0 to s.Length - 1 do
if Char.IsLetter s.[i] then
if capitalize then
result.Append (Char.ToUpperInvariant s.[i]) |> ignore<StringBuilder>
capitalize <- false
else
result.Append s.[i] |> ignore<StringBuilder>
elif Char.IsNumber s.[i] then
if result.Length > 0 then
result.Append s.[i] |> ignore<StringBuilder>
elif s.[i] = '_' then
capitalize <- true
if result.Length = 0 then
failwith $"String %s{s} was not suitable as a type identifier"
Ident (result.ToString (), 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

View File

@@ -6,7 +6,12 @@ open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>] [<RequireQualifiedAccess>]
module internal PreXmlDoc = module internal PreXmlDoc =
let create (s : string) : PreXmlDoc = let create (s : string) : PreXmlDoc =
PreXmlDoc.Create ([| " " + s |], range0) let s = s.Split "\n"
for i = 0 to s.Length - 1 do
s.[i] <- " " + s.[i]
PreXmlDoc.Create (s, range0)
let create' (s : string seq) : PreXmlDoc = let create' (s : string seq) : PreXmlDoc =
PreXmlDoc.Create (Array.ofSeq s, range0) PreXmlDoc.Create (Array.ofSeq s, range0)

View File

@@ -9,12 +9,12 @@ module internal SynArgPats =
match caseNames.Length with match caseNames.Length with
| 0 -> SynArgPats.Pats [] | 0 -> SynArgPats.Pats []
| 1 -> | 1 ->
SynPat.Named (SynIdent.SynIdent (Ident.create caseNames.[0], None), false, None, range0) SynPat.Named (SynIdent.createS caseNames.[0], false, None, range0)
|> List.singleton |> List.singleton
|> SynArgPats.Pats |> SynArgPats.Pats
| len -> | len ->
caseNames caseNames
|> List.map (fun name -> SynPat.Named (SynIdent.SynIdent (Ident.create name, None), false, None, range0)) |> List.map (fun name -> SynPat.Named (SynIdent.createS name, false, None, range0))
|> fun t -> SynPat.Tuple (false, t, List.replicate (len - 1) range0, range0) |> fun t -> SynPat.Tuple (false, t, List.replicate (len - 1) range0, range0)
|> fun t -> SynPat.Paren (t, range0) |> fun t -> SynPat.Paren (t, range0)
|> List.singleton |> List.singleton

View File

@@ -5,32 +5,23 @@ open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>] [<RequireQualifiedAccess>]
module internal SynAttribute = module internal SynAttribute =
let internal compilationRepresentation : SynAttribute = let inline create (typeName : SynLongIdent) (arg : SynExpr) : SynAttribute =
{ {
TypeName = SynLongIdent.createS "CompilationRepresentation" TypeName = typeName
ArgExpr = ArgExpr = arg
[ "CompilationRepresentationFlags" ; "ModuleSuffix" ]
|> SynExpr.createLongIdent
|> SynExpr.paren
Target = None Target = None
AppliesToGetterAndSetter = false AppliesToGetterAndSetter = false
Range = range0 Range = range0
} }
let internal compilationRepresentation : SynAttribute =
[ "CompilationRepresentationFlags" ; "ModuleSuffix" ]
|> SynExpr.createLongIdent
|> SynExpr.paren
|> create (SynLongIdent.createS "CompilationRepresentation")
let internal requireQualifiedAccess : SynAttribute = let internal requireQualifiedAccess : SynAttribute =
{ create (SynLongIdent.createS "RequireQualifiedAccess") (SynExpr.CreateConst ())
TypeName = SynLongIdent.createS "RequireQualifiedAccess"
ArgExpr = SynExpr.CreateConst ()
Target = None
AppliesToGetterAndSetter = false
Range = range0
}
let internal autoOpen : SynAttribute = let internal autoOpen : SynAttribute =
{ create (SynLongIdent.createS "AutoOpen") (SynExpr.CreateConst ())
TypeName = SynLongIdent.createS "AutoOpen"
ArgExpr = SynExpr.CreateConst ()
Target = None
AppliesToGetterAndSetter = false
Range = range0
}

View File

@@ -80,6 +80,11 @@ module internal SynExpr =
let equals (a : SynExpr) (b : SynExpr) = let equals (a : SynExpr) (b : SynExpr) =
SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.eq, a) |> applyTo b SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.eq, a) |> applyTo b
/// {a} && {b}
let booleanAnd (a : SynExpr) (b : SynExpr) =
SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.booleanAnd, a)
|> applyTo b
/// {a} + {b} /// {a} + {b}
let plus (a : SynExpr) (b : SynExpr) = let plus (a : SynExpr) (b : SynExpr) =
SynExpr.CreateAppInfix ( SynExpr.CreateAppInfix (

View File

@@ -0,0 +1,10 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
[<RequireQualifiedAccess>]
module internal SynIdent =
let inline createI (i : Ident) : SynIdent = SynIdent.SynIdent (i, None)
let inline createS (i : string) : SynIdent =
SynIdent.SynIdent (Ident.create i, None)

View File

@@ -33,6 +33,9 @@ module internal SynLongIdent =
let eq = let eq =
SynLongIdent.SynLongIdent ([ Ident.create "op_Equality" ], [], [ Some (IdentTrivia.OriginalNotation "=") ]) SynLongIdent.SynLongIdent ([ Ident.create "op_Equality" ], [], [ Some (IdentTrivia.OriginalNotation "=") ])
let booleanAnd =
SynLongIdent.SynLongIdent ([ Ident.create "op_BooleanAnd" ], [], [ Some (IdentTrivia.OriginalNotation "&&") ])
let pipe = let pipe =
SynLongIdent.SynLongIdent ([ Ident.create "op_PipeRight" ], [], [ Some (IdentTrivia.OriginalNotation "|>") ]) SynLongIdent.SynLongIdent ([ Ident.create "op_PipeRight" ], [], [ Some (IdentTrivia.OriginalNotation "|>") ])

View File

@@ -17,8 +17,8 @@ module internal SynMemberDefn =
SynMemberFlags.MemberKind = SynMemberKind.Member SynMemberFlags.MemberKind = SynMemberKind.Member
} }
let abstractMember let abstractMember
(attrs : SynAttribute list)
(ident : SynIdent) (ident : SynIdent)
(typars : SynTyparDecls option) (typars : SynTyparDecls option)
(arity : SynValInfo) (arity : SynValInfo)
@@ -28,7 +28,13 @@ module internal SynMemberDefn =
= =
let slot = let slot =
SynValSig.SynValSig ( SynValSig.SynValSig (
[], attrs
|> List.map (fun attr ->
{
Attributes = [ attr ]
Range = range0
}
),
ident, ident,
SynValTyparDecls.SynValTyparDecls (typars, true), SynValTyparDecls.SynValTyparDecls (typars, true),
returnType, returnType,

View File

@@ -267,6 +267,8 @@ module internal SynType =
| SynType.Paren (ty, _) -> stripOptionalParen ty | SynType.Paren (ty, _) -> stripOptionalParen ty
| ty -> ty | ty -> ty
let inline paren (ty : SynType) : SynType = SynType.Paren (ty, range0)
let inline createLongIdent (ident : LongIdent) : SynType = let inline createLongIdent (ident : LongIdent) : SynType =
SynType.LongIdent (SynLongIdent.create ident) SynType.LongIdent (SynLongIdent.create ident)
@@ -283,6 +285,17 @@ module internal SynType =
let inline app (name : string) (args : SynType list) : SynType = app' (named name) args let inline app (name : string) (args : SynType list) : SynType = app' (named name) args
/// Returns None if the input list was empty.
let inline tupleNoParen (ty : SynType list) : SynType option =
match List.rev ty with
| [] -> None
| [ t ] -> Some t
| t :: rest ->
([ SynTupleTypeSegment.Type t ], rest)
||> List.fold (fun ty nextArg -> SynTupleTypeSegment.Type nextArg :: SynTupleTypeSegment.Star range0 :: ty)
|> fun segs -> SynType.Tuple (false, segs, range0)
|> Some
let inline appPostfix (name : string) (arg : SynType) : SynType = let inline appPostfix (name : string) (arg : SynType) : SynType =
SynType.App (named name, None, [ arg ], [], None, true, range0) SynType.App (named name, None, [ arg ], [], None, true, range0)
@@ -299,16 +312,54 @@ module internal SynType =
} }
) )
let inline signatureParamOfType (ty : SynType) (name : Ident option) : SynType = let inline signatureParamOfType
SynType.SignatureParameter ([], false, name, ty, range0) (attrs : SynAttribute list)
(ty : SynType)
(optional : bool)
(name : Ident option)
: SynType
=
SynType.SignatureParameter (
attrs
|> List.map (fun attr ->
{
Attributes = [ attr ]
Range = range0
}
),
optional,
name,
ty,
range0
)
let inline var (ty : SynTypar) : SynType = SynType.Var (ty, range0) let inline var (ty : SynTypar) : SynType = SynType.Var (ty, range0)
let unit : SynType = named "unit" let unit : SynType = named "unit"
let obj : SynType = named "obj"
let bool : SynType = named "bool"
let int : SynType = named "int" let int : SynType = named "int"
let array (elt : SynType) : SynType = SynType.Array (1, elt, range0)
let list (elt : SynType) : SynType =
SynType.App (named "list", None, [ elt ], [], None, true, range0)
let option (elt : SynType) : SynType =
SynType.App (named "option", None, [ elt ], [], None, true, range0)
let anon : SynType = SynType.Anon range0 let anon : SynType = SynType.Anon range0
let task (elt : SynType) : SynType =
SynType.App (
createLongIdent' [ "System" ; "Threading" ; "Tasks" ; "Task" ],
None,
[ elt ],
[],
None,
true,
range0
)
let string : SynType = named "string" let string : SynType = named "string"
/// Given ['a1, 'a2] and 'ret, returns 'a1 -> 'a2 -> 'ret. /// Given ['a1, 'a2] and 'ret, returns 'a1 -> 'a2 -> 'ret.

View File

@@ -13,8 +13,12 @@ module internal SynTypeDefnRepr =
let inline augmentation () : SynTypeDefnRepr = let inline augmentation () : SynTypeDefnRepr =
SynTypeDefnRepr.ObjectModel (SynTypeDefnKind.Augmentation range0, [], range0) SynTypeDefnRepr.ObjectModel (SynTypeDefnKind.Augmentation range0, [], range0)
let inline union (cases : SynUnionCase list) : SynTypeDefnRepr = let inline unionWithAccess (implAccess : SynAccess option) (cases : SynUnionCase list) : SynTypeDefnRepr =
SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (None, cases, range0), range0) SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (implAccess, cases, range0), range0)
let inline record (fields : SynField list) : SynTypeDefnRepr = let inline union (cases : SynUnionCase list) : SynTypeDefnRepr = unionWithAccess None cases
SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (None, fields, range0), range0)
let inline recordWithAccess (implAccess : SynAccess option) (fields : SynField list) : SynTypeDefnRepr =
SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (implAccess, fields, range0), range0)
let inline record (fields : SynField list) : SynTypeDefnRepr = recordWithAccess None fields

View File

@@ -44,7 +44,7 @@ module internal SynUnionCase =
SynUnionCase.SynUnionCase ( SynUnionCase.SynUnionCase (
SynAttributes.ofAttrs case.Attributes, SynAttributes.ofAttrs case.Attributes,
SynIdent.SynIdent (case.Name, None), SynIdent.createI case.Name,
SynUnionCaseKind.Fields fields, SynUnionCaseKind.Fields fields,
case.XmlDoc |> Option.defaultValue PreXmlDoc.Empty, case.XmlDoc |> Option.defaultValue PreXmlDoc.Empty,
case.Access, case.Access,

View File

@@ -30,6 +30,7 @@
<Compile Include="SynExpr\SynAttributes.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\SynIdent.fs" />
<Compile Include="SynExpr\SynLongIdent.fs" /> <Compile Include="SynExpr\SynLongIdent.fs" />
<Compile Include="SynExpr\SynExprLetOrUseTrivia.fs" /> <Compile Include="SynExpr\SynExprLetOrUseTrivia.fs" />
<Compile Include="SynExpr\SynArgPats.fs" /> <Compile Include="SynExpr\SynArgPats.fs" />

6
flake.lock generated
View File

@@ -20,11 +20,11 @@
}, },
"nixpkgs": { "nixpkgs": {
"locked": { "locked": {
"lastModified": 1725099143, "lastModified": 1725534445,
"narHash": "sha256-CHgumPZaC7z+WYx72WgaLt2XF0yUVzJS60rO4GZ7ytY=", "narHash": "sha256-Yd0FK9SkWy+ZPuNqUgmVPXokxDgMJoGuNpMEtkfcf84=",
"owner": "NixOS", "owner": "NixOS",
"repo": "nixpkgs", "repo": "nixpkgs",
"rev": "5629520edecb69630a3f4d17d3d33fc96c13f6fe", "rev": "9bb1e7571aadf31ddb4af77fc64b2d59580f9a39",
"type": "github" "type": "github"
}, },
"original": { "original": {

View File

@@ -8,8 +8,8 @@
}) })
(fetchNuGet { (fetchNuGet {
pname = "fantomas"; pname = "fantomas";
version = "6.3.11"; version = "6.3.12";
hash = "sha256-11bHGEAZTNtdp2pTg5zqLrQiyI/j/AT7GGL/2CR4+dw="; hash = "sha256-LFZn2cO72FlsmLI0vTLz52Bn4XBeGILTOr8rz/EuXeg=";
}) })
(fetchNuGet { (fetchNuGet {
pname = "Fantomas.Core"; pname = "Fantomas.Core";
@@ -78,13 +78,13 @@
}) })
(fetchNuGet { (fetchNuGet {
pname = "Microsoft.CodeCoverage"; pname = "Microsoft.CodeCoverage";
version = "17.11.0"; version = "17.11.1";
hash = "sha256-XglInnx5GePUYHG7n2NLX+WfK7kJnornsWOW/5FnOXE="; hash = "sha256-1dLlK3NGh88PuFYZiYpT+izA96etxhU3BSgixDgdtGA=";
}) })
(fetchNuGet { (fetchNuGet {
pname = "Microsoft.NET.Test.Sdk"; pname = "Microsoft.NET.Test.Sdk";
version = "17.11.0"; version = "17.11.1";
hash = "sha256-WjyA78+PG9ZloWTt9Hf1ek3VVj2FfJ9fAjqklnN+fWw="; hash = "sha256-0JUEucQ2lzaPgkrjm/NFLBTbqU1dfhvhN3Tl3moE6mI=";
}) })
(fetchNuGet { (fetchNuGet {
pname = "Microsoft.NETCore.App.Host.linux-arm64"; pname = "Microsoft.NETCore.App.Host.linux-arm64";
@@ -153,13 +153,13 @@
}) })
(fetchNuGet { (fetchNuGet {
pname = "Microsoft.TestPlatform.ObjectModel"; pname = "Microsoft.TestPlatform.ObjectModel";
version = "17.11.0"; version = "17.11.1";
hash = "sha256-mCI3MCV6nyrGLrBat5VvK5LrXTEKlsdp9NkpZyJYwVg="; hash = "sha256-5vX+vCzFY3S7xfMVIv8OlMMFtdedW9UIJzc0WEc+vm4=";
}) })
(fetchNuGet { (fetchNuGet {
pname = "Microsoft.TestPlatform.TestHost"; pname = "Microsoft.TestPlatform.TestHost";
version = "17.11.0"; version = "17.11.1";
hash = "sha256-gViDLobza22kuLvB4JdlGtbANqwBHRwf1wLmIHMw9Eo="; hash = "sha256-wSkY0H1fQAq0H3LcKT4u7Y5RzhAAPa6yueVN84g8HxU=";
}) })
(fetchNuGet { (fetchNuGet {
pname = "Myriad.Core"; pname = "Myriad.Core";