[commit: ghc] wip/rae-new-coercible: Allow multiple type family instances to match in reduceTyFamApp_maybe (f49e19b)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/rae-new-coercible
Link       : http://ghc.haskell.org/trac/ghc/changeset/f49e19b9f65a00e767ae45d60e1766f4a4f82973/ghc

>---------------------------------------------------------------

commit f49e19b9f65a00e767ae45d60e1766f4a4f82973
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Fri Dec 12 12:02:31 2014 -0500

    Allow multiple type family instances to match in reduceTyFamApp_maybe


>---------------------------------------------------------------

f49e19b9f65a00e767ae45d60e1766f4a4f82973
 compiler/types/FamInstEnv.hs                  | 6 ++++--
 testsuite/tests/ghci/scripts/GhciKinds.hs     | 4 ++++
 testsuite/tests/ghci/scripts/GhciKinds.script | 5 +++++
 testsuite/tests/ghci/scripts/GhciKinds.stdout | 6 ++++++
 4 files changed, 19 insertions(+), 2 deletions(-)

diff --git a/compiler/types/FamInstEnv.hs b/compiler/types/FamInstEnv.hs
index e366037..2578726 100644
--- a/compiler/types/FamInstEnv.hs
+++ b/compiler/types/FamInstEnv.hs
@@ -806,8 +806,10 @@ reduceTyFamApp_maybe envs role tc tys
        -- (e.g. the call in topNormaliseType_maybe) then we can
        -- unwrap data families as well as type-synonym families;
        -- otherwise only type-synonym families
-  , [FamInstMatch { fim_instance = fam_inst
-                  , fim_tys =      inst_tys }] <- lookupFamInstEnv envs tc ntys
+  , FamInstMatch { fim_instance = fam_inst
+                 , fim_tys =      inst_tys } : _ <- lookupFamInstEnv envs tc ntys
+      -- NB: Allow multiple matches because of compatible overlap
+                                                    
   = let ax     = famInstAxiom fam_inst
         co     = mkUnbranchedAxInstCo role ax inst_tys
         ty     = pSnd (coercionKind co)
diff --git a/testsuite/tests/ghci/scripts/GhciKinds.hs b/testsuite/tests/ghci/scripts/GhciKinds.hs
index 4945814..8e1af37 100644
--- a/testsuite/tests/ghci/scripts/GhciKinds.hs
+++ b/testsuite/tests/ghci/scripts/GhciKinds.hs
@@ -4,3 +4,7 @@ module GhciKinds where
 type family F a :: *
 type instance F [a] = a -> F a
 type instance F Int = Bool
+
+-- test ":kind!" in the presence of compatible overlap
+type instance F (Maybe a) = Char
+type instance F (Maybe Int) = Char
diff --git a/testsuite/tests/ghci/scripts/GhciKinds.script b/testsuite/tests/ghci/scripts/GhciKinds.script
index 310c2a8..fa94015 100644
--- a/testsuite/tests/ghci/scripts/GhciKinds.script
+++ b/testsuite/tests/ghci/scripts/GhciKinds.script
@@ -3,3 +3,8 @@
 :l GhciKinds
 :kind F [[[Int]]]
 :kind! F [[[Int]]]
+:kind! F (Maybe Int)
+:kind! F (Maybe Bool)
+
+:seti -XRankNTypes
+:kind! forall a. F (Maybe a)
diff --git a/testsuite/tests/ghci/scripts/GhciKinds.stdout b/testsuite/tests/ghci/scripts/GhciKinds.stdout
index 3961994..e34b84a 100644
--- a/testsuite/tests/ghci/scripts/GhciKinds.stdout
+++ b/testsuite/tests/ghci/scripts/GhciKinds.stdout
@@ -3,3 +3,9 @@ Maybe :: * -> *
 F [[[Int]]] :: *
 F [[[Int]]] :: *
 = [[Int]] -> [Int] -> Int -> Bool
+F (Maybe Int) :: *
+= Char
+F (Maybe Bool) :: *
+= Char
+forall a. F (Maybe a) :: *
+= Char