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