Top

This has been processed with:

ocamlorn --library stdlib.mli \ --library exprbis.in.ml --input exprbis.in.ml --lifting exprbis.lif.ml \ > exprbis.out.ml

Hiding administrative data

(code in tests/exprbis.ml, run with ./ocamlorn tests/stdlib.mli tests/exprbis.ml) We described the code for a simple interpreter.

We start with some library functions (should be part of stdlib)

type 'a option = | Some of 'a | None type 'a list = | Nil | Cons of 'a * 'a list

And a few functions on lists:

let rec find x l = match l with | Cons ((k,v), t) -> begin match equal k x with True -> Some v | _ -> find x t end | Nil -> None let rec remove x l = match l with | Cons (h, t) -> let t' = remove x t in begin match equal x h with True -> t' | False -> Cons (h, t') end | Nil -> Nil let rec append l1 l2 = match l1 with | Cons (h, t) -> Cons (h, append t l2) | Nil -> l2

Here is the abstract syntax of the lambda-calculus with constants:

type expr = | Var of string | Abs of string * expr | App of expr * expr | Const of int

and its evalation function:

let rec eval env e = match e with | Var x -> begin match find x env with | Some v -> Some v | None -> None end | App (u, v) -> begin match eval env u with | Some (Abs (x, f)) -> begin match eval env v with | Some w -> eval (Cons ((x, w), env)) f | None -> None end | Some w -> None | None -> None end | v -> Some v

As a first step, we want to a better treatment of erronesous evaluation by returning not some an None in case of failure but also a string indicating the source of the error. We assume defined two messages:

val str__Unbound_variable : string val str__Not_a_function : string

The result of the evaluation will be a ornamented version of the option type:

type ('a,'err) result = | Ok of 'a | Error of 'err
type ornament ('a, 'err) optres : 'a option => ('a, 'err) result with | Some a => Ok a | None => Error _

We may then lift the eval function at the expected type:

let eval_mes_ = lifting eval : _ -> _ -> ('a, 'err) optres with | ornament * <- @id

This is incomplete:

let rec eval_mes_ env e = match e with | Var x -> begin match find x env with | Some a -> Ok a | None -> Error #23 end | (Abs(_, _) | Const _) -> Ok e | App(u, v) -> begin match eval_mes_ env u with | ((Ok (Var _) | Ok (App(_, _))) | Ok (Const _)) -> Error #6 | Ok (Abs(x, f)) -> begin match eval_mes_ env v with | Ok a -> eval_mes_ (Cons((x, a), env)) f | Error _ -> Error #9 end | Error _ -> Error #4 end

Indeed, we must indicate for each source of error the right message to report to the user:

let eval_mes = lifting eval : _ -> _ -> ('a, 'err) optres with | ornament * <- @id | #23 <- str__Unbound_variable | #6 <- str__Not_a_function | #4 <- begin match _2 with Error mes_u -> mes_u end | #9 <- begin match _3 with Error mes_v -> mes_v end
let rec eval_mes env e = match e with | Var x -> begin match find x env with | Some a -> Ok a | None -> Error str__Unbound_variable end | (Abs(_, _) | Const _) -> Ok e | App(u, v) -> begin match eval_mes env u with | ((Ok (Var _) | Ok (App(_, _))) | Ok (Const _)) -> Error str__Not_a_function | Ok (Abs(x, f)) -> begin match eval_mes env v with | Ok a -> eval_mes (Cons((x, a), env)) f | Error mes_v -> Error mes_v end | Error mes_u -> Error mes_u end

To further improve error reporting, with the source location of the error. We need a type extended with locations, and a result type to return either a value or the location of the error.

type location = Location of string * int * int

Remark that instead of attaching locations directly to the constructor, one would rather systematically lift locations to the

type expr_loc = expr' * location and expr' = | Var' of string | Abs' of (string * expr_loc) | App' of expr_loc * expr_loc | Const' of int

However, our prototype does not implement type abbraviation yet. Hence to fit with these syntactic restriction, we may equivalently defined:

type expr' = | Var' of string | Abs' of string * (expr' * location) | App' of (expr' * location) * (expr' * location) | Const' of int

and use expr' loc instead of expr_loc:

type ornament add_loc : expr => expr' * location with | Var x => (Var' x, _) | Abs (x, f) => (Abs' (x, f), _) when f : add_loc | App (u, v) => (App' (u, v), _) when u v : add_loc | Const i => (Const' i, _)
type ornament ('a, 'mes, 'err) optres' : ('a, 'mes) result => ('a, 'mes * 'err) result with | Ok a => Ok a | Error b => Error (b, _)
let _eval_loc = lifting eval_mes : (_ * add_loc) list -> add_loc -> (_, _, _) optres' with ornament * <- @id

We get the following program:

let rec _eval_loc env e = match e with | (Var' x, _) -> begin match find x env with | Some a -> Ok a | None -> Error (str__Unbound_variable, #26) end | ((Abs'(_, _), _) | (Const' _, _)) -> Ok e | (App'(u, v), _) -> begin match _eval_loc env u with | ((Ok (Var' _, _) | Ok (App'(_, _), _)) | Ok (Const' _, _)) -> Error (str__Not_a_function, #6) | Ok (Abs'(x, f), _) -> begin match _eval_loc env v with | Ok a -> _eval_loc (Cons((x, a), env)) f | Error (b, _) -> Error (b, #11) end | Error (b, _) -> Error (b, #4) end

Which we can patch similarly:

let eval_loc = lifting eval_mes : (_ * add_loc) list -> add_loc -> (_, _, _) optres' with | ornament * <- @id | #29 <- begin match e with (_, loc) -> loc (* unbound *) end | #21, #9, #6 <- begin match _2 with Ok (_, loc_naf) -> loc_naf end | #4 <- begin match _2 with Error (_, loc_u) -> loc_u end | #12 <- begin match _3 with Error (_, loc_v) -> loc_v end
let rec eval_loc env e = match e with | (Var' x, _) -> begin match find x env with | Some a -> Ok a | None -> Error (str__Unbound_variable, #26) end | ((Abs'(_, _), _) | (Const' _, _)) -> Ok e | (App'(u, v), _) -> begin match eval_loc env u with | ((Ok (Var' _, loc_naf) | Ok (App'(_, _), loc_naf)) | Ok (Const' _, loc_naf)) -> Error (str__Not_a_function, loc_naf) | Ok (Abs'(x, f), _) -> begin match eval_loc env v with | Ok a -> eval_loc (Cons((x, a), env)) f | Error (b, _) -> Error (b, #11) end | Error (b, loc_u) -> Error (b, loc_u) end

If we were not interested in the locations in the output, we could simply write:

let _eval_loc = lifting eval_mes : (_ * add_loc) list -> add_loc -> _ with | ornament * <- @id
let rec _eval_loc env e = match e with | (Var' x, _) -> begin match find x env with | Some a -> Ok a | None -> Error str__Unbound_variable end | ((Abs'(_, _), _) | (Const' _, _)) -> Ok e | (App'(u, v), _) -> begin match _eval_loc env u with | ((Ok (Var' _, _) | Ok (App'(_, _), _)) | Ok (Const' _, _)) -> Error str__Not_a_function | Ok (Abs'(x, f), _) -> begin match _eval_loc env v with | Ok a -> _eval_loc (Cons((x, a), env)) f | Error mes_v -> Error mes_v end | Error mes_u -> Error mes_u end

which does not need any patch.

Listing free variables

let rec free_vars e = match e with | Var x -> Cons (x, Nil) | Abs (x, f) -> remove x (free_vars f) | App (u, v) -> append (free_vars u) (free_vars v) | Const i -> Nil
let free_vars_loc = lifting free_vars : add_loc -> string list with ornament * <- @id
let rec free_vars_loc e = match e with | (Var' x, _) -> Cons(x, Nil) | (Abs'(x, f), _) -> remove x (free_vars_loc f) | (App'(u, v), _) -> append (free_vars_loc u) (free_vars_loc v) | (Const' _, _) -> Nil