diff --git a/ConsumePlugin/Args.fs b/ConsumePlugin/Args.fs index 65d5fa8..033b28c 100644 --- a/ConsumePlugin/Args.fs +++ b/ConsumePlugin/Args.fs @@ -190,3 +190,8 @@ type ManyLongForms = [] SomeFlag : bool } + +[] +type private IrrelevantDu = + | Foo + | Bar diff --git a/WoofWare.Myriad.Plugins/ArgParserGenerator.fs b/WoofWare.Myriad.Plugins/ArgParserGenerator.fs index cf19930..80e3ff3 100644 --- a/WoofWare.Myriad.Plugins/ArgParserGenerator.fs +++ b/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 + "[] 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 + "[] must have opposite argument values on each case in a two-case discriminated union." + | _, _ -> () + match c1.Fields, c2.Fields with | [], [] -> - 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 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 - "[] 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 - "[] must be placed on both cases of a two-case discriminated union, with opposite argument values on each case." - | _, _ -> None + { + Name = ty.Name + Case1Name = c1.Name + Case1Arg = c1Attr + Case2Name = c2.Name + Case2Arg = c2Attr + } + |> Some | _, _ -> failwith "[] may only be placed on discriminated union members with no data." | _ -> None diff --git a/WoofWare.Myriad.Plugins/AstHelper.fs b/WoofWare.Myriad.Plugins/AstHelper.fs index 8336ef4..d82a23b 100644 --- a/WoofWare.Myriad.Plugins/AstHelper.fs +++ b/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, _) -> - if access <> access2 then - failwith $"TODO what's happened, two different accessibility modifiers: %O{access} and %O{access2}" - + | SynComponentInfo.SynComponentInfo (attrs, typars, _, longId, doc, _, implAccess, _) -> { 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): `[] 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 list } @@ -157,17 +158,15 @@ type internal UnionType = : UnionType = match sci with - | SynComponentInfo.SynComponentInfo (attrs, typars, _, longId, doc, _, access2, _) -> - if access <> access2 then - failwith $"TODO what's happened, two different accessibility modifiers: %O{access} and %O{access2}" - + | 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) - 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) diff --git a/WoofWare.Myriad.Plugins/InterfaceMockGenerator.fs b/WoofWare.Myriad.Plugins/InterfaceMockGenerator.fs index a492ea9..5075508 100644 --- a/WoofWare.Myriad.Plugins/InterfaceMockGenerator.fs +++ b/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 = [] } diff --git a/WoofWare.Myriad.Plugins/RemoveOptionsGenerator.fs b/WoofWare.Myriad.Plugins/RemoveOptionsGenerator.fs index a0f6275..a2466de 100644 --- a/WoofWare.Myriad.Plugins/RemoveOptionsGenerator.fs +++ b/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 list) = + let createMaker (withOptionsType : LongIdent) (withoutOptionsType : Ident) (fields : SynFieldData 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 (SynTypeDefn (synComponentInfo, synTypeDefnRepr, _members, _implicitCtor, _, _)) = - typeDefn + let createRecordModule (namespaceId : LongIdent) (typeDefn : RecordType) = + let fieldData = typeDefn.Fields |> List.map SynField.extractWithIdent - let (SynComponentInfo (_attributes, typeParams, _constraints, recordId, doc, _preferPostfix, _access, _)) = - synComponentInfo + let decls = + [ + createType typeDefn.XmlDoc typeDefn.TypeAccessibility typeDefn.Generics typeDefn.Fields + createMaker [ Ident.create "Short" ] typeDefn.Name fieldData + ] - match synTypeDefnRepr with - | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (accessibility, fields, _range), _) -> - let fieldData = fields |> List.map SynField.extractWithIdent + let xmlDoc = + sprintf "Module containing an option-truncated version of the %s type" typeDefn.Name.idText + |> PreXmlDoc.create - let decls = - [ - createType (Some doc) accessibility typeParams fields - createMaker [ Ident.create "Short" ] recordId fieldData - ] + let info = + SynComponentInfo.create typeDefn.Name + |> SynComponentInfo.withDocString xmlDoc + |> SynComponentInfo.addAttributes [ SynAttribute.compilationRepresentation ] + |> SynComponentInfo.addAttributes [ SynAttribute.requireQualifiedAccess ] - let xmlDoc = - recordId - |> Seq.map (fun i -> i.idText) - |> 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" + SynModuleDecl.nestedModule info decls + |> List.singleton + |> SynModuleOrNamespace.createNamespace namespaceId open Myriad.Core @@ -164,7 +152,24 @@ type RemoveOptionsGenerator () = |> List.choose (fun (ns, types) -> match types |> List.filter Ast.hasAttribute 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 = diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynTypeDefnRepr.fs b/WoofWare.Myriad.Plugins/SynExpr/SynTypeDefnRepr.fs index 39d68fa..a5e0a2b 100644 --- a/WoofWare.Myriad.Plugins/SynExpr/SynTypeDefnRepr.fs +++ b/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 = - SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (None, cases, range0), range0) + let inline unionWithAccess (implAccess : SynAccess option) (cases : SynUnionCase list) : SynTypeDefnRepr = + SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (implAccess, cases, range0), range0) - let inline record (fields : SynField list) : SynTypeDefnRepr = - SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (None, fields, range0), range0) + let inline union (cases : SynUnionCase list) : SynTypeDefnRepr = unionWithAccess None cases + + 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