PageRenderTime 73ms CodeModel.GetById 34ms RepoModel.GetById 1ms app.codeStats 0ms

/compiler/typecheck/TcSMonad.lhs

https://bitbucket.org/khibino/ghc-hack
Haskell | 1572 lines | 1063 code | 311 blank | 198 comment | 22 complexity | c25f26581881e16c19524b0c7a478685 MD5 | raw file
Possible License(s): BSD-3-Clause, BSD-2-Clause, LGPL-3.0

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

  1. \begin{code}
  2. {-# OPTIONS -fno-warn-tabs #-}
  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, extendWorkListNonEq, extendWorkListCt,
  14. appendWorkListCt, appendWorkListEqs, unionWorkList, selectWorkItem,
  15. getTcSWorkList, updWorkListTcS, updWorkListTcS_return, keepWanted,
  16. Ct(..), Xi, tyVarsOfCt, tyVarsOfCts, tyVarsOfCDicts,
  17. emitFrozenError,
  18. isWanted, isGivenOrSolved, isDerived,
  19. isGivenOrSolvedCt, isGivenCt_maybe,
  20. isWantedCt, isDerivedCt, pprFlavorArising,
  21. isFlexiTcsTv,
  22. canRewrite, canSolve,
  23. combineCtLoc, mkSolvedFlavor, mkGivenFlavor,
  24. mkWantedFlavor,
  25. getWantedLoc,
  26. TcS, runTcS, failTcS, panicTcS, traceTcS, -- Basic functionality
  27. traceFireTcS, bumpStepCountTcS, doWithInert,
  28. tryTcS, nestImplicTcS, recoverTcS,
  29. wrapErrTcS, wrapWarnTcS,
  30. SimplContext(..), isInteractive, simplEqsOnly, performDefaulting,
  31. -- Creation of evidence variables
  32. newEvVar, forceNewEvVar, delCachedEvVar, updateFlatCache, flushFlatCache,
  33. newGivenEqVar,
  34. newEqVar, newKindConstraint,
  35. EvVarCreated (..), isNewEvVar, FlatEqOrigin ( .. ), origin_matches,
  36. -- Setting evidence variables
  37. setEqBind,
  38. setEvBind,
  39. setWantedTyBind,
  40. getInstEnvs, getFamInstEnvs, -- Getting the environments
  41. getTopEnv, getGblEnv, getTcEvBinds, getUntouchables,
  42. getTcEvBindsMap, getTcSContext, getTcSTyBinds, getTcSTyBindsMap,
  43. getTcSEvVarCacheMap, getTcSEvVarFlatCache, setTcSEvVarCacheMap, pprEvVarCache,
  44. newFlattenSkolemTy, -- Flatten skolems
  45. -- Inerts
  46. InertSet(..),
  47. getInertEqs, liftInertEqsTy, getCtCoercion,
  48. emptyInert, getTcSInerts, updInertSet, extractUnsolved,
  49. extractUnsolvedTcS, modifyInertTcS,
  50. updInertSetTcS, partitionCCanMap, partitionEqMap,
  51. getRelevantCts, extractRelevantInerts,
  52. CCanMap (..), CtTypeMap, pprCtTypeMap, mkPredKeyForTypeMap, partitionCtTypeMap,
  53. instDFunTypes, -- Instantiation
  54. instDFunConstraints,
  55. newFlexiTcSTy, instFlexiTcS,
  56. compatKind, compatKindTcS, isSubKindTcS, unifyKindTcS,
  57. TcsUntouchables,
  58. isTouchableMetaTyVar,
  59. isTouchableMetaTyVar_InRange,
  60. getDefaultInfo, getDynFlags,
  61. matchClass, matchFam, MatchInstResult (..),
  62. checkWellStagedDFun,
  63. warnTcS,
  64. pprEq -- Smaller utils, re-exported from TcM
  65. -- TODO (DV): these are only really used in the
  66. -- instance matcher in TcSimplify. I am wondering
  67. -- if the whole instance matcher simply belongs
  68. -- here
  69. ) where
  70. #include "HsVersions.h"
  71. import HscTypes
  72. import BasicTypes
  73. import Inst
  74. import InstEnv
  75. import FamInst
  76. import FamInstEnv
  77. import qualified TcRnMonad as TcM
  78. import qualified TcMType as TcM
  79. import qualified TcEnv as TcM
  80. ( checkWellStaged, topIdLvl, tcGetDefaultTys )
  81. import {-# SOURCE #-} qualified TcUnify as TcM ( unifyKindEq, mkKindErrorCtxt )
  82. import Kind
  83. import TcType
  84. import DynFlags
  85. import Type
  86. import TcEvidence
  87. import Class
  88. import TyCon
  89. import TypeRep
  90. import Name
  91. import Var
  92. import VarEnv
  93. import Outputable
  94. import Bag
  95. import MonadUtils
  96. import VarSet
  97. import FastString
  98. import Util
  99. import Id
  100. import TcRnTypes
  101. import Unique
  102. import UniqFM
  103. import Maybes ( orElse )
  104. import Control.Monad( when )
  105. import StaticFlags( opt_PprStyle_Debug )
  106. import Data.IORef
  107. import TrieMap
  108. \end{code}
  109. \begin{code}
  110. compatKind :: Kind -> Kind -> Bool
  111. compatKind k1 k2 = k1 `isSubKind` k2 || k2 `isSubKind` k1
  112. compatKindTcS :: Kind -> Kind -> TcS Bool
  113. -- Because kind unification happens during constraint solving, we have
  114. -- to make sure that two kinds are zonked before we compare them.
  115. compatKindTcS k1 k2 = wrapTcS (TcM.compatKindTcM k1 k2)
  116. isSubKindTcS :: Kind -> Kind -> TcS Bool
  117. isSubKindTcS k1 k2 = wrapTcS (TcM.isSubKindTcM k1 k2)
  118. unifyKindTcS :: Type -> Type -- Context
  119. -> Kind -> Kind -- Corresponding kinds
  120. -> TcS Bool
  121. unifyKindTcS ty1 ty2 ki1 ki2
  122. = wrapTcS $ TcM.addErrCtxtM ctxt $ do
  123. (_errs, mb_r) <- TcM.tryTc (TcM.unifyKindEq ki1 ki2)
  124. return (maybe False (const True) mb_r)
  125. where ctxt = TcM.mkKindErrorCtxt ty1 ki1 ty2 ki2
  126. \end{code}
  127. %************************************************************************
  128. %* *
  129. %* Worklists *
  130. %* Canonical and non-canonical constraints that the simplifier has to *
  131. %* work on. Including their simplification depths. *
  132. %* *
  133. %* *
  134. %************************************************************************
  135. Note [WorkList]
  136. ~~~~~~~~~~~~~~~
  137. A WorkList contains canonical and non-canonical items (of all flavors).
  138. Notice that each Ct now has a simplification depth. We may
  139. consider using this depth for prioritization as well in the future.
  140. As a simple form of priority queue, our worklist separates out
  141. equalities (wl_eqs) from the rest of the canonical constraints,
  142. so that it's easier to deal with them first, but the separation
  143. is not strictly necessary. Notice that non-canonical constraints
  144. are also parts of the worklist.
  145. Note [NonCanonical Semantics]
  146. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  147. Note that canonical constraints involve a CNonCanonical constructor. In the worklist
  148. we use this constructor for constraints that have not yet been canonicalized such as
  149. [Int] ~ [a]
  150. In other words, all constraints start life as NonCanonicals.
  151. On the other hand, in the Inert Set (see below) the presence of a NonCanonical somewhere
  152. means that we have a ``frozen error''.
  153. NonCanonical constraints never interact directly with other constraints -- but they can
  154. be rewritten by equalities (for instance if a non canonical exists in the inert, we'd
  155. better rewrite it as much as possible before reporting it as an error to the user)
  156. \begin{code}
  157. -- See Note [WorkList]
  158. data WorkList = WorkList { wl_eqs :: [Ct], wl_funeqs :: [Ct], wl_rest :: [Ct] }
  159. unionWorkList :: WorkList -> WorkList -> WorkList
  160. unionWorkList new_wl orig_wl =
  161. WorkList { wl_eqs = wl_eqs new_wl ++ wl_eqs orig_wl
  162. , wl_funeqs = wl_funeqs new_wl ++ wl_funeqs orig_wl
  163. , wl_rest = wl_rest new_wl ++ wl_rest orig_wl }
  164. extendWorkListEq :: Ct -> WorkList -> WorkList
  165. -- Extension by equality
  166. extendWorkListEq ct wl
  167. | Just {} <- isCFunEqCan_Maybe ct
  168. = wl { wl_funeqs = ct : wl_funeqs wl }
  169. | otherwise
  170. = wl { wl_eqs = ct : wl_eqs wl }
  171. extendWorkListNonEq :: Ct -> WorkList -> WorkList
  172. -- Extension by non equality
  173. extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl }
  174. extendWorkListCt :: Ct -> WorkList -> WorkList
  175. -- Agnostic
  176. extendWorkListCt ct wl
  177. | isEqVar (cc_id ct) = extendWorkListEq ct wl
  178. | otherwise = extendWorkListNonEq ct wl
  179. appendWorkListCt :: [Ct] -> WorkList -> WorkList
  180. -- Agnostic
  181. appendWorkListCt cts wl = foldr extendWorkListCt wl cts
  182. appendWorkListEqs :: [Ct] -> WorkList -> WorkList
  183. -- Append a list of equalities
  184. appendWorkListEqs cts wl = foldr extendWorkListEq wl cts
  185. isEmptyWorkList :: WorkList -> Bool
  186. isEmptyWorkList wl
  187. = null (wl_eqs wl) && null (wl_rest wl) && null (wl_funeqs wl)
  188. emptyWorkList :: WorkList
  189. emptyWorkList = WorkList { wl_eqs = [], wl_rest = [], wl_funeqs = []}
  190. workListFromEq :: Ct -> WorkList
  191. workListFromEq ct = extendWorkListEq ct emptyWorkList
  192. workListFromNonEq :: Ct -> WorkList
  193. workListFromNonEq ct = extendWorkListNonEq ct emptyWorkList
  194. workListFromCt :: Ct -> WorkList
  195. -- Agnostic
  196. workListFromCt ct | isEqVar (cc_id ct) = workListFromEq ct
  197. | otherwise = workListFromNonEq ct
  198. selectWorkItem :: WorkList -> (Maybe Ct, WorkList)
  199. selectWorkItem wl@(WorkList { wl_eqs = eqs, wl_funeqs = feqs, wl_rest = rest })
  200. = case (eqs,feqs,rest) of
  201. (ct:cts,_,_) -> (Just ct, wl { wl_eqs = cts })
  202. (_,(ct:cts),_) -> (Just ct, wl { wl_funeqs = cts })
  203. (_,_,(ct:cts)) -> (Just ct, wl { wl_rest = cts })
  204. (_,_,_) -> (Nothing,wl)
  205. -- Pretty printing
  206. instance Outputable WorkList where
  207. ppr wl = vcat [ text "WorkList (eqs) = " <+> ppr (wl_eqs wl)
  208. , text "WorkList (funeqs)= " <+> ppr (wl_funeqs wl)
  209. , text "WorkList (rest) = " <+> ppr (wl_rest wl)
  210. ]
  211. keepWanted :: Cts -> Cts
  212. keepWanted = filterBag isWantedCt
  213. -- DV: there used to be a note here that read:
  214. -- ``Important: use fold*r*Bag to preserve the order of the evidence variables''
  215. -- DV: Is this still relevant?
  216. \end{code}
  217. %************************************************************************
  218. %* *
  219. %* Inert sets *
  220. %* *
  221. %* *
  222. %************************************************************************
  223. Note [InertSet invariants]
  224. ~~~~~~~~~~~~~~~~~~~~~~~~~~~
  225. An InertSet is a bag of canonical constraints, with the following invariants:
  226. 1 No two constraints react with each other.
  227. A tricky case is when there exists a given (solved) dictionary
  228. constraint and a wanted identical constraint in the inert set, but do
  229. not react because reaction would create loopy dictionary evidence for
  230. the wanted. See note [Recursive dictionaries]
  231. 2 Given equalities form an idempotent substitution [none of the
  232. given LHS's occur in any of the given RHS's or reactant parts]
  233. 3 Wanted equalities also form an idempotent substitution
  234. 4 The entire set of equalities is acyclic.
  235. 5 Wanted dictionaries are inert with the top-level axiom set
  236. 6 Equalities of the form tv1 ~ tv2 always have a touchable variable
  237. on the left (if possible).
  238. 7 No wanted constraints tv1 ~ tv2 with tv1 touchable. Such constraints
  239. will be marked as solved right before being pushed into the inert set.
  240. See note [Touchables and givens].
  241. 8 No Given constraint mentions a touchable unification variable, but
  242. Given/Solved may do so.
  243. 9 Given constraints will also have their superclasses in the inert set,
  244. but Given/Solved will not.
  245. Note that 6 and 7 are /not/ enforced by canonicalization but rather by
  246. insertion in the inert list, ie by TcInteract.
  247. During the process of solving, the inert set will contain some
  248. previously given constraints, some wanted constraints, and some given
  249. constraints which have arisen from solving wanted constraints. For
  250. now we do not distinguish between given and solved constraints.
  251. Note that we must switch wanted inert items to given when going under an
  252. implication constraint (when in top-level inference mode).
  253. \begin{code}
  254. data CCanMap a = CCanMap { cts_given :: UniqFM Cts
  255. -- Invariant: all Given
  256. , cts_derived :: UniqFM Cts
  257. -- Invariant: all Derived
  258. , cts_wanted :: UniqFM Cts }
  259. -- Invariant: all Wanted
  260. cCanMapToBag :: CCanMap a -> Cts
  261. cCanMapToBag cmap = foldUFM unionBags rest_wder (cts_given cmap)
  262. where rest_wder = foldUFM unionBags rest_der (cts_wanted cmap)
  263. rest_der = foldUFM unionBags emptyCts (cts_derived cmap)
  264. emptyCCanMap :: CCanMap a
  265. emptyCCanMap = CCanMap { cts_given = emptyUFM, cts_derived = emptyUFM, cts_wanted = emptyUFM }
  266. updCCanMap:: Uniquable a => (a,Ct) -> CCanMap a -> CCanMap a
  267. updCCanMap (a,ct) cmap
  268. = case cc_flavor ct of
  269. Wanted {} -> cmap { cts_wanted = insert_into (cts_wanted cmap) }
  270. Given {} -> cmap { cts_given = insert_into (cts_given cmap) }
  271. Derived {} -> cmap { cts_derived = insert_into (cts_derived cmap) }
  272. where
  273. insert_into m = addToUFM_C unionBags m a (singleCt ct)
  274. getRelevantCts :: Uniquable a => a -> CCanMap a -> (Cts, CCanMap a)
  275. -- Gets the relevant constraints and returns the rest of the CCanMap
  276. getRelevantCts a cmap
  277. = let relevant = lookup (cts_wanted cmap) `unionBags`
  278. lookup (cts_given cmap) `unionBags`
  279. lookup (cts_derived cmap)
  280. residual_map = cmap { cts_wanted = delFromUFM (cts_wanted cmap) a
  281. , cts_given = delFromUFM (cts_given cmap) a
  282. , cts_derived = delFromUFM (cts_derived cmap) a }
  283. in (relevant, residual_map)
  284. where
  285. lookup map = lookupUFM map a `orElse` emptyCts
  286. getCtTypeMapRelevants :: PredType -> TypeMap Ct -> (Cts, TypeMap Ct)
  287. getCtTypeMapRelevants key_pty tmap
  288. = partitionCtTypeMap (\ct -> mkPredKeyForTypeMap ct `eqType` key_pty) tmap
  289. partitionCCanMap :: (Ct -> Bool) -> CCanMap a -> (Cts,CCanMap a)
  290. -- All constraints that /match/ the predicate go in the bag, the rest remain in the map
  291. partitionCCanMap pred cmap
  292. = let (ws_map,ws) = foldUFM_Directly aux (emptyUFM,emptyCts) (cts_wanted cmap)
  293. (ds_map,ds) = foldUFM_Directly aux (emptyUFM,emptyCts) (cts_derived cmap)
  294. (gs_map,gs) = foldUFM_Directly aux (emptyUFM,emptyCts) (cts_given cmap)
  295. in (ws `andCts` ds `andCts` gs, cmap { cts_wanted = ws_map
  296. , cts_given = gs_map
  297. , cts_derived = ds_map })
  298. where aux k this_cts (mp,acc_cts) = (new_mp, new_acc_cts)
  299. where new_mp = addToUFM mp k cts_keep
  300. new_acc_cts = acc_cts `andCts` cts_out
  301. (cts_out, cts_keep) = partitionBag pred this_cts
  302. partitionEqMap :: (Ct -> Bool) -> TyVarEnv (Ct,TcCoercion) -> ([Ct], TyVarEnv (Ct,TcCoercion))
  303. partitionEqMap pred isubst
  304. = let eqs_out = foldVarEnv extend_if_pred [] isubst
  305. eqs_in = filterVarEnv_Directly (\_ (ct,_) -> not (pred ct)) isubst
  306. in (eqs_out, eqs_in)
  307. where extend_if_pred (ct,_) cts = if pred ct then ct : cts else cts
  308. extractUnsolvedCMap :: CCanMap a -> (Cts, CCanMap a)
  309. -- Gets the wanted or derived constraints and returns a residual
  310. -- CCanMap with only givens.
  311. extractUnsolvedCMap cmap =
  312. let wntd = foldUFM unionBags emptyCts (cts_wanted cmap)
  313. derd = foldUFM unionBags emptyCts (cts_derived cmap)
  314. in (wntd `unionBags` derd,
  315. cmap { cts_wanted = emptyUFM, cts_derived = emptyUFM })
  316. -- See Note [InertSet invariants]
  317. data InertSet
  318. = IS { inert_eqs :: TyVarEnv (Ct,TcCoercion)
  319. -- Must all be CTyEqCans! If an entry exists of the form:
  320. -- a |-> ct,co
  321. -- Then ct = CTyEqCan { cc_tyvar = a, cc_rhs = xi }
  322. -- And co : a ~ xi
  323. , inert_eq_tvs :: InScopeSet -- Invariant: superset of inert_eqs tvs
  324. , inert_dicts :: CCanMap Class -- Dictionaries only, index is the class
  325. , inert_ips :: CCanMap (IPName Name) -- Implicit parameters
  326. -- NB: We do not want to use TypeMaps here because functional dependencies
  327. -- will only match on the class but not the type. Similarly IPs match on the
  328. -- name but not on the whole datatype
  329. , inert_funeqs :: CtTypeMap -- Map from family heads to CFunEqCan constraints
  330. , inert_irreds :: Cts -- Irreducible predicates
  331. , inert_frozen :: Cts -- All non-canonicals are kept here (as frozen errors)
  332. }
  333. type CtTypeMap = TypeMap Ct
  334. pprCtTypeMap :: TypeMap Ct -> SDoc
  335. pprCtTypeMap ctmap = ppr (foldTM (:) ctmap [])
  336. ctTypeMapCts :: TypeMap Ct -> Cts
  337. ctTypeMapCts ctmap = foldTM (\ct cts -> extendCts cts ct) ctmap emptyCts
  338. mkPredKeyForTypeMap :: Ct -> PredType
  339. -- Create a key from a constraint to use in the inert CtTypeMap.
  340. -- The only interesting case is for family applications, where the
  341. -- key is not the whole PredType of cc_id, but rather the family
  342. -- equality left hand side (head)
  343. mkPredKeyForTypeMap (CFunEqCan { cc_fun = fn, cc_tyargs = xis })
  344. = mkTyConApp fn xis
  345. mkPredKeyForTypeMap ct
  346. = evVarPred (cc_id ct)
  347. partitionCtTypeMap :: (Ct -> Bool)
  348. -> TypeMap Ct -> (Cts, TypeMap Ct)
  349. -- Kick out the ones that match the predicate and keep the rest in the typemap
  350. partitionCtTypeMap f ctmap
  351. = foldTM upd_acc ctmap (emptyBag,ctmap)
  352. where upd_acc ct (cts,acc_map)
  353. | f ct = (extendCts cts ct, alterTM ct_key (\_ -> Nothing) acc_map)
  354. | otherwise = (cts,acc_map)
  355. where ct_key = mkPredKeyForTypeMap ct
  356. instance Outputable InertSet where
  357. ppr is = vcat [ vcat (map ppr (varEnvElts (inert_eqs is)))
  358. , vcat (map ppr (Bag.bagToList $ inert_irreds is))
  359. , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_dicts is)))
  360. , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_ips is)))
  361. , vcat (map ppr (Bag.bagToList $ ctTypeMapCts (inert_funeqs is)))
  362. , text "Frozen errors =" <+> -- Clearly print frozen errors
  363. braces (vcat (map ppr (Bag.bagToList $ inert_frozen is)))
  364. , text "Warning: Not displaying cached (solved) constraints"
  365. ]
  366. emptyInert :: InertSet
  367. emptyInert = IS { inert_eqs = emptyVarEnv
  368. , inert_eq_tvs = emptyInScopeSet
  369. , inert_frozen = emptyCts
  370. , inert_irreds = emptyCts
  371. , inert_dicts = emptyCCanMap
  372. , inert_ips = emptyCCanMap
  373. , inert_funeqs = emptyTM
  374. }
  375. type AtomicInert = Ct
  376. updInertSet :: InertSet -> AtomicInert -> InertSet
  377. -- Add a new inert element to the inert set.
  378. updInertSet is item
  379. | isCTyEqCan item
  380. = let upd_err a b = pprPanic "updInertSet" $
  381. vcat [ text "Multiple inert equalities:"
  382. , text "Old (already inert):" <+> ppr a
  383. , text "Trying to insert :" <+> ppr b
  384. ]
  385. -- If evidence is cached, pick it up from the flavor!
  386. coercion = getCtCoercion item
  387. eqs' = extendVarEnv_C upd_err (inert_eqs is)
  388. (cc_tyvar item)
  389. (item, coercion)
  390. inscope' = extendInScopeSetSet (inert_eq_tvs is) (tyVarsOfCt item)
  391. in is { inert_eqs = eqs', inert_eq_tvs = inscope' }
  392. | Just x <- isCIPCan_Maybe item -- IP
  393. = is { inert_ips = updCCanMap (x,item) (inert_ips is) }
  394. | isCIrredEvCan item -- Presently-irreducible evidence
  395. = is { inert_irreds = inert_irreds is `Bag.snocBag` item }
  396. | Just cls <- isCDictCan_Maybe item -- Dictionary
  397. = is { inert_dicts = updCCanMap (cls,item) (inert_dicts is) }
  398. | Just _tc <- isCFunEqCan_Maybe item -- Function equality
  399. = let pty = mkPredKeyForTypeMap item
  400. upd_funeqs Nothing = Just item
  401. upd_funeqs (Just _alredy_there) = panic "updInertSet: item already there!"
  402. in is { inert_funeqs = alterTM pty upd_funeqs (inert_funeqs is) }
  403. | otherwise
  404. = is { inert_frozen = inert_frozen is `Bag.snocBag` item }
  405. updInertSetTcS :: AtomicInert -> TcS ()
  406. -- Add a new item in the inerts of the monad
  407. updInertSetTcS item
  408. = do { traceTcS "updInertSetTcs {" $
  409. text "Trying to insert new inert item:" <+> ppr item
  410. ; modifyInertTcS (\is -> ((), updInertSet is item))
  411. ; traceTcS "updInertSetTcs }" $ empty }
  412. modifyInertTcS :: (InertSet -> (a,InertSet)) -> TcS a
  413. -- Modify the inert set with the supplied function
  414. modifyInertTcS upd
  415. = do { is_var <- getTcSInertsRef
  416. ; curr_inert <- wrapTcS (TcM.readTcRef is_var)
  417. ; let (a, new_inert) = upd curr_inert
  418. ; wrapTcS (TcM.writeTcRef is_var new_inert)
  419. ; return a }
  420. extractUnsolvedTcS :: TcS (Cts,Cts)
  421. -- Extracts frozen errors and remaining unsolved and sets the
  422. -- inert set to be the remaining!
  423. extractUnsolvedTcS =
  424. modifyInertTcS extractUnsolved
  425. extractUnsolved :: InertSet -> ((Cts,Cts), InertSet)
  426. -- Postcondition
  427. -- -------------
  428. -- When:
  429. -- ((frozen,cts),is_solved) <- extractUnsolved inert
  430. -- Then:
  431. -- -----------------------------------------------------------------------------
  432. -- cts | The unsolved (Derived or Wanted only) residual
  433. -- | canonical constraints, that is, no CNonCanonicals.
  434. -- -----------|-----------------------------------------------------------------
  435. -- frozen | The CNonCanonicals of the original inert (frozen errors),
  436. -- | of all flavors
  437. -- -----------|-----------------------------------------------------------------
  438. -- is_solved | Whatever remains from the inert after removing the previous two.
  439. -- -----------------------------------------------------------------------------
  440. extractUnsolved is@(IS {inert_eqs = eqs, inert_irreds = irreds})
  441. = let is_solved = is { inert_eqs = solved_eqs
  442. , inert_eq_tvs = inert_eq_tvs is
  443. , inert_dicts = solved_dicts
  444. , inert_ips = solved_ips
  445. , inert_irreds = solved_irreds
  446. , inert_frozen = emptyCts
  447. , inert_funeqs = solved_funeqs
  448. }
  449. in ((inert_frozen is, unsolved), is_solved)
  450. where solved_eqs = filterVarEnv_Directly (\_ (ct,_) -> isGivenOrSolvedCt ct) eqs
  451. unsolved_eqs = foldVarEnv (\(ct,_co) cts -> cts `extendCts` ct) emptyCts $
  452. eqs `minusVarEnv` solved_eqs
  453. (unsolved_irreds, solved_irreds) = Bag.partitionBag (not.isGivenOrSolvedCt) irreds
  454. (unsolved_ips, solved_ips) = extractUnsolvedCMap (inert_ips is)
  455. (unsolved_dicts, solved_dicts) = extractUnsolvedCMap (inert_dicts is)
  456. (unsolved_funeqs, solved_funeqs) = extractUnsolvedCtTypeMap (inert_funeqs is)
  457. unsolved = unsolved_eqs `unionBags` unsolved_irreds `unionBags`
  458. unsolved_ips `unionBags` unsolved_dicts `unionBags` unsolved_funeqs
  459. extractUnsolvedCtTypeMap :: TypeMap Ct -> (Cts,TypeMap Ct)
  460. extractUnsolvedCtTypeMap
  461. = partitionCtTypeMap (not . isGivenOrSolved . cc_flavor)
  462. extractRelevantInerts :: Ct -> TcS Cts
  463. -- Returns the constraints from the inert set that are 'relevant' to react with
  464. -- this constraint. The monad is left with the 'thinner' inerts.
  465. -- NB: This function contains logic specific to the constraint solver, maybe move there?
  466. extractRelevantInerts wi
  467. = modifyInertTcS (extract_inert_relevants wi)
  468. where extract_inert_relevants (CDictCan {cc_class = cl}) is =
  469. let (cts,dict_map) = getRelevantCts cl (inert_dicts is)
  470. in (cts, is { inert_dicts = dict_map })
  471. extract_inert_relevants (CFunEqCan {cc_fun = tc, cc_tyargs = xis}) is =
  472. let (cts,feqs_map) = getCtTypeMapRelevants (mkTyConApp tc xis) (inert_funeqs is)
  473. in (cts, is { inert_funeqs = feqs_map })
  474. extract_inert_relevants (CIPCan { cc_ip_nm = nm } ) is =
  475. let (cts, ips_map) = getRelevantCts nm (inert_ips is)
  476. in (cts, is { inert_ips = ips_map })
  477. extract_inert_relevants (CIrredEvCan { }) is =
  478. let cts = inert_irreds is
  479. in (cts, is { inert_irreds = emptyCts })
  480. extract_inert_relevants _ is = (emptyCts,is)
  481. \end{code}
  482. %************************************************************************
  483. %* *
  484. CtFlavor
  485. The "flavor" of a canonical constraint
  486. %* *
  487. %************************************************************************
  488. \begin{code}
  489. getWantedLoc :: Ct -> WantedLoc
  490. getWantedLoc ct
  491. = ASSERT (isWanted (cc_flavor ct))
  492. case cc_flavor ct of
  493. Wanted wl -> wl
  494. _ -> pprPanic "Can't get WantedLoc of non-wanted constraint!" empty
  495. isWantedCt :: Ct -> Bool
  496. isWantedCt ct = isWanted (cc_flavor ct)
  497. isDerivedCt :: Ct -> Bool
  498. isDerivedCt ct = isDerived (cc_flavor ct)
  499. isGivenCt_maybe :: Ct -> Maybe GivenKind
  500. isGivenCt_maybe ct = isGiven_maybe (cc_flavor ct)
  501. isGivenOrSolvedCt :: Ct -> Bool
  502. isGivenOrSolvedCt ct = isGivenOrSolved (cc_flavor ct)
  503. canSolve :: CtFlavor -> CtFlavor -> Bool
  504. -- canSolve ctid1 ctid2
  505. -- The constraint ctid1 can be used to solve ctid2
  506. -- "to solve" means a reaction where the active parts of the two constraints match.
  507. -- active(F xis ~ xi) = F xis
  508. -- active(tv ~ xi) = tv
  509. -- active(D xis) = D xis
  510. -- active(IP nm ty) = nm
  511. --
  512. -- NB: either (a `canSolve` b) or (b `canSolve` a) must hold
  513. -----------------------------------------
  514. canSolve (Given {}) _ = True
  515. canSolve (Wanted {}) (Derived {}) = True
  516. canSolve (Wanted {}) (Wanted {}) = True
  517. canSolve (Derived {}) (Derived {}) = True -- Important: derived can't solve wanted/given
  518. canSolve _ _ = False -- (There is no *evidence* for a derived.)
  519. canRewrite :: CtFlavor -> CtFlavor -> Bool
  520. -- canRewrite ctid1 ctid2
  521. -- The *equality_constraint* ctid1 can be used to rewrite inside ctid2
  522. canRewrite = canSolve
  523. combineCtLoc :: CtFlavor -> CtFlavor -> WantedLoc
  524. -- Precondition: At least one of them should be wanted
  525. combineCtLoc (Wanted loc) _ = loc
  526. combineCtLoc _ (Wanted loc) = loc
  527. combineCtLoc (Derived loc ) _ = loc
  528. combineCtLoc _ (Derived loc ) = loc
  529. combineCtLoc _ _ = panic "combineCtLoc: both given"
  530. mkSolvedFlavor :: CtFlavor -> SkolemInfo -> EvTerm -> CtFlavor
  531. -- To be called when we actually solve a wanted/derived (perhaps leaving residual goals)
  532. mkSolvedFlavor (Wanted loc) sk evterm = Given (setCtLocOrigin loc sk) (GivenSolved (Just evterm))
  533. mkSolvedFlavor (Derived loc) sk evterm = Given (setCtLocOrigin loc sk) (GivenSolved (Just evterm))
  534. mkSolvedFlavor fl@(Given {}) _sk _evterm = pprPanic "Solving a given constraint!" $ ppr fl
  535. mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
  536. mkGivenFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk) GivenOrig
  537. mkGivenFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk) GivenOrig
  538. mkGivenFlavor fl@(Given {}) _sk = pprPanic "Solving a given constraint!" $ ppr fl
  539. mkWantedFlavor :: CtFlavor -> CtFlavor
  540. mkWantedFlavor (Wanted loc) = Wanted loc
  541. mkWantedFlavor (Derived loc) = Wanted loc
  542. mkWantedFlavor fl@(Given {}) = pprPanic "mkWantedFlavor" (ppr fl)
  543. \end{code}
  544. %************************************************************************
  545. %* *
  546. %* The TcS solver monad *
  547. %* *
  548. %************************************************************************
  549. Note [The TcS monad]
  550. ~~~~~~~~~~~~~~~~~~~~
  551. The TcS monad is a weak form of the main Tc monad
  552. All you can do is
  553. * fail
  554. * allocate new variables
  555. * fill in evidence variables
  556. Filling in a dictionary evidence variable means to create a binding
  557. for it, so TcS carries a mutable location where the binding can be
  558. added. This is initialised from the innermost implication constraint.
  559. \begin{code}
  560. data TcSEnv
  561. = TcSEnv {
  562. tcs_ev_binds :: EvBindsVar,
  563. tcs_evvar_cache :: IORef EvVarCache,
  564. -- Evidence bindings and a cache from predicate types to the created evidence
  565. -- variables. The scope of the cache will be the same as the scope of tcs_ev_binds
  566. tcs_ty_binds :: IORef (TyVarEnv (TcTyVar, TcType)),
  567. -- Global type bindings
  568. tcs_context :: SimplContext,
  569. tcs_untch :: TcsUntouchables,
  570. tcs_ic_depth :: Int, -- Implication nesting depth
  571. tcs_count :: IORef Int, -- Global step count
  572. tcs_inerts :: IORef InertSet, -- Current inert set
  573. tcs_worklist :: IORef WorkList -- Current worklist
  574. -- TcSEnv invariant: the tcs_evvar_cache is a superset of tcs_inerts, tcs_worklist, tcs_ev_binds which must
  575. -- all be disjoint with each other.
  576. }
  577. data EvVarCache
  578. = EvVarCache { evc_cache :: TypeMap (EvVar,CtFlavor)
  579. -- Map from PredTys to Evidence variables
  580. -- used to avoid creating new goals
  581. , evc_flat_cache :: TypeMap (TcCoercion,(Xi,CtFlavor,FlatEqOrigin))
  582. -- Map from family-free heads (F xi) to family-free types.
  583. -- Useful during flattening to share flatten skolem generation
  584. -- The boolean flag:
  585. -- True <-> This equation was generated originally during flattening
  586. -- False <-> This equation was generated by having solved a goal
  587. }
  588. data FlatEqOrigin = WhileFlattening -- Was it generated during flattening?
  589. | WhenSolved -- Was it generated when a family equation was solved?
  590. | Any
  591. origin_matches :: FlatEqOrigin -> FlatEqOrigin -> Bool
  592. origin_matches Any _ = True
  593. origin_matches WhenSolved WhenSolved = True
  594. origin_matches WhileFlattening WhileFlattening = True
  595. origin_matches _ _ = False
  596. type TcsUntouchables = (Untouchables,TcTyVarSet)
  597. -- Like the TcM Untouchables,
  598. -- but records extra TcsTv variables generated during simplification
  599. -- See Note [Extra TcsTv untouchables] in TcSimplify
  600. \end{code}
  601. \begin{code}
  602. data SimplContext
  603. = SimplInfer SDoc -- Inferring type of a let-bound thing
  604. | SimplRuleLhs RuleName -- Inferring type of a RULE lhs
  605. | SimplInteractive -- Inferring type at GHCi prompt
  606. | SimplCheck SDoc -- Checking a type signature or RULE rhs
  607. instance Outputable SimplContext where
  608. ppr (SimplInfer d) = ptext (sLit "SimplInfer") <+> d
  609. ppr (SimplCheck d) = ptext (sLit "SimplCheck") <+> d
  610. ppr (SimplRuleLhs n) = ptext (sLit "SimplRuleLhs") <+> doubleQuotes (ftext n)
  611. ppr SimplInteractive = ptext (sLit "SimplInteractive")
  612. isInteractive :: SimplContext -> Bool
  613. isInteractive SimplInteractive = True
  614. isInteractive _ = False
  615. simplEqsOnly :: SimplContext -> Bool
  616. -- Simplify equalities only, not dictionaries
  617. -- This is used for the LHS of rules; ee
  618. -- Note [Simplifying RULE lhs constraints] in TcSimplify
  619. simplEqsOnly (SimplRuleLhs {}) = True
  620. simplEqsOnly _ = False
  621. performDefaulting :: SimplContext -> Bool
  622. performDefaulting (SimplInfer {}) = False
  623. performDefaulting (SimplRuleLhs {}) = False
  624. performDefaulting SimplInteractive = True
  625. performDefaulting (SimplCheck {}) = True
  626. ---------------
  627. newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a }
  628. instance Functor TcS where
  629. fmap f m = TcS $ fmap f . unTcS m
  630. instance Monad TcS where
  631. return x = TcS (\_ -> return x)
  632. fail err = TcS (\_ -> fail err)
  633. m >>= k = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs)
  634. -- Basic functionality
  635. -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  636. wrapTcS :: TcM a -> TcS a
  637. -- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS,
  638. -- and TcS is supposed to have limited functionality
  639. wrapTcS = TcS . const -- a TcM action will not use the TcEvBinds
  640. wrapErrTcS :: TcM a -> TcS a
  641. -- The thing wrapped should just fail
  642. -- There's no static check; it's up to the user
  643. -- Having a variant for each error message is too painful
  644. wrapErrTcS = wrapTcS
  645. wrapWarnTcS :: TcM a -> TcS a
  646. -- The thing wrapped should just add a warning, or no-op
  647. -- There's no static check; it's up to the user
  648. wrapWarnTcS = wrapTcS
  649. failTcS, panicTcS :: SDoc -> TcS a
  650. failTcS = wrapTcS . TcM.failWith
  651. panicTcS doc = pprPanic "TcCanonical" doc
  652. traceTcS :: String -> SDoc -> TcS ()
  653. traceTcS herald doc = wrapTcS (TcM.traceTc herald doc)
  654. bumpStepCountTcS :: TcS ()
  655. bumpStepCountTcS = TcS $ \env -> do { let ref = tcs_count env
  656. ; n <- TcM.readTcRef ref
  657. ; TcM.writeTcRef ref (n+1) }
  658. traceFireTcS :: SubGoalDepth -> SDoc -> TcS ()
  659. -- Dump a rule-firing trace
  660. traceFireTcS depth doc
  661. = TcS $ \env ->
  662. TcM.ifDOptM Opt_D_dump_cs_trace $
  663. do { n <- TcM.readTcRef (tcs_count env)
  664. ; let msg = int n
  665. <> text (replicate (tcs_ic_depth env) '>')
  666. <> brackets (int depth) <+> doc
  667. ; TcM.dumpTcRn msg }
  668. runTcS :: SimplContext
  669. -> Untouchables -- Untouchables
  670. -> InertSet -- Initial inert set
  671. -> WorkList -- Initial work list
  672. -> TcS a -- What to run
  673. -> TcM (a, Bag EvBind)
  674. runTcS context untouch is wl tcs
  675. = do { ty_binds_var <- TcM.newTcRef emptyVarEnv
  676. ; ev_cache_var <- TcM.newTcRef $
  677. EvVarCache { evc_cache = emptyTM, evc_flat_cache = emptyTM }
  678. ; ev_binds_var@(EvBindsVar evb_ref _) <- TcM.newTcEvBinds
  679. ; step_count <- TcM.newTcRef 0
  680. ; inert_var <- TcM.newTcRef is
  681. ; wl_var <- TcM.newTcRef wl
  682. ; let env = TcSEnv { tcs_ev_binds = ev_binds_var
  683. , tcs_evvar_cache = ev_cache_var
  684. , tcs_ty_binds = ty_binds_var
  685. , tcs_context = context
  686. , tcs_untch = (untouch, emptyVarSet) -- No Tcs untouchables yet
  687. , tcs_count = step_count
  688. , tcs_ic_depth = 0
  689. , tcs_inerts = inert_var
  690. , tcs_worklist = wl_var }
  691. -- Run the computation
  692. ; res <- unTcS tcs env
  693. -- Perform the type unifications required
  694. ; ty_binds <- TcM.readTcRef ty_binds_var
  695. ; mapM_ do_unification (varEnvElts ty_binds)
  696. ; when debugIsOn $ do {
  697. count <- TcM.readTcRef step_count
  698. ; when (opt_PprStyle_Debug && count > 0) $
  699. TcM.debugDumpTcRn (ptext (sLit "Constraint solver steps =")
  700. <+> int count <+> ppr context)
  701. }
  702. -- And return
  703. ; ev_binds <- TcM.readTcRef evb_ref
  704. ; return (res, evBindMapBinds ev_binds) }
  705. where
  706. do_unification (tv,ty) = TcM.writeMetaTyVar tv ty
  707. doWithInert :: InertSet -> TcS a -> TcS a
  708. doWithInert inert (TcS action)
  709. = TcS $ \env -> do { new_inert_var <- TcM.newTcRef inert
  710. ; orig_cache_var <- TcM.readTcRef (tcs_evvar_cache env)
  711. ; new_cache_var <- TcM.newTcRef orig_cache_var
  712. ; action (env { tcs_inerts = new_inert_var
  713. , tcs_evvar_cache = new_cache_var }) }
  714. nestImplicTcS :: EvBindsVar -> TcsUntouchables -> TcS a -> TcS a
  715. nestImplicTcS ref (inner_range, inner_tcs) (TcS thing_inside)
  716. = TcS $ \ TcSEnv { tcs_ty_binds = ty_binds
  717. , tcs_evvar_cache = orig_evvar_cache_var
  718. , tcs_untch = (_outer_range, outer_tcs)
  719. , tcs_count = count
  720. , tcs_ic_depth = idepth
  721. , tcs_context = ctxt
  722. , tcs_inerts = inert_var
  723. , tcs_worklist = wl_var } ->
  724. do { let inner_untch = (inner_range, outer_tcs `unionVarSet` inner_tcs)
  725. -- The inner_range should be narrower than the outer one
  726. -- (thus increasing the set of untouchables) but
  727. -- the inner Tcs-untouchables must be unioned with the
  728. -- outer ones!
  729. -- Inherit the inerts from the outer scope
  730. ; orig_inerts <- TcM.readTcRef inert_var
  731. ; new_inert_var <- TcM.newTcRef orig_inerts
  732. -- Inherit EvVar cache
  733. ; orig_evvar_cache <- TcM.readTcRef orig_evvar_cache_var
  734. ; evvar_cache <- TcM.newTcRef orig_evvar_cache
  735. ; let nest_env = TcSEnv { tcs_ev_binds = ref
  736. , tcs_evvar_cache = evvar_cache
  737. , tcs_ty_binds = ty_binds
  738. , tcs_untch = inner_untch
  739. , tcs_count = count
  740. , tcs_ic_depth = idepth+1
  741. , tcs_context = ctxtUnderImplic ctxt
  742. , tcs_inerts = new_inert_var
  743. , tcs_worklist = wl_var
  744. -- NB: worklist is going to be empty anyway,
  745. -- so reuse the same ref cell
  746. }
  747. ; thing_inside nest_env }
  748. recoverTcS :: TcS a -> TcS a -> TcS a
  749. recoverTcS (TcS recovery_code) (TcS thing_inside)
  750. = TcS $ \ env ->
  751. TcM.recoverM (recovery_code env) (thing_inside env)
  752. ctxtUnderImplic :: SimplContext -> SimplContext
  753. -- See Note [Simplifying RULE lhs constraints] in TcSimplify
  754. ctxtUnderImplic (SimplRuleLhs n) = SimplCheck (ptext (sLit "lhs of rule")
  755. <+> doubleQuotes (ftext n))
  756. ctxtUnderImplic ctxt = ctxt
  757. tryTcS :: TcS a -> TcS a
  758. -- Like runTcS, but from within the TcS monad
  759. -- Completely afresh inerts and worklist, be careful!
  760. -- Moreover, we will simply throw away all the evidence generated.
  761. tryTcS tcs
  762. = TcS (\env ->
  763. do { wl_var <- TcM.newTcRef emptyWorkList
  764. ; is_var <- TcM.newTcRef emptyInert
  765. ; ty_binds_var <- TcM.newTcRef emptyVarEnv
  766. ; ev_binds_var <- TcM.newTcEvBinds
  767. ; ev_binds_cache_var <- TcM.newTcRef (EvVarCache emptyTM emptyTM)
  768. -- Empty cache: Don't inherit cache from above, see
  769. -- Note [tryTcS for defaulting] in TcSimplify
  770. ; let env1 = env { tcs_ev_binds = ev_binds_var
  771. , tcs_evvar_cache = ev_binds_cache_var
  772. , tcs_ty_binds = ty_binds_var
  773. , tcs_inerts = is_var
  774. , tcs_worklist = wl_var }
  775. ; unTcS tcs env1 })
  776. -- Getters and setters of TcEnv fields
  777. -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  778. -- Getter of inerts and worklist
  779. getTcSInertsRef :: TcS (IORef InertSet)
  780. getTcSInertsRef = TcS (return . tcs_inerts)
  781. getTcSWorkListRef :: TcS (IORef WorkList)
  782. getTcSWorkListRef = TcS (return . tcs_worklist)
  783. getTcSInerts :: TcS InertSet
  784. getTcSInerts = getTcSInertsRef >>= wrapTcS . (TcM.readTcRef)
  785. getTcSWorkList :: TcS WorkList
  786. getTcSWorkList = getTcSWorkListRef >>= wrapTcS . (TcM.readTcRef)
  787. updWorkListTcS :: (WorkList -> WorkList) -> TcS ()
  788. updWorkListTcS f
  789. = updWorkListTcS_return (\w -> ((),f w))
  790. updWorkListTcS_return :: (WorkList -> (a,WorkList)) -> TcS a
  791. updWorkListTcS_return f
  792. = do { wl_var <- getTcSWorkListRef
  793. ; wl_curr <- wrapTcS (TcM.readTcRef wl_var)
  794. ; let (res,new_work) = f wl_curr
  795. ; wrapTcS (TcM.writeTcRef wl_var new_work)
  796. ; return res }
  797. emitFrozenError :: CtFlavor -> EvVar -> SubGoalDepth -> TcS ()
  798. -- Emits a non-canonical constraint that will stand for a frozen error in the inerts.
  799. emitFrozenError fl ev depth
  800. = do { traceTcS "Emit frozen error" (ppr ev <+> dcolon <+> ppr (evVarPred ev))
  801. ; inert_ref <- getTcSInertsRef
  802. ; inerts <- wrapTcS (TcM.readTcRef inert_ref)
  803. ; let ct = CNonCanonical { cc_id = ev
  804. , cc_flavor = fl
  805. , cc_depth = depth }
  806. inerts_new = inerts { inert_frozen = extendCts (inert_frozen inerts) ct }
  807. ; wrapTcS (TcM.writeTcRef inert_ref inerts_new) }
  808. getDynFlags :: TcS DynFlags
  809. getDynFlags = wrapTcS TcM.getDOpts
  810. getTcSContext :: TcS SimplContext
  811. getTcSContext = TcS (return . tcs_context)
  812. getTcEvBinds :: TcS EvBindsVar
  813. getTcEvBinds = TcS (return . tcs_ev_binds)
  814. getTcSEvVarCache :: TcS (IORef EvVarCache)
  815. getTcSEvVarCache = TcS (return . tcs_evvar_cache)
  816. flushFlatCache :: TcS ()
  817. flushFlatCache
  818. = do { cache_var <- getTcSEvVarCache
  819. ; the_cache <- wrapTcS $ TcM.readTcRef cache_var
  820. ; wrapTcS $ TcM.writeTcRef cache_var (the_cache { evc_flat_cache = emptyTM }) }
  821. getTcSEvVarCacheMap :: TcS (TypeMap (EvVar,CtFlavor))
  822. getTcSEvVarCacheMap = do { cache_var <- getTcSEvVarCache
  823. ; the_cache <- wrapTcS $ TcM.readTcRef cache_var
  824. ; return (evc_cache the_cache) }
  825. getTcSEvVarFlatCache :: TcS (TypeMap (TcCoercion,(Type,CtFlavor,FlatEqOrigin)))
  826. getTcSEvVarFlatCache = do { cache_var <- getTcSEvVarCache
  827. ; the_cache <- wrapTcS $ TcM.readTcRef cache_var
  828. ; return (evc_flat_cache the_cache) }
  829. setTcSEvVarCacheMap :: TypeMap (EvVar,CtFlavor) -> TcS ()
  830. setTcSEvVarCacheMap cache = do { cache_var <- getTcSEvVarCache
  831. ; orig_cache <- wrapTcS $ TcM.readTcRef cache_var
  832. ; let new_cache = orig_cache { evc_cache = cache }
  833. ; wrapTcS $ TcM.writeTcRef cache_var new_cache }
  834. getUntouchables :: TcS TcsUntouchables
  835. getUntouchables = TcS (return . tcs_untch)
  836. getTcSTyBinds :: TcS (IORef (TyVarEnv (TcTyVar, TcType)))
  837. getTcSTyBinds = TcS (return . tcs_ty_binds)
  838. getTcSTyBindsMap :: TcS (TyVarEnv (TcTyVar, TcType))
  839. getTcSTyBindsMap = getTcSTyBinds >>= wrapTcS . (TcM.readTcRef)
  840. getTcEvBindsMap :: TcS EvBindMap
  841. getTcEvBindsMap
  842. = do { EvBindsVar ev_ref _ <- getTcEvBinds
  843. ; wrapTcS $ TcM.readTcRef ev_ref }
  844. setEqBind :: EqVar -> TcCoercion -> CtFlavor -> TcS CtFlavor
  845. setEqBind eqv co fl = setEvBind eqv (EvCoercion co) fl
  846. setWantedTyBind :: TcTyVar -> TcType -> TcS ()
  847. -- Add a type binding
  848. -- We never do this twice!
  849. setWantedTyBind tv ty
  850. = do { ref <- getTcSTyBinds
  851. ; wrapTcS $
  852. do { ty_binds <- TcM.readTcRef ref
  853. ; when debugIsOn $
  854. TcM.checkErr (not (tv `elemVarEnv` ty_binds)) $
  855. vcat [ text "TERRIBLE ERROR: double set of meta type variable"
  856. , ppr tv <+> text ":=" <+> ppr ty
  857. , text "Old value =" <+> ppr (lookupVarEnv_NF ty_binds tv)]
  858. ; TcM.writeTcRef ref (extendVarEnv ty_binds tv (tv,ty)) } }
  859. setEvBind :: EvVar -> EvTerm -> CtFlavor -> TcS CtFlavor
  860. -- If the flavor is Solved, we cache the new evidence term inside the returned flavor
  861. -- see Note [Optimizing Spontaneously Solved Coercions]
  862. setEvBind ev t fl
  863. = do { tc_evbinds <- getTcEvBinds
  864. ; wrapTcS $ TcM.addTcEvBind tc_evbinds ev t
  865. #ifdef DEBUG
  866. ; binds <- getTcEvBindsMap
  867. ; let cycle = any (reaches binds) (evVarsOfTerm t)
  868. ; when cycle (fail_if_co_loop binds)
  869. #endif
  870. ; return $
  871. case fl of
  872. Given gl (GivenSolved _)
  873. -> Given gl (GivenSolved (Just t))
  874. _ -> fl
  875. }
  876. #ifdef DEBUG
  877. where fail_if_co_loop binds
  878. = pprTrace "setEvBind" (vcat [ text "Cycle in evidence binds, evvar =" <+> ppr ev
  879. , ppr (evBindMapBinds binds) ]) $
  880. when (isEqVar ev) (pprPanic "setEvBind" (text "BUG: Coercion loop!"))
  881. reaches :: EvBindMap -> Var -> Bool
  882. -- Does this evvar reach ev?
  883. reaches ebm ev0 = go ev0
  884. where go ev0
  885. | ev0 == ev = True
  886. | Just (EvBind _ evtrm) <- lookupEvBind ebm ev0
  887. = any go (evVarsOfTerm evtrm)
  888. | otherwise = False
  889. #endif
  890. \end{code}
  891. Note [Optimizing Spontaneously Solved Coercions]
  892. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  893. Spontaneously solved coercions such as alpha := tau used to be bound as everything else
  894. in the evidence binds. Subsequently they were used for rewriting other wanted or solved
  895. goals. For instance:
  896. WorkItem = [S] g1 : a ~ tau
  897. Inerts = [S] g2 : b ~ [a]
  898. [S] g3 : c ~ [(a,a)]
  899. Would result, eventually, after the workitem rewrites the inerts, in the
  900. following evidence bindings:
  901. g1 = ReflCo tau
  902. g2 = ReflCo [a]
  903. g3 = ReflCo [(a,a)]
  904. g2' = g2 ; [g1]
  905. g3' = g3 ; [(g1,g1)]
  906. This ia annoying because it puts way too much stress to the zonker and
  907. desugarer, since we /know/ at the generation time (spontaneously
  908. solving) that the evidence for a particular evidence variable is the
  909. identity.
  910. For this reason, our solution is to cache inside the GivenSolved
  911. flavor of a constraint the term which is actually solving this
  912. constraint. Whenever we perform a setEvBind, a new flavor is returned
  913. so that if it was a GivenSolved to start with, it remains a
  914. GivenSolved with a new evidence term inside. Then, when we use solved
  915. goals to rewrite other constraints we simply use whatever is in the
  916. GivenSolved flavor and not the constraint cc_id.
  917. In our particular case we'd get the following evidence bindings, eventually:
  918. g1 = ReflCo tau
  919. g2 = ReflCo [a]
  920. g3 = ReflCo [(a,a)]
  921. g2'= ReflCo [a]
  922. g3'= ReflCo [(a,a)]
  923. Since we use smart constructors to get rid of g;ReflCo t ~~> g etc.
  924. \begin{code}
  925. warnTcS :: CtLoc orig -> Bool -> SDoc -> TcS ()
  926. warnTcS loc warn_if doc
  927. | warn_if = wrapTcS $ TcM.setCtLoc loc $ TcM.addWarnTc doc
  928. | otherwise = return ()
  929. getDefaultInfo :: TcS (SimplContext, [Type], (Bool, Bool))
  930. getDefaultInfo
  931. = do { ctxt <- getTcSContext
  932. ; (tys, flags) <- wrapTcS (TcM.tcGetDefaultTys (isInteractive ctxt))
  933. ; return (ctxt, tys, flags) }
  934. -- Just get some environments needed for instance looking up and matching
  935. -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  936. getInstEnvs :: TcS (InstEnv, InstEnv)
  937. getInstEnvs = wrapTcS $ Inst.tcGetInstEnvs
  938. getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv)
  939. getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs
  940. getTopEnv :: TcS HscEnv
  941. getTopEnv = wrapTcS $ TcM.getTopEnv
  942. getGblEnv :: TcS TcGblEnv
  943. getGblEnv = wrapTcS $ TcM.getGblEnv
  944. -- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]
  945. -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  946. checkWellStagedDFun :: PredType -> DFunId -> WantedLoc -> TcS ()
  947. checkWellStagedDFun pred dfun_id loc
  948. = wrapTcS $ TcM.setCtLoc loc $
  949. do { use_stage <- TcM.getStage
  950. ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }
  951. where
  952. pp_thing = ptext (sLit "instance for") <+> quotes (ppr pred)
  953. bind_lvl = TcM.topIdLvl dfun_id
  954. pprEq :: TcType -> TcType -> SDoc
  955. pprEq ty1 ty2 = pprType $ mkEqPred (ty1,ty2)
  956. isTouchableMetaTyVar :: TcTyVar -> TcS Bool
  957. isTouchableMetaTyVar tv
  958. = do { untch <- getUntouchables
  959. ; return $ isTouchableMetaTyVar_InRange untch tv }
  960. isTouchableMetaTyVar_InRange :: TcsUntouchables -> TcTyVar -> Bool
  961. isTouchableMetaTyVar_InRange (untch,untch_tcs) tv
  962. = case tcTyVarDetails tv of
  963. MetaTv TcsTv _ -> not (tv `elemVarSet` untch_tcs)
  964. -- See Note [Touchable meta type variables]
  965. MetaTv {} -> inTouchableRange untch tv
  966. _ -> False
  967. \end{code}
  968. Note [Touchable meta type variables]
  969. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  970. Meta type variables allocated *by the constraint solver itself* are always
  971. touchable. Example:
  972. instance C a b => D [a] where...
  973. if we use this instance declaration we "make up" a fresh meta type
  974. variable for 'b', which we must later guess. (Perhaps C has a
  975. functional dependency.) But since we aren't in the constraint *generator*
  976. we can't allocate a Unique in the touchable range for this implication
  977. constraint. Instead, we mark it as a "TcsTv", which makes it always-touchable.
  978. \begin{code}
  979. -- Flatten skolems
  980. -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  981. newFlattenSkolemTy :: TcType -> TcS TcType
  982. newFlattenSkolemTy ty = mkTyVarTy <$> newFlattenSkolemTyVar ty
  983. newFlattenSkolemTyVar :: TcType -> TcS TcTyVar
  984. newFlattenSkolemTyVar ty
  985. = do { tv <- wrapTcS $ do { uniq <- TcM.newUnique
  986. ; let name = TcM.mkTcTyVarName uniq (fsLit "f")
  987. ; return $ mkTcTyVar name (typeKind ty) (FlatSkol ty) }
  988. ; traceTcS "New Flatten Skolem Born" $
  989. (ppr tv <+> text "[:= " <+> ppr ty <+> text "]")
  990. ; return tv }
  991. -- Instantiations
  992. -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  993. instDFunTypes :: [Either TyVar TcType] -> TcS [TcType]
  994. instDFunTypes mb_inst_tys
  995. = mapM inst_tv mb_inst_tys
  996. where
  997. inst_tv :: Either TyVar TcType -> TcS Type
  998. inst_tv (Left tv) = mkTyVarTy <$> instFlexiTcS tv
  999. inst_tv (Right ty) = return ty
  1000. instDFunConstraints :: TcThetaType -> CtFlavor -> TcS [EvVarCreated]
  1001. instDFunConstraints preds fl
  1002. = mapM (newEvVar fl) preds
  1003. instFlexiTcS :: TyVar -> TcS TcTyVar
  1004. -- Like TcM.instMetaTyVar but the variable that is created is always
  1005. -- touchable; we are supposed to guess its instantiation.
  1006. -- See Note [Touchable meta type variables]
  1007. instFlexiTcS tv = instFlexiTcSHelper (tyVarName tv) (tyVarKind tv)
  1008. newFlexiTcSTy :: Kind -> TcS TcType
  1009. newFlexiTcSTy knd
  1010. = wrapTcS $
  1011. do { uniq <- TcM.newUnique
  1012. ; ref <- TcM.newMutVar Flexi
  1013. ; let name = TcM.mkTcTyVarName uniq (fsLit "uf")
  1014. ; return $ mkTyVarTy (mkTcTyVar name knd (MetaTv TcsTv ref)) }
  1015. isFlexiTcsTv :: TyVar -> Bool
  1016. isFlexiTcsTv tv
  1017. | not (isTcTyVar tv) = False
  1018. | MetaTv TcsTv _ <- tcTyVarDetails tv = True
  1019. | otherwise = False
  1020. newKindConstraint :: TcTyVar -> Kind -> CtFlavor -> TcS EvVarCreated
  1021. -- Create new wanted CoVar that constrains the type to have the specified kind.
  1022. newKindConstraint tv knd fl
  1023. = do { tv_k <- instFlexiTcSHelper (tyVarName tv) knd
  1024. ; let ty_k = mkTyVarTy tv_k
  1025. ; eqv <- newEqVar fl (mkTyVarTy tv) ty_k
  1026. ; return eqv }
  1027. instFlexiTcSHelper :: Name -> Kind -> TcS TcTyVar
  1028. instFlexiT

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