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