FamInst.lhs 14.9 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  \begin{code}  Ian Lynagh committed Nov 04, 2011 4 5 6 7 8 9 10 {-# OPTIONS -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces -- for details  chak@cse.unsw.edu.au. committed Sep 20, 2006 11 module FamInst (  Simon Peyton Jones committed Sep 23, 2011 12 13  checkFamInstConsistency, tcExtendLocalFamInstEnv, tcLookupFamInst, tcLookupDataFamInst,  eir@cis.upenn.edu committed Jan 05, 2013 14 15 16 17  tcGetFamInstEnvs, freshenFamInstEqn, freshenFamInstEqnLoc, mkFreshenedSynInst, mkFreshenedSynInstLoc  chak@cse.unsw.edu.au. committed Sep 20, 2006 18 19  ) where  Simon Marlow committed Oct 11, 2006 20 21 import HscTypes import FamInstEnv  Simon Peyton Jones committed May 26, 2011 22 import LoadIface  Simon Peyton Jones committed Sep 23, 2011 23 import TypeRep  Simon Marlow committed Oct 11, 2006 24 25 import TcRnMonad import TyCon  eir@cis.upenn.edu committed Dec 21, 2012 26 import CoAxiom  Ian Lynagh committed Jan 19, 2012 27 import DynFlags  eir@cis.upenn.edu committed Jan 05, 2013 28 import SrcLoc  chak@cse.unsw.edu.au. committed Oct 18, 2006 29 import Module  chak@cse.unsw.edu.au. committed Sep 20, 2006 30 import Outputable  Ian Lynagh committed Mar 20, 2010 31 import UniqFM  Ian Lynagh committed Mar 29, 2008 32 import FastString  Ian Lynagh committed Jun 05, 2012 33 import Util  Clemens Fruhwirth committed Nov 07, 2008 34 import Maybes  eir@cis.upenn.edu committed Dec 21, 2012 35 36 import TcMType import Type  eir@cis.upenn.edu committed Jan 05, 2013 37 import Name  Ian Lynagh committed Jul 24, 2009 38 import Control.Monad  Ian Lynagh committed Sep 14, 2010 39 40 import Data.Map (Map) import qualified Data.Map as Map  Simon Peyton Jones committed Sep 23, 2011 41 42  #include "HsVersions.h"  chak@cse.unsw.edu.au. committed Sep 20, 2006 43 44 45 46 47 \end{code} %************************************************************************ %* *  chak@cse.unsw.edu.au. committed Oct 18, 2006 48  Optimised overlap checking for family instances  chak@cse.unsw.edu.au. committed Sep 20, 2006 49 50 51 %* * %************************************************************************  chak@cse.unsw.edu.au. committed Oct 18, 2006 52 53 54 55 56 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 57 58 59 60 61 62 63 64 65 66 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 67 68 69 70 71 72 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 73 \begin{code}  chak@cse.unsw.edu.au. committed Oct 18, 2006 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 -- 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  Simon Peyton Jones committed Mar 28, 2012 91 92 93 instance Outputable ModulePair where ppr (ModulePair m1 m2) = angleBrackets (ppr m1 <> comma <+> ppr m2)  chak@cse.unsw.edu.au. committed Oct 18, 2006 94 95 -- Sets of module pairs --  Ian Lynagh committed Sep 14, 2010 96 type ModulePairSet = Map ModulePair ()  chak@cse.unsw.edu.au. committed Oct 18, 2006 97   simonpj@microsoft.com committed May 02, 2007 98 listToSet :: [ModulePair] -> ModulePairSet  Ian Lynagh committed Sep 14, 2010 99 listToSet l = Map.fromList (zip l (repeat ()))  chak@cse.unsw.edu.au. committed Oct 18, 2006 100 101 102  checkFamInstConsistency :: [Module] -> [Module] -> TcM () checkFamInstConsistency famInstMods directlyImpMods  Ian Lynagh committed Jan 19, 2012 103  = do { dflags <- getDynFlags  chak@cse.unsw.edu.au. committed Oct 18, 2006 104 105 106  ; (eps, hpt) <- getEpsAndHpt ; let { -- Fetch the iface of a given module. Must succeed as  Simon Peyton Jones committed May 26, 2011 107  -- all directly imported modules must already have been loaded.  chak@cse.unsw.edu.au. committed Oct 18, 2006 108 109 110 111 112  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 113  ; hmiModule = mi_module . hm_iface  Simon Peyton Jones committed May 26, 2011 114 115 116 117  ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv . md_fam_insts . hm_details ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi) | hmi <- eltsUFM hpt]  chak@cse.unsw.edu.au. committed Oct 18, 2006 118 119 120 121 122 123  ; 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 124  ; toCheckPairs = Map.keys $criticalPairs Map.difference okPairs  chak@cse.unsw.edu.au. committed Oct 18, 2006 125 126 127  -- the difference gives us the pairs we need to check now }  Simon Peyton Jones committed May 26, 2011 128  ; mapM_ (check hpt_fam_insts) toCheckPairs  chak@cse.unsw.edu.au. committed Oct 18, 2006 129 130 131 132 133  } where allPairs [] = [] allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms  Simon Peyton Jones committed May 26, 2011 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148  check hpt_fam_insts (ModulePair m1 m2) = do { env1 <- getFamInsts hpt_fam_insts m1 ; env2 <- getFamInsts hpt_fam_insts m2 ; mapM_ (checkForConflicts (emptyFamInstEnv, env2)) (famInstEnvElts env1) } getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv getFamInsts hpt_fam_insts mod | Just env <- lookupModuleEnv hpt_fam_insts mod = return env | otherwise = do { _ <- initIfaceTcRn (loadSysInterface doc mod) ; eps <- getEps ; return (expectJust "checkFamInstConsistency"$ lookupModuleEnv (eps_mod_fam_inst_env eps) mod) } where doc = ppr mod <+> ptext (sLit "is a family-instance module")  chak@cse.unsw.edu.au. committed Oct 18, 2006 149 150 \end{code}  Simon Peyton Jones committed Sep 23, 2011 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 %************************************************************************ %* * Lookup %* * %************************************************************************ Look up the instance tycon of a family instance. The match may be ambiguous (as we know that overlapping instances have identical right-hand sides under overlapping substitutions - see 'FamInstEnv.lookupFamInstEnvConflicts'). However, the type arguments used for matching must be equal to or be more specific than those of the family instance declaration. We pick one of the matches in case of ambiguity; as the right-hand sides are identical under the match substitution, the choice does not matter. Return the instance tycon and its type instance. For example, if we have tcLookupFamInst 'T' '[Int]' yields (':R42T', 'Int') then we have a coercion (ie, type instance of family instance coercion) :Co:R42T Int :: T [Int] ~ :R42T Int which implies that :R42T was declared as 'data instance T [a]'. \begin{code}  eir@cis.upenn.edu committed Dec 21, 2012 178 tcLookupFamInst :: TyCon -> [Type] -> TcM (Maybe FamInstMatch)  Simon Peyton Jones committed Sep 23, 2011 179 180 181 182 183 tcLookupFamInst tycon tys | not (isFamilyTyCon tycon) = return Nothing | otherwise = do { instEnv <- tcGetFamInstEnvs  Simon Peyton Jones committed Mar 02, 2012 184  ; let mb_match = lookupFamInstEnv instEnv tycon tys  Simon Peyton Jones committed Oct 01, 2012 185 186 187 -- ; traceTc "lookupFamInst" ((ppr tycon <+> ppr tys) $$-- pprTvBndrs (varSetElems (tyVarsOfTypes tys))$$ -- ppr mb_match $$ppr instEnv)  Simon Peyton Jones committed Mar 02, 2012 188 189  ; case mb_match of [] -> return Nothing  eir@cis.upenn.edu committed Dec 21, 2012 190 191  (match:_) -> return  Just match  Simon Peyton Jones committed Sep 23, 2011 192 193 194 195 196 197 198 199 200 201 202 203  } tcLookupDataFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type]) -- Find the instance of a data family -- Note [Looking up family instances for deriving] tcLookupDataFamInst tycon tys | not (isFamilyTyCon tycon) = return (tycon, tys) | otherwise = ASSERT( isAlgTyCon tycon ) do { maybeFamInst <- tcLookupFamInst tycon tys ; case maybeFamInst of  Simon Peyton Jones committed Jan 03, 2012 204  Nothing -> famInstNotFound tycon tys  eir@cis.upenn.edu committed Dec 21, 2012 205 206 207 208 209 210  Just (FamInstMatch { fim_instance = famInst , fim_index = index , fim_tys = tys }) -> ASSERT( index == 0 ) let tycon' = dataFamInstRepTyCon famInst in return (tycon', tys) }  Simon Peyton Jones committed Sep 23, 2011 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242  famInstNotFound :: TyCon -> [Type] -> TcM a famInstNotFound tycon tys = failWithTc (ptext (sLit "No family instance for") <+> quotes (pprTypeApp tycon tys)) \end{code} Note [Looking up family instances for deriving] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ tcLookupFamInstExact is an auxiliary lookup wrapper which requires that looked-up family instances exist. If called with a vanilla tycon, the old type application is simply returned. If we have data instance F () = ... deriving Eq data instance F () = ... deriving Eq then tcLookupFamInstExact will be confused by the two matches; but that can't happen because tcInstDecls1 doesn't call tcDeriving if there are any overlaps. There are two other things that might go wrong with the lookup. First, we might see a standalone deriving clause deriving Eq (F ()) when there is no data instance F () in scope. Note that it's OK to have data instance F [a] = ... deriving Eq (F [(a,b)]) where the match is not exact; the same holds for ordinary data types with standalone deriving declrations.  chak@cse.unsw.edu.au. committed Oct 18, 2006 243 244 245 246 247 %************************************************************************ %* * Extending the family instance environment %* * %************************************************************************  chak@cse.unsw.edu.au. committed Sep 20, 2006 248   chak@cse.unsw.edu.au. committed Oct 18, 2006 249 \begin{code}  chak@cse.unsw.edu.au. committed Sep 20, 2006 250 -- Add new locally-defined family instances  eir@cis.upenn.edu committed Dec 21, 2012 251 tcExtendLocalFamInstEnv :: [FamInst br] -> TcM a -> TcM a  chak@cse.unsw.edu.au. committed Sep 20, 2006 252 253 tcExtendLocalFamInstEnv fam_insts thing_inside = do { env <- getGblEnv  Simon Peyton Jones committed Feb 10, 2012 254 255 256 257 258  ; (inst_env', fam_insts') <- foldlM addLocalFamInst (tcg_fam_inst_env env, tcg_fam_insts env) fam_insts ; let env' = env { tcg_fam_insts = fam_insts' , tcg_fam_inst_env = inst_env' }  chak@cse.unsw.edu.au. committed Oct 18, 2006 259 260  ; setGblEnv env' thing_inside }  chak@cse.unsw.edu.au. committed Sep 20, 2006 261 262 263  -- Check that the proposed new instance is OK, -- and then add it to the home inst env  eir@cis.upenn.edu committed Dec 21, 2012 264 265 266 267 -- This must be lazy in the fam_inst arguments, see Note [Lazy axiom match] -- in FamInstEnv.lhs addLocalFamInst :: (FamInstEnv,[FamInst Branched]) -> FamInst br -> TcM (FamInstEnv, [FamInst Branched]) addLocalFamInst (home_fie, my_fis) fam_inst  Simon Peyton Jones committed Feb 10, 2012 268 269  -- home_fie includes home package and this module -- my_fies is just the ones from this module  Simon Peyton Jones committed Apr 25, 2012 270  = do { traceTc "addLocalFamInst" (ppr fam_inst)  eir@cis.upenn.edu committed Dec 21, 2012 271   Simon Peyton Jones committed Apr 25, 2012 272  ; isGHCi <- getIsGHCi  Simon Peyton Jones committed Feb 10, 2012 273 274 275  -- In GHCi, we *override* any identical instances -- that are also defined in the interactive context  Simon Peyton Jones committed Apr 25, 2012 276  ; let (home_fie', my_fis')  eir@cis.upenn.edu committed Jan 05, 2013 277 278  | isGHCi = ( deleteFromFamInstEnv home_fie fam_inst , filterOut (identicalFamInst fam_inst) my_fis)  Simon Peyton Jones committed Apr 25, 2012 279  | otherwise = (home_fie, my_fis)  Simon Peyton Jones committed Feb 10, 2012 280 281 282 283 284  -- Load imported instances, so that we report -- overlaps correctly ; eps <- getEps ; let inst_envs = (eps_fam_inst_env eps, home_fie')  eir@cis.upenn.edu committed Jan 05, 2013 285  fam_inst' = toBranchedFamInst fam_inst  eir@cis.upenn.edu committed Dec 21, 2012 286  home_fie'' = extendFamInstEnv home_fie fam_inst'  Simon Peyton Jones committed Feb 10, 2012 287 288  -- Check for conflicting instance decls  eir@cis.upenn.edu committed Dec 21, 2012 289  ; no_conflict <- checkForConflicts inst_envs fam_inst'  Simon Peyton Jones committed Mar 02, 2012 290  ; if no_conflict then  eir@cis.upenn.edu committed Dec 21, 2012 291  return (home_fie'', fam_inst' : my_fis')  Simon Peyton Jones committed Mar 02, 2012 292 293  else return (home_fie, my_fis) }  eir@cis.upenn.edu committed Dec 21, 2012 294   chak@cse.unsw.edu.au. committed Oct 18, 2006 295 296 297 298 299 300 301 302 303 304 305 306 \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}  eir@cis.upenn.edu committed Dec 21, 2012 307 308 309 310 311 checkForConflicts :: FamInstEnvs -> FamInst Branched -> TcM Bool checkForConflicts inst_envs fam_inst@(FamInst { fi_branches = branches , fi_group = group }) = do { let conflicts = brListMap (lookupFamInstEnvConflicts inst_envs group fam_tc) branches no_conflicts = all null conflicts  Simon Peyton Jones committed Mar 02, 2012 312 313  ; traceTc "checkForConflicts" (ppr conflicts$$ ppr fam_inst  ppr inst_envs) ; unless no_conflicts $ Simon Peyton Jones committed Jan 09, 2013 314  zipWithM_ (conflictInstErr fam_inst) (brListIndices branches) conflicts  Simon Peyton Jones committed Mar 02, 2012 315  ; return no_conflicts }  eir@cis.upenn.edu committed Dec 21, 2012 316  where fam_tc = famInstTyCon fam_inst  chak@cse.unsw.edu.au. committed Sep 20, 2006 317   Simon Peyton Jones committed Jan 09, 2013 318 conflictInstErr :: FamInst Branched -> BranchIndex -> [FamInstMatch] -> TcRn ()  eir@cis.upenn.edu committed Dec 21, 2012 319 320 321 conflictInstErr fam_inst branch conflictingMatch | (FamInstMatch { fim_instance = confInst , fim_index = confIndex }) : _ <- conflictingMatch  Simon Peyton Jones committed Apr 23, 2012 322  = addFamInstsErr (ptext (sLit "Conflicting family instance declarations:"))  eir@cis.upenn.edu committed Dec 21, 2012 323  [(fam_inst, branch),  Simon Peyton Jones committed Jan 09, 2013 324  (confInst, confIndex) ]  eir@cis.upenn.edu committed Jan 08, 2013 325 326  | otherwise -- no conflict on this branch; see Trac #7560 = return ()  Simon Peyton Jones committed Apr 23, 2012 327   Simon Peyton Jones committed Jan 09, 2013 328 addFamInstsErr :: SDoc -> [(FamInst Branched, Int)] -> TcRn ()  Simon Peyton Jones committed Apr 23, 2012 329 addFamInstsErr herald insts  Simon Peyton Jones committed Jan 09, 2013 330 331 332 333 334  = ASSERT( not (null insts) ) setSrcSpan srcSpan$ addErr $hang herald 2 (vcat [ pprCoAxBranchHdr (famInstAxiom fi) index | (fi,index) <- sorted ])  Simon Peyton Jones committed Apr 23, 2012 335  where  Simon Peyton Jones committed Jan 09, 2013 336 337 338 339  getSpan = getSrcLoc . famInstAxiom . fst sorted = sortWith getSpan insts (fi1,ix1) = head sorted srcSpan = coAxBranchSpan (coAxiomNthBranch (famInstAxiom fi1) ix1)  Simon Peyton Jones committed Apr 23, 2012 340 341 342  -- The sortWith just arranges that instances are dislayed in order -- of source location, which reduced wobbling in error messages, -- and is better for users  simonpj@microsoft.com committed Sep 13, 2010 343   Simon Peyton Jones committed Sep 23, 2011 344 tcGetFamInstEnvs :: TcM FamInstEnvs  simonpj@microsoft.com committed Sep 13, 2010 345 346 347 348 -- Gets both the external-package inst-env -- and the home-pkg inst env (includes module being compiled) tcGetFamInstEnvs = do { eps <- getEps; env <- getGblEnv  349  ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) }  chak@cse.unsw.edu.au. committed Sep 20, 2006 350 \end{code}  eir@cis.upenn.edu committed Jan 05, 2013 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400  %************************************************************************ %* * Freshening type variables %* * %************************************************************************ \begin{code} -- All type variables in a FamInst/CoAxiom must be fresh. This function -- creates the fresh variables and applies the necessary substitution -- It is defined here to avoid a dependency from FamInstEnv on the monad -- code. freshenFamInstEqn :: [TyVar] -- original, possibly stale, tyvars -> [Type] -- LHS patterns -> Type -- RHS -> TcM ([TyVar], [Type], Type) freshenFamInstEqn tvs lhs rhs = do { loc <- getSrcSpanM ; freshenFamInstEqnLoc loc tvs lhs rhs } -- freshenFamInstEqn needs to be called outside the TcM monad: freshenFamInstEqnLoc :: SrcSpan -> [TyVar] -> [Type] -> Type -> TcRnIf gbl lcl ([TyVar], [Type], Type) freshenFamInstEqnLoc loc tvs lhs rhs = do { (subst, tvs') <- tcInstSkolTyVarsLoc loc tvs ; let lhs' = substTys subst lhs rhs' = substTy subst rhs ; return (tvs', lhs', rhs') } -- Makes an unbranched synonym FamInst, with freshened tyvars mkFreshenedSynInst :: Name -- Unique name for the coercion tycon -> [TyVar] -- possibly stale tyvars of the coercion -> TyCon -- Family tycon -> [Type] -- LHS patterns -> Type -- RHS -> TcM (FamInst Unbranched) mkFreshenedSynInst name tvs fam_tc inst_tys rep_ty = do { loc <- getSrcSpanM ; mkFreshenedSynInstLoc loc name tvs fam_tc inst_tys rep_ty } mkFreshenedSynInstLoc :: SrcSpan -> Name -> [TyVar] -> TyCon -> [Type] -> Type -> TcRnIf gbl lcl (FamInst Unbranched) mkFreshenedSynInstLoc loc name tvs fam_tc inst_tys rep_ty = do { (tvs', inst_tys', rep_ty') <- freshenFamInstEqnLoc loc tvs inst_tys rep_ty ; return$ mkSingleSynFamInst name tvs' fam_tc inst_tys' rep_ty' } \end{code}`