Browse Source

backup

master
zapashcanon 3 years ago
parent
commit
30ea92ffc2
Signed by: zapashcanon GPG Key ID: 8981C3C62D1D28F1
  1. 6
      src/parser.mly
  2. 53
      src/type_analysis.ml
  3. 8
      test/custom_type.dddddml
  4. 8
      test/custom_type.expected

6
src/parser.mly

@ -46,13 +46,13 @@ let const ==
| ~ = var_id; <Var>
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; <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) }

53
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

8
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

8
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)

Loading…
Cancel
Save