PageRenderTime 65ms CodeModel.GetById 32ms RepoModel.GetById 0ms app.codeStats 0ms

/compiler/types/InstEnv.lhs

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