(* <Pre> *)

(* Safe reduction under lambda *)

val ex1 = <(fn x => x + 1) 6>;

val ex2 = <(fn x => x + 1) (5+1) >;

val ex3 = <(fn f => f 4) (fn x => x + 1)>;

(* safe eta *)

val ex5 = <fn x => rev x>;

val ex6 = <fn f => (fn x => f x)>;

val ex7 = <fn x => append [1] x>;

fun app1 x = append [1] x;

val ex7 = <fn x => app1 x>;

(* let hoisting *)

val ex8 = <let val x = 1 and y = 2 in x + y end>;            (* Needs Flattening *)
val ex9 = <let val x = 1 in let val y = 2 in x + y end end>; (* Needs Unnesting *)
val ex10 = <let val y = (let val x = 1 in 2 end) in y end>; (* Needs Hoisting *)


(* use of force *)
val  ex11 =  force <fn f => f 4> <fn x => x + 1>;

val ex12 = force <fn (x::xs) => xs> <[1,2,3]>;

val ex13 = force <fn (x::xs) => xs> <[]>;

(* **************************************************** *)
(* Recall how monads are defined in MetaML
datatype ('M : * -> * ) Monad = Mon of
    (['a]. 'a -> 'a 'M) * (['a,'b]. 'a 'M -> ('a -> 'b 'M) -> 'b 'M);
*)

(* Think of a simple IO monad with just input and output *)

datatype 'x Io = Io of (string -> ('x * string * string))

fun unit x = (Io (fn input => (x,input,"")));
fun bind (Io f) g = 
   let fun h input = 
           let val (x1,in1,out1) = f input
               val (Io i) = g x1
               val (x2,in2,out2) = i in1
           in (x2,in2,out1^out2) end
   in (Io h) end;
val io = Mon (unit,bind);

(* Now lift this to the meta-level *)
datatype 'x MIo = M of (<char list> -> <('x * char list * char list)>);

fun return x = M(fn s => <(~x,~s,[])>);

val (M f) = return <2>;
val x = <[#"a",#"b",#"c"]>;
fun bind ((M f),g) = 
   let fun h x = <let val (a,i1,o1) = ~(f x)
                  in ~(let val (M h) = g <a>
                       in <let val (b,i2,o2) = ~(h <i1>)
                           in (b,i2,o1 @ o2) end>
                       end) end>
   in M h end;

(* Now some meta-morphisms, I.e. functions with type MIo *)
val getchar =
  let fun h <~x :: ~xs> = <(~x,~xs,[])>
        | h x = <(hd ~x,tl ~x,[])>
  in M h end; 

fun putchar c =
  let fun h xs = <((),~xs,[~c])>
  in M h end;

infix >>=;
val (op >>=) = bind;

val z = getchar >>= (fn c => getchar >>= (fn d => putchar c >>= (fn _ => return d)));

val z2 = 
 bind(getchar,
      fn c => bind(getchar,
                   fn d => bind(putchar c,
                                fn _ => return d)));

fun go (M f) = <fn (x::y::z) => ~(f <x::y::z>)>;
fun go1 (M f) = <fn x => ~(f <x>)>;

fun bind ((M f),g) = 
   let fun h x = 
         force <fn (a,i1,o1) => 
                  ~(let val (M h) = g <a>
                    in force <fn (b,i2,o2) => (b,i2,o1 @ o2)>
                             (h <i1>)
                    end)>
              (f x)
   in M h end;


val z3 = 
 bind(getchar,
      fn c => bind(getchar,
                   fn d => bind(putchar c,
                                fn _ => return d)));


(* </Pre> *)