patrick/WoofWare.Myriad
1
0
Fork 0
mirror of https://github.com/Smaug123/WoofWare.Myriad synced 2025-10-11 06:58:42 +00:00
Code Issues Packages Projects Releases Wiki Activity

Absolute bare-bones support for generics in cata (#101)

Browse Source
This commit is contained in:
Patrick Stevens
2024-02-19 00:57:14 +00:00
committed by GitHub
parent 3209372b5b
commit 7b49505064
13 changed files with 648 additions and 372 deletions
Download Patch File Download Diff File Expand all files Collapse all files

20
ConsumePlugin/Catamorphism.fs
View File

@@ -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, 'b> =
| Const of Const<'a> * 'b
| Pair of Tree<'a, 'b> * Tree<'a, 'b> * PairOpKind
| Sequential of Tree<'a, 'b> list
| Builder of Tree<'a, 'b> * TreeBuilder<'b, 'a>
and TreeBuilder =
| Child of TreeBuilder
| Parent of Tree
and TreeBuilder<'b, 'a> =
| Child of TreeBuilder<'b, 'a>
| Parent of Tree<'a, 'b>

4
ConsumePlugin/ConsumePlugin.fsproj
View File

@@ -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>

16
ConsumePlugin/FSharpForFunAndProfitCata.fs
View File

@@ -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

34
ConsumePlugin/GeneratedCatamorphism.fs
View File

@@ -12,16 +12,16 @@ namespace ConsumePlugin
open WoofWare.Myriad.Plugins
/// Description of how to combine cases during a fold
type TreeBuilderCataCase<'TreeBuilder, 'Tree> =
type TreeBuilderCataCase<'b, '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, 'b, 'TreeBuilder, 'Tree> =
/// How to operate on the Const case
abstract Const : Const -> 'Tree
abstract Const : Const<'a> -> 'b -> 'Tree
/// How to operate on the Pair case
abstract Pair : 'Tree -> 'Tree -> PairOpKind -> 'Tree
/// How to operate on the Sequential case
@@ -30,30 +30,30 @@ 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<'b, 'a, 'TreeBuilder, 'Tree> =
{
/// How to perform a fold (catamorphism) over the type TreeBuilder
TreeBuilder : TreeBuilderCataCase<'TreeBuilder, 'Tree>
TreeBuilder : TreeBuilderCataCase<'b, 'a, 'TreeBuilder, 'Tree>
/// How to perform a fold (catamorphism) over the type Tree
Tree : TreeCataCase<'TreeBuilder, 'Tree>
Tree : TreeCataCase<'a, 'b, '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<'b, 'a> =
| Process__TreeBuilder of TreeBuilder<'b, 'a>
| Process__Tree of Tree<'a, 'b>
| 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 ()
let private loop (cata : TreeCata<'b, 'a, 'TreeBuilder, 'Tree>) (instructions : ResizeArray<Instruction<'b, 'a>>) =
let treeStack = ResizeArray<'Tree> ()
let treeBuilderStack = ResizeArray<'TreeBuilder> ()
while instructions.Count > 0 do
let currentInstruction = instructions.[instructions.Count - 1]
@@ -70,7 +70,7 @@ module TreeCata =
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.Const (arg0_0, arg1_0) -> cata.Tree.Const arg0_0 arg1_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)
@@ -120,14 +120,18 @@ module TreeCata =
treeBuilderStack, treeStack
/// Execute the catamorphism.
let runTreeBuilder (cata : TreeCata<'TreeBuilderRet, 'TreeRet>) (x : TreeBuilder) : 'TreeBuilderRet =
let runTreeBuilder
(cata : TreeCata<'b, 'a, 'TreeBuilderRet, 'TreeRet>)
(x : TreeBuilder<'b, '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<'b, 'a, 'TreeBuilderRet, 'TreeRet>) (x : Tree<'a, 'b>) : 'TreeRet =
let instructions = ResizeArray ()
instructions.Add (Instruction.Process__Tree x)
let treeBuilderRetStack, treeRetStack = loop cata instructions

117
ConsumePlugin/GeneratedFileSystem.fs
View File

@@ -33,8 +33,8 @@ module FileSystemItemCata =
| Process__FileSystemItem of FileSystemItem
| FileSystemItem_Directory of string * int * int
let private loop (cata : FileSystemCata<_>) (instructions : ResizeArray<Instruction>) =
let fileSystemItemStack = ResizeArray ()
let private loop (cata : FileSystemCata<'FileSystemItem>) (instructions : ResizeArray<Instruction>) =
let fileSystemItemStack = ResizeArray<'FileSystemItem> ()
while instructions.Count > 0 do
let currentInstruction = instructions.[instructions.Count - 1]
@@ -108,8 +108,8 @@ module GiftCata =
| Gift_Boxed
| Gift_WithACard of string
let private loop (cata : GiftCata<_>) (instructions : ResizeArray<Instruction>) =
let giftStack = ResizeArray ()
let private loop (cata : GiftCata<'Gift>) (instructions : ResizeArray<Instruction>) =
let giftStack = ResizeArray<'Gift> ()
while instructions.Count > 0 do
let currentInstruction = instructions.[instructions.Count - 1]
@@ -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

19
ConsumePlugin/List.fs Normal file
View File

@@ -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>

118
ConsumePlugin/ListCata.fs Normal file
View File

@@ -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<'a, 'MyList>) (instructions : ResizeArray<Instruction<'a>>) =
let myListStack = ResizeArray<'MyList> ()
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<'a, 'MyList2>) (instructions : ResizeArray<Instruction<'a>>) =
let myList2Stack = ResizeArray<'MyList2> ()
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