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