PageRenderTime 47ms CodeModel.GetById 19ms RepoModel.GetById 0ms app.codeStats 0ms

/compiler/types/InstEnv.lhs

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