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 Type
  15 import Name
  16 import Module
  17 import SrcLoc
  18 import Outputable
  19 import LazyUniqFM
  20 import FiniteMap
  21 import FastString
  22
  23 import Maybe
  24 import Monad
  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 = FiniteMap ModulePair ()
  76
  77 listToSet :: [ModulePair] -> ModulePairSet
  78 listToSet l = listToFM (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 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 = mkFamInstEnv . md_fam_insts . hm_details
  94              ; mkFamInstEnv  = extendFamInstEnvList emptyFamInstEnv
  95              ; hptModInsts   = [ (hmiModule hmi, hmiFamInstEnv hmi)
  96                                | hmi <- eltsUFM hpt]
  97              ; modInstsEnv   = eps_mod_fam_inst_env eps -- external modules
  98                                `extendModuleEnvList`    -- plus
  99                                hptModInsts              -- home package modules
 100              ; groups        = map (dep_finsts . mi_deps . modIface)
 101                                    directlyImpMods
 102              ; okPairs       = listToSet $ concatMap allPairs groups
 103                  -- instances of okPairs are consistent
 104              ; criticalPairs = listToSet $ allPairs famInstMods
 105                  -- all pairs that we need to consider
 106              ; toCheckPairs  = keysFM $ criticalPairs `minusFM` okPairs
 107                  -- the difference gives us the pairs we need to check now
 108              }
 109
 110        ; mapM_ (check modInstsEnv) toCheckPairs
 111        }
 112   where
 113     allPairs []     = []
 114     allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms
 115
 116     -- The modules are guaranteed to be in the environment, as they are either
 117     -- already loaded in the EPS or they are in the HPT.
 118     --
 119     check modInstsEnv (ModulePair m1 m2)
 120       = let { instEnv1 = fromJust . lookupModuleEnv modInstsEnv $ m1
 121             ; instEnv2 = fromJust . lookupModuleEnv modInstsEnv $ m2
 122             ; insts1   = famInstEnvElts instEnv1
 123             }
 124         in
 125         mapM_ (checkForConflicts (emptyFamInstEnv, instEnv2)) insts1
 126 \end{code}
 127
 128 %************************************************************************
 129 %*                                                                      *
 130         Extending the family instance environment
 131 %*                                                                      *
 132 %************************************************************************
 133
 134 \begin{code}
 135 -- Add new locally-defined family instances
 136 tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a
 137 tcExtendLocalFamInstEnv fam_insts thing_inside
 138  = do { env <- getGblEnv
 139       ; inst_env' <- foldlM addLocalFamInst (tcg_fam_inst_env env) fam_insts
 140       ; let env' = env { tcg_fam_insts    = fam_insts ++ tcg_fam_insts env,
 141                          tcg_fam_inst_env = inst_env' }
 142       ; setGblEnv env' thing_inside
 143       }
 144
 145 -- Check that the proposed new instance is OK,
 146 -- and then add it to the home inst env
 147 addLocalFamInst :: FamInstEnv -> FamInst -> TcM FamInstEnv
 148 addLocalFamInst home_fie famInst
 149   = do {       -- Load imported instances, so that we report
 150                -- overlaps correctly
 151        ; eps <- getEps
 152        ; let inst_envs = (eps_fam_inst_env eps, home_fie)
 153
 154                -- Check for conflicting instance decls
 155        ; checkForConflicts inst_envs famInst
 156
 157                -- OK, now extend the envt
 158        ; return (extendFamInstEnv home_fie famInst)
 159        }
 160 \end{code}
 161
 162 %************************************************************************
 163 %*                                                                      *
 164         Checking an instance against conflicts with an instance env
 165 %*                                                                      *
 166 %************************************************************************
 167
 168 Check whether a single family instance conflicts with those in two instance
 169 environments (one for the EPS and one for the HPT).
 170
 171 \begin{code}
 172 checkForConflicts :: (FamInstEnv, FamInstEnv) -> FamInst -> TcM ()
 173 checkForConflicts inst_envs famInst
 174   = do {        -- To instantiate the family instance type, extend the instance
 175                 -- envt with completely fresh template variables
 176                 -- This is important because the template variables must
 177                 -- not overlap with anything in the things being looked up
 178                 -- (since we do unification).
 179                 -- We use tcInstSkolType because we don't want to allocate
 180                 -- fresh *meta* type variables.
 181        ; let { tycon = famInstTyCon famInst
 182              ; ty    = case tyConFamInst_maybe tycon of
 183                          Nothing        -> panic "FamInst.checkForConflicts"
 184                          Just (tc, tys) -> tc `mkTyConApp` tys
 185              }
 186        ; (_, _, tau') <- tcInstSkolType FamInstSkol ty
 187
 188        ; let (fam, tys') = tcSplitTyConApp tau'
 189
 190        ; let { matches   = lookupFamInstEnvUnify inst_envs fam tys'
 191              ; conflicts = [ conflictingFamInst
 192                            | match@((conflictingFamInst, _), _) <- matches
 193                            , conflicting tycon match
 194                            ]
 195              }
 196        ; unless (null conflicts) $
 197            conflictInstErr famInst (head conflicts)
 198        }
 199   where
 200       -- - In the case of data family instances, any overlap is fundamentally a
 201       --   conflict (as these instances imply injective type mappings).
 202       -- - In the case of type family instances, overlap is admitted as long as
 203       --   the right-hand sides of the overlapping rules coincide under the
 204       --   overlap substitution.  We require that they are syntactically equal;
 205       --   anything else would be difficult to test for at this stage.
 206     conflicting tycon1 ((famInst2, _), subst)
 207       | isAlgTyCon tycon1 = True
 208       | otherwise         = not (rhs1 `tcEqType` rhs2)
 209       where
 210         tycon2 = famInstTyCon famInst2
 211         rhs1   = substTy subst $ synTyConType tycon1
 212         rhs2   = substTy subst $ synTyConType tycon2
 213
 214 conflictInstErr :: FamInst -> FamInst -> TcRn ()
 215 conflictInstErr famInst conflictingFamInst
 216   = addFamInstLoc famInst $
 217     addErr (hang (ptext (sLit "Conflicting family instance declarations:"))
 218                2 (pprFamInsts [famInst, conflictingFamInst]))
 219
 220 addFamInstLoc :: FamInst -> TcRn a -> TcRn a
 221 addFamInstLoc famInst thing_inside
 222   = setSrcSpan (mkSrcSpan loc loc) thing_inside
 223   where
 224     loc = getSrcLoc famInst
 225 \end{code}