eval_monad.ml

(* term type *)

type term = Con of int | Div of term * term ;;

(* test data *)

let answer = Div (Div (Con 1972, Con 2), Con 23);; (* 42 *)

let error = Div(Con 1, Con 0);; (* Exception: Division_by_zero. *)


(* ======================== *)

(* primitive evaluator *)
val eval = term -> int;;
 
let rec eval = function Con a -> a
            | Div (t, u) -> eval(t) / eval(u) ;;

(* monad version: identy *)
type 'a m = 'a;;

let pure (a: 'a ) : 'a m   = a;;

let bind (a: 'a m) (k: 'a -> 'b  m ) : 'b m = k(a);; 

(*
problem with precedence,function application

*)
let rec eval (s: term) : int m =
    match s with
        | Con a -> pure(a)
        | Div(t,u) -> bind (eval t) (fun a -> 
                      bind (eval u) (fun b ->
                      pure (a / b )));;



(* with exception handling *)
  
type eval_exception = string;;

type 'a m  = Raise of eval_exception | Return of 'a;;

let rec eval x = match x with 
  | Con a      -> Return a
  | Div (t, u) -> match eval(t) with
                  | Raise e -> Raise e
                  | Return b -> match eval(u) with
                                | Raise e  -> Raise e
                                | Return c -> if c = 0 then Raise ("divided by my zero") 
                                                       else Return ( b / c) ;;
type eval_exception = string;;

type 'a m  = Raise of eval_exception | Return of 'a;;

let pure (a: 'a ) : 'a m   = Return(a);;

let bind (m: 'a m) (k: 'a -> 'b  m ) : 'b m = 
    match m with
    | Raise e -> Raise e 
    | Return a -> k(a);; 

let eval_raise (e: eval_exception) : 'a m = Raise e;;

let rec eval (s: term) : int m =
    match s with
        | Con a -> pure(a)
        | Div(t,u) -> 
            bind (eval t)  (fun a -> 
                                (bind (eval u)  (fun b ->
                                                 (if b = 0 then eval_raise ("divided by my zero") 
                                                 else pure (a/b) ) ) )) ;;
 (* why can not you write  bind eval(t) ..  *)

  



(* with state *)
  
(* without explicitly type declearation *)
let rec eval term x = match (term, x)  with 
  | ((Con a),  x)   -> (a, x)
  | (Div (t, u), x) -> let (b,y) = (eval t x)  in
                       let (c,z) = (eval u y) in
                       (b / c, z + 1)  ;;



type state = int ;;
let rec eval (exp:term) (x:state) : int * state  = match (exp, x)  with 
  | ((Con a),  x)   -> (a, x)
  | (Div (t, u), x) -> let (b,y) = (eval t x)  in
                       let (c,z) = (eval u y) in
                       (b / c, z + 1) ;;
  

(* which one is correct in above three declearration? *) 
type 'a m = 'a * state;;
type 'a m = state -> 'a * state;;
type 'a m = 'a -> 'a * state;;
type ('a, state) m = 'a * state;;

(* only this one is right *)
type m 'a = state -> 'a * state;;

let rec eval term : int m  = match term with 
  | (Con a)  -> fun x ->  (a, x)
  | (Div (t, u)) -> fun x -> 
                      let (b,y) = eval t x in
                      let (c,z) = eval u y in
                    (b / c, z + 1);;
  
type state = int ;;

type 'a m = state -> 'a * state ;;

let pure (a: 'a ) = fun x -> (a, x);;

let bind  (m: 'a m) (k: 'a -> 'b m) : 'b m = 
  fun x -> begin 
    let (a, y) = m x in
    let (b, z) = k a y in
    (b,z)
      end;; 

let tick : unit m = fun x -> ((), x + 1);;

(* todo             solve problem like this
Error: This expression has type state m/127727 but an expression was expected of type state m/128041 = state -> state * state 
 *)

let rec eval (s: term) : int m =
    match s with
        | Con a -> pure(a)
        | Div(t,u) -> 
            bind (eval t)  (fun a -> 
            bind (eval u)  (fun b ->
            bind tick (fun () -> pure (a / b))));;
  

  
(* output *)
  
(* helper function for pretty print *)
let rec showterm  = function Con a -> "Con " ^ (string_of_int a)
                            | Div (x, y) -> "Div (" ^ showterm(x) ^ ","  ^ showterm(y) ^ " )" ;;


let line t a = (showterm t) ^ " =  " ^ (string_of_int a) ^ " => " ;;

let rec eval term  = match term with 
  | (Con a)  -> (line (Con a) a, a)
  | (Div (t, u)) -> let (x,a) = eval t in
                    let (y,b) = eval u in
                    (x ^ y ^ (line (Div (t, u)) (a/b)), a/b);;


(* with type * *)
type output_step = string ;;
type m 'a = output_step * 'a ;;

let rec eval term : int m  = match term with 
  | (Con a)  -> (line (Con a) a, a)
  | (Div (t, u)) -> let (x,a) = eval t in
                    let (y,b) = eval u in
                    (x ^ y ^ (line (Div (t, u)) (a/b)), a/b);;

  
(* monad version *)
(* helper function for pretty print *)
let rec showterm  = function Con a -> "Con " ^ (string_of_int a)
                            | Div (x, y) -> "Div (" ^ showterm(x) ^ ","  ^ showterm(y) ^ " )" ;;
let line t a = (showterm t) ^ " =  " ^ (string_of_int a) ^ " => " ;;


type output_step = string ;;
type m 'a = output_step * 'a ;;


let pure (a: 'a) : 'a m = ("", a);;

let bind  (m: 'a m) (k: 'a -> 'b m) : 'b m = 
    let (x, a) = m in
    let (y, b) = k a in
    (x ^ y , b);;

let eval_output (s: output_step) : unit m  = (s,());;

let rec eval (s: term) : int m =
    match s with
        | Con a -> bind (eval_output (line s a))  (fun () -> pure(a))
        | Div(t,u) -> 
            bind (eval t)  (fun a -> 
            bind (eval u)  (fun b ->
                            bind (eval_output (line s (a/b)))  (fun () -> pure(a/b))));