add -fsimpleopt-before-flatten

[ghc-hetmet.git] / compiler / typecheck / FamInst.lhs

diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs
index 8e8df88..45584d9 100644 (file)
--- a/compiler/typecheck/FamInst.lhs
+++ b/compiler/typecheck/FamInst.lhs
@@ -2,26 +2,25 @@ The @FamInst@ type: family instance heads
 
 \begin{code}
 module FamInst ( 
 
 \begin{code}
 module FamInst ( 

-        checkFamInstConsistency, tcExtendLocalFamInstEnv
+        checkFamInstConsistency, tcExtendLocalFamInstEnv, tcGetFamInstEnvs

     ) where
 
 import HscTypes
 import FamInstEnv
 import TcMType
     ) where
 
 import HscTypes
 import FamInstEnv
 import TcMType

-import TcType

 import TcRnMonad
 import TyCon
 import TcRnMonad
 import TyCon

-import Type

 import Name
 import Module
 import SrcLoc
 import Outputable
 import Name
 import Module
 import SrcLoc
 import Outputable

-import LazyUniqFM
-import FiniteMap
+import UniqFM

 import FastString
 
 import FastString
 

-import Maybe
-import Monad
+import Maybes
+import Control.Monad
+import Data.Map (Map)
+import qualified Data.Map as Map

 \end{code}
 
 
 \end{code}
 
 

@@ -36,6 +35,16 @@ check whether the instances in the two modules are consistent, *unless* we can
 be certain that the instances of the two modules have already been checked for
 consistency during the compilation of modules that we import.
 
 be certain that the instances of the two modules have already been checked for
 consistency during the compilation of modules that we import.
 

+Why do we need to check?  Consider 
+   module X1 where               module X2 where
+    data T1                        data T2
+    type instance F T1 b = Int     type instance F a T2 = Char
+    f1 :: F T1 a -> Int                    f2 :: Char -> F a T2
+    f1 x = x                       f2 x = x
+
+Now if we import both X1 and X2 we could make (f2 . f1) :: Int -> Char.
+Notice that neither instance is an orphan.
+

 How do we know which pairs of modules have already been checked?  Any pair of
 modules where both modules occur in the `HscTypes.dep_finsts' set (of the
 `HscTypes.Dependencies') of one of our directly imported modules must have
 How do we know which pairs of modules have already been checked?  Any pair of
 modules where both modules occur in the `HscTypes.dep_finsts' set (of the
 `HscTypes.Dependencies') of one of our directly imported modules must have

@@ -62,10 +71,10 @@ instance Ord ModulePair where
 
 -- Sets of module pairs
 --
 
 -- Sets of module pairs
 --

-type ModulePairSet = FiniteMap ModulePair ()
+type ModulePairSet = Map ModulePair ()

 
 listToSet :: [ModulePair] -> ModulePairSet
 
 listToSet :: [ModulePair] -> ModulePairSet

-listToSet l = listToFM (zip l (repeat ()))
+listToSet l = Map.fromList (zip l (repeat ()))

 
 checkFamInstConsistency :: [Module] -> [Module] -> TcM ()
 checkFamInstConsistency famInstMods directlyImpMods
 
 checkFamInstConsistency :: [Module] -> [Module] -> TcM ()
 checkFamInstConsistency famInstMods directlyImpMods

@@ -93,7 +102,7 @@ checkFamInstConsistency famInstMods directlyImpMods
                 -- instances of okPairs are consistent
             ; criticalPairs = listToSet $ allPairs famInstMods
                 -- all pairs that we need to consider
                 -- instances of okPairs are consistent
             ; criticalPairs = listToSet $ allPairs famInstMods
                 -- all pairs that we need to consider

-             ; toCheckPairs  = keysFM $ criticalPairs `minusFM` okPairs
+             ; toCheckPairs  = Map.keys $ criticalPairs `Map.difference` okPairs

                 -- the difference gives us the pairs we need to check now
             }
 
                 -- the difference gives us the pairs we need to check now
             }
 

@@ -107,8 +116,8 @@ checkFamInstConsistency famInstMods directlyImpMods
     -- already loaded in the EPS or they are in the HPT.
     --
     check modInstsEnv (ModulePair m1 m2)
     -- already loaded in the EPS or they are in the HPT.
     --
     check modInstsEnv (ModulePair m1 m2)

-      = let { instEnv1 = fromJust . lookupModuleEnv modInstsEnv $ m1
-           ; instEnv2 = fromJust . lookupModuleEnv modInstsEnv $ m2
+      = let { instEnv1 = (expectJust "checkFamInstConsistency") . lookupModuleEnv modInstsEnv $ m1
+           ; instEnv2 = (expectJust "checkFamInstConsistency") . lookupModuleEnv modInstsEnv $ m2

            ; insts1   = famInstEnvElts instEnv1
            }
         in
            ; insts1   = famInstEnvElts instEnv1
            }
         in

@@ -168,38 +177,13 @@ checkForConflicts inst_envs famInst
                -- (since we do unification).  
                -- We use tcInstSkolType because we don't want to allocate
                -- fresh *meta* type variables.  
                -- (since we do unification).  
                -- We use tcInstSkolType because we don't want to allocate
                -- fresh *meta* type variables.  

-       ; let { tycon = famInstTyCon famInst
-            ; ty    = case tyConFamInst_maybe tycon of
-                        Nothing        -> panic "FamInst.checkForConflicts"
-                        Just (tc, tys) -> tc `mkTyConApp` tys
-             }
-       ; (_, _, tau') <- tcInstSkolType FamInstSkol ty
-
-       ; let (fam, tys') = tcSplitTyConApp tau'
-
-       ; let { matches   = lookupFamInstEnvUnify inst_envs fam tys'
-            ; conflicts = [ conflictingFamInst
-                          | match@((conflictingFamInst, _), _) <- matches
-                          , conflicting tycon match 
-                          ]
-            }
+
+       ; skol_tvs <- tcInstSkolTyVars (tyConTyVars (famInstTyCon famInst))
+       ; let conflicts = lookupFamInstEnvConflicts inst_envs famInst skol_tvs

        ; unless (null conflicts) $
        ; unless (null conflicts) $

-          conflictInstErr famInst (head conflicts)
+          conflictInstErr famInst (fst (head conflicts))

        }
   where
        }
   where

-      -- * In the case of data family instances, any overlap is fundamentally a 
-      --   conflict (as these instances imply injective type mappings).
-      -- * In the case of type family instances, overlap is admitted as long as 
-      --   the right-hand sides of the overlapping rules coincide under the
-      --   overlap substitution.  We require that they are syntactically equal;
-      --   anything else would be difficult to test for at this stage.
-    conflicting tycon1 ((famInst2, _), subst) 
-      | isAlgTyCon tycon1 = True
-      | otherwise         = not (rhs1 `tcEqType` rhs2)
-      where
-        tycon2 = famInstTyCon famInst2
-        rhs1   = substTy subst $ synTyConType tycon1
-        rhs2   = substTy subst $ synTyConType tycon2

 
 conflictInstErr :: FamInst -> FamInst -> TcRn ()
 conflictInstErr famInst conflictingFamInst
 
 conflictInstErr :: FamInst -> FamInst -> TcRn ()
 conflictInstErr famInst conflictingFamInst

@@ -212,4 +196,17 @@ addFamInstLoc famInst thing_inside
   = setSrcSpan (mkSrcSpan loc loc) thing_inside
   where
     loc = getSrcLoc famInst
   = setSrcSpan (mkSrcSpan loc loc) thing_inside
   where
     loc = getSrcLoc famInst

+\end{code} 
+
+\begin{code} 
+
+tcGetFamInstEnvs :: TcM (FamInstEnv, FamInstEnv)
+-- Gets both the external-package inst-env
+-- and the home-pkg inst env (includes module being compiled)
+tcGetFamInstEnvs 
+  = do { eps <- getEps; env <- getGblEnv
+       ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) 
+       }
+
+

 \end{code}
 \end{code}