Why this syntax error? No given reason from the shell - ocaml

I've just finished writing this piece of pattern matching (to be attached below). No matter how I tried fixing it up, there is still "Error: Syntax error" when I tried to compile it.
The piece of code is here:
let rec stmt (s:Ast.stmt) : X86.inst list =
let get_label e =
let inst = stmt e in
let pattern = (List.nth (List.rev inst) 0) in
let label = match pattern with
|Memory (Store (Addr (Label l), Reg r)) -> l
|_ -> "Error"
in
match s with
|Exp e -> (match e with
|Int i -> [movei RAX i; store new_temp() RAX]
|Var v -> [load RBX v; store new_temp() RBX]
|Binop (e1, op, e2) -> let (label1, label2) = (get_label e1, get_label e2)
in let operation =
match op with
|Plus -> [Arith (Add (RAX, Reg RBX))]
|Minus -> [Arith (Sub (RAX, Reg RBX))]
|Times -> [Arith (Mul RBX)]
|Div -> [Arith (Div RBX)]
|Eq -> [Arith (Cmp (RAX, RBX))]
|Neq -> [Arith (Cmp (RAX, Reg RBX)); set NE RAX]
|Lt -> [Arith (Cmp (RAX, Reg RBX)); set L RAX]
|Lte -> [Arith (Cmp (RAX, Reg RBX)); set LE RAX]
|Gt -> [Arith (Cmp (RAX, Reg RBX)); set G RAX]
|Gte -> [Arith (Cmp (RAX, Reg RBX)); set GE RAX]
in [load RAX label1; load RBX label2] # operation # [store (new_temp()) RAX]
|Not e -> let label = get_label e in
[load RBX label; Arith (Neg RBX); store (new_temp()) RAX]
|And (e1, e2) -> let (label1, label2) = (get_label e1, get_label e2) in
[load RAX label1; load RBX label2; Bitop (And (RAX, Reg RBX)); store (new_temp()) RAX]
|Or (e1, e2) -> let (label1, label2) = (get_label e1, get_label e2) in
[load RAX label1; load RBX label2; Bitop (Or (RAX, Reg RBX)); store (new_temp()) RAX]
|Assign (e1, e2) -> let label = get_label e2 in
[movei RAX label; store e1 RAX; store (new_temp()) RAX]
|_ -> [])
|Block e -> []
|If (l, m, r) -> []
|While (l, r) -> []
|For (l, m1, m2, r) -> []
|Return e -> []
|_ -> []
let compile (p : Ast.program) : result =
let _ = reset() in
let _ = collect_vars(p) in
let insts = List.concat_map stmt p in
{ code = insts; data = VarSet.elements !variables }
Error is at let compile (p: Ast.program) : result =
which is this (from the shell):
110 | let compile (p : Ast.program) : result =
^^^
Error: Syntax error


The error follows from not having properly completed the get_label function:
let get_label e =
let inst = stmt e in
let pattern = (List.nth (List.rev inst) 0) in
let label = match pattern with
|Memory (Store (Addr (Label l), Reg r)) -> l
|_ -> "Error"
Hence the in following it is associated with let label = ..., not let get_label e = ..., despite your indentation.
I suspect what you want is to just skip the label binding:
let get_label e =
let inst = stmt e in
let pattern = (List.nth (List.rev inst) 0) in
match pattern with
| Memory (Store (Addr (Label l), Reg r)) -> l
| _ -> "Error"
It might be a good idea to use a tool like ocp-indent, which will indent your code according to how the compiler will interpret the code, not how you want the compiler to interpret it. That usually helps to avoid mistakes like this :)

Related

definition of a functor in OCaml

I have to define the signature tEXP of a functor which, starting from a module A with signature tARITH, constructs an abstract type representing expressions. This type of expressions will be named t.
the signature have to declare different operations to build an expression:
from a constant of type A.t (cst operation)
as the opposite of an expression (opp)
as an operation on two expressions (add and mul)
Finally, a compute operation will describe the evaluation of an expression to obtain its value (of type A.t).
I have written this so far :
module type tARITH = sig
type t
val zero : t
val one : t
val add : t -> t -> t
val mul : t -> t -> t
val opp : t -> t
val of_int : int -> t
val to_string : t -> string
end
module INT : tARITH = struct
type t = int
let zero = 0;;
let one =1;;
let add x y = x+y;;
let mul x y = x*y;;
let opp x = -x;;
let of_int x= x;;
let to_string x= string_of_int x;;
end ;;
type m3 = Zero | Un | Deux
module M3:tARITH = struct
type t = m3
let zero = Zero;;
let one = Un;;
let add m n = if m=Zero && n=Zero || n=Un && m=Deux || m=Un && n=Deux then Zero
else if m=Deux && n=Zero || m=Un && n=Un || m=Zero && n=Deux then Deux
else Un;;
let mul m n = if m=Deux && n=Deux || m=Un && n=Un then Un
else if m=Deux && n=Un || n=Deux && m=Un then Deux
else Zero;;
let opp m = match m with
|Zero->Zero
|Un->Deux
|Deux->Un;;
let of_int m = match (m mod 3) with
|0->Zero
|1->Un
|2->Deux
|(-1)->opp Un
|(-2)->opp Deux
|_->Zero;;
let to_string x = match x with
|Zero->"0"
|Un->"1"
|Deux->"2" ;;
end;;
and here the signature of tEXP :
module type tEXP =
sig
type t = Constante of m3 | Somme of t*t | Produit of t*t
val cst t -> t;;
val opp x -> t ;;
val add x -> y -> t
val mul x -> y -> t
val compute x -> A.x;;
end ;;
module EXP = functor (A: tARITH)-> struct
type t = Constante of m3 | Somme of t*t | Produit of t*t
let cst x = x;;
let opp x = match x with
|Constante(x) -> x
|Constante(x)-> x
|Somme(x,y)-> A.plus (calculer x) (calculer y)
|Produit(x,y)-> A.mult (calculer x) (calculer y) ;;
let add x y = A.plus (calculer x) (calculer y);;
let mul x y = A.mul (calculer x) (calculer y) ;;
let compute x = A.x;;
end;;
I get an error at "sig" and the first "x", I don't really know why.

Thank you for your help. Here is the final answer:
module type tEXP = functor (A : tARITH) -> sig
type t
val cst : A.t -> t
val opp : t -> t
val add : t -> t -> t
val mul : t -> t -> t
val compute : t -> A.t
end;;
module EXP = functor (A : tARITH) -> struct
type t = Const of A.t | Opp of t | Add of t*t | Mul of t*t
let cst c = Const (c)
let add ex1 ex2 = Add (ex1, ex2)
let opp exp = Opp (exp)
let mul ex1 ex2 = Mul (ex1, ex2)
let rec compute expr = match expr with
Const (c) -> c
| Opp (e) -> A.opp (compute e)
| Add(e1, e2) -> A.add (compute e1) (compute e2)
| Mul(e1, e2) -> A.mul (compute e1) (compute e2)
end;;

Ocaml Error: Answer error (please help fix)

I have been stuck with this for more than an hour. So the test bench is at the bottom, and the answer is supposed to show 120 but I keep getting 20. I believe it only does 5 * 4 not the rest of 3 2 and 1.
What is the problem??
I tried to fix all the other ones but they seem correct. is it a calculation error? is it WHILE problem?
type exp =
| NUM of int | TRUE | FALSE | UNIT
| VAR of id
| ADD of exp * exp
| SUB of exp * exp
| MUL of exp * exp
| DIV of exp * exp
| EQUAL of exp * exp
| LESS of exp * exp
| NOT of exp
| SEQ of exp * exp (* sequence *)
| IF of exp * exp * exp (* if-then-else *)
| WHILE of exp * exp (* while loop *)
| LETV of id * exp * exp (* variable binding *)
| LETF of id * id list * exp * exp (* procedure binding *)
| CALLV of id * exp list (* call by value *)
| CALLR of id * id list (* call by referenece *)
| RECORD of (id * exp) list (* record construction *)
| FIELD of exp * id (* access record field *)
| ASSIGN of id * exp (* assgin to variable *)
| ASSIGNF of exp * id * exp (* assign to record field *)
| WRITE of exp
and id = string
type loc = int
type value =
| Num of int
| Bool of bool
| Unit
| Record of record
and record = (id * loc) list
type memory = (loc * value) list
type env = binding list
and binding = LocBind of id * loc | ProcBind of id * proc
and proc = id list * exp * env
(********************************)
(* Handling environment *)
(********************************)
let rec lookup_loc_env : id -> env -> loc
= fun x env ->
match env with
| [] -> raise(Failure ("Variable "^x^" is not included in environment"))
| hd::tl ->
begin match hd with
| LocBind (id,l) -> if(x=id) then l else lookup_loc_env x tl
| ProcBind _ -> lookup_loc_env x tl
end
let rec lookup_proc_env : id -> env -> proc
= fun x env ->
match env with
| [] -> raise(Failure ("Variable "^x^" is not included in environment"))
| hd::tl ->
begin match hd with
| LocBind _ -> lookup_proc_env x tl
| ProcBind (id,binding) -> if (x=id) then binding else lookup_proc_env x tl
end
let extend_env : binding -> env -> env
= fun e env -> e::env
let empty_env = []`enter code here`
(***************************)
(* Handling memory *)
(***************************)
let rec lookup_mem : loc -> memory -> value
= fun l mem ->
match mem with
| [] -> raise(Failure ("location "^(string_of_int l)^" is not included in memory"))
| (loc,v)::tl -> if(l=loc) then v else lookup_mem l tl
let extend_mem : (loc * value) -> memory -> memory
= fun (l,v) mem -> (l,v)::mem
let empty_mem = []
(***************************)
(* Handling record *)
(***************************)
let rec lookup_record : id -> record -> loc
= fun id record ->
match record with
| [] -> raise(Failure ("field "^ id ^" is not included in record"))
| (x,l)::tl -> if(id=x) then l else lookup_record id tl
let extend_record : (id * loc) -> record -> record
= fun (x,l) record -> (x,l)::record
let empty_record = []
(***************************)
let counter = ref 0
let new_location () = counter:=!counter+1;!counter
exception NotImplemented
exception UndefinedSemantics
let rec list_fold2 : ('a -> 'b -> 'c -> 'c)-> 'a list -> 'b list -> 'c -> 'c
= fun func l1 l2 acc ->
match (l1,l2) with
| ([],[]) -> acc
| (hd1::tl1,hd2::tl2) -> list_fold2 func tl1 tl2 (func hd1 hd2 acc)
| _ -> raise (Failure "two lists have different length")
let rec list_fold : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b
= fun func l acc ->
match l with
| [] -> acc
| hd::tl -> list_fold func tl (func hd acc)
let value2str : value -> string
= fun v ->
match v with
| Num n -> string_of_int n
| Bool b -> string_of_bool b
| Unit -> "unit"
| Record _ -> "record"
let rec eval_aop : env -> memory -> exp -> exp -> (int -> int -> int) -> (value * memory)
= fun env mem e1 e2 op ->
let (v1,mem1) = eval env mem e1 in
let (v2,mem2) = eval env mem1 e2 in
match (v1,v2) with
| (Num n1, Num n2) -> (Num (op n1 n2), mem2)
| _ -> raise (Failure "arithmetic operation type error")
and eval : env -> memory -> exp -> (value * memory)
=fun env mem e ->
match e with
| NUM n -> (Num n, mem)
| TRUE -> (Bool true, mem)
| FALSE -> (Bool false, mem)
| UNIT -> (Unit, mem)
| VAR x -> ((lookup_mem (lookup_loc_env x env) mem ), mem )
| ADD (e1, e2) -> eval_aop env mem e1 e2 (+)
| SUB (e1, e2) -> eval_aop env mem e1 e2 (-)
| MUL (e1, e2) -> eval_aop env mem e1 e2 ( * )
| DIV (e1, e2) -> eval_aop env mem e1 e2 (/)
|EQUAL (e1, e2) ->
let (v1, mem1) = eval env mem e1 in
let (v2, mem2) = eval env mem1 e2 in
if v1 = v2 then (Bool true, mem2) else (Bool false, mem2)
|LESS (e1, e2) ->
let (v1, mem1) = eval env mem e1 in
let (v2, mem2) = eval env mem1 e2 in
begin match (v1, v2) with
| (Num n1, Num n2) ->
if Num n1 < Num n2 then (Bool true, mem2) else (Bool false, mem2)
| _ -> raise (UndefinedSemantics)
end
|NOT (e1) ->
let (b, mem1) = eval env mem e1 in
if b = b then (Bool false,mem1) else (Bool true,mem1)
|SEQ (e1, e2) ->
let (v1, mem1) = eval env mem e1 in
let (v2, mem2) = eval env mem1 e2 in
(v2,mem2)
|IF (e1,e2,e3) ->
(match (eval env mem e1) with
| (Bool true, mem1) -> eval env mem1 e1
| (Bool false, mem1) -> eval env mem1 e2
| _ -> raise (UndefinedSemantics) )
|WHILE (e1,e2) ->
begin match (eval env mem e1) with
| (Bool true, mem1) ->
let (v1, mem2) = eval env mem1 e2 in
eval env mem2 e2
| (Bool false, mem1) -> (Unit, mem1)
| _ -> raise (UndefinedSemantics)
end
|LETV (x,e1,e2) ->
let (v1, mem1) = eval env mem e1 in
let a = LocBind (x, (new_location()) ) in
let (v2,mem2) = eval (extend_env a env) (extend_mem ((lookup_loc_env x)(extend_env a env), v1) mem1 )e2 in
(v2,mem2)
| ASSIGN (x,e1) ->
let (v1, mem1) = eval env mem e1 in
(v1, extend_mem ((lookup_loc_env x env) , (v1) ) mem1)
| WRITE e ->
let (v1,mem1) = eval env mem e in
let _ = print_endline(value2str v1) in
(v1,mem1)
| _ -> raise NotImplemented
;;
let runb : exp -> value
=fun exp -> let (v, _) = eval empty_env empty_mem exp in v;;
let test = LETV ("ret", NUM 1,
LETV ("n", NUM 5,
SEQ (
WHILE (LESS (NUM 0, VAR "n"),
SEQ (
ASSIGN ("ret", MUL (VAR "ret", VAR "n")),
ASSIGN ("n", SUB (VAR "n", NUM 1))
)
),
VAR "ret")))
;;
runb test;;

When evaluating WHILE you need to make sure the inner expression is evaluated as a WHILE. But you are evaluating it just as itself. In other words, the recursive call to eval should be passing e but you are just passing e2.
As a result you're just getting two evaluations of the loop, which gives 20.
So it seems to me.

How do I fix the bug below and get the result I want

I have code below, but I don't get the correct result I want
type expr
= Val of value
| App of expr * expr
| MultiApp of expr * expr list
and value
= Int of int
| Bool of bool
let rec t(e:expr) : expr = match e with
| Val _ -> e
| App(f,a) -> App(t f, t a)
| MultiApp(f,[]) -> raise (Failure "no")
| MultiApp(f,lst) -> match lst with
|[]-> raise (Failure "no")
|x::xs -> let rest = MultiApp(f,xs) in
App(f,x)
let e1 = Val(Int 1)
let e2 = Val(Int 3)
let e3 = Val(Bool true)
let e4 = Val(Bool false)
For example,
MultiApp(fe,[e1;e2;e3])
after apply fun t it would get something like
App(App(App(t fe, t e1), t e2) t e3)

errors on static type checker for OCaml

2010210088
This is an extension from:
Implementing type equation generator in OCaml
type exp =
| CONST of int
| VAR of var
| ADD of exp * exp
| SUB of exp * exp
| ISZERO of exp
| IF of exp * exp * exp
| LET of var * exp * exp
| PROC of var * exp
| CALL of exp * exp
and var = string
(* raise this exception when the program is determined to be ill-typed *)
exception TypeError
(* type *)
type typ = TyInt | TyBool | TyFun of typ * typ | TyVar of tyvar
and tyvar = string
(* type equations are represented by a list of "equalities" (ty1 = ty2) *)
type typ_eqn = (typ * typ) list
(* generate a fresh type variable *)
let tyvar_num = ref 0
let fresh_tyvar () = (tyvar_num := !tyvar_num + 1; (TyVar ("t" ^ string_of_int !tyvar_num)))
(* type environment : var -> type *)
module TEnv = struct
type t = var -> typ
let empty = fun _ -> raise (Failure "Type Env is empty")
let extend (x,t) tenv = fun y -> if x = y then t else (tenv y)
let find tenv x = tenv x
end
(* substitution *)
module Subst = struct
type t = (tyvar * typ) list
let empty = []
let find x subst = List.assoc x subst
(* walk through the type, replacing each type variable by its binding in the substitution *)
let rec apply : typ -> t -> typ
=fun typ subst ->
match typ with
| TyInt -> TyInt
| TyBool -> TyBool
| TyFun (t1,t2) -> TyFun (apply t1 subst, apply t2 subst)
| TyVar x ->
try find x subst
with _ -> typ
(* add a binding (tv,ty) to the subsutition and propagate the information *)
let extend tv ty subst =
(tv,ty) :: (List.map (fun (x,t) -> (x, apply t [(tv,ty)])) subst)
end
let rec gen_equations : TEnv.t -> exp -> typ -> typ_eqn
=fun tenv e ty -> match e with
| CONST n -> [(ty, TyInt)]
| VAR x -> [(ty, TEnv.find tenv x)]
| ADD (e1,e2) ->
let l1 = [(ty, TyInt)] in
let l2 = gen_equations tenv e1 TyInt in
let l3 = gen_equations tenv e2 TyInt in
l1#l2#l3
| SUB (e1,e2) ->
let l1 = [(ty, TyInt)] in
let l2 = gen_equations tenv e1 TyInt in
let l3 = gen_equations tenv e2 TyInt in
l1#l2#l3
| ISZERO e ->
let l1 = [(ty, TyBool)] in
let l2 = gen_equations tenv e TyInt in
l1#l2
| IF (e1,e2,e3) ->
let l1 = gen_equations tenv e1 TyBool in
let l2 = gen_equations tenv e2 ty in
let l3 = gen_equations tenv e3 ty in
l1#l2#l3
| LET (x,e1,e2) ->
let t = fresh_tyvar () in
let l1 = gen_equations tenv e1 t in
let l2 = gen_equations (TEnv.extend (x,t) tenv) e2 ty in
l1#l2
| PROC (x,e) ->
let t1 = fresh_tyvar () in
let t2 = fresh_tyvar () in
let l1 = [(ty, TyFun (t1,t2))] in
let l2 = gen_equations (TEnv.extend (x,t1) tenv) e t2 in
l1#l2
| CALL (e1,e2) ->
let t = fresh_tyvar () in
let l1 = gen_equations tenv e1 (TyFun (t,ty)) in
let l2 = gen_equations tenv e2 t in
l1#l2
| _ -> raise TypeError
(* this is where the error comes up *)
let solve : typ_eqn -> Subst.t
=fun eqn -> unifyall eqn Subst.empty
let rec unify : typ -> typ -> Subst.t -> Subst.t
=fun t1 t2 s -> match (t1,t2) with
| (TyInt,TyInt) -> s
| (TyBool,TyBool) -> s
| (t,TyVar a) -> unify (TyVar a) t s
| (TyVar t1,t2) -> Subst.extend t1 t2 s
| (TyFun (t1,t2), TyFun (t1',t2')) ->
let s' = unify t1 t1' s in
let t1'' = Subst.apply t2 s' in
let t2'' = Subst.apply t2' s' in
unify t1'' t2'' s'
let rec unifyall : typ_eqn -> Subst.t -> Subst.t
=fun eqn s -> match eqn with
| [] -> s
| (t1,t2)::u ->
let s' = unify (Subst.apply t1 s) (Subst.apply t2 s) s in
unifyall u s'
let typeof : exp -> typ
=fun exp ->
let new_tv = fresh_tyvar () in
let eqns = gen_equations TEnv.empty exp new_tv in
let subst = solve eqns in
let ty = Subst.apply new_tv subst in
ty
This is a static type checker from a procedure function in OCaml. All the functions are working well except for the 'solve' function part. The error says,
Error: This expression has type typ_eqn/3404 = (typ/3398 * typ/3398)
list but an expresson was expected of type typ_eqn/3179 = (typ/3173 *
typ/3173) list Type typ/3398 is not compatible with type typ/3173
What is with that big number beside the / mark? and why is it not working out?

It's easily possible in OCaml to have two types with the same name. To make things less confusing is such cases, the compiler tags a duplicated name with a unique number. Before it started doing this, the error messages were truly confusing: "expected type abc but saw type abc".
One way this can happen is if you have multiple definitions during a run of the OCaml toplevel. If you're working in the toplevel, you might try starting again from scratch.
I just tried your code quickly, and I don't see the error you report. Instead I see an undefined symbol error. This is actually evidence for it being a problem of redefinition in the toplevel.

Simple lambda calculus DSL using GADTs in OCaml

How do you define a simple lambda calculus-like DSL in OCaml using GADTs? Specifically, I can't figure out how to properly define the type checker to translate from an untyped AST to a typed AST nor can I figure out the correct type for the context and environment.
Here's some code for a simple lambda calculus-like language using the traditional approach in OCaml
(* Here's a traditional implementation of a lambda calculus like language *)
type typ =
| Boolean
| Integer
| Arrow of typ*typ
type exp =
| Add of exp*exp
| And of exp*exp
| App of exp*exp
| Lam of string*typ*exp
| Var of string
| Int of int
| Bol of bool
let e1=Add(Int 1,Add(Int 2,Int 3))
let e2=Add(Int 1,Add(Int 2,Bol false)) (* Type error *)
let e3=App(Lam("x",Integer,Add(Var "x",Var "x")),Int 4)
let rec typecheck con e =
match e with
| Add(e1,e2) ->
let t1=typecheck con e1 in
let t2=typecheck con e2 in
begin match (t1,t2) with
| (Integer,Integer) -> Integer
| _ -> failwith "Tried to add with something other than Integers"
end
| And(e1,e2) ->
let t1=typecheck con e1 in
let t2=typecheck con e2 in
begin match (t1,t2) with
| (Boolean,Boolean) -> Boolean
| _ -> failwith "Tried to and with something other than Booleans"
end
| App(e1,e2) ->
let t1=typecheck con e1 in
let t2=typecheck con e2 in
begin match t1 with
| Arrow(t11,t12) ->
if t11 <> t2 then
failwith "Mismatch of types on a function application"
else
t12
| _ -> failwith "Tried to apply a non-arrow type"
end
| Lam(x,t,e) ->
Arrow (t,typecheck ((x,t)::con) e)
| Var x ->
let (y,t) = List.find (fun (y,t)->y=x) con in
t
| Int _ -> Integer
| Bol _ -> Boolean
let t1 = typecheck [] e1
(* let t2 = typecheck [] e2 *)
let t3 = typecheck [] e3
type value =
| VBoolean of bool
| VInteger of int
| VArrow of ((string*value) list -> value -> value)
let rec eval env e =
match e with
| Add(e1,e2) ->
let v1=eval env e1 in
let v2=eval env e2 in
begin match (v1,v2) with
| (VInteger i1,VInteger i2) -> VInteger (i1+i2)
| _ -> failwith "Tried to add with something other than Integers"
end
| And(e1,e2) ->
let v1=eval env e1 in
let v2=eval env e2 in
begin match (v1,v2) with
| (VBoolean b1,VBoolean b2) -> VBoolean (b1 && b2)
| _ -> failwith "Tried to and with something other than Booleans"
end
| App(e1,e2) ->
let v1=eval env e1 in
let v2=eval env e2 in
begin match v1 with
| VArrow a1 -> a1 env v2
| _ -> failwith "Tried to apply a non-arrow type"
end
| Lam(x,t,e) ->
VArrow (fun env' v' -> eval ((x,v')::env') e)
| Var x ->
let (y,v) = List.find (fun (y,t)->y=x) env in
v
| Int i -> VInteger i
| Bol b -> VBoolean b
let v1 = eval [] e1
let v3 = eval [] e3
Now, I'm trying to translate this into something that uses GADTs. Here's my start
(* Now, we try to GADT the process *)
type exp =
| Add of exp*exp
| And of exp*exp
| App of exp*exp
| Lam of string*typ*exp
| Var of string
| Int of int
| Bol of bool
let e1=Add(Int 1,Add(Int 2,Int 3))
let e2=Add(Int 1,Add(Int 2,Bol false))
let e3=App(Lam("x",Integer,Add(Var "x",Var "x")),Int 4)
type _ texp =
| TAdd : int texp * int texp -> int texp
| TAnd : bool texp * bool texp -> bool texp
| TApp : ('a -> 'b) texp * 'a texp -> 'b texp
| TLam : string*'b texp -> ('a -> 'b) texp
| TVar : string -> 'a texp
| TInt : int -> int texp
| TBol : bool -> bool texp
let te1 = TAdd(TInt 1,TAdd(TInt 2,TInt 3))
let rec typecheck : type a. exp -> a texp = fun e ->
match e with
| Add(e1,e2) ->
let te1 = typecheck e1 in
let te2 = typecheck e2 in
TAdd (te1,te2)
| _ -> failwith "todo"
Here's the problem. First, I'm not sure how to define the correct type for TLam and TVar in the type texp. Generally, I would provide the type with the variable name, but I'm not sure how to do that in this context. Second, I don't know the correct type for the context in the function typecheck. Before, I used some kind of list, but now I'm sure sure of the type of the list. Third, after leaving out the context, the typecheck function doesn't type check itself. It fails with the message
File "test03.ml", line 32, characters 8-22:
Error: This expression has type int texp
but an expression was expected of type a texp
Type int is not compatible with type a
which makes complete sense. This is more of an issue of that I'm not sure what the correct type for typecheck should be.
In any case, how do you go about fixing these functions?
Edit 1
Here's a possible type for the context or environment
type _ ctx =
| Empty : unit ctx
| Item : string * 'a * 'b ctx -> ('a*'b) ctx
Edit 2
The trick with the environment is to make sure that the type of the environment is embedded into the type of the expression. Otherwise, there's not enough information in order to make things type safe. Here's a completed interpreter. At the moment, I do not have a valid type checker to move from untyped expressions to typed expressions.
type (_,_) texp =
| TAdd : ('e,int) texp * ('e,int) texp -> ('e,int) texp
| TAnd : ('e,bool) texp * ('e,bool) texp -> ('e,bool) texp
| TApp : ('e,('a -> 'b)) texp * ('e,'a) texp -> ('e,'b) texp
| TLam : (('a*'e),'b) texp -> ('e,('a -> 'b)) texp
| TVar0 : (('a*'e),'a) texp
| TVarS : ('e,'a) texp -> (('b*'e),'a) texp
| TInt : int -> ('e,int) texp
| TBol : bool -> ('e,bool) texp
let te1 = TAdd(TInt 1,TAdd(TInt 2,TInt 3))
(*let te2 = TAdd(TInt 1,TAdd(TInt 2,TBol false))*)
let te3 = TApp(TLam(TAdd(TVar0,TVar0)),TInt 4)
let te4 = TApp(TApp(TLam(TLam(TAdd(TVar0,TVarS(TVar0)))),TInt 4),TInt 5)
let te5 = TLam(TLam(TVarS(TVar0)))
let rec eval : type e t. e -> (e,t) texp -> t = fun env e ->
match e with
| TAdd (e1,e2) ->
let v1 = eval env e1 in
let v2 = eval env e2 in
v1 + v2
| TAnd (e1,e2) ->
let v1 = eval env e1 in
let v2 = eval env e2 in
v1 && v2
| TApp (e1,e2) ->
let v1 = eval env e1 in
let v2 = eval env e2 in
v1 v2
| TLam e ->
fun x -> eval (x,env) e
| TVar0 ->
let (v,vs)=env in
v
| TVarS e ->
let (v,vs)=env in
eval vs e
| TInt i -> i
| TBol b -> b
Then, we have
# eval () te1;;
- : int = 6
# eval () te3;;
- : int = 8
# eval () te5;;
- : '_a -> '_b -> '_a = <fun>
# eval () te4;;
- : int = 9

If you want the term representation to enforce well-typedness, you need to change the way type environments (and variables) are represented: you cannot finely type a mapping from strings to value (type to represent mapping are homogeneous). The classic solution is to move to a representation of variables using De Bruijn indices (strongly-typed numbers) instead of variable names. It may help you to perform that conversion in the untyped world first, and then only care about typing in the untyped -> GADT pass.
Here is, rouhgly sketched, a GADT declaration for strongly typed variables:
type (_, _) var =
| Z : ('a, 'a * 'g) var
| S : ('a, 'g) var -> ('a, 'b * 'g) var
A value at type ('a, 'g) var should be understood as a description of a way to extract a value of type 'a out of an environment of type 'g. The environment is represented by a cascade of right-nested tuples. The Z case corresponds to picking the first variable in the environment, while the S case ignores the topmost variables and looks deeper in the environment.
Shayan Najd has a (Haskell) implementation of this idea on github. Feel free to have a look at the GADT representation or the type-checking/translating code.

Alright, so I finally worked things out. Since I may not be the only one who finds this interesting, here's a complete set of code that does both type checking and evaluation:
type (_,_) texp =
| TAdd : ('gamma,int) texp * ('gamma,int) texp -> ('gamma,int) texp
| TAnd : ('gamma,bool) texp * ('gamma,bool) texp -> ('gamma,bool) texp
| TApp : ('gamma,('t1 -> 't2)) texp * ('gamma,'t1) texp -> ('gamma,'t2) texp
| TLam : (('gamma*'t1),'t2) texp -> ('gamma,('t1 -> 't2)) texp
| TVar0 : (('gamma*'t),'t) texp
| TVarS : ('gamma,'t1) texp -> (('gamma*'t2),'t1) texp
| TInt : int -> ('gamma,int) texp
| TBol : bool -> ('gamma,bool) texp
type _ typ =
| Integer : int typ
| Boolean : bool typ
| Arrow : 'a typ * 'b typ -> ('a -> 'b) typ
type (_,_) iseq = IsEqual : ('a,'a) iseq
let rec is_equal : type a b. a typ -> b typ -> (a,b) iseq option = fun a b ->
match a, b with
| Integer, Integer -> Some IsEqual
| Boolean, Boolean -> Some IsEqual
| Arrow(t1,t2), Arrow(u1,u2) ->
begin match is_equal t1 u1, is_equal t2 u2 with
| Some IsEqual, Some IsEqual -> Some IsEqual
| _ -> None
end
| _ -> None
type _ isint = IsInt : int isint
let is_integer : type a. a typ -> a isint option = fun a ->
match a with
| Integer -> Some IsInt
| _ -> None
type _ isbool = IsBool : bool isbool
let is_boolean : type a. a typ -> a isbool option = fun a ->
match a with
| Boolean -> Some IsBool
| _ -> None
type _ context =
| CEmpty : unit context
| CVar : 'a context * 't typ -> ('a*'t) context
type exp =
| Add of exp*exp
| And of exp*exp
| App of exp*exp
| Lam : 'a typ * exp -> exp
| Var0
| VarS of exp
| Int of int
| Bol of bool
type _ exists_texp =
| Exists : ('gamma,'t) texp * 't typ -> 'gamma exists_texp
let rec typecheck
: type gamma t. gamma context -> exp -> gamma exists_texp =
fun ctx e ->
match e with
| Int i -> Exists ((TInt i) , Integer)
| Bol b -> Exists ((TBol b) , Boolean)
| Var0 ->
begin match ctx with
| CEmpty -> failwith "Tried to grab a nonexistent variable"
| CVar(ctx,t) -> Exists (TVar0 , t)
end
| VarS e ->
begin match ctx with
| CEmpty -> failwith "Tried to grab a nonexistent variable"
| CVar(ctx,_) ->
let tet = typecheck ctx e in
begin match tet with
| Exists (te,t) -> Exists ((TVarS te) , t)
end
end
| Lam(t1,e) ->
let tet2 = typecheck (CVar (ctx,t1)) e in
begin match tet2 with
| Exists (te,t2) -> Exists ((TLam te) , (Arrow(t1,t2)))
end
| App(e1,e2) ->
let te1t1 = typecheck ctx e1 in
let te2t2 = typecheck ctx e2 in
begin match te1t1,te2t2 with
| Exists (te1,t1),Exists (te2,t2) ->
begin match t1 with
| Arrow(t11,t12) ->
let p = is_equal t11 t2 in
begin match p with
| Some IsEqual ->
Exists ((TApp (te1,te2)) , t12)
| None ->
failwith "Mismatch of types on a function application"
end
| _ -> failwith "Tried to apply a non-arrow type"
end
end
| Add(e1,e2) ->
let te1t1 = typecheck ctx e1 in
let te2t2 = typecheck ctx e2 in
begin match te1t1,te2t2 with
| Exists (te1,t1),Exists (te2,t2) ->
let p = is_equal t1 t2 in
let q = is_integer t1 in
begin match p,q with
| Some IsEqual, Some IsInt ->
Exists ((TAdd (te1,te2)) , t1)
| _ ->
failwith "Tried to add with something other than Integers"
end
end
| And(e1,e2) ->
let te1t1 = typecheck ctx e1 in
let te2t2 = typecheck ctx e2 in
begin match te1t1,te2t2 with
| Exists (te1,t1),Exists (te2,t2) ->
let p = is_equal t1 t2 in
let q = is_boolean t1 in
begin match p,q with
| Some IsEqual, Some IsBool ->
Exists ((TAnd (te1,te2)) , t1)
| _ ->
failwith "Tried to and with something other than Booleans"
end
end
let e1 = Add(Int 1,Add(Int 2,Int 3))
let e2 = Add(Int 1,Add(Int 2,Bol false))
let e3 = App(Lam(Integer,Add(Var0,Var0)),Int 4)
let e4 = App(App(Lam(Integer,Lam(Integer,Add(Var0,VarS(Var0)))),Int 4),Int 5)
let e5 = Lam(Integer,Lam(Integer,VarS(Var0)))
let e6 = App(Lam(Integer,Var0),Int 1)
let e7 = App(Lam(Integer,Lam(Integer,Var0)),Int 1)
let e8 = Lam(Integer,Var0)
let e9 = Lam(Integer,Lam(Integer,Var0))
let tet1 = typecheck CEmpty e1
(*let tet2 = typecheck CEmpty e2*)
let tet3 = typecheck CEmpty e3
let tet4 = typecheck CEmpty e4
let tet5 = typecheck CEmpty e5
let tet6 = typecheck CEmpty e6
let tet7 = typecheck CEmpty e7
let tet8 = typecheck CEmpty e8
let tet9 = typecheck CEmpty e9
let rec eval : type gamma t. gamma -> (gamma,t) texp -> t = fun env e ->
match e with
| TAdd (e1,e2) ->
let v1 = eval env e1 in
let v2 = eval env e2 in
v1 + v2
| TAnd (e1,e2) ->
let v1 = eval env e1 in
let v2 = eval env e2 in
v1 && v2
| TApp (e1,e2) ->
let v1 = eval env e1 in
let v2 = eval env e2 in
v1 v2
| TLam e ->
fun x -> eval (env,x) e
| TVar0 ->
let (env,x)=env in
x
| TVarS e ->
let (env,x)=env in
eval env e
| TInt i -> i
| TBol b -> b
type exists_v =
| ExistsV : 't -> exists_v
let typecheck_eval e =
let tet = typecheck CEmpty e in
match tet with
| Exists (te,t) -> ExistsV (eval () te)
let v1 = typecheck_eval e1
let v3 = typecheck_eval e3
let v4 = typecheck_eval e4
let v5 = typecheck_eval e5
let v6 = typecheck_eval e6
let v7 = typecheck_eval e7
let v8 = typecheck_eval e8
let v9 = typecheck_eval e9
Here are the pieces I had trouble with and how I managed to resolve them
In order to correctly type the typed expressions texp, the type of the environment needed to be built into the type of texp. This implies, as gasche correctly noted, that we needed some sort of De Bruijin notation. The easiest was just Var0 and VarS. In order to use variable names, we'd just have to preprocess the AST.
The type of the expression, typ, needed to include both variant types to match on as well as the type we use in the typed expression. In other words, that also needed to be a GADT.
We require three proofs in order to ferret out the correct types in the type checker. These are is_equal, is_integer, and is_bool. The code for is_equal is actually in the OCaml manual under Advanced examples. Specifically, look at the definition of eq_type.
The type exp, for the untyped AST, actually needs to be a GADT also. The lambda abstraction needs access to typ, which is a GADT.
The type checker returns an existential type of both a typed expression as well as the type. We need both to get the program to check type. Also, we need the existential because the untyped expression may or may not have a type.
The existential type, exists_texp, exposes the type of the environment/context, but not the type. We need this type exposed in order to type check properly.
Once everything is setup, the evaluator follows the type rules exactly.
The result of combining the type checker with the evaluator must be another existential type. A priori, we don't know the resulting type, so we have to hide it in an existential package.