Demonstrate that this is too dumb

ConsumePlugin/Catamorphism.fs

@@ -2,8 +2,8 @@ namespace ConsumePlugin
 
 open WoofWare.Myriad.Plugins
 
-type Const =
-    | Int of int
+type Const<'a> =
+    | Verbatim of 'a
     | String of string
 
 type PairOpKind =
@@ -11,12 +11,12 @@ type PairOpKind =
     | ThenDoSeq
 
 [<CreateCatamorphism "TreeCata">]
-type Tree =
-    | Const of Const
-    | Pair of Tree * Tree * PairOpKind
-    | Sequential of Tree list
-    | Builder of Tree * TreeBuilder
+type Tree<'a> =
+    | Const of Const<'a>
+    | Pair of Tree<'a> * Tree<'a> * PairOpKind
+    | Sequential of Tree<'a> list
+    | Builder of Tree<'a> * TreeBuilder<'a>
 
-and TreeBuilder =
-    | Child of TreeBuilder
-    | Parent of Tree
+and TreeBuilder<'a> =
+    | Child of TreeBuilder<'a>
+    | Parent of Tree<'a>

ConsumePlugin/ConsumePlugin.fsproj

@@ -47,6 +47,10 @@
     <Compile Include="GeneratedFileSystem.fs">
       <MyriadFile>FSharpForFunAndProfitCata.fs</MyriadFile>
     </Compile>
+    <Compile Include="List.fs" />
+    <Compile Include="ListCata.fs">
+      <MyriadFile>List.fs</MyriadFile>
+    </Compile>
   </ItemGroup>
 
   <ItemGroup>

ConsumePlugin/FSharpForFunAndProfitCata.fs

@@ -50,19 +50,3 @@ type Gift =
     | Wrapped of Gift * WrappingPaperStyle
     | Boxed of Gift
     | WithACard of Gift * message : string
-
-[<CreateCatamorphism "MyListCata">]
-type MyList =
-    | Nil
-    | Cons of ConsCase
-
-and ConsCase =
-    {
-        Head : int
-        Tail : MyList
-    }
-
-[<CreateCatamorphism "MyList2Cata">]
-type MyList2 =
-    | Nil
-    | Cons of int * MyList2

ConsumePlugin/GeneratedCatamorphism.fs

@@ -12,14 +12,14 @@ namespace ConsumePlugin
 open WoofWare.Myriad.Plugins
 
 /// Description of how to combine cases during a fold
-type TreeBuilderCataCase<'TreeBuilder, 'Tree> =
+type TreeBuilderCataCase<'a, '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> =
+type TreeCataCase<'a, 'TreeBuilder, 'Tree> =
     /// How to operate on the Const case
     abstract Const : Const -> 'Tree
     /// How to operate on the Pair case
@@ -30,28 +30,28 @@ type TreeCataCase<'TreeBuilder, 'Tree> =
     abstract Builder : 'Tree -> 'TreeBuilder -> 'Tree
 
 /// Specifies how to perform a fold (catamorphism) over the type Tree and its friends.
-type TreeCata<'TreeBuilder, 'Tree> =
+type TreeCata<'a, 'a, 'TreeBuilder, 'Tree> =
     {
         /// How to perform a fold (catamorphism) over the type TreeBuilder
-        TreeBuilder : TreeBuilderCataCase<'TreeBuilder, 'Tree>
+        TreeBuilder : TreeBuilderCataCase<'a, 'TreeBuilder, 'Tree>
         /// How to perform a fold (catamorphism) over the type Tree
-        Tree : TreeCataCase<'TreeBuilder, 'Tree>
+        Tree : TreeCataCase<'a, '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
+    type private Instruction<'a, 'a> =
+        | Process__TreeBuilder of TreeBuilder<'a>
+        | Process__Tree of Tree<'a>
         | TreeBuilder_Child
         | TreeBuilder_Parent
         | Tree_Pair of PairOpKind
         | Tree_Sequential of int
         | Tree_Builder
 
-    let private loop (cata : TreeCata<_, _>) (instructions : ResizeArray<Instruction>) =
+    let private loop (cata : TreeCata<_, _, _, _>) (instructions : ResizeArray<Instruction<_, _>>) =
         let treeStack = ResizeArray ()
         let treeBuilderStack = ResizeArray ()
 
@@ -120,14 +120,18 @@ module TreeCata =
         treeBuilderStack, treeStack
 
     /// Execute the catamorphism.
-    let runTreeBuilder (cata : TreeCata<'TreeBuilderRet, 'TreeRet>) (x : TreeBuilder) : 'TreeBuilderRet =
+    let runTreeBuilder
+        (cata : TreeCata<'a, 'a, 'TreeBuilderRet, 'TreeRet>)
+        (x : TreeBuilder<'a, 'a>)
+        : '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 runTree (cata : TreeCata<'a, 'a, 'TreeBuilderRet, 'TreeRet>) (x : Tree<'a, 'a>) : 'TreeRet =
         let instructions = ResizeArray ()
         instructions.Add (Instruction.Process__Tree x)
         let treeBuilderRetStack, treeRetStack = loop cata instructions

ConsumePlugin/GeneratedFileSystem.fs

@@ -150,112 +150,3 @@ module GiftCata =
         instructions.Add (Instruction.Process__Gift x)
         let giftRetStack = loop cata instructions
         Seq.exactlyOne giftRetStack
-namespace ConsumePlugin
-
-open WoofWare.Myriad.Plugins
-
-/// Description of how to combine cases during a fold
-type MyListCataCase<'MyList> =
-    /// How to operate on the Nil case
-    abstract Nil : 'MyList
-    /// How to operate on the Cons case
-    abstract Cons : head : int -> tail : 'MyList -> 'MyList
-
-/// Specifies how to perform a fold (catamorphism) over the type MyList and its friends.
-type MyListCata<'MyList> =
-    {
-        /// How to perform a fold (catamorphism) over the type MyList
-        MyList : MyListCataCase<'MyList>
-    }
-
-/// Methods to perform a catamorphism over the type MyList
-[<RequireQualifiedAccess>]
-module MyListCata =
-    [<RequireQualifiedAccess>]
-    type private Instruction =
-        | Process__MyList of MyList
-        | MyList_Cons of int
-
-    let private loop (cata : MyListCata<_>) (instructions : ResizeArray<Instruction>) =
-        let myListStack = ResizeArray ()
-
-        while instructions.Count > 0 do
-            let currentInstruction = instructions.[instructions.Count - 1]
-            instructions.RemoveAt (instructions.Count - 1)
-
-            match currentInstruction with
-            | Instruction.Process__MyList x ->
-                match x with
-                | MyList.Nil -> cata.MyList.Nil |> myListStack.Add
-                | MyList.Cons ({
-                                   Head = head
-                                   Tail = tail
-                               }) ->
-                    instructions.Add (Instruction.MyList_Cons (head))
-                    instructions.Add (Instruction.Process__MyList tail)
-            | Instruction.MyList_Cons (head) ->
-                let tail = myListStack.[myListStack.Count - 1]
-                myListStack.RemoveAt (myListStack.Count - 1)
-                cata.MyList.Cons head tail |> myListStack.Add
-
-        myListStack
-
-    /// Execute the catamorphism.
-    let runMyList (cata : MyListCata<'MyListRet>) (x : MyList) : 'MyListRet =
-        let instructions = ResizeArray ()
-        instructions.Add (Instruction.Process__MyList x)
-        let myListRetStack = loop cata instructions
-        Seq.exactlyOne myListRetStack
-namespace ConsumePlugin
-
-open WoofWare.Myriad.Plugins
-
-/// Description of how to combine cases during a fold
-type MyList2CataCase<'MyList2> =
-    /// How to operate on the Nil case
-    abstract Nil : 'MyList2
-    /// How to operate on the Cons case
-    abstract Cons : int -> 'MyList2 -> 'MyList2
-
-/// Specifies how to perform a fold (catamorphism) over the type MyList2 and its friends.
-type MyList2Cata<'MyList2> =
-    {
-        /// How to perform a fold (catamorphism) over the type MyList2
-        MyList2 : MyList2CataCase<'MyList2>
-    }
-
-/// Methods to perform a catamorphism over the type MyList2
-[<RequireQualifiedAccess>]
-module MyList2Cata =
-    [<RequireQualifiedAccess>]
-    type private Instruction =
-        | Process__MyList2 of MyList2
-        | MyList2_Cons of int
-
-    let private loop (cata : MyList2Cata<_>) (instructions : ResizeArray<Instruction>) =
-        let myList2Stack = ResizeArray ()
-
-        while instructions.Count > 0 do
-            let currentInstruction = instructions.[instructions.Count - 1]
-            instructions.RemoveAt (instructions.Count - 1)
-
-            match currentInstruction with
-            | Instruction.Process__MyList2 x ->
-                match x with
-                | MyList2.Nil -> cata.MyList2.Nil |> myList2Stack.Add
-                | MyList2.Cons (arg0_0, arg1_0) ->
-                    instructions.Add (Instruction.MyList2_Cons (arg0_0))
-                    instructions.Add (Instruction.Process__MyList2 arg1_0)
-            | Instruction.MyList2_Cons (arg0_0) ->
-                let arg1_0 = myList2Stack.[myList2Stack.Count - 1]
-                myList2Stack.RemoveAt (myList2Stack.Count - 1)
-                cata.MyList2.Cons arg0_0 arg1_0 |> myList2Stack.Add
-
-        myList2Stack
-
-    /// Execute the catamorphism.
-    let runMyList2 (cata : MyList2Cata<'MyList2Ret>) (x : MyList2) : 'MyList2Ret =
-        let instructions = ResizeArray ()
-        instructions.Add (Instruction.Process__MyList2 x)
-        let myList2RetStack = loop cata instructions
-        Seq.exactlyOne myList2RetStack

ConsumePlugin/List.fs

@@ -0,0 +1,19 @@
+namespace ConsumePlugin
+
+open WoofWare.Myriad.Plugins
+
+[<CreateCatamorphism "MyListCata">]
+type MyList<'a> =
+    | Nil
+    | Cons of ConsCase<'a>
+
+and ConsCase<'a> =
+    {
+        Head : 'a
+        Tail : MyList<'a>
+    }
+
+[<CreateCatamorphism "MyList2Cata">]
+type MyList2<'a> =
+    | Nil
+    | Cons of 'a * MyList2<'a>

ConsumePlugin/ListCata.fs

@@ -0,0 +1,118 @@
+//------------------------------------------------------------------------------
+//        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 MyListCataCase<'a, 'MyList> =
+    /// How to operate on the Nil case
+    abstract Nil : 'MyList
+    /// How to operate on the Cons case
+    abstract Cons : head : 'a -> tail : 'MyList -> 'MyList
+
+/// Specifies how to perform a fold (catamorphism) over the type MyList and its friends.
+type MyListCata<'a, 'MyList> =
+    {
+        /// How to perform a fold (catamorphism) over the type MyList
+        MyList : MyListCataCase<'a, 'MyList>
+    }
+
+/// Methods to perform a catamorphism over the type MyList
+[<RequireQualifiedAccess>]
+module MyListCata =
+    [<RequireQualifiedAccess>]
+    type private Instruction<'a> =
+        | Process__MyList of MyList<'a>
+        | MyList_Cons of 'a
+
+    let private loop (cata : MyListCata<_, _>) (instructions : ResizeArray<Instruction<_>>) =
+        let myListStack = ResizeArray ()
+
+        while instructions.Count > 0 do
+            let currentInstruction = instructions.[instructions.Count - 1]
+            instructions.RemoveAt (instructions.Count - 1)
+
+            match currentInstruction with
+            | Instruction.Process__MyList x ->
+                match x with
+                | MyList.Nil -> cata.MyList.Nil |> myListStack.Add
+                | MyList.Cons ({
+                                   Head = head
+                                   Tail = tail
+                               }) ->
+                    instructions.Add (Instruction.MyList_Cons (head))
+                    instructions.Add (Instruction.Process__MyList tail)
+            | Instruction.MyList_Cons (head) ->
+                let tail = myListStack.[myListStack.Count - 1]
+                myListStack.RemoveAt (myListStack.Count - 1)
+                cata.MyList.Cons head tail |> myListStack.Add
+
+        myListStack
+
+    /// Execute the catamorphism.
+    let runMyList (cata : MyListCata<'a, 'MyListRet>) (x : MyList<'a>) : 'MyListRet =
+        let instructions = ResizeArray ()
+        instructions.Add (Instruction.Process__MyList x)
+        let myListRetStack = loop cata instructions
+        Seq.exactlyOne myListRetStack
+namespace ConsumePlugin
+
+open WoofWare.Myriad.Plugins
+
+/// Description of how to combine cases during a fold
+type MyList2CataCase<'a, 'MyList2> =
+    /// How to operate on the Nil case
+    abstract Nil : 'MyList2
+    /// How to operate on the Cons case
+    abstract Cons : 'a -> 'MyList2 -> 'MyList2
+
+/// Specifies how to perform a fold (catamorphism) over the type MyList2 and its friends.
+type MyList2Cata<'a, 'MyList2> =
+    {
+        /// How to perform a fold (catamorphism) over the type MyList2
+        MyList2 : MyList2CataCase<'a, 'MyList2>
+    }
+
+/// Methods to perform a catamorphism over the type MyList2
+[<RequireQualifiedAccess>]
+module MyList2Cata =
+    [<RequireQualifiedAccess>]
+    type private Instruction<'a> =
+        | Process__MyList2 of MyList2<'a>
+        | MyList2_Cons of 'a
+
+    let private loop (cata : MyList2Cata<_, _>) (instructions : ResizeArray<Instruction<_>>) =
+        let myList2Stack = ResizeArray ()
+
+        while instructions.Count > 0 do
+            let currentInstruction = instructions.[instructions.Count - 1]
+            instructions.RemoveAt (instructions.Count - 1)
+
+            match currentInstruction with
+            | Instruction.Process__MyList2 x ->
+                match x with
+                | MyList2.Nil -> cata.MyList2.Nil |> myList2Stack.Add
+                | MyList2.Cons (arg0_0, arg1_0) ->
+                    instructions.Add (Instruction.MyList2_Cons (arg0_0))
+                    instructions.Add (Instruction.Process__MyList2 arg1_0)
+            | Instruction.MyList2_Cons (arg0_0) ->
+                let arg1_0 = myList2Stack.[myList2Stack.Count - 1]
+                myList2Stack.RemoveAt (myList2Stack.Count - 1)
+                cata.MyList2.Cons arg0_0 arg1_0 |> myList2Stack.Add
+
+        myList2Stack
+
+    /// Execute the catamorphism.
+    let runMyList2 (cata : MyList2Cata<'a, 'MyList2Ret>) (x : MyList2<'a>) : 'MyList2Ret =
+        let instructions = ResizeArray ()
+        instructions.Add (Instruction.Process__MyList2 x)
+        let myList2RetStack = loop cata instructions
+        Seq.exactlyOne myList2RetStack

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

@@ -8,10 +8,10 @@ open ConsumePlugin
 [<TestFixture>]
 module TestMyList =
 
-    let idCata : MyListCata<_> =
+    let idCata<'a> : MyListCata<'a, _> =
         {
             MyList =
-                { new MyListCataCase<_> with
+                { new MyListCataCase<'a, _> with
                     member _.Nil = MyList.Nil
 
                     member _.Cons head tail =
@@ -26,31 +26,28 @@ module TestMyList =
 
     [<Test>]
     let ``Cata works`` () =
-        let property (x : MyList) = MyListCata.runMyList idCata x = x
+        let property (x : MyList<int>) = MyListCata.runMyList idCata x = x
 
         Check.QuickThrowOnFailure property
 
-    let toListCata =
+    let toListCata<'a> =
         {
             MyList =
-                { new MyListCataCase<int list> with
+                { new MyListCataCase<'a, 'a list> with
                     member _.Nil = []
-                    member _.Cons (head : int) (tail : int list) = head :: tail
+                    member _.Cons (head : 'a) (tail : 'a list) = head :: tail
                 }
         }
 
-    let toListViaCata (l : MyList) : int list = MyListCata.runMyList toListCata l
+    let toListViaCata<'a> (l : MyList<'a>) : 'a list = MyListCata.runMyList toListCata l
 
 
     [<Test>]
     let ``Example of a fold converting to a new data structure`` () =
-        let rec toListNaive (l : MyList) : int list =
+        let rec toListNaive (l : MyList<int>) : int list =
             match l with
             | MyList.Nil -> []
-            | MyList.Cons {
-                              Head = head
-                              Tail = tail
-                          } -> head :: toListNaive tail
+            | MyList.Cons consCell -> consCell.Head :: toListNaive consCell.Tail
 
         Check.QuickThrowOnFailure (fun l -> toListNaive l = toListViaCata l)
 
@@ -62,20 +59,20 @@ module TestMyList =
         let sumCata =
             {
                 MyList =
-                    { new MyListCataCase<int64> with
+                    { new MyListCataCase<int, int64> with
                         member _.Nil = baseCase
                         member _.Cons (head : int) (tail : int64) = atLeaf head tail
                     }
             }
 
-        let viaCata (l : MyList) : int64 = MyListCata.runMyList sumCata l
+        let viaCata (l : MyList<int>) : int64 = MyListCata.runMyList sumCata l
 
-        let viaFold (l : MyList) : int64 =
+        let viaFold (l : MyList<int>) : int64 =
             // choose your favourite "to list" method - here I use the cata
             // but that could have been done naively
             (toListViaCata l, baseCase)
             ||> List.foldBack (fun elt state -> atLeaf elt state)
 
-        let property (l : MyList) = viaCata l = viaFold l
+        let property (l : MyList<int>) = viaCata l = viaFold l
 
         Check.QuickThrowOnFailure property

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

@@ -8,10 +8,10 @@ open ConsumePlugin
 [<TestFixture>]
 module TestMyList2 =
 
-    let idCata : MyList2Cata<_> =
+    let idCata<'a> : MyList2Cata<'a, _> =
         {
             MyList2 =
-                { new MyList2CataCase<_> with
+                { new MyList2CataCase<'a, _> with
                     member _.Nil = MyList2.Nil
 
                     member _.Cons head tail = MyList2.Cons (head, tail)
@@ -21,6 +21,6 @@ module TestMyList2 =
 
     [<Test>]
     let ``Cata works`` () =
-        let property (x : MyList2) = MyList2Cata.runMyList2 idCata x = x
+        let property (x : MyList2<int>) = MyList2Cata.runMyList2 idCata x = x
 
         Check.QuickThrowOnFailure property

WoofWare.Myriad.Plugins/AstHelper.fs

@@ -400,9 +400,28 @@ module internal AstHelper =
             Accessibility = accessibility
         }
 
-    let getUnionCases (SynTypeDefn.SynTypeDefn (_, repr, _, _, _, _)) : AdtProduct list =
+    let getUnionCases
+        (SynTypeDefn.SynTypeDefn (info, repr, _, _, _, _))
+        : AdtProduct list * SynTyparDecl list * SynAccess option
+        =
+        let typars, access =
+            match info with
+            | SynComponentInfo (_, typars, _, _, _, _, access, _) -> typars, access
+
+        let typars =
+            match typars with
+            | None -> []
+            | Some (SynTyparDecls.PrefixList (decls, _)) -> decls
+            | Some (SynTyparDecls.SinglePrefix (l, _)) -> [ l ]
+            | Some (SynTyparDecls.PostfixList (decls, constraints, _)) ->
+                if not constraints.IsEmpty then
+                    failwith "Constrained type parameters not currently supported"
+
+                decls
+
         match repr with
         | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (_, cases, _), _) ->
+            let cases =
                 cases
                 |> List.map (fun (SynUnionCase.SynUnionCase (_, ident, kind, _, _, _, _)) ->
                     match kind with
@@ -420,6 +439,8 @@ module internal AstHelper =
                                 )
                         }
                 )
+
+            cases, typars, access
         | _ -> failwithf "Failed to get union cases for type that was: %+A" repr
 
     let getRecordFields (SynTypeDefn.SynTypeDefn (_, repr, _, _, _, _)) : AdtNode list =

WoofWare.Myriad.Plugins/CataGenerator.fs

@@ -35,6 +35,8 @@ module internal CataGenerator =
             /// The relationship this field has with the parent type (or the
             /// recursive knot of parent types)
             Description : FieldDescription
+            /// Any generic parameters this field consumes
+            RequiredGenerics : SynType list option
         }
 
     type CataUnionRecordField = (Ident * CataUnionBasicField) list
@@ -81,6 +83,8 @@ module internal CataGenerator =
     /// recursive knot), this is everything we need to know about it for the cata.
     type UnionAnalysis =
         {
+            Accessibility : SynAccess option
+            Typars : SynTyparDecl list
             /// The name of the stack we'll use for the results
             /// of returning from a descent into this union type,
             /// when performing the cata
@@ -112,7 +116,8 @@ module internal CataGenerator =
     ///     Seq.exactlyOne {relevantTypar}Stack
     let createRunFunction
         (cataName : Ident)
-        (allTypars : SynType list)
+        (userProvidedTypars : SynTyparDecl list)
+        (allArtificialTypars : SynType list)
         (relevantTypar : SynType)
         (unionType : SynTypeDefn)
         : SynBinding
@@ -121,19 +126,58 @@ module internal CataGenerator =
             match unionType with
             | SynTypeDefn.SynTypeDefn (SynComponentInfo.SynComponentInfo (longId = id), _, _, _, _, _) -> List.last id
 
-        let allTyparNames =
-            allTypars
+        let allArtificialTyparNames =
+            allArtificialTypars
             |> List.map (fun ty ->
                 match ty with
                 | SynType.Var (SynTypar.SynTypar (ident = ident), _) -> ident
                 | _ -> failwith "logic error in generator"
             )
 
+        let userProvidedTypars =
+            userProvidedTypars
+            |> List.map (fun (SynTyparDecl.SynTyparDecl (_, ty)) -> SynType.Var (ty, range0))
+
         let relevantTyparName =
             match relevantTypar with
             | SynType.Var (SynTypar.SynTypar (ident = ident), _) -> ident
             | _ -> failwith "logic error in generator"
 
+        let inputObjectType =
+            let baseType =
+                SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ relevantTypeName ])
+
+            if userProvidedTypars.Length = 0 then
+                baseType
+            else
+                SynType.App (
+                    baseType,
+                    Some range0,
+                    userProvidedTypars,
+                    List.replicate (userProvidedTypars.Length - 1) range0,
+                    Some range0,
+                    false,
+                    range0
+                )
+
+        // The object on which we'll run the cata
+        let inputObject =
+            SynPat.CreateTyped (SynPat.CreateNamed (Ident.Create "x"), inputObjectType)
+
+        let cataObject =
+            SynPat.CreateTyped (
+                SynPat.CreateNamed (Ident.Create "cata"),
+                SynType.App (
+                    SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ cataName ]),
+                    Some range0,
+                    userProvidedTypars @ allArtificialTypars,
+                    List.replicate (userProvidedTypars.Length + allArtificialTypars.Length - 1) range0,
+                    Some range0,
+                    false,
+                    range0
+                )
+            )
+
         SynBinding.SynBinding (
             None,
             SynBindingKind.Normal,
@@ -151,28 +195,7 @@ module internal CataGenerator =
             ),
             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 ])
-                        )
-                    )
-                ]
+                [ SynPat.CreateParen (cataObject) ; SynPat.CreateParen inputObject ]
             ),
             Some (SynBindingReturnInfo.Create relevantTypar),
             SynExpr.CreateTyped (
@@ -219,8 +242,8 @@ module internal CataGenerator =
                                                             Ident.Create (t.idText + "Stack") |> Ident.lowerFirstLetter
                                                         )
                                                     )
-                                                    allTyparNames,
-                                                List.replicate (allTypars.Length - 1) range0,
+                                                    allArtificialTyparNames,
+                                                List.replicate (allArtificialTyparNames.Length - 1) range0,
                                                 range0
                                             ),
                                         expr =
@@ -262,9 +285,10 @@ module internal CataGenerator =
         match ty with
         | SynTypeDefn.SynTypeDefn (SynComponentInfo.SynComponentInfo (_, _, _, id, _, _, _, _), _, _, _, _, _) -> id
 
-    let getNameUnion (unionType : SynType) : LongIdent option =
+    let rec getNameUnion (unionType : SynType) : LongIdent option =
         match unionType with
         | SynType.LongIdent (SynLongIdent.SynLongIdent (name, _, _)) -> Some name
+        | SynType.App (ty, _, _, _, _, _, _) -> getNameUnion ty
         | _ -> None
 
     let getNameKey (ty : SynTypeDefn) : string =
@@ -286,44 +310,8 @@ module internal CataGenerator =
         : CataUnionBasicField list
         =
         let rec go (prefix : string) (name : Ident option) (ty : SynType) : CataUnionBasicField =
-            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 dealWithPrimitive (typeArgs : SynType list option) (ty : SynType) (typeName : LongIdent) =
+                let key = typeName |> List.map _.idText |> String.concat "/"
 
                 let isKnownUnion =
                     allUnionTypes |> List.exists (fun unionTy -> getNameKey unionTy = key)
@@ -339,9 +327,28 @@ module internal CataGenerator =
                             match name with
                             | Some n -> Ident.lowerFirstLetter n
                             | None -> Ident.Create $"arg%s{prefix}"
-                        Description = FieldDescription.Self stripped
+                        Description = FieldDescription.Self ty
+                        RequiredGenerics = typeArgs
                     }
                 else
+                    {
+                        FieldName = name
+                        ArgName =
+                            match name with
+                            | Some n -> Ident.lowerFirstLetter n
+                            | None -> Ident.Create $"arg%s{prefix}"
+                        Description = FieldDescription.NonRecursive ty
+                        RequiredGenerics = typeArgs
+                    }
+
+            let rec dealWithType (typeArgs : SynType list option) (stripped : SynType) =
+                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 =
@@ -349,10 +356,50 @@ module internal CataGenerator =
                                 | Some n -> Ident.lowerFirstLetter n
                                 | None -> Ident.Create $"arg%s{prefix}"
                             Description = FieldDescription.NonRecursive stripped
+                            RequiredGenerics = typeArgs
+                        }
+                    | FieldDescription.Self ty ->
+                        {
+                            FieldName = name
+                            ArgName =
+                                match name with
+                                | Some n -> Ident.lowerFirstLetter n
+                                | None -> Ident.Create $"arg%s{prefix}"
+                            Description = FieldDescription.ListSelf ty
+                            RequiredGenerics = typeArgs
+                        }
+                    | 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
+                        RequiredGenerics = typeArgs
+                    }
+                | SynType.App (ty, _, childTypeArgs, _, _, _, _) ->
+                    match typeArgs with
+                    | Some _ -> failwithf "Nested applications of types not supported in %+A" ty
+                    | None -> dealWithType (Some childTypeArgs) (SynType.stripOptionalParen ty)
+                | SynType.LongIdent (SynLongIdent.SynLongIdent (ty, _, _)) -> dealWithPrimitive typeArgs stripped ty
+                | SynType.Var (typar, _) ->
+                    {
+                        FieldName = name
+                        ArgName =
+                            match name with
+                            | Some n -> Ident.lowerFirstLetter n
+                            | None -> Ident.Create $"arg%s{prefix}"
+                        Description = FieldDescription.NonRecursive ty
+                        RequiredGenerics = typeArgs
                     }
 
                 | _ -> failwithf "Unrecognised type: %+A" stripped
 
+            let stripped = SynType.stripOptionalParen ty
+            dealWithType None 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
@@ -432,7 +479,26 @@ module internal CataGenerator =
                 Fields =
                     {
                         Name = None
-                        Type = SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent union.ParentTypeName)
+                        Type =
+                            let name =
+                                SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent union.ParentTypeName)
+
+                            match union.Typars with
+                            | [] -> name
+                            | typars ->
+                                let typars =
+                                    typars
+                                    |> List.map (fun (SynTyparDecl (_, typar)) -> SynType.Var (typar, range0))
+
+                                SynType.App (
+                                    name,
+                                    Some range0,
+                                    typars,
+                                    List.replicate (typars.Length - 1) range0,
+                                    Some range0,
+                                    false,
+                                    range0
+                                )
                     }
                     |> List.singleton
             }
@@ -461,10 +527,20 @@ module internal CataGenerator =
 
         let cases = casesFromProcess @ casesFromCases
 
+        let typars =
+            // TODO: deduplicate names where we have the same generic across multiple DUs
+            analysis
+            |> List.collect _.Typars
+            |> fun x ->
+                if x.IsEmpty then
+                    None
+                else
+                    Some (SynTyparDecls.PostfixList (x, [], range0))
+
         SynTypeDefn.SynTypeDefn (
             SynComponentInfo.SynComponentInfo (
                 [ SynAttributeList.Create [ SynAttribute.RequireQualifiedAccess () ] ],
-                None,
+                typars,
                 [],
                 [ Ident.Create "Instruction" ],
                 PreXmlDoc.Empty,
@@ -514,7 +590,7 @@ module internal CataGenerator =
             let componentInfo =
                 SynComponentInfo.SynComponentInfo (
                     [],
-                    Some (SynTyparDecls.PostfixList (orderedGenerics, [], range0)),
+                    Some (SynTyparDecls.PostfixList (analysis.Typars @ orderedGenerics, [], range0)),
                     [],
                     [ analysis.CataTypeName ],
                     // TODO: better docstring
@@ -625,30 +701,32 @@ module internal CataGenerator =
     /// Build a record which contains one of every cata type.
     /// That is, define a type Cata<{'ret<U> for U in T}>
     /// with one member for each U, namely of type [U]Cata<{'ret<U> for U in T}>.
-    // TODO: this should take an analysis instead
-    let createCataRecord (cataName : Ident) (doc : PreXmlDoc) (allUnionTypes : SynTypeDefn list) : SynTypeDefn =
+    let createCataRecord (cataName : Ident) (doc : PreXmlDoc) (analysis : UnionAnalysis list) : SynTypeDefn =
+        // An artificial generic for each union type
         let generics =
-            allUnionTypes
-            |> List.map (fun defn ->
-                let name = getName defn |> List.map _.idText |> String.concat "" |> Ident.Create
-                SynTypar.SynTypar (name, TyparStaticReq.None, false)
-            )
+            analysis
+            |> List.map (fun analysis -> SynTypar.SynTypar (analysis.GenericName, TyparStaticReq.None, false))
 
+        // A field for each cata
         let fields =
-            allUnionTypes
-            |> List.map (fun unionType ->
-                let nameForDoc = List.last (getName unionType) |> _.idText
+            analysis
+            |> List.map (fun analysis ->
+                let nameForDoc = List.last(analysis.ParentTypeName).idText
 
                 let doc =
                     PreXmlDoc.Create $" How to perform a fold (catamorphism) over the type %s{nameForDoc}"
 
-                let name = getName unionType
+                let artificialGenerics = generics |> List.map (fun v -> SynType.Var (v, range0))
+
+                let userInputGenerics =
+                    analysis.Typars
+                    |> List.map (fun (SynTyparDecl.SynTyparDecl (_, typar)) -> SynType.Var (typar, range0))
 
                 let ty =
                     SynType.App (
-                        SynType.CreateLongIdent (SynLongIdent.CreateString (List.last(name).idText + "CataCase")),
+                        SynType.LongIdent (SynLongIdent.CreateFromLongIdent [ analysis.CataTypeName ]),
                         Some range0,
-                        generics |> List.map (fun v -> SynType.Var (v, range0)),
+                        userInputGenerics @ artificialGenerics,
                         List.replicate (generics.Length - 1) range0,
                         Some range0,
                         false,
@@ -658,7 +736,7 @@ module internal CataGenerator =
                 SynField.SynField (
                     [],
                     false,
-                    Some (List.last name),
+                    Some (List.last analysis.ParentTypeName),
                     ty,
                     false,
                     doc,
@@ -670,16 +748,21 @@ module internal CataGenerator =
                 )
             )
 
+        // A "real" generic for each generic in the user-provided type
+        let genericsFromUserInput =
+            analysis
+            |> List.collect (fun analysis ->
+                // TODO: deduplicate generics with the same name from different cases
+                analysis.Typars
+            )
+
+        let genericsFromCata =
+            generics |> List.map (fun ty -> SynTyparDecl.SynTyparDecl ([], ty))
+
         let componentInfo =
             SynComponentInfo.SynComponentInfo (
                 [],
-                Some (
-                    SynTyparDecls.PostfixList (
-                        generics |> List.map (fun ty -> SynTyparDecl.SynTyparDecl ([], ty)),
-                        [],
-                        range0
-                    )
-                ),
+                Some (SynTyparDecls.PostfixList (genericsFromUserInput @ genericsFromCata, [], range0)),
                 [],
                 [ cataName ],
                 doc,
@@ -714,13 +797,20 @@ module internal CataGenerator =
 
         allUnionTypes
         |> List.map (fun unionType ->
+            let cases, typars, access = AstHelper.getUnionCases unionType
+
             let cases =
-                AstHelper.getUnionCases unionType
+                cases
                 |> List.map (fun prod ->
                     let fields =
                         prod.Fields
                         |> List.indexed
                         |> List.collect (fun (i, node) ->
+                            let availableGenerics =
+                                match node.Type with
+                                | SynType.App (_, _, vars, _, _, _, _) -> vars
+                                | _ -> []
+
                             match getNameUnion node.Type with
                             | None ->
                                 analyse allRecordTypes allUnionTypes i [ node ] |> List.map CataUnionField.Basic
@@ -742,6 +832,8 @@ module internal CataGenerator =
             let unionTypeName = getName unionType
 
             {
+                Typars = typars
+                Accessibility = access
                 StackName =
                     List.last(getName unionType).idText + "Stack"
                     |> Ident.Create
@@ -1218,6 +1310,23 @@ module internal CataGenerator =
                 None
             )
 
+        // A generic for each DU case, and a generic for each generic in the DU
+        let genericCount = analysis.Length + (analysis |> List.sumBy _.Typars.Length)
+
+        let instructionsArrType =
+            if genericCount > analysis.Length then
+                SynType.App (
+                    SynType.CreateLongIdent "Instruction",
+                    Some range0,
+                    List.replicate (genericCount - analysis.Length) (SynType.Anon range0),
+                    List.replicate (genericCount - analysis.Length - 1) range0,
+                    Some range0,
+                    false,
+                    range0
+                )
+            else
+                SynType.CreateLongIdent "Instruction"
+
         let headPat =
             SynPat.LongIdent (
                 SynLongIdent.CreateString "loop",
@@ -1231,8 +1340,8 @@ module internal CataGenerator =
                                 SynType.App (
                                     SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ cataTypeName ]),
                                     Some range0,
-                                    List.replicate analysis.Length (SynType.Anon range0),
-                                    List.replicate (analysis.Length - 1) range0,
+                                    List.replicate genericCount (SynType.Anon range0),
+                                    List.replicate (genericCount - 1) range0,
                                     Some range0,
                                     false,
                                     range0
@@ -1245,7 +1354,7 @@ module internal CataGenerator =
                                 SynType.App (
                                     SynType.CreateLongIdent "ResizeArray",
                                     Some range0,
-                                    [ SynType.CreateLongIdent "Instruction" ],
+                                    [ instructionsArrType ],
                                     [],
                                     Some range0,
                                     false,
@@ -1404,6 +1513,9 @@ module internal CataGenerator =
                 xmldoc = PreXmlDoc.Create $" Methods to perform a catamorphism over the type %s{parentName}"
             )
 
+        let cataVarName = Ident.Create "cata"
+        let analysis = makeUnionAnalyses cataVarName allRecordTypes allUnionTypes
+
         let allTypars =
             allUnionTypes
             |> List.map (fun unionType ->
@@ -1414,12 +1526,14 @@ module internal CataGenerator =
                 |> fun x -> SynType.Var (x, range0)
             )
 
+        let userProvidedGenerics = analysis |> List.collect (fun x -> x.Typars)
+
         let runFunctions =
             List.zip allUnionTypes allTypars
-            |> List.map (fun (unionType, relevantTypar) -> createRunFunction cataName allTypars relevantTypar unionType)
+            |> List.map (fun (unionType, relevantTypar) ->
+                createRunFunction cataName userProvidedGenerics allTypars relevantTypar unionType
+            )
 
-        let cataVarName = Ident.Create "cata"
-        let analysis = makeUnionAnalyses cataVarName allRecordTypes allUnionTypes
 
         let cataStructures =
             createCataStructure analysis
@@ -1432,7 +1546,7 @@ module internal CataGenerator =
                 $" Specifies how to perform a fold (catamorphism) over the type %s{parentName} and its friends."
 
         let cataRecord =
-            SynModuleDecl.Types ([ createCataRecord cataName recordDoc allUnionTypes ], range0)
+            SynModuleDecl.Types ([ createCataRecord cataName recordDoc analysis ], range0)
 
         SynModuleOrNamespace.CreateNamespace (
             ns,
@@ -1453,14 +1567,7 @@ module internal CataGenerator =
                 ]
         )
 
-/// Myriad generator that provides a catamorphism for an algebraic data type.
-[<MyriadGenerator("create-catamorphism")>]
-type CreateCatamorphismGenerator () =
-
-    interface IMyriadGenerator with
-        member _.ValidInputExtensions = [ ".fs" ]
-
-        member _.Generate (context : GeneratorContext) =
+    let generate (context : GeneratorContext) : Output =
         let ast, _ =
             Ast.fromFilename context.InputFilename |> Async.RunSynchronously |> Array.head
 
@@ -1504,8 +1611,15 @@ type CreateCatamorphismGenerator () =
 
         let modules =
             namespaceAndTypes
-                |> List.map (fun (ns, taggedType, unions, records) ->
-                    CataGenerator.createModule opens ns taggedType unions records
-                )
+            |> List.map (fun (ns, taggedType, unions, records) -> createModule opens ns taggedType unions records)
 
         Output.Ast modules
+
+/// Myriad generator that provides a catamorphism for an algebraic data type.
+[<MyriadGenerator("create-catamorphism")>]
+type CreateCatamorphismGenerator () =
+
+    interface IMyriadGenerator with
+        member _.ValidInputExtensions = [ ".fs" ]
+
+        member _.Generate (context : GeneratorContext) = CataGenerator.generate context