Fix a bug in the cata (#98)

ConsumePlugin/FSharpForFunAndProfitCata.fs

@@ -50,3 +50,14 @@ 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
+    }

ConsumePlugin/GeneratedFileSystem.fs

@@ -150,3 +150,59 @@ 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

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

@@ -0,0 +1,81 @@
+namespace WoofWare.Myriad.Plugins.Test
+
+open NUnit.Framework
+open FsCheck
+open FsUnitTyped
+open ConsumePlugin
+
+[<TestFixture>]
+module TestMyList =
+
+    let idCata : MyListCata<_> =
+        {
+            MyList =
+                { new MyListCataCase<_> with
+                    member _.Nil = MyList.Nil
+
+                    member _.Cons head tail =
+                        MyList.Cons
+                            {
+                                Head = head
+                                Tail = tail
+                            }
+                }
+
+        }
+
+    [<Test>]
+    let ``Cata works`` () =
+        let property (x : MyList) = MyListCata.runMyList idCata x = x
+
+        Check.QuickThrowOnFailure property
+
+    let toListCata =
+        {
+            MyList =
+                { new MyListCataCase<int list> with
+                    member _.Nil = []
+                    member _.Cons (head : int) (tail : int list) = head :: tail
+                }
+        }
+
+    let toListViaCata (l : MyList) : int list = MyListCata.runMyList toListCata l
+
+
+    [<Test>]
+    let ``Example of a fold converting to a new data structure`` () =
+        let rec toListNaive (l : MyList) : int list =
+            match l with
+            | MyList.Nil -> []
+            | MyList.Cons {
+                              Head = head
+                              Tail = tail
+                          } -> head :: toListNaive tail
+
+        Check.QuickThrowOnFailure (fun l -> toListNaive l = toListViaCata l)
+
+    [<Test>]
+    let ``Example of equivalence with FoldBack`` () =
+        let baseCase = 0L
+        let atLeaf (head : int) (tail : int64) : int64 = int64 head + tail
+
+        let sumCata =
+            {
+                MyList =
+                    { new MyListCataCase<int64> with
+                        member _.Nil = baseCase
+                        member _.Cons (head : int) (tail : int64) = atLeaf head tail
+                    }
+            }
+
+        let viaCata (l : MyList) : int64 = MyListCata.runMyList sumCata l
+
+        let viaFold (l : MyList) : 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
+
+        Check.QuickThrowOnFailure property

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

@@ -25,6 +25,7 @@
     <Compile Include="TestCataGenerator\TestCataGenerator.fs" />
     <Compile Include="TestCataGenerator\TestDirectory.fs" />
     <Compile Include="TestCataGenerator\TestGift.fs" />
+    <Compile Include="TestCataGenerator\TestMyList.fs" />
     <Compile Include="TestRemoveOptions.fs"/>
     <Compile Include="TestSurface.fs"/>
     <None Include="../.github/workflows/dotnet.yaml" />

WoofWare.Myriad.Plugins/CataGenerator.fs

@@ -810,7 +810,7 @@ module internal CataGenerator =
                     )
 
                 let matchBody =
-                    if nonRecursiveArgs.Length = unionCase.Fields.Length then
+                    if nonRecursiveArgs.Length = unionCase.FlattenedFields.Length then
                         // directly call the cata
                         callCataAndPushResult analysis.StackName unionCase
                     else
@@ -821,7 +821,7 @@ module internal CataGenerator =
                     let reprocessCommand =
                         SynExpr.CreateApp (
                             SynExpr.CreateLongIdent (SynLongIdent.Create [ "instructions" ; "Add" ]),
-                            if selfArgs.Length = unionCase.Fields.Length then
+                            if selfArgs.Length = unionCase.FlattenedFields.Length then
                                 SynExpr.CreateLongIdent unionCase.AssociatedInstruction
                             else
                                 // We need to tell ourselves each non-rec arg, and the length of each input list.
@@ -906,35 +906,35 @@ module internal CataGenerator =
                     ]
                     |> 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)
-                                                )
+                let matchLhs =
+                    if unionCase.Fields.Length > 0 then
+                        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
-                                )
+                                        SynPat.Record (fields, range0)
+                                ),
+                                List.replicate (unionCase.Fields.Length - 1) range0,
+                                range0
                             )
-                        ]
-                    ),
+                        )
+                        |> List.singleton
+                    else
+                        []
+
+                SynMatchClause.SynMatchClause (
+                    SynPat.CreateLongIdent (unionCase.Match, matchLhs),
                     None,
                     matchBody,
                     range0,