semigroup1.flx

class CT
{
    class Semigroup[T,U] {
        virtual fun \circ : T * T -> T;
    }

    class Monoid[T,U] { 
        inherit Semigroup[T,U];
        virtual fun id : () -> T;

        fun mfold (x : list[T]):T => match x with
            | #Empty => #id
            | first ! rest => first \circ (mfold rest)
            endmatch;
    }

}

class App1 
{
    open CT;

    type Addition = new int;
    type Addition2 = new int;
    instance Semigroup[int, Addition] {fun \circ (a : int, b:int):int => a + b;}
    instance Semigroup[int, Addition2] {fun \circ (a : int, b:int):int => a + b;}
    instance Monoid[int, Addition] {fun id() => 0;}

    typedef Multiplication = (multiplication:unit);
    instance Semigroup[int, Multiplication] {fun \circ (a : int, b:int):int => a * b;}
    instance Monoid[int, Multiplication] {fun id() => 1;}


    class MultCategory{
        open Semigroup[int, Multiplication];
        open Monoid[int, Multiplication];

        println "Mult:";
        println $ 5 \circ 2;
        println $ ((5 \circ 3) \circ 2) \circ #id;
        println $ mfold $ list (5, 10, 2, 100, 30, 7);
        println "";
    }

    class AdditionCategory {
        open Semigroup[int, Addition];
        open Monoid[int, Addition];

        var objects = list (1,2,3,4);
        var morphisms = (
            foo=(fun(x:int) => x + 2)
        );

        println "Add:";
        println $ 5 \circ 2;
        println $ ((5 \circ 3) \circ 2) \circ #id;
        println $ mfold $ list (5, 10, 2, 100, 30, 7);
        println $ morphisms.foo(3);
        println "";

    }

    class OneAboveCat {
        // the category of objects are always one above normal
        open AdditionCategory;

        fun functor(x:int) => x + 1;

        objects = map functor objects;
        //morphisms = map functor morphisms;
    }

    class FunctorTest {
        // TODO
        println$ AdditionCategory::morphisms.foo(8);
        println$ AdditionCategory::objects;
    }
}

semigroup2.flx

class CT
{
    object Semigroup[T] (op: T * T -> T) = {
        method fun compose (a:T, b:T) => op (a, b);
    }

    object Monoid[T] (op: T * T -> T, ident:T)
        extends Semigroup[T] (op) as var super =
    {
        method fun id():T => ident;
        method fun mfold : list[T] -> T =
            | #Empty => #id
            | first ! rest => super.compose (first, (mfold rest));
    }

    object Functor[T,U] (f : T -> U) = {
        method fun fmap(x:list[T]) => map f x;
    }

    object Monad[T,U,V] (_bind: U * (T -> V) -> U, _ret: T -> U) = {
        method fun flatMap(a:U, f: T -> V): U => _bind(a,f);
        method fun ret(a: T): U => _ret(a);
    }

}

class App1 
{
    open CT;

    // creating our composition function ahead of time
    fun add(x:int, y:int) => x + y;

    // first create a monoid (passing in composition function and identity)
    var m = Monoid[int]( add, 0 );

    // note: we can make more than one Monoid over integers!

    // make a category by equiping the monoid wth objects and arrows
    var c = extend m with ( 
        obj = list(1,2,3),
        arr = (one=(fun(x:int)=>x+1)))
    end;

    // see, it works!
    println$ m.compose (1, 1);
    println$ m.mfold$ list$ 1,2,3,4,5;
    println$ c.mfold c.obj;

    // Here's an example over multiplication
    fun mult(x:int, y:int) => x * y;
    var MultMon = Monoid[int]( mult, 1 );
    println$ MultMon.mfold $ list (1,2,3,4,5);

    // let's try functors -------

    // functor law 1: An identity functor must return the same objects
    fun identity[T](x:T) => x;
    var data = list(1,2,3,4,5);
    var f_id = Functor[int,int]( identity[int] );
    println$ data == f_id.fmap data;  // valid 

    // functor law 2: composition of functions is the same as composition of functors
    fun addTwo(x:int) => x + 2;
    fun timesThree(x:int) => x * 3;
    fun comp(x:int) => timesThree(addTwo(x));

    var f1 = Functor[int,int](addTwo);
    var f2 = Functor[int,int](timesThree);
    var f3 = Functor[int,int](comp);
    var o1 = f2.fmap $ f1.fmap data;
    var o2 = f3.fmap data;
    println$ o1 == o2; // valid


    // on to Monads!
    fun bind(x:opt[int], f: int -> opt[int]):opt[int] =>
        match x with
        | #None => None[int]
        | Some(a) => f(a)
        endmatch;
    fun assoc(x:opt[int], y:opt[int]) => bind(x, (fun(z:int) => y));
    fun ret (x:int) => Some(x);

    // a monad!
    var x3 =
        bind( Some(3), (fun (x:int) =>
              bind( Some(1), (fun (y:int) =>
                     ret(x + y)
              ))
        ));

    println $
        match x3 with
        | #None => 0
        | Some (x) => x
        endmatch;

    syntax monad //Override the right shift assignment operator.
    {
        x[ssetunion_pri] := x[ssetunion_pri] ">>=" x[>ssetunion_pri]
                     =># "`(ast_apply ,_sr (bind (,_1 ,_3)))";
    }
    open syntax monad;

    class Try {
        method fun add(x:int) (y:int) : opt[int] =>
            if (x > 0)
               then Some(x + y)
               else None[int];
    }
           
    // using haskell bind syntax
    var n = Some(300)
        >>= Try::add(23)
        >>= Try::add(100) // forces sequence to fail
        >>= Try::add(10);
    println$ n;

}