(* Tagless Final using dictionary passing *)
(* We use objects as extensible records, to model
the implicit dictionary composition in Haskell
*)
(* Compare with Haskell's ExpSYM *)
class type ['repr] expSYM = object
method lit : int -> 'repr
method neg : 'repr -> 'repr
method add : 'repr -> 'repr -> 'repr
end;;
(* Constructor functions *)
let lit n = fun ro -> ro#lit n;;
let neg e = fun ro -> ro#neg (e ro);;
let add e1 e2 = fun ro -> ro#add (e1 ro) (e2 ro);;
(* Unit is for the sake of value restriction *)
(* The term is exactly the same as that in Intro2.hs *)
let tf1 () = add (lit 8) (neg (add (lit 1) (lit 2)));;
(* We can write interepreters of expSYM *)
(* and evaluate exp in several ways. The code for the interpreters
is quite like the one we have seen already
*)
class eval = object
method lit n = (n:int)
method neg e = - e
method add e1 e2 = e1 + e2
end;;
let eval = new eval;;
(* We didn't apply eval, we pass eval as an argument *)
let 5 = tf1 () eval;;
class view = object
method lit n = string_of_int n
method neg e = "(-" ^ e ^ ")"
method add e1 e2 = "(" ^ e1 ^ " + " ^ e2 ^ ")"
end;;
let view = new view;;
let "(8 + (-(1 + 2)))" = tf1 () view;;
(* We can extend our expression adding a new expression form *)
class type ['repr] mulSYM = object
method mul : 'repr -> 'repr -> 'repr
end;;
let mul e1 e2 = fun ro -> ro#mul (e1 ro) (e2 ro);;
(* Extended sample expressions *)
(* Again, the code is the same as before, modulo the occasional () *)
(* Value restriction is indeed annoying ... *)
let tfm1 () = add (lit 7) (neg (mul (lit 1) (lit 2)));;
let tfm2 () = mul (lit 7) (tf1 ());;
class evalM = object
inherit eval
method mul e1 e2 = e1 * e2
end;;
let evalM = new evalM;;
class viewM = object
inherit view
method mul e1 e2 = "(" ^ e1 ^ " * " ^ e2 ^ ")"
end;;
let viewM = new viewM;;
(* can use the extended evaluator to evaluate old expressions *)
let 5 = tf1 () evalM;;
(* Of course we can't use the old evaluator to evaluate extended
expressions
let 5 = tfm1 () eval;;
Error: This expression has type eval but an expression was expected of type
< add : 'a -> 'b -> 'c; lit : int -> 'a; mul : 'a -> 'a -> 'd;
neg : 'd -> 'b; .. >
The first object type has no method mul
*)
let 5 = tfm1 () evalM;;
let 35 = tfm2 () evalM;;
let "(7 + (-(1 * 2)))" = tfm1 () viewM;;
let "(7 * (8 + (-(1 + 2))))" = tfm2 () viewM;;
(* The expressions are first-class: we can put them into the same list *)
let tl1 () = [lit 1; tf1 ()];;
(* and add the extended objects afterwards *)
let tl2 () = tfm1 () :: tfm2 () :: tl1 ();;
let [5; 35; 1; 5] = List.map (fun x -> x evalM) (tl2 ());;
let ["(7 + (-(1 * 2)))"; "(7 * (8 + (-(1 + 2))))"; "1"; "(8 + (-(1 + 2)))"]
= List.map (fun x -> x viewM) (tl2 ());;
Printf.printf "\nAll done\n";;