Fix record/union impl accessibility (#245)

ConsumePlugin/Args.fs

@@ -142,3 +142,56 @@ type ContainsBoolEnvVar =
         [<ArgumentDefaultEnvironmentVariable "CONSUMEPLUGIN_THINGS">]
         BoolVar : Choice<bool, bool>
     }
+
+[<RequireQualifiedAccess>]
+module Consts =
+    [<Literal>]
+    let FALSE = false
+
+    [<Literal>]
+    let TRUE = true
+
+type DryRunMode =
+    | [<ArgumentFlag(Consts.FALSE)>] Wet
+    | [<ArgumentFlag true>] Dry
+
+[<ArgParser true>]
+type WithFlagDu =
+    {
+        DryRun : DryRunMode
+    }
+
+[<ArgParser true>]
+type ContainsFlagEnvVar =
+    {
+        // This phrasing is odd, but it's for a test. Nobody's really going to have `--dry-run`
+        // controlled by an env var!
+        [<ArgumentDefaultEnvironmentVariable "CONSUMEPLUGIN_THINGS">]
+        DryRun : Choice<DryRunMode, DryRunMode>
+    }
+
+[<ArgParser true>]
+type ContainsFlagDefaultValue =
+    {
+        [<ArgumentDefaultFunction>]
+        DryRun : Choice<DryRunMode, DryRunMode>
+    }
+
+    static member DefaultDryRun () = DryRunMode.Wet
+
+[<ArgParser true>]
+type ManyLongForms =
+    {
+        [<ArgumentLongForm "do-something-else">]
+        [<ArgumentLongForm "anotherarg">]
+        DoTheThing : string
+
+        [<ArgumentLongForm "turn-it-on">]
+        [<ArgumentLongForm "dont-turn-it-off">]
+        SomeFlag : bool
+    }
+
+[<RequireQualifiedAccess>]
+type private IrrelevantDu =
+    | Foo
+    | Bar

WoofWare.Myriad.Plugins.Attributes/ArgParserAttributes.fs

@@ -61,3 +61,24 @@ type ParseExactAttribute (format : string) =
 /// `TimeSpan.ParseExact (s, @"hh\:mm\:ss", CultureInfo.InvariantCulture).
 type InvariantCultureAttribute () =
     inherit Attribute ()
+
+/// Attribute placed on a field of a two-case no-data discriminated union, indicating that this is "basically a bool".
+/// For example: `type DryRun = | [<ArgumentFlag true>] Dry | [<ArgumentFlag false>] Wet`
+/// A record with `{ DryRun : DryRun }` will then be parsed like `{ DryRun : bool }` (so the user supplies `--dry-run`),
+/// but that you get this strongly-typed value directly in the code (so you `match args.DryRun with | DryRun.Dry ...`).
+///
+/// You must put this attribute on both cases of the discriminated union, with opposite values in each case.
+type ArgumentFlagAttribute (flagValue : bool) =
+    inherit Attribute ()
+
+/// Attribute placed on a field of a record to specify a different long form from the default. If you place this
+/// attribute, you won't get the default: ArgFoo would normally be expressed as `--arg-foo`, but if you instead
+/// say `[<ArgumentLongForm "thingy-blah">]` or `[<ArgumentLongForm "thingy">]`, you instead use `--thingy-blah`
+/// or `--thingy` respectively.
+///
+/// You can place this argument multiple times.
+///
+/// Omit the initial `--` that you expect the user to type.
+[<AttributeUsage(AttributeTargets.Field, AllowMultiple = true)>]
+type ArgumentLongForm (s : string) =
+    inherit Attribute ()

WoofWare.Myriad.Plugins.Attributes/SurfaceBaseline.txt

@@ -7,8 +7,12 @@ WoofWare.Myriad.Plugins.ArgumentDefaultEnvironmentVariableAttribute inherit Syst
 WoofWare.Myriad.Plugins.ArgumentDefaultEnvironmentVariableAttribute..ctor [constructor]: string
 WoofWare.Myriad.Plugins.ArgumentDefaultFunctionAttribute inherit System.Attribute
 WoofWare.Myriad.Plugins.ArgumentDefaultFunctionAttribute..ctor [constructor]: unit
+WoofWare.Myriad.Plugins.ArgumentFlagAttribute inherit System.Attribute
+WoofWare.Myriad.Plugins.ArgumentFlagAttribute..ctor [constructor]: bool
 WoofWare.Myriad.Plugins.ArgumentHelpTextAttribute inherit System.Attribute
 WoofWare.Myriad.Plugins.ArgumentHelpTextAttribute..ctor [constructor]: string
+WoofWare.Myriad.Plugins.ArgumentLongForm inherit System.Attribute
+WoofWare.Myriad.Plugins.ArgumentLongForm..ctor [constructor]: string
 WoofWare.Myriad.Plugins.CreateCatamorphismAttribute inherit System.Attribute
 WoofWare.Myriad.Plugins.CreateCatamorphismAttribute..ctor [constructor]: string
 WoofWare.Myriad.Plugins.GenerateMockAttribute inherit System.Attribute

WoofWare.Myriad.Plugins.Attributes/version.json

@@ -1,5 +1,5 @@
 {
-  "version": "3.2",
+  "version": "3.4",
   "publicReleaseRefSpec": [
     "^refs/heads/main$"
   ],
@@ -12,4 +12,4 @@
     "./",
     ":^Test"
   ]
-}
+}

WoofWare.Myriad.Plugins.Test/TestArgParser/TestArgParser.fs

@@ -433,12 +433,18 @@ Required argument '--exact' received no value"""
                 Args = [ Choice1Of2 "a" ; Choice1Of2 "b" ; Choice2Of2 "--c" ; Choice2Of2 "--help" ]
             }
 
-    [<TestCase("1", true)>]
+    let boolCases =
-    [<TestCase("0", false)>]
+        [
-    [<TestCase("true", true)>]
+            "1", true
-    [<TestCase("false", false)>]
+            "0", false
-    [<TestCase("TRUE", true)>]
+            "true", true
-    [<TestCase("FALSE", false)>]
+            "false", false
+            "TRUE", true
+            "FALSE", false
+        ]
+        |> List.map TestCaseData
+
+    [<TestCaseSource(nameof (boolCases))>]
     let ``Bool env vars can be populated`` (envValue : string, boolValue : bool) =
         let getEnvVar (s : string) =
             s |> shouldEqual "CONSUMEPLUGIN_THINGS"
@@ -459,3 +465,156 @@ Required argument '--exact' received no value"""
             {
                 BoolVar = Choice1Of2 true
             }
+
+    [<TestCaseSource(nameof boolCases)>]
+    let ``Flag DUs can be parsed from env var`` (envValue : string, boolValue : bool) =
+        let getEnvVar (s : string) =
+            s |> shouldEqual "CONSUMEPLUGIN_THINGS"
+            envValue
+
+        let boolValue = if boolValue then DryRunMode.Dry else DryRunMode.Wet
+
+        ContainsFlagEnvVar.parse' getEnvVar []
+        |> shouldEqual
+            {
+                DryRun = Choice2Of2 boolValue
+            }
+
+    let dryRunData =
+        [
+            [ "--dry-run" ], DryRunMode.Dry
+            [ "--dry-run" ; "true" ], DryRunMode.Dry
+            [ "--dry-run=true" ], DryRunMode.Dry
+            [ "--dry-run" ; "True" ], DryRunMode.Dry
+            [ "--dry-run=True" ], DryRunMode.Dry
+            [ "--dry-run" ; "false" ], DryRunMode.Wet
+            [ "--dry-run=false" ], DryRunMode.Wet
+            [ "--dry-run" ; "False" ], DryRunMode.Wet
+            [ "--dry-run=False" ], DryRunMode.Wet
+        ]
+        |> List.map TestCaseData
+
+    [<TestCaseSource(nameof dryRunData)>]
+    let ``Flag DUs can be parsed`` (args : string list, expected : DryRunMode) =
+        let getEnvVar (_ : string) = failwith "do not call"
+
+        ContainsFlagEnvVar.parse' getEnvVar args
+        |> shouldEqual
+            {
+                DryRun = Choice1Of2 expected
+            }
+
+    [<TestCaseSource(nameof dryRunData)>]
+    let ``Flag DUs can be parsed, ArgumentDefaultFunction`` (args : string list, expected : DryRunMode) =
+        let getEnvVar (_ : string) = failwith "do not call"
+
+        ContainsFlagDefaultValue.parse' getEnvVar args
+        |> shouldEqual
+            {
+                DryRun = Choice1Of2 expected
+            }
+
+    [<Test>]
+    let ``Flag DUs can be given a default value`` () =
+        let getEnvVar (_ : string) = failwith "do not call"
+
+        ContainsFlagDefaultValue.parse' getEnvVar []
+        |> shouldEqual
+            {
+                DryRun = Choice2Of2 DryRunMode.Wet
+            }
+
+    [<Test>]
+    let ``Help text for flag DU`` () =
+        let getEnvVar (_ : string) = failwith "do not call"
+
+        let exc =
+            Assert.Throws<exn> (fun () ->
+                ContainsFlagDefaultValue.parse' getEnvVar [ "--help" ]
+                |> ignore<ContainsFlagDefaultValue>
+            )
+
+        exc.Message
+        |> shouldEqual
+            """Help text requested.
+--dry-run  bool (default value: false)"""
+
+    [<Test>]
+    let ``Help text for flag DU, non default`` () =
+        let getEnvVar (_ : string) = failwith "do not call"
+
+        let exc =
+            Assert.Throws<exn> (fun () -> WithFlagDu.parse' getEnvVar [ "--help" ] |> ignore<WithFlagDu>)
+
+        exc.Message
+        |> shouldEqual
+            """Help text requested.
+--dry-run  bool"""
+
+    let longFormCases =
+        let doTheThing =
+            [
+                [ "--do-something-else=foo" ]
+                [ "--anotherarg=foo" ]
+                [ "--do-something-else" ; "foo" ]
+                [ "--anotherarg" ; "foo" ]
+            ]
+
+        let someFlag =
+            [
+                [ "--turn-it-on" ], true
+                [ "--dont-turn-it-off" ], true
+                [ "--turn-it-on=true" ], true
+                [ "--dont-turn-it-off=true" ], true
+                [ "--turn-it-on=false" ], false
+                [ "--dont-turn-it-off=false" ], false
+                [ "--turn-it-on" ; "true" ], true
+                [ "--dont-turn-it-off" ; "true" ], true
+                [ "--turn-it-on" ; "false" ], false
+                [ "--dont-turn-it-off" ; "false" ], false
+            ]
+
+        List.allPairs doTheThing someFlag
+        |> List.map (fun (doTheThing, (someFlag, someFlagResult)) ->
+            let args = doTheThing @ someFlag
+
+            let expected =
+                {
+                    DoTheThing = "foo"
+                    SomeFlag = someFlagResult
+                }
+
+            args, expected
+        )
+        |> List.map TestCaseData
+
+    [<TestCaseSource(nameof longFormCases)>]
+    let ``Long-form args`` (args : string list, expected : ManyLongForms) =
+        let getEnvVar (_ : string) = failwith "do not call"
+
+        ManyLongForms.parse' getEnvVar args |> shouldEqual expected
+
+    [<Test>]
+    let ``Long-form args can't be referred to by their original name`` () =
+        let getEnvVar (_ : string) = failwith "do not call"
+
+        let exc =
+            Assert.Throws<exn> (fun () ->
+                ManyLongForms.parse' getEnvVar [ "--do-the-thing=foo" ] |> ignore<ManyLongForms>
+            )
+
+        exc.Message
+        |> shouldEqual """Unable to process argument --do-the-thing=foo as key --do-the-thing and value foo"""
+
+    [<Test>]
+    let ``Long-form args help text`` () =
+        let getEnvVar (_ : string) = failwith "do not call"
+
+        let exc =
+            Assert.Throws<exn> (fun () -> ManyLongForms.parse' getEnvVar [ "--help" ] |> ignore<ManyLongForms>)
+
+        exc.Message
+        |> shouldEqual
+            """Help text requested.
+--do-something-else / --anotherarg  string
+--turn-it-on / --dont-turn-it-off  bool"""

WoofWare.Myriad.Plugins/ArgParserGenerator.fs

@@ -12,6 +12,23 @@ type internal ArgParserOutputSpec =
         ExtensionMethods : bool
     }
 
+type internal FlagDu =
+    {
+        Name : Ident
+        Case1Name : Ident
+        Case2Name : Ident
+        /// Hopefully this is simply the const bool True or False, but it might e.g. be a literal
+        Case1Arg : SynExpr
+        /// Hopefully this is simply the const bool True or False, but it might e.g. be a literal
+        Case2Arg : SynExpr
+    }
+
+    static member FromBoolean (flagDu : FlagDu) (value : SynExpr) =
+        SynExpr.ifThenElse
+            (SynExpr.equals value flagDu.Case1Arg)
+            (SynExpr.createLongIdent' [ flagDu.Name ; flagDu.Case2Name ])
+            (SynExpr.createLongIdent' [ flagDu.Name ; flagDu.Case1Name ])
+
 /// The default value of an argument which admits default values can be pulled from different sources.
 /// This defines which source a particular default value comes from.
 type private ArgumentDefaultSpec =
@@ -20,6 +37,7 @@ type private ArgumentDefaultSpec =
     /// From calling the static member `{typeWeParseInto}.Default{name}()`
     /// For example, if `type MyArgs = { Thing : Choice<int, int> }`, then
     /// we would use `MyArgs.DefaultThing () : int`.
+    ///
     | FunctionCall of name : Ident
 
 type private Accumulation<'choice> =
@@ -32,7 +50,18 @@ type private ParseFunction<'acc> =
     {
         FieldName : Ident
         TargetVariable : Ident
-        ArgForm : string
+        /// Any of the forms in this set are acceptable, but make sure they all start with a dash, or we might
+        /// get confused with positional args or something! I haven't thought that hard about this.
+        /// In the default case, this is `Const("arg-name")` for the `ArgName : blah` field; note that we have
+        /// omitted the initial `--` that will be required at runtime.
+        ArgForm : SynExpr list
+        /// If this is a boolean-like field (e.g. a bool or a flag DU), the help text should look a bit different:
+        /// we should lie to the user about the value of the cases there.
+        /// Similarly, if we're reading from an environment variable with the laxer parsing rules of accepting e.g.
+        /// "0" instead of "false", we need to know if we're reading a bool.
+        /// In that case, `boolCases` is Some, and contains the construction of the flag (or boolean, in which case
+        /// you get no data).
+        BoolCases : Choice<FlagDu, unit> option
         Help : SynExpr option
         /// A function string -> %TargetType%, where TargetVariable is probably a `%TargetType% option`.
         /// (Depending on `Accumulation`, we'll remove the `option` at the end of the parse, asserting that the
@@ -45,6 +74,15 @@ type private ParseFunction<'acc> =
         Accumulation : 'acc
     }
 
+    /// A SynExpr of type `string` which we can display to the user at generated-program runtime to display all
+    /// the ways they can refer to this arg.
+    member arg.HumanReadableArgForm : SynExpr =
+        let formatString = List.replicate arg.ArgForm.Length "--%s" |> String.concat " / "
+
+        (SynExpr.applyFunction (SynExpr.createIdent "sprintf") (SynExpr.CreateConst formatString), arg.ArgForm)
+        ||> List.fold SynExpr.applyFunction
+        |> SynExpr.paren
+
 [<RequireQualifiedAccess>]
 type private ChoicePositional =
     | Normal
@@ -185,7 +223,15 @@ module private ParseTree =
 
         |> fun (nonPos, pos) ->
             let duplicateArgs =
+                // This is best-effort. We can't necessarily detect all SynExprs here, but usually it'll be strings.
                 Option.toList (pos |> Option.map _.ArgForm) @ (nonPos |> List.map _.ArgForm)
+                |> Seq.concat
+                |> Seq.choose (fun expr ->
+                    match expr |> SynExpr.stripOptionalParen with
+                    | SynExpr.Const (SynConst.String (s, _, _), _) -> Some s
+                    | _ -> None
+                )
+                |> List.ofSeq
                 |> List.groupBy id
                 |> List.choose (fun (key, v) -> if v.Length > 1 then Some key else None)
 
@@ -226,7 +272,6 @@ module internal ArgParserGenerator =
     /// Convert e.g. "Foo" into "--foo".
     let argify (ident : Ident) : string =
         let result = StringBuilder ()
-        result.Append "-" |> ignore<StringBuilder>
 
         for c in ident.idText do
             if Char.IsUpper c then
@@ -234,7 +279,18 @@ module internal ArgParserGenerator =
             else
                 result.Append c |> ignore<StringBuilder>
 
-        result.ToString ()
+        result.ToString().TrimStart '-'
+
+    let private identifyAsFlag (flagDus : FlagDu list) (ty : SynType) : FlagDu option =
+        match ty with
+        | SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->
+            flagDus
+            |> List.tryPick (fun du ->
+                let duName = du.Name.idText
+                let ident = List.last(ident).idText
+                if duName = ident then Some du else None
+            )
+        | _ -> None
 
     /// Builds a function or lambda of one string argument, which returns a `ty` (as modified by the `Accumulation`;
     /// for example, maybe it returns a `ty option` or a `ty list`).
@@ -242,6 +298,7 @@ module internal ArgParserGenerator =
     /// is the list element.
     let rec private createParseFunction<'choice>
         (choice : ArgumentDefaultSpec option -> 'choice)
+        (flagDus : FlagDu list)
         (fieldName : Ident)
         (attrs : SynAttribute list)
         (ty : SynType)
@@ -334,7 +391,8 @@ module internal ArgParserGenerator =
             Accumulation.Required,
             ty
         | OptionType eltTy ->
-            let parseElt, acc, childTy = createParseFunction choice fieldName attrs eltTy
+            let parseElt, acc, childTy =
+                createParseFunction choice flagDus fieldName attrs eltTy
 
             match acc with
             | Accumulation.Optional ->
@@ -353,7 +411,7 @@ 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 choice fieldName attrs elt1
+                let parseElt, acc, childTy = createParseFunction choice flagDus fieldName attrs elt1
 
                 match acc with
                 | Accumulation.Optional ->
@@ -391,6 +449,7 @@ module internal ArgParserGenerator =
                         | [ "Myriad" ; "Plugins" ; "ArgumentDefaultEnvironmentVariableAttribute" ]
                         | [ "WoofWare" ; "Myriad" ; "Plugins" ; "ArgumentDefaultEnvironmentVariable" ]
                         | [ "WoofWare" ; "Myriad" ; "Plugins" ; "ArgumentDefaultEnvironmentVariableAttribute" ] ->
+
                             ArgumentDefaultSpec.EnvironmentVariable attr.ArgExpr |> Some
                         | _ -> None
                     )
@@ -410,13 +469,26 @@ module internal ArgParserGenerator =
                 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 choice fieldName attrs eltTy
+            let parseElt, acc, childTy =
+                createParseFunction choice flagDus fieldName attrs eltTy
 
             parseElt, Accumulation.List acc, childTy
-        | _ -> failwith $"Could not decide how to parse arguments for field %s{fieldName.idText} of type %O{ty}"
+        | ty ->
+            match identifyAsFlag flagDus ty with
+            | None -> failwith $"Could not decide how to parse arguments for field %s{fieldName.idText} of type %O{ty}"
+            | Some flagDu ->
+                // Parse as a bool, and then do the `if-then` dance.
+                let parser =
+                    SynExpr.createIdent "x"
+                    |> SynExpr.applyFunction (SynExpr.createLongIdent [ "System" ; "Boolean" ; "Parse" ])
+                    |> FlagDu.FromBoolean flagDu
+                    |> SynExpr.createLambda "x"
+
+                parser, Accumulation.Required, ty
 
     let rec private toParseSpec
         (counter : int)
+        (flagDus : FlagDu list)
         (ambientRecords : RecordType list)
         (finalRecord : RecordType)
         : ParseTreeCrate * int
@@ -479,6 +551,20 @@ module internal ArgParserGenerator =
                     | None -> failwith "expected args field to have a name, but it did not"
                     | Some i -> i
 
+                let longForms =
+                    attrs
+                    |> List.choose (fun attr ->
+                        match attr.TypeName with
+                        | SynLongIdent.SynLongIdent (ident, _, _) ->
+                            if (List.last ident).idText = "ArgumentLongForm" then
+                                Some attr.ArgExpr
+                            else
+                                None
+                    )
+                    |> function
+                        | [] -> List.singleton (SynExpr.CreateConst (argify ident))
+                        | l -> List.ofSeq l
+
                 let ambientRecordMatch =
                     match fieldType with
                     | SynType.LongIdent (SynLongIdent.SynLongIdent (id, _, _)) ->
@@ -489,7 +575,7 @@ module internal ArgParserGenerator =
                 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
+                    let spec, counter = toParseSpec counter flagDus ambientRecords ambient
                     counter, (ident, spec) :: acc
                 | None ->
 
@@ -503,7 +589,13 @@ module internal ArgParserGenerator =
                         | None -> ()
 
                     let parser, accumulation, parseTy =
-                        createParseFunction<unit> getChoice ident attrs fieldType
+                        createParseFunction<unit> getChoice flagDus ident attrs fieldType
+
+                    let isBoolLike =
+                        match parseTy with
+                        | PrimitiveType ident when ident |> List.map _.idText = [ "System" ; "Boolean" ] ->
+                            Some (Choice2Of2 ())
+                        | parseTy -> identifyAsFlag flagDus parseTy |> Option.map Choice1Of2
 
                     match accumulation with
                     | Accumulation.List (Accumulation.List _) ->
@@ -517,8 +609,9 @@ module internal ArgParserGenerator =
                             TargetVariable = Ident.create $"arg_%i{counter}"
                             Accumulation = ChoicePositional.Choice
                             TargetType = parseTy
-                            ArgForm = argify ident
+                            ArgForm = longForms
                             Help = helpText
+                            BoolCases = isBoolLike
                         }
                         |> fun t -> ParseTree.PositionalLeaf (t, Teq.refl)
                     | Accumulation.List Accumulation.Required ->
@@ -528,8 +621,9 @@ module internal ArgParserGenerator =
                             TargetVariable = Ident.create $"arg_%i{counter}"
                             Accumulation = ChoicePositional.Normal
                             TargetType = parseTy
-                            ArgForm = argify ident
+                            ArgForm = longForms
                             Help = helpText
+                            BoolCases = isBoolLike
                         }
                         |> fun t -> ParseTree.PositionalLeaf (t, Teq.refl)
                     | Accumulation.Choice _
@@ -546,7 +640,13 @@ module internal ArgParserGenerator =
                         | Some spec -> spec
 
                     let parser, accumulation, parseTy =
-                        createParseFunction getChoice ident attrs fieldType
+                        createParseFunction getChoice flagDus ident attrs fieldType
+
+                    let isBoolLike =
+                        match parseTy with
+                        | PrimitiveType ident when ident |> List.map _.idText = [ "System" ; "Boolean" ] ->
+                            Some (Choice2Of2 ())
+                        | parseTy -> identifyAsFlag flagDus parseTy |> Option.map Choice1Of2
 
                     {
                         FieldName = ident
@@ -554,8 +654,9 @@ module internal ArgParserGenerator =
                         TargetVariable = Ident.create $"arg_%i{counter}"
                         Accumulation = accumulation
                         TargetType = parseTy
-                        ArgForm = argify ident
+                        ArgForm = longForms
                         Help = helpText
+                        BoolCases = isBoolLike
                     }
                     |> fun t -> ParseTree.NonPositionalLeaf (t, Teq.refl)
                     |> ParseTreeCrate.make
@@ -581,7 +682,11 @@ module internal ArgParserGenerator =
         (args : ParseFunctionNonPositional list)
         : SynBinding
         =
-        let describeNonPositional (acc : Accumulation<ArgumentDefaultSpec>) : SynExpr =
+        let describeNonPositional
+            (acc : Accumulation<ArgumentDefaultSpec>)
+            (flagCases : Choice<FlagDu, unit> option)
+            : SynExpr
+            =
             match acc with
             | Accumulation.Required -> SynExpr.CreateConst ""
             | Accumulation.Optional -> SynExpr.CreateConst " (optional)"
@@ -596,18 +701,43 @@ module internal ArgParserGenerator =
                 )
                 |> SynExpr.paren
             | Accumulation.Choice (ArgumentDefaultSpec.FunctionCall var) ->
-                SynExpr.callMethod var.idText (SynExpr.createIdent' typeName)
+                match flagCases with
+                | None -> SynExpr.callMethod var.idText (SynExpr.createIdent' typeName)
+                | Some (Choice2Of2 ()) -> SynExpr.callMethod var.idText (SynExpr.createIdent' typeName)
+                | Some (Choice1Of2 flagDu) ->
+                    // Care required here. The return value from the Default call is not a bool,
+                    // but we should display it as such to the user!
+                    [
+                        SynMatchClause.create
+                            (SynPat.identWithArgs [ flagDu.Name ; flagDu.Case1Name ] (SynArgPats.create []))
+                            (SynExpr.ifThenElse
+                                (SynExpr.equals flagDu.Case1Arg (SynExpr.CreateConst true))
+                                (SynExpr.CreateConst "false")
+                                (SynExpr.CreateConst "true"))
+                        SynMatchClause.create
+                            (SynPat.identWithArgs [ flagDu.Name ; flagDu.Case2Name ] (SynArgPats.create []))
+                            (SynExpr.ifThenElse
+                                (SynExpr.equals flagDu.Case2Arg (SynExpr.CreateConst true))
+                                (SynExpr.CreateConst "false")
+                                (SynExpr.CreateConst "true"))
+                    ]
+                    |> SynExpr.createMatch (SynExpr.callMethod var.idText (SynExpr.createIdent' typeName))
                 |> SynExpr.pipeThroughFunction (
                     SynExpr.applyFunction (SynExpr.createIdent "sprintf") (SynExpr.CreateConst " (default value: %O)")
                 )
                 |> SynExpr.paren
             | Accumulation.List _ -> SynExpr.CreateConst " (can be repeated)"
 
-        let describePositional _ =
+        let describePositional _ _ =
             SynExpr.CreateConst " (positional args) (can be repeated)"
 
-        let toPrintable (describe : 'a -> SynExpr) (arg : ParseFunction<'a>) : SynExpr =
+        /// We may sometimes lie about the type name, if e.g. this is a flag DU which we're pretending is a boolean.
-            let ty = arg.TargetType |> SynType.toHumanReadableString
+        /// So the `renderTypeName` takes the Accumulation which tells us whether we're lying.
+        let toPrintable (describe : 'a -> Choice<FlagDu, unit> option -> SynExpr) (arg : ParseFunction<'a>) : SynExpr =
+            let ty =
+                match arg.BoolCases with
+                | None -> SynType.toHumanReadableString arg.TargetType
+                | Some _ -> "bool"
 
             let helpText =
                 match arg.Help with
@@ -617,11 +747,10 @@ module internal ArgParserGenerator =
                     |> SynExpr.applyTo (SynExpr.paren helpText)
                     |> SynExpr.paren
 
-            let descriptor = describe arg.Accumulation
+            let descriptor = describe arg.Accumulation arg.BoolCases
 
-            let prefix = $"%s{arg.ArgForm}  %s{ty}"
+            SynExpr.applyFunction (SynExpr.createIdent "sprintf") (SynExpr.CreateConst $"%%s  %s{ty}%%s%%s")
-
+            |> SynExpr.applyTo arg.HumanReadableArgForm
-            SynExpr.applyFunction (SynExpr.createIdent "sprintf") (SynExpr.CreateConst (prefix + "%s%s"))
             |> SynExpr.applyTo descriptor
             |> SynExpr.applyTo helpText
             |> SynExpr.paren
@@ -658,7 +787,7 @@ module internal ArgParserGenerator =
                     let multipleErrorMessage =
                         SynExpr.createIdent "sprintf"
                         |> SynExpr.applyTo (SynExpr.CreateConst "Argument '%s' was supplied multiple times: %O and %O")
-                        |> SynExpr.applyTo (SynExpr.CreateConst arg.ArgForm)
+                        |> SynExpr.applyTo arg.HumanReadableArgForm
                         |> SynExpr.applyTo (SynExpr.createIdent "x")
                         |> SynExpr.applyTo (SynExpr.createIdent "value")
 
@@ -734,17 +863,24 @@ module internal ArgParserGenerator =
 
         (SynExpr.applyFunction (SynExpr.createIdent "Error") (SynExpr.createIdent "None"), posArg @ args)
         ||> List.fold (fun finalBranch (argForm, arg) ->
-            arg
+            (finalBranch, argForm)
-            |> SynExpr.ifThenElse
+            ||> List.fold (fun finalBranch argForm ->
-                (SynExpr.applyFunction
+                arg
-                    (SynExpr.createLongIdent [ "System" ; "String" ; "Equals" ])
+                |> SynExpr.ifThenElse
-                    (SynExpr.tuple
+                    (SynExpr.applyFunction
-                        [
+                        (SynExpr.createLongIdent [ "System" ; "String" ; "Equals" ])
-                            SynExpr.createIdent "key"
+                        (SynExpr.tuple
-                            SynExpr.CreateConst argForm
+                            [
-                            SynExpr.createLongIdent [ "System" ; "StringComparison" ; "OrdinalIgnoreCase" ]
+                                SynExpr.createIdent "key"
-                        ]))
+                                SynExpr.applyFunction
-                finalBranch
+                                    (SynExpr.applyFunction
+                                        (SynExpr.createIdent "sprintf")
+                                        (SynExpr.CreateConst "--%s"))
+                                    argForm
+                                SynExpr.createLongIdent [ "System" ; "StringComparison" ; "OrdinalIgnoreCase" ]
+                            ]))
+                    finalBranch
+            )
         )
         |> SynBinding.basic
             [ Ident.create "processKeyValue" ]
@@ -765,46 +901,61 @@ module internal ArgParserGenerator =
         )
 
     /// `let setFlagValue (key : string) : bool = ...`
-    let private setFlagValue (argParseErrors : Ident) (flags : ParseFunction<'a> list) : SynBinding =
+    /// The second member of the `flags` list tuple is the constant "true" with which we will interpret the
+    /// arity-0 `--foo`. So in the case of a boolean-typed field, this is `true`; in the case of a Flag-typed field,
+    /// this is `FlagType.WhicheverCaseHadTrue`.
+    let private setFlagValue (argParseErrors : Ident) (flags : (ParseFunction<'a> * SynExpr) list) : SynBinding =
         (SynExpr.CreateConst false, flags)
-        ||> List.fold (fun finalExpr flag ->
+        ||> List.fold (fun finalExpr (flag, trueCase) ->
             let multipleErrorMessage =
                 SynExpr.createIdent "sprintf"
                 |> SynExpr.applyTo (SynExpr.CreateConst "Flag '%s' was supplied multiple times")
-                |> SynExpr.applyTo (SynExpr.CreateConst flag.ArgForm)
+                |> SynExpr.applyTo flag.HumanReadableArgForm
 
-            [
+            let matchFlag =
-                SynMatchClause.create
+                [
-                    (SynPat.nameWithArgs "Some" [ SynPat.named "x" ])
+                    SynMatchClause.create
-                    // This is an error, but it's one we can gracefully report at the end.
+                        (SynPat.nameWithArgs "Some" [ SynPat.named "x" ])
-                    (SynExpr.sequential
+                        // This is an error, but it's one we can gracefully report at the end.
-                        [
+                        (SynExpr.sequential
-                            multipleErrorMessage
+                            [
-                            |> SynExpr.pipeThroughFunction (SynExpr.dotGet "Add" (SynExpr.createIdent' argParseErrors))
+                                multipleErrorMessage
+                                |> SynExpr.pipeThroughFunction (
+                                    SynExpr.dotGet "Add" (SynExpr.createIdent' argParseErrors)
+                                )
+                                SynExpr.CreateConst true
+                            ])
+
+                    SynMatchClause.create
+                        (SynPat.named "None")
+                        ([
+                            SynExpr.assign
+                                (SynLongIdent.createI flag.TargetVariable)
+                                (SynExpr.pipeThroughFunction (SynExpr.createIdent "Some") trueCase)
                             SynExpr.CreateConst true
-                        ])
+                         ]
+                         |> SynExpr.sequential)
+                ]
+                |> SynExpr.createMatch (SynExpr.createIdent' flag.TargetVariable)
 
-                SynMatchClause.create
+            (finalExpr, flag.ArgForm)
-                    (SynPat.named "None")
+            ||> List.fold (fun finalExpr argForm ->
-                    ([
+                SynExpr.ifThenElse
-                        SynExpr.assign
+                    (SynExpr.applyFunction
-                            (SynLongIdent.createI flag.TargetVariable)
+                        (SynExpr.createLongIdent [ "System" ; "String" ; "Equals" ])
-                            (SynExpr.applyFunction (SynExpr.createIdent "Some") (SynExpr.CreateConst true))
+                        (SynExpr.tuple
-                        SynExpr.CreateConst true
+                            [
-                     ]
+                                SynExpr.createIdent "key"
-                     |> SynExpr.sequential)
+                                SynExpr.applyFunction
-            ]
+                                    (SynExpr.applyFunction
-            |> SynExpr.createMatch (SynExpr.createIdent' flag.TargetVariable)
+                                        (SynExpr.createIdent "sprintf")
-            |> SynExpr.ifThenElse
+                                        (SynExpr.CreateConst "--%s"))
-                (SynExpr.applyFunction
+                                    argForm
-                    (SynExpr.createLongIdent [ "System" ; "String" ; "Equals" ])
+                                SynExpr.createLongIdent [ "System" ; "StringComparison" ; "OrdinalIgnoreCase" ]
-                    (SynExpr.tuple
+                            ]))
-                        [
+                    finalExpr
-                            SynExpr.createIdent "key"
+                    matchFlag
-                            SynExpr.CreateConst flag.ArgForm
+            )
-                            SynExpr.createLongIdent [ "System" ; "StringComparison" ; "OrdinalIgnoreCase" ]
-                        ]))
-                finalExpr
         )
         |> SynBinding.basic [ Ident.create "setFlagValue" ] [ SynPat.annotateType SynType.string (SynPat.named "key") ]
         |> SynBinding.withReturnAnnotation (SynType.named "bool")
@@ -1059,8 +1210,14 @@ module internal ArgParserGenerator =
         |> SynBinding.withRecursion true
 
     /// Takes a single argument, `args : string list`, and returns something of the type indicated by `recordType`.
-    let createRecordParse (parseState : Ident) (ambientRecords : RecordType list) (recordType : RecordType) : SynExpr =
+    let createRecordParse
-        let spec, _ = toParseSpec 0 ambientRecords recordType
+        (parseState : Ident)
+        (flagDus : FlagDu list)
+        (ambientRecords : RecordType list)
+        (recordType : RecordType)
+        : SynExpr
+        =
+        let spec, _ = toParseSpec 0 flagDus ambientRecords recordType
         // For each argument (positional and non-positional), create an accumulator for it.
         let nonPos, pos =
             { new ParseTreeEval<_> with
@@ -1143,8 +1300,15 @@ module internal ArgParserGenerator =
 
                             /// Assumes access to a non-null variable `x` containing the string value.
                             let parser =
-                                match pf.TargetType with
+                                match pf.BoolCases with
-                                | PrimitiveType ident when ident |> List.map _.idText = [ "System" ; "Boolean" ] ->
+                                | Some boolLike ->
+                                    let trueCase, falseCase =
+                                        match boolLike with
+                                        | Choice2Of2 () -> SynExpr.CreateConst true, SynExpr.CreateConst false
+                                        | Choice1Of2 flag ->
+                                            FlagDu.FromBoolean flag (SynExpr.CreateConst true),
+                                            FlagDu.FromBoolean flag (SynExpr.CreateConst false)
+
                                     // We permit environment variables to be populated with 0 and 1 as well.
                                     SynExpr.ifThenElse
                                         (SynExpr.applyFunction
@@ -1167,9 +1331,9 @@ module internal ArgParserGenerator =
                                                             [ "System" ; "StringComparison" ; "OrdinalIgnoreCase" ]
                                                     ]))
                                             (SynExpr.createIdent "x" |> SynExpr.pipeThroughFunction pf.Parser)
-                                            (SynExpr.CreateConst false))
+                                            falseCase)
-                                        (SynExpr.CreateConst true)
+                                        trueCase
-                                | _ -> (SynExpr.createIdent "x" |> SynExpr.pipeThroughFunction pf.Parser)
+                                | None -> (SynExpr.createIdent "x" |> SynExpr.pipeThroughFunction pf.Parser)
 
                             let errorMessage =
                                 SynExpr.createIdent "sprintf"
@@ -1177,7 +1341,7 @@ module internal ArgParserGenerator =
                                     SynExpr.CreateConst
                                         "No value was supplied for %s, nor was environment variable %s set"
                                 )
-                                |> SynExpr.applyTo (SynExpr.CreateConst pf.ArgForm)
+                                |> SynExpr.applyTo pf.HumanReadableArgForm
                                 |> SynExpr.applyTo name
 
                             [
@@ -1226,7 +1390,7 @@ module internal ArgParserGenerator =
                     let errorMessage =
                         SynExpr.createIdent "sprintf"
                         |> SynExpr.applyTo (SynExpr.CreateConst "Required argument '%s' received no value")
-                        |> SynExpr.applyTo (SynExpr.CreateConst pf.ArgForm)
+                        |> SynExpr.applyTo pf.HumanReadableArgForm
 
                     [
                         SynMatchClause.create
@@ -1308,10 +1472,17 @@ module internal ArgParserGenerator =
 
         let flags =
             nonPos
-            |> List.filter (fun pf ->
+            |> List.choose (fun pf ->
                 match pf.TargetType with
-                | PrimitiveType pt -> (pt |> List.map _.idText) = [ "System" ; "Boolean" ]
+                | PrimitiveType pt ->
-                | _ -> false
+                    if (pt |> List.map _.idText) = [ "System" ; "Boolean" ] then
+                        Some (pf, SynExpr.CreateConst true)
+                    else
+                        None
+                | ty ->
+                    match identifyAsFlag flagDus ty with
+                    | Some flag -> (pf, FlagDu.FromBoolean flag (SynExpr.CreateConst true)) |> Some
+                    | _ -> None
             )
 
         let leftoverArgAcc =
@@ -1336,18 +1507,82 @@ module internal ArgParserGenerator =
             ]
         )
 
+    // The type for which we're generating args may refer to any of the supplied records/unions.
     let createModule
         (opens : SynOpenDeclTarget list)
         (ns : LongIdent)
         ((taggedType : SynTypeDefn, spec : ArgParserOutputSpec))
-        (allUnionTypes : SynTypeDefn list)
+        (allUnionTypes : UnionType list)
-        (allRecordTypes : SynTypeDefn list)
+        (allRecordTypes : RecordType list)
         : SynModuleOrNamespace
         =
-        // The type for which we're generating args may refer to any of these records/unions.
+        let flagDus =
-        let allRecordTypes = allRecordTypes |> List.map RecordType.OfRecord
+            allUnionTypes
+            |> List.choose (fun ty ->
+                match ty.Cases with
+                | [ c1 ; c2 ] ->
+                    let c1Attr =
+                        c1.Attributes
+                        |> List.tryPick (fun attr ->
+                            match attr.TypeName with
+                            | SynLongIdent.SynLongIdent (id, _, _) ->
+                                match id |> List.last |> _.idText with
+                                | "ArgumentFlagAttribute"
+                                | "ArgumentFlag" -> Some (SynExpr.stripOptionalParen attr.ArgExpr)
+                                | _ -> None
+                        )
 
-        let taggedType = RecordType.OfRecord taggedType
+                    let c2Attr =
+                        c2.Attributes
+                        |> List.tryPick (fun attr ->
+                            match attr.TypeName with
+                            | SynLongIdent.SynLongIdent (id, _, _) ->
+                                match id |> List.last |> _.idText with
+                                | "ArgumentFlagAttribute"
+                                | "ArgumentFlag" -> Some (SynExpr.stripOptionalParen attr.ArgExpr)
+                                | _ -> None
+                        )
+
+                    match c1Attr, c2Attr with
+                    | Some _, None
+                    | None, Some _ ->
+                        failwith
+                            "[<ArgumentFlag>] must be placed on both cases of a two-case discriminated union, with opposite argument values on each case."
+                    | None, None -> None
+                    | Some c1Attr, Some c2Attr ->
+
+                    // Sanity check where possible
+                    match c1Attr, c2Attr with
+                    | SynExpr.Const (SynConst.Bool b1, _), SynExpr.Const (SynConst.Bool b2, _) ->
+                        if b1 = b2 then
+                            failwith
+                                "[<ArgumentFlag>] must have opposite argument values on each case in a two-case discriminated union."
+                    | _, _ -> ()
+
+                    match c1.Fields, c2.Fields with
+                    | [], [] ->
+                        {
+                            Name = ty.Name
+                            Case1Name = c1.Name
+                            Case1Arg = c1Attr
+                            Case2Name = c2.Name
+                            Case2Arg = c2Attr
+                        }
+                        |> Some
+                    | _, _ ->
+                        failwith "[<ArgumentFlag>] may only be placed on discriminated union members with no data."
+                | _ -> None
+            )
+
+        let taggedType =
+            match taggedType with
+            | SynTypeDefn.SynTypeDefn (sci,
+                                       SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (access, fields, _), _),
+                                       smd,
+                                       _,
+                                       _,
+                                       _) -> RecordType.OfRecord sci smd access fields
+            | _ -> failwith "[<ArgParser>] currently only supports being placed on records."
 
         let modAttrs, modName =
             if spec.ExtensionMethods then
@@ -1368,13 +1603,15 @@ module internal ArgParserGenerator =
             [
                 SynUnionCase.create
                     {
-                        Attrs = []
+                        Attributes = []
                         Fields = []
-                        Ident = Ident.create "AwaitingKey"
+                        Name = Ident.create "AwaitingKey"
+                        XmlDoc = Some (PreXmlDoc.create "Ready to consume a key or positional arg")
+                        Access = None
                     }
                 SynUnionCase.create
                     {
-                        Attrs = []
+                        Attributes = []
                         Fields =
                             [
                                 {
@@ -1383,7 +1620,9 @@ module internal ArgParserGenerator =
                                     Type = SynType.string
                                 }
                             ]
-                        Ident = Ident.create "AwaitingValue"
+                        Name = Ident.create "AwaitingValue"
+                        XmlDoc = Some (PreXmlDoc.create "Waiting to receive a value for the key we've already consumed")
+                        Access = None
                     }
             ]
             |> SynTypeDefnRepr.union
@@ -1400,7 +1639,7 @@ module internal ArgParserGenerator =
                 |> SynPat.annotateType (SynType.appPostfix "list" SynType.string)
 
             let parsePrime =
-                createRecordParse parseStateIdent allRecordTypes taggedType
+                createRecordParse parseStateIdent flagDus allRecordTypes taggedType
                 |> SynBinding.basic
                     [ Ident.create "parse'" ]
                     [
@@ -1498,12 +1737,12 @@ module internal ArgParserGenerator =
                         (([], [], []), types)
                         ||> List.fold (fun
                                            (unions, records, others)
-                                           (SynTypeDefn.SynTypeDefn (_, repr, _, _, _, _) as ty) ->
+                                           (SynTypeDefn.SynTypeDefn (sci, repr, smd, _, _, _) as ty) ->
                             match repr with
-                            | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union _, _) ->
+                            | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (access, cases, _), _) ->
-                                ty :: unions, records, others
+                                UnionType.OfUnion sci smd access cases :: unions, records, others
-                            | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record _, _) ->
+                            | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (access, fields, _), _) ->
-                                unions, ty :: records, others
+                                unions, RecordType.OfRecord sci smd access fields :: records, others
                             | _ -> unions, records, ty :: others
                         )
 

WoofWare.Myriad.Plugins/AstHelper.fs

@@ -67,41 +67,109 @@ type internal RecordType =
         Members : SynMemberDefns option
         XmlDoc : PreXmlDoc option
         Generics : SynTyparDecls option
-        Accessibility : SynAccess option
+        TypeAccessibility : SynAccess option
+        ImplAccessibility : SynAccess option
         Attributes : SynAttribute list
     }
 
     /// Parse from the AST.
-    static member OfRecord (record : SynTypeDefn) : RecordType =
+    static member OfRecord
-        let sci, sdr, smd, smdo =
+        (sci : SynComponentInfo)
-            match record with
+        (smd : SynMemberDefns)
-            | SynTypeDefn.SynTypeDefn (sci, sdr, smd, smdo, _, _) -> sci, sdr, smd, smdo
+        (access : SynAccess option)
-
+        (recordFields : SynField list)
-        let synAccessOption, recordFields =
+        : RecordType
-            match sdr with
+        =
-            | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (sa, fields, _), _) -> sa, fields
-            | _ -> failwith $"expected a record; got: %+A{record}"
-
         match sci with
-        | SynComponentInfo.SynComponentInfo (attrs, typars, _, longId, doc, _, access, _) ->
+        | SynComponentInfo.SynComponentInfo (attrs, typars, _, longId, doc, _, implAccess, _) ->
-            if access <> synAccessOption then
-                failwith
-                    $"TODO what's happened, two different accessibility modifiers: %O{access} and %O{synAccessOption}"
-
-            match smdo with
-            | Some v -> failwith $"TODO what's happened, got a synMemberDefn of %O{v}"
-            | None -> ()
-
             {
                 Name = List.last longId
                 Fields = recordFields
                 Members = if smd.IsEmpty then None else Some smd
                 XmlDoc = if doc.IsEmpty then None else Some doc
                 Generics = typars
-                Accessibility = synAccessOption
+                ImplAccessibility = implAccess
+                TypeAccessibility = access
                 Attributes = attrs |> List.collect (fun l -> l.Attributes)
             }
 
+/// Methods for manipulating UnionCase.
+[<RequireQualifiedAccess>]
+module UnionCase =
+    /// Construct our structured `UnionCase` from an FCS `SynUnionCase`: extract everything
+    /// we care about from the AST representation.
+    let ofSynUnionCase (case : SynUnionCase) : UnionCase<Ident option> =
+        match case with
+        | SynUnionCase.SynUnionCase (attributes, ident, caseType, xmlDoc, access, _, _) ->
+
+        let ident =
+            match ident with
+            | SynIdent.SynIdent (ident, _) -> ident
+
+        let fields =
+            match caseType with
+            | SynUnionCaseKind.Fields cases -> cases
+            | SynUnionCaseKind.FullType _ -> failwith "unexpected FullType union"
+
+        {
+            Name = ident
+            XmlDoc = if xmlDoc.IsEmpty then None else Some xmlDoc
+            Access = access
+            Attributes = attributes |> List.collect (fun t -> t.Attributes)
+            Fields = fields |> List.map SynField.extract
+        }
+
+    /// Functorial `map`.
+    let mapIdentFields<'a, 'b> (f : 'a -> 'b) (unionCase : UnionCase<'a>) : UnionCase<'b> =
+        {
+            Attributes = unionCase.Attributes
+            Name = unionCase.Name
+            Access = unionCase.Access
+            XmlDoc = unionCase.XmlDoc
+            Fields = unionCase.Fields |> List.map (SynField.mapIdent f)
+        }
+
+/// Everything you need to know about a discriminated union definition.
+type internal UnionType =
+    {
+        /// The name of the DU: for example, `type Foo = | Blah` has this being `Foo`.
+        Name : Ident
+        /// Any additional members which are not union cases.
+        Members : SynMemberDefns option
+        /// Any docstring associated with the DU itself (not its cases).
+        XmlDoc : PreXmlDoc option
+        /// Generic type parameters this DU takes: `type Foo<'a> = | ...`.
+        Generics : SynTyparDecls option
+        /// Attributes of the DU (not its cases): `[<Attr>] type Foo = | ...`
+        Attributes : SynAttribute list
+        /// Accessibility modifier of the DU: `type private Foo = ...`
+        TypeAccessibility : SynAccess option
+        /// Accessibility modifier of the DU's implementation: `type Foo = private | ...`
+        ImplAccessibility : SynAccess option
+        /// The actual DU cases themselves.
+        Cases : UnionCase<Ident option> list
+    }
+
+    static member OfUnion
+        (sci : SynComponentInfo)
+        (smd : SynMemberDefns)
+        (access : SynAccess option)
+        (cases : SynUnionCase list)
+        : UnionType
+        =
+        match sci with
+        | SynComponentInfo.SynComponentInfo (attrs, typars, _, longId, doc, _, implAccess, _) ->
+            {
+                Name = List.last longId
+                Members = if smd.IsEmpty then None else Some smd
+                XmlDoc = if doc.IsEmpty then None else Some doc
+                Generics = typars
+                Attributes = attrs |> List.collect (fun l -> l.Attributes)
+                TypeAccessibility = access
+                ImplAccessibility = implAccess
+                Cases = cases |> List.map UnionCase.ofSynUnionCase
+            }
+
 /// Anything that is part of an ADT.
 /// A record is a product of stuff; this type represents one of those stuffs.
 type internal AdtNode =
@@ -144,13 +212,13 @@ module internal AstHelper =
     let defineRecordType (record : RecordType) : SynTypeDefn =
         let name =
             SynComponentInfo.create record.Name
-            |> SynComponentInfo.setAccessibility record.Accessibility
+            |> SynComponentInfo.setAccessibility record.TypeAccessibility
             |> match record.XmlDoc with
                | None -> id
                | Some doc -> SynComponentInfo.withDocString doc
             |> SynComponentInfo.setGenerics record.Generics
 
-        SynTypeDefnRepr.record (Seq.toList record.Fields)
+        SynTypeDefnRepr.recordWithAccess record.ImplAccessibility (Seq.toList record.Fields)
         |> SynTypeDefn.create name
         |> SynTypeDefn.withMemberDefns (defaultArg record.Members SynMemberDefns.Empty)
 

WoofWare.Myriad.Plugins/InterfaceMockGenerator.fs

@@ -212,7 +212,8 @@ module internal InterfaceMockGenerator =
                 Members = Some ([ constructor ; interfaceMembers ] @ extraInterfaces)
                 XmlDoc = Some xmlDoc
                 Generics = interfaceType.Generics
-                Accessibility = Some access
+                TypeAccessibility = Some access
+                ImplAccessibility = None
                 Attributes = []
             }
 

WoofWare.Myriad.Plugins/JsonParseGenerator.fs

@@ -416,11 +416,11 @@ module internal JsonParseGenerator =
     let createUnionMaker (spec : JsonParseOutputSpec) (typeName : LongIdent) (fields : UnionCase<Ident> list) =
         fields
         |> List.map (fun case ->
-            let propertyName = JsonSerializeGenerator.getPropertyName case.Ident case.Attrs
+            let propertyName = JsonSerializeGenerator.getPropertyName case.Name case.Attributes
 
             let body =
                 if case.Fields.IsEmpty then
-                    SynExpr.createLongIdent' (typeName @ [ case.Ident ])
+                    SynExpr.createLongIdent' (typeName @ [ case.Name ])
                 else
                     case.Fields
                     |> List.map (fun field ->
@@ -429,7 +429,7 @@ module internal JsonParseGenerator =
                         createParseRhs options propertyName field.Type
                     )
                     |> SynExpr.tuple
-                    |> SynExpr.applyFunction (SynExpr.createLongIdent' (typeName @ [ case.Ident ]))
+                    |> SynExpr.applyFunction (SynExpr.createLongIdent' (typeName @ [ case.Name ]))
                     |> SynExpr.createLet
                         [
                             SynExpr.index (SynExpr.CreateConst "data") (SynExpr.createIdent "node")
@@ -600,7 +600,7 @@ module internal JsonParseGenerator =
                     | Some i -> i
 
                 cases
-                |> List.map SynUnionCase.extract
+                |> List.map UnionCase.ofSynUnionCase
                 |> List.map (UnionCase.mapIdentFields optionGet)
                 |> createUnionMaker spec ident
             | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Enum (cases, _range), _) ->

WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs

@@ -263,11 +263,11 @@ module internal JsonSerializeGenerator =
 
     let unionModule (spec : JsonSerializeOutputSpec) (typeName : LongIdent) (cases : SynUnionCase list) =
         let inputArg = Ident.create "input"
-        let fields = cases |> List.map SynUnionCase.extract
+        let fields = cases |> List.map UnionCase.ofSynUnionCase
 
         fields
         |> List.map (fun unionCase ->
-            let propertyName = getPropertyName unionCase.Ident unionCase.Attrs
+            let propertyName = getPropertyName unionCase.Name unionCase.Attributes
 
             let caseNames = unionCase.Fields |> List.mapi (fun i _ -> $"arg%i{i}")
 
@@ -275,7 +275,7 @@ module internal JsonSerializeGenerator =
 
             let pattern =
                 SynPat.LongIdent (
-                    SynLongIdent.create (typeName @ [ unionCase.Ident ]),
+                    SynLongIdent.create (typeName @ [ unionCase.Name ]),
                     None,
                     None,
                     argPats,

WoofWare.Myriad.Plugins/RemoveOptionsGenerator.fs

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

WoofWare.Myriad.Plugins/SurfaceBaseline.txt

@@ -11,4 +11,27 @@ WoofWare.Myriad.Plugins.JsonParseGenerator..ctor [constructor]: unit
 WoofWare.Myriad.Plugins.JsonSerializeGenerator inherit obj, implements Myriad.Core.IMyriadGenerator
 WoofWare.Myriad.Plugins.JsonSerializeGenerator..ctor [constructor]: unit
 WoofWare.Myriad.Plugins.RemoveOptionsGenerator inherit obj, implements Myriad.Core.IMyriadGenerator
-WoofWare.Myriad.Plugins.RemoveOptionsGenerator..ctor [constructor]: unit
+WoofWare.Myriad.Plugins.RemoveOptionsGenerator..ctor [constructor]: unit
+WoofWare.Myriad.Plugins.SynFieldData`1 inherit obj
+WoofWare.Myriad.Plugins.SynFieldData`1..ctor [constructor]: (Fantomas.FCS.Syntax.SynAttribute list, 'Ident, Fantomas.FCS.Syntax.SynType)
+WoofWare.Myriad.Plugins.SynFieldData`1.Attrs [property]: [read-only] Fantomas.FCS.Syntax.SynAttribute list
+WoofWare.Myriad.Plugins.SynFieldData`1.get_Attrs [method]: unit -> Fantomas.FCS.Syntax.SynAttribute list
+WoofWare.Myriad.Plugins.SynFieldData`1.get_Ident [method]: unit -> 'Ident
+WoofWare.Myriad.Plugins.SynFieldData`1.get_Type [method]: unit -> Fantomas.FCS.Syntax.SynType
+WoofWare.Myriad.Plugins.SynFieldData`1.Ident [property]: [read-only] 'Ident
+WoofWare.Myriad.Plugins.SynFieldData`1.Type [property]: [read-only] Fantomas.FCS.Syntax.SynType
+WoofWare.Myriad.Plugins.UnionCase inherit obj
+WoofWare.Myriad.Plugins.UnionCase.mapIdentFields [static method]: ('a -> 'b) -> 'a WoofWare.Myriad.Plugins.UnionCase -> 'b WoofWare.Myriad.Plugins.UnionCase
+WoofWare.Myriad.Plugins.UnionCase.ofSynUnionCase [static method]: Fantomas.FCS.Syntax.SynUnionCase -> Fantomas.FCS.Syntax.Ident option WoofWare.Myriad.Plugins.UnionCase
+WoofWare.Myriad.Plugins.UnionCase`1 inherit obj
+WoofWare.Myriad.Plugins.UnionCase`1..ctor [constructor]: (Fantomas.FCS.Syntax.Ident, Fantomas.FCS.Xml.PreXmlDoc option, Fantomas.FCS.Syntax.SynAccess option, Fantomas.FCS.Syntax.SynAttribute list, 'ident WoofWare.Myriad.Plugins.SynFieldData list)
+WoofWare.Myriad.Plugins.UnionCase`1.Access [property]: [read-only] Fantomas.FCS.Syntax.SynAccess option
+WoofWare.Myriad.Plugins.UnionCase`1.Attributes [property]: [read-only] Fantomas.FCS.Syntax.SynAttribute list
+WoofWare.Myriad.Plugins.UnionCase`1.Fields [property]: [read-only] 'ident WoofWare.Myriad.Plugins.SynFieldData list
+WoofWare.Myriad.Plugins.UnionCase`1.get_Access [method]: unit -> Fantomas.FCS.Syntax.SynAccess option
+WoofWare.Myriad.Plugins.UnionCase`1.get_Attributes [method]: unit -> Fantomas.FCS.Syntax.SynAttribute list
+WoofWare.Myriad.Plugins.UnionCase`1.get_Fields [method]: unit -> 'ident WoofWare.Myriad.Plugins.SynFieldData list
+WoofWare.Myriad.Plugins.UnionCase`1.get_Name [method]: unit -> Fantomas.FCS.Syntax.Ident
+WoofWare.Myriad.Plugins.UnionCase`1.get_XmlDoc [method]: unit -> Fantomas.FCS.Xml.PreXmlDoc option
+WoofWare.Myriad.Plugins.UnionCase`1.Name [property]: [read-only] Fantomas.FCS.Syntax.Ident
+WoofWare.Myriad.Plugins.UnionCase`1.XmlDoc [property]: [read-only] Fantomas.FCS.Xml.PreXmlDoc option

WoofWare.Myriad.Plugins/SynExpr/SynField.fs

@@ -5,10 +5,17 @@ open Fantomas.FCS.Syntax
 open Fantomas.FCS.SyntaxTrivia
 open Fantomas.FCS.Xml
 
-type internal SynFieldData<'Ident> =
+/// The data needed to reconstitute a single piece of data within a union field, or a single record field.
+/// This is generic on whether the field is identified. For example, in `type Foo = Blah of int`, the `int`
+/// field is not identified; whereas in `type Foo = Blah of baz : int`, it is identified.
+type SynFieldData<'Ident> =
     {
+        /// Attributes on this field. I think you can only get these if this is a *record* field.
         Attrs : SynAttribute list
+        /// The identifier of this field (see docstring for SynFieldData).
         Ident : 'Ident
+        /// The type of the data contained in this field. For example, `type Foo = { Blah : int }`
+        /// has this being `int`.
         Type : SynType
     }
 

WoofWare.Myriad.Plugins/SynExpr/SynType.fs

@@ -363,6 +363,7 @@ module internal SynType =
         | DateTimeOffset -> "DateTimeOffset"
         | DateOnly -> "DateOnly"
         | TimeSpan -> "TimeSpan"
+        | SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) -> ident |> List.map _.idText |> String.concat "."
         | ty -> failwithf "could not compute human-readable string for type: %O" ty
 
     /// Guess whether the types are equal. We err on the side of saying "no, they're different".
@@ -454,4 +455,11 @@ module internal SynType =
             match ty2 with
             | DateOnly -> true
             | _ -> false
-        | _ -> false
+        | _ ->
+
+        match ty1, ty2 with
+        | SynType.LongIdent (SynLongIdent (ident1, _, _)), SynType.LongIdent (SynLongIdent (ident2, _, _)) ->
+            let ident1 = ident1 |> List.map _.idText
+            let ident2 = ident2 |> List.map _.idText
+            ident1 = ident2
+        | _, _ -> false

WoofWare.Myriad.Plugins/SynExpr/SynTypeDefnRepr.fs

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

WoofWare.Myriad.Plugins/SynExpr/SynUnionCase.fs

@@ -5,44 +5,24 @@ open Fantomas.FCS.Text.Range
 open Fantomas.FCS.Xml
 open Fantomas.FCS.SyntaxTrivia
 
-type internal UnionCase<'Ident> =
+/// Represents everything you need to know about a union case.
+/// This is generic on whether each field of this case must be named.
+type UnionCase<'ident> =
     {
-        Fields : SynFieldData<'Ident> list
+        /// The name of the case: e.g. `| Foo of blah` has this being `Foo`.
-        Attrs : SynAttribute list
+        Name : Ident
-        Ident : Ident
+        /// Any docstring associated with this case.
+        XmlDoc : PreXmlDoc option
+        /// Any accessibility modifier: e.g. `type Foo = private | Blah`.
+        Access : SynAccess option
+        /// Attributes on the case: for example, `| [<Attr>] Foo of blah`.
+        Attributes : SynAttribute list
+        /// The data contained within the case: for example, `[blah]` in `| Foo of blah`.
+        Fields : SynFieldData<'ident> list
     }
 
-[<RequireQualifiedAccess>]
-module internal UnionCase =
-    let mapIdentFields<'a, 'b> (f : 'a -> 'b) (unionCase : UnionCase<'a>) : UnionCase<'b> =
-        {
-            Fields = unionCase.Fields |> List.map (SynField.mapIdent f)
-            Attrs = unionCase.Attrs
-            Ident = unionCase.Ident
-        }
-
 [<RequireQualifiedAccess>]
 module internal SynUnionCase =
-    let extract (SynUnionCase (attrs, id, caseType, _, _, _, _)) : UnionCase<Ident option> =
-        match caseType with
-        | SynUnionCaseKind.FullType _ -> failwith "WoofWare.Myriad does not support FullType union cases."
-        | SynUnionCaseKind.Fields fields ->
-
-        let fields = fields |> List.map SynField.extract
-
-        let id =
-            match id with
-            | SynIdent.SynIdent (ident, _) -> ident
-
-        // As far as I can tell, there's no way to get any attributes here? :shrug:
-        let attrs = attrs |> List.collect (fun l -> l.Attributes)
-
-        {
-            Fields = fields
-            Attrs = attrs
-            Ident = id
-        }
-
     let create (case : UnionCase<Ident>) : SynUnionCase =
         let fields =
             case.Fields
@@ -63,11 +43,11 @@ module internal SynUnionCase =
             )
 
         SynUnionCase.SynUnionCase (
-            SynAttributes.ofAttrs case.Attrs,
+            SynAttributes.ofAttrs case.Attributes,
-            SynIdent.SynIdent (case.Ident, None),
+            SynIdent.SynIdent (case.Name, None),
             SynUnionCaseKind.Fields fields,
-            PreXmlDoc.Empty,
+            case.XmlDoc |> Option.defaultValue PreXmlDoc.Empty,
-            None,
+            case.Access,
             range0,
             {
                 BarRange = Some range0

WoofWare.Myriad.Plugins/version.json

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