compiler/typecheck/FamInst.lhs

   1 The @FamInst@ type: family instance heads
   2
   3 \begin{code}
   4 {-# OPTIONS -w #-}
   5 -- The above warning supression flag is a temporary kludge.
   6 -- While working on this module you are encouraged to remove it and fix
   7 -- any warnings in the module. See
   8 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
   9 -- for details
  10
  11 module FamInst (
  12         checkFamInstConsistency, tcExtendLocalFamInstEnv
  13     ) where
  14
  15 import HscTypes
  16 import FamInstEnv
  17 import TcMType
  18 import TcType
  19 import TcRnMonad
  20 import TyCon
  21 import Type
  22 import Name
  23 import Module
  24 import SrcLoc
  25 import Outputable
  26 import LazyUniqFM
  27 import FiniteMap
  28 import FastString
  29
  30 import Maybe
  31 import Monad
  32 \end{code}
  33
  34
  35 %************************************************************************
  36 %*                                                                      *
  37         Optimised overlap checking for family instances
  38 %*                                                                      *
  39 %************************************************************************
  40
  41 For any two family instance modules that we import directly or indirectly, we
  42 check whether the instances in the two modules are consistent, *unless* we can
  43 be certain that the instances of the two modules have already been checked for
  44 consistency during the compilation of modules that we import.
  45
  46 How do we know which pairs of modules have already been checked?  Any pair of
  47 modules where both modules occur in the `HscTypes.dep_finsts' set (of the
  48 `HscTypes.Dependencies') of one of our directly imported modules must have
  49 already been checked.  Everything else, we check now.  (So that we can be
  50 certain that the modules in our `HscTypes.dep_finsts' are consistent.)
  51
  52 \begin{code}
  53 -- The optimisation of overlap tests is based on determining pairs of modules
  54 -- whose family instances need to be checked for consistency.
  55 --
  56 data ModulePair = ModulePair Module Module
  57
  58 -- canonical order of the components of a module pair
  59 --
  60 canon :: ModulePair -> (Module, Module)
  61 canon (ModulePair m1 m2) | m1 < m2   = (m1, m2)
  62                          | otherwise = (m2, m1)
  63
  64 instance Eq ModulePair where
  65   mp1 == mp2 = canon mp1 == canon mp2
  66
  67 instance Ord ModulePair where
  68   mp1 `compare` mp2 = canon mp1 `compare` canon mp2
  69
  70 -- Sets of module pairs
  71 --
  72 type ModulePairSet = FiniteMap ModulePair ()
  73
  74 listToSet :: [ModulePair] -> ModulePairSet
  75 listToSet l = listToFM (zip l (repeat ()))
  76
  77 checkFamInstConsistency :: [Module] -> [Module] -> TcM ()
  78 checkFamInstConsistency famInstMods directlyImpMods
  79   = do { dflags     <- getDOpts
  80        ; (eps, hpt) <- getEpsAndHpt
  81
  82        ; let { -- Fetch the iface of a given module.  Must succeed as
  83                -- all imported modules must already have been loaded.
  84                modIface mod =
  85                  case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of
  86                    Nothing    -> panic "FamInst.checkFamInstConsistency"
  87                    Just iface -> iface
  88
  89              ; hmiModule     = mi_module . hm_iface
  90              ; hmiFamInstEnv = mkFamInstEnv . md_fam_insts . hm_details
  91              ; mkFamInstEnv  = extendFamInstEnvList emptyFamInstEnv
  92              ; hptModInsts   = [ (hmiModule hmi, hmiFamInstEnv hmi)
  93                                | hmi <- eltsUFM hpt]
  94              ; modInstsEnv   = eps_mod_fam_inst_env eps -- external modules
  95                                `extendModuleEnvList`    -- plus
  96                                hptModInsts              -- home package modules
  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  = keysFM $ criticalPairs `minusFM` okPairs
 104                  -- the difference gives us the pairs we need to check now
 105              }
 106
 107        ; mapM_ (check modInstsEnv) toCheckPairs
 108        }
 109   where
 110     allPairs []     = []
 111     allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms
 112
 113     -- The modules are guaranteed to be in the environment, as they are either
 114     -- already loaded in the EPS or they are in the HPT.
 115     --
 116     check modInstsEnv (ModulePair m1 m2)
 117       = let { instEnv1 = fromJust . lookupModuleEnv modInstsEnv $ m1
 118             ; instEnv2 = fromJust . lookupModuleEnv modInstsEnv $ m2
 119             ; insts1   = famInstEnvElts instEnv1
 120             }
 121         in
 122         mapM_ (checkForConflicts (emptyFamInstEnv, instEnv2)) insts1
 123 \end{code}
 124
 125 %************************************************************************
 126 %*                                                                      *
 127         Extending the family instance environment
 128 %*                                                                      *
 129 %************************************************************************
 130
 131 \begin{code}
 132 -- Add new locally-defined family instances
 133 tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a
 134 tcExtendLocalFamInstEnv fam_insts thing_inside
 135  = do { env <- getGblEnv
 136       ; inst_env' <- foldlM addLocalFamInst (tcg_fam_inst_env env) fam_insts
 137       ; let env' = env { tcg_fam_insts    = fam_insts ++ tcg_fam_insts env,
 138                          tcg_fam_inst_env = inst_env' }
 139       ; setGblEnv env' thing_inside
 140       }
 141
 142 -- Check that the proposed new instance is OK,
 143 -- and then add it to the home inst env
 144 addLocalFamInst :: FamInstEnv -> FamInst -> TcM FamInstEnv
 145 addLocalFamInst home_fie famInst
 146   = do {       -- Load imported instances, so that we report
 147                -- overlaps correctly
 148        ; eps <- getEps
 149        ; let inst_envs = (eps_fam_inst_env eps, home_fie)
 150
 151                -- Check for conflicting instance decls
 152        ; checkForConflicts inst_envs famInst
 153
 154                -- OK, now extend the envt
 155        ; return (extendFamInstEnv home_fie famInst)
 156        }
 157 \end{code}
 158
 159 %************************************************************************
 160 %*                                                                      *
 161         Checking an instance against conflicts with an instance env
 162 %*                                                                      *
 163 %************************************************************************
 164
 165 Check whether a single family instance conflicts with those in two instance
 166 environments (one for the EPS and one for the HPT).
 167
 168 \begin{code}
 169 checkForConflicts :: (FamInstEnv, FamInstEnv) -> FamInst -> TcM ()
 170 checkForConflicts inst_envs famInst
 171   = do {        -- To instantiate the family instance type, extend the instance
 172                 -- envt with completely fresh template variables
 173                 -- This is important because the template variables must
 174                 -- not overlap with anything in the things being looked up
 175                 -- (since we do unification).
 176                 -- We use tcInstSkolType because we don't want to allocate
 177                 -- fresh *meta* type variables.
 178        ; let { tycon = famInstTyCon famInst
 179              ; ty    = case tyConFamInst_maybe tycon of
 180                          Nothing        -> panic "FamInst.checkForConflicts"
 181                          Just (tc, tys) -> tc `mkTyConApp` tys
 182              }
 183        ; (tvs', _, tau') <- tcInstSkolType FamInstSkol ty
 184
 185        ; let (fam, tys') = tcSplitTyConApp tau'
 186
 187        ; let { matches   = lookupFamInstEnvUnify inst_envs fam tys'
 188              ; conflicts = [ conflictingFamInst
 189                            | match@((conflictingFamInst, _), _) <- matches
 190                            , conflicting tycon match
 191                            ]
 192              }
 193        ; unless (null conflicts) $
 194            conflictInstErr famInst (head conflicts)
 195        }
 196   where
 197       -- * In the case of data family instances, any overlap is fundamentally a
 198       --   conflict (as these instances imply injective type mappings).
 199       -- * In the case of type family instances, overlap is admitted as long as
 200       --   the right-hand sides of the overlapping rules coincide under the
 201       --   overlap substitution.  We require that they are syntactically equal;
 202       --   anything else would be difficult to test for at this stage.
 203     conflicting tycon1 ((famInst2, _), subst)
 204       | isAlgTyCon tycon1 = True
 205       | otherwise         = not (rhs1 `tcEqType` rhs2)
 206       where
 207         tycon2 = famInstTyCon famInst2
 208         rhs1   = substTy subst $ synTyConType tycon1
 209         rhs2   = substTy subst $ synTyConType tycon2
 210
 211 conflictInstErr famInst conflictingFamInst
 212   = addFamInstLoc famInst $
 213     addErr (hang (ptext (sLit "Conflicting family instance declarations:"))
 214                2 (pprFamInsts [famInst, conflictingFamInst]))
 215
 216 addFamInstLoc famInst thing_inside
 217   = setSrcSpan (mkSrcSpan loc loc) thing_inside
 218   where
 219     loc = getSrcLoc famInst
 220 \end{code}