From 30ea92ffc2e8ef4f7ed06ae07156c0e7e8e817c8 Mon Sep 17 00:00:00 2001
From: zapashcanon <leo@ndrs.fr>
Date: Fri, 6 May 2022 14:54:18 +0200
Subject: [PATCH] backup

---
 src/parser.mly            |  6 ++---
 src/type_analysis.ml      | 53 +++++++++++++++++++++++++++++++--------
 test/custom_type.dddddml  |  8 +++---
 test/custom_type.expected |  8 +++---
 4 files changed, 53 insertions(+), 22 deletions(-)

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; <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) }
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)