Top

This file 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 #30 end | App(u, v) -> begin match eval_mes_ env u with | Ok (Abs(x, f)) -> begin match eval_mes_ env v with | Ok a -> eval_mes_ (Cons((x, a), env)) f | Error _ -> Error #14 end | Ok (Var _) -> Error #22 | Ok (App(_, _)) -> Error #12 | Ok (Const _) -> Error #10 | Error _ -> Error #8 end | (Abs (_, _) | Const _) -> Ok e

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 patch #30[str__Unbound_variable] patch (match _a with Ok _ -> Error (#[str__Not_a_function])) patch (match _a with Error a -> Error (#[a]))
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 | App(u, v) -> begin match eval_mes env u with | Ok (Abs(x, f)) -> begin match eval_mes env v with | Ok a -> eval_mes (Cons((x, a), env)) f | Error x -> Error x end | ((Ok (Var _) | Ok (App(_, _))) | Ok (Const _)) -> Error str__Not_a_function | Error x -> Error x end | (Abs (_, _) | Const _) -> Ok e

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, #33) end | (App'(u, v), _) -> begin match _eval_loc env u with | Ok (Abs'(x, f), _) -> begin match _eval_loc env v with | Ok a -> _eval_loc (Cons((x, a), env)) f | Error (b, _) -> Error (b, #16) end | Ok (Var' _, _) -> Error (str__Not_a_function, #24) | Ok (App'(_, _), _) -> Error (str__Not_a_function, #13) | Ok (Const' _, _) -> Error (str__Not_a_function, #10) | Error (b, _) -> Error (b, #8) end | ((Abs'(_, _), _) | (Const' _, _)) -> Ok e

Which we can patch similarly:

let eval_loc = lifting eval_mes : (_ * add_loc) list -> add_loc -> (_, _, _) optres' with ornament * <- @id patch #33[begin match e with (_, loc) -> loc (* unbound *) end] patch match _a with Ok(_, _b) -> Error (_c, (#[_b])) patch match _a with Error(_, _b) -> Error (_c, (#[_b]))
let rec eval_loc env e = match e with | (Var' x, loc) -> begin match find x env with | Some a -> Ok a | None -> Error (str__Unbound_variable, loc) end | (App'(u, v), _) -> begin match eval_loc env u with | Ok (Abs'(x, f), _) -> begin match eval_loc env v with | Ok a -> eval_loc (Cons((x, a), env)) f | Error (b, x) -> Error (b, x) end | ((Ok (Var' _, x) | Ok (App'(_, _), x)) | Ok (Const' _, x)) -> Error (str__Not_a_function, x) | Error (b, x) -> Error (b, x) end | ((Abs'(_, _), _) | (Const' _, _)) -> Ok e

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 | (App'(u, v), _) -> begin match _eval_loc env u with | Ok (Abs'(x, f), _) -> begin match _eval_loc env v with | Ok a -> _eval_loc (Cons((x, a), env)) f | Error x -> Error x end | ((Ok (Var' _, _) | Ok (App'(_, _), _)) | Ok (Const' _, _)) -> Error str__Not_a_function | Error x -> Error x end | ((Abs'(_, _), _) | (Const' _, _)) -> Ok e

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