\begin{code}
module FamInst (
- tcExtendLocalFamInstEnv
+ checkFamInstConsistency, tcExtendLocalFamInstEnv
) where
-#include "HsVersions.h"
-
import HscTypes
import FamInstEnv
import TcMType
import TcRnMonad
import TyCon
import Type
+import Name
+import Module
+import SrcLoc
import Outputable
+import LazyUniqFM
+import FiniteMap
+import FastString
+
+import Maybe
+import Monad
\end{code}
%************************************************************************
%* *
- Extending the family instance environment
+ Optimised overlap checking for family instances
%* *
%************************************************************************
+For any two family instance modules that we import directly or indirectly, we
+check whether the instances in the two modules are consistent, *unless* we can
+be certain that the instances of the two modules have already been checked for
+consistency during the compilation of modules that we import.
+
+How do we know which pairs of modules have already been checked? Any pair of
+modules where both modules occur in the `HscTypes.dep_finsts' set (of the
+`HscTypes.Dependencies') of one of our directly imported modules must have
+already been checked. Everything else, we check now. (So that we can be
+certain that the modules in our `HscTypes.dep_finsts' are consistent.)
+
\begin{code}
+-- The optimisation of overlap tests is based on determining pairs of modules
+-- whose family instances need to be checked for consistency.
+--
+data ModulePair = ModulePair Module Module
+
+-- canonical order of the components of a module pair
+--
+canon :: ModulePair -> (Module, Module)
+canon (ModulePair m1 m2) | m1 < m2 = (m1, m2)
+ | otherwise = (m2, m1)
+
+instance Eq ModulePair where
+ mp1 == mp2 = canon mp1 == canon mp2
+
+instance Ord ModulePair where
+ mp1 `compare` mp2 = canon mp1 `compare` canon mp2
+
+-- Sets of module pairs
+--
+type ModulePairSet = FiniteMap ModulePair ()
+
+listToSet :: [ModulePair] -> ModulePairSet
+listToSet l = listToFM (zip l (repeat ()))
+
+checkFamInstConsistency :: [Module] -> [Module] -> TcM ()
+checkFamInstConsistency famInstMods directlyImpMods
+ = do { dflags <- getDOpts
+ ; (eps, hpt) <- getEpsAndHpt
+
+ ; let { -- Fetch the iface of a given module. Must succeed as
+ -- all imported modules must already have been loaded.
+ modIface mod =
+ case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of
+ Nothing -> panic "FamInst.checkFamInstConsistency"
+ Just iface -> iface
+
+ ; hmiModule = mi_module . hm_iface
+ ; hmiFamInstEnv = mkFamInstEnv . md_fam_insts . hm_details
+ ; mkFamInstEnv = extendFamInstEnvList emptyFamInstEnv
+ ; hptModInsts = [ (hmiModule hmi, hmiFamInstEnv hmi)
+ | hmi <- eltsUFM hpt]
+ ; modInstsEnv = eps_mod_fam_inst_env eps -- external modules
+ `extendModuleEnvList` -- plus
+ hptModInsts -- home package modules
+ ; groups = map (dep_finsts . mi_deps . modIface)
+ directlyImpMods
+ ; okPairs = listToSet $ concatMap allPairs groups
+ -- instances of okPairs are consistent
+ ; criticalPairs = listToSet $ allPairs famInstMods
+ -- all pairs that we need to consider
+ ; toCheckPairs = keysFM $ criticalPairs `minusFM` okPairs
+ -- the difference gives us the pairs we need to check now
+ }
+
+ ; mapM_ (check modInstsEnv) toCheckPairs
+ }
+ where
+ allPairs [] = []
+ allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms
+
+ -- The modules are guaranteed to be in the environment, as they are either
+ -- already loaded in the EPS or they are in the HPT.
+ --
+ check modInstsEnv (ModulePair m1 m2)
+ = let { instEnv1 = fromJust . lookupModuleEnv modInstsEnv $ m1
+ ; instEnv2 = fromJust . lookupModuleEnv modInstsEnv $ m2
+ ; insts1 = famInstEnvElts instEnv1
+ }
+ in
+ mapM_ (checkForConflicts (emptyFamInstEnv, instEnv2)) insts1
+\end{code}
+
+%************************************************************************
+%* *
+ Extending the family instance environment
+%* *
+%************************************************************************
+\begin{code}
-- Add new locally-defined family instances
tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a
tcExtendLocalFamInstEnv fam_insts thing_inside
; inst_env' <- foldlM addLocalFamInst (tcg_fam_inst_env env) fam_insts
; let env' = env { tcg_fam_insts = fam_insts ++ tcg_fam_insts env,
tcg_fam_inst_env = inst_env' }
- ; setGblEnv env' thing_inside }
-
+ ; setGblEnv env' thing_inside
+ }
-- Check that the proposed new instance is OK,
-- and then add it to the home inst env
addLocalFamInst :: FamInstEnv -> FamInst -> TcM FamInstEnv
addLocalFamInst home_fie famInst
- = do { -- To instantiate the family instance type, extend the instance
+ = do { -- Load imported instances, so that we report
+ -- overlaps correctly
+ ; eps <- getEps
+ ; let inst_envs = (eps_fam_inst_env eps, home_fie)
+
+ -- Check for conflicting instance decls
+ ; checkForConflicts inst_envs famInst
+
+ -- OK, now extend the envt
+ ; return (extendFamInstEnv home_fie famInst)
+ }
+\end{code}
+
+%************************************************************************
+%* *
+ Checking an instance against conflicts with an instance env
+%* *
+%************************************************************************
+
+Check whether a single family instance conflicts with those in two instance
+environments (one for the EPS and one for the HPT).
+
+\begin{code}
+checkForConflicts :: (FamInstEnv, FamInstEnv) -> FamInst -> TcM ()
+checkForConflicts inst_envs famInst
+ = do { -- To instantiate the family instance type, extend the instance
-- envt with completely fresh template variables
-- This is important because the template variables must
-- not overlap with anything in the things being looked up
-- (since we do unification).
-- We use tcInstSkolType because we don't want to allocate
-- fresh *meta* type variables.
- let tycon = famInstTyCon famInst
- ty = case tyConFamInst_maybe tycon of
- Nothing -> panic "FamInst.addLocalFamInst"
- Just (tc, tys) -> tc `mkTyConApp` tys
- ; (tvs', theta', tau') <- tcInstSkolType (FamInstSkol tycon) ty
-
- ; let (fam, tys') = tcSplitTyConApp tau'
-
- -- Load imported instances, so that we report
- -- overlaps correctly
- ; eps <- getEps
- ; let inst_envs = (eps_fam_inst_env eps, home_fie)
-
-{- !!!TODO: Need to complete this:
- -- Check for overlapping instance decls
- ; let { (matches, _) = lookupFamInstEnv inst_envs fam tys'
- ; dup_ispecs = [ dup_ispec --!!!adapt
- | (_, dup_ispec) <- matches
- , let (_,_,_,dup_tys) = instanceHead dup_ispec
- , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
- -- Find memebers of the match list which ispec itself matches.
- -- If the match is 2-way, it's a duplicate
- ; case dup_ispecs of
- dup_ispec : _ -> dupInstErr famInst dup_ispec
- [] -> return ()
- -}
-
- -- OK, now extend the envt
- ; return (extendFamInstEnv home_fie famInst) }
-
-{- UNUSED??? --SDM
-overlapErr famInst dupFamInst
+ ; let { tycon = famInstTyCon famInst
+ ; ty = case tyConFamInst_maybe tycon of
+ Nothing -> panic "FamInst.checkForConflicts"
+ Just (tc, tys) -> tc `mkTyConApp` tys
+ }
+ ; (_, _, tau') <- tcInstSkolType FamInstSkol ty
+
+ ; let (fam, tys') = tcSplitTyConApp tau'
+
+ ; let { matches = lookupFamInstEnvUnify inst_envs fam tys'
+ ; conflicts = [ conflictingFamInst
+ | match@((conflictingFamInst, _), _) <- matches
+ , conflicting tycon match
+ ]
+ }
+ ; unless (null conflicts) $
+ conflictInstErr famInst (head conflicts)
+ }
+ where
+ -- - In the case of data family instances, any overlap is fundamentally a
+ -- conflict (as these instances imply injective type mappings).
+ -- - In the case of type family instances, overlap is admitted as long as
+ -- the right-hand sides of the overlapping rules coincide under the
+ -- overlap substitution. We require that they are syntactically equal;
+ -- anything else would be difficult to test for at this stage.
+ conflicting tycon1 ((famInst2, _), subst)
+ | isAlgTyCon tycon1 = True
+ | otherwise = not (rhs1 `tcEqType` rhs2)
+ where
+ tycon2 = famInstTyCon famInst2
+ rhs1 = substTy subst $ synTyConType tycon1
+ rhs2 = substTy subst $ synTyConType tycon2
+
+conflictInstErr :: FamInst -> FamInst -> TcRn ()
+conflictInstErr famInst conflictingFamInst
= addFamInstLoc famInst $
- addErr (hang (ptext SLIT("Overlapping family instance declarations:"))
- 2 (pprFamInsts [famInst, dupFamInst]))
+ addErr (hang (ptext (sLit "Conflicting family instance declarations:"))
+ 2 (pprFamInsts [famInst, conflictingFamInst]))
+addFamInstLoc :: FamInst -> TcRn a -> TcRn a
addFamInstLoc famInst thing_inside
= setSrcSpan (mkSrcSpan loc loc) thing_inside
where
loc = getSrcLoc famInst
--}
\end{code}
projects / ghc-hetmet.git / blobdiff