[Git][ghc/ghc][wip/derived-refactor] 4 commits: Remove unused function
Richard Eisenberg
gitlab at gitlab.haskell.org
Thu Jun 18 22:23:45 UTC 2020
Richard Eisenberg pushed to branch wip/derived-refactor at Glasgow Haskell Compiler / GHC
Commits:
97e58841 by Richard Eisenberg at 2020-06-18T12:26:58+01:00
Remove unused function
- - - - -
1aebc93a by Richard Eisenberg at 2020-06-18T12:52:01+01:00
Restore WRW stuff.
This reverts commit 15251d86871b4817aca0e0256e1cc4c691190676.
- - - - -
49bed678 by Richard Eisenberg at 2020-06-18T23:03:10+01:00
Checkpoint with CtReportAs. Good so far.
- - - - -
e091141d by Richard Eisenberg at 2020-06-18T23:23:15+01:00
typecheck/should_fail is passing. Hooray!
- - - - -
18 changed files:
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Solver/Canonical.hs
- compiler/GHC/Tc/Solver/Flatten.hs
- compiler/GHC/Tc/Solver/Interact.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Types/Constraint.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- testsuite/tests/typecheck/should_fail/ExpandSynsFail2.stderr
- testsuite/tests/typecheck/should_fail/T10619.stderr
- testsuite/tests/typecheck/should_fail/T12170a.stderr
- testsuite/tests/typecheck/should_fail/T12785b.stderr
- testsuite/tests/typecheck/should_fail/T15801.stderr
- testsuite/tests/typecheck/should_fail/T16204c.stderr
- testsuite/tests/typecheck/should_fail/T1899.stderr
- testsuite/tests/typecheck/should_fail/T2714.stderr
- testsuite/tests/typecheck/should_fail/T7748a.stderr
- testsuite/tests/typecheck/should_fail/T8450.stderr
- testsuite/tests/typecheck/should_fail/tcfail201.stderr
Changes:
=====================================
compiler/GHC/Tc/Errors.hs
=====================================
@@ -22,7 +22,7 @@ import GHC.Tc.Utils.Monad
import GHC.Tc.Types.Constraint
import GHC.Core.Predicate
import GHC.Tc.Utils.TcMType
-import GHC.Tc.Utils.Unify( occCheckForErrors, MetaTyVarUpdateResult(..) )
+import GHC.Tc.Utils.Unify( occCheckForErrors, MetaTyVarUpdateResult(..), swapOverTyVars )
import GHC.Tc.Utils.Env( tcInitTidyEnv )
import GHC.Tc.Utils.TcType
import GHC.Tc.Types.Origin
@@ -34,7 +34,7 @@ import GHC.Core.TyCo.Ppr ( pprTyVars, pprWithExplicitKindsWhen, pprSourceTyCon,
import GHC.Core.Unify ( tcMatchTys )
import GHC.Types.Module
import GHC.Tc.Instance.Family
-import GHC.Core.FamInstEnv ( flattenTys, normaliseType, topNormaliseType_maybe )
+import GHC.Core.FamInstEnv ( flattenTys )
import GHC.Tc.Utils.Instantiate
import GHC.Core.InstEnv
import GHC.Core.TyCon
@@ -42,9 +42,6 @@ import GHC.Core.Class
import GHC.Core.DataCon
import GHC.Tc.Types.Evidence
import GHC.Tc.Types.EvTerm
-import GHC.Tc.Solver.Monad ( TcS )
-import GHC.Tc.Solver.Flatten ( flattenType )
-import GHC.Tc.Solver.Interact ( withGivens )
import GHC.Hs.Binds ( PatSynBind(..) )
import GHC.Types.Name
import GHC.Types.Name.Reader ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual )
@@ -569,20 +566,28 @@ mkErrorItem ct = EI { ei_pred = tyvar_first pred
= (Nothing, ctPred ct)
-- We reorient any tyvar equalities to put the tyvar first; this
- -- allows fewer cases when choosing how to treat errors
+ -- allows fewer cases when choosing how to treat errors. Forgetting
+ -- to do this causes mischaracterization of errors.
tyvar_first pred
| Just (r, ty1, ty2) <- getEqPredTys_maybe pred
, Just (tv2, co2) <- getCastedTyVar_maybe ty2
- , Nothing <- getCastedTyVar_maybe ty1 -- no need to swap unnecessarily
- = mkPrimEqPredRole r (mkTyVarTy tv2) (ty1 `mkCastTy` mkSymCo co2)
+ = let swapped_pred = mkPrimEqPredRole r (mkTyVarTy tv2)
+ (ty1 `mkCastTy` mkSymCo co2)
+ in
+ case getCastedTyVar_maybe ty1 of
+ -- tyvar originally on right; non-tyvar originally on left: swap
+ Nothing -> swapped_pred
+ Just (tv1, _)
+ | swapOverTyVars tv1 tv2 -> swapped_pred
+ | otherwise -> pred
| otherwise
= pred
-
+{- "RAE"
tidyErrorItem :: TidyEnv -> ErrorItem -> ErrorItem
tidyErrorItem env item@(EI { ei_pred = pred })
= item { ei_pred = tidyType env pred }
-
+-}
errorItemOrigin :: ErrorItem -> CtOrigin
errorItemOrigin = ctLocOrigin . ei_loc
@@ -595,8 +600,9 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics
, wc_holes = holes })
= do { traceTc "reportWanteds 1" (vcat [ text "Simples =" <+> ppr simples
, text "Suppress =" <+> ppr (cec_suppress ctxt)
- , text "wc_holes = " <+> ppr holes ])
-
+ , text "tidy_items =" <+> ppr tidy_items
+ , text "tidy_holes =" <+> ppr tidy_holes ])
+{- "RAE"
-- rewrite all the errors with respect to the givens
; let givens = errCtxtGivens ctxt
raw_items = map mkErrorItem (bagToList simples)
@@ -613,7 +619,7 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics
tidy_holes = map (tidyHole env) rewritten_holes
; traceTc "reportWanteds 2" (vcat [ text "tidy_items =" <+> ppr tidy_items
, text "tidy_holes =" <+> ppr tidy_holes ])
-
+-}
-- First, deal with any out-of-scope errors:
; let (out_of_scope, other_holes) = partition isOutOfScopeHole tidy_holes
-- don't suppress out-of-scope errors
@@ -649,7 +655,9 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics
-- wanted insoluble here; but do suppress inner insolubles
-- if there's a *given* insoluble here (= inaccessible code)
where
- env = cec_tidy ctxt
+ env = cec_tidy ctxt
+ tidy_items = bagToList (mapBag (mkErrorItem . tidyCt env) simples)
+ tidy_holes = bagToList (mapBag (tidyHole env) holes)
-- report1: ones that should *not* be suppressed by
-- an insoluble somewhere else in the tree
@@ -3129,7 +3137,7 @@ are created by in GHC.Runtime.Heap.Inspect.zonkRTTIType.
See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint for the
motivation why we need these.
-}
-
+{- "RAE"
-- | Extract out all the givens from enclosing implications; order of
-- result does not matter.
errCtxtGivens :: ReportErrCtxt -> [Ct]
@@ -3161,3 +3169,5 @@ simplifyHole :: Hole -> TcS Hole
simplifyHole h@(Hole { hole_ty = ty, hole_loc = loc })
= do { ty' <- flattenType loc ty
; return (h { hole_ty = ty' }) }
+
+-}
=====================================
compiler/GHC/Tc/Solver/Canonical.hs
=====================================
@@ -49,6 +49,7 @@ import Data.Maybe ( isJust )
import Data.List ( zip4 )
import GHC.Types.Basic
+import qualified Data.Semigroup as S
import Data.Bifunctor ( bimap )
import Data.Foldable ( traverse_ )
@@ -204,7 +205,7 @@ canClass :: CtEvidence
canClass ev cls tys pend_sc
= -- all classes do *nominal* matching
ASSERT2( ctEvRole ev == Nominal, ppr ev $$ ppr cls $$ ppr tys )
- do { (xis, cos, _kind_co) <- flattenArgsNom ev cls_tc tys
+ do { (xis, cos, _kind_co, wrw) <- flattenArgsNom ev cls_tc tys
; MASSERT( isTcReflCo _kind_co )
; let co = mkTcTyConAppCo Nominal cls_tc cos
xi = mkClassPred cls xis
@@ -212,7 +213,7 @@ canClass ev cls tys pend_sc
, cc_tyargs = xis
, cc_class = cls
, cc_pend_sc = pend_sc }
- ; mb <- rewriteEvidence ev xi co
+ ; mb <- rewriteEvidence wrw ev xi co
; traceTcS "canClass" (vcat [ ppr ev
, ppr xi, ppr mb ])
; return (fmap mk_ct mb) }
@@ -704,8 +705,8 @@ canIrred :: CtIrredStatus -> CtEvidence -> TcS (StopOrContinue Ct)
canIrred status ev
= do { let pred = ctEvPred ev
; traceTcS "can_pred" (text "IrredPred = " <+> ppr pred)
- ; (xi,co) <- flatten FM_FlattenAll ev pred -- co :: xi ~ pred
- ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev ->
+ ; (xi,co,wrw) <- flatten FM_FlattenAll ev pred -- co :: xi ~ pred
+ ; rewriteEvidence wrw ev xi co `andWhenContinue` \ new_ev ->
do { -- Re-classify, in case flattening has improved its shape
; case classifyPredType (ctEvPred new_ev) of
ClassPred cls tys -> canClassNC new_ev cls tys
@@ -814,8 +815,8 @@ canForAll ev pend_sc
-- do them under a forall anyway (c.f. Flatten.flatten_one
-- on a forall type)
let pred = ctEvPred ev
- ; (xi,co) <- flatten FM_SubstOnly ev pred -- co :: xi ~ pred
- ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev ->
+ ; (xi,co,wrw) <- flatten FM_SubstOnly ev pred -- co :: xi ~ pred
+ ; rewriteEvidence wrw ev xi co `andWhenContinue` \ new_ev ->
do { -- Now decompose into its pieces and solve it
-- (It takes a lot less code to flatten before decomposing.)
@@ -1029,9 +1030,9 @@ can_eq_nc' True _rdr_env _envs ev eq_rel ty1 _ (AppTy t2 s2) _
-- No similarity in type structure detected. Flatten and try again.
can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2
- = do { (xi1, co1) <- flatten FM_FlattenAll ev ps_ty1
- ; (xi2, co2) <- flatten FM_FlattenAll ev ps_ty2
- ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2
+ = do { (xi1, co1, wrw1) <- flatten FM_FlattenAll ev ps_ty1
+ ; (xi2, co2, wrw2) <- flatten FM_FlattenAll ev ps_ty2
+ ; new_ev <- rewriteEqEvidence (wrw1 S.<> wrw2) ev NotSwapped xi1 xi2 co1 co2
; can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 }
-- We've flattened and the types don't match. Give up.
@@ -1363,7 +1364,7 @@ can_eq_newtype_nc ev swapped ty1 ((gres, co), ty1') ty2 ps_ty2
-- module, don't warn about it being unused.
-- See Note [Tracking unused binding and imports] in GHC.Tc.Utils.
- ; new_ev <- rewriteEqEvidence ev swapped ty1' ps_ty2
+ ; new_ev <- rewriteEqEvidence NoWRW ev swapped ty1' ps_ty2
(mkTcSymCo co) (mkTcReflCo Representational ps_ty2)
; can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 }
where
@@ -1439,7 +1440,7 @@ canEqCast flat ev eq_rel swapped ty1 co1 ty2 ps_ty2
= do { traceTcS "Decomposing cast" (vcat [ ppr ev
, ppr ty1 <+> text "|>" <+> ppr co1
, ppr ps_ty2 ])
- ; new_ev <- rewriteEqEvidence ev swapped ty1 ps_ty2
+ ; new_ev <- rewriteEqEvidence NoWRW ev swapped ty1 ps_ty2
(mkTcGReflRightCo role ty1 co1)
(mkTcReflCo role ps_ty2)
; can_eq_nc flat new_ev eq_rel ty1 ty1 ty2 ps_ty2 }
@@ -1732,14 +1733,14 @@ canEqFailure :: CtEvidence -> EqRel
canEqFailure ev NomEq ty1 ty2
= canEqHardFailure ev ty1 ty2
canEqFailure ev ReprEq ty1 ty2
- = do { (xi1, co1) <- flatten FM_FlattenAll ev ty1
- ; (xi2, co2) <- flatten FM_FlattenAll ev ty2
+ = do { (xi1, co1, wrw1) <- flatten FM_FlattenAll ev ty1
+ ; (xi2, co2, wrw2) <- flatten FM_FlattenAll ev ty2
-- We must flatten the types before putting them in the
-- inert set, so that we are sure to kick them out when
-- new equalities become available
; traceTcS "canEqFailure with ReprEq" $
vcat [ ppr ev, ppr ty1, ppr ty2, ppr xi1, ppr xi2 ]
- ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2
+ ; new_ev <- rewriteEqEvidence (wrw1 S.<> wrw2) ev NotSwapped xi1 xi2 co1 co2
; continueWith (mkIrredCt OtherCIS new_ev) }
-- | Call when canonicalizing an equality fails with utterly no hope.
@@ -1747,9 +1748,9 @@ canEqHardFailure :: CtEvidence
-> TcType -> TcType -> TcS (StopOrContinue Ct)
-- See Note [Make sure that insolubles are fully rewritten]
canEqHardFailure ev ty1 ty2
- = do { (s1, co1) <- flatten FM_SubstOnly ev ty1
- ; (s2, co2) <- flatten FM_SubstOnly ev ty2
- ; new_ev <- rewriteEqEvidence ev NotSwapped s1 s2 co1 co2
+ = do { (s1, co1, wrw1) <- flatten FM_SubstOnly ev ty1
+ ; (s2, co2, wrw2) <- flatten FM_SubstOnly ev ty2
+ ; new_ev <- rewriteEqEvidence (wrw1 S.<> wrw2) ev NotSwapped s1 s2 co1 co2
; continueWith (mkIrredCt InsolubleCIS new_ev) }
{-
@@ -1884,7 +1885,7 @@ canCFunEqCan :: CtEvidence
-- Instead, flatten the args. The RHS is an fsk, which we
-- must *not* substitute.
canCFunEqCan ev fn tys fsk
- = do { (tys', cos, kind_co) <- flattenArgsNom ev fn tys
+ = do { (tys', cos, kind_co, wrw) <- flattenArgsNom ev fn tys
-- cos :: tys' ~ tys
; let lhs_co = mkTcTyConAppCo Nominal fn cos
@@ -1892,11 +1893,13 @@ canCFunEqCan ev fn tys fsk
new_lhs = mkTyConApp fn tys'
flav = ctEvFlavour ev
+
+ report_as = updateReportAs wrw (ctEvPred ev) (ctEvReportAs ev)
; (ev', fsk')
<- if isTcReflexiveCo kind_co -- See Note [canCFunEqCan]
then do { traceTcS "canCFunEqCan: refl" (ppr new_lhs)
; let fsk_ty = mkTyVarTy fsk
- ; ev' <- rewriteEqEvidence ev NotSwapped new_lhs fsk_ty
+ ; ev' <- rewriteEqEvidence wrw ev NotSwapped new_lhs fsk_ty
lhs_co (mkTcNomReflCo fsk_ty)
; return (ev', fsk) }
else do { traceTcS "canCFunEqCan: non-refl" $
@@ -1907,7 +1910,7 @@ canCFunEqCan ev fn tys fsk
, text "New LHS" <+> hang (ppr new_lhs)
2 (dcolon <+> ppr (tcTypeKind new_lhs)) ]
; (ev', new_co, new_fsk)
- <- newFlattenSkolem flav (ctEvLoc ev) fn tys'
+ <- newFlattenSkolem flav (ctEvLoc ev) report_as fn tys'
; let xi = mkTyVarTy new_fsk `mkCastTy` kind_co
-- sym lhs_co :: F tys ~ F tys'
-- new_co :: F tys' ~ new_fsk
@@ -1967,7 +1970,9 @@ canEqTyVarHetero ev eq_rel swapped tv1 ps_tv1 ki1 xi2 ps_xi2 ki2
; traceTcS "Hetero equality gives rise to kind equality"
(ppr kind_co <+> dcolon <+> sep [ ppr ki2, text "~#", ppr ki1 ])
- ; type_ev <- rewriteEqEvidence ev swapped lhs' rhs' lhs_co rhs_co
+ -- YesWRW: we've just emitted a new wanted and rewrote with it
+ -- See Note [Equalities with incompatible kinds]
+ ; type_ev <- rewriteEqEvidence YesWRW ev swapped lhs' rhs' lhs_co rhs_co
-- rewriteEqEvidence carries out the swap, so we're NotSwapped any more
; canEqTyVarHomo type_ev eq_rel NotSwapped tv1 ps_tv1 rhs' ps_rhs' }
@@ -2022,7 +2027,7 @@ canEqTyVarHomo ev eq_rel swapped tv1 ps_xi1 xi2 _
new_rhs = mkTyVarTy tv2
rhs_co = mkTcGReflRightCo role new_rhs co2
- ; new_ev <- rewriteEqEvidence ev swapped new_lhs new_rhs lhs_co rhs_co
+ ; new_ev <- rewriteEqEvidence NoWRW ev swapped new_lhs new_rhs lhs_co rhs_co
; dflags <- getDynFlags
; canEqTyVar2 dflags new_ev eq_rel IsSwapped tv2 (ps_xi1 `mkCastTy` sym_co2) }
@@ -2054,14 +2059,14 @@ canEqTyVar2 dflags ev eq_rel swapped tv1 rhs
-- equalities, in case have x ~ (y :: ..x...)
-- #12593
-- guarantees (TyEq:OC), (TyEq:F), and (TyEq:H)
- = do { new_ev <- rewriteEqEvidence ev swapped lhs rhs' rewrite_co1 rewrite_co2
+ = do { new_ev <- rewriteEqEvidence NoWRW ev swapped lhs rhs' rewrite_co1 rewrite_co2
; continueWith (CTyEqCan { cc_ev = new_ev, cc_tyvar = tv1
, cc_rhs = rhs', cc_eq_rel = eq_rel }) }
| otherwise -- For some reason (occurs check, or forall) we can't unify
-- We must not use it for further rewriting!
= do { traceTcS "canEqTyVar2 can't unify" (ppr tv1 $$ ppr rhs)
- ; new_ev <- rewriteEqEvidence ev swapped lhs rhs rewrite_co1 rewrite_co2
+ ; new_ev <- rewriteEqEvidence NoWRW ev swapped lhs rhs rewrite_co1 rewrite_co2
; let status | isInsolubleOccursCheck eq_rel tv1 rhs
= InsolubleCIS
-- If we have a ~ [a], it is not canonical, and in particular
@@ -2293,7 +2298,10 @@ andWhenContinue tcs1 tcs2
ContinueWith ct -> tcs2 ct }
infixr 0 `andWhenContinue` -- allow chaining with ($)
-rewriteEvidence :: CtEvidence -- old evidence
+rewriteEvidence :: WRWFlag -- did wanteds rewrite wanteds?
+ -- See Note [Wanteds rewrite Wanteds]
+ -- in GHC.Tc.Types.Constraint
+ -> CtEvidence -- old evidence
-> TcPredType -- new predicate
-> TcCoercion -- Of type :: new predicate ~ <type of old evidence>
-> TcS (StopOrContinue CtEvidence)
@@ -2331,7 +2339,7 @@ as well as in old_pred; that is important for good error messages.
-}
-rewriteEvidence old_ev@(CtDerived {}) new_pred _co
+rewriteEvidence _wrw old_ev@(CtDerived {}) new_pred _co
= -- If derived, don't even look at the coercion.
-- This is very important, DO NOT re-order the equations for
-- rewriteEvidence to put the isTcReflCo test first!
@@ -2341,12 +2349,13 @@ rewriteEvidence old_ev@(CtDerived {}) new_pred _co
-- (Getting this wrong caused #7384.)
continueWith (old_ev { ctev_pred = new_pred })
-rewriteEvidence old_ev new_pred co
+rewriteEvidence _wrw old_ev new_pred co
| isTcReflCo co -- See Note [Rewriting with Refl]
= continueWith (old_ev { ctev_pred = new_pred })
-rewriteEvidence ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) new_pred co
- = do { new_ev <- newGivenEvVar loc (new_pred, new_tm)
+rewriteEvidence wrw ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) new_pred co
+ = ASSERT( wrw == NoWRW ) -- this is a Given, not a wanted
+ do { new_ev <- newGivenEvVar loc (new_pred, new_tm)
; continueWith new_ev }
where
-- mkEvCast optimises ReflCo
@@ -2354,11 +2363,12 @@ rewriteEvidence ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) new_pred c
(ctEvRole ev)
(mkTcSymCo co))
-rewriteEvidence ev@(CtWanted { ctev_dest = dest
- , ctev_nosh = si
- , ctev_loc = loc
- , ctev_report_as = report_as }) new_pred co
- = do { mb_new_ev <- newWanted_SI si loc report_as new_pred
+rewriteEvidence wrw ev@(CtWanted { ctev_pred = old_pred
+ , ctev_dest = dest
+ , ctev_nosh = si
+ , ctev_loc = loc
+ , ctev_report_as = report_as }) new_pred co
+ = do { mb_new_ev <- newWanted_SI si loc report_as' new_pred
-- The "_SI" variant ensures that we make a new Wanted
-- with the same shadow-info as the existing one
-- with the same shadow-info as the existing one (#16735)
@@ -2369,9 +2379,12 @@ rewriteEvidence ev@(CtWanted { ctev_dest = dest
; case mb_new_ev of
Fresh new_ev -> continueWith new_ev
Cached _ -> stopWith ev "Cached wanted" }
+ where
+ report_as' = updateReportAs wrw old_pred report_as
-rewriteEqEvidence :: CtEvidence -- Old evidence :: olhs ~ orhs (not swapped)
+rewriteEqEvidence :: WRWFlag -- YesWRW <=> a wanted rewrote a wanted
+ -> CtEvidence -- Old evidence :: olhs ~ orhs (not swapped)
-- or orhs ~ olhs (swapped)
-> SwapFlag
-> TcType -> TcType -- New predicate nlhs ~ nrhs
@@ -2393,7 +2406,7 @@ rewriteEqEvidence :: CtEvidence -- Old evidence :: olhs ~ orhs (not swap
-- w : orhs ~ olhs = sym rhs_co ; sym w1 ; lhs_co
--
-- It's all a form of rewwriteEvidence, specialised for equalities
-rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co
+rewriteEqEvidence wrw old_ev swapped nlhs nrhs lhs_co rhs_co
| CtDerived {} <- old_ev -- Don't force the evidence for a Derived
= return (old_ev { ctev_pred = new_pred })
@@ -2408,10 +2421,14 @@ rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co
`mkTcTransCo` mkTcSymCo rhs_co)
; newGivenEvVar loc' (new_pred, new_tm) }
- | CtWanted { ctev_dest = dest, ctev_nosh = si, ctev_report_as = report_as } <- old_ev
+ | CtWanted { ctev_pred = old_pred
+ , ctev_dest = dest
+ , ctev_nosh = si
+ , ctev_report_as = report_as } <- old_ev
+ , let report_as' = updateReportAs wrw old_pred report_as
= case dest of
HoleDest hole ->
- do { (new_ev, hole_co) <- newWantedEq_SI (ch_blocker hole) si loc' report_as
+ do { (new_ev, hole_co) <- newWantedEq_SI (ch_blocker hole) si loc' report_as'
(ctEvRole old_ev) nlhs nrhs
-- The "_SI" variant ensures that we make a new Wanted
-- with the same shadow-info as the existing one (#16735)
=====================================
compiler/GHC/Tc/Solver/Flatten.hs
=====================================
@@ -4,7 +4,7 @@
module GHC.Tc.Solver.Flatten(
FlattenMode(..),
- flatten, flattenKind, flattenArgsNom,
+ flatten, flattenArgsNom,
rewriteTyVar, flattenType,
unflattenWanteds
@@ -461,7 +461,8 @@ data FlattenEnv
-- unbanged because it's bogus in rewriteTyVar
, fe_flavour :: !CtFlavour
, fe_eq_rel :: !EqRel -- See Note [Flattener EqRels]
- , fe_work :: !FlatWorkListRef } -- See Note [The flattening work list]
+ , fe_work :: !FlatWorkListRef -- See Note [The flattening work list]
+ , fe_wrw :: !(TcRef WRWFlag) } -- See Note [Flattening wanteds]
data FlattenMode -- Postcondition for all three: inert wrt the type substitution
= FM_FlattenAll -- Postcondition: function-free
@@ -511,26 +512,30 @@ emitFlatWork ct = FlatM $ \env -> updTcRef (fe_work env) (ct :)
-- convenient wrapper when you have a CtEvidence describing
-- the flattening operation
-runFlattenCtEv :: FlattenMode -> CtEvidence -> FlatM a -> TcS a
+runFlattenCtEv :: FlattenMode -> CtEvidence -> FlatM a -> TcS (a, WRWFlag)
runFlattenCtEv mode ev
= runFlatten mode (ctEvLoc ev) (ctEvFlavour ev) (ctEvEqRel ev)
-- Run thing_inside (which does flattening), and put all
-- the work it generates onto the main work list
-- See Note [The flattening work list]
-runFlatten :: FlattenMode -> CtLoc -> CtFlavour -> EqRel -> FlatM a -> TcS a
+-- Also returns whether a wanted rewrote a wanted; see Note [Flattening wanteds]
+runFlatten :: FlattenMode -> CtLoc -> CtFlavour -> EqRel -> FlatM a -> TcS (a, WRWFlag)
runFlatten mode loc flav eq_rel thing_inside
= do { flat_ref <- newTcRef []
+ ; wrw_ref <- newTcRef NoWRW
; let fmode = FE { fe_mode = mode
, fe_loc = bumpCtLocDepth loc
-- See Note [Flatten when discharging CFunEqCan]
, fe_flavour = flav
, fe_eq_rel = eq_rel
- , fe_work = flat_ref }
+ , fe_work = flat_ref
+ , fe_wrw = wrw_ref }
; res <- runFlatM thing_inside fmode
; new_flats <- readTcRef flat_ref
; updWorkListTcS (add_flats new_flats)
- ; return res }
+ ; wrw <- readTcRef wrw_ref
+ ; return (res, wrw) }
where
add_flats new_flats wl
= wl { wl_funeqs = add_funeqs new_flats (wl_funeqs wl) }
@@ -611,6 +616,11 @@ bumpDepth (FlatM thing_inside)
{ let !env' = env { fe_loc = bumpCtLocDepth (fe_loc env) }
; thing_inside env' }
+-- See Note [Flattening wanteds]
+recordWRW :: WRWFlag -> FlatM ()
+recordWRW YesWRW = FlatM $ \env -> writeTcRef (fe_wrw env) YesWRW
+recordWRW NoWRW = return ()
+
{-
Note [The flattening work list]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -689,6 +699,20 @@ will be essentially impossible. So, the official recommendation if a
stack limit is hit is to disable the check entirely. Otherwise, there
will be baffling, unpredictable errors.
+Note [Flattening wanteds]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Wanteds rewrite wanteds] tells us that wanteds rewriting wanteds
+can lead to poor error messages. But we really need wanteds to rewrite
+wanteds in order to saturate our equalities. So, we need to know when
+we have done this step (call it w-r-w), so that we can record an ancestor
+constraint. W-r-w will happen in flattenTyVar2, deeply buried within
+the flattener algorithm. And, when flattening a large type, we might
+w-r-w several times in several different places. We thus record, in the
+FlatM monad, a WRWFlag that says whether or not any w-r-w has taken place.
+
+Then, in all calls to the flattener, we check this result and record
+the ancestor constraint if necessary. We use a mutable WRWFlag for efficiency.
+
Note [Lazy flattening]
~~~~~~~~~~~~~~~~~~~~~~
The idea of FM_Avoid mode is to flatten less aggressively. If we have
@@ -763,17 +787,23 @@ when trying to find derived equalities arising from injectivity.
-}
-- | See Note [Flattening].
--- If (xi, co) <- flatten mode ev ty, then co :: xi ~r ty
+-- If (xi, co, wrw) <- flatten mode ev ty, then co :: xi ~r ty
-- where r is the role in @ev at . If @mode@ is 'FM_FlattenAll',
-- then 'xi' is almost function-free (Note [Almost function-free]
-- in GHC.Tc.Types).
+-- wrw is True <=> a wanted rewrote a wanted.
+-- See Note [Wanteds rewrite wanteds] in GHC.Tc.Types.Constraint
+-- and Note [Flattening wanteds]
flatten :: FlattenMode -> CtEvidence -> TcType
- -> TcS (Xi, TcCoercion)
+ -> TcS (Xi, TcCoercion, WRWFlag)
flatten mode ev ty
= do { traceTcS "flatten {" (ppr mode <+> ppr ty)
- ; (ty', co) <- runFlattenCtEv mode ev (flatten_one ty)
- ; traceTcS "flatten }" (ppr ty')
- ; return (ty', co) }
+ ; ((ty', co), wrw) <- runFlattenCtEv mode ev (flatten_one ty)
+ ; traceTcS "flatten }" (ppr ty' $$ pp_wrw wrw)
+ ; return (ty', co, wrw) }
+ where
+ pp_wrw YesWRW = text "YesWRW: wanted rewrote wanted"
+ pp_wrw _ = empty
-- Apply the inert set as an *inert generalised substitution* to
-- a variable, zonking along the way.
@@ -786,28 +816,16 @@ flatten mode ev ty
rewriteTyVar :: TcTyVar -> TcS TcType
rewriteTyVar tv
= do { traceTcS "rewriteTyVar {" (ppr tv)
- ; (ty, _) <- runFlatten FM_SubstOnly fake_loc Derived NomEq $
- flattenTyVar tv
+ ; ((ty, _), _) <- runFlatten FM_SubstOnly fake_loc Derived NomEq $
+ flattenTyVar tv
; traceTcS "rewriteTyVar }" (ppr ty)
; return ty }
where
fake_loc = pprPanic "rewriteTyVar used a CtLoc" (ppr tv)
--- specialized to flattening kinds: never Derived, always Nominal
--- See Note [No derived kind equalities]
-- See Note [Flattening]
-flattenKind :: CtLoc -> CtFlavour -> TcType -> TcS (Xi, TcCoercionN)
-flattenKind loc flav ty
- = do { traceTcS "flattenKind {" (ppr flav <+> ppr ty)
- ; let flav' = case flav of
- Derived -> Wanted WDeriv -- the WDeriv/WOnly choice matters not
- _ -> flav
- ; (ty', co) <- runFlatten FM_FlattenAll loc flav' NomEq (flatten_one ty)
- ; traceTcS "flattenKind }" (ppr ty' $$ ppr co) -- co is never a panic
- ; return (ty', co) }
-
--- See Note [Flattening]
-flattenArgsNom :: CtEvidence -> TyCon -> [TcType] -> TcS ([Xi], [TcCoercion], TcCoercionN)
+flattenArgsNom :: CtEvidence -> TyCon -> [TcType]
+ -> TcS ([Xi], [TcCoercion], TcCoercionN, WRWFlag)
-- Externally-callable, hence runFlatten
-- Flatten a vector of types all at once; in fact they are
-- always the arguments of type family or class, so
@@ -818,12 +836,15 @@ flattenArgsNom :: CtEvidence -> TyCon -> [TcType] -> TcS ([Xi], [TcCoercion], Tc
--
-- For Derived constraints the returned coercion may be undefined
-- because flattening may use a Derived equality ([D] a ~ ty)
+--
+-- Final Bool returned says whether a wanted rewrote a wanted
+-- See Note [Flattening wanteds]
flattenArgsNom ev tc tys
= do { traceTcS "flatten_args {" (vcat (map ppr tys))
- ; (tys', cos, kind_co)
+ ; ((tys', cos, kind_co), wrw)
<- runFlattenCtEv FM_FlattenAll ev (flatten_args_tc tc (repeat Nominal) tys)
; traceTcS "flatten }" (vcat (map ppr tys'))
- ; return (tys', cos, kind_co) }
+ ; return (tys', cos, kind_co, wrw) }
-- | Flatten a type w.r.t. nominal equality. This is useful to rewrite
-- a type w.r.t. any givens. It does not do type-family reduction. This
@@ -832,8 +853,8 @@ flattenArgsNom ev tc tys
flattenType :: CtLoc -> TcType -> TcS TcType
flattenType loc ty
-- More info about FM_SubstOnly in Note [Holes] in GHC.Tc.Types.Constraint
- = do { (xi, _) <- runFlatten FM_SubstOnly loc Given NomEq $
- flatten_one ty
+ = do { ((xi, _), _) <- runFlatten FM_SubstOnly loc Given NomEq $
+ flatten_one ty
-- use Given flavor so that it is rewritten
-- only w.r.t. Givens, never Wanteds/Deriveds
-- (Shouldn't matter, if only Givens are present
@@ -1384,7 +1405,7 @@ flatten_fam_app tc tys -- Can be over-saturated
; flatten_app_ty_args xi1 co1 tys_rest } } }
-- the [TcType] exactly saturate the TyCon
--- See Note [flatten_exact_fam_app_fully performance]
+-- See note [flatten_exact_fam_app_fully performance]
flatten_exact_fam_app_fully :: TyCon -> [TcType] -> FlatM (Xi, Coercion)
flatten_exact_fam_app_fully tc tys
-- See Note [Reduce type family applications eagerly]
@@ -1440,7 +1461,7 @@ flatten_exact_fam_app_fully tc tys
Nothing -> do
{ loc <- getLoc
; (ev, co, fsk) <- liftTcS $
- newFlattenSkolem cur_flav loc tc xis
+ newFlattenSkolem cur_flav loc CtReportAsSame tc xis
-- The new constraint (F xis ~ fsk) is not
-- necessarily inert (e.g. the LHS may be a
@@ -1634,24 +1655,26 @@ flatten_tyvar2 tv fr@(_, eq_rel)
, cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct
, let ct_fr = (ctEvFlavour ctev, ct_eq_rel)
, ct_fr `eqCanRewriteFR` fr -- This is THE key call of eqCanRewriteFR
- -> do { traceFlat "Following inert tyvar"
- (ppr mode <+>
- ppr tv <+>
- equals <+>
- ppr rhs_ty $$ ppr ctev)
- ; let rewrite_co1 = mkSymCo (ctEvCoercion ctev)
- rewrite_co = case (ct_eq_rel, eq_rel) of
- (ReprEq, _rel) -> ASSERT( _rel == ReprEq )
- -- if this ASSERT fails, then
- -- eqCanRewriteFR answered incorrectly
- rewrite_co1
- (NomEq, NomEq) -> rewrite_co1
- (NomEq, ReprEq) -> mkSubCo rewrite_co1
-
- ; return (FTRFollowed rhs_ty rewrite_co) }
- -- NB: ct is Derived then fmode must be also, hence
- -- we are not going to touch the returned coercion
- -- so ctEvCoercion is fine.
+ -> do { let wrw = ct_fr `wantedRewriteWanted` fr
+ ; traceFlat "Following inert tyvar" $
+ vcat [ sep [ ppr mode, ppr tv, equals, ppr rhs_ty]
+ , ppr ctev
+ , text "wanted_rewrite_wanted:" <+> ppr wrw ]
+ ; recordWRW wrw
+
+ ; let rewrite_co1 = mkSymCo (ctEvCoercion ctev)
+ rewrite_co = case (ct_eq_rel, eq_rel) of
+ (ReprEq, _rel) -> ASSERT( _rel == ReprEq )
+ -- if this ASSERT fails, then
+ -- eqCanRewriteFR answered incorrectly
+ rewrite_co1
+ (NomEq, NomEq) -> rewrite_co1
+ (NomEq, ReprEq) -> mkSubCo rewrite_co1
+
+ ; return (FTRFollowed rhs_ty rewrite_co) }
+ -- NB: ct is Derived then fmode must be also, hence
+ -- we are not going to touch the returned coercion
+ -- so ctEvCoercion is fine.
_other -> return FTRNotFollowed }
=====================================
compiler/GHC/Tc/Solver/Interact.hs
=====================================
@@ -1985,7 +1985,7 @@ reduce_top_fun_eq old_ev fsk (ax_co, rhs_ty)
= ASSERT2( not (fsk `elemVarSet` tyCoVarsOfType rhs_ty)
, ppr old_ev $$ ppr rhs_ty )
-- Guaranteed by Note [FunEq occurs-check principle]
- do { (rhs_xi, flatten_co) <- flatten FM_FlattenAll old_ev rhs_ty
+ do { (rhs_xi, flatten_co, _wrw) <- flatten FM_FlattenAll old_ev rhs_ty
-- flatten_co :: rhs_xi ~ rhs_ty
-- See Note [Flatten when discharging CFunEqCan]
; let total_co = ax_co `mkTcTransCo` mkTcSymCo flatten_co
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -3201,10 +3201,10 @@ zonkTyCoVarKind tv = wrapTcS (TcM.zonkTyCoVarKind tv)
* *
********************************************************************* -}
-newFlattenSkolem :: CtFlavour -> CtLoc
+newFlattenSkolem :: CtFlavour -> CtLoc -> CtReportAs
-> TyCon -> [TcType] -- F xis
-> TcS (CtEvidence, Coercion, TcTyVar) -- [G/WD] x:: F xis ~ fsk
-newFlattenSkolem flav loc tc xis
+newFlattenSkolem flav loc report_as tc xis
= do { stuff@(ev, co, fsk) <- new_skolem
; let fsk_ty = mkTyVarTy fsk
; extendFlatCache tc xis (co, fsk_ty, ctEvFlavour ev)
@@ -3230,8 +3230,7 @@ newFlattenSkolem flav loc tc xis
= do { fmv <- wrapTcS (TcM.newFmvTyVar fam_ty)
-- See (2a) in TcCanonical
-- Note [Equalities with incompatible kinds]
- ; let pred_ty = mkPrimEqPred fam_ty (mkTyVarTy fmv)
- ; (ev, hole_co) <- newWantedEq_SI NoBlockSubst WDeriv loc CtReportAsSame
+ ; (ev, hole_co) <- newWantedEq_SI NoBlockSubst WDeriv loc report_as
Nominal fam_ty (mkTyVarTy fmv)
; return (ev, hole_co, fmv) }
=====================================
compiler/GHC/Tc/Types/Constraint.hs
=====================================
@@ -51,8 +51,10 @@ module GHC.Tc.Types.Constraint (
isWanted, isGiven, isDerived, isGivenOrWDeriv,
ctEvRole, setCtEvLoc, arisesFromGivens,
tyCoVarsOfCtEvList, tyCoVarsOfCtEv, tyCoVarsOfCtEvsList,
+ ctEvReportAs,
CtReportAs(..), ctPredToReport, substCtReportAs,
+ updateReportAs, WRWFlag(..), wantedRewriteWanted,
wrapType,
@@ -101,6 +103,7 @@ import GHC.Types.SrcLoc
import GHC.Data.Bag
import GHC.Utils.Misc
+import qualified Data.Semigroup
import Control.Monad ( msum )
{-
@@ -1410,6 +1413,17 @@ data CtReportAs
= CtReportAsSame -- just report the predicate in the Ct
| CtReportAsOther TcPredType -- report this other type
+-- | Did a wanted rewrite a wanted?
+-- See Note [Wanteds rewrite Wanteds]
+data WRWFlag
+ = YesWRW
+ | NoWRW
+ deriving Eq
+
+instance Semigroup WRWFlag where
+ NoWRW <> NoWRW = NoWRW
+ _ <> _ = YesWRW
+
data CtEvidence
= CtGiven -- Truly given, not depending on subgoals
{ ctev_pred :: TcPredType -- See Note [Ct/evidence invariant]
@@ -1482,6 +1496,12 @@ arisesFromGivens Given _ = True
arisesFromGivens (Wanted {}) _ = False
arisesFromGivens Derived loc = isGivenLoc loc
+-- | Return a 'CtReportAs' from a 'CtEvidence'. Returns
+-- 'CtReportAsSame' for non-wanteds.
+ctEvReportAs :: CtEvidence -> CtReportAs
+ctEvReportAs (CtWanted { ctev_report_as = report_as }) = report_as
+ctEvReportAs _ = CtReportAsSame
+
-- | Given the pred in a CtWanted and its 'CtReportAs', get
-- the pred to report. See Note [Wanteds rewrite Wanteds]
ctPredToReport :: TcPredType -> CtReportAs -> TcPredType
@@ -1493,6 +1513,15 @@ substCtReportAs :: TCvSubst -> CtReportAs -> CtReportAs
substCtReportAs _ CtReportAsSame = CtReportAsSame
substCtReportAs subst (CtReportAsOther pred) = CtReportAsOther (substTy subst pred)
+-- | After rewriting a Wanted, update the 'CtReportAs' for the new Wanted.
+-- If the old CtReportAs is CtReportAsSame and a wanted rewrote a wanted,
+-- record the old pred as the new CtReportAs.
+-- See Note [Wanteds rewrite Wanteds]
+updateReportAs :: WRWFlag -> TcPredType -- _old_ pred type
+ -> CtReportAs -> CtReportAs
+updateReportAs YesWRW old_pred CtReportAsSame = CtReportAsOther old_pred
+updateReportAs _ _ report_as = report_as
+
instance Outputable TcEvDest where
ppr (HoleDest h) = text "hole" <> ppr h
ppr (EvVarDest ev) = ppr ev
@@ -1501,6 +1530,10 @@ instance Outputable CtReportAs where
ppr CtReportAsSame = text "CtReportAsSame"
ppr (CtReportAsOther pred) = parens $ text "CtReportAsOther" <+> ppr pred
+instance Outputable WRWFlag where
+ ppr NoWRW = text "NoWRW"
+ ppr YesWRW = text "YesWRW"
+
instance Outputable CtEvidence where
ppr ev = ppr (ctEvFlavour ev)
<+> pp_ev
@@ -1689,6 +1722,14 @@ eqMayRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool
eqMayRewriteFR (Derived, NomEq) (Wanted WDeriv, NomEq) = True
eqMayRewriteFR fr1 fr2 = eqCanRewriteFR fr1 fr2
+-- | Checks if the first flavour rewriting the second is a wanted
+-- rewriting a wanted. See Note [Wanteds rewrite Wanteds]
+wantedRewriteWanted :: CtFlavourRole -> CtFlavourRole -> WRWFlag
+wantedRewriteWanted (Wanted _, _) _ = YesWRW
+wantedRewriteWanted _ _ = NoWRW
+ -- It doesn't matter what the second argument is; it can only
+ -- be Wanted or Derived anyway
+
-----------------
{- Note [funEqCanDischarge]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -2082,13 +2082,19 @@ zonkCtEvidence :: CtEvidence -> TcM CtEvidence
zonkCtEvidence ctev@(CtGiven { ctev_pred = pred })
= do { pred' <- zonkTcType pred
; return (ctev { ctev_pred = pred'}) }
-zonkCtEvidence ctev@(CtWanted { ctev_pred = pred, ctev_dest = dest })
+zonkCtEvidence ctev@(CtWanted { ctev_pred = pred
+ , ctev_dest = dest
+ , ctev_report_as = report_as })
= do { pred' <- zonkTcType pred
; let dest' = case dest of
EvVarDest ev -> EvVarDest $ setVarType ev pred'
-- necessary in simplifyInfer
HoleDest h -> HoleDest h
- ; return (ctev { ctev_pred = pred', ctev_dest = dest' }) }
+ ; report_as' <- case report_as of
+ CtReportAsSame -> return CtReportAsSame
+ CtReportAsOther report_pred -> CtReportAsOther <$> zonkTcType report_pred
+ ; return (ctev { ctev_pred = pred', ctev_dest = dest'
+ , ctev_report_as = report_as' }) }
zonkCtEvidence ctev@(CtDerived { ctev_pred = pred })
= do { pred' <- zonkTcType pred
; return (ctev { ctev_pred = pred' }) }
@@ -2275,6 +2281,12 @@ tidyCt env ct = ct { cc_ev = tidyCtEvidence env (ctEvidence ct) }
tidyCtEvidence :: TidyEnv -> CtEvidence -> CtEvidence
-- NB: we do not tidy the ctev_evar field because we don't
-- show it in error messages
+ -- But definitely do tidy the report_as field, as that's reported.
+tidyCtEvidence env ctev@(CtWanted { ctev_pred = pred, ctev_report_as = report_as })
+ = ctev { ctev_pred = tidyType env pred, ctev_report_as = tidy_report_as report_as }
+ where tidy_report_as CtReportAsSame = CtReportAsSame
+ tidy_report_as (CtReportAsOther report_pred)
+ = CtReportAsOther (tidyType env report_pred)
tidyCtEvidence env ctev = ctev { ctev_pred = tidyType env ty }
where
ty = ctev_pred ctev
=====================================
testsuite/tests/typecheck/should_fail/ExpandSynsFail2.stderr
=====================================
@@ -1,6 +1,6 @@
ExpandSynsFail2.hs:19:37: error:
- • Couldn't match type ‘Foo’ with ‘Bar’
+ • Couldn't match type ‘Int’ with ‘Bool’
Expected type: ST s Foo
Actual type: MyBarST s
Type synonyms expanded:
=====================================
testsuite/tests/typecheck/should_fail/T10619.stderr
=====================================
@@ -1,6 +1,6 @@
T10619.hs:9:15: error:
- • Couldn't match type ‘b -> b’ with ‘forall a. a -> a’
+ • Couldn't match type ‘forall a. a -> a’ with ‘b -> b’
Expected type: (b -> b) -> b -> b
Actual type: (forall a. a -> a) -> b -> b
• In the expression:
@@ -20,7 +20,7 @@ T10619.hs:9:15: error:
foo :: p -> (b -> b) -> b -> b (bound at T10619.hs:8:1)
T10619.hs:14:15: error:
- • Couldn't match type ‘b -> b’ with ‘forall a. a -> a’
+ • Couldn't match type ‘forall a. a -> a’ with ‘b -> b’
Expected type: (b -> b) -> b -> b
Actual type: (forall a. a -> a) -> b -> b
• In the expression:
@@ -40,7 +40,7 @@ T10619.hs:14:15: error:
bar :: p -> (b -> b) -> b -> b (bound at T10619.hs:12:1)
T10619.hs:16:13: error:
- • Couldn't match type ‘b -> b’ with ‘forall a. a -> a’
+ • Couldn't match type ‘forall a. a -> a’ with ‘b -> b’
Expected type: (b -> b) -> b -> b
Actual type: (forall a. a -> a) -> b -> b
• In the expression:
@@ -51,7 +51,7 @@ T10619.hs:16:13: error:
baz :: Bool -> (b -> b) -> b -> b (bound at T10619.hs:16:1)
T10619.hs:20:14: error:
- • Couldn't match type ‘b -> b’ with ‘forall a. a -> a’
+ • Couldn't match type ‘forall a. a -> a’ with ‘b -> b’
Expected type: (b -> b) -> b -> b
Actual type: (forall a. a -> a) -> b -> b
• In the expression:
=====================================
testsuite/tests/typecheck/should_fail/T12170a.stderr
=====================================
@@ -6,4 +6,4 @@ T12170a.hs:20:7: error:
The type variable ‘m0’ is ambiguous
• In the first argument of ‘(>>=)’, namely ‘newRef (pure ())’
In the expression: newRef (pure ()) >>= join . readRef
- In an equation for ‘foo’: foo = newRef (pure ()) >>= join . readRef
+ In an equation for ‘foo’: foo = newRef (pure ()) >>= join . readRef
\ No newline at end of file
=====================================
testsuite/tests/typecheck/should_fail/T12785b.stderr
=====================================
@@ -1,6 +1,6 @@
T12785b.hs:29:65: error:
- • Could not deduce: Payload ('S n) (Payload n s1) ~ s
+ • Could not deduce: s ~ Payload ('S n) (Payload n s1)
arising from a use of ‘SBranchX’
from the context: m ~ 'S n
bound by a pattern with constructor:
=====================================
testsuite/tests/typecheck/should_fail/T15801.stderr
=====================================
@@ -1,6 +1,6 @@
T15801.hs:52:10: error:
- • Couldn't match representation of type ‘op_a --> b’
- with that of ‘UnOp op_a -> UnOp b’
+ • Couldn't match representation of type ‘UnOp op_a -> UnOp b’
+ with that of ‘op_a --> b’
arising from the superclasses of an instance declaration
• In the instance declaration for ‘OpRíki (Op (*))’
=====================================
testsuite/tests/typecheck/should_fail/T16204c.stderr
=====================================
@@ -1,6 +1,6 @@
T16204c.hs:16:8: error:
- • Couldn't match kind ‘*’ with ‘Rep’
+ • Couldn't match kind ‘Rep’ with ‘*’
When matching types
a0 :: Rep
a :: *
=====================================
testsuite/tests/typecheck/should_fail/T1899.stderr
=====================================
@@ -1,15 +1,24 @@
-T1899.hs:14:36: error:
+T1899.hs:12:13: error:
• Couldn't match type ‘a’ with ‘Proposition a0’
‘a’ is a rigid type variable bound by
the type signature for:
transRHS :: forall a. [a] -> Int -> Constraint a
at T1899.hs:9:2-39
- Expected type: [Proposition a0]
- Actual type: [a]
- • In the first argument of ‘Auxiliary’, namely ‘varSet’
- In the first argument of ‘Prop’, namely ‘(Auxiliary varSet)’
- In the expression: Prop (Auxiliary varSet)
+ Expected type: Constraint a
+ Actual type: Constraint (Proposition a0)
+ • In the expression: Formula [[Prop (Auxiliary undefined)]]
+ In the expression:
+ if b < 0 then
+ Formula [[Prop (Auxiliary undefined)]]
+ else
+ Formula $ [[Prop (Auxiliary varSet), Prop (Auxiliary varSet)]]
+ In an equation for ‘transRHS’:
+ transRHS varSet b
+ = if b < 0 then
+ Formula [[Prop (Auxiliary undefined)]]
+ else
+ Formula $ [[Prop (Auxiliary varSet), ....]]
• Relevant bindings include
varSet :: [a] (bound at T1899.hs:10:11)
transRHS :: [a] -> Int -> Constraint a (bound at T1899.hs:10:2)
=====================================
testsuite/tests/typecheck/should_fail/T2714.stderr
=====================================
@@ -1,10 +1,10 @@
T2714.hs:8:5: error:
- • Couldn't match type ‘c’ with ‘f0 (a -> b)’
- ‘c’ is a rigid type variable bound by
+ • Couldn't match type ‘a’ with ‘f0 b’
+ ‘a’ is a rigid type variable bound by
the type signature for:
- f :: ((a -> b) -> b) -> forall c. c -> a
- at T2714.hs:8:1-9
+ f :: forall a b. ((a -> b) -> b) -> forall c. c -> a
+ at T2714.hs:7:1-42
Expected type: ((a -> b) -> b) -> c -> a
Actual type: ((a -> b) -> b) -> f0 (a -> b) -> f0 b
• In the expression: ffmap
=====================================
testsuite/tests/typecheck/should_fail/T7748a.stderr
=====================================
@@ -1,13 +1,13 @@
-T7748a.hs:16:24: error:
+T7748a.hs:14:24: error:
• Couldn't match expected type ‘a’
with actual type ‘Maybe (Maybe (r -> ()))’
‘a’ is a rigid type variable bound by
the type signature for:
test :: forall a r. a -> r -> ()
at T7748a.hs:11:1-20
- • In the pattern: Just (Just p)
- In a case alternative: Just (Just p) -> p
+ • In the pattern: Nothing
+ In a case alternative: Nothing -> const ()
In the expression:
case zd of
Nothing -> const ()
=====================================
testsuite/tests/typecheck/should_fail/T8450.stderr
=====================================
@@ -1,15 +1,11 @@
-T8450.hs:8:20: error:
- • Couldn't match type ‘a’ with ‘Bool’
+T8450.hs:8:7: error:
+ • Couldn't match expected type ‘a’ with actual type ‘()’
‘a’ is a rigid type variable bound by
the type signature for:
run :: forall a. a
at T8450.hs:7:1-18
- Expected type: Either Bool ()
- Actual type: Either a ()
- • In the second argument of ‘($)’, namely
- ‘(undefined :: Either a ())’
- In the expression: runEffect $ (undefined :: Either a ())
+ • In the expression: runEffect $ (undefined :: Either a ())
In an equation for ‘run’:
run = runEffect $ (undefined :: Either a ())
• Relevant bindings include run :: a (bound at T8450.hs:8:1)
=====================================
testsuite/tests/typecheck/should_fail/tcfail201.stderr
=====================================
@@ -1,15 +1,13 @@
-tcfail201.hs:17:56: error:
- • Couldn't match type ‘a’ with ‘HsDoc id0’
+tcfail201.hs:17:27: error:
+ • Couldn't match expected type ‘a’ with actual type ‘HsDoc id0’
‘a’ is a rigid type variable bound by
the type signature for:
gfoldl' :: forall (c :: * -> *) a.
(forall a1 b. c (a1 -> b) -> a1 -> c b)
-> (forall g. g -> c g) -> a -> c a
at tcfail201.hs:15:1-85
- Expected type: c a
- Actual type: c (HsDoc id0)
- • In the expression: z DocEmpty
+ • In the pattern: DocEmpty
In a case alternative: DocEmpty -> z DocEmpty
In the expression: case hsDoc of { DocEmpty -> z DocEmpty }
• Relevant bindings include
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/609563362994f3a6704308a73779ac0d29c58557...e091141d11228f719a56681736d5c2d75e760407
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/609563362994f3a6704308a73779ac0d29c58557...e091141d11228f719a56681736d5c2d75e760407
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200618/b9479c51/attachment-0001.html>
More information about the ghc-commits
mailing list