ocaml.ml

module Term = 
  struct
    type t = Const of int | Div of t * t | Add of t * t
    let answer = Div(Div(Const 1972, Const 2), Const 23)
    let error = Div(Const 1, Const 0)
  end

module Eval =   
 struct
    include Term
                           
    let rec eval t = match t with  
      | Const c -> c
      | Add (a,b) -> eval a  +  eval b
      | Div (a,b) -> (eval a) / (eval b)
         
  end

open Term;;
open Eval;;
eval(answer);; 
(* retourne 42 *)

eval(error);;
(* retourne une erreur *)


module type MONAD_SIG =  
  sig
    type 'a t
    val return : 'a -> 'a t
    val bind : 'a t -> ('a -> 'b t) -> 'b t
    val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
  end

module IdMonad : MONAD_SIG  = 
  struct
    type 'a t = Id of 'a
    let return v = Id v
    let bind (Id v) f = f v
    let (>>=) = bind
  end

module type MONAD_SIG_ARITHMETIC =
  sig
    include MONAD_SIG
    val divM : int -> int -> int t
    val addM : int -> int -> int t
    val print : int t -> string  
  end

module IdMonadForEval : MONAD_SIG_ARITHMETIC =   
  struct
    open IdMonad
    let divM a b = return (a / b)
    let addM a b = return (a + b)
    let print a = string_of_int(a)
  end

module MakeEvalMonad(Q : MONAD_SIG_ARITHMETIC)  : 
   sig
     val evalM : Term.t -> int Q.t  
  end =
  struct
    include Term
    open Q  
    let rec evalMrec   t = 
          match t with
          | Const c -> return c
          | Div(a,b)-> evalMrec a >>= (fun n -> evalMrec b >>=  (divM n) ) 
          | Add(a,b)-> evalMrec a >>= (fun n -> evalMrec b >>=  (addM n) )  
          
    let evalM t = return t >>= evalMrec
    end

include MakeEvalMonad(IdMonadForEval);; 
evalM(answer);; 





module OptionMonad : MONAD_SIG =     
  struct
    type 'a t = 'a option 
                                     
    let return e = Some e   
                              
    let bind m f = 
        match m with
        | None -> None
        | Some e -> f e 
                                 
    let (>>=) = bind
           
  end

module OptionMonadForEval : MONAD_SIG_ARITHMETIC = 
  struct
    type 'a t = 'a option 
                                     
    let return e = Some e   
                              
    let bind m f = 
        match m with
        | None -> None
        | Some e -> f e 
                                 
    let (>>=) = bind
    let divM a b = if b = 0 then None else Some (a / b) 
    let addM a b = Some (a + b)  (*/!\*)
    let print a = match a with
        | None -> "None"
        | Some x  -> string_of_int x
  end


include MakeEvalMonad(OptionMonadForEval);;
answer |> evalM |> OptionMonadForEval.print;;
error |> evalM |> OptionMonadForEval.print;;