Commit 35d37ff8 authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu
Browse files

Fix #11401.

This commit teaches shortCutReduction about Derived constraints.

[skip ci]
parent 84c773e1
...@@ -1527,47 +1527,39 @@ shortCutReduction :: CtEvidence -> TcTyVar -> TcCoercion ...@@ -1527,47 +1527,39 @@ shortCutReduction :: CtEvidence -> TcTyVar -> TcCoercion
-> TyCon -> [TcType] -> TcS (StopOrContinue Ct) -> TyCon -> [TcType] -> TcS (StopOrContinue Ct)
-- See Note [Top-level reductions for type functions] -- See Note [Top-level reductions for type functions]
shortCutReduction old_ev fsk ax_co fam_tc tc_args shortCutReduction old_ev fsk ax_co fam_tc tc_args
| isGiven old_ev = ASSERT( ctEvEqRel old_ev == NomEq)
= ASSERT( ctEvEqRel old_ev == NomEq )
do { (xis, cos) <- flattenManyNom old_ev tc_args do { (xis, cos) <- flattenManyNom old_ev tc_args
-- ax_co :: F args ~ G tc_args -- ax_co :: F args ~ G tc_args
-- cos :: xis ~ tc_args -- cos :: xis ~ tc_args
-- old_ev :: F args ~ fsk -- old_ev :: F args ~ fsk
-- G cos ; sym ax_co ; old_ev :: G xis ~ fsk -- G cos ; sym ax_co ; old_ev :: G xis ~ fsk
; new_ev <- newGivenEvVar deeper_loc ; new_ev <- case ctEvFlavour old_ev of
Given -> newGivenEvVar deeper_loc
( mkPrimEqPred (mkTyConApp fam_tc xis) (mkTyVarTy fsk) ( mkPrimEqPred (mkTyConApp fam_tc xis) (mkTyVarTy fsk)
, EvCoercion (mkTcTyConAppCo Nominal fam_tc cos , EvCoercion (mkTcTyConAppCo Nominal fam_tc cos
`mkTcTransCo` mkTcSymCo ax_co `mkTcTransCo` mkTcSymCo ax_co
`mkTcTransCo` ctEvCoercion old_ev) ) `mkTcTransCo` ctEvCoercion old_ev) )
; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc, cc_tyargs = xis, cc_fsk = fsk } Derived -> newDerivedNC deeper_loc $
; updWorkListTcS (extendWorkListFunEq new_ct) mkPrimEqPred (mkTyConApp fam_tc xis)
; stopWith old_ev "Fun/Top (given, shortcut)" } (mkTyVarTy fsk)
| otherwise Wanted ->
= ASSERT( not (isDerived old_ev) ) -- Caller ensures this do { (new_ev, new_co) <- newWantedEq deeper_loc Nominal
ASSERT( ctEvEqRel old_ev == NomEq ) (mkTyConApp fam_tc xis) (mkTyVarTy fsk)
do { (xis, cos) <- flattenManyNom old_ev tc_args ; setWantedEq (ctev_dest old_ev) $
-- ax_co :: F args ~ G tc_args ax_co `mkTcTransCo` mkTcSymCo (mkTcTyConAppCo Nominal
-- cos :: xis ~ tc_args fam_tc cos)
-- G cos ; sym ax_co ; old_ev :: G xis ~ fsk `mkTcTransCo` new_co
-- new_ev :: G xis ~ fsk ; return new_ev }
-- old_ev :: F args ~ fsk := ax_co ; sym (G cos) ; new_ev
; (new_ev, new_co) <- newWantedEq deeper_loc Nominal
(mkTyConApp fam_tc xis) (mkTyVarTy fsk)
; setWantedEq (ctev_dest old_ev)
(ax_co `mkTcTransCo` mkTcSymCo (mkTcTyConAppCo Nominal fam_tc cos)
`mkTcTransCo` new_co)
; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc ; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc
, cc_tyargs = xis, cc_fsk = fsk } , cc_tyargs = xis, cc_fsk = fsk }
; updWorkListTcS (extendWorkListFunEq new_ct) ; updWorkListTcS (extendWorkListFunEq new_ct)
; stopWith old_ev "Fun/Top (wanted, shortcut)" } ; stopWith old_ev "Fun/Top (shortcut)" }
where where
loc = ctEvLoc old_ev deeper_loc = bumpCtLocDepth (ctEvLoc old_ev)
deeper_loc = bumpCtLocDepth loc
dischargeFmv :: CtEvidence -> TcTyVar -> TcCoercion -> TcType -> TcS () dischargeFmv :: CtEvidence -> TcTyVar -> TcCoercion -> TcType -> TcS ()
-- (dischargeFmv x fmv co ty) -- (dischargeFmv x fmv co ty)
......
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
module T11401 where
newtype Value a = Value a
newtype CodeGen r a = CodeGen a
bind :: CodeGen r a -> (a -> CodeGen r b) -> CodeGen r b
bind (CodeGen a) k = k a
class
(f ~ CalledFunction g, r ~ CallerResult g, g ~ CallerFunction f r) =>
CallArgs f g r where
type CalledFunction g :: *
type CallerResult g :: *
type CallerFunction f r :: *
call :: f -> g
instance CallArgs (IO a) (CodeGen r (Value a)) r where
type CalledFunction (CodeGen r (Value a)) = IO a
type CallerResult (CodeGen r (Value a)) = r
type CallerFunction (IO a) r = CodeGen r (Value a)
call = undefined
instance CallArgs b b' r => CallArgs (a -> b) (Value a -> b') r where
type CalledFunction (Value a -> b') = a -> CalledFunction b'
type CallerResult (Value a -> b') = CallerResult b'
type CallerFunction (a -> b) r = Value a -> CallerFunction b r
call = undefined
test :: IO a -> (a -> IO ()) -> CodeGen () (Value ())
test start stop = bind (call start) (call stop)
...@@ -507,3 +507,4 @@ test('T11524', normal, compile, ['']) ...@@ -507,3 +507,4 @@ test('T11524', normal, compile, [''])
test('T11552', normal, compile, ['']) test('T11552', normal, compile, [''])
test('T11246', normal, compile, ['']) test('T11246', normal, compile, [''])
test('T11608', normal, compile, ['']) test('T11608', normal, compile, [''])
test('T11401', normal, compile, [''])
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