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 import HscTypes
   9 import FamInstEnv
  10 import TcMType
  11 import TcType
  12 import TcRnMonad
  13 import TyCon
  14 import Type
  15 import Name
  16 import Module
  17 import SrcLoc
  18 import Outputable
  19 import LazyUniqFM
  20 import FiniteMap
  21 import FastString
  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 :: [ModulePair] -> ModulePairSet
  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        ; (_, _, 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 tycon match
 184                            ]
 185              }
 186        ; unless (null conflicts) $
 187            conflictInstErr famInst (head conflicts)
 188        }
 189   where
 190       -- - In the case of data family instances, any overlap is fundamentally a
 191       --   conflict (as these instances imply injective type mappings).
 192       -- - In the case of type family instances, overlap is admitted as long as
 193       --   the right-hand sides of the overlapping rules coincide under the
 194       --   overlap substitution.  We require that they are syntactically equal;
 195       --   anything else would be difficult to test for at this stage.
 196     conflicting tycon1 ((famInst2, _), subst)
 197       | isAlgTyCon tycon1 = True
 198       | otherwise         = not (rhs1 `tcEqType` rhs2)
 199       where
 200         tycon2 = famInstTyCon famInst2
 201         rhs1   = substTy subst $ synTyConType tycon1
 202         rhs2   = substTy subst $ synTyConType tycon2
 203
 204 conflictInstErr :: FamInst -> FamInst -> TcRn ()
 205 conflictInstErr famInst conflictingFamInst
 206   = addFamInstLoc famInst $
 207     addErr (hang (ptext (sLit "Conflicting family instance declarations:"))
 208                2 (pprFamInsts [famInst, conflictingFamInst]))
 209
 210 addFamInstLoc :: FamInst -> TcRn a -> TcRn a
 211 addFamInstLoc famInst thing_inside
 212   = setSrcSpan (mkSrcSpan loc loc) thing_inside
 213   where
 214     loc = getSrcLoc famInst
 215 \end{code}