Pull out general changes from ArgParser PR (#217)

2025-10-13 07:58:40 +00:00 · 2024-08-25 20:23:23 +01:00
parent 20226b9da9
commit 569b3cc553
19 changed files with 412 additions and 90 deletions
--- a/WoofWare.Myriad.Plugins/SynExpr/SynAttributes.fs
+++ b/WoofWare.Myriad.Plugins/SynExpr/SynAttributes.fs
@@ -0,0 +1,15 @@
+namespace WoofWare.Myriad.Plugins
+
+open Fantomas.FCS.Syntax
+open Fantomas.FCS.Text.Range
+
+[<RequireQualifiedAccess>]
+module internal SynAttributes =
+    let ofAttrs (attrs : SynAttribute list) : SynAttributes =
+        attrs
+        |> List.map (fun a ->
+            {
+                Attributes = [ a ]
+                Range = range0
+            }
+        )
--- a/WoofWare.Myriad.Plugins/SynExpr/SynBinding.fs
+++ b/WoofWare.Myriad.Plugins/SynExpr/SynBinding.fs
@@ -62,6 +62,35 @@ module internal SynBinding =
            triviaZero false
        )

+    let withMutability (mut : bool) (binding : SynBinding) : SynBinding =
+        match binding with
+        | SynBinding (pat, kind, inl, _, attrs, xml, valData, headPat, returnInfo, expr, range, debugPoint, trivia) ->
+            SynBinding (pat, kind, inl, mut, attrs, xml, valData, headPat, returnInfo, expr, range, debugPoint, trivia)
+
+    let withRecursion (isRec : bool) (binding : SynBinding) : SynBinding =
+        match binding with
+        | SynBinding (pat, kind, inl, mut, attrs, xml, valData, headPat, returnInfo, expr, range, debugPoint, trivia) ->
+            let trivia =
+                { trivia with
+                    LeadingKeyword =
+                        match trivia.LeadingKeyword with
+                        | SynLeadingKeyword.Let _ ->
+                            if isRec then
+                                SynLeadingKeyword.LetRec (range0, range0)
+                            else
+                                trivia.LeadingKeyword
+                        | SynLeadingKeyword.LetRec _ ->
+                            if isRec then
+                                trivia.LeadingKeyword
+                            else
+                                trivia.LeadingKeyword
+                        | existing ->
+                            failwith
+                                $"WoofWare.Myriad doesn't yet let you adjust the recursion modifier on a binding with modifier %O{existing}"
+                }
+
+            SynBinding (pat, kind, inl, mut, attrs, xml, valData, headPat, returnInfo, expr, range, debugPoint, trivia)
+
    let withAccessibility (acc : SynAccess option) (binding : SynBinding) : SynBinding =
        match binding with
        | SynBinding (_, kind, inl, mut, attrs, xml, valData, headPat, returnInfo, expr, range, debugPoint, trivia) ->
--- a/WoofWare.Myriad.Plugins/SynExpr/SynExpr.fs
+++ b/WoofWare.Myriad.Plugins/SynExpr/SynExpr.fs
@@ -13,6 +13,13 @@ module internal SynExprExtensions =

        static member CreateConst () : SynExpr = SynExpr.Const (SynConst.Unit, range0)

+        static member CreateConst (b : bool) : SynExpr = SynExpr.Const (SynConst.Bool b, range0)
+
+        static member CreateConst (c : char) : SynExpr =
+            // apparent Myriad bug: `IndexOf '?'` gets formatted as `IndexOf ?` which is clearly wrong
+            SynExpr.CreateApp (SynExpr.Ident (Ident.Create "char"), SynExpr.CreateConst (int c))
+            |> fun e -> SynExpr.Paren (e, range0, Some range0, range0)
+
        static member CreateConst (i : int32) : SynExpr =
            SynExpr.Const (SynConst.Int32 i, range0)

@@ -138,6 +145,14 @@ module internal SynExpr =
    let inline index (property : SynExpr) (obj : SynExpr) : SynExpr =
        SynExpr.DotIndexedGet (obj, property, range0, range0)

+    let inline arrayIndexRange (start : SynExpr option) (endRange : SynExpr option) (arr : SynExpr) : SynExpr =
+        SynExpr.DotIndexedGet (
+            arr,
+            (SynExpr.IndexRange (start, range0, endRange, range0, range0, range0)),
+            range0,
+            range0
+        )
+
    let inline paren (e : SynExpr) : SynExpr =
        SynExpr.Paren (e, range0, Some range0, range0)

@@ -202,6 +217,18 @@ module internal SynExpr =

        pipeThroughFunction lambda body

+    let inline createForEach (pat : SynPat) (enumExpr : SynExpr) (body : SynExpr) : SynExpr =
+        SynExpr.ForEach (
+            DebugPointAtFor.No,
+            DebugPointAtInOrTo.No,
+            SeqExprOnly.SeqExprOnly false,
+            true,
+            pat,
+            enumExpr,
+            body,
+            range0
+        )
+
    let inline createLet (bindings : SynBinding list) (body : SynExpr) : SynExpr =
        SynExpr.LetOrUse (false, false, bindings, body, range0, SynExprLetOrUseTrivia.empty)

@@ -296,9 +323,37 @@ module internal SynExpr =

    /// {y} > {x}
    let greaterThan (x : SynExpr) (y : SynExpr) : SynExpr =
-        SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.ge, y) |> applyTo x
+        SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.gt, y) |> applyTo x
+
+    /// {y} < {x}
+    let lessThan (x : SynExpr) (y : SynExpr) : SynExpr =
+        SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.lt, y) |> applyTo x

    /// {y} >= {x}
    let greaterThanOrEqual (x : SynExpr) (y : SynExpr) : SynExpr =
        SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.geq, y)
        |> applyTo x
+
+    /// {y} <= {x}
+    let lessThanOrEqual (x : SynExpr) (y : SynExpr) : SynExpr =
+        SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.leq, y)
+        |> applyTo x
+
+    /// {x} :: {y}
+    let listCons (x : SynExpr) (y : SynExpr) : SynExpr =
+        SynExpr.CreateAppInfix (
+            SynExpr.LongIdent (
+                false,
+                SynLongIdent.SynLongIdent (
+                    [ Ident.create "op_ColonColon" ],
+                    [],
+                    [ Some (IdentTrivia.OriginalNotation "::") ]
+                ),
+                None,
+                range0
+            ),
+            tupleNoParen [ x ; y ]
+        )
+        |> paren
+
+    let assign (lhs : SynLongIdent) (rhs : SynExpr) : SynExpr = SynExpr.LongIdentSet (lhs, rhs, range0)
--- a/WoofWare.Myriad.Plugins/SynExpr/SynLongIdent.fs
+++ b/WoofWare.Myriad.Plugins/SynExpr/SynLongIdent.fs
@@ -14,9 +14,19 @@ module internal SynLongIdent =
            [ Some (IdentTrivia.OriginalNotation ">=") ]
        )

-    let ge =
+    let leq =
+        SynLongIdent.SynLongIdent (
+            [ Ident.create "op_LessThanOrEqual" ],
+            [],
+            [ Some (IdentTrivia.OriginalNotation "<=") ]
+        )
+
+    let gt =
        SynLongIdent.SynLongIdent ([ Ident.create "op_GreaterThan" ], [], [ Some (IdentTrivia.OriginalNotation ">") ])

+    let lt =
+        SynLongIdent.SynLongIdent ([ Ident.create "op_LessThan" ], [], [ Some (IdentTrivia.OriginalNotation "<") ])
+
    let sub =
        SynLongIdent.SynLongIdent ([ Ident.create "op_Subtraction" ], [], [ Some (IdentTrivia.OriginalNotation "-") ])

@@ -70,6 +80,12 @@ module internal SynLongIdent =
        // TODO: consider Microsoft.FSharp.Option or whatever it is
        | _ -> false

+    let isChoice (ident : SynLongIdent) : bool =
+        match ident.LongIdent with
+        | [ i ] when System.String.Equals (i.idText, "Choice", System.StringComparison.Ordinal) -> true
+        // TODO: consider Microsoft.FSharp.Choice or whatever it is
+        | _ -> false
+
    let isNullable (ident : SynLongIdent) : bool =
        match ident.LongIdent |> List.map _.idText with
        | [ "System" ; "Nullable" ]
--- a/WoofWare.Myriad.Plugins/SynExpr/SynModuleDecl.fs
+++ b/WoofWare.Myriad.Plugins/SynExpr/SynModuleDecl.fs
@@ -14,6 +14,8 @@ module internal SynModuleDecl =

    let inline createLet (binding : SynBinding) : SynModuleDecl = createLets [ binding ]

+    let inline createTypes (tys : SynTypeDefn list) : SynModuleDecl = SynModuleDecl.Types (tys, range0)
+
    let nestedModule (info : SynComponentInfo) (decls : SynModuleDecl list) : SynModuleDecl =
        SynModuleDecl.NestedModule (
            info,
--- a/WoofWare.Myriad.Plugins/SynExpr/SynPat.fs
+++ b/WoofWare.Myriad.Plugins/SynExpr/SynPat.fs
@@ -33,3 +33,17 @@ module internal SynPat =
    let unit = createConst SynConst.Unit

    let createNull = SynPat.Null range0
+
+    let emptyList = SynPat.ArrayOrList (false, [], range0)
+
+    let listCons (lhs : SynPat) (rhs : SynPat) =
+        SynPat.ListCons (
+            lhs,
+            rhs,
+            range0,
+            {
+                ColonColonRange = range0
+            }
+        )
+
+    let emptyArray = SynPat.ArrayOrList (true, [], range0)
--- a/WoofWare.Myriad.Plugins/SynExpr/SynType.fs
+++ b/WoofWare.Myriad.Plugins/SynExpr/SynType.fs
@@ -1,56 +1,9 @@
 namespace WoofWare.Myriad.Plugins

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

-[<RequireQualifiedAccess>]
-module internal SynType =
-    let rec stripOptionalParen (ty : SynType) : SynType =
-        match ty with
-        | SynType.Paren (ty, _) -> stripOptionalParen ty
-        | ty -> ty
-
-    let inline createLongIdent (ident : LongIdent) : SynType =
-        SynType.LongIdent (SynLongIdent.create ident)
-
-    let inline createLongIdent' (ident : string list) : SynType =
-        SynType.LongIdent (SynLongIdent.createS' ident)
-
-    let inline named (name : string) = createLongIdent' [ name ]
-
-    let inline app' (name : SynType) (args : SynType list) : SynType =
-        if args.IsEmpty then
-            failwith "Type cannot be applied to no arguments"
-
-        SynType.App (name, Some range0, args, List.replicate (args.Length - 1) range0, Some range0, false, range0)
-
-    let inline app (name : string) (args : SynType list) : SynType = app' (named name) args
-
-    let inline appPostfix (name : string) (arg : SynType) : SynType =
-        SynType.App (named name, None, [ arg ], [], None, true, range0)
-
-    let inline funFromDomain (domain : SynType) (range : SynType) : SynType =
-        SynType.Fun (
-            domain,
-            range,
-            range0,
-            {
-                ArrowRange = range0
-            }
-        )
-
-    let inline signatureParamOfType (ty : SynType) (name : Ident option) : SynType =
-        SynType.SignatureParameter ([], false, name, ty, range0)
-
-    let inline var (ty : SynTypar) : SynType = SynType.Var (ty, range0)
-
-    let unit : SynType = named "unit"
-    let int : SynType = named "int"
-
-    /// Given ['a1, 'a2] and 'ret, returns 'a1 -> 'a2 -> 'ret.
-    let toFun (inputs : SynType list) (ret : SynType) : SynType =
-        (ret, List.rev inputs) ||> List.fold (fun ty input -> funFromDomain input ty)
-
 [<AutoOpen>]
 module internal SynTypePatterns =
    let (|OptionType|_|) (fieldType : SynType) =
@@ -59,6 +12,11 @@ module internal SynTypePatterns =
            Some innerType
        | _ -> None

+    let (|ChoiceType|_|) (fieldType : SynType) =
+        match fieldType with
+        | SynType.App (SynType.LongIdent ident, _, inner, _, _, _, _) when SynLongIdent.isChoice ident -> Some inner
+        | _ -> None
+
    let (|NullableType|_|) (fieldType : SynType) =
        match fieldType with
        | SynType.App (SynType.LongIdent ident, _, [ innerType ], _, _, _, _) when SynLongIdent.isNullable ident ->
@@ -272,3 +230,169 @@ module internal SynTypePatterns =
                | _ -> failwithf "Expected Task to be applied to exactly one arg, but got: %+A" args
            | _ -> None
        | _ -> None
+
+    let (|DirectoryInfo|_|) (fieldType : SynType) =
+        match fieldType with
+        | SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->
+            match ident |> List.map (fun i -> i.idText) with
+            | [ "System" ; "IO" ; "DirectoryInfo" ]
+            | [ "IO" ; "DirectoryInfo" ]
+            | [ "DirectoryInfo" ] -> Some ()
+            | _ -> None
+        | _ -> None
+
+    let (|FileInfo|_|) (fieldType : SynType) =
+        match fieldType with
+        | SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->
+            match ident |> List.map (fun i -> i.idText) with
+            | [ "System" ; "IO" ; "FileInfo" ]
+            | [ "IO" ; "FileInfo" ]
+            | [ "FileInfo" ] -> Some ()
+            | _ -> None
+        | _ -> None
+
+[<RequireQualifiedAccess>]
+module internal SynType =
+    let rec stripOptionalParen (ty : SynType) : SynType =
+        match ty with
+        | SynType.Paren (ty, _) -> stripOptionalParen ty
+        | ty -> ty
+
+    let inline createLongIdent (ident : LongIdent) : SynType =
+        SynType.LongIdent (SynLongIdent.create ident)
+
+    let inline createLongIdent' (ident : string list) : SynType =
+        SynType.LongIdent (SynLongIdent.createS' ident)
+
+    let inline named (name : string) = createLongIdent' [ name ]
+
+    let inline app' (name : SynType) (args : SynType list) : SynType =
+        if args.IsEmpty then
+            failwith "Type cannot be applied to no arguments"
+
+        SynType.App (name, Some range0, args, List.replicate (args.Length - 1) range0, Some range0, false, range0)
+
+    let inline app (name : string) (args : SynType list) : SynType = app' (named name) args
+
+    let inline appPostfix (name : string) (arg : SynType) : SynType =
+        SynType.App (named name, None, [ arg ], [], None, true, range0)
+
+    let inline appPostfix' (name : string list) (arg : SynType) : SynType =
+        SynType.App (createLongIdent' name, None, [ arg ], [], None, true, range0)
+
+    let inline funFromDomain (domain : SynType) (range : SynType) : SynType =
+        SynType.Fun (
+            domain,
+            range,
+            range0,
+            {
+                ArrowRange = range0
+            }
+        )
+
+    let inline signatureParamOfType (ty : SynType) (name : Ident option) : SynType =
+        SynType.SignatureParameter ([], false, name, ty, range0)
+
+    let inline var (ty : SynTypar) : SynType = SynType.Var (ty, range0)
+
+    let unit : SynType = named "unit"
+    let int : SynType = named "int"
+
+    let anon : SynType = SynType.Anon range0
+
+    let string : SynType = named "string"
+
+    /// Given ['a1, 'a2] and 'ret, returns 'a1 -> 'a2 -> 'ret.
+    let toFun (inputs : SynType list) (ret : SynType) : SynType =
+        (ret, List.rev inputs) ||> List.fold (fun ty input -> funFromDomain input 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
+            true
+        else
+
+        match ty1 with
+        | PrimitiveType t1 ->
+            match ty2 with
+            | PrimitiveType t2 -> (t1 |> List.map _.idText) = (t2 |> List.map _.idText)
+            | _ -> false
+        | OptionType t1 ->
+            match ty2 with
+            | OptionType t2 -> provablyEqual t1 t2
+            | _ -> false
+        | NullableType t1 ->
+            match ty2 with
+            | NullableType t2 -> provablyEqual t1 t2
+            | _ -> false
+        | ChoiceType t1 ->
+            match ty2 with
+            | ChoiceType t2 ->
+                t1.Length = t2.Length
+                && List.forall (fun (a, b) -> provablyEqual a b) (List.zip t1 t2)
+            | _ -> false
+        | DictionaryType (k1, v1) ->
+            match ty2 with
+            | DictionaryType (k2, v2) -> provablyEqual k1 k2 && provablyEqual v1 v2
+            | _ -> false
+        | IDictionaryType (k1, v1) ->
+            match ty2 with
+            | IDictionaryType (k2, v2) -> provablyEqual k1 k2 && provablyEqual v1 v2
+            | _ -> false
+        | IReadOnlyDictionaryType (k1, v1) ->
+            match ty2 with
+            | IReadOnlyDictionaryType (k2, v2) -> provablyEqual k1 k2 && provablyEqual v1 v2
+            | _ -> false
+        | MapType (k1, v1) ->
+            match ty2 with
+            | MapType (k2, v2) -> provablyEqual k1 k2 && provablyEqual v1 v2
+            | _ -> false
+        | ListType t1 ->
+            match ty2 with
+            | ListType t2 -> provablyEqual t1 t2
+            | _ -> false
+        | ArrayType t1 ->
+            match ty2 with
+            | ArrayType t2 -> provablyEqual t1 t2
+            | _ -> false
+        | Task t1 ->
+            match ty2 with
+            | Task t2 -> provablyEqual t1 t2
+            | _ -> false
+        | UnitType ->
+            match ty2 with
+            | UnitType -> true
+            | _ -> false
+        | FileInfo ->
+            match ty2 with
+            | FileInfo -> true
+            | _ -> false
+        | DirectoryInfo ->
+            match ty2 with
+            | DirectoryInfo -> true
+            | _ -> false
+        | Uri ->
+            match ty2 with
+            | Uri -> true
+            | _ -> false
+        | Stream ->
+            match ty2 with
+            | Stream -> true
+            | _ -> false
+        | Guid ->
+            match ty2 with
+            | Guid -> true
+            | _ -> false
+        | BigInt ->
+            match ty2 with
+            | BigInt -> true
+            | _ -> false
+        | DateTimeOffset ->
+            match ty2 with
+            | DateTimeOffset -> true
+            | _ -> false
+        | DateOnly ->
+            match ty2 with
+            | DateOnly -> true
+            | _ -> false
+        | _ -> false
--- a/WoofWare.Myriad.Plugins/SynExpr/SynUnionCase.fs
+++ b/WoofWare.Myriad.Plugins/SynExpr/SynUnionCase.fs
@@ -1,6 +1,9 @@
 namespace WoofWare.Myriad.Plugins

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

 type internal UnionCase<'Ident> =
    {
@@ -39,3 +42,34 @@ module internal SynUnionCase =
            Attrs = attrs
            Ident = id
        }
+
+    let create (case : UnionCase<Ident>) : SynUnionCase =
+        let fields =
+            case.Fields
+            |> List.map (fun field ->
+                SynField.SynField (
+                    SynAttributes.ofAttrs field.Attrs,
+                    false,
+                    Some field.Ident,
+                    field.Type,
+                    false,
+                    PreXmlDoc.Empty,
+                    None,
+                    range0,
+                    {
+                        LeadingKeyword = None
+                    }
+                )
+            )
+
+        SynUnionCase.SynUnionCase (
+            SynAttributes.ofAttrs case.Attrs,
+            SynIdent.SynIdent (case.Ident, None),
+            SynUnionCaseKind.Fields fields,
+            PreXmlDoc.Empty,
+            None,
+            range0,
+            {
+                BarRange = Some range0
+            }
+        )