Polymorphic function for phantom GADT type - ocaml

I am new to OCaml. And I am writing a simple assembler compiler. I have the following types which I use in my AST.
type asmreg8
type asmreg16
type asmreg32
type asmreg64
type asmreg128
type _ reg =
| Reg8 : string -> asmreg8 reg
| Reg16 : string -> asmreg16 reg
| Reg32 : string -> asmreg32 reg
| Reg64 : string -> asmreg64 reg
| Reg128 : string -> asmreg128 reg
type asmlabel
type _ const = ASMConst of string const
type _ var = ASMVar of string var
type _ label = ASMLabel of asmlabel label
type double_arg =
| RegToReg : 'a reg * 'a reg -> double_arg
| RegToConst : 'a reg * 'b const -> double_arg
type mnemonic = Mov | Add | Inc | Ret
type single_arg =
| Var : _ var -> single_arg
| Reg : _ reg -> single_arg
| Label : _ label -> single_arg
type command =
| Args2 of mnemonic * double_arg
| Args1 of mnemonic * single_arg
| Args0 of mnemonic
type code_section = Command of command | Id of asmlabel label
type data_type = DB | DW | DD | DQ | DT
type var = string * data_type * string list
type dir = Code of code_section list | Data of var list
I think types are good because they forbid operations on different (by bits) registers. But now I have a problem. I do not know how to write a function like the following
let string_to_reg = function
| "something" -> Reg8 "something"
| "Reg16" -> Reg16 "16"
| _ -> Reg32 "123"
I just do not know how to get a function that takes a string (or another type that does not explicitly contain 'a) and returns values of type 'a reg where 'a can be asmreg8, asmreg16 ets.
I have read several articles about GADT and phantom types, but have not found an example that suits me. I'm starting to think I'm missing something about types and that things should be a lot simpler.
I tried this code `
let string_to_reg : type a. string -> a reg = function
| "something" -> Reg8 "something"
| "Reg16" -> Reg16 "16"
| _ -> Reg32 "123"
but I get
This expression has type asmreg8 reg but an expression was expected of type
a reg
Type asmreg8 is not compatible with type a
I thought I can just show to compiler that the function returns a polymorphic type.
I tried this
let string_to_reg : string -> 'a reg = function
| "something" -> Reg8 "something"
| "Reg16" -> Reg16 "16"
| _ -> Reg32 "123"
but I get a string -> asmreg8 reg function and it can not return value of asmreg16 reg type.
I tried pack my _ ret types by another type
type asmreg =
| ASM8 : asmreg8 reg -> asmreg
| ASM16 : asmreg16 reg -> asmreg
| ASM32 : asmreg32 reg -> asmreg
| ASM64 : asmreg64 reg -> asmreg
| ASM128 : asmreg128 reg -> asmreg
let reg_to_asmreg : type a. asmreg -> a reg = function
| ASM8 x -> Reg8 x
| ASM16 x -> Reg16 x
| _ -> Reg32 "123"
but I have a same problem. I can not write a function that returns values of different reg types.

It is not possible to write the function string_to_reg directly
let string_to_reg s x = match x with
| "something" -> Reg8 "something"
| "Reg16" -> Reg16 "16"
| _ -> Reg32 "123"
because the type of the function would not be 'a. string -> 'a reg. Indeed this type means that the function returns a register of all possible type simultaneously which is not what you meant.
The correct type of the result of the function would be something like
(x:string) -> reg_type(x) in a dependently typed language. In other words, you want the type of the result to depend on the value of its argument. This is not possible in OCaml (in the core language).
This is common issue when interfacing a strongly typed GADT DSLs with the exterior world. The solution is to use another layer of GADTs to convey the information that the type of the parsed register cannot be known in advance:
type dyn_reg = Dyn: 'any reg -> dyn_reg [##unboxed]
let string_to_dyn_reg s = function
| "something" -> Dyn (Reg8 "something")
| "Reg16" -> Dyn(Reg16 "16")
| _ -> Dyn(Reg32 "123")
Here, if I have a value Dyn x, I know that there is some type 'e such that the type of x is x:'e reg, but I don't know anything more about this type 'e (this kind of type variable 'e is said to be existentially quantified type). Thus I can only apply function on x that work for any 'e reg.
Since reg is a GADTs, the possible values for 'e reg are well-known, so there are still many useful function of type 'e. 'e reg -> ... and it should still possible to use the parsed register.
An important point to notice however is that this dyn_reg type has mostly erased all fine-grained type information that was available on the GADTs definition, and whenever we are using dyn_reg, we are in fact using an encoding of the normal variants. Thus, if you end up using only dyn_reg, it is a sign that GADTs were not really useful in this case.
EDIT:
A good example of the consequence of erasing the types is to try to write a move function.
Just writing
let mov (Dyn a) (Dyn b) =
Args2(Mov, RegToReg(a,b)
fails because the type of a and b might not be compatible.
However, once we check that the types are compatible, the function
compiles as expected
exception Type_error
let mov (Dyn a) (Dyn b) =
let matching x y = Args2(Mov,RegToReg(x,y)) in
match a, b with
| Reg8 _, Reg8 _ -> matching a b
| Reg16 _, Reg16 _ -> matching a b
| Reg32 _, Reg32 _ -> matching a b
| Reg64 _, Reg64 _ -> matching a b
| Reg128 _, Reg128 _ -> matching a b
| _ -> raise Type_error

Related

Why does OCaml think that this function takes an int parameter when nothing suggests that it should be the case?

I was working on chapter 1 of Modern Compiler Implementation in ML by Andrew Appel and I decided to implement it in OCaml instead of SML. I'm new to OCaml and I came across a very frustrating problem. OCaml seems to think that the below function has the signature int * (int * 'a) -> 'a option.
let rec lookupTable = function
| name, (i, v) :: _ when name = i -> Some v
| name, (_, _) :: rest -> lookupTable (name, rest)
| _, [] -> None
But as far as I can tell, there should be nothing that suggests that the first element in the tuple is an int. This is a problem because when the lookupTable function down the line, the compiler complains that I am not passing it an integer. Perhaps I am missing something incredibly obvious, but it has been pretty mind-boggling. Here is the rest of the program
open Base
type id = string
type binop = Plus | Minus | Times | Div
type stm =
| CompoundStm of stm * stm
| AssignStm of id * exp
| PrintStm of exp list
and exp =
| IdExp of id
| NumExp of int
| OpExp of exp * binop * exp
| EseqExp of stm * exp
(* Returns the maximum number of arguments of any print
statement within any subexpression of a given statement *)
let rec maxargs s =
match s with
| CompoundStm (stm1, stm2) -> Int.max (maxargs stm1) (maxargs stm2)
| AssignStm (_, exp) -> maxargs_exp exp
(* Might be more nested expressions *)
| PrintStm exps -> Int.max (List.length exps) (maxargs_explist exps)
and maxargs_exp e = match e with EseqExp (stm, _) -> maxargs stm | _ -> 0
and maxargs_explist exps =
match exps with
| exp :: rest -> Int.max (maxargs_exp exp) (maxargs_explist rest)
| [] -> 0
type table = (id * int) list
let updateTable name value t : table = (name, value) :: t
let rec lookupTable = function
| name, (i, v) :: _ when name = i -> Some v
| name, (_, _) :: rest -> lookupTable (name, rest)
| _, [] -> None
exception UndefinedVariable of string
let rec interp s =
let t = [] in
interpStm s t
and interpStm s t =
match s with
| CompoundStm (stm1, stm2) -> interpStm stm2 (interpStm stm1 t)
| AssignStm (id, exp) ->
let v, t' = interpExp exp t in
updateTable id v t'
(* Might be more nested expressions *)
| PrintStm exps ->
let interpretAndPrint t e =
let v, t' = interpExp e t in
Stdio.print_endline (Int.to_string v);
t'
in
List.fold_left exps ~init:t ~f:interpretAndPrint
and interpExp e t =
match e with
| IdExp i -> (
match lookupTable (i, t) with
| Some v -> (v, t)
| None -> raise (UndefinedVariable i))
| NumExp i -> (i, t)
| OpExp (exp1, binop, exp2) ->
let exp1_val, t' = interpExp exp1 t in
let exp2_val, _ = interpExp exp2 t' in
let res =
match binop with
| Plus -> exp1_val + exp2_val
| Minus -> exp1_val - exp2_val
| Times -> exp1_val * exp2_val
| Div -> exp1_val / exp2_val
in
(res, t')
| EseqExp (s, e) -> interpExp e (interpStm s t)
Base defines = as int -> int -> bool, so when you have the expression name = i the compiler will infer them as ints.
You can access the polymorphic functions and operators through the Poly module, or use a type-specific operator by locally opening the relevant module, e.g. String.(name = i).
The reason Base does not expose polymorphic operators by default is briefly explained in the documentation's introduction:
The comparison operators exposed by the OCaml standard library are polymorphic:
What they implement is structural comparison of the runtime representation of values. Since these are often error-prone, i.e., they don't correspond to what the user expects, they are not exposed directly by Base.
There's also a performance-argument to be made, because the polymorphic/structural operators need to also inspect what kind of value it is at runtime in order to compare them correctly.

expanding 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
type typ = TyInt | TyBool | TyFun of typ * typ | TyVar of tyvar
and tyvar = string
type typ_eqn = (typ * typ) list
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
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) -> [(ty, TyInt)]#
[gen_equations (tenv, e1, TyInt)]#
[gen_equations (tenv, e2, TyInt)]
Implementing type equation generator in OCaml
I'm expanding type checker based on above code
What I want to do is add "EQUAL" expression, which take two input and return TyBool as output
Problem is how to make equation of input, as input is not a fixed type.
EQUAL can take both TyInt and TyBool as input
ex)
EQUAL (FALSE, FALSE) have output TRUE (because false == false)
EQUAL (5, 3) have output FALSE (because 5 != 3)
How can I make equation?
Your EQUAL expression has a polymorphic type, i.e., it is typable for integers and variables. It is your choice, as a language designer, which flavor of polymorphism you will implement. You can start with the classical parametric polymorphism. In that case, you will type EQUAL as 'a -> 'a -> bool, or, in the parlance of your representation,
TyFun (TyVar a, TyFun (TyVar a, TyBool))
Then, during the unification process, the type variable a will be unified either with TyBool or with TyVar (well, it could also unify with functional types, which you can turn into a type error if you wish).
Alternatively, you can implement EQUAL using ad-hoc polymorphism. This will require you to change your type system though, i.e., to add new constructors to your type typ. You can take the type classes approach and have TyCls of string * typ and give EQUAL the following type,
TyFun (TyCls ("comparable",t), TyFun (TyCls ("comparable",t), TyBool))
But inference with type classes is hard and is not always decidable.

How to convert generic variants instance without the redundancy match cases?

I have the following generic variant type:
type 'a t = A | B | C | D | E | Value of 'a
and some function that converts int t to string t
let int_to_sting = function
| Value x -> Value (string_of_int x)
| some -> some
This function is uncompilable because of
| some -> some
Error: This expression has type int t but an expression was expected
of type string t
Type int is not compatible
Even it has type annotation.
let int_to_sting : int t -> string t = function
| Value x -> Value (string_of_int x)
| some -> some
I can rewrite it with
let int_to_sting = function
| Value x -> Value (string_of_int x)
| A -> A
| B -> B
| C -> C
| D -> D
| E -> E
But the long list of constructors looks redundancy.
Is it possible to convert some in my first implementation to avoid this noisy code?
You can make it slightly less redundant by both enumerating and binding them to a name:
let int_to_sting = function
| Value x -> Value (string_of_int x)
| (A | B | C | D | E) as some -> some
Another option that is OBVIOUSLY NOT SAFE and that you DEFINITELY SHOULDN'T USE is to circumvent the type system using Obj.magic:
let int_to_sting = function
| Value x -> Value (string_of_int x)
| some -> (Obj.magic (some: int t): string t)
This happens to work because the representation of these values are the same regardless of the type argument. But if you were to add another constructor that is not... then you crash and burn.

OCaml: How to handle sum type properly?

suppose I have the following code:
type s = A of a | B of b
let foo (a:?) =
let bar (input:s) = match input with
| A a -> foo input
| B b -> ...
My question is what should I fill in the question mark in the signature of foo so I won't need a (redundant) match statement in it? Or is there a better pattern to do this?
If you want to avoid rematch, I see 3 solutions:
have the function foo simply take the "payload" of the value constructor A, and reconstruct a value of type s as its output (or any other type matching the output type of bar).
# type a;;
type a
# type b;;
type b
# module Ex1 = struct
type s = A of a | B of b
let foo (a:a) = A a
let bar (input:s) = match input with
| A a -> foo a
| B b -> (* ... *) input
end;;
module Ex1 :
sig
type s = A of a | B of b
val foo : a -> s
val bar : s -> s
end
use polymorphic variants:
# module Ex2 = struct
type s = [ `A of a | `B of b ]
let foo (`A a) = `A a
let bar (input:s) = match input with
| `A _ as a -> foo a
| `B b -> (* ... *) input
end;;
module Ex2 :
sig
type s = [ `A of a | `B of b ]
val foo : [< `A of 'a ] -> [> `A of 'a ]
val bar : s -> s
end
use GADTs:
# module Ex3 = struct
type _ s =
| A : a -> a s
| B : b -> b s
let foo (a: a s) : a s =
match a with
| A a -> A a
let bar: type x. x s -> x s = fun input ->
match input with
| A _ as a -> foo a
| B b -> (* ... *) input
end;;
module Ex3 :
sig
type _ s = A : a -> a s | B : b -> b s
val foo : a s -> a s
val bar : 'x s -> 'x s
end
Starting with your example, the solution would be simple:
type s = A of a | B of b
let foo (a:a) =
let bar (input:s) = match input with
| A a -> foo a
| B b -> ...
But constraint here is not needed. Looks like that you're misunderstanding the idea of type constraints. In general, in OCaml type constraints cannot affect the program. Programs with and without type constraints have the same behavior. So, here you don't need to put any constraints at all. You must think of type annotations only as a helper tool for programmer.
Update
I'm still not sure, that I understand what actually you want, but if you want to split your variants into subsets, and keep this split refutable, then, indeed, you can use polymorphic variants, as Pascal suggested.
Let me first rephrase the questions. Suppose I have type:
type t = A | B | C | D | E
and I have a pattern match
let f = function
| A | B | C as x -> handle_abc x
| D | E as x -> handle_de x
How can I prove to a compiler, that handle_abc takes only a subset of all possible constructors, namely A | B | C ?
The answer is, with regular variants it is impossible. But it is possible with polymorphic variants:
type t = [`A | `B | `C | `D | `E]
let f = function
| `A | `B | `C as x -> handle_abc x
| `D | `E as -> handle_de x
So, handle_abc now needs only to pattern match on three variants, and don't need to have any redundant matches. Moreover, you can give names to a groups of constructors, and pattern match on this names:
type abc = [`A | `B | `C ]
type de = [`D | `E ]
type t = [ abc | de ]
let f = function
| #abc as x -> handle_abc x
| #de as -> handle_de x
As a real world example, you can take a look at BAP project where polymorphic variants are used to represent instruction code. Here we split all codes into different subgroups, like all move instructions, all branch instructions and so on. And later we can pattern match on the groups directly.
One solution, that incurs a runtime cost, would be to have the variants wrap tuples instead of individual values. Then it's easier to capture the whole tuple and send it to a specialized function:
type s =
(* Note the extra parentheses! *)
| Foo of (int * string)
| Bar of (char * int * string)
let foo (i, s) = "foo"
let bar (c, i, s) = "bar"
let main input =
match input with
| Foo f -> foo f (* `f` is bound to a tuple of type `int * string` *)
| Bar b -> bar b (* `b` is bound to a tuple of type `char * int * string` *)
You would have to fill in the type in the question mark for the signature of Foo, and then use a match statement in it. The place where the question mark is denotes a type. In a way it is assisting the compiler by telling it what exact type you want, and it will strictly ensure that operations you carry out on a or input is of a matching type.
The match statement is not that redundant and does not hurt performance much as it is very efficient in OCaml. However we have another approach as below.
Alternatively if you only have one parameter, you could save some typing by doing function in place of match. For example:
let foo (c:s) = match c with ....
we can do
let foo = function
| A -> ...
| B -> ...
Note that the function word will only work if you have one parameter passed in (you could definitely wrap up all your parameters into a list and pass it in if you like)
Here's an additional example to get my point across:
type number = |Int of int
|Float of float
let to_int: (number -> int option) = function
| Int n -> Some n
| _ -> None
(*this is the same as *) (*also note that int option denotes return type*)
let to_int (input:number) : int option =
match input with
| Int n -> Some n
| _ -> None
(*notice how the first one does not have a input as a parameter name*)
let n1:number = Int 1;;
let n2:number = Int 2;;
Example use: `to_int(n1);`
Just to be clear, there isn't a need to fill it in, and type assists helps the programmer as well, and for me in some ambiguous cases helped make sure the compiler knew what I wanted. According to my professor a few semesters ago, it is a good practice to explicitly mention it to keep types in check.

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.