compiler/typecheck/FamInst.lhs

   1 The @FamInst@ type: family instance heads
   2
   3 \begin{code}
   4 module FamInst (
   5         checkFamInstConsistency, tcExtendLocalFamInstEnv
   6     ) where
   7
   8 import HscTypes
   9 import FamInstEnv
  10 import TcMType
  11 import TcType
  12 import TcRnMonad
  13 import TyCon
  14 import Name
  15 import Module
  16 import SrcLoc
  17 import Outputable
  18 import UniqFM
  19 import FiniteMap
  20 import FastString
  21
  22 import Maybes
  23 import Control.Monad
  24 \end{code}
  25
  26
  27 %************************************************************************
  28 %*                                                                      *
  29         Optimised overlap checking for family instances
  30 %*                                                                      *
  31 %************************************************************************
  32
  33 For any two family instance modules that we import directly or indirectly, we
  34 check whether the instances in the two modules are consistent, *unless* we can
  35 be certain that the instances of the two modules have already been checked for
  36 consistency during the compilation of modules that we import.
  37
  38 Why do we need to check?  Consider
  39    module X1 where                module X2 where
  40     data T1                         data T2
  41     type instance F T1 b = Int      type instance F a T2 = Char
  42     f1 :: F T1 a -> Int             f2 :: Char -> F a T2
  43     f1 x = x                        f2 x = x
  44
  45 Now if we import both X1 and X2 we could make (f2 . f1) :: Int -> Char.
  46 Notice that neither instance is an orphan.
  47
  48 How do we know which pairs of modules have already been checked?  Any pair of
  49 modules where both modules occur in the `HscTypes.dep_finsts' set (of the
  50 `HscTypes.Dependencies') of one of our directly imported modules must have
  51 already been checked.  Everything else, we check now.  (So that we can be
  52 certain that the modules in our `HscTypes.dep_finsts' are consistent.)
  53
  54 \begin{code}
  55 -- The optimisation of overlap tests is based on determining pairs of modules
  56 -- whose family instances need to be checked for consistency.
  57 --
  58 data ModulePair = ModulePair Module Module
  59
  60 -- canonical order of the components of a module pair
  61 --
  62 canon :: ModulePair -> (Module, Module)
  63 canon (ModulePair m1 m2) | m1 < m2   = (m1, m2)
  64                          | otherwise = (m2, m1)
  65
  66 instance Eq ModulePair where
  67   mp1 == mp2 = canon mp1 == canon mp2
  68
  69 instance Ord ModulePair where
  70   mp1 `compare` mp2 = canon mp1 `compare` canon mp2
  71
  72 -- Sets of module pairs
  73 --
  74 type ModulePairSet = FiniteMap ModulePair ()
  75
  76 listToSet :: [ModulePair] -> ModulePairSet
  77 listToSet l = listToFM (zip l (repeat ()))
  78
  79 checkFamInstConsistency :: [Module] -> [Module] -> TcM ()
  80 checkFamInstConsistency famInstMods directlyImpMods
  81   = do { dflags     <- getDOpts
  82        ; (eps, hpt) <- getEpsAndHpt
  83
  84        ; let { -- Fetch the iface of a given module.  Must succeed as
  85                -- all imported modules must already have been loaded.
  86                modIface mod =
  87                  case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of
  88                    Nothing    -> panic "FamInst.checkFamInstConsistency"
  89                    Just iface -> iface
  90
  91              ; hmiModule     = mi_module . hm_iface
  92              ; hmiFamInstEnv = mkFamInstEnv . md_fam_insts . hm_details
  93              ; mkFamInstEnv  = extendFamInstEnvList emptyFamInstEnv
  94              ; hptModInsts   = [ (hmiModule hmi, hmiFamInstEnv hmi)
  95                                | hmi <- eltsUFM hpt]
  96              ; modInstsEnv   = eps_mod_fam_inst_env eps -- external modules
  97                                `extendModuleEnvList`    -- plus
  98                                hptModInsts              -- home package modules
  99              ; groups        = map (dep_finsts . mi_deps . modIface)
 100                                    directlyImpMods
 101              ; okPairs       = listToSet $ concatMap allPairs groups
 102                  -- instances of okPairs are consistent
 103              ; criticalPairs = listToSet $ allPairs famInstMods
 104                  -- all pairs that we need to consider
 105              ; toCheckPairs  = keysFM $ criticalPairs `minusFM` okPairs
 106                  -- the difference gives us the pairs we need to check now
 107              }
 108
 109        ; mapM_ (check modInstsEnv) toCheckPairs
 110        }
 111   where
 112     allPairs []     = []
 113     allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms
 114
 115     -- The modules are guaranteed to be in the environment, as they are either
 116     -- already loaded in the EPS or they are in the HPT.
 117     --
 118     check modInstsEnv (ModulePair m1 m2)
 119       = let { instEnv1 = (expectJust "checkFamInstConsistency") . lookupModuleEnv modInstsEnv $ m1
 120             ; instEnv2 = (expectJust "checkFamInstConsistency") . lookupModuleEnv modInstsEnv $ m2
 121             ; insts1   = famInstEnvElts instEnv1
 122             }
 123         in
 124         mapM_ (checkForConflicts (emptyFamInstEnv, instEnv2)) insts1
 125 \end{code}
 126
 127 %************************************************************************
 128 %*                                                                      *
 129         Extending the family instance environment
 130 %*                                                                      *
 131 %************************************************************************
 132
 133 \begin{code}
 134 -- Add new locally-defined family instances
 135 tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a
 136 tcExtendLocalFamInstEnv fam_insts thing_inside
 137  = do { env <- getGblEnv
 138       ; inst_env' <- foldlM addLocalFamInst (tcg_fam_inst_env env) fam_insts
 139       ; let env' = env { tcg_fam_insts    = fam_insts ++ tcg_fam_insts env,
 140                          tcg_fam_inst_env = inst_env' }
 141       ; setGblEnv env' thing_inside
 142       }
 143
 144 -- Check that the proposed new instance is OK,
 145 -- and then add it to the home inst env
 146 addLocalFamInst :: FamInstEnv -> FamInst -> TcM FamInstEnv
 147 addLocalFamInst home_fie famInst
 148   = do {       -- Load imported instances, so that we report
 149                -- overlaps correctly
 150        ; eps <- getEps
 151        ; let inst_envs = (eps_fam_inst_env eps, home_fie)
 152
 153                -- Check for conflicting instance decls
 154        ; checkForConflicts inst_envs famInst
 155
 156                -- OK, now extend the envt
 157        ; return (extendFamInstEnv home_fie famInst)
 158        }
 159 \end{code}
 160
 161 %************************************************************************
 162 %*                                                                      *
 163         Checking an instance against conflicts with an instance env
 164 %*                                                                      *
 165 %************************************************************************
 166
 167 Check whether a single family instance conflicts with those in two instance
 168 environments (one for the EPS and one for the HPT).
 169
 170 \begin{code}
 171 checkForConflicts :: (FamInstEnv, FamInstEnv) -> FamInst -> TcM ()
 172 checkForConflicts inst_envs famInst
 173   = do {        -- To instantiate the family instance type, extend the instance
 174                 -- envt with completely fresh template variables
 175                 -- This is important because the template variables must
 176                 -- not overlap with anything in the things being looked up
 177                 -- (since we do unification).
 178                 -- We use tcInstSkolType because we don't want to allocate
 179                 -- fresh *meta* type variables.
 180
 181        ; skol_tvs <- tcInstSkolTyVars FamInstSkol
 182                                       (tyConTyVars (famInstTyCon famInst))
 183        ; let conflicts = lookupFamInstEnvConflicts inst_envs famInst skol_tvs
 184        ; unless (null conflicts) $
 185            conflictInstErr famInst (fst (head conflicts))
 186        }
 187   where
 188
 189 conflictInstErr :: FamInst -> FamInst -> TcRn ()
 190 conflictInstErr famInst conflictingFamInst
 191   = addFamInstLoc famInst $
 192     addErr (hang (ptext (sLit "Conflicting family instance declarations:"))
 193                2 (pprFamInsts [famInst, conflictingFamInst]))
 194
 195 addFamInstLoc :: FamInst -> TcRn a -> TcRn a
 196 addFamInstLoc famInst thing_inside
 197   = setSrcSpan (mkSrcSpan loc loc) thing_inside
 198   where
 199     loc = getSrcLoc famInst
 200 \end{code}