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

/compiler/typecheck/TcSMonad.lhs

https://github.com/crdueck/ghc
Haskell | 1708 lines | 1194 code | 327 blank | 187 comment | 33 complexity | 9df82e264681ff4fe9252c473990d9bd MD5 | raw file

Large files files are truncated, but you can click here to view the full file

  1. \begin{code}
  2. {-# OPTIONS -fno-warn-tabs -w #-}
  3. -- The above warning supression flag is a temporary kludge.
  4. -- While working on this module you are encouraged to remove it and
  5. -- detab the module (please do the detabbing in a separate patch). See
  6. -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
  7. -- for details
  8. -- Type definitions for the constraint solver
  9. module TcSMonad (
  10. -- Canonical constraints, definition is now in TcRnTypes
  11. WorkList(..), isEmptyWorkList, emptyWorkList,
  12. workListFromEq, workListFromNonEq, workListFromCt,
  13. extendWorkListEq, extendWorkListFunEq,
  14. extendWorkListNonEq, extendWorkListCt,
  15. extendWorkListCts, extendWorkListEqs, appendWorkList, selectWorkItem,
  16. withWorkList, workListSize,
  17. updWorkListTcS, updWorkListTcS_return,
  18. updTcSImplics,
  19. Ct(..), Xi, tyVarsOfCt, tyVarsOfCts,
  20. emitInsoluble,
  21. isWanted, isDerived,
  22. isGivenCt, isWantedCt, isDerivedCt,
  23. canRewrite, canSolve,
  24. mkGivenLoc,
  25. TcS, runTcS, runTcSWithEvBinds, failTcS, panicTcS, traceTcS, -- Basic functionality
  26. traceFireTcS, bumpStepCountTcS,
  27. tryTcS, nestTcS, nestImplicTcS, recoverTcS,
  28. wrapErrTcS, wrapWarnTcS,
  29. -- Getting and setting the flattening cache
  30. addSolvedDict, addSolvedFunEq, getFlattenSkols,
  31. deferTcSForAllEq,
  32. setEvBind,
  33. XEvTerm(..),
  34. MaybeNew (..), isFresh, freshGoals, getEvTerms,
  35. xCtFlavor, -- Transform a CtEvidence during a step
  36. rewriteCtFlavor, -- Specialized version of xCtFlavor for coercions
  37. newWantedEvVar, newWantedEvVarNC, instDFunConstraints,
  38. newDerived,
  39. -- Creation of evidence variables
  40. setWantedTyBind,
  41. getInstEnvs, getFamInstEnvs, -- Getting the environments
  42. getTopEnv, getGblEnv, getTcEvBinds, getUntouchables,
  43. getTcEvBindsMap, getTcSTyBinds, getTcSTyBindsMap,
  44. lookupFlatEqn, newFlattenSkolem, -- Flatten skolems
  45. -- Deque
  46. Deque(..), insertDeque, emptyDeque,
  47. -- Inerts
  48. InertSet(..), InertCans(..),
  49. getInertEqs,
  50. emptyInert, getTcSInerts, lookupInInerts,
  51. getInertUnsolved, checkAllSolved,
  52. prepareInertsForImplications,
  53. modifyInertTcS,
  54. insertInertItemTcS, partitionCCanMap, partitionEqMap,
  55. getRelevantCts, extractRelevantInerts,
  56. CCanMap(..), CtTypeMap, CtFamHeadMap, CtPredMap,
  57. PredMap, FamHeadMap,
  58. partCtFamHeadMap, lookupFamHead, lookupSolvedDict,
  59. filterSolved,
  60. instDFunType, -- Instantiation
  61. newFlexiTcSTy, instFlexiTcS, instFlexiTcSHelperTcS,
  62. cloneMetaTyVar,
  63. Untouchables, isTouchableMetaTyVarTcS, isFilledMetaTyVar_maybe,
  64. zonkTyVarsAndFV,
  65. getDefaultInfo, getDynFlags,
  66. matchFam, matchOpenFam,
  67. checkWellStagedDFun,
  68. pprEq -- Smaller utils, re-exported from TcM
  69. -- TODO (DV): these are only really used in the
  70. -- instance matcher in TcSimplify. I am wondering
  71. -- if the whole instance matcher simply belongs
  72. -- here
  73. ) where
  74. #include "HsVersions.h"
  75. import HscTypes
  76. import Inst
  77. import InstEnv
  78. import FamInst
  79. import FamInstEnv
  80. import qualified TcRnMonad as TcM
  81. import qualified TcMType as TcM
  82. import qualified TcEnv as TcM
  83. ( checkWellStaged, topIdLvl, tcGetDefaultTys )
  84. import Kind
  85. import TcType
  86. import DynFlags
  87. import Type
  88. import TcEvidence
  89. import Class
  90. import TyCon
  91. import Name
  92. import Var
  93. import VarEnv
  94. import Outputable
  95. import Bag
  96. import MonadUtils
  97. import FastString
  98. import Util
  99. import Id
  100. import TcRnTypes
  101. import Unique
  102. import UniqFM
  103. import Maybes ( orElse, catMaybes, firstJust )
  104. import Pair ( pSnd )
  105. import Control.Monad( unless, when, zipWithM )
  106. import Data.IORef
  107. import TrieMap
  108. #ifdef DEBUG
  109. import StaticFlags( opt_PprStyle_Debug )
  110. import VarSet
  111. import Digraph
  112. #endif
  113. \end{code}
  114. %************************************************************************
  115. %* *
  116. %* Worklists *
  117. %* Canonical and non-canonical constraints that the simplifier has to *
  118. %* work on. Including their simplification depths. *
  119. %* *
  120. %* *
  121. %************************************************************************
  122. Note [WorkList priorities]
  123. ~~~~~~~~~~~~~~~~~~~~~~~~~~~
  124. A WorkList contains canonical and non-canonical items (of all flavors).
  125. Notice that each Ct now has a simplification depth. We may
  126. consider using this depth for prioritization as well in the future.
  127. As a simple form of priority queue, our worklist separates out
  128. equalities (wl_eqs) from the rest of the canonical constraints,
  129. so that it's easier to deal with them first, but the separation
  130. is not strictly necessary. Notice that non-canonical constraints
  131. are also parts of the worklist.
  132. Note [NonCanonical Semantics]
  133. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  134. Note that canonical constraints involve a CNonCanonical constructor. In the worklist
  135. we use this constructor for constraints that have not yet been canonicalized such as
  136. [Int] ~ [a]
  137. In other words, all constraints start life as NonCanonicals.
  138. On the other hand, in the Inert Set (see below) the presence of a NonCanonical somewhere
  139. means that we have a ``frozen error''.
  140. NonCanonical constraints never interact directly with other constraints -- but they can
  141. be rewritten by equalities (for instance if a non canonical exists in the inert, we'd
  142. better rewrite it as much as possible before reporting it as an error to the user)
  143. \begin{code}
  144. data Deque a = DQ [a] [a] -- Insert in RH field, remove from LH field
  145. -- First to remove is at head of LH field
  146. instance Outputable a => Outputable (Deque a) where
  147. ppr (DQ as bs) = ppr (as ++ reverse bs) -- Show first one to come out at the start
  148. emptyDeque :: Deque a
  149. emptyDeque = DQ [] []
  150. isEmptyDeque :: Deque a -> Bool
  151. isEmptyDeque (DQ as bs) = null as && null bs
  152. dequeSize :: Deque a -> Int
  153. dequeSize (DQ as bs) = length as + length bs
  154. insertDeque :: a -> Deque a -> Deque a
  155. insertDeque b (DQ as bs) = DQ as (b:bs)
  156. appendDeque :: Deque a -> Deque a -> Deque a
  157. appendDeque (DQ as1 bs1) (DQ as2 bs2) = DQ (as1 ++ reverse bs1 ++ as2) bs2
  158. extractDeque :: Deque a -> Maybe (Deque a, a)
  159. extractDeque (DQ [] []) = Nothing
  160. extractDeque (DQ (a:as) bs) = Just (DQ as bs, a)
  161. extractDeque (DQ [] bs) = case reverse bs of
  162. (a:as) -> Just (DQ as [], a)
  163. [] -> panic "extractDeque"
  164. -- See Note [WorkList priorities]
  165. data WorkList = WorkList { wl_eqs :: [Ct]
  166. , wl_funeqs :: Deque Ct
  167. , wl_rest :: [Ct]
  168. }
  169. appendWorkList :: WorkList -> WorkList -> WorkList
  170. appendWorkList new_wl orig_wl
  171. = WorkList { wl_eqs = wl_eqs new_wl ++ wl_eqs orig_wl
  172. , wl_funeqs = wl_funeqs new_wl `appendDeque` wl_funeqs orig_wl
  173. , wl_rest = wl_rest new_wl ++ wl_rest orig_wl }
  174. workListSize :: WorkList -> Int
  175. workListSize (WorkList { wl_eqs = eqs, wl_funeqs = funeqs, wl_rest = rest })
  176. = length eqs + dequeSize funeqs + length rest
  177. extendWorkListEq :: Ct -> WorkList -> WorkList
  178. -- Extension by equality
  179. extendWorkListEq ct wl
  180. | Just {} <- isCFunEqCan_Maybe ct
  181. = extendWorkListFunEq ct wl
  182. | otherwise
  183. = wl { wl_eqs = ct : wl_eqs wl }
  184. extendWorkListFunEq :: Ct -> WorkList -> WorkList
  185. extendWorkListFunEq ct wl
  186. = wl { wl_funeqs = insertDeque ct (wl_funeqs wl) }
  187. extendWorkListEqs :: [Ct] -> WorkList -> WorkList
  188. -- Append a list of equalities
  189. extendWorkListEqs cts wl = foldr extendWorkListEq wl cts
  190. extendWorkListNonEq :: Ct -> WorkList -> WorkList
  191. -- Extension by non equality
  192. extendWorkListNonEq ct wl
  193. = wl { wl_rest = ct : wl_rest wl }
  194. extendWorkListCt :: Ct -> WorkList -> WorkList
  195. -- Agnostic
  196. extendWorkListCt ct wl
  197. | isEqPred (ctPred ct) = extendWorkListEq ct wl
  198. | otherwise = extendWorkListNonEq ct wl
  199. extendWorkListCts :: [Ct] -> WorkList -> WorkList
  200. -- Agnostic
  201. extendWorkListCts cts wl = foldr extendWorkListCt wl cts
  202. isEmptyWorkList :: WorkList -> Bool
  203. isEmptyWorkList wl
  204. = null (wl_eqs wl) && null (wl_rest wl) && isEmptyDeque (wl_funeqs wl)
  205. emptyWorkList :: WorkList
  206. emptyWorkList = WorkList { wl_eqs = [], wl_rest = [], wl_funeqs = emptyDeque }
  207. workListFromEq :: Ct -> WorkList
  208. workListFromEq ct = extendWorkListEq ct emptyWorkList
  209. workListFromNonEq :: Ct -> WorkList
  210. workListFromNonEq ct = extendWorkListNonEq ct emptyWorkList
  211. workListFromCt :: Ct -> WorkList
  212. -- Agnostic
  213. workListFromCt ct | isEqPred (ctPred ct) = workListFromEq ct
  214. | otherwise = workListFromNonEq ct
  215. selectWorkItem :: WorkList -> (Maybe Ct, WorkList)
  216. selectWorkItem wl@(WorkList { wl_eqs = eqs, wl_funeqs = feqs, wl_rest = rest })
  217. = case (eqs,feqs,rest) of
  218. (ct:cts,_,_) -> (Just ct, wl { wl_eqs = cts })
  219. (_,fun_eqs,_) | Just (fun_eqs', ct) <- extractDeque fun_eqs
  220. -> (Just ct, wl { wl_funeqs = fun_eqs' })
  221. (_,_,(ct:cts)) -> (Just ct, wl { wl_rest = cts })
  222. (_,_,_) -> (Nothing,wl)
  223. -- Pretty printing
  224. instance Outputable WorkList where
  225. ppr wl = vcat [ text "WorkList (eqs) = " <+> ppr (wl_eqs wl)
  226. , text "WorkList (funeqs)= " <+> ppr (wl_funeqs wl)
  227. , text "WorkList (rest) = " <+> ppr (wl_rest wl)
  228. ]
  229. -- Canonical constraint maps
  230. data CCanMap a
  231. = CCanMap { cts_given :: UniqFM Cts -- All Given
  232. , cts_derived :: UniqFM Cts -- All Derived
  233. , cts_wanted :: UniqFM Cts } -- All Wanted
  234. keepGivenCMap :: CCanMap a -> CCanMap a
  235. keepGivenCMap cc = emptyCCanMap { cts_given = cts_given cc }
  236. instance Outputable (CCanMap a) where
  237. ppr (CCanMap given derived wanted) = ptext (sLit "CCanMap") <+> (ppr given) <+> (ppr derived) <+> (ppr wanted)
  238. cCanMapToBag :: CCanMap a -> Cts
  239. cCanMapToBag cmap = foldUFM unionBags rest_wder (cts_given cmap)
  240. where rest_wder = foldUFM unionBags rest_der (cts_wanted cmap)
  241. rest_der = foldUFM unionBags emptyCts (cts_derived cmap)
  242. emptyCCanMap :: CCanMap a
  243. emptyCCanMap = CCanMap { cts_given = emptyUFM, cts_derived = emptyUFM, cts_wanted = emptyUFM }
  244. updCCanMap:: Uniquable a => (a,Ct) -> CCanMap a -> CCanMap a
  245. updCCanMap (a,ct) cmap
  246. = case cc_ev ct of
  247. CtWanted {} -> cmap { cts_wanted = insert_into (cts_wanted cmap) }
  248. CtGiven {} -> cmap { cts_given = insert_into (cts_given cmap) }
  249. CtDerived {} -> cmap { cts_derived = insert_into (cts_derived cmap) }
  250. where
  251. insert_into m = addToUFM_C unionBags m a (singleCt ct)
  252. getRelevantCts :: Uniquable a => a -> CCanMap a -> (Cts, CCanMap a)
  253. -- Gets the relevant constraints and returns the rest of the CCanMap
  254. getRelevantCts a cmap
  255. = let relevant = lookup (cts_wanted cmap) `unionBags`
  256. lookup (cts_given cmap) `unionBags`
  257. lookup (cts_derived cmap)
  258. residual_map = cmap { cts_wanted = delFromUFM (cts_wanted cmap) a
  259. , cts_given = delFromUFM (cts_given cmap) a
  260. , cts_derived = delFromUFM (cts_derived cmap) a }
  261. in (relevant, residual_map)
  262. where
  263. lookup map = lookupUFM map a `orElse` emptyCts
  264. lookupCCanMap :: Uniquable a => a -> (CtEvidence -> Bool) -> CCanMap a -> Maybe CtEvidence
  265. lookupCCanMap a pick_me map
  266. = findEvidence pick_me possible_cts
  267. where
  268. possible_cts = lookupUFM (cts_given map) a `plus` (
  269. lookupUFM (cts_wanted map) a `plus` (
  270. lookupUFM (cts_derived map) a `plus` emptyCts))
  271. plus Nothing cts2 = cts2
  272. plus (Just cts1) cts2 = cts1 `unionBags` cts2
  273. findEvidence :: (CtEvidence -> Bool) -> Cts -> Maybe CtEvidence
  274. findEvidence pick_me cts
  275. = foldrBag pick Nothing cts
  276. where
  277. pick :: Ct -> Maybe CtEvidence -> Maybe CtEvidence
  278. pick ct deflt | let ctev = cc_ev ct, pick_me ctev = Just ctev
  279. | otherwise = deflt
  280. partitionCCanMap :: (Ct -> Bool) -> CCanMap a -> (Cts,CCanMap a)
  281. -- All constraints that /match/ the predicate go in the bag, the rest remain in the map
  282. partitionCCanMap pred cmap
  283. = let (ws_map,ws) = foldUFM_Directly aux (emptyUFM,emptyCts) (cts_wanted cmap)
  284. (ds_map,ds) = foldUFM_Directly aux (emptyUFM,emptyCts) (cts_derived cmap)
  285. (gs_map,gs) = foldUFM_Directly aux (emptyUFM,emptyCts) (cts_given cmap)
  286. in (ws `andCts` ds `andCts` gs, cmap { cts_wanted = ws_map
  287. , cts_given = gs_map
  288. , cts_derived = ds_map })
  289. where aux k this_cts (mp,acc_cts) = (new_mp, new_acc_cts)
  290. where new_mp = addToUFM mp k cts_keep
  291. new_acc_cts = acc_cts `andCts` cts_out
  292. (cts_out, cts_keep) = partitionBag pred this_cts
  293. partitionEqMap :: (Ct -> Bool) -> TyVarEnv (Ct,TcCoercion) -> ([Ct], TyVarEnv (Ct,TcCoercion))
  294. partitionEqMap pred isubst
  295. = let eqs_out = foldVarEnv extend_if_pred [] isubst
  296. eqs_in = filterVarEnv_Directly (\_ (ct,_) -> not (pred ct)) isubst
  297. in (eqs_out, eqs_in)
  298. where extend_if_pred (ct,_) cts = if pred ct then ct : cts else cts
  299. extractUnsolvedCMap :: CCanMap a -> Cts
  300. -- Gets the wanted or derived constraints
  301. extractUnsolvedCMap cmap = foldUFM unionBags emptyCts (cts_wanted cmap)
  302. `unionBags` foldUFM unionBags emptyCts (cts_derived cmap)
  303. -- Maps from PredTypes to Constraints
  304. type CtTypeMap = TypeMap Ct
  305. type CtPredMap = PredMap Ct
  306. type CtFamHeadMap = FamHeadMap Ct
  307. newtype PredMap a = PredMap { unPredMap :: TypeMap a } -- Indexed by TcPredType
  308. newtype FamHeadMap a = FamHeadMap { unFamHeadMap :: TypeMap a } -- Indexed by family head
  309. instance Outputable a => Outputable (PredMap a) where
  310. ppr (PredMap m) = ppr (foldTM (:) m [])
  311. instance Outputable a => Outputable (FamHeadMap a) where
  312. ppr (FamHeadMap m) = ppr (foldTM (:) m [])
  313. sizePredMap :: PredMap a -> Int
  314. sizePredMap (PredMap m) = foldTypeMap (\_ x -> x+1) 0 m
  315. emptyFamHeadMap :: FamHeadMap a
  316. emptyFamHeadMap = FamHeadMap emptyTM
  317. sizeFamHeadMap :: FamHeadMap a -> Int
  318. sizeFamHeadMap (FamHeadMap m) = foldTypeMap (\_ x -> x+1) 0 m
  319. ctTypeMapCts :: TypeMap Ct -> Cts
  320. ctTypeMapCts ctmap = foldTM (\ct cts -> extendCts cts ct) ctmap emptyCts
  321. lookupFamHead :: FamHeadMap a -> TcType -> Maybe a
  322. lookupFamHead (FamHeadMap m) key = lookupTM key m
  323. insertFamHead :: FamHeadMap a -> TcType -> a -> FamHeadMap a
  324. insertFamHead (FamHeadMap m) key value = FamHeadMap (alterTM key (const (Just value)) m)
  325. delFamHead :: FamHeadMap a -> TcType -> FamHeadMap a
  326. delFamHead (FamHeadMap m) key = FamHeadMap (alterTM key (const Nothing) m)
  327. anyFamHeadMap :: (Ct -> Bool) -> CtFamHeadMap -> Bool
  328. anyFamHeadMap f ctmap = foldTM ((||) . f) (unFamHeadMap ctmap) False
  329. partCtFamHeadMap :: (Ct -> Bool)
  330. -> CtFamHeadMap
  331. -> (Cts, CtFamHeadMap)
  332. partCtFamHeadMap f ctmap
  333. = let (cts,tymap_final) = foldTM upd_acc tymap_inside (emptyBag, tymap_inside)
  334. in (cts, FamHeadMap tymap_final)
  335. where
  336. tymap_inside = unFamHeadMap ctmap
  337. upd_acc ct (cts,acc_map)
  338. | f ct = (extendCts cts ct, alterTM ct_key (\_ -> Nothing) acc_map)
  339. | otherwise = (cts,acc_map)
  340. where ct_key | EqPred ty1 _ <- classifyPredType (ctPred ct)
  341. = ty1
  342. | otherwise
  343. = panic "partCtFamHeadMap, encountered non equality!"
  344. filterSolved :: (CtEvidence -> Bool) -> PredMap CtEvidence -> PredMap CtEvidence
  345. filterSolved p (PredMap mp) = PredMap (foldTM upd mp emptyTM)
  346. where upd a m = if p a then alterTM (ctEvPred a) (\_ -> Just a) m
  347. else m
  348. \end{code}
  349. %************************************************************************
  350. %* *
  351. %* Inert Sets *
  352. %* *
  353. %* *
  354. %************************************************************************
  355. Note [Detailed InertCans Invariants]
  356. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  357. The InertCans represents a collection of constraints with the following properties:
  358. 1 All canonical
  359. 2 All Given or Wanted or Derived. No (partially) Solved
  360. 3 No two dictionaries with the same head
  361. 4 No two family equations with the same head
  362. NB: This is enforced by construction since we use a CtFamHeadMap for inert_funeqs
  363. 5 Family equations inert wrt top-level family axioms
  364. 6 Dictionaries have no matching top-level instance
  365. 7 Non-equality constraints are fully rewritten with respect to the equalities (CTyEqCan)
  366. 8 Equalities _do_not_ form an idempotent substitution, but they are
  367. guaranteed to not have any occurs errors. Additional notes:
  368. - The lack of idempotence of the inert substitution implies
  369. that we must make sure that when we rewrite a constraint we
  370. apply the substitution /recursively/ to the types
  371. involved. Currently the one AND ONLY way in the whole
  372. constraint solver that we rewrite types and constraints wrt
  373. to the inert substitution is TcCanonical/flattenTyVar.
  374. - In the past we did try to have the inert substitution as
  375. idempotent as possible but this would only be true for
  376. constraints of the same flavor, so in total the inert
  377. substitution could not be idempotent, due to flavor-related
  378. issued. Note [Non-idempotent inert substitution] explains
  379. what is going on.
  380. - Whenever a constraint ends up in the worklist we do
  381. recursively apply exhaustively the inert substitution to it
  382. to check for occurs errors. But if an equality is already in
  383. the inert set and we can guarantee that adding a new equality
  384. will not cause the first equality to have an occurs check
  385. then we do not rewrite the inert equality. This happens in
  386. TcInteract, rewriteInertEqsFromInertEq.
  387. See Note [Delicate equality kick-out] to see which inert
  388. equalities can safely stay in the inert set and which must be
  389. kicked out to be rewritten and re-checked for occurs errors.
  390. 9 Given family or dictionary constraints don't mention touchable unification variables
  391. Note [Solved constraints]
  392. ~~~~~~~~~~~~~~~~~~~~~~~~~
  393. When we take a step to simplify a constraint 'c', we call the original constraint "solved".
  394. For example: Wanted: ev :: [s] ~ [t]
  395. New goal: ev1 :: s ~ t
  396. Then 'ev' is now "solved".
  397. The reason for all this is simply to avoid re-solving goals we have solved already.
  398. * A solved Wanted may depend on as-yet-unsolved goals, so (for example) we should not
  399. use it to rewrite a Given; in that sense the solved goal is still a Wanted
  400. * A solved Given is just given
  401. * A solved Derived in inert_solved is possible; purpose is to avoid
  402. creating tons of identical Derived goals.
  403. But there are no solved Deriveds in inert_solved_funeqs
  404. Note [Type family equations]
  405. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  406. Type-family equations, of form (ev : F tys ~ ty), live in four places
  407. * The work-list, of course
  408. * The inert_flat_cache. This is used when flattening, to get maximal
  409. sharing. It contains lots of things that are still in the work-list.
  410. E.g Suppose we have (w1: F (G a) ~ Int), and (w2: H (G a) ~ Int) in the
  411. work list. Then we flatten w1, dumping (w3: G a ~ f1) in the work
  412. list. Now if we flatten w2 before we get to w3, we still want to
  413. share that (G a).
  414. Because it contains work-list things, DO NOT use the flat cache to solve
  415. a top-level goal. Eg in the above example we don't want to solve w3
  416. using w3 itself!
  417. * The inert_solved_funeqs. These are all "solved" goals (see Note [Solved constraints]),
  418. the result of using a top-level type-family instance.
  419. * THe inert_funeqs are un-solved but fully processed and in the InertCans.
  420. \begin{code}
  421. -- All Given (fully known) or Wanted or Derived
  422. -- See Note [Detailed InertCans Invariants] for more
  423. data InertCans
  424. = IC { inert_eqs :: TyVarEnv Ct
  425. -- Must all be CTyEqCans! If an entry exists of the form:
  426. -- a |-> ct,co
  427. -- Then ct = CTyEqCan { cc_tyvar = a, cc_rhs = xi }
  428. -- And co : a ~ xi
  429. , inert_dicts :: CCanMap Class
  430. -- Dictionaries only, index is the class
  431. -- NB: index is /not/ the whole type because FD reactions
  432. -- need to match the class but not necessarily the whole type.
  433. , inert_funeqs :: CtFamHeadMap
  434. -- Family equations, index is the whole family head type.
  435. , inert_irreds :: Cts
  436. -- Irreducible predicates
  437. , inert_insols :: Cts
  438. -- Frozen errors (as non-canonicals)
  439. }
  440. -- The Inert Set
  441. data InertSet
  442. = IS { inert_cans :: InertCans
  443. -- Canonical Given, Wanted, Derived (no Solved)
  444. -- Sometimes called "the inert set"
  445. , inert_flat_cache :: FamHeadMap (CtEvidence, TcType)
  446. -- See Note [Type family equations]
  447. -- Just a hash-cons cache for use when flattening only
  448. -- These include entirely un-processed goals, so don't use
  449. -- them to solve a top-level goal, else you may end up solving
  450. -- (w:F ty ~ a) by setting w:=w! We just use the flat-cache
  451. -- when allocating a new flatten-skolem.
  452. -- Not necessarily inert wrt top-level equations (or inert_cans)
  453. , inert_fsks :: [TcTyVar] -- Rigid flatten-skolems (arising from givens)
  454. -- allocated in this local scope
  455. , inert_solved_funeqs :: FamHeadMap (CtEvidence, TcType)
  456. -- See Note [Type family equations]
  457. -- Of form co :: F xis ~ xi
  458. -- Always the result of using a top-level family axiom F xis ~ tau
  459. -- No Deriveds
  460. -- Not necessarily fully rewritten (by type substitutions)
  461. , inert_solved_dicts :: PredMap CtEvidence
  462. -- Of form ev :: C t1 .. tn
  463. -- Always the result of using a top-level instance declaration
  464. -- See Note [Solved constraints]
  465. -- - Used to avoid creating a new EvVar when we have a new goal
  466. -- that we have solved in the past
  467. -- - Stored not necessarily as fully rewritten
  468. -- (ToDo: rewrite lazily when we lookup)
  469. }
  470. instance Outputable InertCans where
  471. ppr ics = vcat [ ptext (sLit "Equalities:")
  472. <+> vcat (map ppr (varEnvElts (inert_eqs ics)))
  473. , ptext (sLit "Type-function equalities:")
  474. <+> vcat (map ppr (Bag.bagToList $
  475. ctTypeMapCts (unFamHeadMap $ inert_funeqs ics)))
  476. , ptext (sLit "Dictionaries:")
  477. <+> vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_dicts ics)))
  478. , ptext (sLit "Irreds:")
  479. <+> vcat (map ppr (Bag.bagToList $ inert_irreds ics))
  480. , text "Insolubles =" <+> -- Clearly print frozen errors
  481. braces (vcat (map ppr (Bag.bagToList $ inert_insols ics)))
  482. ]
  483. instance Outputable InertSet where
  484. ppr is = vcat [ ppr $ inert_cans is
  485. , text "Solved dicts" <+> int (sizePredMap (inert_solved_dicts is))
  486. , text "Solved funeqs" <+> int (sizeFamHeadMap (inert_solved_funeqs is))]
  487. emptyInert :: InertSet
  488. emptyInert
  489. = IS { inert_cans = IC { inert_eqs = emptyVarEnv
  490. , inert_dicts = emptyCCanMap
  491. , inert_funeqs = emptyFamHeadMap
  492. , inert_irreds = emptyCts
  493. , inert_insols = emptyCts }
  494. , inert_fsks = []
  495. , inert_flat_cache = emptyFamHeadMap
  496. , inert_solved_dicts = PredMap emptyTM
  497. , inert_solved_funeqs = emptyFamHeadMap }
  498. insertInertItem :: Ct -> InertSet -> InertSet
  499. -- Add a new inert element to the inert set.
  500. insertInertItem item is
  501. = -- A canonical Given, Wanted, or Derived
  502. is { inert_cans = upd_inert_cans (inert_cans is) item }
  503. where upd_inert_cans :: InertCans -> Ct -> InertCans
  504. -- Precondition: item /is/ canonical
  505. upd_inert_cans ics item
  506. | isCTyEqCan item
  507. = let upd_err a b = pprPanic "insertInertItem" $
  508. vcat [ text "Multiple inert equalities:"
  509. , text "Old (already inert):" <+> ppr a
  510. , text "Trying to insert :" <+> ppr b ]
  511. eqs' = extendVarEnv_C upd_err (inert_eqs ics)
  512. (cc_tyvar item) item
  513. in ics { inert_eqs = eqs' }
  514. | isCIrredEvCan item -- Presently-irreducible evidence
  515. = ics { inert_irreds = inert_irreds ics `Bag.snocBag` item }
  516. | Just cls <- isCDictCan_Maybe item -- Dictionary
  517. = ics { inert_dicts = updCCanMap (cls,item) (inert_dicts ics) }
  518. | Just _tc <- isCFunEqCan_Maybe item -- Function equality
  519. = let fam_head = mkTyConApp (cc_fun item) (cc_tyargs item)
  520. upd_funeqs Nothing = Just item
  521. upd_funeqs (Just _already_there)
  522. = panic "insertInertItem: item already there!"
  523. in ics { inert_funeqs = FamHeadMap
  524. (alterTM fam_head upd_funeqs $
  525. (unFamHeadMap $ inert_funeqs ics)) }
  526. | otherwise
  527. = pprPanic "upd_inert set: can't happen! Inserting " $
  528. ppr item -- Can't be CNonCanonical, CHoleCan,
  529. -- because they only land in inert_insols
  530. insertInertItemTcS :: Ct -> TcS ()
  531. -- Add a new item in the inerts of the monad
  532. insertInertItemTcS item
  533. = do { traceTcS "insertInertItemTcS {" $
  534. text "Trying to insert new inert item:" <+> ppr item
  535. ; updInertTcS (insertInertItem item)
  536. ; traceTcS "insertInertItemTcS }" $ empty }
  537. addSolvedDict :: CtEvidence -> TcS ()
  538. -- Add a new item in the solved set of the monad
  539. addSolvedDict item
  540. | isIPPred (ctEvPred item) -- Never cache "solved" implicit parameters (not sure why!)
  541. = return ()
  542. | otherwise
  543. = do { traceTcS "updSolvedSetTcs:" $ ppr item
  544. ; updInertTcS upd_solved_dicts }
  545. where
  546. upd_solved_dicts is
  547. = is { inert_solved_dicts = PredMap $ alterTM pred upd_solved $
  548. unPredMap $ inert_solved_dicts is }
  549. pred = ctEvPred item
  550. upd_solved _ = Just item
  551. addSolvedFunEq :: TcType -> CtEvidence -> TcType -> TcS ()
  552. addSolvedFunEq fam_ty ev rhs_ty
  553. = updInertTcS $ \ inert ->
  554. inert { inert_solved_funeqs = insertFamHead (inert_solved_funeqs inert)
  555. fam_ty (ev, rhs_ty) }
  556. modifyInertTcS :: (InertSet -> (a,InertSet)) -> TcS a
  557. -- Modify the inert set with the supplied function
  558. modifyInertTcS upd
  559. = do { is_var <- getTcSInertsRef
  560. ; curr_inert <- wrapTcS (TcM.readTcRef is_var)
  561. ; let (a, new_inert) = upd curr_inert
  562. ; wrapTcS (TcM.writeTcRef is_var new_inert)
  563. ; return a }
  564. updInertTcS :: (InertSet -> InertSet) -> TcS ()
  565. -- Modify the inert set with the supplied function
  566. updInertTcS upd
  567. = do { is_var <- getTcSInertsRef
  568. ; curr_inert <- wrapTcS (TcM.readTcRef is_var)
  569. ; let new_inert = upd curr_inert
  570. ; wrapTcS (TcM.writeTcRef is_var new_inert) }
  571. prepareInertsForImplications :: InertSet -> InertSet
  572. -- See Note [Preparing inert set for implications]
  573. prepareInertsForImplications is
  574. = is { inert_cans = getGivens (inert_cans is)
  575. , inert_fsks = []
  576. , inert_flat_cache = emptyFamHeadMap }
  577. where
  578. getGivens (IC { inert_eqs = eqs
  579. , inert_irreds = irreds
  580. , inert_funeqs = FamHeadMap funeqs
  581. , inert_dicts = dicts })
  582. = IC { inert_eqs = filterVarEnv_Directly (\_ ct -> isGivenCt ct) eqs
  583. , inert_funeqs = FamHeadMap (mapTM given_from_wanted funeqs)
  584. , inert_irreds = Bag.filterBag isGivenCt irreds
  585. , inert_dicts = keepGivenCMap dicts
  586. , inert_insols = emptyCts }
  587. given_from_wanted funeq -- This is where the magic processing happens
  588. | isGiven ev = funeq -- for type-function equalities
  589. -- See Note [Preparing inert set for implications]
  590. | otherwise = funeq { cc_ev = given_ev }
  591. where
  592. ev = ctEvidence funeq
  593. given_ev = CtGiven { ctev_evtm = EvId (ctev_evar ev)
  594. , ctev_pred = ctev_pred ev }
  595. \end{code}
  596. Note [Preparing inert set for implications]
  597. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  598. Before solving the nested implications, we trim the inert set,
  599. retaining only Givens. These givens can be used when solving
  600. the inner implications.
  601. With one wrinkle! We take all *wanted* *funeqs*, and turn them into givens.
  602. Consider (Trac #4935)
  603. type instance F True a b = a
  604. type instance F False a b = b
  605. [w] F c a b ~ gamma
  606. (c ~ True) => a ~ gamma
  607. (c ~ False) => b ~ gamma
  608. Obviously this is soluble with gamma := F c a b. But
  609. Since solveCTyFunEqs happens at the very end of solving, the only way
  610. to solve the two implications is temporarily consider (F c a b ~ gamma)
  611. as Given and push it inside the implications. Now, when we come
  612. out again at the end, having solved the implications solveCTyFunEqs
  613. will solve this equality.
  614. Turning type-function equalities into Givens is easy becase they
  615. *stay inert*. No need to re-process them.
  616. We don't try to turn any *other* Wanteds into Givens:
  617. * For example, we should not push given dictionaries in because
  618. of example LongWayOverlapping.hs, where we might get strange
  619. overlap errors between far-away constraints in the program.
  620. There might be cases where interactions between wanteds can help
  621. to solve a constraint. For example
  622. class C a b | a -> b
  623. (C Int alpha), (forall d. C d blah => C Int a)
  624. If we push the (C Int alpha) inwards, as a given, it can produce a
  625. fundep (alpha~a) and this can float out again and be used to fix
  626. alpha. (In general we can't float class constraints out just in case
  627. (C d blah) might help to solve (C Int a).) But we ignore this possiblity.
  628. \begin{code}
  629. getInertEqs :: TcS (TyVarEnv Ct)
  630. getInertEqs = do { inert <- getTcSInerts
  631. ; return (inert_eqs (inert_cans inert)) }
  632. getInertUnsolved :: TcS (Cts, Cts)
  633. -- Return (unsolved-wanteds, insolubles)
  634. -- Both consist of a mixture of Wanted and Derived
  635. getInertUnsolved
  636. = do { is <- getTcSInerts
  637. ; let icans = inert_cans is
  638. unsolved_irreds = Bag.filterBag is_unsolved (inert_irreds icans)
  639. unsolved_dicts = extractUnsolvedCMap (inert_dicts icans)
  640. (unsolved_funeqs,_) = partCtFamHeadMap is_unsolved (inert_funeqs icans)
  641. unsolved_eqs = foldVarEnv add_if_unsolved emptyCts (inert_eqs icans)
  642. unsolved_flats = unsolved_eqs `unionBags` unsolved_irreds `unionBags`
  643. unsolved_dicts `unionBags` unsolved_funeqs
  644. ; return (unsolved_flats, inert_insols icans) }
  645. where
  646. add_if_unsolved ct cts
  647. | is_unsolved ct = cts `extendCts` ct
  648. | otherwise = cts
  649. is_unsolved ct = not (isGivenCt ct) -- Wanted or Derived
  650. checkAllSolved :: TcS Bool
  651. -- True if there are no unsolved wanteds
  652. -- Ignore Derived for this purpose, unless in insolubles
  653. checkAllSolved
  654. = do { is <- getTcSInerts
  655. ; let icans = inert_cans is
  656. unsolved_irreds = Bag.anyBag isWantedCt (inert_irreds icans)
  657. unsolved_dicts = not (isNullUFM (cts_wanted (inert_dicts icans)))
  658. unsolved_funeqs = anyFamHeadMap isWantedCt (inert_funeqs icans)
  659. unsolved_eqs = foldVarEnv ((||) . isWantedCt) False (inert_eqs icans)
  660. ; return (not (unsolved_eqs || unsolved_irreds
  661. || unsolved_dicts || unsolved_funeqs
  662. || not (isEmptyBag (inert_insols icans)))) }
  663. extractRelevantInerts :: Ct -> TcS Cts
  664. -- Returns the constraints from the inert set that are 'relevant' to react with
  665. -- this constraint. The monad is left with the 'thinner' inerts.
  666. -- NB: This function contains logic specific to the constraint solver, maybe move there?
  667. extractRelevantInerts wi
  668. = modifyInertTcS (extract_relevants wi)
  669. where
  670. extract_relevants :: Ct -> InertSet -> (Cts,InertSet)
  671. extract_relevants wi is
  672. = let (cts,ics') = extract_ics_relevants wi (inert_cans is)
  673. in (cts, is { inert_cans = ics' })
  674. extract_ics_relevants :: Ct -> InertCans -> (Cts, InertCans)
  675. extract_ics_relevants (CDictCan {cc_class = cl}) ics =
  676. let (cts,dict_map) = getRelevantCts cl (inert_dicts ics)
  677. in (cts, ics { inert_dicts = dict_map })
  678. extract_ics_relevants ct@(CFunEqCan {}) ics@(IC { inert_funeqs = funeq_map })
  679. | Just ct <- lookupFamHead funeq_map fam_head
  680. = (singleCt ct, ics { inert_funeqs = delFamHead funeq_map fam_head })
  681. | otherwise
  682. = (emptyCts, ics)
  683. where
  684. fam_head = mkTyConApp (cc_fun ct) (cc_tyargs ct)
  685. extract_ics_relevants (CHoleCan {}) ics
  686. = pprPanic "extractRelevantInerts" (ppr wi)
  687. -- Holes are put straight into inert_frozen, so never get here
  688. extract_ics_relevants (CIrredEvCan { }) ics =
  689. let cts = inert_irreds ics
  690. in (cts, ics { inert_irreds = emptyCts })
  691. extract_ics_relevants _ ics = (emptyCts,ics)
  692. lookupFlatEqn :: TcType -> TcS (Maybe (CtEvidence, TcType))
  693. lookupFlatEqn fam_ty
  694. = do { IS { inert_solved_funeqs = solved_funeqs
  695. , inert_flat_cache = flat_cache
  696. , inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts
  697. ; return (lookupFamHead solved_funeqs fam_ty `firstJust`
  698. lookup_in_inerts inert_funeqs `firstJust`
  699. lookupFamHead flat_cache fam_ty) }
  700. where
  701. lookup_in_inerts inert_funeqs
  702. = case lookupFamHead inert_funeqs fam_ty of
  703. Nothing -> Nothing
  704. Just ct -> Just (ctEvidence ct, cc_rhs ct)
  705. lookupInInerts :: TcPredType -> TcS (Maybe CtEvidence)
  706. -- Is this exact predicate type cached in the solved or canonicals of the InertSet
  707. lookupInInerts pty
  708. = do { inerts <- getTcSInerts
  709. ; case lookupSolvedDict inerts pty of
  710. Just ctev -> return (Just ctev)
  711. Nothing -> return (lookupInInertCans inerts pty) }
  712. lookupSolvedDict :: InertSet -> TcPredType -> Maybe CtEvidence
  713. -- Returns just if exactly this predicate type exists in the solved.
  714. lookupSolvedDict (IS { inert_solved_dicts = solved }) pty
  715. = lookupTM pty (unPredMap solved)
  716. lookupInInertCans :: InertSet -> TcPredType -> Maybe CtEvidence
  717. -- Returns Just if exactly this pred type exists in the inert canonicals
  718. lookupInInertCans (IS { inert_cans = ics }) pty
  719. = case (classifyPredType pty) of
  720. ClassPred cls _
  721. -> lookupCCanMap cls (\ct -> ctEvPred ct `eqType` pty) (inert_dicts ics)
  722. EqPred ty1 _ty2
  723. | Just tv <- getTyVar_maybe ty1 -- Tyvar equation
  724. , Just ct <- lookupVarEnv (inert_eqs ics) tv
  725. , let ctev = ctEvidence ct
  726. , ctEvPred ctev `eqType` pty
  727. -> Just ctev
  728. | Just _ <- splitTyConApp_maybe ty1 -- Family equation
  729. , Just ct <- lookupTM ty1 (unFamHeadMap $ inert_funeqs ics)
  730. , let ctev = ctEvidence ct
  731. , ctEvPred ctev `eqType` pty
  732. -> Just ctev
  733. IrredPred {} -> findEvidence (\ct -> ctEvPred ct `eqType` pty) (inert_irreds ics)
  734. _other -> Nothing -- NB: No caching for IPs or holes
  735. \end{code}
  736. %************************************************************************
  737. %* *
  738. %* The TcS solver monad *
  739. %* *
  740. %************************************************************************
  741. Note [The TcS monad]
  742. ~~~~~~~~~~~~~~~~~~~~
  743. The TcS monad is a weak form of the main Tc monad
  744. All you can do is
  745. * fail
  746. * allocate new variables
  747. * fill in evidence variables
  748. Filling in a dictionary evidence variable means to create a binding
  749. for it, so TcS carries a mutable location where the binding can be
  750. added. This is initialised from the innermost implication constraint.
  751. \begin{code}
  752. data TcSEnv
  753. = TcSEnv {
  754. tcs_ev_binds :: EvBindsVar,
  755. tcs_ty_binds :: IORef (TyVarEnv (TcTyVar, TcType)),
  756. -- Global type bindings
  757. tcs_count :: IORef Int, -- Global step count
  758. tcs_inerts :: IORef InertSet, -- Current inert set
  759. tcs_worklist :: IORef WorkList, -- Current worklist
  760. -- Residual implication constraints that are generated
  761. -- while solving or canonicalising the current worklist.
  762. -- Specifically, when canonicalising (forall a. t1 ~ forall a. t2)
  763. -- from which we get the implication (forall a. t1 ~ t2)
  764. tcs_implics :: IORef (Bag Implication)
  765. }
  766. \end{code}
  767. \begin{code}
  768. ---------------
  769. newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a }
  770. instance Functor TcS where
  771. fmap f m = TcS $ fmap f . unTcS m
  772. instance Monad TcS where
  773. return x = TcS (\_ -> return x)
  774. fail err = TcS (\_ -> fail err)
  775. m >>= k = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs)
  776. -- Basic functionality
  777. -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  778. wrapTcS :: TcM a -> TcS a
  779. -- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS,
  780. -- and TcS is supposed to have limited functionality
  781. wrapTcS = TcS . const -- a TcM action will not use the TcEvBinds
  782. wrapErrTcS :: TcM a -> TcS a
  783. -- The thing wrapped should just fail
  784. -- There's no static check; it's up to the user
  785. -- Having a variant for each error message is too painful
  786. wrapErrTcS = wrapTcS
  787. wrapWarnTcS :: TcM a -> TcS a
  788. -- The thing wrapped should just add a warning, or no-op
  789. -- There's no static check; it's up to the user
  790. wrapWarnTcS = wrapTcS
  791. failTcS, panicTcS :: SDoc -> TcS a
  792. failTcS = wrapTcS . TcM.failWith
  793. panicTcS doc = pprPanic "TcCanonical" doc
  794. traceTcS :: String -> SDoc -> TcS ()
  795. traceTcS herald doc = wrapTcS (TcM.traceTc herald doc)
  796. instance HasDynFlags TcS where
  797. getDynFlags = wrapTcS getDynFlags
  798. bumpStepCountTcS :: TcS ()
  799. bumpStepCountTcS = TcS $ \env -> do { let ref = tcs_count env
  800. ; n <- TcM.readTcRef ref
  801. ; TcM.writeTcRef ref (n+1) }
  802. traceFireTcS :: Ct -> SDoc -> TcS ()
  803. -- Dump a rule-firing trace
  804. traceFireTcS ct doc
  805. = TcS $ \env ->
  806. TcM.whenDOptM Opt_D_dump_cs_trace $
  807. do { n <- TcM.readTcRef (tcs_count env)
  808. ; let msg = int n <> brackets (int (ctLocDepth (cc_loc ct))) <+> doc
  809. ; TcM.dumpTcRn msg }
  810. runTcS :: TcS a -- What to run
  811. -> TcM (a, Bag EvBind)
  812. runTcS tcs
  813. = do { ev_binds_var <- TcM.newTcEvBinds
  814. ; res <- runTcSWithEvBinds ev_binds_var tcs
  815. ; ev_binds <- TcM.getTcEvBinds ev_binds_var
  816. ; return (res, ev_binds) }
  817. runTcSWithEvBinds :: EvBindsVar
  818. -> TcS a
  819. -> TcM a
  820. runTcSWithEvBinds ev_binds_var tcs
  821. = do { ty_binds_var <- TcM.newTcRef emptyVarEnv
  822. ; step_count <- TcM.newTcRef 0
  823. ; inert_var <- TcM.newTcRef is
  824. ; let env = TcSEnv { tcs_ev_binds = ev_binds_var
  825. , tcs_ty_binds = ty_binds_var
  826. , tcs_count = step_count
  827. , tcs_inerts = inert_var
  828. , tcs_worklist = panic "runTcS: worklist"
  829. , tcs_implics = panic "runTcS: implics" }
  830. -- NB: Both these are initialised by withWorkList
  831. -- Run the computation
  832. ; res <- unTcS tcs env
  833. -- Perform the type unifications required
  834. ; ty_binds <- TcM.readTcRef ty_binds_var
  835. ; mapM_ do_unification (varEnvElts ty_binds)
  836. #ifdef DEBUG
  837. ; count <- TcM.readTcRef step_count
  838. ; when (opt_PprStyle_Debug && count > 0) $
  839. TcM.debugDumpTcRn (ptext (sLit "Constraint solver steps =") <+> int count )
  840. ; ev_binds <- TcM.getTcEvBinds ev_binds_var
  841. ; checkForCyclicBinds ev_binds
  842. #endif
  843. ; return res }
  844. where
  845. do_unification (tv,ty) = TcM.writeMetaTyVar tv ty
  846. is = emptyInert
  847. #ifdef DEBUG
  848. checkForCyclicBinds :: Bag EvBind -> TcM ()
  849. checkForCyclicBinds ev_binds
  850. | null cycles
  851. = return ()
  852. | null coercion_cycles
  853. = TcM.traceTc "Cycle in evidence binds" $ ppr cycles
  854. | otherwise
  855. = pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles
  856. where
  857. cycles :: [[EvBind]]
  858. cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVertices edges]
  859. coercion_cycles = [c | c <- cycles, any is_co_bind c]
  860. is_co_bind (EvBind b _) = isEqVar b
  861. edges :: [(EvBind, EvVar, [EvVar])]
  862. edges = [(bind, bndr, varSetElems (evVarsOfTerm rhs)) | bind@(EvBind bndr rhs) <- bagToList ev_binds]
  863. #endif
  864. nestImplicTcS :: EvBindsVar -> Untouchables -> InertSet -> TcS a -> TcS a
  865. nestImplicTcS ref inner_untch inerts (TcS thing_inside)
  866. = TcS $ \ TcSEnv { tcs_ty_binds = ty_binds
  867. , tcs_count = count } ->
  868. do { new_inert_var <- TcM.newTcRef inerts
  869. ; let nest_env = TcSEnv { tcs_ev_binds = ref
  870. , tcs_ty_binds = ty_binds
  871. , tcs_count = count
  872. , tcs_inerts = new_inert_var
  873. , tcs_worklist = panic "nextImplicTcS: worklist"
  874. , tcs_implics = panic "nextImplicTcS: implics"
  875. -- NB: Both these are initialised by withWorkList
  876. }
  877. ; res <- TcM.setUntouchables inner_untch $
  878. thing_inside nest_env
  879. #ifdef DEBUG
  880. -- Perform a check that the thing_inside did not cause cycles
  881. ; ev_binds <- TcM.getTcEvBinds ref
  882. ; checkForCyclicBinds ev_binds
  883. #endif
  884. ; return res }
  885. recoverTcS :: TcS a -> TcS a -> TcS a
  886. recoverTcS (TcS recovery_code) (TcS thing_inside)
  887. = TcS $ \ env ->
  888. TcM.recoverM (recovery_code env) (thing_inside env)
  889. nestTcS :: TcS a -> TcS a
  890. -- Use the current untouchables, augmenting the current
  891. -- evidence bindings, ty_binds, and solved caches
  892. -- But have no effect on the InertCans or insolubles
  893. nestTcS (TcS thing_inside)
  894. = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) ->
  895. do { inerts <- TcM.readTcRef inerts_var
  896. ; new_inert_var <- TcM.newTcRef inerts
  897. ; let nest_env = env { tcs_inerts = new_inert_var
  898. , tcs_worklist = panic "nextImplicTcS: worklist"
  899. , tcs_implics = panic "nextImplicTcS: implics" }
  900. ; thing_inside nest_env }
  901. tryTcS :: TcS a -> TcS a
  902. -- Like runTcS, but from within the TcS monad
  903. -- Completely afresh inerts and worklist, be careful!
  904. -- Moreover, we will simply throw away all the evidence generated.
  905. tryTcS (TcS thing_inside)
  906. = TcS $ \env ->
  907. do { is_var <- TcM.newTcRef emptyInert
  908. ; ty_binds_var <- TcM.newTcRef emptyVarEnv
  909. ; ev_binds_var <- TcM.newTcEvBinds
  910. ; let nest_env = env { tcs_ev_binds = ev_binds_var
  911. , tcs_ty_binds = ty_binds_var
  912. , tcs_inerts = is_var
  913. , tcs_worklist = panic "nextImplicTcS: worklist"
  914. , tcs_implics = panic "nextImplicTcS: implics" }
  915. ; thing_inside nest_env }
  916. -- Getters and setters of TcEnv fields
  917. -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  918. -- Getter of inerts and worklist
  919. getTcSInertsRef :: TcS (IORef InertSet)
  920. getTcSInertsRef = TcS (return . tcs_inerts)
  921. getTcSWorkListRef :: TcS (IORef WorkList)
  922. getTcSWorkListRef = TcS (return . tcs_worklist)
  923. getTcSInerts :: TcS InertSet
  924. getTcSInerts = getTcSInertsRef >>= wrapTcS . (TcM.readTcRef)
  925. updWorkListTcS :: (WorkList -> WorkList) -> TcS ()
  926. updWorkListTcS f
  927. = do { wl_var <- getTcSWorkListRef
  928. ; wl_curr <- wrapTcS (TcM.readTcRef wl_var)
  929. ; let new_work = f wl_curr
  930. ; wrapTcS (TcM.writeTcRef wl_var new_work) }
  931. updWorkListTcS_return :: (WorkList -> (a,WorkList)) -> TcS a
  932. -- Process the work list, returning a depleted work list,
  933. -- plus a value extracted from it (typically a work item removed from it)
  934. updWorkListTcS_return f
  935. = do { wl_var <- getTcSWorkListRef
  936. ; wl_curr <- wrapTcS (TcM.readTcRef wl_var)
  937. ; let (res,new_work) = f wl_curr
  938. ; wrapTcS (TcM.writeTcRef wl_var new_work)
  939. ; return res }
  940. withWorkList :: Cts -> TcS () -> TcS (Bag Implication)
  941. -- Use 'thing_inside' to solve 'work_items', extending the
  942. -- ambient InertSet, and returning any residual implications
  943. -- (arising from polytype equalities)
  944. -- We do this with fresh work list and residual-implications variables
  945. withWorkList work_items (TcS thing_inside)
  946. = TcS $ \ tcs_env ->
  947. do { let init_work_list = foldrBag extendWorkListCt emptyWorkList work_items
  948. ; new_wl_var <- TcM.newTcRef init_work_list
  949. ; new_implics_var <- TcM.newTcRef emptyBag
  950. ; thing_inside (tcs_env { tcs_worklist = new_wl_var
  951. , tcs_implics = new_implics_var })
  952. ; final_wl <- TcM.readTcRef new_wl_var
  953. ; implics <- TcM.readTcRef new_implics_var
  954. ; ASSERT( isEmptyWorkList final_wl )
  955. return implics }
  956. updTcSImplics :: (Bag Implication -> Bag Implication) -> TcS ()
  957. updTcSImplics f
  958. = do { impl_ref <- getTcSImplicsRef
  959. ; wrapTcS $ do { implics <- TcM.readTcRef impl_ref
  960. ; TcM.writeTcRef impl_ref (f implics) } }
  961. emitInsoluble :: Ct -> TcS ()
  962. -- Emits a non-canonical constraint that will stand for a frozen error in the inerts.
  963. emitInsoluble ct
  964. = do { traceTcS "Emit insoluble" (ppr ct)
  965. ; updInertTcS add_insol }
  966. where
  967. this_pred = ctPred ct
  968. add_insol is@(IS { inert_cans = ics@(IC { inert_insols = old_insols }) })
  969. | already_there = is
  970. | otherwise = is { inert_cans = ics { inert_insols = extendCts old_insols ct } }
  971. where
  972. already_there = not (isWantedCt ct) && anyBag (eqType this_pred . ctPred) old_insols
  973. -- See Note [Do not add duplicate derived insolubles]
  974. getTcSImplicsRef :: TcS (IORef (Bag Implication))
  975. getTcSImplicsRef = TcS (return . tcs_implics)
  976. getTcEvBinds :: TcS EvBindsVar
  977. getTcEvBinds = TcS (return . tcs_ev_binds)
  978. getUntouchables :: TcS Untouchables
  979. getUntouchables = wrapTcS TcM.getUntouchables
  980. getFlattenSkols :: TcS [TcTyVar]
  981. getFlattenSkols = do { is <- getTcSInerts; return (inert_fsks is) }
  982. getTcSTyBinds :: TcS (IORef (TyVarEnv (TcTyVar, TcType)))
  983. getTcSTyBinds = TcS (return . tcs_ty_binds)
  984. getTcSTyBindsMap :: TcS (TyVarEnv (TcTyVar, TcType))
  985. getTcSTyBindsMap = getTcSTyBinds >>= wrapTcS . (TcM.readTcRef)
  986. getTcEvBindsMap :: TcS EvBindMap
  987. getTcEvBindsMap
  988. = do { EvBindsVar ev_ref _ <- getTcEvBinds
  989. ; wrapTcS $ TcM.readTcRef ev_ref }
  990. setWantedTyBind :: TcTyVar -> TcType -> TcS ()
  991. -- Add a type binding
  992. -- We never do this twice!
  993. setWantedTyBind tv ty
  994. = ASSERT2( isMetaTyVar tv, ppr tv )
  995. do { ref <- getTcSTyBinds
  996. ; wrapTcS $
  997. do { ty_binds <- TcM.readTcRef ref
  998. ; when debugIsOn $
  999. TcM.checkErr (not (tv `elemVarEnv` ty_binds)) $
  1000. vcat [ text "TERRIBLE ERROR: double set of meta type variable"
  1001. , ppr tv <+> text ":=" <+> ppr ty
  1002. , text "Old value =" <+> ppr (lookupVarEnv_NF ty_binds tv)]
  1003. ; TcM.traceTc "setWantedTyBind" (ppr tv <+> text ":=" <+> ppr ty)
  1004. ; TcM.writeTcRef ref (extendVarEnv ty_binds tv (tv,ty)) } }
  1005. \end{code}
  1006. \begin{code}
  1007. getDefaultInfo :: TcS ([Type], (Bool, Bool))
  1008. getDefaultInfo = wrapTcS TcM.tcGetDefaultTys
  1009. -- Just get some environments needed for instance looking up and matching
  1010. -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  1011. getInstEnvs :: TcS (InstEnv, InstEnv)
  1012. getInstEnvs = wrapTcS $ Inst.tcGetInstEnvs
  1013. getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv)
  1014. getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs
  1015. getTopEnv :: TcS HscEnv
  1016. getTopEnv = wrapTcS $ TcM.getTopEnv
  1017. getGblEnv :: TcS TcGblEnv
  1018. getGblEnv = wrapTcS $ TcM.getGblEnv
  1019. -- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]
  1020. -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  1021. checkWellStagedDFun :: PredType -> DFunId -> CtLoc -> TcS ()
  1022. checkWellStagedDFun pred dfun_id loc
  1023. = wrapTcS $ TcM.setCtLoc loc $
  1024. do { use_stage <- TcM.getStage
  1025. ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }
  1026. where
  1027. pp_thing = ptext (sLit "instance for") <+> quotes (ppr pred)
  1028. bind_lvl = TcM.topIdLvl dfun_id
  1029. pprEq :: TcType -> TcType -> SDoc
  1030. pprEq ty1 ty2 = pprType $ mkEqPred ty1 ty2
  1031. isTouchableMetaTyVarTcS :: TcTyVar -> TcS Bool
  1032. isTouchableMetaTyVarTcS tv
  1033. = do { untch <- getUntouchables
  1034. ; return $ isTouchableMetaTyVar untch tv }
  1035. isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type)
  1036. isFilledMetaTyVar_maybe tv
  1037. = ASSERT2( is

Large files files are truncated, but you can click here to view the full file