From 84888838353a09714e8a7bb718adbfe31e4113d1 Mon Sep 17 00:00:00 2001 From: Patrick Stevens <3138005+Smaug123@users.noreply.github.com> Date: Wed, 2 Oct 2024 21:38:00 +0100 Subject: [PATCH] Remove more of Myriad.Core (#276) --- ConsumePlugin/GeneratedFileSystem.fs | 4 +- ConsumePlugin/ListCata.fs | 2 +- WoofWare.Myriad.Plugins/ArgParserGenerator.fs | 142 ++++++++--------- WoofWare.Myriad.Plugins/CataGenerator.fs | 144 ++++++++++-------- .../HttpClientGenerator.fs | 2 +- WoofWare.Myriad.Plugins/JsonParseGenerator.fs | 2 +- .../JsonSerializeGenerator.fs | 2 +- .../RemoveOptionsGenerator.fs | 5 +- WoofWare.Myriad.Plugins/SynExpr/SynArgInfo.fs | 7 + WoofWare.Myriad.Plugins/SynExpr/SynConst.fs | 10 ++ WoofWare.Myriad.Plugins/SynExpr/SynExpr.fs | 92 +++++------ .../SynExpr/SynLongIdent.fs | 6 + .../SynExpr/SynSimplePat.fs | 10 ++ .../SynExpr/SynSimplePats.fs | 12 ++ .../SynExpr/SynTypeDefn.fs | 15 ++ .../SynExpr/SynUnionCase.fs | 4 +- WoofWare.Myriad.Plugins/SynExpr/SynValInfo.fs | 7 + .../WoofWare.Myriad.Plugins.fsproj | 5 + 18 files changed, 276 insertions(+), 195 deletions(-) create mode 100644 WoofWare.Myriad.Plugins/SynExpr/SynArgInfo.fs create mode 100644 WoofWare.Myriad.Plugins/SynExpr/SynConst.fs create mode 100644 WoofWare.Myriad.Plugins/SynExpr/SynSimplePat.fs create mode 100644 WoofWare.Myriad.Plugins/SynExpr/SynSimplePats.fs create mode 100644 WoofWare.Myriad.Plugins/SynExpr/SynValInfo.fs diff --git a/ConsumePlugin/GeneratedFileSystem.fs b/ConsumePlugin/GeneratedFileSystem.fs index 26932d9..4a2fff9 100644 --- a/ConsumePlugin/GeneratedFileSystem.fs +++ b/ConsumePlugin/GeneratedFileSystem.fs @@ -31,7 +31,7 @@ module FileSystemItemCata = [] type private Instruction = | Process__FileSystemItem of FileSystemItem - | FileSystemItem_Directory of string * int * int + | FileSystemItem_Directory of name : string * dirSize : int * contents : int let private loop (cata : FileSystemCata<'FileSystemItem>) (instructions : ResizeArray) = let fileSystemItemStack = ResizeArray<'FileSystemItem> () @@ -106,7 +106,7 @@ module GiftCata = | Process__Gift of Gift | Gift_Wrapped of WrappingPaperStyle | Gift_Boxed - | Gift_WithACard of string + | Gift_WithACard of message : string let private loop (cata : GiftCata<'Gift>) (instructions : ResizeArray) = let giftStack = ResizeArray<'Gift> () diff --git a/ConsumePlugin/ListCata.fs b/ConsumePlugin/ListCata.fs index 91c01f8..a6e3e84 100644 --- a/ConsumePlugin/ListCata.fs +++ b/ConsumePlugin/ListCata.fs @@ -31,7 +31,7 @@ module MyListCata = [] type private Instruction<'a> = | Process__MyList of MyList<'a> - | MyList_Cons of 'a + | MyList_Cons of head : 'a let private loop (cata : MyListCata<'a, 'MyList>) (instructions : ResizeArray>) = let myListStack = ResizeArray<'MyList> () diff --git a/WoofWare.Myriad.Plugins/ArgParserGenerator.fs b/WoofWare.Myriad.Plugins/ArgParserGenerator.fs index c06de1b..d2774fb 100644 --- a/WoofWare.Myriad.Plugins/ArgParserGenerator.fs +++ b/WoofWare.Myriad.Plugins/ArgParserGenerator.fs @@ -4,8 +4,6 @@ open System open System.Text open Fantomas.FCS.Syntax open Fantomas.FCS.Text.Range -open Fantomas.FCS.Xml -open Myriad.Core type internal ArgParserOutputSpec = { @@ -1224,7 +1222,7 @@ module internal ArgParserGenerator = (SynExpr.CreateConst ())) ]) SynMatchClause.create - (SynPat.listCons (SynPat.createConst (SynConst.CreateString "--")) (SynPat.named "rest")) + (SynPat.listCons (SynPat.createConst (SynConst.Create "--")) (SynPat.named "rest")) (SynExpr.callMethodArg "AddRange" (SynExpr.paren ( @@ -1643,7 +1641,7 @@ module internal ArgParserGenerator = let modInfo = SynComponentInfo.create modName |> SynComponentInfo.withDocString ( - PreXmlDoc.Create $" Methods to parse arguments for the type %s{taggedType.Name.idText}" + PreXmlDoc.create $"Methods to parse arguments for the type %s{taggedType.Name.idText}" ) |> SynComponentInfo.addAttributes modAttrs @@ -1666,7 +1664,7 @@ module internal ArgParserGenerator = [ { Attrs = [] - Ident = Ident.create "key" + Ident = Some (Ident.create "key") Type = SynType.string } ] @@ -1740,75 +1738,12 @@ module internal ArgParserGenerator = [ for openStatement in opens do - yield SynModuleDecl.CreateOpen openStatement + yield SynModuleDecl.openAny openStatement yield taggedMod ] |> SynModuleOrNamespace.createNamespace ns - let generate (context : GeneratorContext) : Output = - let ast, _ = - Ast.fromFilename context.InputFilename |> Async.RunSynchronously |> Array.head - - let types = - Ast.extractTypeDefn ast - |> List.groupBy (fst >> List.map _.idText >> String.concat ".") - |> List.map (fun (_, v) -> fst (List.head v), List.collect snd v) - - let opens = AstHelper.extractOpens ast - - let namespaceAndTypes = - types - |> List.collect (fun (ns, types) -> - let typeWithAttr = - types - |> List.choose (fun ty -> - match Ast.getAttribute ty with - | None -> None - | Some attr -> - let arg = - match SynExpr.stripOptionalParen attr.ArgExpr with - | SynExpr.Const (SynConst.Bool value, _) -> value - | SynExpr.Const (SynConst.Unit, _) -> ArgParserAttribute.DefaultIsExtensionMethod - | arg -> - failwith - $"Unrecognised argument %+A{arg} to [<%s{nameof ArgParserAttribute}>]. Literals are not supported. Use `true` or `false` (or unit) only." - - let spec = - { - ExtensionMethods = arg - } - - Some (ty, spec) - ) - - typeWithAttr - |> List.map (fun taggedType -> - let unions, records, others = - (([], [], []), types) - ||> List.fold (fun - (unions, records, others) - (SynTypeDefn.SynTypeDefn (sci, repr, smd, _, _, _) as ty) -> - match repr with - | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (access, cases, _), _) -> - UnionType.OfUnion sci smd access cases :: unions, records, others - | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (access, fields, _), _) -> - unions, RecordType.OfRecord sci smd access fields :: records, others - | _ -> unions, records, ty :: others - ) - - if not others.IsEmpty then - failwith - $"Error: all types recursively defined together with an ArgParserGenerator type must be discriminated unions or records. %+A{others}" - - (ns, taggedType, unions, records) - ) - ) - - let modules = - namespaceAndTypes - |> List.map (fun (ns, taggedType, unions, records) -> createModule opens ns taggedType unions records) - - Output.Ast modules +open Myriad.Core /// Myriad generator that provides a catamorphism for an algebraic data type. [] @@ -1817,4 +1752,69 @@ type ArgParserGenerator () = interface IMyriadGenerator with member _.ValidInputExtensions = [ ".fs" ] - member _.Generate (context : GeneratorContext) = ArgParserGenerator.generate context + member _.Generate (context : GeneratorContext) = + let ast, _ = + Ast.fromFilename context.InputFilename |> Async.RunSynchronously |> Array.head + + let types = + Ast.extractTypeDefn ast + |> List.groupBy (fst >> List.map _.idText >> String.concat ".") + |> List.map (fun (_, v) -> fst (List.head v), List.collect snd v) + + let opens = AstHelper.extractOpens ast + + let namespaceAndTypes = + types + |> List.collect (fun (ns, types) -> + let typeWithAttr = + types + |> List.choose (fun ty -> + match SynTypeDefn.getAttribute typeof.Name ty with + | None -> None + | Some attr -> + let arg = + match SynExpr.stripOptionalParen attr.ArgExpr with + | SynExpr.Const (SynConst.Bool value, _) -> value + | SynExpr.Const (SynConst.Unit, _) -> ArgParserAttribute.DefaultIsExtensionMethod + | arg -> + failwith + $"Unrecognised argument %+A{arg} to [<%s{nameof ArgParserAttribute}>]. Literals are not supported. Use `true` or `false` (or unit) only." + + let spec = + { + ExtensionMethods = arg + } + + Some (ty, spec) + ) + + typeWithAttr + |> List.map (fun taggedType -> + let unions, records, others = + (([], [], []), types) + ||> List.fold (fun + (unions, records, others) + (SynTypeDefn.SynTypeDefn (sci, repr, smd, _, _, _) as ty) -> + match repr with + | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (access, cases, _), _) -> + UnionType.OfUnion sci smd access cases :: unions, records, others + | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (access, fields, _), _) -> + unions, RecordType.OfRecord sci smd access fields :: records, others + | _ -> unions, records, ty :: others + ) + + if not others.IsEmpty then + failwith + $"Error: all types recursively defined together with an ArgParserGenerator type must be discriminated unions or records. %+A{others}" + + (ns, taggedType, unions, records) + ) + ) + + let modules = + namespaceAndTypes + |> List.map (fun (ns, taggedType, unions, records) -> + ArgParserGenerator.createModule opens ns taggedType unions records + ) + + Output.Ast modules diff --git a/WoofWare.Myriad.Plugins/CataGenerator.fs b/WoofWare.Myriad.Plugins/CataGenerator.fs index 4039cab..48de317 100644 --- a/WoofWare.Myriad.Plugins/CataGenerator.fs +++ b/WoofWare.Myriad.Plugins/CataGenerator.fs @@ -3,7 +3,6 @@ namespace WoofWare.Myriad.Plugins open Fantomas.FCS.Syntax open Fantomas.FCS.SyntaxTrivia open Fantomas.FCS.Xml -open Myriad.Core [] module internal CataGenerator = @@ -176,7 +175,7 @@ module internal CataGenerator = |> SynExpr.createLet [ SynBinding.Let ( - valData = SynValData.SynValData (None, SynValInfo.Empty, None), + valData = SynValData.SynValData (None, SynValInfo.empty, None), pattern = SynPat.tupleNoParen ( allArtificialTyparNames @@ -463,18 +462,39 @@ module internal CataGenerator = { SynFieldData.Type = field.Type Attrs = [] - Ident = None + Ident = field.Name } - |> SynField.make ) - SynUnionCase.Create (unionCase.Name, fields) + { + Name = unionCase.Name + XmlDoc = None + Access = None + Attributes = [] + Fields = fields + } + |> SynUnionCase.create ) let casesFromCases = recursiveCases analysis |> List.map (fun case -> - SynUnionCase.Create (case.Name, case.Fields |> List.map (fun field -> SynField.Create field.Type)) + { + UnionCase.Name = case.Name + XmlDoc = None + Access = None + Attributes = [] + Fields = + case.Fields + |> List.map (fun field -> + { + SynFieldData.Type = field.Type + Attrs = [] + Ident = field.Name + } + ) + } + |> SynUnionCase.create ) let cases = casesFromProcess @ casesFromCases @@ -539,8 +559,8 @@ module internal CataGenerator = |> List.map (fun case -> let arity = SynValInfo.SynValInfo ( - case.Fields |> List.map (fun field -> [ SynArgInfo.Empty ]), - SynArgInfo.Empty + case.Fields |> List.map (fun field -> [ SynArgInfo.empty ]), + SynArgInfo.empty ) (SynType.var generics.[analysis.GenericName.idText], List.rev case.FlattenedFields) @@ -852,9 +872,7 @@ module internal CataGenerator = else [] - SynMatchClause.create - (SynPat.CreateLongIdent (SynLongIdent.create unionCase.Match, matchLhs)) - matchBody + SynMatchClause.create (SynPat.identWithArgs unionCase.Match (SynArgPats.create matchLhs)) matchBody ) SynExpr.createMatch (SynExpr.createIdent "x") matchCases @@ -1059,7 +1077,7 @@ module internal CataGenerator = (SynExpr.CreateConst 0) (SynExpr.createLongIdent [ "instructions" ; "Count" ])) body - SynExpr.CreateTuple ( + SynExpr.tupleNoParen ( analysis |> List.map (fun unionAnalysis -> [ unionAnalysis.StackName ] |> SynExpr.createLongIdent') ) @@ -1103,7 +1121,7 @@ module internal CataGenerator = let modInfo = SynComponentInfo.create moduleName |> SynComponentInfo.withDocString ( - PreXmlDoc.Create $" Methods to perform a catamorphism over the type %s{parentName}" + PreXmlDoc.create $"Methods to perform a catamorphism over the type %s{parentName}" ) |> SynComponentInfo.addAttributes [ SynAttribute.requireQualifiedAccess ] @@ -1150,7 +1168,7 @@ module internal CataGenerator = [ for openStatement in opens do - yield SynModuleDecl.CreateOpen openStatement + yield SynModuleDecl.openAny openStatement yield! cataStructures yield cataRecord yield @@ -1162,53 +1180,7 @@ module internal CataGenerator = ] |> SynModuleOrNamespace.createNamespace ns - let generate (context : GeneratorContext) : Output = - let ast, _ = - Ast.fromFilename context.InputFilename |> Async.RunSynchronously |> Array.head - - let types = Ast.extractTypeDefn ast - - let opens = AstHelper.extractOpens ast - - let namespaceAndTypes = - types - |> List.choose (fun (ns, types) -> - let typeWithAttr = - types - |> List.tryPick (fun ty -> - match Ast.getAttribute ty with - | None -> None - | Some attr -> Some (attr.ArgExpr, ty) - ) - - match typeWithAttr with - | Some taggedType -> - let unions, records, others = - (([], [], []), types) - ||> List.fold (fun - (unions, records, others) - (SynTypeDefn.SynTypeDefn (_, repr, _, _, _, _) as ty) -> - match repr with - | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union _, _) -> - ty :: unions, records, others - | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record _, _) -> - unions, ty :: records, others - | _ -> unions, records, ty :: others - ) - - if not others.IsEmpty then - failwith - $"Error: all types recursively defined together with a CreateCatamorphism type must be discriminated unions or records. %+A{others}" - - Some (ns, taggedType, unions, records) - | _ -> None - ) - - let modules = - namespaceAndTypes - |> List.map (fun (ns, taggedType, unions, records) -> createModule opens ns taggedType unions records) - - Output.Ast modules +open Myriad.Core /// Myriad generator that provides a catamorphism for an algebraic data type. [] @@ -1217,4 +1189,52 @@ type CreateCatamorphismGenerator () = interface IMyriadGenerator with member _.ValidInputExtensions = [ ".fs" ] - member _.Generate (context : GeneratorContext) = CataGenerator.generate context + member _.Generate (context : GeneratorContext) = + let ast, _ = + Ast.fromFilename context.InputFilename |> Async.RunSynchronously |> Array.head + + let types = Ast.extractTypeDefn ast + + let opens = AstHelper.extractOpens ast + + let namespaceAndTypes = + types + |> List.choose (fun (ns, types) -> + let typeWithAttr = + types + |> List.tryPick (fun ty -> + match SynTypeDefn.getAttribute typeof.Name ty with + | None -> None + | Some attr -> Some (attr.ArgExpr, ty) + ) + + match typeWithAttr with + | Some taggedType -> + let unions, records, others = + (([], [], []), types) + ||> List.fold (fun + (unions, records, others) + (SynTypeDefn.SynTypeDefn (_, repr, _, _, _, _) as ty) -> + match repr with + | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union _, _) -> + ty :: unions, records, others + | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record _, _) -> + unions, ty :: records, others + | _ -> unions, records, ty :: others + ) + + if not others.IsEmpty then + failwith + $"Error: all types recursively defined together with a CreateCatamorphism type must be discriminated unions or records. %+A{others}" + + Some (ns, taggedType, unions, records) + | _ -> None + ) + + let modules = + namespaceAndTypes + |> List.map (fun (ns, taggedType, unions, records) -> + CataGenerator.createModule opens ns taggedType unions records + ) + + Output.Ast modules diff --git a/WoofWare.Myriad.Plugins/HttpClientGenerator.fs b/WoofWare.Myriad.Plugins/HttpClientGenerator.fs index 57cab3e..6b24d32 100644 --- a/WoofWare.Myriad.Plugins/HttpClientGenerator.fs +++ b/WoofWare.Myriad.Plugins/HttpClientGenerator.fs @@ -1008,7 +1008,7 @@ type HttpClientGenerator () = |> List.choose (fun (ns, types) -> types |> List.choose (fun typeDef -> - match Ast.getAttribute typeDef with + match SynTypeDefn.getAttribute typeof.Name typeDef with | None -> let name = SynTypeDefn.getName typeDef |> List.map _.idText |> String.concat "." diff --git a/WoofWare.Myriad.Plugins/JsonParseGenerator.fs b/WoofWare.Myriad.Plugins/JsonParseGenerator.fs index 14f5f36..9e0d134 100644 --- a/WoofWare.Myriad.Plugins/JsonParseGenerator.fs +++ b/WoofWare.Myriad.Plugins/JsonParseGenerator.fs @@ -727,7 +727,7 @@ type JsonParseGenerator () = |> List.choose (fun (ns, types) -> types |> List.choose (fun typeDef -> - match Ast.getAttribute typeDef with + match SynTypeDefn.getAttribute typeof.Name typeDef with | None -> let name = SynTypeDefn.getName typeDef |> List.map _.idText |> String.concat "." diff --git a/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs b/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs index 594c45a..e69d400 100644 --- a/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs +++ b/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs @@ -544,7 +544,7 @@ type JsonSerializeGenerator () = |> List.choose (fun (ns, types) -> types |> List.choose (fun typeDef -> - match Ast.getAttribute typeDef with + match SynTypeDefn.getAttribute typeof.Name typeDef with | None -> let name = SynTypeDefn.getName typeDef |> List.map _.idText |> String.concat "." diff --git a/WoofWare.Myriad.Plugins/RemoveOptionsGenerator.fs b/WoofWare.Myriad.Plugins/RemoveOptionsGenerator.fs index a2466de..94d8f94 100644 --- a/WoofWare.Myriad.Plugins/RemoveOptionsGenerator.fs +++ b/WoofWare.Myriad.Plugins/RemoveOptionsGenerator.fs @@ -150,7 +150,10 @@ type RemoveOptionsGenerator () = let namespaceAndRecords = records |> List.choose (fun (ns, types) -> - match types |> List.filter Ast.hasAttribute with + match + types + |> List.filter (SynTypeDefn.hasAttribute typeof.Name) + with | [] -> None | types -> let types = diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynArgInfo.fs b/WoofWare.Myriad.Plugins/SynExpr/SynArgInfo.fs new file mode 100644 index 0000000..afafbcb --- /dev/null +++ b/WoofWare.Myriad.Plugins/SynExpr/SynArgInfo.fs @@ -0,0 +1,7 @@ +namespace WoofWare.Myriad.Plugins + +open Fantomas.FCS.Syntax + +[] +module internal SynArgInfo = + let empty = SynArgInfo.SynArgInfo ([], false, None) diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynConst.fs b/WoofWare.Myriad.Plugins/SynExpr/SynConst.fs new file mode 100644 index 0000000..11d71ee --- /dev/null +++ b/WoofWare.Myriad.Plugins/SynExpr/SynConst.fs @@ -0,0 +1,10 @@ +namespace WoofWare.Myriad.Plugins + +open Fantomas.FCS.Syntax +open Fantomas.FCS.Text.Range + +[] +module internal SynConstExt = + type SynConst with + static member Create (s : string) : SynConst = + SynConst.String (s, SynStringKind.Regular, range0) diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynExpr.fs b/WoofWare.Myriad.Plugins/SynExpr/SynExpr.fs index 52f4221..ede3ad2 100644 --- a/WoofWare.Myriad.Plugins/SynExpr/SynExpr.fs +++ b/WoofWare.Myriad.Plugins/SynExpr/SynExpr.fs @@ -2,14 +2,13 @@ namespace WoofWare.Myriad.Plugins open Fantomas.FCS.Syntax open Fantomas.FCS.SyntaxTrivia -open Myriad.Core open Fantomas.FCS.Text.Range [] module internal SynExprExtensions = type SynExpr with static member CreateConst (s : string) : SynExpr = - SynExpr.Const (SynConst.String (s, SynStringKind.Regular, range0), range0) + SynExpr.Const (SynConst.Create s, range0) static member CreateConst () : SynExpr = SynExpr.Const (SynConst.Unit, range0) @@ -17,7 +16,13 @@ module internal SynExprExtensions = 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)) + SynExpr.App ( + ExprAtomicFlag.NonAtomic, + false, + SynExpr.Ident (Ident.create "char"), + SynExpr.CreateConst (int c), + range0 + ) |> fun e -> SynExpr.Paren (e, range0, Some range0, range0) static member CreateConst (i : int32) : SynExpr = @@ -27,15 +32,27 @@ module internal SynExprExtensions = module internal SynExpr = /// {f} {x} - let applyFunction (f : SynExpr) (x : SynExpr) : SynExpr = SynExpr.CreateApp (f, x) + let applyFunction (f : SynExpr) (x : SynExpr) : SynExpr = + SynExpr.App (ExprAtomicFlag.NonAtomic, false, f, x, range0) /// {f} {x} let inline applyTo (x : SynExpr) (f : SynExpr) : SynExpr = applyFunction f x + let inline private createAppInfix (f : SynExpr) (x : SynExpr) = + SynExpr.App (ExprAtomicFlag.NonAtomic, true, f, x, range0) + + let inline createLongIdent'' (ident : SynLongIdent) : SynExpr = + SynExpr.LongIdent (false, ident, None, range0) + + let inline createLongIdent' (ident : Ident list) : SynExpr = + createLongIdent'' (SynLongIdent.create ident) + + let inline createLongIdent (ident : string list) : SynExpr = + createLongIdent' (ident |> List.map Ident.create) + /// {expr} |> {func} let pipeThroughFunction (func : SynExpr) (expr : SynExpr) : SynExpr = - SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.pipe, expr) - |> applyTo func + createAppInfix (createLongIdent'' SynLongIdent.pipe) expr |> applyTo func /// if {cond} then {trueBranch} else {falseBranch} /// Note that this function puts the trueBranch last, for pipelining convenience: @@ -78,45 +95,23 @@ module internal SynExpr = /// {a} = {b} let equals (a : SynExpr) (b : SynExpr) = - SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.eq, a) |> applyTo b + createAppInfix (createLongIdent'' SynLongIdent.eq) a |> applyTo b /// {a} && {b} let booleanAnd (a : SynExpr) (b : SynExpr) = - SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.booleanAnd, a) - |> applyTo b + createAppInfix (createLongIdent'' SynLongIdent.booleanAnd) a |> applyTo b /// {a} || {b} let booleanOr (a : SynExpr) (b : SynExpr) = - SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.booleanOr, a) - |> applyTo b + createAppInfix (createLongIdent'' SynLongIdent.booleanOr) a |> applyTo b /// {a} + {b} let plus (a : SynExpr) (b : SynExpr) = - SynExpr.CreateAppInfix ( - SynExpr.CreateLongIdent ( - SynLongIdent.SynLongIdent ( - Ident.CreateLong "op_Addition", - [], - [ Some (IdentTrivia.OriginalNotation "+") ] - ) - ), - a - ) - |> applyTo b + createAppInfix (createLongIdent'' SynLongIdent.plus) a |> applyTo b /// {a} * {b} let times (a : SynExpr) (b : SynExpr) = - SynExpr.CreateAppInfix ( - SynExpr.CreateLongIdent ( - SynLongIdent.SynLongIdent ( - Ident.CreateLong "op_Multiply", - [], - [ Some (IdentTrivia.OriginalNotation "*") ] - ) - ), - a - ) - |> applyTo b + createAppInfix (createLongIdent'' SynLongIdent.times) a |> applyTo b let rec stripOptionalParen (expr : SynExpr) : SynExpr = match expr with @@ -172,7 +167,7 @@ module internal SynExpr = SynExpr.Lambda ( false, false, - SynSimplePats.Create [ SynSimplePat.CreateId (Ident.Create varName) ], + SynSimplePats.create [ SynSimplePat.createId (Ident.create varName) ], body, Some (parsedDataPat, body), range0, @@ -186,7 +181,7 @@ module internal SynExpr = SynExpr.Lambda ( false, false, - SynSimplePats.Create [], + SynSimplePats.create [], body, Some ([ SynPat.unit ], body), range0, @@ -200,12 +195,6 @@ module internal SynExpr = let inline createIdent' (i : Ident) : SynExpr = SynExpr.Ident i - let inline createLongIdent' (ident : Ident list) : SynExpr = - SynExpr.LongIdent (false, SynLongIdent.create ident, None, range0) - - let inline createLongIdent (ident : string list) : SynExpr = - createLongIdent' (ident |> List.map Ident.create) - let tupleNoParen (args : SynExpr list) : SynExpr = SynExpr.Tuple (false, args, List.replicate (args.Length - 1) range0, range0) @@ -332,7 +321,7 @@ module internal SynExpr = /// {ident} - {rhs} let minus (ident : SynLongIdent) (rhs : SynExpr) : SynExpr = - SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.sub, SynExpr.CreateLongIdent ident) + createAppInfix (createLongIdent'' SynLongIdent.sub) (createLongIdent'' ident) |> applyTo rhs /// {ident} - {n} @@ -340,26 +329,24 @@ module internal SynExpr = /// {y} > {x} let greaterThan (x : SynExpr) (y : SynExpr) : SynExpr = - SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.gt, y) |> applyTo x + createAppInfix (createLongIdent'' SynLongIdent.gt) y |> applyTo x /// {y} < {x} let lessThan (x : SynExpr) (y : SynExpr) : SynExpr = - SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.lt, y) |> applyTo x + createAppInfix (createLongIdent'' SynLongIdent.lt) y |> applyTo x /// {y} >= {x} let greaterThanOrEqual (x : SynExpr) (y : SynExpr) : SynExpr = - SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.geq, y) - |> applyTo x + createAppInfix (createLongIdent'' SynLongIdent.geq) y |> applyTo x /// {y} <= {x} let lessThanOrEqual (x : SynExpr) (y : SynExpr) : SynExpr = - SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.leq, y) - |> applyTo x + createAppInfix (createLongIdent'' SynLongIdent.leq) y |> applyTo x /// {x} :: {y} let listCons (x : SynExpr) (y : SynExpr) : SynExpr = - SynExpr.CreateAppInfix ( - SynExpr.LongIdent ( + createAppInfix + (SynExpr.LongIdent ( false, SynLongIdent.SynLongIdent ( [ Ident.create "op_ColonColon" ], @@ -368,9 +355,8 @@ module internal SynExpr = ), None, range0 - ), - tupleNoParen [ x ; y ] - ) + )) + (tupleNoParen [ x ; y ]) |> paren let assign (lhs : SynLongIdent) (rhs : SynExpr) : SynExpr = SynExpr.LongIdentSet (lhs, rhs, range0) diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynLongIdent.fs b/WoofWare.Myriad.Plugins/SynExpr/SynLongIdent.fs index 39f1769..de86308 100644 --- a/WoofWare.Myriad.Plugins/SynExpr/SynLongIdent.fs +++ b/WoofWare.Myriad.Plugins/SynExpr/SynLongIdent.fs @@ -39,6 +39,12 @@ module internal SynLongIdent = let booleanOr = SynLongIdent.SynLongIdent ([ Ident.create "op_BooleanOr" ], [], [ Some (IdentTrivia.OriginalNotation "||") ]) + let plus = + SynLongIdent.SynLongIdent ([ Ident.create "op_Addition" ], [], [ Some (IdentTrivia.OriginalNotation "+") ]) + + let times = + SynLongIdent.SynLongIdent ([ Ident.create "op_Multiply" ], [], [ Some (IdentTrivia.OriginalNotation "*") ]) + let pipe = SynLongIdent.SynLongIdent ([ Ident.create "op_PipeRight" ], [], [ Some (IdentTrivia.OriginalNotation "|>") ]) diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynSimplePat.fs b/WoofWare.Myriad.Plugins/SynExpr/SynSimplePat.fs new file mode 100644 index 0000000..5f1c475 --- /dev/null +++ b/WoofWare.Myriad.Plugins/SynExpr/SynSimplePat.fs @@ -0,0 +1,10 @@ +namespace WoofWare.Myriad.Plugins + +open Fantomas.FCS.Syntax +open Fantomas.FCS.Text.Range + +[] +module internal SynSimplePat = + + let createId (id : Ident) : SynSimplePat = + SynSimplePat.Id (id, None, false, false, false, range0) diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynSimplePats.fs b/WoofWare.Myriad.Plugins/SynExpr/SynSimplePats.fs new file mode 100644 index 0000000..4714a0b --- /dev/null +++ b/WoofWare.Myriad.Plugins/SynExpr/SynSimplePats.fs @@ -0,0 +1,12 @@ +namespace WoofWare.Myriad.Plugins + +open Fantomas.FCS.Syntax +open Fantomas.FCS.Text.Range + +[] +module internal SynSimplePats = + + let create (pats : SynSimplePat list) : SynSimplePats = + match pats with + | [] -> SynSimplePats.SimplePats ([], [], range0) + | pats -> SynSimplePats.SimplePats (pats, List.replicate (pats.Length - 1) range0, range0) diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynTypeDefn.fs b/WoofWare.Myriad.Plugins/SynExpr/SynTypeDefn.fs index 529352a..71eb8c0 100644 --- a/WoofWare.Myriad.Plugins/SynExpr/SynTypeDefn.fs +++ b/WoofWare.Myriad.Plugins/SynExpr/SynTypeDefn.fs @@ -29,3 +29,18 @@ module internal SynTypeDefn = let getName (defn : SynTypeDefn) : LongIdent = match defn with | SynTypeDefn (SynComponentInfo.SynComponentInfo (_, _, _, id, _, _, _, _), _, _, _, _, _) -> id + + let getAttribute (attrName : string) (defn : SynTypeDefn) : SynAttribute option = + match defn with + | SynTypeDefn (SynComponentInfo.SynComponentInfo (attrs, _, _, _, _, _, _, _), _, _, _, _, _) -> + attrs + |> List.collect (fun a -> a.Attributes) + |> List.tryFind (fun i -> + match i.TypeName with + | SynLongIdent.SynLongIdent (id, _, _) -> + let name = List.last(id).idText + name = attrName || name + "Attribute" = attrName + ) + + let hasAttribute (attrName : string) (defn : SynTypeDefn) : bool = + getAttribute attrName defn |> Option.isSome diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynUnionCase.fs b/WoofWare.Myriad.Plugins/SynExpr/SynUnionCase.fs index 9bf1dfc..85ee398 100644 --- a/WoofWare.Myriad.Plugins/SynExpr/SynUnionCase.fs +++ b/WoofWare.Myriad.Plugins/SynExpr/SynUnionCase.fs @@ -23,14 +23,14 @@ type UnionCase<'ident> = [] module internal SynUnionCase = - let create (case : UnionCase) : SynUnionCase = + let create (case : UnionCase) : SynUnionCase = let fields = case.Fields |> List.map (fun field -> SynField.SynField ( SynAttributes.ofAttrs field.Attrs, false, - Some field.Ident, + field.Ident, field.Type, false, PreXmlDoc.Empty, diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynValInfo.fs b/WoofWare.Myriad.Plugins/SynExpr/SynValInfo.fs new file mode 100644 index 0000000..0848db0 --- /dev/null +++ b/WoofWare.Myriad.Plugins/SynExpr/SynValInfo.fs @@ -0,0 +1,7 @@ +namespace WoofWare.Myriad.Plugins + +open Fantomas.FCS.Syntax + +[] +module internal SynValInfo = + let empty = SynValInfo.SynValInfo ([], SynArgInfo.empty) diff --git a/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj b/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj index 9af3bb2..1f04d67 100644 --- a/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj +++ b/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj @@ -29,8 +29,13 @@ + + + + +