From 3ea1c7ab79a89bdcd04abb2bfc62f85ff2bfcb7c Mon Sep 17 00:00:00 2001 From: Patrick Stevens <3138005+Smaug123@users.noreply.github.com> Date: Sat, 17 Feb 2024 23:16:54 +0000 Subject: [PATCH] Add catamorphism generator (#97) --- ConsumePlugin/Catamorphism.fs | 22 + ConsumePlugin/ConsumePlugin.fsproj | 8 + ConsumePlugin/FSharpForFunAndProfitCata.fs | 52 + ConsumePlugin/GeneratedCatamorphism.fs | 134 ++ ConsumePlugin/GeneratedFileSystem.fs | 152 ++ README.md | 73 + .../Attributes.fs | 8 + .../SurfaceBaseline.txt | 2 + .../version.json | 4 +- .../TestCataGenerator/TestCataGenerator.fs | 47 + .../TestCataGenerator/TestDirectory.fs | 37 + .../TestCataGenerator/TestGift.fs | 99 ++ .../WoofWare.Myriad.Plugins.Test.fsproj | 8 +- WoofWare.Myriad.Plugins/AstHelper.fs | 50 + WoofWare.Myriad.Plugins/CataGenerator.fs | 1511 +++++++++++++++++ .../HttpClientGenerator.fs | 10 +- WoofWare.Myriad.Plugins/Ident.fs | 14 + WoofWare.Myriad.Plugins/SurfaceBaseline.txt | 2 + WoofWare.Myriad.Plugins/SynExpr.fs | 36 + .../WoofWare.Myriad.Plugins.fsproj | 2 + WoofWare.Myriad.Plugins/version.json | 4 +- 21 files changed, 2259 insertions(+), 16 deletions(-) create mode 100644 ConsumePlugin/Catamorphism.fs create mode 100644 ConsumePlugin/FSharpForFunAndProfitCata.fs create mode 100644 ConsumePlugin/GeneratedCatamorphism.fs create mode 100644 ConsumePlugin/GeneratedFileSystem.fs create mode 100644 WoofWare.Myriad.Plugins.Test/TestCataGenerator/TestCataGenerator.fs create mode 100644 WoofWare.Myriad.Plugins.Test/TestCataGenerator/TestDirectory.fs create mode 100644 WoofWare.Myriad.Plugins.Test/TestCataGenerator/TestGift.fs create mode 100644 WoofWare.Myriad.Plugins/CataGenerator.fs create mode 100644 WoofWare.Myriad.Plugins/Ident.fs diff --git a/ConsumePlugin/Catamorphism.fs b/ConsumePlugin/Catamorphism.fs new file mode 100644 index 0000000..ab271e1 --- /dev/null +++ b/ConsumePlugin/Catamorphism.fs @@ -0,0 +1,22 @@ +namespace ConsumePlugin + +open WoofWare.Myriad.Plugins + +type Const = + | Int of int + | String of string + +type PairOpKind = + | NormalSeq + | ThenDoSeq + +[] +type Tree = + | Const of Const + | Pair of Tree * Tree * PairOpKind + | Sequential of Tree list + | Builder of Tree * TreeBuilder + +and TreeBuilder = + | Child of TreeBuilder + | Parent of Tree diff --git a/ConsumePlugin/ConsumePlugin.fsproj b/ConsumePlugin/ConsumePlugin.fsproj index e24b828..67dc38a 100644 --- a/ConsumePlugin/ConsumePlugin.fsproj +++ b/ConsumePlugin/ConsumePlugin.fsproj @@ -39,6 +39,14 @@ SerializationAndDeserialization.fs + + + Catamorphism.fs + + + + FSharpForFunAndProfitCata.fs + diff --git a/ConsumePlugin/FSharpForFunAndProfitCata.fs b/ConsumePlugin/FSharpForFunAndProfitCata.fs new file mode 100644 index 0000000..e8bf751 --- /dev/null +++ b/ConsumePlugin/FSharpForFunAndProfitCata.fs @@ -0,0 +1,52 @@ +namespace ConsumePlugin + +open WoofWare.Myriad.Plugins + +type File = + { + Name : string + FileSize : int + } + +type Directory = + { + Name : string + DirSize : int + Contents : FileSystemItem list + } + +and [] FileSystemItem = + | Directory of Directory + | File of File + +type Book = + { + title : string + price : decimal + } + +type ChocolateType = + | Dark + | Milk + | SeventyPercent + +type Chocolate = + { + chocType : ChocolateType + price : decimal + } + + override this.ToString () = this.chocType.ToString () + +type WrappingPaperStyle = + | HappyBirthday + | HappyHolidays + | SolidColor + +[] +type Gift = + | Book of Book + | Chocolate of Chocolate + | Wrapped of Gift * WrappingPaperStyle + | Boxed of Gift + | WithACard of Gift * message : string diff --git a/ConsumePlugin/GeneratedCatamorphism.fs b/ConsumePlugin/GeneratedCatamorphism.fs new file mode 100644 index 0000000..369e1c6 --- /dev/null +++ b/ConsumePlugin/GeneratedCatamorphism.fs @@ -0,0 +1,134 @@ +//------------------------------------------------------------------------------ +// This code was generated by myriad. +// Changes to this file will be lost when the code is regenerated. +//------------------------------------------------------------------------------ + + + + + +namespace ConsumePlugin + +open WoofWare.Myriad.Plugins + +/// Description of how to combine cases during a fold +type TreeBuilderCataCase<'TreeBuilder, 'Tree> = + /// How to operate on the Child case + abstract Child : 'TreeBuilder -> 'TreeBuilder + /// How to operate on the Parent case + abstract Parent : 'Tree -> 'TreeBuilder + +/// Description of how to combine cases during a fold +type TreeCataCase<'TreeBuilder, 'Tree> = + /// How to operate on the Const case + abstract Const : Const -> 'Tree + /// How to operate on the Pair case + abstract Pair : 'Tree -> 'Tree -> PairOpKind -> 'Tree + /// How to operate on the Sequential case + abstract Sequential : 'Tree list -> 'Tree + /// How to operate on the Builder case + abstract Builder : 'Tree -> 'TreeBuilder -> 'Tree + +/// Specifies how to perform a fold (catamorphism) over the type Tree and its friends. +type TreeCata<'TreeBuilder, 'Tree> = + { + /// How to perform a fold (catamorphism) over the type TreeBuilder + TreeBuilder : TreeBuilderCataCase<'TreeBuilder, 'Tree> + /// How to perform a fold (catamorphism) over the type Tree + Tree : TreeCataCase<'TreeBuilder, 'Tree> + } + +/// Methods to perform a catamorphism over the type Tree +[] +module TreeCata = + [] + type private Instruction = + | Process__TreeBuilder of TreeBuilder + | Process__Tree of Tree + | TreeBuilder_Child + | TreeBuilder_Parent + | Tree_Pair of PairOpKind + | Tree_Sequential of int + | Tree_Builder + + let private loop (cata : TreeCata<_, _>) (instructions : ResizeArray) = + let treeStack = ResizeArray () + let treeBuilderStack = ResizeArray () + + while instructions.Count > 0 do + let currentInstruction = instructions.[instructions.Count - 1] + instructions.RemoveAt (instructions.Count - 1) + + match currentInstruction with + | Instruction.Process__TreeBuilder x -> + match x with + | TreeBuilder.Child (arg0_0) -> + instructions.Add Instruction.TreeBuilder_Child + instructions.Add (Instruction.Process__TreeBuilder arg0_0) + | TreeBuilder.Parent (arg0_0) -> + instructions.Add Instruction.TreeBuilder_Parent + instructions.Add (Instruction.Process__Tree arg0_0) + | Instruction.Process__Tree x -> + match x with + | Tree.Const (arg0_0) -> cata.Tree.Const arg0_0 |> treeStack.Add + | Tree.Pair (arg0_0, arg1_0, arg2_0) -> + instructions.Add (Instruction.Tree_Pair (arg2_0)) + instructions.Add (Instruction.Process__Tree arg0_0) + instructions.Add (Instruction.Process__Tree arg1_0) + | Tree.Sequential (arg0_0) -> + instructions.Add (Instruction.Tree_Sequential ((List.length arg0_0))) + + for elt in arg0_0 do + instructions.Add (Instruction.Process__Tree elt) + | Tree.Builder (arg0_0, arg1_0) -> + instructions.Add Instruction.Tree_Builder + instructions.Add (Instruction.Process__Tree arg0_0) + instructions.Add (Instruction.Process__TreeBuilder arg1_0) + | Instruction.TreeBuilder_Child -> + let arg0_0 = treeBuilderStack.[treeBuilderStack.Count - 1] + treeBuilderStack.RemoveAt (treeBuilderStack.Count - 1) + cata.TreeBuilder.Child arg0_0 |> treeBuilderStack.Add + | Instruction.TreeBuilder_Parent -> + let arg0_0 = treeStack.[treeStack.Count - 1] + treeStack.RemoveAt (treeStack.Count - 1) + cata.TreeBuilder.Parent arg0_0 |> treeBuilderStack.Add + | Instruction.Tree_Pair (arg2_0) -> + let arg0_0 = treeStack.[treeStack.Count - 1] + treeStack.RemoveAt (treeStack.Count - 1) + let arg1_0 = treeStack.[treeStack.Count - 1] + treeStack.RemoveAt (treeStack.Count - 1) + cata.Tree.Pair arg0_0 arg1_0 arg2_0 |> treeStack.Add + | Instruction.Tree_Sequential (arg0_0) -> + let arg0_0_len = arg0_0 + + let arg0_0 = + seq { + for i = treeStack.Count - 1 downto treeStack.Count - arg0_0 do + yield treeStack.[i] + } + |> Seq.toList + + treeStack.RemoveRange (treeStack.Count - arg0_0_len, arg0_0_len) + cata.Tree.Sequential arg0_0 |> treeStack.Add + | Instruction.Tree_Builder -> + let arg0_0 = treeStack.[treeStack.Count - 1] + treeStack.RemoveAt (treeStack.Count - 1) + let arg1_0 = treeBuilderStack.[treeBuilderStack.Count - 1] + treeBuilderStack.RemoveAt (treeBuilderStack.Count - 1) + cata.Tree.Builder arg0_0 arg1_0 |> treeStack.Add + + treeBuilderStack, treeStack + + /// Execute the catamorphism. + let runTreeBuilder (cata : TreeCata<'TreeBuilderRet, 'TreeRet>) (x : TreeBuilder) : 'TreeBuilderRet = + let instructions = ResizeArray () + instructions.Add (Instruction.Process__TreeBuilder x) + let treeBuilderRetStack, treeRetStack = loop cata instructions + Seq.exactlyOne treeBuilderRetStack + + /// Execute the catamorphism. + let runTree (cata : TreeCata<'TreeBuilderRet, 'TreeRet>) (x : Tree) : 'TreeRet = + let instructions = ResizeArray () + instructions.Add (Instruction.Process__Tree x) + let treeBuilderRetStack, treeRetStack = loop cata instructions + Seq.exactlyOne treeRetStack diff --git a/ConsumePlugin/GeneratedFileSystem.fs b/ConsumePlugin/GeneratedFileSystem.fs new file mode 100644 index 0000000..7a472c2 --- /dev/null +++ b/ConsumePlugin/GeneratedFileSystem.fs @@ -0,0 +1,152 @@ +//------------------------------------------------------------------------------ +// This code was generated by myriad. +// Changes to this file will be lost when the code is regenerated. +//------------------------------------------------------------------------------ + + + + + +namespace ConsumePlugin + +open WoofWare.Myriad.Plugins + +/// Description of how to combine cases during a fold +type FileSystemItemCataCase<'FileSystemItem> = + /// How to operate on the Directory case + abstract Directory : name : string -> dirSize : int -> contents : 'FileSystemItem list -> 'FileSystemItem + /// How to operate on the File case + abstract File : File -> 'FileSystemItem + +/// Specifies how to perform a fold (catamorphism) over the type FileSystemItem and its friends. +type FileSystemCata<'FileSystemItem> = + { + /// How to perform a fold (catamorphism) over the type FileSystemItem + FileSystemItem : FileSystemItemCataCase<'FileSystemItem> + } + +/// Methods to perform a catamorphism over the type FileSystemItem +[] +module FileSystemItemCata = + [] + type private Instruction = + | Process__FileSystemItem of FileSystemItem + | FileSystemItem_Directory of string * int * int + + let private loop (cata : FileSystemCata<_>) (instructions : ResizeArray) = + let fileSystemItemStack = ResizeArray () + + while instructions.Count > 0 do + let currentInstruction = instructions.[instructions.Count - 1] + instructions.RemoveAt (instructions.Count - 1) + + match currentInstruction with + | Instruction.Process__FileSystemItem x -> + match x with + | FileSystemItem.Directory ({ + Name = name + DirSize = dirSize + Contents = contents + }) -> + instructions.Add (Instruction.FileSystemItem_Directory (name, dirSize, (List.length contents))) + + for elt in contents do + instructions.Add (Instruction.Process__FileSystemItem elt) + | FileSystemItem.File (arg0_0) -> cata.FileSystemItem.File arg0_0 |> fileSystemItemStack.Add + | Instruction.FileSystemItem_Directory (name, dirSize, contents) -> + let contents_len = contents + + let contents = + seq { + for i = fileSystemItemStack.Count - 1 downto fileSystemItemStack.Count - contents do + yield fileSystemItemStack.[i] + } + |> Seq.toList + + fileSystemItemStack.RemoveRange (fileSystemItemStack.Count - contents_len, contents_len) + cata.FileSystemItem.Directory name dirSize contents |> fileSystemItemStack.Add + + fileSystemItemStack + + /// Execute the catamorphism. + let runFileSystemItem (cata : FileSystemCata<'FileSystemItemRet>) (x : FileSystemItem) : 'FileSystemItemRet = + let instructions = ResizeArray () + instructions.Add (Instruction.Process__FileSystemItem x) + let fileSystemItemRetStack = loop cata instructions + Seq.exactlyOne fileSystemItemRetStack +namespace ConsumePlugin + +open WoofWare.Myriad.Plugins + +/// Description of how to combine cases during a fold +type GiftCataCase<'Gift> = + /// How to operate on the Book case + abstract Book : Book -> 'Gift + /// How to operate on the Chocolate case + abstract Chocolate : Chocolate -> 'Gift + /// How to operate on the Wrapped case + abstract Wrapped : 'Gift -> WrappingPaperStyle -> 'Gift + /// How to operate on the Boxed case + abstract Boxed : 'Gift -> 'Gift + /// How to operate on the WithACard case + abstract WithACard : 'Gift -> message : string -> 'Gift + +/// Specifies how to perform a fold (catamorphism) over the type Gift and its friends. +type GiftCata<'Gift> = + { + /// How to perform a fold (catamorphism) over the type Gift + Gift : GiftCataCase<'Gift> + } + +/// Methods to perform a catamorphism over the type Gift +[] +module GiftCata = + [] + type private Instruction = + | Process__Gift of Gift + | Gift_Wrapped of WrappingPaperStyle + | Gift_Boxed + | Gift_WithACard of string + + let private loop (cata : GiftCata<_>) (instructions : ResizeArray) = + let giftStack = ResizeArray () + + while instructions.Count > 0 do + let currentInstruction = instructions.[instructions.Count - 1] + instructions.RemoveAt (instructions.Count - 1) + + match currentInstruction with + | Instruction.Process__Gift x -> + match x with + | Gift.Book (arg0_0) -> cata.Gift.Book arg0_0 |> giftStack.Add + | Gift.Chocolate (arg0_0) -> cata.Gift.Chocolate arg0_0 |> giftStack.Add + | Gift.Wrapped (arg0_0, arg1_0) -> + instructions.Add (Instruction.Gift_Wrapped (arg1_0)) + instructions.Add (Instruction.Process__Gift arg0_0) + | Gift.Boxed (arg0_0) -> + instructions.Add Instruction.Gift_Boxed + instructions.Add (Instruction.Process__Gift arg0_0) + | Gift.WithACard (arg0_0, message) -> + instructions.Add (Instruction.Gift_WithACard (message)) + instructions.Add (Instruction.Process__Gift arg0_0) + | Instruction.Gift_Wrapped (arg1_0) -> + let arg0_0 = giftStack.[giftStack.Count - 1] + giftStack.RemoveAt (giftStack.Count - 1) + cata.Gift.Wrapped arg0_0 arg1_0 |> giftStack.Add + | Instruction.Gift_Boxed -> + let arg0_0 = giftStack.[giftStack.Count - 1] + giftStack.RemoveAt (giftStack.Count - 1) + cata.Gift.Boxed arg0_0 |> giftStack.Add + | Instruction.Gift_WithACard (message) -> + let arg0_0 = giftStack.[giftStack.Count - 1] + giftStack.RemoveAt (giftStack.Count - 1) + cata.Gift.WithACard arg0_0 message |> giftStack.Add + + giftStack + + /// Execute the catamorphism. + let runGift (cata : GiftCata<'GiftRet>) (x : Gift) : 'GiftRet = + let instructions = ResizeArray () + instructions.Add (Instruction.Process__Gift x) + let giftRetStack = loop cata instructions + Seq.exactlyOne giftRetStack diff --git a/README.md b/README.md index 636fcb1..e598b47 100644 --- a/README.md +++ b/README.md @@ -23,6 +23,7 @@ Currently implemented: * `RemoveOptions` (to strip `option` modifiers from a type). * `HttpClient` (to stamp out a [RestEase](https://github.com/canton7/RestEase)-style HTTP client). * `GenerateMock` (to stamp out a record type corresponding to an interface). +* `CreateCatamorphism` (to stamp out a non-stack-overflowing [catamorphism](https://fsharpforfunandprofit.com/posts/recursive-types-and-folds/) for a discriminated union). ## `JsonParse` @@ -326,6 +327,78 @@ thereby allowing the programmer to use F#'s record-update syntax. * You may supply an `isInternal : bool` argument to the attribute. By default, we make the resulting record type at most internal (never public), since this is intended only to be used in tests; but you can instead make it public with `[]`. +## `CreateCatamorphism` + +Takes a collection of mutually recursive discriminated unions: + +```fsharp +[] +type Expr = + | Const of Const + | Pair of Expr * Expr * PairOpKind + | Sequential of Expr list + | Builder of Expr * ExprBuilder + +and ExprBuilder = + | Child of ExprBuilder + | Parent of Expr +``` + +and stamps out a type like this: +```fsharp +type ExprCata<'Expr, 'ExprBuilder> = + abstract Const : Const -> 'Expr + abstract Pair : 'Expr -> 'Expr -> PairOpKind -> 'Expr + abstract Sequential : 'Expr list -> 'Expr + abstract Builder : 'Expr -> 'ExprBuilder -> 'Expr + +type ExprBuilderCata<'Expr, 'ExprBuilder> = + abstract Child : 'ExprBuilder -> 'ExprBuilder + abstract Parent : 'Expr -> 'ExprBuilder + +type Cata<'Expr, 'ExprBuilder> = + { + Expr : ExprCata<'Expr, 'ExprBuilder> + ExprBuilder : ExprBuilderCata<'Expr, 'ExprBuilder> + } + +[] +module ExprCata = + let runExpr (cata : Cata<'ExprRet, 'ExprBuilderRet>) (x : Expr) : 'ExprRet = + failwith "this is implemented" + + let runExprBuilder (cata : Cata<'ExprRet, 'ExprBuilderRet>) (x : ExprBuilder) : 'ExprBuilderRet = + failwith "this is implemented" +``` + +### What's the point? +Recursing over a tree is not easy to get right, especially if you want to avoid stack overflows. +Instead of writing the recursion many times, it's better to do it once, +and then each time you only plug in what you want to do. + +### Features + +* Mutually recursive DUs are supported (as in the example above). + Every DU in a recursive `type Foo... and Bar...` knot will be given an appropriate cata, as long as any one of those DUs has the `[]` attribute. +* There is *limited* support for records and for lists. + +### Limitations + +**I am not at all convinced of the correctness of this generator**, and I know it is very incomplete (in the sense that there are many possible DUs you could write for which the generator will bail out). +I *strongly* recommend implementing the identity catamorphism for your type and using property-based tests ([as I do](./WoofWare.Myriad.Plugins.Test/TestCataGenerator/TestDirectory.fs)) to assert that the correct thing happens. +Feel free to raise GitHub issues with code I can copy-paste to reproduce a case where the wrong thing happens (though I can't promise to look at them). + +* This is a particularly half-baked generator which has so far seen no real-world use. + It likely has a bunch of [80/20](https://en.wikipedia.org/wiki/Pareto_principle) low-hanging fruit remaining, but it also likely has impossible problems to solve which I don't know about yet. +* Only a very few kinds of DU field are currently implemented. + For example, this generator can't see through an interface (e.g. the kind of interface one would use to implement the [crate pattern](https://www.patrickstevens.co.uk/posts/2021-10-19-crates/) to represent a [GADT](https://en.wikipedia.org/wiki/Generalized_algebraic_data_type)), + so the generated cata will simply grant you access to the interface (rather than attempting to descend into it to discover recursive references). + You can't nest lists deeply. All sorts of other cases are unaddressed. +* This generator does not try to solve the "exponential diamond dependency" problem. + If you have a case of the form `type Expr = | Branch of Expr * Expr`, the cata will walk into both `Expr`s separately. + If the `Expr`s happen to be equal, the cata will nevertheless traverse them individually (that is, it will traverse the same `Expr` twice). + Your type may represent a [DAG](https://en.wikipedia.org/wiki/Directed_acyclic_graph), but we will always effectively expand it into a tree of paths and operate on each of the exponentially-many paths. + # Detailed examples See the tests. diff --git a/WoofWare.Myriad.Plugins.Attributes/Attributes.fs b/WoofWare.Myriad.Plugins.Attributes/Attributes.fs index b39bf83..dce93de 100644 --- a/WoofWare.Myriad.Plugins.Attributes/Attributes.fs +++ b/WoofWare.Myriad.Plugins.Attributes/Attributes.fs @@ -62,3 +62,11 @@ type JsonParseAttribute (isExtensionMethod : bool) = /// i.e. to stamp out HTTP REST clients from interfaces defining the API. type HttpClientAttribute () = inherit Attribute () + +/// Attribute indicating a DU type to which the "create catamorphism" Myriad +/// generator should apply during build. +/// Supply the `typeName` for the name of the record type we will generate, which contains +/// all the catas required; for example, "MyThing" would generate: +/// type MyThing<'a, 'b> = { Du1 : Du1Cata<'a, 'b> ; Du2 : Du2Cata<'a, 'b> }. +type CreateCatamorphismAttribute (typeName : string) = + inherit Attribute () diff --git a/WoofWare.Myriad.Plugins.Attributes/SurfaceBaseline.txt b/WoofWare.Myriad.Plugins.Attributes/SurfaceBaseline.txt index c98a9d4..77f474a 100644 --- a/WoofWare.Myriad.Plugins.Attributes/SurfaceBaseline.txt +++ b/WoofWare.Myriad.Plugins.Attributes/SurfaceBaseline.txt @@ -1,3 +1,5 @@ +WoofWare.Myriad.Plugins.CreateCatamorphismAttribute inherit System.Attribute +WoofWare.Myriad.Plugins.CreateCatamorphismAttribute..ctor [constructor]: string WoofWare.Myriad.Plugins.GenerateMockAttribute inherit System.Attribute WoofWare.Myriad.Plugins.GenerateMockAttribute..ctor [constructor]: bool WoofWare.Myriad.Plugins.GenerateMockAttribute..ctor [constructor]: unit diff --git a/WoofWare.Myriad.Plugins.Attributes/version.json b/WoofWare.Myriad.Plugins.Attributes/version.json index a2ebf80..70765f7 100644 --- a/WoofWare.Myriad.Plugins.Attributes/version.json +++ b/WoofWare.Myriad.Plugins.Attributes/version.json @@ -1,7 +1,7 @@ { - "version": "2.1", + "version": "2.2", "publicReleaseRefSpec": [ "^refs/heads/main$" ], "pathFilters": null -} \ No newline at end of file +} diff --git a/WoofWare.Myriad.Plugins.Test/TestCataGenerator/TestCataGenerator.fs b/WoofWare.Myriad.Plugins.Test/TestCataGenerator/TestCataGenerator.fs new file mode 100644 index 0000000..8516b68 --- /dev/null +++ b/WoofWare.Myriad.Plugins.Test/TestCataGenerator/TestCataGenerator.fs @@ -0,0 +1,47 @@ +namespace WoofWare.Myriad.Plugins.Test + +open System.Threading +open NUnit.Framework +open FsUnitTyped +open ConsumePlugin +open FsCheck + +[] +module TestCataGenerator = + let idCata : TreeCata<_, _> = + { + Tree = + { new TreeCataCase<_, _> with + member _.Const x = Const x + member _.Pair x y z = Pair (x, y, z) + member _.Sequential xs = Sequential xs + member _.Builder x b = Builder (x, b) + } + TreeBuilder = + { new TreeBuilderCataCase<_, _> with + member _.Child x = Child x + member _.Parent x = Parent x + } + } + + [] + let ``Example`` () = + let x = + Tree.Pair (Tree.Const (Const.Int 0), Tree.Const (Const.String ""), PairOpKind.ThenDoSeq) + + TreeCata.runTree idCata x |> shouldEqual x + + + [] + let ``Cata works`` () = + let builderCases = ref 0 + + let property (x : Tree) = + match x with + | Tree.Builder _ -> Interlocked.Increment builderCases |> ignore + | _ -> () + + TreeCata.runTree idCata x = x + + Check.QuickThrowOnFailure property + builderCases.Value |> shouldBeGreaterThan 10 diff --git a/WoofWare.Myriad.Plugins.Test/TestCataGenerator/TestDirectory.fs b/WoofWare.Myriad.Plugins.Test/TestCataGenerator/TestDirectory.fs new file mode 100644 index 0000000..5168791 --- /dev/null +++ b/WoofWare.Myriad.Plugins.Test/TestCataGenerator/TestDirectory.fs @@ -0,0 +1,37 @@ +namespace WoofWare.Myriad.Plugins.Test + +open NUnit.Framework +open ConsumePlugin +open FsCheck + +[] +module TestDirectory = + let idCata : FileSystemCata<_> = + { + FileSystemItem = + { new FileSystemItemCataCase<_> with + member _.File file = FileSystemItem.File file + + member _.Directory name dirSize results = + FileSystemItem.Directory + { + Name = name + DirSize = dirSize + Contents = results + } + } + + } + + // Note: this file is preserved as an example of writing an identity cata. + // Don't add anything else to this file, because that will muddy the example. + + [] + let ``Cata works`` () = + let property (x : FileSystemItem) = + FileSystemItemCata.runFileSystemItem idCata x = x + + Check.QuickThrowOnFailure property + +// Note: this file is preserved as an example of writing an identity cata. +// Don't add anything else to this file, because that will muddy the example. diff --git a/WoofWare.Myriad.Plugins.Test/TestCataGenerator/TestGift.fs b/WoofWare.Myriad.Plugins.Test/TestCataGenerator/TestGift.fs new file mode 100644 index 0000000..21c6213 --- /dev/null +++ b/WoofWare.Myriad.Plugins.Test/TestCataGenerator/TestGift.fs @@ -0,0 +1,99 @@ +namespace WoofWare.Myriad.Plugins.Test + +open NUnit.Framework +open ConsumePlugin +open FsCheck +open FsUnitTyped + +[] +module TestGift = + + let idCata : GiftCata<_> = + { + Gift = + { new GiftCataCase<_> with + member _.Book b = Gift.Book b + member _.Boxed g = Gift.Boxed g + member _.Chocolate g = Gift.Chocolate g + member _.WithACard g message = Gift.WithACard (g, message) + member _.Wrapped g paper = Gift.Wrapped (g, paper) + } + } + + let totalCostCata : GiftCata<_> = + { + Gift = + { new GiftCataCase<_> with + member _.Book b = b.price + member _.Boxed g = g + 1.0m + member _.Chocolate c = c.price + member _.WithACard g message = g + 2.0m + member _.Wrapped g paper = g + 0.5m + } + } + + let descriptionCata : GiftCata<_> = + { + Gift = + { new GiftCataCase<_> with + member _.Book b = b.title + member _.Boxed g = $"%s{g} in a box" + member _.Chocolate c = $"%O{c} chocolate" + + member _.WithACard g message = + $"%s{g} with a card saying '%s{message}'" + + member _.Wrapped g paper = $"%s{g} wrapped in %A{paper} paper" + } + } + + [] + let ``Cata works`` () = + let property (x : Gift) = GiftCata.runGift idCata x = x + + Check.QuickThrowOnFailure property + + [] + let ``Example from docs`` () = + let wolfHall = + { + title = "Wolf Hall" + price = 20m + } + + let yummyChoc = + { + chocType = SeventyPercent + price = 5m + } + + let birthdayPresent = + WithACard (Wrapped (Book wolfHall, HappyBirthday), "Happy Birthday") + + let christmasPresent = Wrapped (Boxed (Chocolate yummyChoc), HappyHolidays) + + GiftCata.runGift totalCostCata birthdayPresent |> shouldEqual 22.5m + + GiftCata.runGift descriptionCata christmasPresent + |> shouldEqual "SeventyPercent chocolate in a box wrapped in HappyHolidays paper" + + let deeplyNestedBox depth = + let rec loop depth boxSoFar = + match depth with + | 0 -> boxSoFar + | n -> loop (n - 1) (Boxed boxSoFar) + + loop depth (Book wolfHall) + + deeplyNestedBox 10 |> GiftCata.runGift totalCostCata |> shouldEqual 30.0M + deeplyNestedBox 100 |> GiftCata.runGift totalCostCata |> shouldEqual 120.0M + deeplyNestedBox 1000 |> GiftCata.runGift totalCostCata |> shouldEqual 1020.0M + deeplyNestedBox 10000 |> GiftCata.runGift totalCostCata |> shouldEqual 10020.0M + + deeplyNestedBox 100000 + |> GiftCata.runGift totalCostCata + |> shouldEqual 100020.0M + + deeplyNestedBox 1000000 + |> GiftCata.runGift totalCostCata + |> shouldEqual 1000020.0M diff --git a/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj b/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj index 4a99cdf..955e311 100644 --- a/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj +++ b/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj @@ -21,6 +21,10 @@ + + + + @@ -41,8 +45,4 @@ - - - - diff --git a/WoofWare.Myriad.Plugins/AstHelper.fs b/WoofWare.Myriad.Plugins/AstHelper.fs index 02e3a2c..70f4138 100644 --- a/WoofWare.Myriad.Plugins/AstHelper.fs +++ b/WoofWare.Myriad.Plugins/AstHelper.fs @@ -70,6 +70,23 @@ type internal RecordType = Accessibility : SynAccess option } +/// Anything that is part of an ADT. +/// A record is a product of stuff; this type represents one of those stuffs. +type internal AdtNode = + { + Type : SynType + Name : Ident option + } + +/// A DU is a sum of products (e.g. `type Thing = Foo of a * b`); +/// similarly a record is a product. +/// This type represents a product in that sense. +type internal AdtProduct = + { + Name : SynIdent + Fields : AdtNode list + } + [] module internal AstHelper = @@ -383,6 +400,39 @@ module internal AstHelper = Accessibility = accessibility } + let getUnionCases (SynTypeDefn.SynTypeDefn (_, repr, _, _, _, _)) : AdtProduct list = + match repr with + | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (_, cases, _), _) -> + cases + |> List.map (fun (SynUnionCase.SynUnionCase (_, ident, kind, _, _, _, _)) -> + match kind with + | SynUnionCaseKind.FullType _ -> failwith "FullType union cases not supported" + | SynUnionCaseKind.Fields fields -> + { + Name = ident + Fields = + fields + |> List.map (fun (SynField.SynField (_, _, id, ty, _, _, _, _, _)) -> + { + Type = ty + Name = id + } + ) + } + ) + | _ -> failwithf "Failed to get union cases for type that was: %+A" repr + + let getRecordFields (SynTypeDefn.SynTypeDefn (_, repr, _, _, _, _)) : AdtNode list = + match repr with + | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (_, fields, _), _) -> + fields + |> List.map (fun (SynField.SynField (_, _, ident, ty, _, _, _, _, _)) -> + { + Name = ident + Type = ty + } + ) + | _ -> failwithf "Failed to get record elements for type that was: %+A" repr [] module internal SynTypePatterns = diff --git a/WoofWare.Myriad.Plugins/CataGenerator.fs b/WoofWare.Myriad.Plugins/CataGenerator.fs new file mode 100644 index 0000000..c26f472 --- /dev/null +++ b/WoofWare.Myriad.Plugins/CataGenerator.fs @@ -0,0 +1,1511 @@ +namespace WoofWare.Myriad.Plugins + +open Fantomas.FCS.Syntax +open Fantomas.FCS.SyntaxTrivia +open Fantomas.FCS.Xml +open Myriad.Core + +[] +module internal CataGenerator = + open Fantomas.FCS.Text.Range + open Myriad.Core.Ast + + /// The user-provided DU contains cases, each of which contains fields. + /// We have a hard-coded set of things we know how to deal with as field contents. + type FieldDescription = + /// type Thing = | Case of Thing list * whatever + | ListSelf of SynType + /// type Thing = | Case of Thing * whatever + | Self of SynType + /// type Thing = | Case of int * whatever + | NonRecursive of SynType + + /// Within a union case, there are several fields. This is a field. + /// (The name is "CataUnionField" merely to distinguish it from the more general + /// `UnionField` notion we already have in this library; it's got more information + /// in it that is unique to this source generator.) + type CataUnionBasicField = + { + /// The name of this field as the user originally wrote, if available. + /// For example, `| Foo of blah : int` would give `Some "blah"`. + FieldName : Ident option + /// The name we will use when accessing this field. + /// This is FieldName if available, or otherwise an autogenerated name. + ArgName : Ident + /// The relationship this field has with the parent type (or the + /// recursive knot of parent types) + Description : FieldDescription + } + + type CataUnionRecordField = (Ident * CataUnionBasicField) list + + [] + type CataUnionField = + | Record of CataUnionRecordField + | Basic of CataUnionBasicField + + /// Everything we'll need to know about a single union case within the + /// user-provided DU. + type RenderedUnionCase = + { + /// The name of the case within the `Instruction` state-machine DU + /// which indicates "all the recursive calls are now resolved; you may proceed + /// to pull recursive results from the stack and execute the cata directly" + InstructionName : Ident + /// This user-provided DU case + CaseName : SynIdent + /// The fields of this user-provided DU + Fields : CataUnionField list + /// The corresponding method of the appropriate cata, fully-qualified as a call + /// into some specific cata + CataMethodName : SynLongIdent + /// The identifier of the method of the appropriate cata + CataMethodIdent : SynIdent + /// The Instruction case which instructs the state machine to pull anything + /// necessary from the stacks and call into the cata. + AssociatedInstruction : SynLongIdent + /// Matching on an element of this union type, if you match against this + /// left-hand side (and give appropriate field arguments), you will enter this union case. + Match : SynLongIdent + } + + member this.FlattenedFields : CataUnionBasicField list = + this.Fields + |> List.collect (fun f -> + match f with + | CataUnionField.Basic x -> [ x ] + | CataUnionField.Record r -> r |> List.map snd + ) + + /// For a single user-provided DU (which is possibly one of several within a + /// recursive knot), this is everything we need to know about it for the cata. + type UnionAnalysis = + { + /// The name of the stack we'll use for the results + /// of returning from a descent into this union type, + /// when performing the cata + StackName : Ident + /// The cases of this DU + UnionCases : RenderedUnionCase list + /// The Process instruction case which contains one of this union type. + /// For example, the very first instruction processed will be one of these + /// (i.e. when we enter the loop for the first time). + /// The state machine interprets this instruction as "break me apart and + /// descend recursively if necessary before coming back to me". + AssociatedProcessInstruction : SynLongIdent + /// Name of the parent type: e.g. in `type Foo = | Blah`, this is `Foo`. + ParentTypeName : LongIdent + /// The name of the generic type parameter we'll use within the cata + /// to represent the result of cata'ing on this type. + GenericName : Ident + /// The name of the Cata type which represents "operate on this union case". + CataTypeName : Ident + } + + /// Returns a function: + /// let run{Case} (cata : {cataName}<{typars}>) (x : {Case}) : {TyPar} = + /// let instructions = ResizeArray () + /// instructions.Add (Instruction.Process{Case} e) + /// let {typar1}Results, {typar2}Results, ... = loop cata instructions + /// { for all non-relevant typars: } + /// if {typar}Results.Count > 0 then failwith "logic error" + /// Seq.exactlyOne {relevantTypar}Stack + let createRunFunction + (cataName : Ident) + (allTypars : SynType list) + (relevantTypar : SynType) + (unionType : SynTypeDefn) + : SynBinding + = + let relevantTypeName = + match unionType with + | SynTypeDefn.SynTypeDefn (SynComponentInfo.SynComponentInfo (longId = id), _, _, _, _, _) -> List.last id + + let allTyparNames = + allTypars + |> List.map (fun ty -> + match ty with + | SynType.Var (SynTypar.SynTypar (ident = ident), _) -> ident + | _ -> failwith "logic error in generator" + ) + + let relevantTyparName = + match relevantTypar with + | SynType.Var (SynTypar.SynTypar (ident = ident), _) -> ident + | _ -> failwith "logic error in generator" + + SynBinding.SynBinding ( + None, + SynBindingKind.Normal, + false, + false, + [], + PreXmlDoc.Create " Execute the catamorphism.", + SynValData.SynValData ( + None, + SynValInfo.SynValInfo ( + [ [ SynArgInfo.CreateIdString "cata" ] ; [ SynArgInfo.CreateIdString "x" ] ], + SynArgInfo.SynArgInfo ([], false, None) + ), + None + ), + SynPat.CreateLongIdent ( + SynLongIdent.CreateString ("run" + relevantTypeName.idText), + [ + SynPat.CreateParen ( + SynPat.CreateTyped ( + SynPat.CreateNamed (Ident.Create "cata"), + SynType.App ( + SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ cataName ]), + Some range0, + allTypars, + List.replicate (allTypars.Length - 1) range0, + Some range0, + false, + range0 + ) + ) + ) + SynPat.CreateParen ( + SynPat.CreateTyped ( + SynPat.CreateNamed (Ident.Create "x"), + SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ relevantTypeName ]) + ) + ) + ] + ), + Some (SynBindingReturnInfo.Create relevantTypar), + SynExpr.CreateTyped ( + SynExpr.LetOrUse ( + false, + false, + [ + SynBinding.Let ( + valData = SynValData.SynValData (None, SynValInfo.Empty, None), + pattern = SynPat.CreateNamed (Ident.Create "instructions"), + expr = + SynExpr.CreateApp ( + SynExpr.CreateIdentString "ResizeArray", + SynExpr.CreateConst SynConst.Unit + ) + ) + ], + SynExpr.CreateSequential + [ + SynExpr.CreateApp ( + SynExpr.CreateLongIdent (SynLongIdent.Create [ "instructions" ; "Add" ]), + SynExpr.CreateParen ( + SynExpr.CreateApp ( + SynExpr.CreateLongIdent ( + SynLongIdent.Create + [ "Instruction" ; "Process__" + relevantTypeName.idText ] + ), + SynExpr.CreateLongIdent (SynLongIdent.CreateString "x") + ) + ) + ) + SynExpr.LetOrUse ( + false, + false, + [ + SynBinding.Let ( + valData = SynValData.SynValData (None, SynValInfo.Empty, None), + pattern = + SynPat.Tuple ( + false, + List.map + (fun (t : Ident) -> + SynPat.CreateNamed ( + Ident.Create (t.idText + "Stack") |> Ident.lowerFirstLetter + ) + ) + allTyparNames, + List.replicate (allTypars.Length - 1) range0, + range0 + ), + expr = + SynExpr.CreateApp ( + SynExpr.CreateApp ( + SynExpr.CreateIdentString "loop", + SynExpr.CreateIdentString "cata" + ), + SynExpr.CreateIdentString "instructions" + ) + ) + ], + // TODO: add the "all other stacks are empty" sanity checks + SynExpr.CreateApp ( + SynExpr.CreateLongIdent (SynLongIdent.Create [ "Seq" ; "exactlyOne" ]), + SynExpr.CreateIdent ( + Ident.Create (relevantTyparName.idText + "Stack") |> Ident.lowerFirstLetter + ) + ), + range0, + { + SynExprLetOrUseTrivia.InKeyword = None + } + ) + ], + range0, + { + InKeyword = None + } + ), + relevantTypar + ), + range0, + DebugPointAtBinding.NoneAtLet, + SynExpr.synBindingTriviaZero false + ) + + let getName (ty : SynTypeDefn) : LongIdent = + match ty with + | SynTypeDefn.SynTypeDefn (SynComponentInfo.SynComponentInfo (_, _, _, id, _, _, _, _), _, _, _, _, _) -> id + + let getNameUnion (unionType : SynType) : LongIdent option = + match unionType with + | SynType.LongIdent (SynLongIdent.SynLongIdent (name, _, _)) -> Some name + | _ -> None + + let getNameKey (ty : SynTypeDefn) : string = + getName ty |> List.map _.idText |> String.concat "/" + + // TODO: get rid of this function; it's causing some very spooky coupling at a distance + let getNameKeyUnion (unionType : SynType) : string = + match unionType with + | SynType.LongIdent (SynLongIdent.SynLongIdent (name, _, _)) -> name |> List.map _.idText |> String.concat "/" + | _ -> failwithf "unrecognised type: %+A" unionType + + /// Get the fields of this particular union case, and describe their relation to the + /// recursive knot of user-provided DUs for which we are creating a cata. + let analyse + (allRecordTypes : SynTypeDefn list) + (allUnionTypes : SynTypeDefn list) + (argIndex : int) + (fields : AdtNode list) + : CataUnionBasicField list + = + let rec go (prefix : string) (name : Ident option) (ty : SynType) = + let stripped = SynType.stripOptionalParen ty + + match stripped with + | ListType child -> + let gone = go (prefix + "_") None child + + match gone.Description with + | FieldDescription.NonRecursive ty -> + // Great, no recursion, just treat it as atomic + { + FieldName = name + ArgName = + match name with + | Some n -> Ident.lowerFirstLetter n + | None -> Ident.Create $"arg%s{prefix}" + Description = FieldDescription.NonRecursive stripped + } + | FieldDescription.Self ty -> + { + FieldName = name + ArgName = + match name with + | Some n -> Ident.lowerFirstLetter n + | None -> Ident.Create $"arg%s{prefix}" + Description = FieldDescription.ListSelf ty + } + | FieldDescription.ListSelf _ -> failwith "Deeply nested lists not currently supported" + | PrimitiveType _ -> + { + FieldName = name + ArgName = + match name with + | Some n -> Ident.lowerFirstLetter n + | None -> Ident.Create $"arg%s{prefix}" + Description = FieldDescription.NonRecursive stripped + } + | SynType.LongIdent (SynLongIdent.SynLongIdent (ty, _, _)) -> + let key = ty |> List.map _.idText |> String.concat "/" + + let isKnownUnion = + allUnionTypes |> List.exists (fun unionTy -> getNameKey unionTy = key) + + let knownRecord = + allRecordTypes + |> List.tryPick (fun recordTy -> if getNameKey recordTy = key then Some recordTy else None) + + if isKnownUnion then + { + FieldName = name + ArgName = + match name with + | Some n -> Ident.lowerFirstLetter n + | None -> Ident.Create $"arg%s{prefix}" + Description = FieldDescription.Self stripped + } + else + { + FieldName = name + ArgName = + match name with + | Some n -> Ident.lowerFirstLetter n + | None -> Ident.Create $"arg%s{prefix}" + Description = FieldDescription.NonRecursive stripped + } + + | _ -> failwithf "Unrecognised type: %+A" stripped + + fields |> List.mapi (fun i x -> go $"%i{argIndex}_%i{i}" x.Name x.Type) + + /// Returns whether this type recursively contains a Self, and the type which + /// the Instruction case is going to have to store to obtain this field. + /// (For example, a `self list` will need to store an int, namely the number + /// of recursive results to pull from the stack just before we feed them + /// into the cata.) + let rec toInstructionCase (field : FieldDescription) : bool * SynType option = + match field with + | FieldDescription.NonRecursive ty -> false, Some ty + | FieldDescription.Self ty -> true, None + | FieldDescription.ListSelf ty -> + // store the length of the list + true, Some (SynType.Int ()) + + type InstructionCase = + { + Name : Ident + Fields : AdtNode list + } + + let getInstructionCaseName (thisUnionType : SynTypeDefn) (caseName : SynIdent) : Ident = + match caseName with + | SynIdent.SynIdent (ident, _) -> + (List.last (getName thisUnionType)).idText + "_" + ident.idText |> Ident.Create + + /// Given the input `| Pair of Expr * Expr * PairOpKind`, + /// strips out any members which contain recursive calls. + /// Stores a list as an int which is "the length of the list". + /// TODO: support other compound types. + let getRecursiveInstruction (case : RenderedUnionCase) : InstructionCase option = + let hasRecursion, cases = + ((false, []), case.FlattenedFields) + ||> List.fold (fun (hasRecursion, cases) field -> + let newHasRecursion, case = toInstructionCase field.Description + + let cases = + match case with + | None -> cases + | Some case -> (field.FieldName, case) :: cases + + hasRecursion || newHasRecursion, cases + ) + + if not hasRecursion then + // No recursive instructions required; we'll be feeding the data + // straight into the cata without any stack manipulation. + None + else + + let fields = + cases + |> List.rev + |> List.map (fun (name, ty) -> + { + Name = name |> Option.map Ident.lowerFirstLetter + Type = ty + } + ) + + { + Name = case.InstructionName + Fields = fields + } + |> Some + + /// The instruction to "process an Expr"; the loop will have to descend + /// into this Expr and break it down to discover what recursive calls + /// and calls to the cata this will imply making. + let baseCases (unions : UnionAnalysis list) : InstructionCase list = + unions + |> List.map (fun union -> + { + Name = + match union.AssociatedProcessInstruction with + | SynLongIdent.SynLongIdent (i, _, _) -> List.last i + Fields = + { + Name = None + Type = SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent union.ParentTypeName) + } + |> List.singleton + } + ) + + /// The instruction to "pull recursive results from the stack, and then call into the cata". + let recursiveCases (allUnionTypes : UnionAnalysis list) : InstructionCase list = + allUnionTypes + |> List.collect (fun union -> union.UnionCases |> List.choose getRecursiveInstruction) + + /// Build the DU which defines the states our state machine can be in. + let createInstructionType (analysis : UnionAnalysis list) : SynTypeDefn = + // One union case for each union type, and then + // a union case for each union case which contains a recursive reference. + let casesFromProcess : SynUnionCase list = + baseCases analysis + |> List.map (fun unionCase -> + SynUnionCase.Create (unionCase.Name, unionCase.Fields |> List.map (fun f -> SynField.Create f.Type)) + ) + + let casesFromCases = + recursiveCases analysis + |> List.map (fun case -> + SynUnionCase.Create (case.Name, case.Fields |> List.map (fun field -> SynField.Create field.Type)) + ) + + let cases = casesFromProcess @ casesFromCases + + SynTypeDefn.SynTypeDefn ( + SynComponentInfo.SynComponentInfo ( + [ SynAttributeList.Create [ SynAttribute.RequireQualifiedAccess () ] ], + None, + [], + [ Ident.Create "Instruction" ], + PreXmlDoc.Empty, + false, + Some (SynAccess.Private range0), + range0 + ), + SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (None, cases, range0), range0), + [], + None, + range0, + { + LeadingKeyword = SynTypeDefnLeadingKeyword.Type range0 + EqualsRange = Some range0 + WithKeyword = None + } + ) + + /// Build the cata interfaces, which a user will instantiate to specify a particular + /// catamorphism. This produces one interface per input union type. + /// + /// Say that CreateCatamorphism-tagged types form the set T. + /// Assert that each U in T is a discriminated union. + /// For each type U in T, assign a generic parameter 'ret. + /// For each U: + /// * Define the type [U]Cata, generic on all the parameters {'ret : U in T}. + /// * For each DU case C in type U: + /// * create a method in [U]Cata, whose return value is 'ret and whose args are the fields of the case C + /// * any occurrence in a field of an input value of type equal to any element of T (say type V) is replaced by 'ret + let createCataStructure (analyses : UnionAnalysis list) : SynTypeDefn list = + // Obtain the generic parameter for a UnionAnalysis by dotting into this + // with `case.GenericName.idText`. + // Remember that this is essentially unordered! + let generics = + analyses + |> List.map (fun case -> + case.GenericName.idText, SynTypar.SynTypar (case.GenericName, TyparStaticReq.None, false) + ) + |> Map.ofList + + let orderedGenerics = + analyses + |> List.map (fun case -> SynTyparDecl.SynTyparDecl ([], generics.[case.GenericName.idText])) + + analyses + |> List.map (fun analysis -> + let componentInfo = + SynComponentInfo.SynComponentInfo ( + [], + Some (SynTyparDecls.PostfixList (orderedGenerics, [], range0)), + [], + [ analysis.CataTypeName ], + // TODO: better docstring + PreXmlDoc.Create " Description of how to combine cases during a fold", + false, + None, + range0 + ) + + let slots = + let ourGenericName = generics.[analysis.GenericName.idText] + + let flags = + { + SynMemberFlags.IsInstance = true + SynMemberFlags.IsDispatchSlot = true + SynMemberFlags.IsOverrideOrExplicitImpl = false + SynMemberFlags.IsFinal = false + SynMemberFlags.GetterOrSetterIsCompilerGenerated = false + SynMemberFlags.MemberKind = SynMemberKind.Member + } + + analysis.UnionCases + |> List.map (fun case -> + let arity = + SynValInfo.SynValInfo ( + case.Fields |> List.map (fun field -> [ SynArgInfo.Empty ]), + SynArgInfo.Empty + ) + + let ty = + (SynType.Var (ourGenericName, range0), List.rev case.FlattenedFields) + ||> List.fold (fun acc field -> + let place : SynType = + match field.Description with + | FieldDescription.Self ty -> SynType.Var (generics.[getNameKeyUnion ty], range0) + | FieldDescription.ListSelf ty -> + SynType.CreateApp ( + SynType.CreateLongIdent "list", + [ SynType.Var (generics.[getNameKeyUnion ty], range0) ], + true + ) + | FieldDescription.NonRecursive ty -> ty + + SynType.Fun ( + SynType.SignatureParameter ( + [], + false, + field.FieldName |> Option.map Ident.lowerFirstLetter, + place, + range0 + ), + acc, + range0, + { + ArrowRange = range0 + } + ) + ) + + let slot = + SynValSig.SynValSig ( + [], + case.CataMethodIdent, + SynValTyparDecls.SynValTyparDecls (None, true), + ty, + arity, + false, + false, + PreXmlDoc.Create $" How to operate on the %s{List.last(case.Match.LongIdent).idText} case", + None, + None, + range0, + { + EqualsRange = None + WithKeyword = None + InlineKeyword = None + LeadingKeyword = SynLeadingKeyword.Abstract range0 + } + ) + + SynMemberDefn.AbstractSlot ( + slot, + flags, + range0, + { + GetSetKeywords = None + } + ) + ) + + let repr = SynTypeDefnRepr.ObjectModel (SynTypeDefnKind.Unspecified, slots, range0) + + SynTypeDefn.SynTypeDefn ( + componentInfo, + repr, + [], + None, + range0, + { + LeadingKeyword = SynTypeDefnLeadingKeyword.Type range0 + EqualsRange = Some range0 + WithKeyword = None + } + ) + ) + + /// Build a record which contains one of every cata type. + /// That is, define a type Cata<{'ret for U in T}> + /// with one member for each U, namely of type [U]Cata<{'ret for U in T}>. + // TODO: this should take an analysis instead + let createCataRecord (cataName : Ident) (doc : PreXmlDoc) (allUnionTypes : SynTypeDefn list) : SynTypeDefn = + let generics = + allUnionTypes + |> List.map (fun defn -> + let name = getName defn |> List.map _.idText |> String.concat "" |> Ident.Create + SynTypar.SynTypar (name, TyparStaticReq.None, false) + ) + + let fields = + allUnionTypes + |> List.map (fun unionType -> + let nameForDoc = List.last (getName unionType) |> _.idText + + let doc = + PreXmlDoc.Create $" How to perform a fold (catamorphism) over the type %s{nameForDoc}" + + let name = getName unionType + + let ty = + SynType.App ( + SynType.CreateLongIdent (SynLongIdent.CreateString (List.last(name).idText + "CataCase")), + Some range0, + generics |> List.map (fun v -> SynType.Var (v, range0)), + List.replicate (generics.Length - 1) range0, + Some range0, + false, + range0 + ) + + SynField.SynField ( + [], + false, + Some (List.last name), + ty, + false, + doc, + None, + range0, + { + LeadingKeyword = None + } + ) + ) + + let componentInfo = + SynComponentInfo.SynComponentInfo ( + [], + Some ( + SynTyparDecls.PostfixList ( + generics |> List.map (fun ty -> SynTyparDecl.SynTyparDecl ([], ty)), + [], + range0 + ) + ), + [], + [ cataName ], + doc, + false, + None, + range0 + ) + + SynTypeDefn.SynTypeDefn ( + componentInfo, + SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (None, fields, range0), range0), + [], + None, + range0, + { + LeadingKeyword = SynTypeDefnLeadingKeyword.Type range0 + WithKeyword = None + EqualsRange = Some range0 + } + ) + + let makeUnionAnalyses + (cataVarName : Ident) + (allRecordTypes : SynTypeDefn list) + (allUnionTypes : SynTypeDefn list) + : UnionAnalysis list + = + let recordTypes = + allRecordTypes + |> List.map (fun ty -> List.last(getName ty).idText, AstHelper.getRecordFields ty) + |> Map.ofList + + allUnionTypes + |> List.map (fun unionType -> + let cases = + AstHelper.getUnionCases unionType + |> List.map (fun prod -> + let fields = + prod.Fields + |> List.indexed + |> List.collect (fun (i, node) -> + match getNameUnion node.Type with + | None -> + analyse allRecordTypes allUnionTypes i [ node ] |> List.map CataUnionField.Basic + | Some name -> + + match Map.tryFind (List.last(name).idText) recordTypes with + | None -> + analyse allRecordTypes allUnionTypes i [ node ] |> List.map CataUnionField.Basic + | Some fields -> + List.zip fields (analyse allRecordTypes allUnionTypes i fields) + |> List.map (fun (field, analysis) -> Option.get field.Name, analysis) + |> CataUnionField.Record + |> List.singleton + ) + + prod.Name, fields + ) + + let unionTypeName = getName unionType + + { + StackName = + List.last(getName unionType).idText + "Stack" + |> Ident.Create + |> Ident.lowerFirstLetter + UnionCases = + cases + |> List.map (fun (name, analysis) -> + let instructionName = getInstructionCaseName unionType name + + let unionCaseName = + match name with + | SynIdent (ident, _) -> ident + + { + InstructionName = instructionName + Fields = analysis + CaseName = name + CataMethodName = + SynLongIdent.CreateFromLongIdent (cataVarName :: unionTypeName @ [ unionCaseName ]) + CataMethodIdent = SynIdent.SynIdent (unionCaseName, None) + AssociatedInstruction = + SynLongIdent.CreateFromLongIdent [ Ident.Create "Instruction" ; instructionName ] + Match = SynLongIdent.CreateFromLongIdent (unionTypeName @ [ unionCaseName ]) + } + ) + AssociatedProcessInstruction = + SynLongIdent.Create + [ + "Instruction" + // such jank! + "Process__" + List.last(unionTypeName).idText + ] + ParentTypeName = getName unionType + GenericName = getName unionType |> List.map _.idText |> String.concat "" |> Ident.Create + CataTypeName = List.last(getName unionType).idText + "CataCase" |> Ident.Create + } + ) + + let callCataAndPushResult (resultStackName : Ident) (unionCase : RenderedUnionCase) : SynExpr = + (SynExpr.CreateLongIdent unionCase.CataMethodName, unionCase.FlattenedFields) + ||> List.fold (fun body caseDesc -> SynExpr.CreateApp (body, SynExpr.CreateIdent caseDesc.ArgName)) + |> SynExpr.pipeThroughFunction ( + SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent (resultStackName :: [ Ident.Create "Add" ])) + ) + + /// Create the state-machine matches which deal with receiving the instruction + /// to "process one of the user-specified DU cases, pushing recursion instructions onto + /// the instruction stack". + /// It very rarely involves invoking the cata; that happens only if there's no recursion. + let createBaseMatchClause (analysis : UnionAnalysis) : SynMatchClause = + let matchCases = + analysis.UnionCases + |> List.map (fun unionCase -> + let name = + match unionCase.CaseName with + | SynIdent (ident, _) -> ident + + let _, nonRecursiveArgs, selfArgs, listSelfArgs = + ((0, [], [], []), unionCase.FlattenedFields) + ||> List.fold (fun (i, nonRec, self, listSelf) caseDesc -> + match caseDesc.Description with + | FieldDescription.NonRecursive ty -> + i + 1, (i, caseDesc.ArgName, ty) :: nonRec, self, listSelf + | FieldDescription.Self ty -> i + 1, nonRec, (i, caseDesc.ArgName, ty) :: self, listSelf + | FieldDescription.ListSelf ty -> i + 1, nonRec, self, (i, caseDesc.ArgName, ty) :: listSelf + ) + + let matchBody = + if nonRecursiveArgs.Length = unionCase.Fields.Length then + // directly call the cata + callCataAndPushResult analysis.StackName unionCase + else + // There's a recursive type in here, so we'll have to make some calls + // and then come back. + + // The instruction to process us again once our inputs are ready: + let reprocessCommand = + SynExpr.CreateApp ( + SynExpr.CreateLongIdent (SynLongIdent.Create [ "instructions" ; "Add" ]), + if selfArgs.Length = unionCase.Fields.Length then + SynExpr.CreateLongIdent unionCase.AssociatedInstruction + else + // We need to tell ourselves each non-rec arg, and the length of each input list. + SynExpr.CreateApp ( + SynExpr.CreateLongIdent unionCase.AssociatedInstruction, + SynExpr.CreateParenedTuple ( + listSelfArgs + |> List.map (fun (i, argName, _) -> + i, + SynExpr.CreateParen ( + SynExpr.CreateApp ( + SynExpr.CreateLongIdent ( + SynLongIdent.Create [ "List" ; "length" ] + ), + SynExpr.CreateIdent argName + ) + ) + ) + |> List.append ( + nonRecursiveArgs + |> List.map (fun (i, arg, _) -> i, SynExpr.CreateIdent arg) + ) + |> List.sortBy fst + |> List.map snd + ) + ) + |> SynExpr.CreateParen + ) + + [ + yield reprocessCommand + + for i, caseDesc in Seq.indexed unionCase.FlattenedFields do + match caseDesc.Description with + | NonRecursive synType -> + // Nothing to do, because we're not calling the cata yet + () + | ListSelf synType -> + // Tell our future self to process the list elements first. + yield + SynExpr.ForEach ( + DebugPointAtFor.Yes range0, + DebugPointAtInOrTo.Yes range0, + SeqExprOnly.SeqExprOnly false, + true, + SynPat.CreateNamed (SynIdent.SynIdent (Ident.Create "elt", None)), + SynExpr.CreateIdent caseDesc.ArgName, + SynExpr.CreateApp ( + SynExpr.CreateLongIdent (SynLongIdent.Create [ "instructions" ; "Add" ]), + SynExpr.CreateParen ( + SynExpr.CreateApp ( + SynExpr.CreateLongIdent analysis.AssociatedProcessInstruction, + SynExpr.CreateIdentString "elt" + ) + ) + ), + range0 + ) + | Self synType -> + // And push the instruction to process each recursive call + // onto the stack. + yield + SynExpr.CreateApp ( + SynExpr.CreateLongIdent (SynLongIdent.Create [ "instructions" ; "Add" ]), + SynExpr.CreateParen ( + SynExpr.CreateApp ( + SynExpr.CreateLongIdent ( + // TODO: use an AssociatedProcessInstruction instead + SynLongIdent.Create + [ + "Instruction" + // TODO wonky domain + "Process" + + "__" + + List.last(getNameUnion(synType).Value).idText + ] + ), + SynExpr.CreateIdent caseDesc.ArgName + ) + ) + ) + ] + |> SynExpr.CreateSequential + + SynMatchClause.SynMatchClause ( + SynPat.CreateLongIdent ( + unionCase.Match, + [ + SynPat.CreateParen ( + SynPat.Tuple ( + false, + unionCase.Fields + |> List.mapi (fun i case -> + match case with + | CataUnionField.Basic case -> + SynPat.CreateNamed (Ident.lowerFirstLetter case.ArgName) + | CataUnionField.Record fields -> + let fields = + fields + |> List.map (fun (name, field) -> + ([], name), + range0, + SynPat.CreateNamed (Ident.lowerFirstLetter name) + ) + + SynPat.Record (fields, range0) + ), + List.replicate (unionCase.Fields.Length - 1) range0, + range0 + ) + ) + ] + ), + None, + matchBody, + range0, + DebugPointAtTarget.Yes, + { + ArrowRange = Some range0 + BarRange = Some range0 + } + ) + ) + + let bodyMatch = SynExpr.CreateMatch (SynExpr.CreateIdentString "x", matchCases) + + SynMatchClause.SynMatchClause ( + SynPat.LongIdent ( + analysis.AssociatedProcessInstruction, + None, + None, + SynArgPats.Pats [ SynPat.CreateNamed (Ident.Create "x") ], + None, + range0 + ), + None, + bodyMatch, + range0, + DebugPointAtTarget.Yes, + { + ArrowRange = Some range0 + BarRange = Some range0 + } + ) + + /// Create the state-machine matches which deal with receiving the instruction + /// to "pull recursive results from the result stacks, and invoke the cata". + let createRecursiveMatchClauses (analyses : UnionAnalysis list) : SynMatchClause list = + let inputStacks = + analyses + |> Seq.map (fun a -> + // TODO this is jank + (List.last a.ParentTypeName).idText, a.StackName + ) + |> Map.ofSeq + + analyses + |> List.collect (fun analysis -> + analysis.UnionCases + |> List.choose (fun unionCase -> + // We already know there is a recursive reference somewhere + // in `analysis`. + if + unionCase.FlattenedFields + |> List.exists (fun case -> + match case.Description with + | NonRecursive _ -> false + | _ -> true + ) + then + Some unionCase + else + None + ) + |> List.map (fun unionCase -> + let lhsNames = + unionCase.FlattenedFields + |> Seq.mapi (fun i x -> (i, x)) + |> Seq.choose (fun (i, case) -> + match case.Description with + | FieldDescription.NonRecursive _ -> SynPat.CreateNamed case.ArgName |> Some + | FieldDescription.ListSelf _ -> SynPat.CreateNamed case.ArgName |> Some + | FieldDescription.Self _ -> None + ) + |> Seq.toList + + let lhs = + match lhsNames with + | [] -> [] + | lhsNames -> + SynPat.Tuple (false, lhsNames, List.replicate (lhsNames.Length - 1) range0, range0) + |> SynPat.CreateParen + |> List.singleton + + let pat = + SynPat.LongIdent (unionCase.AssociatedInstruction, None, None, SynArgPats.Pats lhs, None, range0) + + let populateArgs = + unionCase.FlattenedFields + |> List.choose (fun field -> + match field.Description with + | NonRecursive _ -> + // this was passed in already in the match + None + | Self synType -> + // pull the one entry from the stack + // let {field.ArgName} = {appropriateStack}.[SynExpr.minusN {appropriateStack.Count} 1] + // {appropriateStack}.RemoveRange (SynExpr.minusN {appropriateStack.Count} 1) + // TODO: this is jank + let stackName = inputStacks.[List.last(getNameUnion(synType).Value).idText] + + SynExpr.LetOrUse ( + false, + false, + [ + SynBinding.SynBinding ( + None, + SynBindingKind.Normal, + false, + false, + [], + PreXmlDoc.Empty, + SynValData.SynValData (None, SynValInfo.Empty, None), + SynPat.CreateNamed field.ArgName, + None, + SynExpr.DotIndexedGet ( + SynExpr.CreateIdent stackName, + SynExpr.minusN + (SynLongIdent.CreateFromLongIdent + [ stackName ; Ident.Create "Count" ]) + 1, + range0, + range0 + ), + range0, + DebugPointAtBinding.Yes range0, + SynExpr.synBindingTriviaZero false + ) + ], + SynExpr.CreateApp ( + SynExpr.CreateLongIdent ( + SynLongIdent.CreateFromLongIdent [ stackName ; Ident.Create "RemoveAt" ] + ), + SynExpr.CreateParen ( + SynExpr.minusN + (SynLongIdent.CreateFromLongIdent [ stackName ; Ident.Create "Count" ]) + 1 + ) + ), + range0, + { + InKeyword = None + } + ) + |> Some + | ListSelf synType -> + // TODO: also jank + let stackName = inputStacks.[List.last(getNameUnion(synType).Value).idText] + + let vals = + SynBinding.SynBinding ( + None, + SynBindingKind.Normal, + false, + false, + [], + PreXmlDoc.Empty, + SynValData.SynValData (None, SynValInfo.Empty, None), + SynPat.CreateNamed field.ArgName, + None, + SynExpr.pipeThroughFunction + (SynExpr.CreateLongIdent (SynLongIdent.Create [ "Seq" ; "toList" ])) + (SynExpr.CreateApp ( + SynExpr.CreateIdentString "seq", + SynExpr.ComputationExpr ( + false, + SynExpr.For ( + DebugPointAtFor.Yes range0, + DebugPointAtInOrTo.Yes range0, + Ident.Create "i", + Some range0, + SynExpr.minusN + (SynLongIdent.CreateFromLongIdent + [ stackName ; Ident.Create "Count" ]) + 1, + false, + SynExpr.minus + (SynLongIdent.CreateFromLongIdent + [ stackName ; Ident.Create "Count" ]) + (SynExpr.CreateIdent field.ArgName), + SynExpr.YieldOrReturn ( + (true, false), + SynExpr.DotIndexedGet ( + SynExpr.CreateIdent stackName, + SynExpr.CreateIdentString "i", + range0, + range0 + ), + range0 + ), + range0 + ), + range0 + ) + )), + range0, + DebugPointAtBinding.Yes range0, + SynExpr.synBindingTriviaZero false + ) + + let shadowedIdent = Ident.Create (field.ArgName.idText + "_len") + + SynExpr.LetOrUse ( + false, + false, + [ + SynBinding.SynBinding ( + None, + SynBindingKind.Normal, + false, + false, + [], + PreXmlDoc.Empty, + SynValData.SynValData (None, SynValInfo.Empty, None), + SynPat.CreateNamed shadowedIdent, + None, + SynExpr.CreateIdent field.ArgName, + range0, + DebugPointAtBinding.Yes range0, + SynExpr.synBindingTriviaZero false + ) + + ], + SynExpr.CreateSequential + [ + SynExpr.LetOrUse ( + false, + false, + [ vals ], + SynExpr.CreateApp ( + SynExpr.CreateLongIdent ( + SynLongIdent.CreateFromLongIdent + [ stackName ; Ident.Create "RemoveRange" ] + ), + SynExpr.CreateParenedTuple + [ + SynExpr.minus + (SynLongIdent.CreateFromLongIdent + [ stackName ; Ident.Create "Count" ]) + (SynExpr.CreateIdent shadowedIdent) + SynExpr.CreateIdent shadowedIdent + ] + ), + range0, + { + InKeyword = None + } + ) + ], + + range0, + { + InKeyword = None + } + ) + |> Some + ) + + SynMatchClause.SynMatchClause ( + pat, + None, + SynExpr.CreateSequential (populateArgs @ [ callCataAndPushResult analysis.StackName unionCase ]), + range0, + DebugPointAtTarget.Yes, + { + ArrowRange = Some range0 + BarRange = Some range0 + } + ) + ) + ) + + let createLoopFunction (cataTypeName : Ident) (cataVarName : Ident) (analysis : UnionAnalysis list) : SynBinding = + let valData = + SynValData.SynValData ( + None, + SynValInfo.SynValInfo ( + [ + [ SynArgInfo.SynArgInfo ([], false, Some cataVarName) ] + [ SynArgInfo.SynArgInfo ([], false, Some (Ident.Create "instructions")) ] + ], + SynArgInfo.Empty + ), + None + ) + + let headPat = + SynPat.LongIdent ( + SynLongIdent.CreateString "loop", + None, + None, + SynArgPats.Pats + [ + SynPat.CreateParen ( + SynPat.CreateTyped ( + SynPat.CreateNamed cataVarName, + SynType.App ( + SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ cataTypeName ]), + Some range0, + List.replicate analysis.Length (SynType.Anon range0), + List.replicate (analysis.Length - 1) range0, + Some range0, + false, + range0 + ) + ) + ) + SynPat.CreateParen ( + SynPat.CreateTyped ( + SynPat.CreateNamed (Ident.Create "instructions"), + SynType.App ( + SynType.CreateLongIdent "ResizeArray", + Some range0, + [ SynType.CreateLongIdent "Instruction" ], + [], + Some range0, + false, + range0 + ) + ) + ) + ], + Some (SynAccess.Private range0), + range0 + ) + + let baseMatchClauses = analysis |> List.map createBaseMatchClause + + let recMatchClauses = createRecursiveMatchClauses analysis + + let matchStatement = + SynExpr.CreateMatch (SynExpr.CreateIdentString "currentInstruction", baseMatchClauses @ recMatchClauses) + + let body = + SynExpr.CreateSequential + [ + SynExpr.CreateApp ( + SynExpr.CreateLongIdent (SynLongIdent.Create [ "instructions" ; "RemoveAt" ]), + SynExpr.CreateParen (SynExpr.minusN (SynLongIdent.Create [ "instructions" ; "Count" ]) 1) + ) + matchStatement + ] + + let body = + SynExpr.LetOrUse ( + false, + false, + [ + SynBinding.SynBinding ( + None, + SynBindingKind.Normal, + false, + false, + [], + PreXmlDoc.Empty, + SynValData.SynValData (None, SynValInfo.SynValInfo ([], SynArgInfo.Empty), None), + SynPat.CreateNamed (Ident.Create "currentInstruction"), + None, + SynExpr.DotIndexedGet ( + SynExpr.CreateIdentString "instructions", + SynExpr.minusN (SynLongIdent.Create [ "instructions" ; "Count" ]) 1, + range0, + range0 + ), + range0, + DebugPointAtBinding.Yes range0, + SynExpr.synBindingTriviaZero false + ) + ], + body, + range0, + { + InKeyword = None + } + ) + + let body = + SynExpr.CreateSequential + [ + SynExpr.While ( + DebugPointAtWhile.Yes range0, + SynExpr.greaterThan + (SynExpr.CreateConst (SynConst.Int32 0)) + (SynExpr.CreateLongIdent (SynLongIdent.Create [ "instructions" ; "Count" ])), + body, + range0 + ) + SynExpr.CreateTuple ( + analysis + |> List.map (fun unionAnalysis -> + [ unionAnalysis.StackName ] + |> SynLongIdent.CreateFromLongIdent + |> SynExpr.CreateLongIdent + ) + ) + ] + + let body = + (body, analysis) + ||> List.fold (fun body unionCase -> + SynExpr.LetOrUse ( + false, + false, + [ + SynBinding.SynBinding ( + None, + SynBindingKind.Normal, + false, + false, + [], + PreXmlDoc.Empty, + SynValData.SynValData (None, SynValInfo.Empty, None), + SynPat.Named (SynIdent.SynIdent (unionCase.StackName, None), false, None, range0), + None, + SynExpr.CreateApp ( + SynExpr.CreateLongIdent (SynLongIdent.CreateString "ResizeArray"), + SynExpr.CreateConst SynConst.Unit + ), + range0, + DebugPointAtBinding.Yes range0, + SynExpr.synBindingTriviaZero false + ) + ], + body, + range0, + { + SynExprLetOrUseTrivia.InKeyword = None + } + ) + ) + + SynBinding.SynBinding ( + Some (SynAccess.Private range0), + SynBindingKind.Normal, + false, + false, + [], + PreXmlDoc.Empty, + valData, + headPat, + None, + body, + range0, + DebugPointAtBinding.NoneAtLet, + trivia = SynExpr.synBindingTriviaZero false + ) + + let createModule + (opens : SynOpenDeclTarget list) + (ns : LongIdent) + (cataName : SynExpr, taggedType : SynTypeDefn) + (allUnionTypes : SynTypeDefn list) + (allRecordTypes : SynTypeDefn list) + : SynModuleOrNamespace + = + let cataName = + match cataName |> SynExpr.stripOptionalParen with + | SynExpr.Const (SynConst.String (name, _, _), _) -> Ident.Create name + | _ -> failwith "Cata name in attribute must be literally a string, sorry" + + let parentName = List.last (getName taggedType) |> _.idText + let moduleName : LongIdent = parentName + "Cata" |> Ident.Create |> List.singleton + + let attribs = [ SynAttributeList.Create (SynAttribute.RequireQualifiedAccess ()) ] + + let modInfo = + SynComponentInfo.Create ( + moduleName, + attributes = attribs, + xmldoc = PreXmlDoc.Create $" Methods to perform a catamorphism over the type %s{parentName}" + ) + + let allTypars = + allUnionTypes + |> List.map (fun unionType -> + List.last (getName unionType) + |> fun x -> x.idText + "Ret" + |> Ident.Create + |> fun x -> SynTypar.SynTypar (x, TyparStaticReq.None, false) + |> fun x -> SynType.Var (x, range0) + ) + + let runFunctions = + List.zip allUnionTypes allTypars + |> List.map (fun (unionType, relevantTypar) -> createRunFunction cataName allTypars relevantTypar unionType) + + let cataVarName = Ident.Create "cata" + let analysis = makeUnionAnalyses cataVarName allRecordTypes allUnionTypes + + let cataStructures = + createCataStructure analysis + |> List.map (fun repr -> SynModuleDecl.Types ([ repr ], range0)) + + let loopFunction = createLoopFunction cataName cataVarName analysis + + let recordDoc = + PreXmlDoc.Create + $" Specifies how to perform a fold (catamorphism) over the type %s{parentName} and its friends." + + let cataRecord = + SynModuleDecl.Types ([ createCataRecord cataName recordDoc allUnionTypes ], range0) + + SynModuleOrNamespace.CreateNamespace ( + ns, + decls = + [ + for openStatement in opens do + yield SynModuleDecl.CreateOpen openStatement + yield! cataStructures + yield cataRecord + yield + SynModuleDecl.CreateNestedModule ( + modInfo, + [ + SynModuleDecl.Types ([ createInstructionType analysis ], range0) + SynModuleDecl.CreateLet (loopFunction :: runFunctions) + ] + ) + ] + ) + +/// Myriad generator that provides a catamorphism for an algebraic data type. +[] +type CreateCatamorphismGenerator () = + + interface IMyriadGenerator with + member _.ValidInputExtensions = [ ".fs" ] + + 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 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) -> + 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 c6a8434..5ad7c53 100644 --- a/WoofWare.Myriad.Plugins/HttpClientGenerator.fs +++ b/WoofWare.Myriad.Plugins/HttpClientGenerator.fs @@ -756,12 +756,6 @@ module internal HttpClientGenerator = | _ -> None ) - let lowerFirstLetter (x : Ident) : Ident = - let result = StringBuilder x.idText.Length - result.Append (Char.ToLowerInvariant x.idText.[0]) |> ignore - result.Append x.idText.[1..] |> ignore - Ident.Create ((result : StringBuilder).ToString ()) - let createModule (opens : SynOpenDeclTarget list) (ns : LongIdent) @@ -891,7 +885,7 @@ module internal HttpClientGenerator = Some (SynBindingReturnInfo.Create pi.Type), SynExpr.CreateApp ( SynExpr.CreateLongIdent ( - SynLongIdent.CreateFromLongIdent [ lowerFirstLetter pi.Identifier ] + SynLongIdent.CreateFromLongIdent [ Ident.lowerFirstLetter pi.Identifier ] ), SynExpr.CreateConst SynConst.Unit ), @@ -927,7 +921,7 @@ module internal HttpClientGenerator = properties |> List.map (fun (_, pi) -> SynPat.CreateTyped ( - SynPat.CreateNamed (lowerFirstLetter pi.Identifier), + SynPat.CreateNamed (Ident.lowerFirstLetter pi.Identifier), SynType.CreateFun (SynType.CreateLongIdent "unit", pi.Type) ) |> SynPat.CreateParen diff --git a/WoofWare.Myriad.Plugins/Ident.fs b/WoofWare.Myriad.Plugins/Ident.fs new file mode 100644 index 0000000..4b7708a --- /dev/null +++ b/WoofWare.Myriad.Plugins/Ident.fs @@ -0,0 +1,14 @@ +namespace WoofWare.Myriad.Plugins + +open System +open System.Text +open Fantomas.FCS.Syntax +open Myriad.Core + +[] +module internal Ident = + let lowerFirstLetter (x : Ident) : Ident = + let result = StringBuilder x.idText.Length + result.Append (Char.ToLowerInvariant x.idText.[0]) |> ignore + result.Append x.idText.[1..] |> ignore + Ident.Create ((result : StringBuilder).ToString ()) diff --git a/WoofWare.Myriad.Plugins/SurfaceBaseline.txt b/WoofWare.Myriad.Plugins/SurfaceBaseline.txt index 8e2d6b3..dd41183 100644 --- a/WoofWare.Myriad.Plugins/SurfaceBaseline.txt +++ b/WoofWare.Myriad.Plugins/SurfaceBaseline.txt @@ -1,3 +1,5 @@ +WoofWare.Myriad.Plugins.CreateCatamorphismGenerator inherit obj, implements Myriad.Core.IMyriadGenerator +WoofWare.Myriad.Plugins.CreateCatamorphismGenerator..ctor [constructor]: unit WoofWare.Myriad.Plugins.HttpClientGenerator inherit obj, implements Myriad.Core.IMyriadGenerator WoofWare.Myriad.Plugins.HttpClientGenerator..ctor [constructor]: unit WoofWare.Myriad.Plugins.InterfaceMockGenerator inherit obj, implements Myriad.Core.IMyriadGenerator diff --git a/WoofWare.Myriad.Plugins/SynExpr.fs b/WoofWare.Myriad.Plugins/SynExpr.fs index 95805b5..e5c9d46 100644 --- a/WoofWare.Myriad.Plugins/SynExpr.fs +++ b/WoofWare.Myriad.Plugins/SynExpr.fs @@ -275,3 +275,39 @@ module internal SynExpr = else SynLeadingKeyword.Let range0 } + + /// {ident} - {rhs} + let minus (ident : SynLongIdent) (rhs : SynExpr) : SynExpr = + SynExpr.CreateApp ( + SynExpr.CreateAppInfix ( + SynExpr.CreateLongIdent ( + SynLongIdent.SynLongIdent ( + [ Ident.Create "op_Subtraction" ], + [], + [ Some (IdentTrivia.OriginalNotation "-") ] + ) + ), + SynExpr.CreateLongIdent ident + ), + rhs + ) + + /// {ident} - {n} + let minusN (ident : SynLongIdent) (n : int) : SynExpr = + minus ident (SynExpr.CreateConst (SynConst.Int32 n)) + + /// {y} > {x} + let greaterThan (x : SynExpr) (y : SynExpr) : SynExpr = + SynExpr.CreateApp ( + SynExpr.CreateAppInfix ( + SynExpr.CreateLongIdent ( + SynLongIdent.SynLongIdent ( + [ Ident.Create "op_GreaterThan" ], + [], + [ Some (IdentTrivia.OriginalNotation ">") ] + ) + ), + y + ), + x + ) diff --git a/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj b/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj index 5474356..d2a44a6 100644 --- a/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj +++ b/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj @@ -25,6 +25,7 @@ + @@ -34,6 +35,7 @@ + diff --git a/WoofWare.Myriad.Plugins/version.json b/WoofWare.Myriad.Plugins/version.json index 958fb13..a2ebf80 100644 --- a/WoofWare.Myriad.Plugins/version.json +++ b/WoofWare.Myriad.Plugins/version.json @@ -1,7 +1,7 @@ { - "version": "2.0", + "version": "2.1", "publicReleaseRefSpec": [ "^refs/heads/main$" ], "pathFilters": null -} +} \ No newline at end of file