diff --git a/src/parser.mly b/src/parser.mly index 79e8472..821c7fa 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -46,13 +46,13 @@ let const == | ~ = var_id; let match_case == -| VBAR; s = literal; RARROW; e = expr; { s, e } +| VBAR; ~ = literal; RARROW; ~ = expr; <> let type_case == -| VBAR; s = CONID; { s } +| VBAR; ~ = CONID; <> let expr := -| LPAR; ~ = expr; RPAR; { expr } +| LPAR; ~ = expr; RPAR; <> | ~ = const; | FUN; ~ = var_id; RARROW; ~ = expr; { Abstract (Raw, var_id, expr) } | LET; TYPE; ~ = var_id; EQ; cons = list(type_case); IN; e = expr; { Type (var_id, cons, e) } diff --git a/src/type_analysis.ml b/src/type_analysis.ml index ad89513..12a6705 100644 --- a/src/type_analysis.ml +++ b/src/type_analysis.ml @@ -8,6 +8,26 @@ module Make (M : sig end end) = struct + (* + let mk_fresh = + let seen = Hashtbl.create 512 in + fun x -> + match Hashtbl.find_opt seen x with + | None -> + Hashtbl.add seen x 0; x + | Some n -> + Hashtbl.replace seen x (n + 1) ; + Format.sprintf "_%s%d" x n + + module Env = Map.Make (String) + + let old_names = Hashtbl.create 512 + + let add key value scope = + Hashtbl.add old_names value key ; + Env.add key value scope + *) + let tbl = Hashtbl.create 512 let literal = function @@ -19,27 +39,38 @@ struct if not @@ Hashtbl.mem tbl s then raise @@ M.Error.Unbound_literal (Custom s) - let const = function Literal l -> literal l | Var _id -> () + let const = function + | Literal l -> literal l; Literal l + | Var id -> Var id let rec expr = function | Const c -> - const c - | Bind (_p, e1, e2) -> - expr e1 ; expr e2 - | Abstract (_b, _p, e) -> - expr e + Const (const c) + | Bind (p, e1, e2) -> + let e1 = expr e1 in + let e2 = expr e2 in + Bind (p, e1, e2) + | Abstract (b, p, e) -> + let e = expr e in + Abstract (b, p, e) | Apply (e1, e2) -> - expr e1 ; expr e2 - | Match (_origin, match_expr, cases) -> + let e1 = expr e1 in + let e2 = expr e2 in + Apply (e1, e2) + | Match (origin, match_expr, cases) -> List.iter literal (List.map fst cases) ; - List.iter expr (match_expr :: List.map snd cases) + let match_expr = expr match_expr in + let cases = List.map (fun (l, r) -> l, expr r) cases in + Match (origin, match_expr, cases) | Type (id, cons, e) -> + if List.sort String.compare cons <> cons then failwith "please sort constructor correctly@."; List.iter (fun con -> Hashtbl.add tbl con (Types.Custom (id, cons))) cons ; - expr e + let e = expr e in + Type (id, cons, e) let expr e = - expr e ; + ignore (expr e) ; fun x -> Hashtbl.find tbl x end diff --git a/test/custom_type.dddddml b/test/custom_type.dddddml index 8e81264..e0f1be3 100644 --- a/test/custom_type.dddddml +++ b/test/custom_type.dddddml @@ -1,11 +1,11 @@ let type t = - | Coucou - | Sava + | Coucousava | Ouiettoi + | Sava in fun x -> match x - | Coucou -> True - | Sava -> False + | Coucousava -> True | Ouiettoi -> True + | Sava -> False end diff --git a/test/custom_type.expected b/test/custom_type.expected index f844cab..a83d329 100644 --- a/test/custom_type.expected +++ b/test/custom_type.expected @@ -1,11 +1,11 @@ let type t = -| Coucou -| Sava +| Coucousava | Ouiettoi +| Sava in (fun x -> match x -| Coucou -> True -| Sava -> False +| Coucousava -> True | Ouiettoi -> True +| Sava -> False end ) : (t -> bool)