Skip to content

Commit

Permalink
Pull out general changes from ArgParser PR (#217)
Browse files Browse the repository at this point in the history
  • Loading branch information
Smaug123 authored Aug 25, 2024
1 parent 20226b9 commit 569b3cc
Show file tree
Hide file tree
Showing 19 changed files with 412 additions and 90 deletions.
6 changes: 3 additions & 3 deletions ConsumePlugin/ConsumePlugin.fsproj
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,7 @@
<PropertyGroup>
<TargetFramework>net8.0</TargetFramework>
<IsPackable>false</IsPackable>
<OtherFlags>--reflectionfree $(OtherFlags)</OtherFlags>
</PropertyGroup>
<ItemGroup>
<MyriadSdkGenerator Include="$(MSBuildThisFileDirectory)..\WoofWare.Myriad.Plugins\bin\$(Configuration)\net6.0\WoofWare.Myriad.Plugins.dll"/>
Expand Down Expand Up @@ -56,9 +57,8 @@
<ItemGroup>
<PackageReference Include="RestEase" Version="1.6.4"/>
<ProjectReference Include="..\WoofWare.Myriad.Plugins.Attributes\WoofWare.Myriad.Plugins.Attributes.fsproj" />
<ProjectReference Include="..\WoofWare.Myriad.Plugins\WoofWare.Myriad.Plugins.fsproj"/>
<PackageReference Include="Myriad.Sdk" Version="0.8.3"/>
<PackageReference Include="Myriad.Core" Version="0.8.3"/>
<ProjectReference Include="..\WoofWare.Myriad.Plugins\WoofWare.Myriad.Plugins.fsproj" PrivateAssets="all" />
<PackageReference Include="Myriad.Sdk" Version="0.8.3" PrivateAssets="all" />
</ItemGroup>

</Project>
12 changes: 12 additions & 0 deletions ConsumePlugin/FSharpForFunAndProfitCata.fs
Original file line number Diff line number Diff line change
Expand Up @@ -30,6 +30,12 @@ type ChocolateType =
| Milk
| SeventyPercent

override this.ToString () =
match this with
| ChocolateType.Dark -> "Dark"
| ChocolateType.Milk -> "Milk"
| ChocolateType.SeventyPercent -> "SeventyPercent"

type Chocolate =
{
chocType : ChocolateType
Expand All @@ -43,6 +49,12 @@ type WrappingPaperStyle =
| HappyHolidays
| SolidColor

override this.ToString () =
match this with
| WrappingPaperStyle.HappyBirthday -> "HappyBirthday"
| WrappingPaperStyle.HappyHolidays -> "HappyHolidays"
| WrappingPaperStyle.SolidColor -> "SolidColor"

[<CreateCatamorphism "GiftCata">]
type Gift =
| Book of Book
Expand Down
4 changes: 0 additions & 4 deletions ConsumePlugin/RecordFile.fs
Original file line number Diff line number Diff line change
@@ -1,9 +1,5 @@
namespace ConsumePlugin

type ParseState =
| AwaitingKey
| AwaitingValue of string

/// My whatnot
[<WoofWare.Myriad.Plugins.RemoveOptions>]
type RecordType =
Expand Down
2 changes: 1 addition & 1 deletion WoofWare.Myriad.Plugins.Test/TestCataGenerator/TestGift.fs
Original file line number Diff line number Diff line change
Expand Up @@ -43,7 +43,7 @@ module TestGift =
member _.WithACard g message =
$"%s{g} with a card saying '%s{message}'"

member _.Wrapped g paper = $"%s{g} wrapped in %A{paper} paper"
member _.Wrapped g paper = $"%s{g} wrapped in %O{paper} paper"
}
}

Expand Down
39 changes: 36 additions & 3 deletions WoofWare.Myriad.Plugins/AstHelper.fs
Original file line number Diff line number Diff line change
Expand Up @@ -62,13 +62,46 @@ type internal InterfaceType =
type internal RecordType =
{
Name : Ident
Fields : SynField seq
Fields : SynField list
/// Any additional members which are not record fields.
Members : SynMemberDefns option
XmlDoc : PreXmlDoc option
Generics : SynTyparDecls option
Accessibility : SynAccess option
Attributes : SynAttribute list
}

/// Parse from the AST.
static member OfRecord (record : SynTypeDefn) : RecordType =
let sci, sdr, smd, smdo =
match record with
| SynTypeDefn.SynTypeDefn (sci, sdr, smd, smdo, _, _) -> sci, sdr, smd, smdo

let synAccessOption, recordFields =
match sdr with
| SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (sa, fields, _), _) -> sa, fields
| _ -> failwith $"expected a record; got: %+A{record}"

match sci with
| SynComponentInfo.SynComponentInfo (attrs, typars, _, longId, doc, _, access, _) ->
if access <> synAccessOption then
failwith
$"TODO what's happened, two different accessibility modifiers: %O{access} and %O{synAccessOption}"

match smdo with
| Some v -> failwith $"TODO what's happened, got a synMemberDefn of %O{v}"
| None -> ()

{
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 = synAccessOption
Attributes = attrs |> List.collect (fun l -> l.Attributes)
}

/// Anything that is part of an ADT.
/// A record is a product of stuff; this type represents one of those stuffs.
type internal AdtNode =
Expand Down Expand Up @@ -101,10 +134,10 @@ module internal AstHelper =
| SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Enum _, _) -> true
| _ -> false

let instantiateRecord (fields : (RecordFieldName * SynExpr option) list) : SynExpr =
let instantiateRecord (fields : (SynLongIdent * SynExpr) list) : SynExpr =
let fields =
fields
|> List.map (fun (rfn, synExpr) -> SynExprRecordField (rfn, Some range0, synExpr, None))
|> List.map (fun (rfn, synExpr) -> SynExprRecordField ((rfn, true), Some range0, Some synExpr, None))

SynExpr.Record (None, None, fields, range0)

Expand Down
2 changes: 1 addition & 1 deletion WoofWare.Myriad.Plugins/CataGenerator.fs
Original file line number Diff line number Diff line change
Expand Up @@ -1100,7 +1100,7 @@ module internal CataGenerator =
let moduleName = parentName + "Cata" |> Ident.create

let modInfo =
SynComponentInfo.create (parentName + "Cata" |> Ident.create)
SynComponentInfo.create moduleName
|> SynComponentInfo.withDocString (
PreXmlDoc.Create $" Methods to perform a catamorphism over the type %s{parentName}"
)
Expand Down
30 changes: 10 additions & 20 deletions WoofWare.Myriad.Plugins/HttpClientGenerator.fs
Original file line number Diff line number Diff line change
Expand Up @@ -257,11 +257,7 @@ module internal HttpClientGenerator =
| Some id -> id

let urlSeparator =
// apparent Myriad bug: `IndexOf '?'` gets formatted as `IndexOf ?` which is clearly wrong
let questionMark =
SynExpr.CreateConst 63
|> SynExpr.applyFunction (SynExpr.createIdent "char")
|> SynExpr.paren
let questionMark = SynExpr.CreateConst '?'

let containsQuestion =
info.UrlTemplate
Expand Down Expand Up @@ -425,21 +421,17 @@ module internal HttpClientGenerator =
(SynExpr.createIdent' bodyParamName)
)
Do (
SynExpr.LongIdentSet (
SynLongIdent.createS' [ "httpMessage" ; "Content" ],
SynExpr.createIdent "queryParams",
range0
)
SynExpr.assign
(SynLongIdent.createS' [ "httpMessage" ; "Content" ])
(SynExpr.createIdent "queryParams")
)
]
| BodyParamMethods.HttpContent ->
[
Do (
SynExpr.LongIdentSet (
SynLongIdent.createS' [ "httpMessage" ; "Content" ],
SynExpr.createIdent' bodyParamName,
range0
)
SynExpr.assign
(SynLongIdent.createS' [ "httpMessage" ; "Content" ])
(SynExpr.createIdent' bodyParamName)
)
]
| BodyParamMethods.Serialise ty ->
Expand All @@ -464,11 +456,9 @@ module internal HttpClientGenerator =
))
)
Do (
SynExpr.LongIdentSet (
SynLongIdent.createS' [ "httpMessage" ; "Content" ],
SynExpr.createIdent "queryParams",
range0
)
SynExpr.assign
(SynLongIdent.createS' [ "httpMessage" ; "Content" ])
(SynExpr.createIdent "queryParams")
)
]

Expand Down
5 changes: 3 additions & 2 deletions WoofWare.Myriad.Plugins/InterfaceMockGenerator.fs
Original file line number Diff line number Diff line change
Expand Up @@ -71,13 +71,13 @@ module internal InterfaceMockGenerator =
if inherits.Contains KnownInheritance.IDisposable then
let unitFun = SynExpr.createThunk (SynExpr.CreateConst ())

[ (SynLongIdent.createS "Dispose", true), Some unitFun ]
[ SynLongIdent.createS "Dispose", unitFun ]
else
[]

let nonExtras =
fields
|> List.map (fun field -> (SynLongIdent.createI (getName field), true), Some (failwithFun field))
|> List.map (fun field -> SynLongIdent.createI (getName field), failwithFun field)

extras @ nonExtras

Expand Down Expand Up @@ -213,6 +213,7 @@ module internal InterfaceMockGenerator =
XmlDoc = Some xmlDoc
Generics = interfaceType.Generics
Accessibility = Some access
Attributes = []
}

let typeDecl = AstHelper.defineRecordType record
Expand Down
4 changes: 1 addition & 3 deletions WoofWare.Myriad.Plugins/JsonParseGenerator.fs
Original file line number Diff line number Diff line change
Expand Up @@ -407,9 +407,7 @@ module internal JsonParseGenerator =

let finalConstruction =
fields
|> List.mapi (fun i fieldData ->
(SynLongIdent.createI fieldData.Ident, true), Some (SynExpr.createIdent $"arg_%i{i}")
)
|> List.mapi (fun i fieldData -> SynLongIdent.createI fieldData.Ident, SynExpr.createIdent $"arg_%i{i}")
|> AstHelper.instantiateRecord

(finalConstruction, assignments)
Expand Down
4 changes: 3 additions & 1 deletion WoofWare.Myriad.Plugins/RemoveOptionsGenerator.fs
Original file line number Diff line number Diff line change
Expand Up @@ -42,6 +42,7 @@ module internal RemoveOptionsGenerator =
(accessibility : SynAccess option)
(generics : SynTyparDecls option)
(fields : SynField list)
: SynModuleDecl
=
let fields : SynField list = fields |> List.map removeOption
let name = Ident.create "Short"
Expand All @@ -54,6 +55,7 @@ module internal RemoveOptionsGenerator =
XmlDoc = xmlDoc
Generics = generics
Accessibility = accessibility
Attributes = []
}

let typeDecl = AstHelper.defineRecordType record
Expand Down Expand Up @@ -91,7 +93,7 @@ module internal RemoveOptionsGenerator =
)
| _ -> accessor

(SynLongIdent.createI fieldData.Ident, true), Some body
SynLongIdent.createI fieldData.Ident, body
)
|> AstHelper.instantiateRecord

Expand Down
15 changes: 15 additions & 0 deletions WoofWare.Myriad.Plugins/SynExpr/SynAttributes.fs
Original file line number Diff line number Diff line change
@@ -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
}
)
29 changes: 29 additions & 0 deletions WoofWare.Myriad.Plugins/SynExpr/SynBinding.fs
Original file line number Diff line number Diff line change
Expand Up @@ -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) ->
Expand Down
57 changes: 56 additions & 1 deletion WoofWare.Myriad.Plugins/SynExpr/SynExpr.fs
Original file line number Diff line number Diff line change
Expand Up @@ -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)

Expand Down Expand Up @@ -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)

Expand Down Expand Up @@ -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)

Expand Down Expand Up @@ -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)
Loading

0 comments on commit 569b3cc

Please sign in to comment.