Fix record/union impl accessibility (#245)

ConsumePlugin/Args.fs

@@ -190,3 +190,8 @@ type ManyLongForms =
         [<ArgumentLongForm "dont-turn-it-off">]
         SomeFlag : bool
     }
+
+[<RequireQualifiedAccess>]
+type private IrrelevantDu =
+    | Foo
+    | Bar

WoofWare.Myriad.Plugins/ArgParserGenerator.fs

@@ -1521,53 +1521,54 @@ module internal ArgParserGenerator =
             |> 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 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
                     | [], [] ->
-                        let c1Attr =
+                        {
-                            c1.Attributes
+                            Name = ty.Name
-                            |> List.tryPick (fun attr ->
+                            Case1Name = c1.Name
-                                match attr.TypeName with
+                            Case1Arg = c1Attr
-                                | SynLongIdent.SynLongIdent (id, _, _) ->
+                            Case2Name = c2.Name
-                                    match id |> List.last |> _.idText with
+                            Case2Arg = c2Attr
-                                    | "ArgumentFlagAttribute"
+                        }
-                                    | "ArgumentFlag" -> Some (SynExpr.stripOptionalParen attr.ArgExpr)
+                        |> Some
-                                    | _ -> None
-                            )
-
-                        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 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."
-                            | _, _ -> ()
-
-                            {
-                                Name = ty.Name
-                                Case1Name = c1.Name
-                                Case1Arg = c1Attr
-                                Case2Name = c2.Name
-                                Case2Arg = c2Attr
-                            }
-                            |> Some
-                        | 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
                     | _, _ ->
                         failwith "[<ArgumentFlag>] may only be placed on discriminated union members with no data."
                 | _ -> None

WoofWare.Myriad.Plugins/AstHelper.fs

@@ -67,7 +67,8 @@ type internal RecordType =
         Members : SynMemberDefns option
         XmlDoc : PreXmlDoc option
         Generics : SynTyparDecls option
-        Accessibility : SynAccess option
+        TypeAccessibility : SynAccess option
+        ImplAccessibility : SynAccess option
         Attributes : SynAttribute list
     }
 
@@ -80,17 +81,15 @@ type internal RecordType =
         : RecordType
         =
         match sci with
-        | SynComponentInfo.SynComponentInfo (attrs, typars, _, longId, doc, _, access2, _) ->
+        | SynComponentInfo.SynComponentInfo (attrs, typars, _, longId, doc, _, implAccess, _) ->
-            if access <> access2 then
-                failwith $"TODO what's happened, two different accessibility modifiers: %O{access} and %O{access2}"
-
             {
                 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 = access
+                ImplAccessibility = implAccess
+                TypeAccessibility = access
                 Attributes = attrs |> List.collect (fun l -> l.Attributes)
             }
 
@@ -144,7 +143,9 @@ type internal UnionType =
         /// Attributes of the DU (not its cases): `[<Attr>] type Foo = | ...`
         Attributes : SynAttribute list
         /// Accessibility modifier of the DU: `type private Foo = ...`
-        Accessibility : SynAccess option
+        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
     }
@@ -157,17 +158,15 @@ type internal UnionType =
         : UnionType
         =
         match sci with
-        | SynComponentInfo.SynComponentInfo (attrs, typars, _, longId, doc, _, access2, _) ->
+        | SynComponentInfo.SynComponentInfo (attrs, typars, _, longId, doc, _, implAccess, _) ->
-            if access <> access2 then
-                failwith $"TODO what's happened, two different accessibility modifiers: %O{access} and %O{access2}"
-
             {
                 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)
-                Accessibility = access
+                TypeAccessibility = access
+                ImplAccessibility = implAccess
                 Cases = cases |> List.map UnionCase.ofSynUnionCase
             }
 
@@ -213,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/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/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