mirror of
https://github.com/Smaug123/WoofWare.Myriad
synced 2025-10-05 20:18:43 +00:00
Compose records in arg parser (#234)
This commit is contained in:
1
.fantomasignore
Normal file
1
.fantomasignore
Normal file
@@ -0,0 +1 @@
|
||||
.direnv/
|
@@ -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,38 @@ 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 : string list
|
||||
}
|
||||
|
||||
[<ArgParser true>]
|
||||
type ParentRecordChildPos =
|
||||
{
|
||||
Child : ChildRecordWithPositional
|
||||
AndAnother : bool
|
||||
}
|
||||
|
||||
[<ArgParser true>]
|
||||
type ParentRecordSelfPos =
|
||||
{
|
||||
Child : ChildRecord
|
||||
[<PositionalArgs>]
|
||||
AndAnother : bool list
|
||||
}
|
||||
|
File diff suppressed because it is too large
Load Diff
@@ -341,3 +341,83 @@ 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=some" ; "--thing2=thing" ]
|
||||
|
||||
parsed
|
||||
|> shouldEqual
|
||||
{
|
||||
Child =
|
||||
{
|
||||
Thing1 = 9
|
||||
Thing2 = [ "some" ; "thing" ]
|
||||
}
|
||||
AndAnother = true
|
||||
}
|
||||
|
||||
[<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)"""
|
||||
|
@@ -57,6 +57,150 @@ 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 ParseFunction * Teq<'hasPositional, HasNoPositional>
|
||||
| PositionalLeaf of ParseFunction * 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>) : ParseFunction 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>) : ParseFunction list * ParseFunction =
|
||||
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>) : ParseFunction list * ParseFunction 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
|
||||
|
||||
/// 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 =
|
||||
|
||||
@@ -254,16 +398,21 @@ module internal ArgParserGenerator =
|
||||
| Accumulation.Required -> parseElt, Accumulation.List, 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,6 +462,20 @@ module internal ArgParserGenerator =
|
||||
| None -> failwith "expected args field to have a name, but it did not"
|
||||
| Some i -> i
|
||||
|
||||
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 ->
|
||||
|
||||
let parser, accumulation, parseTy = createParseFunction ident attrs fieldType
|
||||
|
||||
match positionalArgAttr with
|
||||
@@ -322,47 +485,41 @@ module internal ArgParserGenerator =
|
||||
{
|
||||
FieldName = ident
|
||||
Parser = parser
|
||||
TargetVariable = ident
|
||||
TargetVariable = Ident.create $"arg_%i{counter}"
|
||||
Accumulation = accumulation
|
||||
TargetType = parseTy
|
||||
ArgForm = argify ident
|
||||
Help = helpText
|
||||
}
|
||||
|> ArgToParse.Positional
|
||||
|> fun t -> ParseTree.PositionalLeaf (t, Teq.refl)
|
||||
|> ParseTreeCrate.make
|
||||
| _ -> failwith $"Expected positional arg accumulation type to be List, but it was %O{fieldType}"
|
||||
| None ->
|
||||
{
|
||||
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
|
||||
@@ -478,10 +635,10 @@ module internal ArgParserGenerator =
|
||||
| Accumulation.List ->
|
||||
[
|
||||
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
|
||||
@@ -508,14 +665,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 list) : SynBinding =
|
||||
(SynExpr.CreateConst false, flags)
|
||||
||> List.fold (fun finalExpr flag ->
|
||||
let multipleErrorMessage =
|
||||
@@ -568,7 +725,7 @@ module internal ArgParserGenerator =
|
||||
(leftoverArgParser : SynExpr)
|
||||
: SynBinding
|
||||
=
|
||||
/// `go (AwaitingValue arg) args
|
||||
/// `go (AwaitingValue arg) args`
|
||||
let recurseValue =
|
||||
SynExpr.createIdent "go"
|
||||
|> SynExpr.applyTo (
|
||||
@@ -608,9 +765,9 @@ module internal ArgParserGenerator =
|
||||
argStartsWithDashes
|
||||
(SynExpr.sequential
|
||||
[
|
||||
(SynExpr.createIdent "arg"
|
||||
|> SynExpr.pipeThroughFunction leftoverArgParser
|
||||
|> SynExpr.pipeThroughFunction (SynExpr.createLongIdent' [ leftoverArgs ; Ident.create "Add" ]))
|
||||
SynExpr.createIdent "arg"
|
||||
|> SynExpr.pipeThroughFunction leftoverArgParser
|
||||
|> SynExpr.pipeThroughFunction (SynExpr.createLongIdent' [ leftoverArgs ; Ident.create "Add" ])
|
||||
|
||||
recurseKey
|
||||
])
|
||||
@@ -786,18 +943,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
|
||||
@@ -816,7 +979,7 @@ 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")),
|
||||
@@ -839,7 +1002,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 +1012,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 ->
|
||||
@@ -912,7 +1075,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 +1098,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 +1132,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,7 +1156,7 @@ 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" ]
|
||||
@@ -1019,8 +1174,8 @@ module internal ArgParserGenerator =
|
||||
|> SynExpr.createLet (
|
||||
bindings
|
||||
@ [
|
||||
processKeyValue argParseErrors (Option.toList spec.Positionals @ spec.NonPositionals)
|
||||
setFlagValue parseState argParseErrors flags
|
||||
processKeyValue argParseErrors (Option.toList pos @ nonPos)
|
||||
setFlagValue argParseErrors flags
|
||||
mainLoop parseState argParseErrors leftoverArgsName leftoverArgsParser
|
||||
]
|
||||
)
|
||||
@@ -1029,10 +1184,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 +1244,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 +1304,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 +1336,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 +1355,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">
|
||||
|
Reference in New Issue
Block a user