Commit fd3bd417 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Merge branch 'tc-untouchables' of http://darcs.haskell.org/ghc into tc-untouchables

parents 316d3edc b3f2f732
...@@ -177,7 +177,9 @@ tcLookupFamInst tycon tys ...@@ -177,7 +177,9 @@ tcLookupFamInst tycon tys
| otherwise | otherwise
= do { instEnv <- tcGetFamInstEnvs = do { instEnv <- tcGetFamInstEnvs
; let mb_match = lookupFamInstEnv instEnv tycon tys ; let mb_match = lookupFamInstEnv instEnv tycon tys
; traceTc "lookupFamInst" ((ppr tycon <+> ppr tys) $$ pprTvBndrs (varSetElems (tyVarsOfTypes tys)) $$ ppr mb_match $$ ppr instEnv) -- ; traceTc "lookupFamInst" ((ppr tycon <+> ppr tys) $$
-- pprTvBndrs (varSetElems (tyVarsOfTypes tys)) $$
-- ppr mb_match $$ ppr instEnv)
; case mb_match of ; case mb_match of
[] -> return Nothing [] -> return Nothing
((fam_inst, rep_tys):_) ((fam_inst, rep_tys):_)
......
...@@ -247,20 +247,15 @@ canClassNC d ev cls tys ...@@ -247,20 +247,15 @@ canClassNC d ev cls tys
`andWhenContinue` emitSuperclasses `andWhenContinue` emitSuperclasses
canClass d ev cls tys canClass d ev cls tys
= do { -- sctx <- getTcSContext = do { (xis, cos) <- flattenMany d FMFullFlatten (ctEvFlavour ev) tys
; (xis, cos) <- flattenMany d FMFullFlatten (ctEvFlavour ev) tys
; let co = mkTcTyConAppCo (classTyCon cls) cos ; let co = mkTcTyConAppCo (classTyCon cls) cos
xi = mkClassPred cls xis xi = mkClassPred cls xis
; mb <- rewriteCtFlavor ev xi co ; mb <- rewriteCtFlavor ev xi co
; case mb of ; case mb of
Just new_ev -> Nothing -> return Stop
let (ClassPred cls xis_for_dict) = classifyPredType (ctEvPred new_ev) Just new_ev -> continueWith $
in continueWith $ CDictCan { cc_ev = new_ev, cc_loc = d
CDictCan { cc_ev = new_ev, cc_loc = d , cc_tyargs = xis, cc_class = cls } }
, cc_tyargs = xis_for_dict, cc_class = cls }
Nothing -> return Stop }
emitSuperclasses :: Ct -> TcS StopOrContinue emitSuperclasses :: Ct -> TcS StopOrContinue
emitSuperclasses ct@(CDictCan { cc_loc = d, cc_ev = ev emitSuperclasses ct@(CDictCan { cc_loc = d, cc_ev = ev
...@@ -567,24 +562,22 @@ flatten loc f ctxt (TyConApp tc tys) ...@@ -567,24 +562,22 @@ flatten loc f ctxt (TyConApp tc tys)
, cc_tyargs = xi_args , cc_tyargs = xi_args
, cc_rhs = rhs_ty , cc_rhs = rhs_ty
, cc_loc = loc } , cc_loc = loc }
; updWorkListTcS $ extendWorkListEq ct ; updWorkListTcS $ extendWorkListFunEq ct
; return (co, rhs_ty) } ; return (co, rhs_ty) }
| otherwise -- Wanted or Derived: make new unification variable | otherwise -- Wanted or Derived: make new unification variable
-> do { traceTcS "flatten/flat-cache miss" $ empty -> do { traceTcS "flatten/flat-cache miss" $ empty
; rhs_xi_var <- newFlexiTcSTy (typeKind fam_ty) ; rhs_xi_var <- newFlexiTcSTy (typeKind fam_ty)
; let pred = mkTcEqPred fam_ty rhs_xi_var ; ctev <- newWantedEvVarNC (mkTcEqPred fam_ty rhs_xi_var)
; mw <- newWantedEvVar pred -- NC (no-cache) version because we've already
; case mw of -- looked in the solved goals an inerts (lookupFlatEqn)
Fresh ctev -> ; let ct = CFunEqCan { cc_ev = ctev
do { let ct = CFunEqCan { cc_ev = ctev , cc_fun = tc
, cc_fun = tc , cc_tyargs = xi_args
, cc_tyargs = xi_args , cc_rhs = rhs_xi_var
, cc_rhs = rhs_xi_var , cc_loc = loc }
, cc_loc = loc } ; updWorkListTcS $ extendWorkListFunEq ct
; updWorkListTcS $ extendWorkListEq ct ; return (evTermCoercion (ctEvTerm ctev), rhs_xi_var) }
; return (evTermCoercion (ctEvTerm ctev), rhs_xi_var) }
Cached {} -> panic "flatten TyConApp, var must be fresh!" }
} }
-- Emit the flat constraints -- Emit the flat constraints
; return ( mkAppTys rhs_xi xi_rest -- NB mkAppTys: rhs_xi might not be a type variable ; return ( mkAppTys rhs_xi xi_rest -- NB mkAppTys: rhs_xi might not be a type variable
...@@ -1071,19 +1064,15 @@ reOrient :: CtEvidence -> TypeClassifier -> TypeClassifier -> Bool ...@@ -1071,19 +1064,15 @@ reOrient :: CtEvidence -> TypeClassifier -> TypeClassifier -> Bool
-- We try to say False if possible, to minimise evidence generation -- We try to say False if possible, to minimise evidence generation
-- --
-- Postcondition: After re-orienting, first arg is not OTherCls -- Postcondition: After re-orienting, first arg is not OTherCls
reOrient _ev (OtherCls {}) (FunCls {}) = True reOrient _ev (OtherCls {}) cls2 = ASSERT( case cls2 of { OtherCls {} -> False; _ -> True } )
reOrient _ev (OtherCls {}) (VarCls {}) = True True -- One must be Var/Fun
reOrient _ev (OtherCls {}) (OtherCls {}) = panic "reOrient" -- One must be Var/Fun
reOrient _ev (FunCls {}) (VarCls _tv) = False reOrient _ev (FunCls {}) _ = False -- Fun/Other on rhs
-- But consider the following variation: isGiven ev && isMetaTyVar tv -- But consider the following variation: isGiven ev && isMetaTyVar tv
-- See Note [No touchables as FunEq RHS] in TcSMonad -- See Note [No touchables as FunEq RHS] in TcSMonad
reOrient _ev (FunCls {}) _ = False -- Fun/Other on rhs
reOrient _ev (VarCls {}) (FunCls {}) = True
reOrient _ev (VarCls {}) (OtherCls {}) = False
reOrient _ev (VarCls {}) (FunCls {}) = True
reOrient _ev (VarCls {}) (OtherCls {}) = False
reOrient _ev (VarCls tv1) (VarCls tv2) reOrient _ev (VarCls tv1) (VarCls tv2)
| isMetaTyVar tv2 && not (isMetaTyVar tv1) = True | isMetaTyVar tv2 && not (isMetaTyVar tv1) = True
| otherwise = False | otherwise = False
...@@ -1153,7 +1142,7 @@ canEqLeafFunEq loc ev fn tys1 ty2 -- ev :: F tys1 ~ ty2 ...@@ -1153,7 +1142,7 @@ canEqLeafFunEq loc ev fn tys1 ty2 -- ev :: F tys1 ~ ty2
Nothing -> return Stop ; Nothing -> return Stop ;
Just new_ev Just new_ev
| isTcReflCo xco -> continueWith new_ct | isTcReflCo xco -> continueWith new_ct
| otherwise -> do { updWorkListTcS (extendWorkListEq new_ct); return Stop } | otherwise -> do { updWorkListTcS (extendWorkListFunEq new_ct); return Stop }
where where
new_ct = CFunEqCan { cc_ev = new_ev, cc_loc = loc new_ct = CFunEqCan { cc_ev = new_ev, cc_loc = loc
, cc_fun = fn, cc_tyargs = xis1, cc_rhs = xi2 } } } , cc_fun = fn, cc_tyargs = xis1, cc_rhs = xi2 } } }
......
...@@ -296,11 +296,10 @@ spontaneousSolveStage workItem ...@@ -296,11 +296,10 @@ spontaneousSolveStage workItem
SPSolved new_tv SPSolved new_tv
-- Post: tv ~ xi is now in TyBinds, no need to put in inerts as well -- Post: tv ~ xi is now in TyBinds, no need to put in inerts as well
-- see Note [Spontaneously solved in TyBinds] -- see Note [Spontaneously solved in TyBinds]
-> do { bumpStepCountTcS -> do { traceFireTcS workItem $
; traceFireTcS workItem $ ptext (sLit "Spontaneously solved:") <+> ppr workItem
ptext (sLit "Spontaneously solved:") <+> ppr workItem ; kickOutRewritable Given new_tv
; kickOutRewritable Given new_tv ; return Stop } }
; return Stop } }
\end{code} \end{code}
Note [Spontaneously solved in TyBinds] Note [Spontaneously solved in TyBinds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
...@@ -649,19 +648,16 @@ interactWithInertsStage wi ...@@ -649,19 +648,16 @@ interactWithInertsStage wi
, ptext (sLit "WorkItem =") <+> ppr wi ] , ptext (sLit "WorkItem =") <+> ppr wi ]
; case ir of ; case ir of
IRWorkItemConsumed { ir_fire = rule } IRWorkItemConsumed { ir_fire = rule }
-> do { bumpStepCountTcS -> do { traceFireTcS wi (mk_msg rule (text "WorkItemConsumed"))
; traceFireTcS wi (mk_msg rule (text "WorkItemConsumed"))
; insertInertItemTcS atomic_inert ; insertInertItemTcS atomic_inert
; return Stop } ; return Stop }
IRReplace { ir_fire = rule } IRReplace { ir_fire = rule }
-> do { bumpStepCountTcS -> do { traceFireTcS atomic_inert
; traceFireTcS atomic_inert
(mk_msg rule (text "InertReplace")) (mk_msg rule (text "InertReplace"))
; insertInertItemTcS wi ; insertInertItemTcS wi
; return Stop } ; return Stop }
IRInertConsumed { ir_fire = rule } IRInertConsumed { ir_fire = rule }
-> do { bumpStepCountTcS -> do { traceFireTcS atomic_inert
; traceFireTcS atomic_inert
(mk_msg rule (text "InertItemConsumed")) (mk_msg rule (text "InertItemConsumed"))
; return (ContinueWith wi) } ; return (ContinueWith wi) }
IRKeepGoing {} -- Should we do a bumpStepCountTcS? No for now. IRKeepGoing {} -- Should we do a bumpStepCountTcS? No for now.
...@@ -726,8 +722,9 @@ doInteractWithInert ii@(CFunEqCan { cc_ev = ev1, cc_fun = tc1 ...@@ -726,8 +722,9 @@ doInteractWithInert ii@(CFunEqCan { cc_ev = ev1, cc_fun = tc1
, cc_tyargs = args1, cc_rhs = xi1, cc_loc = d1 }) , cc_tyargs = args1, cc_rhs = xi1, cc_loc = d1 })
wi@(CFunEqCan { cc_ev = ev2, cc_fun = tc2 wi@(CFunEqCan { cc_ev = ev2, cc_fun = tc2
, cc_tyargs = args2, cc_rhs = xi2, cc_loc = d2 }) , cc_tyargs = args2, cc_rhs = xi2, cc_loc = d2 })
| fl1 `canSolve` fl2 && lhss_match | fl1 `canSolve` fl2
= do { traceTcS "interact with inerts: FunEq/FunEq" $ = ASSERT( lhss_match ) -- extractRelevantInerts ensures this
do { traceTcS "interact with inerts: FunEq/FunEq" $
vcat [ text "workItem =" <+> ppr wi vcat [ text "workItem =" <+> ppr wi
, text "inertItem=" <+> ppr ii ] , text "inertItem=" <+> ppr ii ]
...@@ -744,8 +741,9 @@ doInteractWithInert ii@(CFunEqCan { cc_ev = ev1, cc_fun = tc1 ...@@ -744,8 +741,9 @@ doInteractWithInert ii@(CFunEqCan { cc_ev = ev1, cc_fun = tc1
; emitWorkNC d2 ctevs ; emitWorkNC d2 ctevs
; return (IRWorkItemConsumed "FunEq/FunEq") } ; return (IRWorkItemConsumed "FunEq/FunEq") }
| fl2 `canSolve` fl1 && lhss_match | fl2 `canSolve` fl1
= do { traceTcS "interact with inerts: FunEq/FunEq" $ = ASSERT( lhss_match ) -- extractRelevantInerts ensures this
do { traceTcS "interact with inerts: FunEq/FunEq" $
vcat [ text "workItem =" <+> ppr wi vcat [ text "workItem =" <+> ppr wi
, text "inertItem=" <+> ppr ii ] , text "inertItem=" <+> ppr ii ]
...@@ -1027,7 +1025,7 @@ So our problem is this ...@@ -1027,7 +1025,7 @@ So our problem is this
We may add the given in the inert set, along with its superclasses We may add the given in the inert set, along with its superclasses
[assuming we don't fail because there is a matching instance, see [assuming we don't fail because there is a matching instance, see
tryTopReact, given case ] topReactionsStage, given case ]
Inert: Inert:
d0 :_g Foo t d0 :_g Foo t
WorkList WorkList
...@@ -1339,20 +1337,14 @@ mkEqnMsg (pred1,from1) (pred2,from2) tidy_env ...@@ -1339,20 +1337,14 @@ mkEqnMsg (pred1,from1) (pred2,from2) tidy_env
********************************************************************************* *********************************************************************************
\begin{code} \begin{code}
topReactionsStage :: SimplifierStage topReactionsStage :: WorkItem -> TcS StopOrContinue
topReactionsStage workItem topReactionsStage wi
= tryTopReact workItem
tryTopReact :: WorkItem -> TcS StopOrContinue
tryTopReact wi
= do { inerts <- getTcSInerts = do { inerts <- getTcSInerts
; tir <- doTopReact inerts wi ; tir <- doTopReact inerts wi
; case tir of ; case tir of
NoTopInt -> return (ContinueWith wi) NoTopInt -> return (ContinueWith wi)
SomeTopInt rule what_next SomeTopInt rule what_next
-> do { bumpStepCountTcS -> do { traceFireTcS wi $
; traceFireTcS wi $
vcat [ ptext (sLit "Top react:") <+> text rule vcat [ ptext (sLit "Top react:") <+> text rule
, text "WorkItem =" <+> ppr wi ] , text "WorkItem =" <+> ppr wi ]
; return what_next } } ; return what_next } }
...@@ -1440,18 +1432,18 @@ doTopReactFunEq :: Ct -> CtEvidence -> TyCon -> [Xi] -> Xi ...@@ -1440,18 +1432,18 @@ doTopReactFunEq :: Ct -> CtEvidence -> TyCon -> [Xi] -> Xi
-> CtLoc -> TcS TopInteractResult -> CtLoc -> TcS TopInteractResult
doTopReactFunEq ct fl fun_tc args xi loc doTopReactFunEq ct fl fun_tc args xi loc
= ASSERT (isSynFamilyTyCon fun_tc) -- No associated data families have = ASSERT (isSynFamilyTyCon fun_tc) -- No associated data families have
-- reached that far -- reached this far
-- Look in the cache of solved funeqs
-- First look in the cache of solved funeqs
do { fun_eq_cache <- getTcSInerts >>= (return . inert_solved_funeqs) do { fun_eq_cache <- getTcSInerts >>= (return . inert_solved_funeqs)
; case lookupFamHead fun_eq_cache fam_ty of { ; case lookupFamHead fun_eq_cache fam_ty of {
Just (CFunEqCan { cc_ev = ctev, cc_rhs = rhs_ty }) Just (CFunEqCan { cc_ev = ctev, cc_rhs = rhs_ty })
-> ASSERT( not (isDerived ctev) ) | ctEvFlavour ctev `canRewrite` ctEvFlavour fl
succeed_with "Fun/Cache" (evTermCoercion (ctEvTerm ctev)) rhs_ty ; -> ASSERT( not (isDerived ctev) )
Just {} -> pprPanic "doTopReactFunEq" (ppr ct) ; succeed_with "Fun/Cache" (evTermCoercion (ctEvTerm ctev)) rhs_ty ;
Nothing -> Just ct' -> pprPanic "doTopReactFunEq" (ppr ct') ;
Nothing ->
-- No cached solved, so look up in top-level instances
-- Look up in top-level instances
do { match_res <- matchFam fun_tc args -- See Note [MATCHING-SYNONYMS] do { match_res <- matchFam fun_tc args -- See Note [MATCHING-SYNONYMS]
; case match_res of { ; case match_res of {
Nothing -> return NoTopInt ; Nothing -> return NoTopInt ;
...@@ -1462,7 +1454,7 @@ doTopReactFunEq ct fl fun_tc args xi loc ...@@ -1462,7 +1454,7 @@ doTopReactFunEq ct fl fun_tc args xi loc
unless (isDerived fl) (addSolvedFunEq ct fam_ty) unless (isDerived fl) (addSolvedFunEq ct fam_ty)
; let coe_ax = famInstAxiom famInst ; let coe_ax = famInstAxiom famInst
; succeed_with "Fun/Top"(mkTcAxInstCo coe_ax rep_tys) ; succeed_with "Fun/Top" (mkTcAxInstCo coe_ax rep_tys)
(mkAxInstRHS coe_ax rep_tys) } } } } } (mkAxInstRHS coe_ax rep_tys) } } } } }
where where
fam_ty = mkTyConApp fun_tc args fam_ty = mkTyConApp fun_tc args
......
...@@ -155,17 +155,17 @@ newWantedEvVars theta = mapM newWantedEvVar theta ...@@ -155,17 +155,17 @@ newWantedEvVars theta = mapM newWantedEvVar theta
newEvVar :: TcPredType -> TcM EvVar newEvVar :: TcPredType -> TcM EvVar
-- Creates new *rigid* variables for predicates -- Creates new *rigid* variables for predicates
newEvVar ty = do { name <- newName (predTypeOccName ty) newEvVar ty = do { name <- newSysName (predTypeOccName ty)
; return (mkLocalId name ty) } ; return (mkLocalId name ty) }
newEq :: TcType -> TcType -> TcM EvVar newEq :: TcType -> TcType -> TcM EvVar
newEq ty1 ty2 newEq ty1 ty2
= do { name <- newName (mkVarOccFS (fsLit "cobox")) = do { name <- newSysName (mkVarOccFS (fsLit "cobox"))
; return (mkLocalId name (mkTcEqPred ty1 ty2)) } ; return (mkLocalId name (mkTcEqPred ty1 ty2)) }
newDict :: Class -> [TcType] -> TcM DictId newDict :: Class -> [TcType] -> TcM DictId
newDict cls tys newDict cls tys
= do { name <- newName (mkDictOcc (getOccName cls)) = do { name <- newSysName (mkDictOcc (getOccName cls))
; return (mkLocalId name (mkClassPred cls tys)) } ; return (mkLocalId name (mkClassPred cls tys)) }
predTypeOccName :: PredType -> OccName predTypeOccName :: PredType -> OccName
...@@ -679,7 +679,7 @@ zonkFlats binds_var untch cts ...@@ -679,7 +679,7 @@ zonkFlats binds_var untch cts
, not (tv `elemVarSet` tyVarsOfType ty_lhs) , not (tv `elemVarSet` tyVarsOfType ty_lhs)
-- , Just ty_lhs' <- occurCheck tv ty_lhs -- , Just ty_lhs' <- occurCheck tv ty_lhs
= ASSERT2( isWantedCt orig_ct, ppr orig_ct ) = ASSERT2( isWantedCt orig_ct, ppr orig_ct )
ASSERT2( case orig_ct of { CFunEqCan {} -> True; _ -> False }, ppr orig_ct ) ASSERT2( case tcSplitTyConApp_maybe ty_lhs of { Just (tc,_) -> isSynFamilyTyCon tc; _ -> False }, ppr orig_ct )
do { writeMetaTyVar tv ty_lhs do { writeMetaTyVar tv ty_lhs
; let evterm = EvCoercion (mkTcReflCo ty_lhs) ; let evterm = EvCoercion (mkTcReflCo ty_lhs)
evvar = ctev_evar (cc_ev zct) evvar = ctev_evar (cc_ev zct)
......
...@@ -376,6 +376,11 @@ newName occ ...@@ -376,6 +376,11 @@ newName occ
; loc <- getSrcSpanM ; loc <- getSrcSpanM
; return (mkInternalName uniq occ loc) } ; return (mkInternalName uniq occ loc) }
newSysName :: OccName -> TcM Name
newSysName occ
= do { uniq <- newUnique
; return (mkSystemName uniq occ) }
newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId] newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
newSysLocalIds fs tys newSysLocalIds fs tys
= do { us <- newUniqueSupply = do { us <- newUniqueSupply
......
...@@ -13,7 +13,8 @@ module TcSMonad ( ...@@ -13,7 +13,8 @@ module TcSMonad (
WorkList(..), isEmptyWorkList, emptyWorkList, WorkList(..), isEmptyWorkList, emptyWorkList,
workListFromEq, workListFromNonEq, workListFromCt, workListFromEq, workListFromNonEq, workListFromCt,
extendWorkListEq, extendWorkListNonEq, extendWorkListCt, extendWorkListEq, extendWorkListFunEq,
extendWorkListNonEq, extendWorkListCt,
extendWorkListCts, extendWorkListEqs, appendWorkList, selectWorkItem, extendWorkListCts, extendWorkListEqs, appendWorkList, selectWorkItem,
withWorkList, withWorkList,
...@@ -31,7 +32,7 @@ module TcSMonad ( ...@@ -31,7 +32,7 @@ module TcSMonad (
mkGivenLoc, mkGivenLoc,
TcS, runTcS, runTcSWithEvBinds, failTcS, panicTcS, traceTcS, -- Basic functionality TcS, runTcS, runTcSWithEvBinds, failTcS, panicTcS, traceTcS, -- Basic functionality
traceFireTcS, bumpStepCountTcS, traceFireTcS,
tryTcS, nestTcS, nestImplicTcS, recoverTcS, tryTcS, nestTcS, nestImplicTcS, recoverTcS,
wrapErrTcS, wrapWarnTcS, wrapErrTcS, wrapWarnTcS,
...@@ -46,7 +47,7 @@ module TcSMonad ( ...@@ -46,7 +47,7 @@ module TcSMonad (
xCtFlavor, -- Transform a CtEvidence during a step xCtFlavor, -- Transform a CtEvidence during a step
rewriteCtFlavor, -- Specialized version of xCtFlavor for coercions rewriteCtFlavor, -- Specialized version of xCtFlavor for coercions
newWantedEvVar, instDFunConstraints, newWantedEvVar, newWantedEvVarNC, instDFunConstraints,
newDerived, newDerived,
-- Creation of evidence variables -- Creation of evidence variables
...@@ -167,8 +168,8 @@ mkKindErrorCtxtTcS ty1 ki1 ty2 ki2 ...@@ -167,8 +168,8 @@ mkKindErrorCtxtTcS ty1 ki1 ty2 ki2
%* * %* *
%************************************************************************ %************************************************************************
Note [WorkList] Note [WorkList priorities]
~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~
A WorkList contains canonical and non-canonical items (of all flavors). A WorkList contains canonical and non-canonical items (of all flavors).
Notice that each Ct now has a simplification depth. We may Notice that each Ct now has a simplification depth. We may
consider using this depth for prioritization as well in the future. consider using this depth for prioritization as well in the future.
...@@ -179,6 +180,7 @@ so that it's easier to deal with them first, but the separation ...@@ -179,6 +180,7 @@ so that it's easier to deal with them first, but the separation
is not strictly necessary. Notice that non-canonical constraints is not strictly necessary. Notice that non-canonical constraints
are also parts of the worklist. are also parts of the worklist.
Note [NonCanonical Semantics] Note [NonCanonical Semantics]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Note that canonical constraints involve a CNonCanonical constructor. In the worklist Note that canonical constraints involve a CNonCanonical constructor. In the worklist
...@@ -219,7 +221,7 @@ extractDeque (DQ [] bs) = case reverse bs of ...@@ -219,7 +221,7 @@ extractDeque (DQ [] bs) = case reverse bs of
(a:as) -> Just (DQ as [], a) (a:as) -> Just (DQ as [], a)
[] -> panic "extractDeque" [] -> panic "extractDeque"
-- See Note [WorkList] -- See Note [WorkList priorities]
data WorkList = WorkList { wl_eqs :: [Ct] data WorkList = WorkList { wl_eqs :: [Ct]
, wl_funeqs :: Deque Ct , wl_funeqs :: Deque Ct
, wl_rest :: [Ct] , wl_rest :: [Ct]
...@@ -237,10 +239,14 @@ extendWorkListEq :: Ct -> WorkList -> WorkList ...@@ -237,10 +239,14 @@ extendWorkListEq :: Ct -> WorkList -> WorkList
-- Extension by equality -- Extension by equality
extendWorkListEq ct wl extendWorkListEq ct wl
| Just {} <- isCFunEqCan_Maybe ct | Just {} <- isCFunEqCan_Maybe ct
= wl { wl_funeqs = insertDeque ct (wl_funeqs wl) } = extendWorkListFunEq ct wl
| otherwise | otherwise
= wl { wl_eqs = ct : wl_eqs wl } = wl { wl_eqs = ct : wl_eqs wl }
extendWorkListFunEq :: Ct -> WorkList -> WorkList
extendWorkListFunEq ct wl
= wl { wl_funeqs = insertDeque ct (wl_funeqs wl) }
extendWorkListEqs :: [Ct] -> WorkList -> WorkList extendWorkListEqs :: [Ct] -> WorkList -> WorkList
-- Append a list of equalities -- Append a list of equalities
extendWorkListEqs cts wl = foldr extendWorkListEq wl cts extendWorkListEqs cts wl = foldr extendWorkListEq wl cts
...@@ -954,17 +960,14 @@ traceTcS herald doc = wrapTcS (TcM.traceTc herald doc) ...@@ -954,17 +960,14 @@ traceTcS herald doc = wrapTcS (TcM.traceTc herald doc)
instance HasDynFlags TcS where instance HasDynFlags TcS where
getDynFlags = wrapTcS getDynFlags getDynFlags = wrapTcS getDynFlags
bumpStepCountTcS :: TcS ()
bumpStepCountTcS = TcS $ \env -> do { let ref = tcs_count env
; n <- TcM.readTcRef ref
; TcM.writeTcRef ref (n+1) }
traceFireTcS :: Ct -> SDoc -> TcS () traceFireTcS :: Ct -> SDoc -> TcS ()
-- Dump a rule-firing trace -- Dump a rule-firing trace, and bumpt the counter
traceFireTcS ct doc traceFireTcS ct doc
= TcS $ \env -> = TcS $ \env ->
TcM.ifDOptM Opt_D_dump_cs_trace $ TcM.ifDOptM Opt_D_dump_cs_trace $
do { n <- TcM.readTcRef (tcs_count env) do { let count_ref = tcs_count env
; n <- TcM.readTcRef count_ref
; TcM.writeTcRef count_ref (n+1)
; let msg = int n <> brackets (int (ctLocDepth (cc_loc ct))) <+> doc ; let msg = int n <> brackets (int (ctLocDepth (cc_loc ct))) <+> doc
; TcM.dumpTcRn msg } ; TcM.dumpTcRn msg }
...@@ -1404,6 +1407,12 @@ newGivenEvVar pred rhs ...@@ -1404,6 +1407,12 @@ newGivenEvVar pred rhs
; setEvBind new_ev rhs ; setEvBind new_ev rhs
; return (CtGiven { ctev_pred = pred, ctev_evtm = EvId new_ev }) } ; return (CtGiven { ctev_pred = pred, ctev_evtm = EvId new_ev }) }
newWantedEvVarNC :: TcPredType -> TcS CtEvidence
-- Don't look up in the solved/inerts; we know it's not there
newWantedEvVarNC pty
= do { new_ev <- wrapTcS $ TcM.newEvVar pty
; return (CtWanted { ctev_pred = pty, ctev_evar = new_ev })}
newWantedEvVar :: TcPredType -> TcS MaybeNew newWantedEvVar :: TcPredType -> TcS MaybeNew
newWantedEvVar pty newWantedEvVar pty
= do { mb_ct <- lookupInInerts pty = do { mb_ct <- lookupInInerts pty
...@@ -1411,10 +1420,8 @@ newWantedEvVar pty ...@@ -1411,10 +1420,8 @@ newWantedEvVar pty
Just ctev | not (isDerived ctev) Just ctev | not (isDerived ctev)
-> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev
; return (Cached (ctEvTerm ctev)) } ; return (Cached (ctEvTerm ctev)) }
_ -> do { new_ev <- wrapTcS $ TcM.newEvVar pty _ -> do { ctev <- newWantedEvVarNC pty
; traceTcS "newWantedEvVar/cache miss" $ ppr new_ev ; traceTcS "newWantedEvVar/cache miss" $ ppr ctev
; let ctev = CtWanted { ctev_pred = pty
, ctev_evar = new_ev }
; return (Fresh ctev) } } ; return (Fresh ctev) } }
newDerived :: TcPredType -> TcS (Maybe CtEvidence) newDerived :: TcPredType -> TcS (Maybe CtEvidence)
...@@ -1471,7 +1478,7 @@ See Note [Coercion evidence terms] in TcEvidence. ...@@ -1471,7 +1478,7 @@ See Note [Coercion evidence terms] in TcEvidence.
\begin{code} \begin{code}
xCtFlavor :: CtEvidence -- Original flavor xCtFlavor :: CtEvidence -- Original flavor
-> [TcPredType] -- New predicate types -> [TcPredType] -- New predicate types
-> XEvTerm -- Instructions about how to manipulate evidence -> XEvTerm -- Instructions about how to manipulate evidence
-> TcS [CtEvidence] -> TcS [CtEvidence]
......
...@@ -1013,18 +1013,21 @@ happy to have types of kind Constraint on either end of an arrow. ...@@ -1013,18 +1013,21 @@ happy to have types of kind Constraint on either end of an arrow.
matchExpectedFunKind :: TcKind -> TcM (Maybe (TcKind, TcKind)) matchExpectedFunKind :: TcKind -> TcM (Maybe (TcKind, TcKind))
-- Like unifyFunTy, but does not fail; instead just returns Nothing -- Like unifyFunTy, but does not fail; instead just returns Nothing
matchExpectedFunKind (TyVarTy kvar) = do matchExpectedFunKind (FunTy arg_kind res_kind)
maybe_kind <- readMetaTyVar kvar = return (Just (arg_kind,res_kind))
case maybe_kind of
Indirect fun_kind -> matchExpectedFunKind fun_kind matchExpectedFunKind (TyVarTy kvar)
Flexi -> | isTcTyVar kvar, isMetaTyVar kvar
do { arg_kind <- newMetaKindVar = do { maybe_kind <- readMetaTyVar kvar
; res_kind <- newMetaKindVar ; case maybe_kind of
; writeMetaTyVar kvar (mkArrowKind arg_kind res_kind) Indirect fun_kind -> matchExpectedFunKind fun_kind
; return (Just (arg_kind,res_kind)) } Flexi ->
do { arg_kind <- newMetaKindVar
matchExpectedFunKind (FunTy arg_kind res_kind) = return (Just (arg_kind,res_kind)) ; res_kind <- newMetaKindVar
matchExpectedFunKind _ = return Nothing ; writeMetaTyVar kvar (mkArrowKind arg_kind res_kind)
; return (Just (arg_kind,res_kind)) } }
matchExpectedFunKind _ = return Nothing
----------------- -----------------
unifyKindX :: TcKind -- k1 (actual) unifyKindX :: TcKind -- k1 (actual)
......
...@@ -418,10 +418,11 @@ ppr_co p co@(ForAllCo {}) = ppr_forall_co p co ...@@ -418,10 +418,11 @@ ppr_co p co@(ForAllCo {}) = ppr_forall_co p co
ppr_co _ (CoVarCo cv) = parenSymOcc (getOccName cv) (ppr cv) ppr_co _ (CoVarCo cv) = parenSymOcc (getOccName cv) (ppr cv)
ppr_co p (AxiomInstCo con cos) = pprTypeNameApp p ppr_co (getName con) cos ppr_co p (AxiomInstCo con cos) = pprTypeNameApp p ppr_co (getName con) cos
ppr_co p (TransCo co1 co2) = maybeParen p FunPrec $ ppr_co p co@(TransCo {}) = maybeParen p FunPrec $
ppr_co FunPrec co1 case trans_co_list co [] of
<+> ptext (sLit ";") [] -> panic "ppr_co"
<+> ppr_co FunPrec co2 (co:cos) -> sep ( ppr_co FunPrec co
: [ char ';' <+> ppr_co FunPrec co | co <- cos])
ppr_co p (InstCo co ty) = maybeParen p TyConPrec $ ppr_co p (InstCo co ty) = maybeParen p TyConPrec $
pprParendCo co <> ptext (sLit "@") <> pprType ty pprParendCo co <> ptext (sLit "@") <> pprType ty
...@@ -431,6 +432,10 @@ ppr_co p (SymCo co) = pprPrefixApp p (ptext (sLit "Sym")) [pprParendCo c ...@@ -431,6 +432,10 @@ ppr_co p (SymCo co) = pprPrefixApp p (ptext (sLit "Sym")) [pprParendCo c
ppr_co p (NthCo n co) = pprPrefixApp p (ptext (sLit "Nth:") <> int n) [pprParendCo co] ppr_co p (NthCo n co) = pprPrefixApp p (ptext (sLit "Nth:") <> int n) [pprParendCo co]
ppr_co p (LRCo sel co) = pprPrefixApp p (ppr sel) [pprParendCo co] ppr_co p (LRCo sel co) = pprPrefixApp p (ppr sel) [pprParendCo co]
trans_co_list :: Coercion -> [Coercion] -> [Coercion]
trans_co_list (TransCo co1 co2) cos = trans_co_list co1 (trans_co_list co2 cos)
trans_co_list co cos = co : cos
instance Outputable LeftOrRight where instance Outputable LeftOrRight where
ppr CLeft = ptext (sLit "Left") ppr CLeft = ptext (sLit "Left")
ppr CRight = ptext (sLit "Right") ppr CRight = ptext (sLit "Right")
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment