PageRenderTime 50ms CodeModel.GetById 14ms RepoModel.GetById 0ms app.codeStats 0ms

/compiler/types/InstEnv.lhs

https://bitbucket.org/carter/ghc
Haskell | 668 lines | 462 code | 113 blank | 93 comment | 36 complexity | 48a440b85fe9c748c3b5ad14047083b6 MD5 | raw file
  1. %
  2. % (c) The University of Glasgow 2006
  3. % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
  4. %
  5. \section[InstEnv]{Utilities for typechecking instance declarations}
  6. The bits common to TcInstDcls and TcDeriv.
  7. \begin{code}
  8. module InstEnv (
  9. DFunId, OverlapFlag(..), InstMatch, ClsInstLookupResult,
  10. ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances,
  11. instanceHead, mkLocalInstance, mkImportedInstance,
  12. instanceDFunId, setInstanceDFunId, instanceRoughTcs,
  13. InstEnv, emptyInstEnv, extendInstEnv, overwriteInstEnv,
  14. extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv', lookupInstEnv, instEnvElts,
  15. classInstances, instanceBindFun,
  16. instanceCantMatch, roughMatchTcs
  17. ) where
  18. #include "HsVersions.h"
  19. import Class
  20. import Var
  21. import VarSet
  22. import Name
  23. import TcType
  24. import TyCon
  25. import Unify
  26. import Outputable
  27. import ErrUtils
  28. import BasicTypes
  29. import UniqFM
  30. import Util
  31. import Id
  32. import FastString
  33. import Data.Data ( Data, Typeable )
  34. import Data.Maybe ( isJust, isNothing )
  35. \end{code}
  36. %************************************************************************
  37. %* *
  38. \subsection{The key types}
  39. %* *
  40. %************************************************************************
  41. \begin{code}
  42. data ClsInst
  43. = ClsInst { is_cls :: Name -- Class name
  44. -- Used for "rough matching"; see Note [Rough-match field]
  45. -- INVARIANT: is_tcs = roughMatchTcs is_tys
  46. , is_tcs :: [Maybe Name] -- Top of type args
  47. -- Used for "proper matching"; see Note [Proper-match fields]
  48. , is_tvs :: TyVarSet -- Template tyvars for full match
  49. , is_tys :: [Type] -- Full arg types
  50. -- INVARIANT: is_dfun Id has type
  51. -- forall is_tvs. (...) => is_cls is_tys
  52. , is_dfun :: DFunId -- See Note [Haddock assumptions]
  53. -- See Note [Silent superclass arguments] in TcInstDcls
  54. -- for how to map the DFun's type back to the source
  55. -- language instance decl
  56. , is_flag :: OverlapFlag -- See detailed comments with
  57. -- the decl of BasicTypes.OverlapFlag
  58. }
  59. deriving (Data, Typeable)
  60. \end{code}
  61. Note [Rough-match field]
  62. ~~~~~~~~~~~~~~~~~~~~~~~~~~~
  63. The is_cls, is_tcs fields allow a "rough match" to be done
  64. without poking inside the DFunId. Poking the DFunId forces
  65. us to suck in all the type constructors etc it involves,
  66. which is a total waste of time if it has no chance of matching
  67. So the Name, [Maybe Name] fields allow us to say "definitely
  68. does not match", based only on the Name.
  69. In is_tcs,
  70. Nothing means that this type arg is a type variable
  71. (Just n) means that this type arg is a
  72. TyConApp with a type constructor of n.
  73. This is always a real tycon, never a synonym!
  74. (Two different synonyms might match, but two
  75. different real tycons can't.)
  76. NB: newtypes are not transparent, though!
  77. Note [Proper-match fields]
  78. ~~~~~~~~~~~~~~~~~~~~~~~~~
  79. The is_tvs, is_tys fields are simply cached values, pulled
  80. out (lazily) from the dfun id. They are cached here simply so
  81. that we don't need to decompose the DFunId each time we want
  82. to match it. The hope is that the fast-match fields mean
  83. that we often never poke th proper-match fields
  84. However, note that:
  85. * is_tvs must be a superset of the free vars of is_tys
  86. * The is_dfun must itself be quantified over exactly is_tvs
  87. (This is so that we can use the matching substitution to
  88. instantiate the dfun's context.)
  89. Note [Haddock assumptions]
  90. ~~~~~~~~~~~~~~~~~~~~~~~~~~
  91. For normal user-written instances, Haddock relies on
  92. * the SrcSpan of
  93. * the Name of
  94. * the is_dfun of
  95. * an Instance
  96. being equal to
  97. * the SrcSpan of
  98. * the instance head type of
  99. * the InstDecl used to construct the Instance.
  100. \begin{code}
  101. instanceDFunId :: ClsInst -> DFunId
  102. instanceDFunId = is_dfun
  103. setInstanceDFunId :: ClsInst -> DFunId -> ClsInst
  104. setInstanceDFunId ispec dfun
  105. = ASSERT2( idType dfun `eqType` idType (is_dfun ispec)
  106. , ppr dfun $$ ppr (idType dfun) $$ ppr (is_dfun ispec) $$ ppr (idType (is_dfun ispec)) )
  107. -- We need to create the cached fields afresh from
  108. -- the new dfun id. In particular, the is_tvs in
  109. -- the ClsInst must match those in the dfun!
  110. -- We assume that the only thing that changes is
  111. -- the quantified type variables, so the other fields
  112. -- are ok; hence the assert
  113. ispec { is_dfun = dfun, is_tvs = mkVarSet tvs, is_tys = tys }
  114. where
  115. (tvs, _, _, tys) = tcSplitDFunTy (idType dfun)
  116. instanceRoughTcs :: ClsInst -> [Maybe Name]
  117. instanceRoughTcs = is_tcs
  118. \end{code}
  119. \begin{code}
  120. instance NamedThing ClsInst where
  121. getName ispec = getName (is_dfun ispec)
  122. instance Outputable ClsInst where
  123. ppr = pprInstance
  124. pprInstance :: ClsInst -> SDoc
  125. -- Prints the ClsInst as an instance declaration
  126. pprInstance ispec
  127. = hang (pprInstanceHdr ispec)
  128. 2 (ptext (sLit "--") <+> pprDefinedAt (getName ispec))
  129. -- * pprInstanceHdr is used in VStudio to populate the ClassView tree
  130. pprInstanceHdr :: ClsInst -> SDoc
  131. -- Prints the ClsInst as an instance declaration
  132. pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun })
  133. = getPprStyle $ \ sty ->
  134. let theta_to_print
  135. | debugStyle sty = theta
  136. | otherwise = drop (dfunNSilent dfun) theta
  137. -- See Note [Silent superclass arguments] in TcInstDcls
  138. in ptext (sLit "instance") <+> ppr flag
  139. <+> sep [pprThetaArrowTy theta_to_print, ppr res_ty]
  140. where
  141. (_, theta, res_ty) = tcSplitSigmaTy (idType dfun)
  142. -- Print without the for-all, which the programmer doesn't write
  143. pprInstances :: [ClsInst] -> SDoc
  144. pprInstances ispecs = vcat (map pprInstance ispecs)
  145. instanceHead :: ClsInst -> ([TyVar], ThetaType, Class, [Type])
  146. instanceHead ispec = (tvs, theta, cls, tys)
  147. where
  148. (tvs, theta, tau) = tcSplitSigmaTy (idType dfun)
  149. (cls, tys) = tcSplitDFunHead tau
  150. dfun = is_dfun ispec
  151. mkLocalInstance :: DFunId
  152. -> OverlapFlag
  153. -> ClsInst
  154. -- Used for local instances, where we can safely pull on the DFunId
  155. mkLocalInstance dfun oflag
  156. = ClsInst { is_flag = oflag, is_dfun = dfun,
  157. is_tvs = mkVarSet tvs, is_tys = tys,
  158. is_cls = className cls, is_tcs = roughMatchTcs tys }
  159. where
  160. (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
  161. mkImportedInstance :: Name -> [Maybe Name]
  162. -> DFunId -> OverlapFlag -> ClsInst
  163. -- Used for imported instances, where we get the rough-match stuff
  164. -- from the interface file
  165. mkImportedInstance cls mb_tcs dfun oflag
  166. = ClsInst { is_flag = oflag, is_dfun = dfun,
  167. is_tvs = mkVarSet tvs, is_tys = tys,
  168. is_cls = cls, is_tcs = mb_tcs }
  169. where
  170. (tvs, _, _, tys) = tcSplitDFunTy (idType dfun)
  171. roughMatchTcs :: [Type] -> [Maybe Name]
  172. roughMatchTcs tys = map rough tys
  173. where
  174. rough ty = case tcSplitTyConApp_maybe ty of
  175. Just (tc,_) -> Just (tyConName tc)
  176. Nothing -> Nothing
  177. instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool
  178. -- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot
  179. -- possibly be instantiated to actual, nor vice versa;
  180. -- False is non-committal
  181. instanceCantMatch (Just t : ts) (Just a : as) = t/=a || instanceCantMatch ts as
  182. instanceCantMatch _ _ = False -- Safe
  183. \end{code}
  184. Note [Overlapping instances]
  185. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  186. Overlap is permitted, but only in such a way that one can make
  187. a unique choice when looking up. That is, overlap is only permitted if
  188. one template matches the other, or vice versa. So this is ok:
  189. [a] [Int]
  190. but this is not
  191. (Int,a) (b,Int)
  192. If overlap is permitted, the list is kept most specific first, so that
  193. the first lookup is the right choice.
  194. For now we just use association lists.
  195. \subsection{Avoiding a problem with overlapping}
  196. Consider this little program:
  197. \begin{pseudocode}
  198. class C a where c :: a
  199. class C a => D a where d :: a
  200. instance C Int where c = 17
  201. instance D Int where d = 13
  202. instance C a => C [a] where c = [c]
  203. instance ({- C [a], -} D a) => D [a] where d = c
  204. instance C [Int] where c = [37]
  205. main = print (d :: [Int])
  206. \end{pseudocode}
  207. What do you think `main' prints (assuming we have overlapping instances, and
  208. all that turned on)? Well, the instance for `D' at type `[a]' is defined to
  209. be `c' at the same type, and we've got an instance of `C' at `[Int]', so the
  210. answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because
  211. the `C [Int]' instance is more specific).
  212. Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong. That
  213. was easy ;-) Let's just consult hugs for good measure. Wait - if I use old
  214. hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it
  215. doesn't even compile! What's going on!?
  216. What hugs complains about is the `D [a]' instance decl.
  217. \begin{pseudocode}
  218. ERROR "mj.hs" (line 10): Cannot build superclass instance
  219. *** Instance : D [a]
  220. *** Context supplied : D a
  221. *** Required superclass : C [a]
  222. \end{pseudocode}
  223. You might wonder what hugs is complaining about. It's saying that you
  224. need to add `C [a]' to the context of the `D [a]' instance (as appears
  225. in comments). But there's that `C [a]' instance decl one line above
  226. that says that I can reduce the need for a `C [a]' instance to the
  227. need for a `C a' instance, and in this case, I already have the
  228. necessary `C a' instance (since we have `D a' explicitly in the
  229. context, and `C' is a superclass of `D').
  230. Unfortunately, the above reasoning indicates a premature commitment to the
  231. generic `C [a]' instance. I.e., it prematurely rules out the more specific
  232. instance `C [Int]'. This is the mistake that ghc-4.06 makes. The fix is to
  233. add the context that hugs suggests (uncomment the `C [a]'), effectively
  234. deferring the decision about which instance to use.
  235. Now, interestingly enough, 4.04 has this same bug, but it's covered up
  236. in this case by a little known `optimization' that was disabled in
  237. 4.06. Ghc-4.04 silently inserts any missing superclass context into
  238. an instance declaration. In this case, it silently inserts the `C
  239. [a]', and everything happens to work out.
  240. (See `basicTypes/MkId:mkDictFunId' for the code in question. Search for
  241. `Mark Jones', although Mark claims no credit for the `optimization' in
  242. question, and would rather it stopped being called the `Mark Jones
  243. optimization' ;-)
  244. So, what's the fix? I think hugs has it right. Here's why. Let's try
  245. something else out with ghc-4.04. Let's add the following line:
  246. d' :: D a => [a]
  247. d' = c
  248. Everyone raise their hand who thinks that `d :: [Int]' should give a
  249. different answer from `d' :: [Int]'. Well, in ghc-4.04, it does. The
  250. `optimization' only applies to instance decls, not to regular
  251. bindings, giving inconsistent behavior.
  252. Old hugs had this same bug. Here's how we fixed it: like GHC, the
  253. list of instances for a given class is ordered, so that more specific
  254. instances come before more generic ones. For example, the instance
  255. list for C might contain:
  256. ..., C Int, ..., C a, ...
  257. When we go to look for a `C Int' instance we'll get that one first.
  258. But what if we go looking for a `C b' (`b' is unconstrained)? We'll
  259. pass the `C Int' instance, and keep going. But if `b' is
  260. unconstrained, then we don't know yet if the more specific instance
  261. will eventually apply. GHC keeps going, and matches on the generic `C
  262. a'. The fix is to, at each step, check to see if there's a reverse
  263. match, and if so, abort the search. This prevents hugs from
  264. prematurely chosing a generic instance when a more specific one
  265. exists.
  266. --Jeff
  267. BUT NOTE [Nov 2001]: we must actually *unify* not reverse-match in
  268. this test. Suppose the instance envt had
  269. ..., forall a b. C a a b, ..., forall a b c. C a b c, ...
  270. (still most specific first)
  271. Now suppose we are looking for (C x y Int), where x and y are unconstrained.
  272. C x y Int doesn't match the template {a,b} C a a b
  273. but neither does
  274. C a a b match the template {x,y} C x y Int
  275. But still x and y might subsequently be unified so they *do* match.
  276. Simple story: unify, don't match.
  277. %************************************************************************
  278. %* *
  279. InstEnv, ClsInstEnv
  280. %* *
  281. %************************************************************************
  282. A @ClsInstEnv@ all the instances of that class. The @Id@ inside a
  283. ClsInstEnv mapping is the dfun for that instance.
  284. If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then
  285. forall a b, C t1 t2 t3 can be constructed by dfun
  286. or, to put it another way, we have
  287. instance (...) => C t1 t2 t3, witnessed by dfun
  288. \begin{code}
  289. ---------------------------------------------------
  290. type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class
  291. newtype ClsInstEnv
  292. = ClsIE [ClsInst] -- The instances for a particular class, in any order
  293. instance Outputable ClsInstEnv where
  294. ppr (ClsIE is) = pprInstances is
  295. -- INVARIANTS:
  296. -- * The is_tvs are distinct in each ClsInst
  297. -- of a ClsInstEnv (so we can safely unify them)
  298. -- Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry:
  299. -- [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
  300. -- The "a" in the pattern must be one of the forall'd variables in
  301. -- the dfun type.
  302. emptyInstEnv :: InstEnv
  303. emptyInstEnv = emptyUFM
  304. instEnvElts :: InstEnv -> [ClsInst]
  305. instEnvElts ie = [elt | ClsIE elts <- eltsUFM ie, elt <- elts]
  306. classInstances :: (InstEnv,InstEnv) -> Class -> [ClsInst]
  307. classInstances (pkg_ie, home_ie) cls
  308. = get home_ie ++ get pkg_ie
  309. where
  310. get env = case lookupUFM env cls of
  311. Just (ClsIE insts) -> insts
  312. Nothing -> []
  313. extendInstEnvList :: InstEnv -> [ClsInst] -> InstEnv
  314. extendInstEnvList inst_env ispecs = foldl extendInstEnv inst_env ispecs
  315. extendInstEnv :: InstEnv -> ClsInst -> InstEnv
  316. extendInstEnv inst_env ins_item@(ClsInst { is_cls = cls_nm })
  317. = addToUFM_C add inst_env cls_nm (ClsIE [ins_item])
  318. where
  319. add (ClsIE cur_insts) _ = ClsIE (ins_item : cur_insts)
  320. overwriteInstEnv :: InstEnv -> ClsInst -> InstEnv
  321. overwriteInstEnv inst_env ins_item@(ClsInst { is_cls = cls_nm, is_tys = tys })
  322. = addToUFM_C add inst_env cls_nm (ClsIE [ins_item])
  323. where
  324. add (ClsIE cur_insts) _ = ClsIE (replaceInst cur_insts)
  325. rough_tcs = roughMatchTcs tys
  326. replaceInst [] = [ins_item]
  327. replaceInst (item@(ClsInst { is_tcs = mb_tcs, is_tvs = tpl_tvs,
  328. is_tys = tpl_tys,
  329. is_dfun = dfun }) : rest)
  330. -- Fast check for no match, uses the "rough match" fields
  331. | instanceCantMatch rough_tcs mb_tcs
  332. = item : replaceInst rest
  333. | Just _ <- tcMatchTys tpl_tvs tpl_tys tys
  334. = let (dfun_tvs, _) = tcSplitForAllTys (idType dfun)
  335. in ASSERT( all (`elemVarSet` tpl_tvs) dfun_tvs ) -- Check invariant
  336. ins_item : rest
  337. | otherwise
  338. = item : replaceInst rest
  339. \end{code}
  340. %************************************************************************
  341. %* *
  342. Looking up an instance
  343. %* *
  344. %************************************************************************
  345. @lookupInstEnv@ looks up in a @InstEnv@, using a one-way match. Since
  346. the env is kept ordered, the first match must be the only one. The
  347. thing we are looking up can have an arbitrary "flexi" part.
  348. \begin{code}
  349. type DFunInstType = Maybe Type
  350. -- Just ty => Instantiate with this type
  351. -- Nothing => Instantiate with any type of this tyvar's kind
  352. -- See Note [DFunInstType: instantiating types]
  353. type InstMatch = (ClsInst, [DFunInstType])
  354. type ClsInstLookupResult
  355. = ( [InstMatch] -- Successful matches
  356. , [ClsInst] -- These don't match but do unify
  357. , Bool) -- True if error condition caused by
  358. -- SafeHaskell condition.
  359. \end{code}
  360. Note [DFunInstType: instantiating types]
  361. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  362. A successful match is an ClsInst, together with the types at which
  363. the dfun_id in the ClsInst should be instantiated
  364. The instantiating types are (Either TyVar Type)s because the dfun
  365. might have some tyvars that *only* appear in arguments
  366. dfun :: forall a b. C a b, Ord b => D [a]
  367. When we match this against D [ty], we return the instantiating types
  368. [Just ty, Nothing]
  369. where the 'Nothing' indicates that 'b' can be freely instantiated.
  370. (The caller instantiates it to a flexi type variable, which will
  371. presumably later become fixed via functional dependencies.)
  372. \begin{code}
  373. -- |Look up an instance in the given instance environment. The given class application must match exactly
  374. -- one instance and the match may not contain any flexi type variables. If the lookup is unsuccessful,
  375. -- yield 'Left errorMessage'.
  376. --
  377. lookupUniqueInstEnv :: (InstEnv, InstEnv)
  378. -> Class -> [Type]
  379. -> Either MsgDoc (ClsInst, [Type])
  380. lookupUniqueInstEnv instEnv cls tys
  381. = case lookupInstEnv instEnv cls tys of
  382. ([(inst, inst_tys)], _, _)
  383. | noFlexiVar -> Right (inst, inst_tys')
  384. | otherwise -> Left $ ptext (sLit "flexible type variable:") <+>
  385. (ppr $ mkTyConApp (classTyCon cls) tys)
  386. where
  387. inst_tys' = [ty | Just ty <- inst_tys]
  388. noFlexiVar = all isJust inst_tys
  389. _other -> Left $ ptext (sLit "instance not found") <+> (ppr $ mkTyConApp (classTyCon cls) tys)
  390. lookupInstEnv' :: InstEnv -- InstEnv to look in
  391. -> Class -> [Type] -- What we are looking for
  392. -> ([InstMatch], -- Successful matches
  393. [ClsInst]) -- These don't match but do unify
  394. -- The second component of the result pair happens when we look up
  395. -- Foo [a]
  396. -- in an InstEnv that has entries for
  397. -- Foo [Int]
  398. -- Foo [b]
  399. -- Then which we choose would depend on the way in which 'a'
  400. -- is instantiated. So we report that Foo [b] is a match (mapping b->a)
  401. -- but Foo [Int] is a unifier. This gives the caller a better chance of
  402. -- giving a suitable error message
  403. lookupInstEnv' ie cls tys
  404. = lookup ie
  405. where
  406. rough_tcs = roughMatchTcs tys
  407. all_tvs = all isNothing rough_tcs
  408. --------------
  409. lookup env = case lookupUFM env cls of
  410. Nothing -> ([],[]) -- No instances for this class
  411. Just (ClsIE insts) -> find [] [] insts
  412. --------------
  413. find ms us [] = (ms, us)
  414. find ms us (item@(ClsInst { is_tcs = mb_tcs, is_tvs = tpl_tvs,
  415. is_tys = tpl_tys, is_flag = oflag,
  416. is_dfun = dfun }) : rest)
  417. -- Fast check for no match, uses the "rough match" fields
  418. | instanceCantMatch rough_tcs mb_tcs
  419. = find ms us rest
  420. | Just subst <- tcMatchTys tpl_tvs tpl_tys tys
  421. = let
  422. (dfun_tvs, _) = tcSplitForAllTys (idType dfun)
  423. in
  424. ASSERT( all (`elemVarSet` tpl_tvs) dfun_tvs ) -- Check invariant
  425. find ((item, map (lookup_tv subst) dfun_tvs) : ms) us rest
  426. -- Does not match, so next check whether the things unify
  427. -- See Note [Overlapping instances] above
  428. | Incoherent _ <- oflag
  429. = find ms us rest
  430. | otherwise
  431. = ASSERT2( tyVarsOfTypes tys `disjointVarSet` tpl_tvs,
  432. (ppr cls <+> ppr tys <+> ppr all_tvs) $$
  433. (ppr dfun <+> ppr tpl_tvs <+> ppr tpl_tys)
  434. )
  435. -- Unification will break badly if the variables overlap
  436. -- They shouldn't because we allocate separate uniques for them
  437. case tcUnifyTys instanceBindFun tpl_tys tys of
  438. Just _ -> find ms (item:us) rest
  439. Nothing -> find ms us rest
  440. ----------------
  441. lookup_tv :: TvSubst -> TyVar -> DFunInstType
  442. -- See Note [DFunInstType: instantiating types]
  443. lookup_tv subst tv = case lookupTyVar subst tv of
  444. Just ty -> Just ty
  445. Nothing -> Nothing
  446. ---------------
  447. -- This is the common way to call this function.
  448. lookupInstEnv :: (InstEnv, InstEnv) -- External and home package inst-env
  449. -> Class -> [Type] -- What we are looking for
  450. -> ClsInstLookupResult
  451. lookupInstEnv (pkg_ie, home_ie) cls tys
  452. = (safe_matches, all_unifs, safe_fail)
  453. where
  454. (home_matches, home_unifs) = lookupInstEnv' home_ie cls tys
  455. (pkg_matches, pkg_unifs) = lookupInstEnv' pkg_ie cls tys
  456. all_matches = home_matches ++ pkg_matches
  457. all_unifs = home_unifs ++ pkg_unifs
  458. pruned_matches = foldr insert_overlapping [] all_matches
  459. (safe_matches, safe_fail) = if length pruned_matches == 1
  460. then check_safe (head pruned_matches) all_matches
  461. else (pruned_matches, False)
  462. -- Even if the unifs is non-empty (an error situation)
  463. -- we still prune the matches, so that the error message isn't
  464. -- misleading (complaining of multiple matches when some should be
  465. -- overlapped away)
  466. -- Safe Haskell: We restrict code compiled in 'Safe' mode from
  467. -- overriding code compiled in any other mode. The rational is
  468. -- that code compiled in 'Safe' mode is code that is untrusted
  469. -- by the ghc user. So we shouldn't let that code change the
  470. -- behaviour of code the user didn't compile in 'Safe' mode
  471. -- since that's the code they trust. So 'Safe' instances can only
  472. -- overlap instances from the same module. A same instance origin
  473. -- policy for safe compiled instances.
  474. check_safe match@(inst,_) others
  475. = case isSafeOverlap (is_flag inst) of
  476. -- most specific isn't from a Safe module so OK
  477. False -> ([match], False)
  478. -- otherwise we make sure it only overlaps instances from
  479. -- the same module
  480. True -> (go [] others, True)
  481. where
  482. go bad [] = match:bad
  483. go bad (i@(x,_):unchecked) =
  484. if inSameMod x
  485. then go bad unchecked
  486. else go (i:bad) unchecked
  487. inSameMod b =
  488. let na = getName $ getName inst
  489. la = isInternalName na
  490. nb = getName $ getName b
  491. lb = isInternalName nb
  492. in (la && lb) || (nameModule na == nameModule nb)
  493. ---------------
  494. ---------------
  495. insert_overlapping :: InstMatch -> [InstMatch] -> [InstMatch]
  496. -- Add a new solution, knocking out strictly less specific ones
  497. insert_overlapping new_item [] = [new_item]
  498. insert_overlapping new_item (item:items)
  499. | new_beats_old && old_beats_new = item : insert_overlapping new_item items
  500. -- Duplicate => keep both for error report
  501. | new_beats_old = insert_overlapping new_item items
  502. -- Keep new one
  503. | old_beats_new = item : items
  504. -- Keep old one
  505. | otherwise = item : insert_overlapping new_item items
  506. -- Keep both
  507. where
  508. new_beats_old = new_item `beats` item
  509. old_beats_new = item `beats` new_item
  510. (instA, _) `beats` (instB, _)
  511. = overlap_ok &&
  512. isJust (tcMatchTys (is_tvs instB) (is_tys instB) (is_tys instA))
  513. -- A beats B if A is more specific than B,
  514. -- (ie. if B can be instantiated to match A)
  515. -- and overlap is permitted
  516. where
  517. -- Overlap permitted if *either* instance permits overlap
  518. -- This is a change (Trac #3877, Dec 10). It used to
  519. -- require that instB (the less specific one) permitted overlap.
  520. overlap_ok = case (is_flag instA, is_flag instB) of
  521. (NoOverlap _, NoOverlap _) -> False
  522. _ -> True
  523. \end{code}
  524. %************************************************************************
  525. %* *
  526. Binding decisions
  527. %* *
  528. %************************************************************************
  529. \begin{code}
  530. instanceBindFun :: TyVar -> BindFlag
  531. instanceBindFun tv | isTcTyVar tv && isOverlappableTyVar tv = Skolem
  532. | otherwise = BindMe
  533. -- Note [Binding when looking up instances]
  534. \end{code}
  535. Note [Binding when looking up instances]
  536. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  537. When looking up in the instance environment, or family-instance environment,
  538. we are careful about multiple matches, as described above in
  539. Note [Overlapping instances]
  540. The key_tys can contain skolem constants, and we can guarantee that those
  541. are never going to be instantiated to anything, so we should not involve
  542. them in the unification test. Example:
  543. class Foo a where { op :: a -> Int }
  544. instance Foo a => Foo [a] -- NB overlap
  545. instance Foo [Int] -- NB overlap
  546. data T = forall a. Foo a => MkT a
  547. f :: T -> Int
  548. f (MkT x) = op [x,x]
  549. The op [x,x] means we need (Foo [a]). Without the filterVarSet we'd
  550. complain, saying that the choice of instance depended on the instantiation
  551. of 'a'; but of course it isn't *going* to be instantiated.
  552. We do this only for isOverlappableTyVar skolems. For example we reject
  553. g :: forall a => [a] -> Int
  554. g x = op x
  555. on the grounds that the correct instance depends on the instantiation of 'a'