patrick/WoofWare.Myriad
1
0
Fork 0
mirror of https://github.com/Smaug123/WoofWare.Myriad synced 2025-10-05 03:58:40 +00:00
Code Issues Packages Projects Releases Wiki Activity

Fix record/union impl accessibility (#245)

Browse Source
This commit is contained in:
Patrick Stevens
2024-09-07 09:49:28 +01:00
committed by GitHub
parent 8ae749c529
commit 029e3746bb
6 changed files with 115 additions and 100 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
ConsumePlugin/Args.fs
View File

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

91
WoofWare.Myriad.Plugins/ArgParserGenerator.fs
View File

@@ -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
|> 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
"[<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
{
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

27
WoofWare.Myriad.Plugins/AstHelper.fs
View File

@@ -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): `[<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, _) ->
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)

3
WoofWare.Myriad.Plugins/InterfaceMockGenerator.fs
View File

@@ -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 = []
}

77
WoofWare.Myriad.Plugins/RemoveOptionsGenerator.fs
View File

@@ -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 (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<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 =

12
WoofWare.Myriad.Plugins/SynExpr/SynTypeDefnRepr.fs
View File

@@ -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