Skip to content

Commit 1d77593

Browse files
polytypicpolytypic
committed
Fix prim defs to use an internal GADT to avoid warnings
1 parent 89edfee commit 1d77593

1 file changed

Lines changed: 84 additions & 82 deletions

File tree

‎prim.ml‎

Lines changed: 84 additions & 82 deletions
Original file line numberDiff line numberDiff line change
@@ -54,90 +54,92 @@ let is_poly {typ = ts1, ts2} = List.mem VarT ts1 || List.mem VarT ts2
5454

5555
let typs = [BoolT; IntT; CharT; TextT]
5656

57+
type 'a def =
58+
| VoidD: unit def
59+
| BoolD: bool def
60+
| IntD: int def
61+
| CharD: char def
62+
| TextD: string def
63+
| VarD: const def
64+
| ProdD: 'a def * 'b def -> ('a * 'b) def
65+
66+
let (&) l r = ProdD (l, r)
67+
68+
let rec typs_of: type a. a def -> typ list = function
69+
| VoidD -> []
70+
| BoolD -> [BoolT]
71+
| IntD -> [IntT]
72+
| CharD -> [CharT]
73+
| TextD -> [TextT]
74+
| VarD -> [VarT]
75+
| ProdD (l, r) -> typs_of l @ typs_of r
76+
77+
let rec inj: type a. a def -> a -> const list -> const list = function
78+
| VoidD -> fun () vs -> vs
79+
| BoolD -> fun v vs -> BoolV v :: vs
80+
| IntD -> fun v vs -> IntV v :: vs
81+
| CharD -> fun v vs -> CharV v :: vs
82+
| TextD -> fun v vs -> TextV v :: vs
83+
| VarD -> fun v vs -> v :: vs
84+
| ProdD (lD, rD) ->
85+
let injL = inj lD and injR = inj rD in fun (l, r) vs -> injL l (injR r vs)
86+
87+
let rec prj: type a. a def -> const list -> a * const list = function
88+
| VoidD -> fun vs -> ((), vs)
89+
| BoolD -> (function (BoolV v :: vs) -> (v, vs) | _ -> failwith "bool")
90+
| IntD -> (function (IntV v :: vs) -> (v, vs) | _ -> failwith "int")
91+
| CharD -> (function (CharV v :: vs) -> (v, vs) | _ -> failwith "char")
92+
| TextD -> (function (TextV v :: vs) -> (v, vs) | _ -> failwith "text")
93+
| VarD -> (function (v :: vs) -> (v, vs) | _ -> failwith "var")
94+
| ProdD (lD, rD) ->
95+
let prjL = prj lD and prjR = prj rD in
96+
fun vs -> let (l, vs) = prjL vs in let (r, vs) = prjR vs in ((l, r), vs)
97+
98+
let def name inD outD fn = {
99+
name = name;
100+
typ = typs_of inD, typs_of outD;
101+
fn = let inj = inj outD and prj = prj inD in
102+
fun vs -> let (v, vs) = prj vs in assert (vs = []); inj (fn v) []
103+
}
104+
57105
let funs =
58106
[
59-
{name = "==";
60-
typ = [VarT; VarT], [BoolT];
61-
fn = fun [x1; x2] -> [BoolV(x1 = x2)]};
62-
{name = "<>";
63-
typ = [VarT; VarT], [BoolT];
64-
fn = fun [x1; x2] -> [BoolV(x1 <> x2)]};
65-
66-
{name = "true";
67-
typ = [], [BoolT];
68-
fn = fun [] -> [BoolV(true)]};
69-
{name = "false";
70-
typ = [], [BoolT];
71-
fn = fun [] -> [BoolV(false)]};
72-
73-
{name = "Int.+";
74-
typ = [IntT; IntT], [IntT];
75-
fn = fun [IntV i1; IntV i2] -> [IntV(i1 + i2)]};
76-
{name = "Int.-";
77-
typ = [IntT; IntT], [IntT];
78-
fn = fun [IntV i1; IntV i2] -> [IntV(i1 - i2)]};
79-
{name = "Int.*";
80-
typ = [IntT; IntT], [IntT];
81-
fn = fun [IntV i1; IntV i2] -> [IntV(i1 * i2)]};
82-
{name = "Int./";
83-
typ = [IntT; IntT], [IntT];
84-
fn = fun [IntV i1; IntV i2] -> [IntV(i1 / i2)]};
85-
{name = "Int.%";
86-
typ = [IntT; IntT], [IntT];
87-
fn = fun [IntV i1; IntV i2] -> [IntV(i1 mod i2)]};
88-
{name = "Int.<";
89-
typ = [IntT; IntT], [BoolT];
90-
fn = fun [x1; x2] -> [BoolV(x1 < x2)]};
91-
{name = "Int.>";
92-
typ = [IntT; IntT], [BoolT];
93-
fn = fun [x1; x2] -> [BoolV(x1 > x2)]};
94-
{name = "Int.<=";
95-
typ = [IntT; IntT], [BoolT];
96-
fn = fun [x1; x2] -> [BoolV(x1 <= x2)]};
97-
{name = "Int.>=";
98-
typ = [IntT; IntT], [BoolT];
99-
fn = fun [x1; x2] -> [BoolV(x1 >= x2)]};
100-
{name = "Int.print";
101-
typ = [IntT], [];
102-
fn = fun [IntV i] -> print_int i; flush_all (); []};
103-
104-
{name = "Char.toInt";
105-
typ = [CharT], [IntT];
106-
fn = fun [CharV c] -> [IntV(Char.code c)]};
107-
{name = "Char.fromInt";
108-
typ = [IntT], [CharT];
109-
fn = fun [IntV i] -> [CharV(Char.chr i)]};
110-
{name = "Char.print";
111-
typ = [CharT], [];
112-
fn = fun [CharV c] -> print_char c; flush_all (); []};
113-
114-
{name = "Text.++";
115-
typ = [TextT; TextT], [TextT];
116-
fn = fun [TextV t1; TextV t2] -> [TextV(t1 ^ t2)]};
117-
{name = "Text.<";
118-
typ = [TextT; TextT], [BoolT];
119-
fn = fun [x1; x2] -> [BoolV(x1 < x2)]};
120-
{name = "Text.>";
121-
typ = [TextT; TextT], [BoolT];
122-
fn = fun [x1; x2] -> [BoolV(x1 > x2)]};
123-
{name = "Text.<=";
124-
typ = [TextT; TextT], [BoolT];
125-
fn = fun [x1; x2] -> [BoolV(x1 <= x2)]};
126-
{name = "Text.>=";
127-
typ = [TextT; TextT], [BoolT];
128-
fn = fun [x1; x2] -> [BoolV(x1 >= x2)]};
129-
{name = "Text.length";
130-
typ = [TextT], [IntT];
131-
fn = fun [TextV t] -> [IntV(String.length t)]};
132-
{name = "Text.sub";
133-
typ = [TextT; IntT], [CharT];
134-
fn = fun [TextV t; IntV i] -> [CharV(t.[i])]};
135-
{name = "Text.fromChar";
136-
typ = [CharT], [TextT];
137-
fn = fun [CharV c] -> [TextV(String.make 1 c)]};
138-
{name = "Text.print";
139-
typ = [TextT], [];
140-
fn = fun [TextV t] -> print_string t; flush_all (); []};
107+
def "==" (VarD & VarD) BoolD (fun (x1, x2) -> x1 = x2);
108+
def "<>" (VarD & VarD) BoolD (fun (x1, x2) -> x1 <> x2);
109+
110+
def "true" VoidD BoolD (fun () -> true);
111+
def "false" VoidD BoolD (fun () -> false);
112+
113+
def "Int.+" (IntD & IntD) IntD (fun (i1, i2) -> i1 + i2);
114+
def "Int.-" (IntD & IntD) IntD (fun (i1, i2) -> i1 - i2);
115+
def "Int.*" (IntD & IntD) IntD (fun (i1, i2) -> i1 * i2);
116+
def "Int./" (IntD & IntD) IntD (fun (i1, i2) -> i1 / i2);
117+
def "Int.%" (IntD & IntD) IntD (fun (i1, i2) -> i1 mod i2);
118+
119+
def "Int.<" (IntD & IntD) BoolD (fun (i1, i2) -> i1 < i2);
120+
def "Int.>" (IntD & IntD) BoolD (fun (i1, i2) -> i1 > i2);
121+
def "Int.<=" (IntD & IntD) BoolD (fun (i1, i2) -> i1 <= i2);
122+
def "Int.>=" (IntD & IntD) BoolD (fun (i1, i2) -> i1 >= i2);
123+
124+
def "Int.print" IntD VoidD (fun i -> print_int i; flush_all ());
125+
126+
def "Char.toInt" CharD IntD Char.code;
127+
def "Char.fromInt" IntD CharD Char.chr;
128+
129+
def "Char.print" CharD VoidD (fun c -> print_char c; flush_all ());
130+
131+
def "Text.++" (TextD & TextD) TextD (fun (t1, t2) -> t1 ^ t2);
132+
133+
def "Text.<" (TextD & TextD) BoolD (fun (i1, i2) -> i1 < i2);
134+
def "Text.>" (TextD & TextD) BoolD (fun (i1, i2) -> i1 > i2);
135+
def "Text.<=" (TextD & TextD) BoolD (fun (i1, i2) -> i1 <= i2);
136+
def "Text.>=" (TextD & TextD) BoolD (fun (i1, i2) -> i1 >= i2);
137+
138+
def "Text.length" TextD IntD String.length;
139+
def "Text.sub" (TextD & IntD) CharD (fun (t, i) -> t.[i]);
140+
def "Text.fromChar" CharD TextD (String.make 1);
141+
142+
def "Text.print" TextD VoidD (fun t -> print_string t; flush_all ());
141143
]
142144

143145
let fun_of_string name =

0 commit comments

Comments
 (0)