From 4635acd2d4e4404b2b1a89909cd765ac310d62c5 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Fri, 27 Nov 2015 15:28:12 -0500
Subject: Fix tricky case of functor signature subsumption

---
 src/elab_env.sig     | 2 ++
 src/elab_env.sml     | 4 ++++
 src/elaborate.sml    | 9 +++++++--
 tests/subfunctor.ur  | 6 ++++++
 tests/subfunctor.urs | 3 +++
 5 files changed, 22 insertions(+), 2 deletions(-)
 create mode 100644 tests/subfunctor.ur
 create mode 100644 tests/subfunctor.urs

diff --git a/src/elab_env.sig b/src/elab_env.sig
index e0c589c4..cbc85cdd 100644
--- a/src/elab_env.sig
+++ b/src/elab_env.sig
@@ -37,6 +37,8 @@ signature ELAB_ENV = sig
 
     type env
 
+    val dump : env -> unit
+
     val empty : env
 
     exception UnboundRel of int
diff --git a/src/elab_env.sml b/src/elab_env.sml
index 9c9cd14f..3523b576 100644
--- a/src/elab_env.sml
+++ b/src/elab_env.sml
@@ -239,6 +239,10 @@ type env = {
      str : (string * sgn) IM.map
 }
 
+fun dump (env : env) =
+    (print "NamedC:\n";
+     IM.appi (fn (n, (x, k, co)) => print (x ^ " [" ^ Int.toString n ^ "]\n")) (#namedC env))
+
 val namedCounter = ref 0
 
 fun newNamed () =
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 7671f597..25cce6bd 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -1359,7 +1359,9 @@
      end
 
  and unifyCons env loc c1 c2 =
-     unifyCons' env loc c1 c2
+     ((*Print.prefaces "uc" [("c1", p_con env c1),
+                           ("c2", p_con env c2)];*)
+     unifyCons' env loc c1 c2)
      handle CUnify' (env', err) => raise CUnify (c1, c2, env', err)
           | KUnify (arg as {3 = env', ...}) => raise CUnify (c1, c2, env', CKind arg)
 
@@ -3079,6 +3081,8 @@ and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) =
 
             fun cpart n = IM.find (!counterparts, n)
             fun cparts (n2, n1) = counterparts := IM.insert (!counterparts, n2, n1)
+            fun uncparts n2 = (counterparts := #1 (IM.remove (!counterparts, n2)))
+                              handle NotFound => ()
 
             val sub2 = U.Con.map {kind = fn k => k,
                                   con = fn c =>
@@ -3107,7 +3111,8 @@ and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) =
                                                           if E.checkENamed env n then
                                                               env
                                                           else
-                                                              E.pushCNamedAs env x n k (SOME c)
+                                                              (uncparts n;
+                                                               E.pushCNamedAs env x n k (SOME c))
                                                         | L'.SgiConAbs (x, n, k) =>
                                                           if E.checkENamed env n then
                                                               env
diff --git a/tests/subfunctor.ur b/tests/subfunctor.ur
new file mode 100644
index 00000000..3c2aa83f
--- /dev/null
+++ b/tests/subfunctor.ur
@@ -0,0 +1,6 @@
+functor F(M : sig con fs :: {Type} end) = struct
+    open M
+
+    functor G(M : sig val x : $(map sql_injectable_prim fs) end) = struct
+    end
+end
diff --git a/tests/subfunctor.urs b/tests/subfunctor.urs
new file mode 100644
index 00000000..db393d21
--- /dev/null
+++ b/tests/subfunctor.urs
@@ -0,0 +1,3 @@
+functor F(M : sig con fs :: {Type} end) : sig
+    functor G(M : sig val x : $(map sql_injectable_prim M.fs) end) : sig end
+end
-- 
cgit v1.2.3