(**************************************************************************) (* Interpreters: sample code to show the power of monadic programming *) (* *) (* Author(s): Roberto Di Cosmo *) (* *) (* This is free software: you can redistribute it and/or modify *) (* it under the terms of the GNU Lesser General Public License as *) (* published by the Free Software Foundation, either version 2 of the *) (* License, or (at your option) any later version. A special linking *) (* exception to the GNU Lesser General Public License applies to this *) (* library, see the LICENSE file for more information. *) (**************************************************************************) (* Abstract syntax *) type id = string and exp = [ `INT of int | `BOOL of bool | `Iden of id | `App of (exp * exp)| `Abs of (id * exp) | `IF of (exp * exp * exp) | `Comp of (compop * exp * exp) | `Base of (op * exp * exp)] and op = Plus | Minus | Mult | Div and compop = Eq | Less | More;; (* The result type *) type res = [ `Int of int | `Bool of bool | `Arrow of (res -> res) ];; (* Base operations *) let getop op v v' = match v with `Int x -> (match v' with `Int y -> (match op with Plus -> `Int (x+y) | Minus -> `Int(x-y) | Mult -> `Int(x*y) | Div -> `Int(x/y)) | _ -> failwith "Non integer in binop") | _ -> failwith "Non integer in binop";; let getcompop op v v' = match v with `Int x -> (match v' with `Int y -> (match op with Eq -> `Bool (x=y) | Less -> `Bool (x `Bool (x>y)) | _ -> failwith "Non integer in bincomp") | _ -> failwith "Non integer in bincomp";; (* Auxiliary function *) let rec var (i,env) = match env with [] -> failwith "Unknwown variable" | (id,a)::r -> if id = i then a else var (i, r);; (* The interpreter *) let rec interp (exp:exp) env : res= match exp with `App (e1,e2) -> let fv = interp e1 env in (match fv with `Arrow f -> let rv = interp e2 env in f rv | _ -> failwith "Application of non function") | `Abs (id,exp)-> `Arrow(fun a -> (interp exp ((id,a)::env))) | `Iden(id) -> var(id,env) | `INT i -> `Int i | `BOOL b -> `Bool b | `Base(op,e1,e2) -> getop op (interp e1 env) (interp e2 env) | `Comp(op,e1,e2) -> getcompop op (interp e1 env) (interp e2 env) | `IF(b,e1,e2) -> let bv = interp b env in (match bv with `Bool true -> interp e1 env | `Bool false -> interp e2 env | _ -> failwith "Non boolean test") ;; (* Well typed program *) interp (`App(`Abs("x",`IF(`Iden "x",`INT 1,`INT 2)),`BOOL true)) [];; (* Ill typed program *) interp (`App(`INT 1, `INT 2))[];; (* Now add an error value *) type resok = [ `Int of int | `Bool of bool | `Arrow of (resok -> reserr) ] and reserr = Err | Res of resok;; let rec interperr exp env : reserr = match exp with (* the functional core *) `App (e1,e2) -> let fv = interperr e1 env in (match fv with Err -> Err | Res (`Arrow f) -> let rv = interperr e2 env in (match rv with Err -> Err | Res v -> f v) | _ -> failwith "Application of non function") | `Abs (id,exp)-> Res (`Arrow(fun a -> (interperr exp ((id,a)::env)))) | `Iden(id) -> Res (var(id,env)) (* base values and operations *) | `INT i -> Res (`Int i) | `BOOL b -> Res (`Bool b) | `Base(op,e1,e2) -> let r1 = interperr e1 env in (match r1 with Err -> Err | Res v1 -> let r2 = interperr e2 env in (match r2 with Err -> Err | Res v2 -> Res (getop op v1 v2))) | `Comp(op,e1,e2) -> let r1 = interperr e1 env in (match r1 with Err -> Err | Res v1 -> let r2 = interperr e2 env in (match r2 with Err -> Err | Res v2 -> Res (getcompop op v1 v2))) (* conditonal *) | `IF(b,e1,e2) -> let bv = interperr b env in (match bv with Err -> Err | Res (`Bool true) -> interperr e1 env | Res (`Bool false) -> interperr e2 env | _ -> failwith "Non boolean test") (* Error *) | `Fail -> Err;; (* Program with no error *) interperr (`App(`Abs("x",`IF(`Iden "x",`INT 1,`INT 2)),`BOOL true)) [];; (* Program with an error *) let errp = `App( `Abs("x",`IF(`Iden "x",`Fail,`INT 2)), `BOOL true);; (* interperr returns an error value *) interperr errp [];; (* Now add references and a state *) type state = loc -> stres and loc = int and stres = [ `Int of int | `Bool of bool | `Loc of loc | `Arrow of (stres -> state -> stres * state) | `Unit ];; let emptyst = (fun _ -> failwith "No such cell") type env = (id * stres) list;; let newloc = let l = ref 0 in fun () -> let nl = !l in l:= nl+1; nl;; let update (l:loc) v (s:state) = let s' = fun l' -> if l = l' then v else s l' in (`Unit,(s':state));; let lkp (l:loc) (s:state) = (s l),s;; let init v (s:state) = let (l:loc) = newloc() in let s' = fun l' -> if l = l' then v else s l' in ((`Loc l:stres), (s':state));; let rec interpst exp (env:env) : state -> stres * state = fun s -> match exp with (* functional core *) `App (e1,e2) -> let fv = interpst e1 env s in (match fv with `Arrow f, s' -> let v,s'' = interpst e2 env s' in f v s'' | _ -> failwith "Non functional value in application") | `Abs (id,exp)-> `Arrow(fun a -> (interpst exp ((id,a)::env))), s | `Iden(id) -> var(id,env), s (* base types and operations *) | `INT i -> `Int i, s | `BOOL b -> `Bool b, s | `Base(op,e1,e2) -> let v,s' = interpst e1 env s in let v',s'' = interpst e2 env s' in getop op v v', s'' | `Comp(op,e1,e2) -> let v,s' = interpst e1 env s in let v',s'' = interpst e2 env s' in getcompop op v v', s'' (* conditional *) | `IF(b,e1,e2) -> let bv,s' = interpst b env s in (match bv with `Bool true -> interpst e1 env s' | `Bool false -> interpst e2 env s' | _ -> failwith "Non boolean condition in conditional") (* statements and references *) | `UNIT -> `Unit, s | `Seq (e1,e2) -> let _,s' = interpst e1 env s in interpst e2 env s' | `Ref e -> let v,s' = interpst e env s in init v s' | `Deref e -> let l,s' = interpst e env s in (match l with `Loc loc -> lkp loc s' | _ -> failwith "Not a reference") | `Update (e,e') -> let l,s' = interpst e env s in (match l with `Loc loc -> let v,s'' = interpst e' env s' in update loc v s' | _ -> failwith "Not a reference") ;; (* Program with a sequence and memory access, equivalente to OCaml code: *) (* # let x = ref true in if !x = true then x := false else (); !x - : bool = false *) interpst (`App (`Abs("x", `Seq(`IF(`Deref (`Iden "x"), `Update (`Iden "x",`BOOL false), `UNIT), `Deref (`Iden "x"))), `Ref (`BOOL true))) [] emptyst;; (** Now redo everything in monadic style *) (* see how we can write the code modularly *) module type Monad = sig type 'a t val return : 'a -> 'a t val bind : 'a t -> ('a -> 'b t) -> 'b t val reveal : 'a t -> 'a end (* The various monads *) module IdM = struct type 'a t = 'a let return v = v let bind m f = f m let reveal v = v end;; module ErrM = struct type 'a t = Err | Res of 'a let return v = Res v let bind m f = match m with Err -> Err | Res v -> f v let raise () = Err let reveal m = match m with Err -> failwith "Error" | Res v -> v end;; module StateM = struct type s = int -> int type 'a t = s -> 'a * s let return v = fun s -> (v,s) let bind m f s = let (v,s') = m s in f v s' (* Uninitialised memory *) let emptys = (fun l -> failwith "Uninitialised memory location") let reveal m = let (v,s') = m emptys in v (* newloc, update, lkp, init *) let newloc = let l = ref 0 in fun () -> let nl = !l in l:= nl+1; nl let update l v s = let s' = fun l' -> if l = l' then v else s l' in (`Unit,s') let lkp l s = (s l),s let init v (s:state) = let l = newloc() in `Loc l, update l v s end;; (* The monadic interpreter *) module Interp (M: Monad) = struct type idt = (* les valeurs *) [ `Int of int | `Bool of bool | `Arrow of (idt -> expt) ] and expt = idt M.t let ( >>= ) = M.bind let return = M.return let rec interp (exp:exp) (env: (id * idt) list) : expt = match exp with `App (e1,e2) -> interp e1 env >>= fun fv -> (match fv with `Arrow f -> interp e2 env >>= fun rv -> f rv | _ -> failwith "Application of non function") | `Abs (id,exp)-> return (`Arrow(fun a -> (interp exp ((id,a)::env)))) | `Iden(id) -> return (var(id,env)) | `INT i -> return (`Int i) | `BOOL b -> return (`Bool b) | `Base(op,e1,e2) -> interp e1 env >>= fun v1 -> interp e2 env >>= fun v2 -> return (getop op v1 v2) | `Comp(op,e1,e2) -> interp e1 env >>= fun v1 -> interp e2 env >>= fun v2 -> return (getcompop op v1 v2) | `IF(b,e1,e2) -> interp b env >>= fun bv -> (match bv with `Bool true -> interp e1 env | `Bool false -> interp e2 env | _ -> failwith "Non boolean test") end;; (* Instanciate the interpreter with the proper monad *) module IntPlain = Interp(IdM);; module IntErr = Interp(ErrM);; module IntState = Interp(StateM);; (* Test the result on the same program *) (* Notice that we need to use reveal to expose the value *) let prog : exp = (`App(`Abs("x",`IF(`Iden "x",`INT 1,`INT 2)),`BOOL true));; IntPlain.interp prog [];; ErrM.reveal (IntErr.interp prog []);; StateM.reveal (IntState.interp prog []);;