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