gadt_partially_solved.ml

module Make_expr (Args :
  sig
    type a
  end)
  =
  struct
    include Args

    type _ t =
      | Const : a -> a t
      | Add : a t * a t -> a t
      | Less : a t * a t -> bool t
      | IfThenElse : bool t * a t * a t -> a t
  end


module Make_eval (Args :
  sig
    type a
    val add : a -> a -> a
    val less : a -> a -> bool
  end)
  =
  struct
    open Args

    type _ t =
      | Const : a -> a t
      | Add : a t * a t -> a t
      | Less : a t * a t -> bool t
      | IfThenElse : bool t * a t * a t -> a t

    let rec eval : type a. a t -> a = function
      | Const x -> x
      | Add (l, r) -> add (eval l) (eval r)
      | Less (l, r) -> less (eval l) (eval r)
      | IfThenElse (cond, then_, else_) ->
          eval (if eval cond then then_ else else_)
  end

module IntEval = Make_eval (struct
  type a = int
  let add = ( + )
  let less = ( < )
end)

module StringEval = Make_eval (struct
  type a = string
  let add = ( ^ )
  let less = ( < )
end)

module BoolEval = Make_eval (struct
  type a = bool
  let add = ( || )
  let less l r = not l || r
end)

let int_term =
  let open IntEval in
  Add (Const 10,
       IfThenElse (Less (Add (Const 20,
                              Const 30),
                         Const 40),
                   Const 0,
                   Add (Const 30,
                        Const 2)))

let bool_valued_int_term =
  let open IntEval in
  Less (int_term, Const 50)

let string_term =
  let open StringEval in
  Add (Const "o", Const "k")

let bool_term =
  let open BoolEval in
  IfThenElse (Add (Less (Const true,
                         Const false),
                   Const true),
              Const true,
              Const false)

let () =
  assert (IntEval.eval int_term = 42);
  assert (IntEval.eval bool_valued_int_term);
  assert (StringEval.eval string_term = "ok");
  assert (BoolEval.eval bool_term)