Canonicalize hashtables after running them through htab_map. Closes #77.

2 files changed, 19 insertions, 13 deletions

diff --git a/src/boot/me/semant.ml b/src/boot/me/semant.ml
index 3868d6f0..5160429e 100644
--- a/src/boot/me/semant.ml
+++ b/src/boot/me/semant.ml
@@ -817,14 +817,13 @@ let rebuild_ty_under_params
         end
         params
     in
-    let substituted = ref false in
     let rec rebuild_ty t =
       let base = ty_fold_rebuild (fun t -> t) in
       let ty_fold_param (i, mut) =
         let param = Ast.TY_param (i, mut) in
           match htab_search pmap param with
               None -> param
-            | Some arg -> (substituted := true; arg)
+            | Some arg -> arg
       in
       let ty_fold_named n =
         let rec rebuild_name n =
@@ -863,7 +862,7 @@ let rebuild_ty_under_params
                   begin
                     match htab_search nmap id with
                         None -> Ast.TY_named n
-                      | Some arg -> (substituted := true; arg)
+                      | Some arg -> arg
                   end
             | _ -> Ast.TY_named n
       in
@@ -873,14 +872,7 @@ let rebuild_ty_under_params
             ty_fold_named = ty_fold_named;
         }
       in
-      let t' = fold_ty fold t in
-        (* FIXME (issue #77): "substituted" and "ty'" here are only required
-         * because the current type-equality-comparison code in Type uses <>
-         * and will judge some cases, such as rebuilt tags, as unequal simply
-         * due to the different hashtable order in the fold.  *)
-        if !substituted
-        then t'
-        else t
+        fold_ty fold t
     in
       rebuild_ty ty
 ;;
diff --git a/src/boot/util/common.ml b/src/boot/util/common.ml
index f33a6ea1..5c381b81 100644
--- a/src/boot/util/common.ml
+++ b/src/boot/util/common.ml
@@ -220,6 +220,21 @@ let htab_put (htab:('a,'b) Hashtbl.t) (a:'a) (b:'b) : unit =
   Hashtbl.add htab a b
 ;;
 
+(* This is completely ridiculous, but it turns out that ocaml hashtables are
+ * order-of-element-addition sensitive when it comes to the built-in
+ * polymorphic comparison operator. So you have to canonicalize them after
+ * you've stopped adding things to them if you ever want to use them in a
+ * term that requires structural comparison to work. Sigh.
+ *)
+
+let htab_canonicalize (htab:('a,'b) Hashtbl.t) : ('a,'b) Hashtbl.t =
+  let n = Hashtbl.create (Hashtbl.length htab) in
+    Array.iter
+      (fun k -> Hashtbl.add n k (Hashtbl.find htab k))
+      (sorted_htab_keys htab);
+    n
+;;
+
 let htab_map
     (htab:('a,'b) Hashtbl.t)
     (f:'a -> 'b -> ('c * 'd))
@@ -230,10 +245,9 @@ let htab_map
       htab_put ntab c d
   in
     Hashtbl.iter g htab;
-    ntab
+    htab_canonicalize (ntab)
 ;;
 
-
 let htab_fold
     (fn:'a -> 'b -> 'c -> 'c)
     (init:'c)