FamInst.lhs 7.32 KB
 Simon Marlow committed Oct 11, 2006 1 The @FamInst@ type: family instance heads  chak@cse.unsw.edu.au. committed Sep 20, 2006 2 3 4  \begin{code} module FamInst (  simonpj@microsoft.com committed Sep 13, 2010 5  checkFamInstConsistency, tcExtendLocalFamInstEnv, tcGetFamInstEnvs  chak@cse.unsw.edu.au. committed Sep 20, 2006 6 7  ) where  Simon Marlow committed Oct 11, 2006 8 9 10 11 12 import HscTypes import FamInstEnv import TcMType import TcRnMonad import TyCon  chak@cse.unsw.edu.au. committed Oct 12, 2006 13 import Name  chak@cse.unsw.edu.au. committed Oct 18, 2006 14 import Module  chak@cse.unsw.edu.au. committed Oct 12, 2006 15 import SrcLoc  chak@cse.unsw.edu.au. committed Sep 20, 2006 16 import Outputable  Ian Lynagh committed Mar 20, 2010 17 import UniqFM  Ian Lynagh committed Mar 29, 2008 18 import FastString  chak@cse.unsw.edu.au. committed Oct 12, 2006 19   Clemens Fruhwirth committed Nov 07, 2008 20 import Maybes  Ian Lynagh committed Jul 24, 2009 21 import Control.Monad  Ian Lynagh committed Sep 14, 2010 22 23 import Data.Map (Map) import qualified Data.Map as Map  chak@cse.unsw.edu.au. committed Sep 20, 2006 24 25 26 27 28 \end{code} %************************************************************************ %* *  chak@cse.unsw.edu.au. committed Oct 18, 2006 29  Optimised overlap checking for family instances  chak@cse.unsw.edu.au. committed Sep 20, 2006 30 31 32 %* * %************************************************************************  chak@cse.unsw.edu.au. committed Oct 18, 2006 33 34 35 36 37 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.  simonpj@microsoft.com committed Oct 19, 2008 38 39 40 41 42 43 44 45 46 47 Why do we need to check? Consider module X1 where module X2 where data T1 data T2 type instance F T1 b = Int type instance F a T2 = Char f1 :: F T1 a -> Int f2 :: Char -> F a T2 f1 x = x f2 x = x Now if we import both X1 and X2 we could make (f2 . f1) :: Int -> Char. Notice that neither instance is an orphan.  chak@cse.unsw.edu.au. committed Oct 18, 2006 48 49 50 51 52 53 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.)  chak@cse.unsw.edu.au. committed Sep 20, 2006 54 \begin{code}  chak@cse.unsw.edu.au. committed Oct 18, 2006 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 -- 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 --  Ian Lynagh committed Sep 14, 2010 74 type ModulePairSet = Map ModulePair ()  chak@cse.unsw.edu.au. committed Oct 18, 2006 75   simonpj@microsoft.com committed May 02, 2007 76 listToSet :: [ModulePair] -> ModulePairSet  Ian Lynagh committed Sep 14, 2010 77 listToSet l = Map.fromList (zip l (repeat ()))  chak@cse.unsw.edu.au. committed Oct 18, 2006 78 79 80 81 82 83 84 85 86 87 88 89 90  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  chak@cse.unsw.edu.au. committed Dec 07, 2006 91 92 93 94 95 96 97 98  ; 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  chak@cse.unsw.edu.au. committed Oct 18, 2006 99 100 101 102 103 104  ; 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  Ian Lynagh committed Sep 14, 2010 105  ; toCheckPairs = Map.keys $criticalPairs Map.difference okPairs  chak@cse.unsw.edu.au. committed Oct 18, 2006 106 107 108 109 110 111 112 113 114  -- 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  chak@cse.unsw.edu.au. committed Dec 07, 2006 115 116 117  -- The modules are guaranteed to be in the environment, as they are either -- already loaded in the EPS or they are in the HPT. --  chak@cse.unsw.edu.au. committed Oct 18, 2006 118  check modInstsEnv (ModulePair m1 m2)  Clemens Fruhwirth committed Nov 07, 2008 119 120  = let { instEnv1 = (expectJust "checkFamInstConsistency") . lookupModuleEnv modInstsEnv$ m1 ; instEnv2 = (expectJust "checkFamInstConsistency") . lookupModuleEnv modInstsEnv $m2  chak@cse.unsw.edu.au. committed Oct 18, 2006 121 122 123 124 125 126 127 128 129 130 131  ; insts1 = famInstEnvElts instEnv1 } in mapM_ (checkForConflicts (emptyFamInstEnv, instEnv2)) insts1 \end{code} %************************************************************************ %* * Extending the family instance environment %* * %************************************************************************  chak@cse.unsw.edu.au. committed Sep 20, 2006 132   chak@cse.unsw.edu.au. committed Oct 18, 2006 133 \begin{code}  chak@cse.unsw.edu.au. committed Sep 20, 2006 134 135 136 137 138 -- Add new locally-defined family instances tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a tcExtendLocalFamInstEnv fam_insts thing_inside = do { env <- getGblEnv ; inst_env' <- foldlM addLocalFamInst (tcg_fam_inst_env env) fam_insts  chak@cse.unsw.edu.au. committed Oct 10, 2006 139 140  ; let env' = env { tcg_fam_insts = fam_insts ++ tcg_fam_insts env, tcg_fam_inst_env = inst_env' }  chak@cse.unsw.edu.au. committed Oct 18, 2006 141 142  ; setGblEnv env' thing_inside }  chak@cse.unsw.edu.au. committed Sep 20, 2006 143 144 145 146 147  -- 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  chak@cse.unsw.edu.au. committed Oct 18, 2006 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173  = 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  chak@cse.unsw.edu.au. committed Sep 20, 2006 174 175 176 177 178 179  -- 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.  simonpj@microsoft.com committed Jan 15, 2009 180   simonpj@microsoft.com committed Jan 12, 2011 181  ; skol_tvs <- tcInstSkolTyVars (tyConTyVars (famInstTyCon famInst))  simonpj@microsoft.com committed Jan 15, 2009 182  ; let conflicts = lookupFamInstEnvConflicts inst_envs famInst skol_tvs  chak@cse.unsw.edu.au. committed Oct 18, 2006 183  ; unless (null conflicts)$  simonpj@microsoft.com committed Jan 15, 2009 184  conflictInstErr famInst (fst (head conflicts))  chak@cse.unsw.edu.au. committed Oct 18, 2006 185  }  chak@cse.unsw.edu.au. committed Oct 12, 2006 186  where  chak@cse.unsw.edu.au. committed Sep 20, 2006 187   Ian Lynagh committed May 06, 2008 188 conflictInstErr :: FamInst -> FamInst -> TcRn ()  chak@cse.unsw.edu.au. committed Oct 12, 2006 189 conflictInstErr famInst conflictingFamInst  chak@cse.unsw.edu.au. committed Sep 20, 2006 190  = addFamInstLoc famInst \$  Ian Lynagh committed Apr 12, 2008 191  addErr (hang (ptext (sLit "Conflicting family instance declarations:"))  chak@cse.unsw.edu.au. committed Oct 12, 2006 192  2 (pprFamInsts [famInst, conflictingFamInst]))  chak@cse.unsw.edu.au. committed Sep 20, 2006 193   Ian Lynagh committed May 06, 2008 194 addFamInstLoc :: FamInst -> TcRn a -> TcRn a  chak@cse.unsw.edu.au. committed Sep 20, 2006 195 196 197 198 addFamInstLoc famInst thing_inside = setSrcSpan (mkSrcSpan loc loc) thing_inside where loc = getSrcLoc famInst  simonpj@microsoft.com committed Sep 13, 2010 199 200 201 202 203 204 205 206 207 208 209 210 211 \end{code} \begin{code} tcGetFamInstEnvs :: TcM (FamInstEnv, FamInstEnv) -- Gets both the external-package inst-env -- and the home-pkg inst env (includes module being compiled) tcGetFamInstEnvs = do { eps <- getEps; env <- getGblEnv ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) }  chak@cse.unsw.edu.au. committed Sep 20, 2006 212 \end{code}`