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 l = listToFM (zip l (repeat ()))
  69
  70 checkFamInstConsistency :: [Module] -> [Module] -> TcM ()
  71 checkFamInstConsistency famInstMods directlyImpMods
  72   = do { dflags     <- getDOpts
  73        ; (eps, hpt) <- getEpsAndHpt
  74
  75        ; let { -- Fetch the iface of a given module.  Must succeed as
  76                -- all imported modules must already have been loaded.
  77                modIface mod =
  78                  case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of
  79                    Nothing    -> panic "FamInst.checkFamInstConsistency"
  80                    Just iface -> iface
  81
  82              ; hmiModule     = mi_module . hm_iface
  83              ; hmiFamInstEnv = mkFamInstEnv . md_fam_insts . hm_details
  84              ; mkFamInstEnv  = extendFamInstEnvList emptyFamInstEnv
  85              ; hptModInsts   = [ (hmiModule hmi, hmiFamInstEnv hmi)
  86                                | hmi <- eltsUFM hpt]
  87              ; modInstsEnv   = eps_mod_fam_inst_env eps -- external modules
  88                                `extendModuleEnvList`    -- plus
  89                                hptModInsts              -- home package modules
  90              ; groups        = map (dep_finsts . mi_deps . modIface)
  91                                    directlyImpMods
  92              ; okPairs       = listToSet $ concatMap allPairs groups
  93                  -- instances of okPairs are consistent
  94              ; criticalPairs = listToSet $ allPairs famInstMods
  95                  -- all pairs that we need to consider
  96              ; toCheckPairs  = keysFM $ criticalPairs `minusFM` okPairs
  97                  -- the difference gives us the pairs we need to check now
  98              }
  99
 100        ; mapM_ (check modInstsEnv) toCheckPairs
 101        }
 102   where
 103     allPairs []     = []
 104     allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms
 105
 106     -- The modules are guaranteed to be in the environment, as they are either
 107     -- already loaded in the EPS or they are in the HPT.
 108     --
 109     check modInstsEnv (ModulePair m1 m2)
 110       = let { instEnv1 = fromJust . lookupModuleEnv modInstsEnv $ m1
 111             ; instEnv2 = fromJust . lookupModuleEnv modInstsEnv $ m2
 112             ; insts1   = famInstEnvElts instEnv1
 113             }
 114         in
 115         mapM_ (checkForConflicts (emptyFamInstEnv, instEnv2)) insts1
 116 \end{code}
 117
 118 %************************************************************************
 119 %*                                                                      *
 120         Extending the family instance environment
 121 %*                                                                      *
 122 %************************************************************************
 123
 124 \begin{code}
 125 -- Add new locally-defined family instances
 126 tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a
 127 tcExtendLocalFamInstEnv fam_insts thing_inside
 128  = do { env <- getGblEnv
 129       ; inst_env' <- foldlM addLocalFamInst (tcg_fam_inst_env env) fam_insts
 130       ; let env' = env { tcg_fam_insts    = fam_insts ++ tcg_fam_insts env,
 131                          tcg_fam_inst_env = inst_env' }
 132       ; setGblEnv env' thing_inside
 133       }
 134
 135 -- Check that the proposed new instance is OK,
 136 -- and then add it to the home inst env
 137 addLocalFamInst :: FamInstEnv -> FamInst -> TcM FamInstEnv
 138 addLocalFamInst home_fie famInst
 139   = do {       -- Load imported instances, so that we report
 140                -- overlaps correctly
 141        ; eps <- getEps
 142        ; let inst_envs = (eps_fam_inst_env eps, home_fie)
 143
 144                -- Check for conflicting instance decls
 145        ; checkForConflicts inst_envs famInst
 146
 147                -- OK, now extend the envt
 148        ; return (extendFamInstEnv home_fie famInst)
 149        }
 150 \end{code}
 151
 152 %************************************************************************
 153 %*                                                                      *
 154         Checking an instance against conflicts with an instance env
 155 %*                                                                      *
 156 %************************************************************************
 157
 158 Check whether a single family instance conflicts with those in two instance
 159 environments (one for the EPS and one for the HPT).
 160
 161 \begin{code}
 162 checkForConflicts :: (FamInstEnv, FamInstEnv) -> FamInst -> TcM ()
 163 checkForConflicts inst_envs famInst
 164   = do {        -- To instantiate the family instance type, extend the instance
 165                 -- envt with completely fresh template variables
 166                 -- This is important because the template variables must
 167                 -- not overlap with anything in the things being looked up
 168                 -- (since we do unification).
 169                 -- We use tcInstSkolType because we don't want to allocate
 170                 -- fresh *meta* type variables.
 171        ; let { tycon = famInstTyCon famInst
 172              ; ty    = case tyConFamInst_maybe tycon of
 173                          Nothing        -> panic "FamInst.checkForConflicts"
 174                          Just (tc, tys) -> tc `mkTyConApp` tys
 175              }
 176        ; (tvs', _, tau') <- tcInstSkolType FamInstSkol ty
 177
 178        ; let (fam, tys') = tcSplitTyConApp tau'
 179
 180        ; let { matches   = lookupFamInstEnvUnify inst_envs fam tys'
 181              ; conflicts = [ conflictingFamInst
 182                            | match@(_, conflictingFamInst) <- matches
 183                            , conflicting fam tys' tycon match
 184                            ]
 185              }
 186        ; unless (null conflicts) $
 187            conflictInstErr famInst (head conflicts)
 188        }
 189   where
 190     -- In the case of data/newtype instances, any overlap is a conflict (as
 191     -- these instances imply injective type mappings).
 192     conflicting _   _    tycon _                 | isAlgTyCon tycon = True
 193     conflicting fam tys' tycon (subst, cFamInst) | otherwise      =
 194       panic "FamInst.checkForConflicts: overlap check for indexed synonyms is still missing"
 195
 196 conflictInstErr famInst conflictingFamInst
 197   = addFamInstLoc famInst $
 198     addErr (hang (ptext SLIT("Conflicting family instance declarations:"))
 199                2 (pprFamInsts [famInst, conflictingFamInst]))
 200
 201 addFamInstLoc famInst thing_inside
 202   = setSrcSpan (mkSrcSpan loc loc) thing_inside
 203   where
 204     loc = getSrcLoc famInst
 205 \end{code}