compiler/typecheck/FamInst.lhs

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