Basic arg parser (#216)

2025-10-11 06:58:42 +00:00 · 2024-08-26 11:54:35 +01:00
parent 569b3cc553
commit 417ca45c37
22 changed files with 3493 additions and 24 deletions
--- a/WoofWare.Myriad.Plugins/ArgParserGenerator.fs
+++ b/WoofWare.Myriad.Plugins/ArgParserGenerator.fs
--- a/WoofWare.Myriad.Plugins/CataGenerator.fs
+++ b/WoofWare.Myriad.Plugins/CataGenerator.fs
@@ -858,7 +858,7 @@ module internal CataGenerator =

        SynExpr.createMatch (SynExpr.createIdent "x") matchCases
        |> SynMatchClause.create (
-            SynPat.identWithArgs analysis.AssociatedProcessInstruction (SynArgPats.create [ Ident.create "x" ])
+            SynPat.identWithArgs analysis.AssociatedProcessInstruction (SynArgPats.createNamed [ "x" ])
        )

    /// Create the state-machine matches which deal with receiving the instruction
@@ -896,8 +896,8 @@ module internal CataGenerator =
                    |> Seq.mapi (fun i x -> (i, x))
                    |> Seq.choose (fun (i, case) ->
                        match case.Description with
-                        | FieldDescription.NonRecursive _ -> case.ArgName |> Some
-                        | FieldDescription.ListSelf _ -> case.ArgName |> Some
+                        | FieldDescription.NonRecursive _ -> case.ArgName |> SynPat.namedI |> Some
+                        | FieldDescription.ListSelf _ -> case.ArgName |> SynPat.namedI |> Some
                        | FieldDescription.Self _ -> None
                    )
                    |> Seq.toList
--- a/WoofWare.Myriad.Plugins/HttpClientGenerator.fs
+++ b/WoofWare.Myriad.Plugins/HttpClientGenerator.fs
@@ -833,7 +833,7 @@ module internal HttpClientGenerator =
                    |> SynTypeDefn.create componentInfo
                    |> SynTypeDefn.withMemberDefns [ binding ]

-                SynModuleDecl.Types ([ containingType ], range0)
+                SynModuleDecl.createTypes [ containingType ]

            else
                SynBinding.basic [ Ident.create "make" ] (headerArgs @ [ clientCreationArg ]) interfaceImpl
--- a/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs
+++ b/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs
@@ -72,9 +72,7 @@ module internal JsonSerializeGenerator =
                    target
                    |> SynExpr.paren
                    |> SynExpr.upcast' (SynType.createLongIdent' [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ])
-                |> SynMatchClause.create (
-                    SynPat.identWithArgs [ Ident.create "Some" ] (SynArgPats.create [ Ident.create "field" ])
-                )
+                |> SynMatchClause.create (SynPat.nameWithArgs "Some" [ SynPat.named "field" ])

            [ noneClause ; someClause ]
            |> SynExpr.createMatch (SynExpr.createIdent "field")
@@ -125,11 +123,7 @@ module internal JsonSerializeGenerator =
                    DebugPointAtInOrTo.Yes range0,
                    SeqExprOnly.SeqExprOnly false,
                    true,
-                    SynPat.paren (
-                        SynPat.identWithArgs
-                            [ Ident.create "KeyValue" ]
-                            (SynArgPats.create [ Ident.create "key" ; Ident.create "value" ])
-                    ),
+                    SynPat.paren (SynPat.nameWithArgs "KeyValue" [ SynPat.named "key" ; SynPat.named "value" ]),
                    SynExpr.createIdent "field",
                    SynExpr.applyFunction
                        (SynExpr.createLongIdent [ "ret" ; "Add" ])
@@ -275,9 +269,9 @@ module internal JsonSerializeGenerator =
        |> List.map (fun unionCase ->
            let propertyName = getPropertyName unionCase.Ident unionCase.Attrs

-            let caseNames = unionCase.Fields |> List.mapi (fun i _ -> Ident.create $"arg%i{i}")
+            let caseNames = unionCase.Fields |> List.mapi (fun i _ -> $"arg%i{i}")

-            let argPats = SynArgPats.create caseNames
+            let argPats = SynArgPats.createNamed caseNames

            let pattern =
                SynPat.LongIdent (
@@ -311,7 +305,7 @@ module internal JsonSerializeGenerator =
                    let propertyName = getPropertyName (Option.get fieldData.Ident) fieldData.Attrs

                    let node =
-                        SynExpr.applyFunction (fst (serializeNode fieldData.Type)) (SynExpr.createIdent' caseName)
+                        SynExpr.applyFunction (fst (serializeNode fieldData.Type)) (SynExpr.createIdent caseName)

                    [ propertyName ; node ]
                    |> SynExpr.tuple
--- a/WoofWare.Myriad.Plugins/SurfaceBaseline.txt
+++ b/WoofWare.Myriad.Plugins/SurfaceBaseline.txt
@@ -1,3 +1,5 @@
+WoofWare.Myriad.Plugins.ArgParserGenerator inherit obj, implements Myriad.Core.IMyriadGenerator
+WoofWare.Myriad.Plugins.ArgParserGenerator..ctor [constructor]: unit
 WoofWare.Myriad.Plugins.CreateCatamorphismGenerator inherit obj, implements Myriad.Core.IMyriadGenerator
 WoofWare.Myriad.Plugins.CreateCatamorphismGenerator..ctor [constructor]: unit
 WoofWare.Myriad.Plugins.HttpClientGenerator inherit obj, implements Myriad.Core.IMyriadGenerator
--- a/WoofWare.Myriad.Plugins/SynExpr/PreXmlDoc.fs
+++ b/WoofWare.Myriad.Plugins/SynExpr/PreXmlDoc.fs
@@ -7,3 +7,6 @@ open Fantomas.FCS.Text.Range
 module internal PreXmlDoc =
    let create (s : string) : PreXmlDoc =
        PreXmlDoc.Create ([| " " + s |], range0)
+
+    let create' (s : string seq) : PreXmlDoc =
+        PreXmlDoc.Create (Array.ofSeq s, range0)
--- a/WoofWare.Myriad.Plugins/SynExpr/SynArgPats.fs
+++ b/WoofWare.Myriad.Plugins/SynExpr/SynArgPats.fs
@@ -1,16 +1,30 @@
 namespace WoofWare.Myriad.Plugins

 open Fantomas.FCS.Syntax
+open Fantomas.FCS.Text.Range

 [<RequireQualifiedAccess>]
 module internal SynArgPats =
-    let create (caseNames : Ident list) : SynArgPats =
+    let createNamed (caseNames : string list) : SynArgPats =
        match caseNames.Length with
        | 0 -> SynArgPats.Pats []
-        | 1 -> [ SynPat.named caseNames.[0].idText ] |> SynArgPats.Pats
-        | _ ->
-            caseNames
-            |> List.map (fun i -> SynPat.named i.idText)
-            |> SynPat.tuple
+        | 1 ->
+            SynPat.Named (SynIdent.SynIdent (Ident.create caseNames.[0], None), false, None, range0)
+            |> List.singleton
+            |> SynArgPats.Pats
+        | len ->
+            caseNames
+            |> List.map (fun name -> SynPat.Named (SynIdent.SynIdent (Ident.create name, None), false, None, range0))
+            |> fun t -> SynPat.Tuple (false, t, List.replicate (len - 1) range0, range0)
+            |> fun t -> SynPat.Paren (t, range0)
+            |> List.singleton
+            |> SynArgPats.Pats
+
+    let create (pats : SynPat list) : SynArgPats =
+        match pats.Length with
+        | 0 -> SynArgPats.Pats []
+        | 1 -> [ pats.[0] ] |> SynArgPats.Pats
+        | len ->
+            SynPat.Paren (SynPat.Tuple (false, pats, List.replicate (len - 1) range0, range0), range0)
            |> List.singleton
            |> SynArgPats.Pats
--- a/WoofWare.Myriad.Plugins/SynExpr/SynExpr.fs
+++ b/WoofWare.Myriad.Plugins/SynExpr/SynExpr.fs
@@ -260,6 +260,12 @@ module internal SynExpr =
        exprs
        |> List.reduce (fun a b -> SynExpr.Sequential (DebugPointAtSequential.SuppressNeither, false, a, b, range0))

+    let listLiteral (elts : SynExpr list) : SynExpr =
+        SynExpr.ArrayOrListComputed (false, sequential elts, range0)
+
+    let arrayLiteral (elts : SynExpr list) : SynExpr =
+        SynExpr.ArrayOrListComputed (true, sequential elts, range0)
+
    /// {compExpr} { {lets} ; return {ret} }
    let createCompExpr (compExpr : string) (retBody : SynExpr) (lets : CompExprBinding list) : SynExpr =
        let retStatement = SynExpr.YieldOrReturn ((false, true), retBody, range0)
--- a/WoofWare.Myriad.Plugins/SynExpr/SynPat.fs
+++ b/WoofWare.Myriad.Plugins/SynExpr/SynPat.fs
@@ -7,6 +7,8 @@ open Fantomas.FCS.Text.Range
 module internal SynPat =
    let inline paren (pat : SynPat) : SynPat = SynPat.Paren (pat, range0)

+    let anon : SynPat = SynPat.Wild range0
+
    let inline annotateTypeNoParen (ty : SynType) (pat : SynPat) = SynPat.Typed (pat, ty, range0)

    let inline annotateType (ty : SynType) (pat : SynPat) = paren (annotateTypeNoParen ty pat)
@@ -20,6 +22,9 @@ module internal SynPat =
    let inline identWithArgs (i : LongIdent) (args : SynArgPats) : SynPat =
        SynPat.LongIdent (SynLongIdent.create i, None, None, args, None, range0)

+    let inline nameWithArgs (i : string) (args : SynPat list) : SynPat =
+        identWithArgs [ Ident.create i ] (SynArgPats.create args)
+
    let inline tupleNoParen (elements : SynPat list) : SynPat =
        match elements with
        | [] -> failwith "Can't tuple no elements in a pattern"
--- a/WoofWare.Myriad.Plugins/SynExpr/SynType.fs
+++ b/WoofWare.Myriad.Plugins/SynExpr/SynType.fs
@@ -251,6 +251,15 @@ module internal SynTypePatterns =
            | _ -> None
        | _ -> None

+    let (|TimeSpan|_|) (fieldType : SynType) =
+        match fieldType with
+        | SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->
+            match ident |> List.map (fun i -> i.idText) with
+            | [ "System" ; "TimeSpan" ]
+            | [ "TimeSpan" ] -> Some ()
+            | _ -> None
+        | _ -> None
+
 [<RequireQualifiedAccess>]
 module internal SynType =
    let rec stripOptionalParen (ty : SynType) : SynType =
@@ -306,6 +315,56 @@ module internal SynType =
    let toFun (inputs : SynType list) (ret : SynType) : SynType =
        (ret, List.rev inputs) ||> List.fold (fun ty input -> funFromDomain input ty)

+    let primitiveToHumanReadableString (name : LongIdent) : string =
+        match name |> List.map _.idText with
+        | [ "System" ; "Single" ] -> "single"
+        | [ "System" ; "Double" ] -> "double"
+        | [ "System" ; "Byte" ] -> "byte"
+        | [ "System" ; "SByte" ] -> "signed byte"
+        | [ "System" ; "Int16" ] -> "int16"
+        | [ "System" ; "Int32" ] -> "int32"
+        | [ "System" ; "Int64" ] -> "int64"
+        | [ "System" ; "UInt16" ] -> "uint16"
+        | [ "System" ; "UInt32" ] -> "uint32"
+        | [ "System" ; "UInt64" ] -> "uint64"
+        | [ "System" ; "Char" ] -> "char"
+        | [ "System" ; "Decimal" ] -> "decimal"
+        | [ "System" ; "String" ] -> "string"
+        | [ "System" ; "Boolean" ] -> "bool"
+        | ty ->
+            ty
+            |> String.concat "."
+            |> failwithf "could not create human-readable string for primitive type %s"
+
+    let rec toHumanReadableString (ty : SynType) : string =
+        match ty with
+        | PrimitiveType t1 -> primitiveToHumanReadableString t1
+        | OptionType t1 -> toHumanReadableString t1 + " option"
+        | NullableType t1 -> toHumanReadableString t1 + " Nullable"
+        | ChoiceType ts ->
+            ts
+            |> List.map toHumanReadableString
+            |> String.concat ", "
+            |> sprintf "Choice<%s>"
+        | MapType (k, v)
+        | DictionaryType (k, v)
+        | IDictionaryType (k, v)
+        | IReadOnlyDictionaryType (k, v) -> sprintf "map<%s, %s>" (toHumanReadableString k) (toHumanReadableString v)
+        | ListType t1 -> toHumanReadableString t1 + " list"
+        | ArrayType t1 -> toHumanReadableString t1 + " array"
+        | Task t1 -> toHumanReadableString t1 + " Task"
+        | UnitType -> "unit"
+        | FileInfo -> "FileInfo"
+        | DirectoryInfo -> "DirectoryInfo"
+        | Uri -> "URI"
+        | Stream -> "Stream"
+        | Guid -> "GUID"
+        | BigInt -> "bigint"
+        | DateTimeOffset -> "DateTimeOffset"
+        | DateOnly -> "DateOnly"
+        | TimeSpan -> "TimeSpan"
+        | 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".
    let rec provablyEqual (ty1 : SynType) (ty2 : SynType) : bool =
        if Object.ReferenceEquals (ty1, ty2) then
--- a/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj
+++ b/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj
@@ -31,13 +31,13 @@
    <Compile Include="SynExpr\Ident.fs" />
    <Compile Include="SynExpr\SynLongIdent.fs" />
    <Compile Include="SynExpr\SynExprLetOrUseTrivia.fs" />
+    <Compile Include="SynExpr\SynArgPats.fs" />
    <Compile Include="SynExpr\SynPat.fs" />
    <Compile Include="SynExpr\SynBinding.fs" />
    <Compile Include="SynExpr\SynType.fs" />
    <Compile Include="SynExpr\SynMatchClause.fs" />
    <Compile Include="SynExpr\CompExpr.fs" />
    <Compile Include="SynExpr\SynExpr.fs" />
-    <Compile Include="SynExpr\SynArgPats.fs" />
    <Compile Include="SynExpr\SynField.fs" />
    <Compile Include="SynExpr\SynUnionCase.fs" />
    <Compile Include="SynExpr\SynTypeDefnRepr.fs" />
@@ -55,6 +55,7 @@
    <Compile Include="JsonParseGenerator.fs"/>
    <Compile Include="HttpClientGenerator.fs"/>
    <Compile Include="CataGenerator.fs" />
+    <Compile Include="ArgParserGenerator.fs" />
    <EmbeddedResource Include="version.json"/>
    <EmbeddedResource Include="SurfaceBaseline.txt"/>
    <None Include="..\README.md">
--- a/WoofWare.Myriad.Plugins/version.json
+++ b/WoofWare.Myriad.Plugins/version.json
@@ -1,5 +1,5 @@
 {
-  "version": "2.1",
+  "version": "2.2",
  "publicReleaseRefSpec": [
    "^refs/heads/main$"
  ],