fix haddock submodule pointer

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

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

-        checkFamInstConsistency, tcExtendLocalFamInstEnv
+        checkFamInstConsistency, tcExtendLocalFamInstEnv, tcGetFamInstEnvs

     ) where
 
     ) where
 

-#include "HsVersions.h"
-

 import HscTypes
 import FamInstEnv
 import HscTypes
 import FamInstEnv

+import LoadIface

 import TcMType
 import TcMType

-import TcType

 import TcRnMonad
 import TyCon
 import TcRnMonad
 import TyCon

-import Type

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

-import FiniteMap
+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}
 
 

@@ -37,6 +36,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

@@ -63,10 +72,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

@@ -74,46 +83,48 @@ checkFamInstConsistency famInstMods directlyImpMods
        ; (eps, hpt) <- getEpsAndHpt
 
        ; let { -- Fetch the iface of a given module.  Must succeed as
        ; (eps, hpt) <- getEpsAndHpt
 
        ; let { -- Fetch the iface of a given module.  Must succeed as

-              -- all imported modules must already have been loaded.
+              -- all directly imported modules must already have been loaded.

               modIface mod = 
                 case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of
                    Nothing    -> panic "FamInst.checkFamInstConsistency"
                    Just iface -> iface
 
              ; hmiModule     = mi_module . hm_iface
               modIface mod = 
                 case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of
                    Nothing    -> panic "FamInst.checkFamInstConsistency"
                    Just iface -> iface
 
              ; hmiModule     = mi_module . hm_iface

-            ; hmiFamInstEnv = mkFamInstEnv . md_fam_insts . hm_details
-            ; mkFamInstEnv  = extendFamInstEnvList emptyFamInstEnv
-             ; hptModInsts   = [ (hmiModule hmi, hmiFamInstEnv hmi) 
-                              | hmi <- eltsUFM hpt]
-             ; modInstsEnv   = eps_mod_fam_inst_env eps        -- external modules
-                              `extendModuleEnvList`    -- plus
-                              hptModInsts              -- home package modules
+            ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv 
+                               . md_fam_insts . hm_details
+             ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi) 
+                                          | hmi <- eltsUFM hpt]

             ; groups        = map (dep_finsts . mi_deps . modIface) 
                                   directlyImpMods
             ; okPairs       = listToSet $ concatMap allPairs groups
                 -- instances of okPairs are consistent
             ; criticalPairs = listToSet $ allPairs famInstMods
                 -- all pairs that we need to consider
             ; groups        = map (dep_finsts . mi_deps . modIface) 
                                   directlyImpMods
             ; okPairs       = listToSet $ concatMap allPairs groups
                 -- 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
             }
 

-       ; mapM_ (check modInstsEnv) toCheckPairs
+       ; mapM_ (check hpt_fam_insts) toCheckPairs

        }
   where
     allPairs []     = []
     allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms
 
        }
   where
     allPairs []     = []
     allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms
 

-    -- The modules are guaranteed to be in the environment, as they are either
-    -- 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
-           ; insts1   = famInstEnvElts instEnv1
-           }
-        in
-       mapM_ (checkForConflicts (emptyFamInstEnv, instEnv2)) insts1
+    check hpt_fam_insts (ModulePair m1 m2)
+      = do { env1 <- getFamInsts hpt_fam_insts m1
+           ; env2 <- getFamInsts hpt_fam_insts m2
+           ; mapM_ (checkForConflicts (emptyFamInstEnv, env2))   
+                   (famInstEnvElts env1) }
+
+getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv
+getFamInsts hpt_fam_insts mod
+  | Just env <- lookupModuleEnv hpt_fam_insts mod = return env
+  | otherwise = do { _ <- initIfaceTcRn (loadSysInterface doc mod)
+                   ; eps <- getEps
+                   ; return (expectJust "checkFamInstConsistency" $
+                             lookupModuleEnv (eps_mod_fam_inst_env eps) mod) }
+  where
+    doc = ppr mod <+> ptext (sLit "is a family-instance module")

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -169,38 +180,30 @@ 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
-             }
-       ; (tvs', _, tau') <- tcInstSkolType FamInstSkol ty
-
-       ; let (fam, tys') = tcSplitTyConApp tau'
-
-       ; let { matches   = lookupFamInstEnvUnify inst_envs fam tys'
-            ; conflicts = [ conflictingFamInst
-                          | match@(conflictingFamInst, _) <- matches
-                          , conflicting fam tys' 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/newtype instances, any overlap is a conflict (as
-    -- these instances imply injective type mappings).
-    conflicting _   _    tycon _                 | isAlgTyCon tycon = True
-    conflicting fam tys' tycon (subst, cFamInst) | otherwise     =
-      panic "FamInst.checkForConflicts: overlap check for indexed synonyms is still missing"

 
 

+conflictInstErr :: FamInst -> FamInst -> TcRn ()

 conflictInstErr famInst conflictingFamInst
   = addFamInstLoc famInst $
 conflictInstErr famInst conflictingFamInst
   = addFamInstLoc famInst $

-    addErr (hang (ptext SLIT("Conflicting family instance declarations:"))
+    addErr (hang (ptext (sLit "Conflicting family instance declarations:"))

               2 (pprFamInsts [famInst, conflictingFamInst]))
 
               2 (pprFamInsts [famInst, conflictingFamInst]))
 

+addFamInstLoc :: FamInst -> TcRn a -> TcRn a

 addFamInstLoc famInst thing_inside
   = setSrcSpan (mkSrcSpan loc loc) thing_inside
   where
     loc = getSrcLoc famInst
 addFamInstLoc famInst thing_inside
   = setSrcSpan (mkSrcSpan loc loc) thing_inside
   where
     loc = getSrcLoc famInst

+
+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}