mirror of
https://github.com/Smaug123/WoofWare.Myriad
synced 2025-10-05 20:18:43 +00:00
Compare commits
4 Commits
WoofWare.M
...
WoofWare.M
Author | SHA1 | Date | |
---|---|---|---|
|
8f9f933971 | ||
|
3a55ba1242 | ||
|
047b2eda99 | ||
|
2220f88053 |
1
.fantomasignore
Normal file
1
.fantomasignore
Normal file
@@ -0,0 +1 @@
|
||||
.direnv/
|
1
.gitignore
vendored
1
.gitignore
vendored
@@ -11,3 +11,4 @@ result
|
||||
analysis.sarif
|
||||
.direnv/
|
||||
.venv/
|
||||
.vs/
|
||||
|
@@ -1,5 +1,9 @@
|
||||
Notable changes are recorded here.
|
||||
|
||||
# WoofWare.Myriad.Plugins 2.2.1, WoofWare.Myriad.Plugins.Attributes 3.2.1
|
||||
|
||||
New generator: `ArgParser`, a basic reflection-free argument parser.
|
||||
|
||||
# WoofWare.Myriad.Plugins 2.1.45, WoofWare.Myriad.Plugins.Attributes 3.1.7
|
||||
|
||||
The NuGet packages are now attested to through [GitHub Attestations](https://github.blog/2024-05-02-introducing-artifact-attestations-now-in-public-beta/).
|
||||
|
@@ -93,3 +93,45 @@ type DatesAndTimes =
|
||||
[<InvariantCulture ; ParseExact @"hh\:mm\:ss">]
|
||||
InvariantExact : TimeSpan
|
||||
}
|
||||
|
||||
type ChildRecord =
|
||||
{
|
||||
Thing1 : int
|
||||
Thing2 : string
|
||||
}
|
||||
|
||||
[<ArgParser true>]
|
||||
type ParentRecord =
|
||||
{
|
||||
Child : ChildRecord
|
||||
AndAnother : bool
|
||||
}
|
||||
|
||||
type ChildRecordWithPositional =
|
||||
{
|
||||
Thing1 : int
|
||||
[<PositionalArgs>]
|
||||
Thing2 : Uri list
|
||||
}
|
||||
|
||||
[<ArgParser true>]
|
||||
type ParentRecordChildPos =
|
||||
{
|
||||
Child : ChildRecordWithPositional
|
||||
AndAnother : bool
|
||||
}
|
||||
|
||||
[<ArgParser true>]
|
||||
type ParentRecordSelfPos =
|
||||
{
|
||||
Child : ChildRecord
|
||||
[<PositionalArgs>]
|
||||
AndAnother : bool list
|
||||
}
|
||||
|
||||
[<ArgParser true>]
|
||||
type ChoicePositionals =
|
||||
{
|
||||
[<PositionalArgs>]
|
||||
Args : Choice<string, string> list
|
||||
}
|
||||
|
File diff suppressed because it is too large
Load Diff
@@ -5,6 +5,11 @@
|
||||
|
||||
<IsPackable>false</IsPackable>
|
||||
<IsTestProject>true</IsTestProject>
|
||||
<!--
|
||||
Known high severity vulnerability
|
||||
I have not yet seen a single instance where I care about this warning
|
||||
-->
|
||||
<NoWarn>$(NoWarn),NU1903</NoWarn>
|
||||
</PropertyGroup>
|
||||
|
||||
<ItemGroup>
|
||||
|
@@ -341,3 +341,94 @@ Input string was not in a correct format. (at arg --exact=11:34)
|
||||
Required argument '--exact' received no value"""
|
||||
|
||||
count.Value |> shouldEqual 0
|
||||
|
||||
[<Test>]
|
||||
let ``Can consume stacked record without positionals`` () =
|
||||
let getEnvVar (_ : string) = failwith "should not call"
|
||||
|
||||
let parsed =
|
||||
ParentRecord.parse' getEnvVar [ "--and-another=true" ; "--thing1=9" ; "--thing2=a thing!" ]
|
||||
|
||||
parsed
|
||||
|> shouldEqual
|
||||
{
|
||||
Child =
|
||||
{
|
||||
Thing1 = 9
|
||||
Thing2 = "a thing!"
|
||||
}
|
||||
AndAnother = true
|
||||
}
|
||||
|
||||
[<Test>]
|
||||
let ``Can consume stacked record, child has positionals`` () =
|
||||
let getEnvVar (_ : string) = failwith "should not call"
|
||||
|
||||
let parsed =
|
||||
ParentRecordChildPos.parse'
|
||||
getEnvVar
|
||||
[
|
||||
"--and-another=true"
|
||||
"--thing1=9"
|
||||
"--thing2=https://example.com"
|
||||
"--thing2=http://example.com"
|
||||
]
|
||||
|
||||
parsed.AndAnother |> shouldEqual true
|
||||
parsed.Child.Thing1 |> shouldEqual 9
|
||||
|
||||
parsed.Child.Thing2
|
||||
|> List.map (fun (x : Uri) -> x.ToString ())
|
||||
|> shouldEqual [ "https://example.com/" ; "http://example.com/" ]
|
||||
|
||||
[<Test>]
|
||||
let ``Can consume stacked record, child has no positionals, parent has positionals`` () =
|
||||
let getEnvVar (_ : string) = failwith "should not call"
|
||||
|
||||
let parsed =
|
||||
ParentRecordSelfPos.parse'
|
||||
getEnvVar
|
||||
[
|
||||
"--and-another=true"
|
||||
"--and-another=false"
|
||||
"--and-another=true"
|
||||
"--thing1=9"
|
||||
"--thing2=some"
|
||||
]
|
||||
|
||||
parsed
|
||||
|> shouldEqual
|
||||
{
|
||||
Child =
|
||||
{
|
||||
Thing1 = 9
|
||||
Thing2 = "some"
|
||||
}
|
||||
AndAnother = [ true ; false ; true ]
|
||||
}
|
||||
|
||||
[<Test>]
|
||||
let ``Help text for stacked records`` () =
|
||||
let getEnvVar (_ : string) = failwith "should not call"
|
||||
|
||||
let exc =
|
||||
Assert.Throws<exn> (fun () ->
|
||||
ParentRecordSelfPos.parse' getEnvVar [ "--help" ] |> ignore<ParentRecordSelfPos>
|
||||
)
|
||||
|
||||
exc.Message
|
||||
|> shouldEqual
|
||||
"""Help text requested.
|
||||
--thing1 int32
|
||||
--thing2 string
|
||||
--and-another bool (positional args) (can be repeated)"""
|
||||
|
||||
[<Test>]
|
||||
let ``Positionals are tagged with Choice`` () =
|
||||
let getEnvVar (_ : string) = failwith "should not call"
|
||||
|
||||
ChoicePositionals.parse' getEnvVar [ "a" ; "b" ; "--" ; "--c" ; "--help" ]
|
||||
|> shouldEqual
|
||||
{
|
||||
Args = [ Choice1Of2 "a" ; Choice1Of2 "b" ; Choice2Of2 "--c" ; Choice2Of2 "--help" ]
|
||||
}
|
||||
|
@@ -4,6 +4,11 @@
|
||||
<TargetFramework>net8.0</TargetFramework>
|
||||
<IsPackable>false</IsPackable>
|
||||
<IsTestProject>true</IsTestProject>
|
||||
<!--
|
||||
Known high severity vulnerability
|
||||
I have not yet seen a single instance where I care about this warning
|
||||
-->
|
||||
<NoWarn>$(NoWarn),NU1903</NoWarn>
|
||||
</PropertyGroup>
|
||||
|
||||
<ItemGroup>
|
||||
|
@@ -22,13 +22,13 @@ type private ArgumentDefaultSpec =
|
||||
/// we would use `MyArgs.DefaultThing () : int`.
|
||||
| FunctionCall of name : Ident
|
||||
|
||||
type private Accumulation =
|
||||
type private Accumulation<'choice> =
|
||||
| Required
|
||||
| Optional
|
||||
| Choice of ArgumentDefaultSpec
|
||||
| List
|
||||
| Choice of 'choice
|
||||
| List of Accumulation<'choice>
|
||||
|
||||
type private ParseFunction =
|
||||
type private ParseFunction<'acc> =
|
||||
{
|
||||
FieldName : Ident
|
||||
TargetVariable : Ident
|
||||
@@ -42,20 +42,183 @@ type private ParseFunction =
|
||||
/// If `Accumulation` is `List`, then this is the type of the list *element*; analogously for optionals
|
||||
/// and choices and so on.
|
||||
TargetType : SynType
|
||||
Accumulation : Accumulation
|
||||
Accumulation : 'acc
|
||||
}
|
||||
|
||||
[<RequireQualifiedAccess>]
|
||||
type private ChoicePositional =
|
||||
| Normal
|
||||
| Choice
|
||||
|
||||
type private ParseFunctionPositional = ParseFunction<ChoicePositional>
|
||||
type private ParseFunctionNonPositional = ParseFunction<Accumulation<ArgumentDefaultSpec>>
|
||||
|
||||
type private ParserSpec =
|
||||
{
|
||||
NonPositionals : ParseFunction list
|
||||
NonPositionals : ParseFunctionNonPositional list
|
||||
/// The variable into which positional arguments will be accumulated.
|
||||
/// In this case, the TargetVariable is a `ResizeArray` rather than the usual `option`.
|
||||
Positionals : ParseFunction option
|
||||
Positionals : ParseFunctionPositional option
|
||||
}
|
||||
|
||||
type private ArgToParse =
|
||||
| Positional of ParseFunction
|
||||
| NonPositional of ParseFunction
|
||||
type private HasPositional = HasPositional
|
||||
type private HasNoPositional = HasNoPositional
|
||||
|
||||
[<AutoOpen>]
|
||||
module private TeqUtils =
|
||||
let exFalso<'a> (_ : Teq<HasNoPositional, HasPositional>) : 'a = failwith "LOGIC ERROR!"
|
||||
let exFalso'<'a> (_ : Teq<HasPositional, HasNoPositional>) : 'a = failwith "LOGIC ERROR!"
|
||||
|
||||
[<RequireQualifiedAccess>]
|
||||
type private ParseTree<'hasPositional> =
|
||||
| NonPositionalLeaf of ParseFunctionNonPositional * Teq<'hasPositional, HasNoPositional>
|
||||
| PositionalLeaf of ParseFunctionPositional * Teq<'hasPositional, HasPositional>
|
||||
/// `assemble` takes the SynExpr's (e.g. each record field contents) corresponding to each `Ident` in
|
||||
/// the branch (e.g. each record field name),
|
||||
/// and composes them into a `SynExpr` (e.g. the record-typed object).
|
||||
| Branch of
|
||||
fields : (Ident * ParseTree<HasNoPositional>) list *
|
||||
assemble : (Map<string, SynExpr> -> SynExpr) *
|
||||
Teq<'hasPositional, HasNoPositional>
|
||||
/// `assemble` takes the SynExpr's (e.g. each record field contents) corresponding to each `Ident` in
|
||||
/// the branch (e.g. each record field name),
|
||||
/// and composes them into a `SynExpr` (e.g. the record-typed object).
|
||||
| BranchPos of
|
||||
posField : Ident *
|
||||
fields : ParseTree<HasPositional> *
|
||||
(Ident * ParseTree<HasNoPositional>) list *
|
||||
assemble : (Map<string, SynExpr> -> SynExpr) *
|
||||
Teq<'hasPositional, HasPositional>
|
||||
|
||||
type private ParseTreeEval<'ret> =
|
||||
abstract Eval<'a> : ParseTree<'a> -> 'ret
|
||||
|
||||
type private ParseTreeCrate =
|
||||
abstract Apply<'ret> : ParseTreeEval<'ret> -> 'ret
|
||||
|
||||
[<RequireQualifiedAccess>]
|
||||
module private ParseTreeCrate =
|
||||
let make<'a> (p : ParseTree<'a>) =
|
||||
{ new ParseTreeCrate with
|
||||
member _.Apply a = a.Eval p
|
||||
}
|
||||
|
||||
[<RequireQualifiedAccess>]
|
||||
module private ParseTree =
|
||||
[<RequireQualifiedAccess>]
|
||||
type State =
|
||||
| Positional of ParseTree<HasPositional> * ParseTree<HasNoPositional> list
|
||||
| NoPositional of ParseTree<HasNoPositional> list
|
||||
|
||||
let private cast (t : Teq<'a, 'b>) : Teq<ParseTree<'a>, ParseTree<'b>> = Teq.Cong.believeMe t
|
||||
|
||||
/// The `Ident` here is the field name.
|
||||
let branch (assemble : Map<string, SynExpr> -> SynExpr) (subs : (Ident * ParseTreeCrate) list) : ParseTreeCrate =
|
||||
let rec go
|
||||
(selfIdent : Ident option)
|
||||
(acc : (Ident * ParseTree<HasNoPositional>) list, pos : (Ident * ParseTree<HasPositional>) option)
|
||||
(subs : (Ident * ParseTreeCrate) list)
|
||||
: ParseTreeCrate
|
||||
=
|
||||
match subs with
|
||||
| [] ->
|
||||
match pos with
|
||||
| None -> ParseTree.Branch (List.rev acc, assemble, Teq.refl) |> ParseTreeCrate.make
|
||||
| Some (posField, pos) ->
|
||||
ParseTree.BranchPos (posField, pos, List.rev acc, assemble, Teq.refl)
|
||||
|> ParseTreeCrate.make
|
||||
| (fieldName, sub) :: subs ->
|
||||
{ new ParseTreeEval<_> with
|
||||
member _.Eval (t : ParseTree<'a>) =
|
||||
match t with
|
||||
| ParseTree.NonPositionalLeaf (_, teq)
|
||||
| ParseTree.Branch (_, _, teq) ->
|
||||
go selfIdent (((fieldName, Teq.cast (cast teq) t) :: acc), pos) subs
|
||||
| ParseTree.PositionalLeaf (_, teq)
|
||||
| ParseTree.BranchPos (_, _, _, _, teq) ->
|
||||
match pos with
|
||||
| None -> go selfIdent (acc, Some (fieldName, Teq.cast (cast teq) t)) subs
|
||||
| Some (ident, _) ->
|
||||
failwith
|
||||
$"Multiple entries tried to claim positional args! %s{ident.idText} and %s{fieldName.idText}"
|
||||
}
|
||||
|> sub.Apply
|
||||
|
||||
go None ([], None) subs
|
||||
|
||||
let rec accumulatorsNonPos (tree : ParseTree<HasNoPositional>) : ParseFunctionNonPositional list =
|
||||
match tree with
|
||||
| ParseTree.PositionalLeaf (_, teq) -> exFalso teq
|
||||
| ParseTree.BranchPos (_, _, _, _, teq) -> exFalso teq
|
||||
| ParseTree.NonPositionalLeaf (pf, _) -> [ pf ]
|
||||
| ParseTree.Branch (trees, _, _) -> trees |> List.collect (snd >> accumulatorsNonPos)
|
||||
|
||||
/// Returns the positional arg separately.
|
||||
let rec accumulatorsPos
|
||||
(tree : ParseTree<HasPositional>)
|
||||
: ParseFunctionNonPositional list * ParseFunctionPositional
|
||||
=
|
||||
match tree with
|
||||
| ParseTree.PositionalLeaf (pf, _) -> [], pf
|
||||
| ParseTree.NonPositionalLeaf (_, teq) -> exFalso' teq
|
||||
| ParseTree.Branch (_, _, teq) -> exFalso' teq
|
||||
| ParseTree.BranchPos (_, tree, trees, _, _) ->
|
||||
let nonPos = trees |> List.collect (snd >> accumulatorsNonPos)
|
||||
|
||||
let nonPos2, pos = accumulatorsPos tree
|
||||
nonPos @ nonPos2, pos
|
||||
|
||||
/// Collect all the ParseFunctions which are necessary to define variables, throwing away
|
||||
/// all information relevant to composing the resulting variables into records.
|
||||
/// Returns the list of non-positional parsers, and any positional parser that exists.
|
||||
let accumulators<'a> (tree : ParseTree<'a>) : ParseFunctionNonPositional list * ParseFunctionPositional option =
|
||||
// Sad duplication of some code here, but it was the easiest way to make it type-safe :(
|
||||
match tree with
|
||||
| ParseTree.PositionalLeaf (pf, _) -> [], Some pf
|
||||
| ParseTree.NonPositionalLeaf (pf, _) -> [ pf ], None
|
||||
| ParseTree.Branch (trees, _, _) -> trees |> List.collect (snd >> accumulatorsNonPos) |> (fun i -> i, None)
|
||||
| ParseTree.BranchPos (_, tree, trees, _, _) ->
|
||||
let nonPos = trees |> List.collect (snd >> accumulatorsNonPos)
|
||||
|
||||
let nonPos2, pos = accumulatorsPos tree
|
||||
nonPos @ nonPos2, Some pos
|
||||
|
||||
|> fun (nonPos, pos) ->
|
||||
let duplicateArgs =
|
||||
Option.toList (pos |> Option.map _.ArgForm) @ (nonPos |> List.map _.ArgForm)
|
||||
|> List.groupBy id
|
||||
|> List.choose (fun (key, v) -> if v.Length > 1 then Some key else None)
|
||||
|
||||
match duplicateArgs with
|
||||
| [] -> nonPos, pos
|
||||
| dups ->
|
||||
let dups = dups |> String.concat " "
|
||||
failwith $"Duplicate args detected! %s{dups}"
|
||||
|
||||
/// Build the return value.
|
||||
let rec instantiate<'a> (tree : ParseTree<'a>) : SynExpr =
|
||||
match tree with
|
||||
| ParseTree.NonPositionalLeaf (pf, _) -> SynExpr.createIdent' pf.TargetVariable
|
||||
| ParseTree.PositionalLeaf (pf, _) -> SynExpr.createIdent' pf.TargetVariable
|
||||
| ParseTree.Branch (trees, assemble, _) ->
|
||||
trees
|
||||
|> List.map (fun (fieldName, contents) ->
|
||||
let instantiated = instantiate contents
|
||||
fieldName.idText, instantiated
|
||||
)
|
||||
|> Map.ofList
|
||||
|> assemble
|
||||
| ParseTree.BranchPos (posField, tree, trees, assemble, _) ->
|
||||
let withPos = instantiate tree
|
||||
|
||||
trees
|
||||
|> List.map (fun (fieldName, contents) ->
|
||||
let instantiated = instantiate contents
|
||||
fieldName.idText, instantiated
|
||||
)
|
||||
|> Map.ofList
|
||||
|> Map.add posField.idText withPos
|
||||
|> assemble
|
||||
|
||||
[<RequireQualifiedAccess>]
|
||||
module internal ArgParserGenerator =
|
||||
@@ -77,11 +240,12 @@ module internal ArgParserGenerator =
|
||||
/// for example, maybe it returns a `ty option` or a `ty list`).
|
||||
/// The resulting SynType is the type of the *element* being parsed; so if the Accumulation is List, the SynType
|
||||
/// is the list element.
|
||||
let rec private createParseFunction
|
||||
let rec private createParseFunction<'choice>
|
||||
(choice : ArgumentDefaultSpec option -> 'choice)
|
||||
(fieldName : Ident)
|
||||
(attrs : SynAttribute list)
|
||||
(ty : SynType)
|
||||
: SynExpr * Accumulation * SynType
|
||||
: SynExpr * Accumulation<'choice> * SynType
|
||||
=
|
||||
match ty with
|
||||
| String -> SynExpr.createLambda "x" (SynExpr.createIdent "x"), Accumulation.Required, SynType.string
|
||||
@@ -93,6 +257,12 @@ module internal ArgParserGenerator =
|
||||
(SynExpr.createIdent "x")),
|
||||
Accumulation.Required,
|
||||
ty
|
||||
| Uri ->
|
||||
SynExpr.createLambda
|
||||
"x"
|
||||
(SynExpr.applyFunction (SynExpr.createLongIdent [ "System" ; "Uri" ]) (SynExpr.createIdent "x")),
|
||||
Accumulation.Required,
|
||||
ty
|
||||
| TimeSpan ->
|
||||
let parseExact =
|
||||
attrs
|
||||
@@ -164,7 +334,7 @@ module internal ArgParserGenerator =
|
||||
Accumulation.Required,
|
||||
ty
|
||||
| OptionType eltTy ->
|
||||
let parseElt, acc, childTy = createParseFunction fieldName attrs eltTy
|
||||
let parseElt, acc, childTy = createParseFunction choice fieldName attrs eltTy
|
||||
|
||||
match acc with
|
||||
| Accumulation.Optional ->
|
||||
@@ -173,7 +343,7 @@ module internal ArgParserGenerator =
|
||||
| Accumulation.Choice _ ->
|
||||
failwith
|
||||
$"ArgParser does not support optionals containing choices at field %s{fieldName.idText}: %O{ty}"
|
||||
| Accumulation.List ->
|
||||
| Accumulation.List _ ->
|
||||
failwith $"ArgParser does not support optional lists at field %s{fieldName.idText}: %O{ty}"
|
||||
| Accumulation.Required -> parseElt, Accumulation.Optional, childTy
|
||||
| ChoiceType elts ->
|
||||
@@ -183,13 +353,13 @@ module internal ArgParserGenerator =
|
||||
failwith
|
||||
$"ArgParser was unable to prove types %O{elt1} and %O{elt2} to be equal in a Choice. We require them to be equal."
|
||||
|
||||
let parseElt, acc, childTy = createParseFunction fieldName attrs elt1
|
||||
let parseElt, acc, childTy = createParseFunction choice fieldName attrs elt1
|
||||
|
||||
match acc with
|
||||
| Accumulation.Optional ->
|
||||
failwith
|
||||
$"ArgParser does not support choices containing options at field %s{fieldName.idText}: %O{ty}"
|
||||
| Accumulation.List ->
|
||||
| Accumulation.List _ ->
|
||||
failwith
|
||||
$"ArgParser does not support choices containing lists at field %s{fieldName.idText}: %O{ty}"
|
||||
| Accumulation.Choice _ ->
|
||||
@@ -227,43 +397,39 @@ module internal ArgParserGenerator =
|
||||
|
||||
let relevantAttr =
|
||||
match relevantAttrs with
|
||||
| [] ->
|
||||
failwith
|
||||
$"Expected Choice to be annotated with ArgumentDefaultFunction or similar, but it was not. Field: %s{fieldName.idText}"
|
||||
| [ x ] -> x
|
||||
| [] -> None
|
||||
| [ x ] -> Some x
|
||||
| _ ->
|
||||
failwith
|
||||
$"Expected Choice to be annotated with exactly one ArgumentDefaultFunction or similar, but it was annotated with multiple. Field: %s{fieldName.idText}"
|
||||
$"Expected Choice to be annotated with at most one ArgumentDefaultFunction or similar, but it was annotated with multiple. Field: %s{fieldName.idText}"
|
||||
|
||||
parseElt, Accumulation.Choice relevantAttr, childTy
|
||||
parseElt, Accumulation.Choice (choice relevantAttr), childTy
|
||||
| elts ->
|
||||
let elts = elts |> List.map string<SynType> |> String.concat ", "
|
||||
|
||||
failwith
|
||||
$"ArgParser requires Choice to be of the form Choice<'a, 'a>; that is, two arguments, both the same. For field %s{fieldName.idText}, got: %s{elts}"
|
||||
| ListType eltTy ->
|
||||
let parseElt, acc, childTy = createParseFunction fieldName attrs eltTy
|
||||
let parseElt, acc, childTy = createParseFunction choice fieldName attrs eltTy
|
||||
|
||||
match acc with
|
||||
| Accumulation.List ->
|
||||
failwith $"ArgParser does not support nested lists at field %s{fieldName.idText}: %O{ty}"
|
||||
| Accumulation.Choice _ ->
|
||||
failwith $"ArgParser does not support lists containing choices at field %s{fieldName.idText}: %O{ty}"
|
||||
| Accumulation.Optional ->
|
||||
failwith $"ArgParser does not support lists of options at field %s{fieldName.idText}: %O{ty}"
|
||||
| Accumulation.Required -> parseElt, Accumulation.List, childTy
|
||||
parseElt, Accumulation.List acc, childTy
|
||||
| _ -> failwith $"Could not decide how to parse arguments for field %s{fieldName.idText} of type %O{ty}"
|
||||
|
||||
let private toParseSpec (finalRecord : RecordType) : ParserSpec =
|
||||
let rec private toParseSpec
|
||||
(counter : int)
|
||||
(ambientRecords : RecordType list)
|
||||
(finalRecord : RecordType)
|
||||
: ParseTreeCrate * int
|
||||
=
|
||||
finalRecord.Fields
|
||||
|> List.iter (fun (SynField.SynField (isStatic = isStatic)) ->
|
||||
if isStatic then
|
||||
failwith "No static record fields allowed in ArgParserGenerator"
|
||||
)
|
||||
|
||||
let args : ArgToParse list =
|
||||
finalRecord.Fields
|
||||
|> List.map (fun (SynField.SynField (attrs, _, identOption, fieldType, _, _, _, _, _)) ->
|
||||
let counter, contents =
|
||||
((counter, []), finalRecord.Fields)
|
||||
||> List.fold (fun (counter, acc) (SynField.SynField (attrs, _, identOption, fieldType, _, _, _, _, _)) ->
|
||||
let attrs = attrs |> List.collect (fun a -> a.Attributes)
|
||||
|
||||
let positionalArgAttr =
|
||||
@@ -313,77 +479,110 @@ module internal ArgParserGenerator =
|
||||
| None -> failwith "expected args field to have a name, but it did not"
|
||||
| Some i -> i
|
||||
|
||||
let parser, accumulation, parseTy = createParseFunction ident attrs fieldType
|
||||
let ambientRecordMatch =
|
||||
match fieldType with
|
||||
| SynType.LongIdent (SynLongIdent.SynLongIdent (id, _, _)) ->
|
||||
let target = List.last(id).idText
|
||||
ambientRecords |> List.tryFind (fun r -> r.Name.idText = target)
|
||||
| _ -> None
|
||||
|
||||
match ambientRecordMatch with
|
||||
| Some ambient ->
|
||||
// This field has a type we need to obtain from parsing another record.
|
||||
let spec, counter = toParseSpec counter ambientRecords ambient
|
||||
counter, (ident, spec) :: acc
|
||||
| None ->
|
||||
|
||||
match positionalArgAttr with
|
||||
| Some _ ->
|
||||
let getChoice (spec : ArgumentDefaultSpec option) : unit =
|
||||
match spec with
|
||||
| Some _ ->
|
||||
failwith
|
||||
"Positional Choice args cannot have default values. Remove [<ArgumentDefault*>] from the positional arg."
|
||||
| None -> ()
|
||||
|
||||
let parser, accumulation, parseTy =
|
||||
createParseFunction<unit> getChoice ident attrs fieldType
|
||||
|
||||
match accumulation with
|
||||
| Accumulation.List ->
|
||||
| Accumulation.List (Accumulation.List _) ->
|
||||
failwith "A list of positional args cannot contain lists."
|
||||
| Accumulation.List Accumulation.Optional ->
|
||||
failwith "A list of positional args cannot contain optionals. What would that even mean?"
|
||||
| Accumulation.List (Accumulation.Choice ()) ->
|
||||
{
|
||||
FieldName = ident
|
||||
Parser = parser
|
||||
TargetVariable = ident
|
||||
Accumulation = accumulation
|
||||
TargetVariable = Ident.create $"arg_%i{counter}"
|
||||
Accumulation = ChoicePositional.Choice
|
||||
TargetType = parseTy
|
||||
ArgForm = argify ident
|
||||
Help = helpText
|
||||
}
|
||||
|> ArgToParse.Positional
|
||||
| _ -> failwith $"Expected positional arg accumulation type to be List, but it was %O{fieldType}"
|
||||
|> fun t -> ParseTree.PositionalLeaf (t, Teq.refl)
|
||||
| Accumulation.List Accumulation.Required ->
|
||||
{
|
||||
FieldName = ident
|
||||
Parser = parser
|
||||
TargetVariable = Ident.create $"arg_%i{counter}"
|
||||
Accumulation = ChoicePositional.Normal
|
||||
TargetType = parseTy
|
||||
ArgForm = argify ident
|
||||
Help = helpText
|
||||
}
|
||||
|> fun t -> ParseTree.PositionalLeaf (t, Teq.refl)
|
||||
| Accumulation.Choice _
|
||||
| Accumulation.Optional
|
||||
| Accumulation.Required ->
|
||||
failwith $"Expected positional arg accumulation type to be List, but it was %O{fieldType}"
|
||||
|> ParseTreeCrate.make
|
||||
| None ->
|
||||
let getChoice (spec : ArgumentDefaultSpec option) : ArgumentDefaultSpec =
|
||||
match spec with
|
||||
| None ->
|
||||
failwith
|
||||
"Non-positional Choice args must have an `[<ArgumentDefault*>]` attribute on them."
|
||||
| Some spec -> spec
|
||||
|
||||
let parser, accumulation, parseTy =
|
||||
createParseFunction getChoice ident attrs fieldType
|
||||
|
||||
{
|
||||
FieldName = ident
|
||||
Parser = parser
|
||||
TargetVariable = ident
|
||||
TargetVariable = Ident.create $"arg_%i{counter}"
|
||||
Accumulation = accumulation
|
||||
TargetType = parseTy
|
||||
ArgForm = argify ident
|
||||
Help = helpText
|
||||
}
|
||||
|> ArgToParse.NonPositional
|
||||
|> fun t -> ParseTree.NonPositionalLeaf (t, Teq.refl)
|
||||
|> ParseTreeCrate.make
|
||||
|> fun tree -> counter + 1, (ident, tree) :: acc
|
||||
)
|
||||
|
||||
let positional, nonPositionals =
|
||||
let mutable p = None
|
||||
let n = ResizeArray ()
|
||||
let tree =
|
||||
contents
|
||||
|> List.rev
|
||||
|> ParseTree.branch (fun args ->
|
||||
args
|
||||
|> Map.toList
|
||||
|> List.map (fun (ident, expr) -> SynLongIdent.create [ Ident.create ident ], expr)
|
||||
|> AstHelper.instantiateRecord
|
||||
)
|
||||
|
||||
for arg in args do
|
||||
match arg with
|
||||
| ArgToParse.Positional arg ->
|
||||
match p with
|
||||
| None -> p <- Some arg
|
||||
| Some existing ->
|
||||
failwith
|
||||
$"Multiple args were tagged with `Positional`: %s{existing.TargetVariable.idText}, %s{arg.TargetVariable.idText}"
|
||||
| ArgToParse.NonPositional arg -> n.Add arg
|
||||
|
||||
p, List.ofSeq n
|
||||
|
||||
{
|
||||
NonPositionals = nonPositionals
|
||||
Positionals = positional
|
||||
}
|
||||
tree, counter
|
||||
|
||||
/// let helpText : string = ...
|
||||
let private helpText
|
||||
(typeName : Ident)
|
||||
(positional : ParseFunction option)
|
||||
(args : ParseFunction list)
|
||||
(positional : ParseFunctionPositional option)
|
||||
(args : ParseFunctionNonPositional list)
|
||||
: SynBinding
|
||||
=
|
||||
let toPrintable (prefix : string) (arg : ParseFunction) : SynExpr =
|
||||
let ty = arg.TargetType |> SynType.toHumanReadableString
|
||||
|
||||
let helpText =
|
||||
match arg.Help with
|
||||
| None -> SynExpr.CreateConst ""
|
||||
| Some helpText ->
|
||||
SynExpr.applyFunction (SynExpr.createIdent "sprintf") (SynExpr.CreateConst " : %s")
|
||||
|> SynExpr.applyTo (SynExpr.paren helpText)
|
||||
|> SynExpr.paren
|
||||
|
||||
let descriptor =
|
||||
match arg.Accumulation with
|
||||
let describeNonPositional (acc : Accumulation<ArgumentDefaultSpec>) : SynExpr =
|
||||
match acc with
|
||||
| Accumulation.Required -> SynExpr.CreateConst ""
|
||||
| Accumulation.Optional -> SynExpr.CreateConst " (optional)"
|
||||
| Accumulation.Choice (ArgumentDefaultSpec.EnvironmentVariable var) ->
|
||||
@@ -399,14 +598,28 @@ module internal ArgParserGenerator =
|
||||
| Accumulation.Choice (ArgumentDefaultSpec.FunctionCall var) ->
|
||||
SynExpr.callMethod var.idText (SynExpr.createIdent' typeName)
|
||||
|> SynExpr.pipeThroughFunction (
|
||||
SynExpr.applyFunction
|
||||
(SynExpr.createIdent "sprintf")
|
||||
(SynExpr.CreateConst " (default value: %O)")
|
||||
SynExpr.applyFunction (SynExpr.createIdent "sprintf") (SynExpr.CreateConst " (default value: %O)")
|
||||
)
|
||||
|> SynExpr.paren
|
||||
| Accumulation.List -> SynExpr.CreateConst " (can be repeated)"
|
||||
| Accumulation.List _ -> SynExpr.CreateConst " (can be repeated)"
|
||||
|
||||
let prefix = $"%s{arg.ArgForm} %s{ty}%s{prefix}"
|
||||
let describePositional _ =
|
||||
SynExpr.CreateConst " (positional args) (can be repeated)"
|
||||
|
||||
let toPrintable (describe : 'a -> SynExpr) (arg : ParseFunction<'a>) : SynExpr =
|
||||
let ty = arg.TargetType |> SynType.toHumanReadableString
|
||||
|
||||
let helpText =
|
||||
match arg.Help with
|
||||
| None -> SynExpr.CreateConst ""
|
||||
| Some helpText ->
|
||||
SynExpr.applyFunction (SynExpr.createIdent "sprintf") (SynExpr.CreateConst " : %s")
|
||||
|> SynExpr.applyTo (SynExpr.paren helpText)
|
||||
|> SynExpr.paren
|
||||
|
||||
let descriptor = describe arg.Accumulation
|
||||
|
||||
let prefix = $"%s{arg.ArgForm} %s{ty}"
|
||||
|
||||
SynExpr.applyFunction (SynExpr.createIdent "sprintf") (SynExpr.CreateConst (prefix + "%s%s"))
|
||||
|> SynExpr.applyTo descriptor
|
||||
@@ -414,11 +627,11 @@ module internal ArgParserGenerator =
|
||||
|> SynExpr.paren
|
||||
|
||||
args
|
||||
|> List.map (toPrintable "")
|
||||
|> List.map (toPrintable describeNonPositional)
|
||||
|> fun l ->
|
||||
match positional with
|
||||
| None -> l
|
||||
| Some pos -> l @ [ toPrintable " (positional args)" pos ]
|
||||
| Some pos -> l @ [ toPrintable describePositional pos ]
|
||||
|> SynExpr.listLiteral
|
||||
|> SynExpr.pipeThroughFunction (
|
||||
SynExpr.applyFunction (SynExpr.createLongIdent [ "String" ; "concat" ]) (SynExpr.CreateConst @"\n")
|
||||
@@ -429,9 +642,15 @@ module internal ArgParserGenerator =
|
||||
/// Returns a possible error.
|
||||
/// A parse failure might not be fatal (e.g. maybe the input was optionally of arity 0, and we failed to do
|
||||
/// the parse because in fact the key decided not to take this argument); in that case we return Error None.
|
||||
let private processKeyValue (argParseErrors : Ident) (args : ParseFunction list) : SynBinding =
|
||||
(SynExpr.applyFunction (SynExpr.createIdent "Error") (SynExpr.createIdent "None"), args)
|
||||
||> List.fold (fun finalBranch arg ->
|
||||
let private processKeyValue
|
||||
(argParseErrors : Ident)
|
||||
(pos : ParseFunctionPositional option)
|
||||
(args : ParseFunctionNonPositional list)
|
||||
: SynBinding
|
||||
=
|
||||
let args =
|
||||
args
|
||||
|> List.map (fun arg ->
|
||||
match arg.Accumulation with
|
||||
| Accumulation.Required
|
||||
| Accumulation.Choice _
|
||||
@@ -475,23 +694,54 @@ module internal ArgParserGenerator =
|
||||
performAssignment)
|
||||
]
|
||||
|> SynExpr.createMatch (SynExpr.createIdent' arg.TargetVariable)
|
||||
| Accumulation.List ->
|
||||
| Accumulation.List (Accumulation.List _)
|
||||
| Accumulation.List Accumulation.Optional
|
||||
| Accumulation.List (Accumulation.Choice _) ->
|
||||
failwith
|
||||
"WoofWare.Myriad invariant violated: expected a list to contain only a Required accumulation. Non-positional lists cannot be optional or Choice, nor can they themselves contain lists."
|
||||
| Accumulation.List Accumulation.Required ->
|
||||
[
|
||||
SynExpr.createIdent "value"
|
||||
|> SynExpr.pipeThroughFunction arg.Parser
|
||||
|> SynExpr.pipeThroughFunction (
|
||||
SynExpr.createLongIdent' [ arg.TargetVariable ; Ident.create "Add" ]
|
||||
)
|
||||
|> SynExpr.applyFunction arg.Parser
|
||||
SynExpr.CreateConst () |> SynExpr.pipeThroughFunction (SynExpr.createIdent "Ok")
|
||||
]
|
||||
|> SynExpr.sequential
|
||||
|> fun expr -> arg.ArgForm, expr
|
||||
)
|
||||
|
||||
let posArg =
|
||||
match pos with
|
||||
| None -> []
|
||||
| Some pos ->
|
||||
[
|
||||
SynExpr.createIdent "value"
|
||||
|> SynExpr.pipeThroughFunction pos.Parser
|
||||
|> fun p ->
|
||||
match pos.Accumulation with
|
||||
| ChoicePositional.Choice -> p |> SynExpr.pipeThroughFunction (SynExpr.createIdent "Choice1Of2")
|
||||
| ChoicePositional.Normal -> p
|
||||
|> SynExpr.pipeThroughFunction (
|
||||
SynExpr.createLongIdent' [ pos.TargetVariable ; Ident.create "Add" ]
|
||||
)
|
||||
SynExpr.CreateConst () |> SynExpr.pipeThroughFunction (SynExpr.createIdent "Ok")
|
||||
]
|
||||
|> SynExpr.sequential
|
||||
|> fun expr -> pos.ArgForm, expr
|
||||
|> List.singleton
|
||||
|
||||
(SynExpr.applyFunction (SynExpr.createIdent "Error") (SynExpr.createIdent "None"), posArg @ args)
|
||||
||> List.fold (fun finalBranch (argForm, arg) ->
|
||||
arg
|
||||
|> SynExpr.ifThenElse
|
||||
(SynExpr.applyFunction
|
||||
(SynExpr.createLongIdent [ "System" ; "String" ; "Equals" ])
|
||||
(SynExpr.tuple
|
||||
[
|
||||
SynExpr.createIdent "key"
|
||||
SynExpr.CreateConst arg.ArgForm
|
||||
SynExpr.CreateConst argForm
|
||||
SynExpr.createLongIdent [ "System" ; "StringComparison" ; "OrdinalIgnoreCase" ]
|
||||
]))
|
||||
finalBranch
|
||||
@@ -508,14 +758,14 @@ module internal ArgParserGenerator =
|
||||
|> SynBinding.withXmlDoc (
|
||||
[
|
||||
" Processes the key-value pair, returning Error if no key was matched."
|
||||
" If the key is an arg which can arity 1, but throws when consuming that arg, we return Error(<the message>)."
|
||||
" If the key is an arg which can have arity 1, but throws when consuming that arg, we return Error(<the message>)."
|
||||
" This can nevertheless be a successful parse, e.g. when the key may have arity 0."
|
||||
]
|
||||
|> PreXmlDoc.create'
|
||||
)
|
||||
|
||||
/// `let setFlagValue (key : string) : bool = ...`
|
||||
let private setFlagValue (parseState : Ident) (argParseErrors : Ident) (flags : ParseFunction list) : SynBinding =
|
||||
let private setFlagValue (argParseErrors : Ident) (flags : ParseFunction<'a> list) : SynBinding =
|
||||
(SynExpr.CreateConst false, flags)
|
||||
||> List.fold (fun finalExpr flag ->
|
||||
let multipleErrorMessage =
|
||||
@@ -564,11 +814,12 @@ module internal ArgParserGenerator =
|
||||
let private mainLoop
|
||||
(parseState : Ident)
|
||||
(errorAcc : Ident)
|
||||
(leftoverArgAcc : ChoicePositional)
|
||||
(leftoverArgs : Ident)
|
||||
(leftoverArgParser : SynExpr)
|
||||
: SynBinding
|
||||
=
|
||||
/// `go (AwaitingValue arg) args
|
||||
/// `go (AwaitingValue arg) args`
|
||||
let recurseValue =
|
||||
SynExpr.createIdent "go"
|
||||
|> SynExpr.applyTo (
|
||||
@@ -608,9 +859,14 @@ module internal ArgParserGenerator =
|
||||
argStartsWithDashes
|
||||
(SynExpr.sequential
|
||||
[
|
||||
(SynExpr.createIdent "arg"
|
||||
SynExpr.createIdent "arg"
|
||||
|> SynExpr.pipeThroughFunction leftoverArgParser
|
||||
|> SynExpr.pipeThroughFunction (SynExpr.createLongIdent' [ leftoverArgs ; Ident.create "Add" ]))
|
||||
|> 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
|
||||
])
|
||||
@@ -775,6 +1031,16 @@ module internal ArgParserGenerator =
|
||||
|> SynExpr.pipeThroughFunction (
|
||||
SynExpr.applyFunction (SynExpr.createLongIdent [ "Seq" ; "map" ]) leftoverArgParser
|
||||
)
|
||||
|> fun p ->
|
||||
match leftoverArgAcc with
|
||||
| ChoicePositional.Normal -> p
|
||||
| ChoicePositional.Choice ->
|
||||
p
|
||||
|> SynExpr.pipeThroughFunction (
|
||||
SynExpr.applyFunction
|
||||
(SynExpr.createLongIdent [ "Seq" ; "map" ])
|
||||
(SynExpr.createIdent "Choice2Of2")
|
||||
)
|
||||
))
|
||||
(SynExpr.createIdent' leftoverArgs))
|
||||
SynMatchClause.create (SynPat.listCons (SynPat.named "arg") (SynPat.named "args")) argBody
|
||||
@@ -786,18 +1052,24 @@ module internal ArgParserGenerator =
|
||||
SynPat.named "state"
|
||||
|> SynPat.annotateType (SynType.createLongIdent [ parseState ])
|
||||
SynPat.named "args"
|
||||
|> SynPat.annotateType (SynType.appPostfix "list" (SynType.string))
|
||||
|> SynPat.annotateType (SynType.appPostfix "list" SynType.string)
|
||||
]
|
||||
|
||||
SynBinding.basic [ Ident.create "go" ] args body
|
||||
|> SynBinding.withRecursion true
|
||||
|
||||
/// Takes a single argument, `args : string list`, and returns something of the type indicated by `recordType`.
|
||||
let createRecordParse (parseState : Ident) (recordType : RecordType) : SynExpr =
|
||||
let spec = toParseSpec recordType
|
||||
let createRecordParse (parseState : Ident) (ambientRecords : RecordType list) (recordType : RecordType) : SynExpr =
|
||||
let spec, _ = toParseSpec 0 ambientRecords recordType
|
||||
// For each argument (positional and non-positional), create an accumulator for it.
|
||||
let nonPos, pos =
|
||||
{ new ParseTreeEval<_> with
|
||||
member _.Eval tree = ParseTree.accumulators tree
|
||||
}
|
||||
|> spec.Apply
|
||||
|
||||
let bindings =
|
||||
spec.NonPositionals
|
||||
nonPos
|
||||
|> List.map (fun pf ->
|
||||
match pf.Accumulation with
|
||||
| Accumulation.Required
|
||||
@@ -807,7 +1079,12 @@ module internal ArgParserGenerator =
|
||||
|> SynBinding.basic [ pf.TargetVariable ] []
|
||||
|> SynBinding.withMutability true
|
||||
|> SynBinding.withReturnAnnotation (SynType.appPostfix "option" pf.TargetType)
|
||||
| Accumulation.List ->
|
||||
| Accumulation.List (Accumulation.List _)
|
||||
| Accumulation.List Accumulation.Optional
|
||||
| Accumulation.List (Accumulation.Choice _) ->
|
||||
failwith
|
||||
"WoofWare.Myriad invariant violated: expected a list to contain only a Required accumulation. Non-positional lists cannot be optional or Choice, nor can they themselves contain lists."
|
||||
| Accumulation.List Accumulation.Required ->
|
||||
SynExpr.createIdent "ResizeArray"
|
||||
|> SynExpr.applyTo (SynExpr.CreateConst ())
|
||||
|> SynBinding.basic [ pf.TargetVariable ] []
|
||||
@@ -816,12 +1093,16 @@ module internal ArgParserGenerator =
|
||||
|
||||
let bindings, leftoverArgsName, leftoverArgsParser =
|
||||
let bindingName, leftoverArgsParser, leftoverArgsType =
|
||||
match spec.Positionals with
|
||||
match pos with
|
||||
| None ->
|
||||
Ident.create "parser_LeftoverArgs",
|
||||
(SynExpr.createLambda "x" (SynExpr.createIdent "x")),
|
||||
SynType.string
|
||||
| Some pf -> pf.TargetVariable, pf.Parser, pf.TargetType
|
||||
| Some pf ->
|
||||
match pf.Accumulation with
|
||||
| ChoicePositional.Choice ->
|
||||
pf.TargetVariable, pf.Parser, SynType.app "Choice" [ pf.TargetType ; pf.TargetType ]
|
||||
| ChoicePositional.Normal -> pf.TargetVariable, pf.Parser, pf.TargetType
|
||||
|
||||
let bindings =
|
||||
SynExpr.createIdent "ResizeArray"
|
||||
@@ -839,7 +1120,7 @@ module internal ArgParserGenerator =
|
||||
|> SynExpr.applyTo (SynExpr.CreateConst ())
|
||||
|> SynBinding.basic [ argParseErrors ] []
|
||||
|
||||
let helpText = helpText recordType.Name spec.Positionals spec.NonPositionals
|
||||
let helpText = helpText recordType.Name pos nonPos
|
||||
|
||||
let bindings = errorCollection :: helpText :: bindings
|
||||
|
||||
@@ -849,7 +1130,7 @@ module internal ArgParserGenerator =
|
||||
|
||||
// Determine whether any required arg is missing, and freeze args into immutable form.
|
||||
let freezeNonPositionalArgs =
|
||||
spec.NonPositionals
|
||||
nonPos
|
||||
|> List.map (fun pf ->
|
||||
match pf.Accumulation with
|
||||
| Accumulation.Choice spec ->
|
||||
@@ -902,7 +1183,12 @@ module internal ArgParserGenerator =
|
||||
|> SynBinding.basic [ pf.TargetVariable ] []
|
||||
| Accumulation.Optional ->
|
||||
SynBinding.basic [ pf.TargetVariable ] [] (SynExpr.createIdent' pf.TargetVariable)
|
||||
| Accumulation.List ->
|
||||
| Accumulation.List (Accumulation.List _)
|
||||
| Accumulation.List Accumulation.Optional
|
||||
| Accumulation.List (Accumulation.Choice _) ->
|
||||
failwith
|
||||
"WoofWare.Myriad invariant violated: expected a list to contain only a Required accumulation. Non-positional lists cannot be optional or Choice, nor can they themselves contain lists."
|
||||
| Accumulation.List Accumulation.Required ->
|
||||
SynBinding.basic
|
||||
[ pf.TargetVariable ]
|
||||
[]
|
||||
@@ -912,7 +1198,7 @@ module internal ArgParserGenerator =
|
||||
let errorMessage =
|
||||
SynExpr.createIdent "sprintf"
|
||||
|> SynExpr.applyTo (SynExpr.CreateConst "Required argument '%s' received no value")
|
||||
|> SynExpr.applyTo (SynExpr.CreateConst (argify pf.TargetVariable))
|
||||
|> SynExpr.applyTo (SynExpr.CreateConst pf.ArgForm)
|
||||
|
||||
[
|
||||
SynMatchClause.create
|
||||
@@ -935,7 +1221,7 @@ module internal ArgParserGenerator =
|
||||
)
|
||||
|
||||
let freezePositional =
|
||||
match spec.Positionals with
|
||||
match pos with
|
||||
| None ->
|
||||
// Check if there are leftover args. If there are, throw.
|
||||
let errorMessage =
|
||||
@@ -969,20 +1255,12 @@ module internal ArgParserGenerator =
|
||||
|
||||
let freezeArgs = freezePositional @ freezeNonPositionalArgs
|
||||
|
||||
let retPositional =
|
||||
match spec.Positionals with
|
||||
| None -> []
|
||||
| Some pf ->
|
||||
[
|
||||
SynLongIdent.createI pf.TargetVariable, SynExpr.createIdent' pf.TargetVariable
|
||||
]
|
||||
|
||||
let retValue =
|
||||
let happyPath =
|
||||
spec.NonPositionals
|
||||
|> List.map (fun pf -> SynLongIdent.createI pf.TargetVariable, SynExpr.createIdent' pf.TargetVariable)
|
||||
|> fun np -> retPositional @ np
|
||||
|> AstHelper.instantiateRecord
|
||||
{ new ParseTreeEval<_> with
|
||||
member _.Eval tree = ParseTree.instantiate tree
|
||||
}
|
||||
|> spec.Apply
|
||||
|
||||
let sadPath =
|
||||
SynExpr.createIdent' argParseErrors
|
||||
@@ -1001,13 +1279,18 @@ module internal ArgParserGenerator =
|
||||
SynExpr.ifThenElse areErrors sadPath happyPath
|
||||
|
||||
let flags =
|
||||
spec.NonPositionals
|
||||
nonPos
|
||||
|> List.filter (fun pf ->
|
||||
match pf.TargetType with
|
||||
| PrimitiveType pt -> (pt |> List.map _.idText) = [ "System" ; "Boolean" ]
|
||||
| _ -> false
|
||||
)
|
||||
|
||||
let leftoverArgAcc =
|
||||
match pos with
|
||||
| None -> ChoicePositional.Normal
|
||||
| Some pos -> pos.Accumulation
|
||||
|
||||
[
|
||||
SynExpr.createIdent "go"
|
||||
|> SynExpr.applyTo (SynExpr.createLongIdent' [ parseState ; Ident.create "AwaitingKey" ])
|
||||
@@ -1019,9 +1302,9 @@ module internal ArgParserGenerator =
|
||||
|> SynExpr.createLet (
|
||||
bindings
|
||||
@ [
|
||||
processKeyValue argParseErrors (Option.toList spec.Positionals @ spec.NonPositionals)
|
||||
setFlagValue parseState argParseErrors flags
|
||||
mainLoop parseState argParseErrors leftoverArgsName leftoverArgsParser
|
||||
processKeyValue argParseErrors pos nonPos
|
||||
setFlagValue argParseErrors flags
|
||||
mainLoop parseState argParseErrors leftoverArgAcc leftoverArgsName leftoverArgsParser
|
||||
]
|
||||
)
|
||||
|
||||
@@ -1029,10 +1312,13 @@ module internal ArgParserGenerator =
|
||||
(opens : SynOpenDeclTarget list)
|
||||
(ns : LongIdent)
|
||||
((taggedType : SynTypeDefn, spec : ArgParserOutputSpec))
|
||||
(_allUnionTypesTODO : SynTypeDefn list)
|
||||
(allUnionTypes : SynTypeDefn list)
|
||||
(allRecordTypes : SynTypeDefn list)
|
||||
: SynModuleOrNamespace
|
||||
=
|
||||
// The type for which we're generating args may refer to any of these records/unions.
|
||||
let allRecordTypes = allRecordTypes |> List.map RecordType.OfRecord
|
||||
|
||||
let taggedType = RecordType.OfRecord taggedType
|
||||
|
||||
let modAttrs, modName =
|
||||
@@ -1086,7 +1372,7 @@ module internal ArgParserGenerator =
|
||||
|> SynPat.annotateType (SynType.appPostfix "list" SynType.string)
|
||||
|
||||
let parsePrime =
|
||||
createRecordParse parseStateIdent taggedType
|
||||
createRecordParse parseStateIdent allRecordTypes taggedType
|
||||
|> SynBinding.basic
|
||||
[ Ident.create "parse'" ]
|
||||
[
|
||||
@@ -1146,16 +1432,19 @@ module internal ArgParserGenerator =
|
||||
let ast, _ =
|
||||
Ast.fromFilename context.InputFilename |> Async.RunSynchronously |> Array.head
|
||||
|
||||
let types = Ast.extractTypeDefn ast
|
||||
let types =
|
||||
Ast.extractTypeDefn ast
|
||||
|> List.groupBy (fst >> List.map _.idText >> String.concat ".")
|
||||
|> List.map (fun (_, v) -> fst (List.head v), List.collect snd v)
|
||||
|
||||
let opens = AstHelper.extractOpens ast
|
||||
|
||||
let namespaceAndTypes =
|
||||
types
|
||||
|> List.choose (fun (ns, types) ->
|
||||
|> List.collect (fun (ns, types) ->
|
||||
let typeWithAttr =
|
||||
types
|
||||
|> List.tryPick (fun ty ->
|
||||
|> List.choose (fun ty ->
|
||||
match Ast.getAttribute<ArgParserAttribute> ty with
|
||||
| None -> None
|
||||
| Some attr ->
|
||||
@@ -1175,8 +1464,8 @@ module internal ArgParserGenerator =
|
||||
Some (ty, spec)
|
||||
)
|
||||
|
||||
match typeWithAttr with
|
||||
| Some taggedType ->
|
||||
typeWithAttr
|
||||
|> List.map (fun taggedType ->
|
||||
let unions, records, others =
|
||||
(([], [], []), types)
|
||||
||> List.fold (fun
|
||||
@@ -1194,8 +1483,8 @@ module internal ArgParserGenerator =
|
||||
failwith
|
||||
$"Error: all types recursively defined together with an ArgParserGenerator type must be discriminated unions or records. %+A{others}"
|
||||
|
||||
Some (ns, taggedType, unions, records)
|
||||
| _ -> None
|
||||
(ns, taggedType, unions, records)
|
||||
)
|
||||
)
|
||||
|
||||
let modules =
|
||||
|
18
WoofWare.Myriad.Plugins/Teq.fs
Normal file
18
WoofWare.Myriad.Plugins/Teq.fs
Normal file
@@ -0,0 +1,18 @@
|
||||
namespace WoofWare.Myriad.Plugins
|
||||
|
||||
// Extracted from https://github.com/G-Research/TypeEquality
|
||||
// which is Apache-2.0 licenced. See `TeqLicence.txt`.
|
||||
// We inline this code because Myriad doesn't seem to reliably load package references in the generator.
|
||||
// I have reformatted a little, and stripped out all the code I don't use.
|
||||
|
||||
type internal Teq<'a, 'b> = private | Teq of ('a -> 'b) * ('b -> 'a)
|
||||
|
||||
[<RequireQualifiedAccess>]
|
||||
module internal Teq =
|
||||
|
||||
let refl<'a> : Teq<'a, 'a> = Teq (id, id)
|
||||
let cast (Teq (f, _)) a = f a
|
||||
|
||||
[<RequireQualifiedAccess>]
|
||||
module Cong =
|
||||
let believeMe<'a, 'b, 'a2, 'b2> (_ : Teq<'a, 'b>) : Teq<'a2, 'b2> = unbox <| (refl : Teq<'a2, 'a2>)
|
201
WoofWare.Myriad.Plugins/TeqLicence.txt
Normal file
201
WoofWare.Myriad.Plugins/TeqLicence.txt
Normal file
@@ -0,0 +1,201 @@
|
||||
Apache License
|
||||
Version 2.0, January 2004
|
||||
http://www.apache.org/licenses/
|
||||
|
||||
TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
|
||||
|
||||
1. Definitions.
|
||||
|
||||
"License" shall mean the terms and conditions for use, reproduction,
|
||||
and distribution as defined by Sections 1 through 9 of this document.
|
||||
|
||||
"Licensor" shall mean the copyright owner or entity authorized by
|
||||
the copyright owner that is granting the License.
|
||||
|
||||
"Legal Entity" shall mean the union of the acting entity and all
|
||||
other entities that control, are controlled by, or are under common
|
||||
control with that entity. For the purposes of this definition,
|
||||
"control" means (i) the power, direct or indirect, to cause the
|
||||
direction or management of such entity, whether by contract or
|
||||
otherwise, or (ii) ownership of fifty percent (50%) or more of the
|
||||
outstanding shares, or (iii) beneficial ownership of such entity.
|
||||
|
||||
"You" (or "Your") shall mean an individual or Legal Entity
|
||||
exercising permissions granted by this License.
|
||||
|
||||
"Source" form shall mean the preferred form for making modifications,
|
||||
including but not limited to software source code, documentation
|
||||
source, and configuration files.
|
||||
|
||||
"Object" form shall mean any form resulting from mechanical
|
||||
transformation or translation of a Source form, including but
|
||||
not limited to compiled object code, generated documentation,
|
||||
and conversions to other media types.
|
||||
|
||||
"Work" shall mean the work of authorship, whether in Source or
|
||||
Object form, made available under the License, as indicated by a
|
||||
copyright notice that is included in or attached to the work
|
||||
(an example is provided in the Appendix below).
|
||||
|
||||
"Derivative Works" shall mean any work, whether in Source or Object
|
||||
form, that is based on (or derived from) the Work and for which the
|
||||
editorial revisions, annotations, elaborations, or other modifications
|
||||
represent, as a whole, an original work of authorship. For the purposes
|
||||
of this License, Derivative Works shall not include works that remain
|
||||
separable from, or merely link (or bind by name) to the interfaces of,
|
||||
the Work and Derivative Works thereof.
|
||||
|
||||
"Contribution" shall mean any work of authorship, including
|
||||
the original version of the Work and any modifications or additions
|
||||
to that Work or Derivative Works thereof, that is intentionally
|
||||
submitted to Licensor for inclusion in the Work by the copyright owner
|
||||
or by an individual or Legal Entity authorized to submit on behalf of
|
||||
the copyright owner. For the purposes of this definition, "submitted"
|
||||
means any form of electronic, verbal, or written communication sent
|
||||
to the Licensor or its representatives, including but not limited to
|
||||
communication on electronic mailing lists, source code control systems,
|
||||
and issue tracking systems that are managed by, or on behalf of, the
|
||||
Licensor for the purpose of discussing and improving the Work, but
|
||||
excluding communication that is conspicuously marked or otherwise
|
||||
designated in writing by the copyright owner as "Not a Contribution."
|
||||
|
||||
"Contributor" shall mean Licensor and any individual or Legal Entity
|
||||
on behalf of whom a Contribution has been received by Licensor and
|
||||
subsequently incorporated within the Work.
|
||||
|
||||
2. Grant of Copyright License. Subject to the terms and conditions of
|
||||
this License, each Contributor hereby grants to You a perpetual,
|
||||
worldwide, non-exclusive, no-charge, royalty-free, irrevocable
|
||||
copyright license to reproduce, prepare Derivative Works of,
|
||||
publicly display, publicly perform, sublicense, and distribute the
|
||||
Work and such Derivative Works in Source or Object form.
|
||||
|
||||
3. Grant of Patent License. Subject to the terms and conditions of
|
||||
this License, each Contributor hereby grants to You a perpetual,
|
||||
worldwide, non-exclusive, no-charge, royalty-free, irrevocable
|
||||
(except as stated in this section) patent license to make, have made,
|
||||
use, offer to sell, sell, import, and otherwise transfer the Work,
|
||||
where such license applies only to those patent claims licensable
|
||||
by such Contributor that are necessarily infringed by their
|
||||
Contribution(s) alone or by combination of their Contribution(s)
|
||||
with the Work to which such Contribution(s) was submitted. If You
|
||||
institute patent litigation against any entity (including a
|
||||
cross-claim or counterclaim in a lawsuit) alleging that the Work
|
||||
or a Contribution incorporated within the Work constitutes direct
|
||||
or contributory patent infringement, then any patent licenses
|
||||
granted to You under this License for that Work shall terminate
|
||||
as of the date such litigation is filed.
|
||||
|
||||
4. Redistribution. You may reproduce and distribute copies of the
|
||||
Work or Derivative Works thereof in any medium, with or without
|
||||
modifications, and in Source or Object form, provided that You
|
||||
meet the following conditions:
|
||||
|
||||
(a) You must give any other recipients of the Work or
|
||||
Derivative Works a copy of this License; and
|
||||
|
||||
(b) You must cause any modified files to carry prominent notices
|
||||
stating that You changed the files; and
|
||||
|
||||
(c) You must retain, in the Source form of any Derivative Works
|
||||
that You distribute, all copyright, patent, trademark, and
|
||||
attribution notices from the Source form of the Work,
|
||||
excluding those notices that do not pertain to any part of
|
||||
the Derivative Works; and
|
||||
|
||||
(d) If the Work includes a "NOTICE" text file as part of its
|
||||
distribution, then any Derivative Works that You distribute must
|
||||
include a readable copy of the attribution notices contained
|
||||
within such NOTICE file, excluding those notices that do not
|
||||
pertain to any part of the Derivative Works, in at least one
|
||||
of the following places: within a NOTICE text file distributed
|
||||
as part of the Derivative Works; within the Source form or
|
||||
documentation, if provided along with the Derivative Works; or,
|
||||
within a display generated by the Derivative Works, if and
|
||||
wherever such third-party notices normally appear. The contents
|
||||
of the NOTICE file are for informational purposes only and
|
||||
do not modify the License. You may add Your own attribution
|
||||
notices within Derivative Works that You distribute, alongside
|
||||
or as an addendum to the NOTICE text from the Work, provided
|
||||
that such additional attribution notices cannot be construed
|
||||
as modifying the License.
|
||||
|
||||
You may add Your own copyright statement to Your modifications and
|
||||
may provide additional or different license terms and conditions
|
||||
for use, reproduction, or distribution of Your modifications, or
|
||||
for any such Derivative Works as a whole, provided Your use,
|
||||
reproduction, and distribution of the Work otherwise complies with
|
||||
the conditions stated in this License.
|
||||
|
||||
5. Submission of Contributions. Unless You explicitly state otherwise,
|
||||
any Contribution intentionally submitted for inclusion in the Work
|
||||
by You to the Licensor shall be under the terms and conditions of
|
||||
this License, without any additional terms or conditions.
|
||||
Notwithstanding the above, nothing herein shall supersede or modify
|
||||
the terms of any separate license agreement you may have executed
|
||||
with Licensor regarding such Contributions.
|
||||
|
||||
6. Trademarks. This License does not grant permission to use the trade
|
||||
names, trademarks, service marks, or product names of the Licensor,
|
||||
except as required for reasonable and customary use in describing the
|
||||
origin of the Work and reproducing the content of the NOTICE file.
|
||||
|
||||
7. Disclaimer of Warranty. Unless required by applicable law or
|
||||
agreed to in writing, Licensor provides the Work (and each
|
||||
Contributor provides its Contributions) on an "AS IS" BASIS,
|
||||
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
|
||||
implied, including, without limitation, any warranties or conditions
|
||||
of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. You are solely responsible for determining the
|
||||
appropriateness of using or redistributing the Work and assume any
|
||||
risks associated with Your exercise of permissions under this License.
|
||||
|
||||
8. Limitation of Liability. In no event and under no legal theory,
|
||||
whether in tort (including negligence), contract, or otherwise,
|
||||
unless required by applicable law (such as deliberate and grossly
|
||||
negligent acts) or agreed to in writing, shall any Contributor be
|
||||
liable to You for damages, including any direct, indirect, special,
|
||||
incidental, or consequential damages of any character arising as a
|
||||
result of this License or out of the use or inability to use the
|
||||
Work (including but not limited to damages for loss of goodwill,
|
||||
work stoppage, computer failure or malfunction, or any and all
|
||||
other commercial damages or losses), even if such Contributor
|
||||
has been advised of the possibility of such damages.
|
||||
|
||||
9. Accepting Warranty or Additional Liability. While redistributing
|
||||
the Work or Derivative Works thereof, You may choose to offer,
|
||||
and charge a fee for, acceptance of support, warranty, indemnity,
|
||||
or other liability obligations and/or rights consistent with this
|
||||
License. However, in accepting such obligations, You may act only
|
||||
on Your own behalf and on Your sole responsibility, not on behalf
|
||||
of any other Contributor, and only if You agree to indemnify,
|
||||
defend, and hold each Contributor harmless for any liability
|
||||
incurred by, or claims asserted against, such Contributor by reason
|
||||
of your accepting any such warranty or additional liability.
|
||||
|
||||
END OF TERMS AND CONDITIONS
|
||||
|
||||
APPENDIX: How to apply the Apache License to your work.
|
||||
|
||||
To apply the Apache License to your work, attach the following
|
||||
boilerplate notice, with the fields enclosed by brackets "[]"
|
||||
replaced with your own identifying information. (Don't include
|
||||
the brackets!) The text should be enclosed in the appropriate
|
||||
comment syntax for the file format. We also recommend that a
|
||||
file or class name and description of purpose be included on the
|
||||
same "printed page" as the copyright notice for easier
|
||||
identification within third-party archives.
|
||||
|
||||
Copyright [yyyy] [name of copyright owner]
|
||||
|
||||
Licensed under the Apache License, Version 2.0 (the "License");
|
||||
you may not use this file except in compliance with the License.
|
||||
You may obtain a copy of the License at
|
||||
|
||||
http://www.apache.org/licenses/LICENSE-2.0
|
||||
|
||||
Unless required by applicable law or agreed to in writing, software
|
||||
distributed under the License is distributed on an "AS IS" BASIS,
|
||||
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
See the License for the specific language governing permissions and
|
||||
limitations under the License.
|
@@ -25,6 +25,7 @@
|
||||
|
||||
<ItemGroup>
|
||||
<Compile Include="List.fs"/>
|
||||
<Compile Include="Teq.fs" />
|
||||
<Compile Include="Primitives.fs" />
|
||||
<Compile Include="SynExpr\SynAttributes.fs" />
|
||||
<Compile Include="SynExpr\PreXmlDoc.fs" />
|
||||
@@ -56,6 +57,7 @@
|
||||
<Compile Include="HttpClientGenerator.fs"/>
|
||||
<Compile Include="CataGenerator.fs" />
|
||||
<Compile Include="ArgParserGenerator.fs" />
|
||||
<None Include="TeqLicence.txt" />
|
||||
<EmbeddedResource Include="version.json"/>
|
||||
<EmbeddedResource Include="SurfaceBaseline.txt"/>
|
||||
<None Include="..\README.md">
|
||||
|
@@ -1,6 +1,6 @@
|
||||
{
|
||||
"sdk": {
|
||||
"version": "8.0.100",
|
||||
"rollForward": "latestFeature"
|
||||
"rollForward": "latestMajor"
|
||||
}
|
||||
}
|
||||
|
Reference in New Issue
Block a user