Add catamorphism generator (#97)

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
+
+[<CreateCatamorphism "TreeCata">]
+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

ConsumePlugin/ConsumePlugin.fsproj

@@ -39,6 +39,14 @@
     <Compile Include="GeneratedSerde.fs">
       <MyriadFile>SerializationAndDeserialization.fs</MyriadFile>
     </Compile>
+    <Compile Include="Catamorphism.fs" />
+    <Compile Include="GeneratedCatamorphism.fs">
+      <MyriadFile>Catamorphism.fs</MyriadFile>
+    </Compile>
+    <Compile Include="FSharpForFunAndProfitCata.fs" />
+    <Compile Include="GeneratedFileSystem.fs">
+      <MyriadFile>FSharpForFunAndProfitCata.fs</MyriadFile>
+    </Compile>
   </ItemGroup>
 
   <ItemGroup>

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 [<CreateCatamorphism "FileSystemCata">] 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
+
+[<CreateCatamorphism "GiftCata">]
+type Gift =
+    | Book of Book
+    | Chocolate of Chocolate
+    | Wrapped of Gift * WrappingPaperStyle
+    | Boxed of Gift
+    | WithACard of Gift * message : string

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
+[<RequireQualifiedAccess>]
+module TreeCata =
+    [<RequireQualifiedAccess>]
+    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<Instruction>) =
+        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

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
+[<RequireQualifiedAccess>]
+module FileSystemItemCata =
+    [<RequireQualifiedAccess>]
+    type private Instruction =
+        | Process__FileSystemItem of FileSystemItem
+        | FileSystemItem_Directory of string * int * int
+
+    let private loop (cata : FileSystemCata<_>) (instructions : ResizeArray<Instruction>) =
+        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
+[<RequireQualifiedAccess>]
+module GiftCata =
+    [<RequireQualifiedAccess>]
+    type private Instruction =
+        | Process__Gift of Gift
+        | Gift_Wrapped of WrappingPaperStyle
+        | Gift_Boxed
+        | Gift_WithACard of string
+
+    let private loop (cata : GiftCata<_>) (instructions : ResizeArray<Instruction>) =
+        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

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 `[<GenerateMock false>]`.
 
+## `CreateCatamorphism`
+
+Takes a collection of mutually recursive discriminated unions:
+
+```fsharp
+[<CreateCatamorphism>]
+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>
+    }
+
+[<RequireQualifiedAccess>]
+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 `[<CreateCatamorphism>]` 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.

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 ()

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

WoofWare.Myriad.Plugins.Attributes/version.json

@@ -1,5 +1,5 @@
 {
-  "version": "2.1",
+  "version": "2.2",
   "publicReleaseRefSpec": [
     "^refs/heads/main$"
   ],

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
+
+[<TestFixture>]
+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
+                }
+        }
+
+    [<Test>]
+    let ``Example`` () =
+        let x =
+            Tree.Pair (Tree.Const (Const.Int 0), Tree.Const (Const.String ""), PairOpKind.ThenDoSeq)
+
+        TreeCata.runTree idCata x |> shouldEqual x
+
+
+    [<Test>]
+    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

WoofWare.Myriad.Plugins.Test/TestCataGenerator/TestDirectory.fs

@@ -0,0 +1,37 @@
+namespace WoofWare.Myriad.Plugins.Test
+
+open NUnit.Framework
+open ConsumePlugin
+open FsCheck
+
+[<TestFixture>]
+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.
+
+    [<Test>]
+    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.

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
+
+[<TestFixture>]
+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"
+                }
+        }
+
+    [<Test>]
+    let ``Cata works`` () =
+        let property (x : Gift) = GiftCata.runGift idCata x = x
+
+        Check.QuickThrowOnFailure property
+
+    [<Test>]
+    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

WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj

@@ -21,6 +21,10 @@
     <Compile Include="TestHttpClient\TestVaultClient.fs" />
     <Compile Include="TestHttpClient\TestVariableHeader.fs" />
     <Compile Include="TestMockGenerator\TestMockGenerator.fs" />
+    <Compile Include="TestJsonSerialize\TestJsonSerde.fs" />
+    <Compile Include="TestCataGenerator\TestCataGenerator.fs" />
+    <Compile Include="TestCataGenerator\TestDirectory.fs" />
+    <Compile Include="TestCataGenerator\TestGift.fs" />
     <Compile Include="TestRemoveOptions.fs"/>
     <Compile Include="TestSurface.fs"/>
     <None Include="../.github/workflows/dotnet.yaml" />
@@ -41,8 +45,4 @@
     <ProjectReference Include="..\ConsumePlugin\ConsumePlugin.fsproj"/>
   </ItemGroup>
 
-  <ItemGroup>
-    <Compile Include="TestJsonSerialize\TestJsonSerde.fs" />
-  </ItemGroup>
-
 </Project>

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
+    }
+
 [<RequireQualifiedAccess>]
 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
 
 [<AutoOpen>]
 module internal SynTypePatterns =

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

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
+
+[<RequireQualifiedAccess>]
+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 ())

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

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
+        )

WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj

@@ -25,6 +25,7 @@
 
   <ItemGroup>
     <Compile Include="List.fs"/>
+    <Compile Include="Ident.fs" />
     <Compile Include="AstHelper.fs"/>
     <Compile Include="SynExpr.fs"/>
     <Compile Include="SynType.fs"/>
@@ -34,6 +35,7 @@
     <Compile Include="JsonSerializeGenerator.fs"/>
     <Compile Include="JsonParseGenerator.fs"/>
     <Compile Include="HttpClientGenerator.fs"/>
+    <Compile Include="CataGenerator.fs" />
     <EmbeddedResource Include="version.json"/>
     <EmbeddedResource Include="SurfaceBaseline.txt"/>
     <None Include="..\README.md">

WoofWare.Myriad.Plugins/version.json

@@ -1,5 +1,5 @@
 {
-  "version": "2.0",
+  "version": "2.1",
   "publicReleaseRefSpec": [
     "^refs/heads/main$"
   ],