From 44a7b9baa45c4ab939c7d996519b5e3de3e13c5a Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Tue, 24 Jul 2018 14:40:42 +0200 Subject: Suppress -Winaccessible-code in derived code Summary: It's rather unfortunate that derived code can produce inaccessible code warnings (as demonstrated in #8128, #8740, and #15398), since the programmer has no control over the generated code. This patch aims to suppress `-Winaccessible-code` in all derived code. It accomplishes this by doing the following: * Generalize the `ic_env :: TcLclEnv` field of `Implication` to be of type `Env TcGblEnc TcLclEnv` instead. This way, it also captures `DynFlags`, which record the flag state at the time the `Implication` was created. * When typechecking derived code, turn off `-Winaccessible-code`. This way, any insoluble given `Implication`s that are created when typechecking this derived code will remember that `-Winaccessible-code` was disabled. * During error reporting, consult the `DynFlags` of an `Implication` before making the decision to report an inaccessible code warning. Test Plan: make test TEST="T8128 T8740 T15398" Reviewers: simonpj, bgamari Reviewed By: simonpj Subscribers: monoidal, rwbarton, thomie, carter GHC Trac Issues: #8128, #8740, #15398 Differential Revision: https://phabricator.haskell.org/D4993 --- compiler/typecheck/TcErrors.hs | 33 +++++---- compiler/typecheck/TcInstDcls.hs | 84 ++++++++++++++++++---- compiler/typecheck/TcRnTypes.hs | 66 +++++++++++------ compiler/typecheck/TcSMonad.hs | 34 +++++---- compiler/typecheck/TcSimplify.hs | 39 +++++----- compiler/typecheck/TcUnify.hs | 38 +++++----- testsuite/tests/deriving/should_compile/T15398.hs | 20 ++++++ .../tests/deriving/should_compile/T8128.stderr | 14 ---- .../tests/deriving/should_compile/T8740.stderr | 18 ----- testsuite/tests/deriving/should_compile/all.T | 1 + 10 files changed, 209 insertions(+), 138 deletions(-) create mode 100644 testsuite/tests/deriving/should_compile/T15398.hs delete mode 100644 testsuite/tests/deriving/should_compile/T8128.stderr delete mode 100644 testsuite/tests/deriving/should_compile/T8740.stderr diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index 95dc152767..9a45d7ada0 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -387,7 +387,7 @@ reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_telescope = m_telescope , ic_given = given , ic_wanted = wanted, ic_binds = evb , ic_status = status, ic_info = info - , ic_env = tcl_env, ic_tclvl = tc_lvl }) + , ic_tclvl = tc_lvl }) | BracketSkol <- info , not insoluble = return () -- For Template Haskell brackets report only @@ -402,6 +402,7 @@ reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_telescope = m_telescope warnRedundantConstraints ctxt' tcl_env info' dead_givens ; when bad_telescope $ reportBadTelescope ctxt tcl_env m_telescope tvs } where + tcl_env = implicLclEnv implic insoluble = isInsolubleStatus status (env1, tvs') = mapAccumL tidyTyCoVarBndr (cec_tidy ctxt) tvs info' = tidySkolemInfo env1 info @@ -622,6 +623,9 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics }) find_gadt_match (implic : implics) | PatSkol {} <- ic_info implic , not (ic_no_eqs implic) + , wopt Opt_WarnInaccessibleCode (implicDynFlags implic) + -- Don't bother doing this if -Winaccessible-code isn't enabled. + -- See Note [Avoid -Winaccessible-code when deriving] in TcInstDcls. = Just implic | otherwise = find_gadt_match implics @@ -698,7 +702,7 @@ mkGivenErrorReporter :: Implication -> Reporter mkGivenErrorReporter implic ctxt cts = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct ; dflags <- getDynFlags - ; let ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (ic_env implic)) + ; let ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (implicLclEnv implic)) -- For given constraints we overwrite the env (and hence src-loc) -- with one from the implication. See Note [Inaccessible code] @@ -1233,9 +1237,9 @@ givenConstraintsMsg :: ReportErrCtxt -> SDoc givenConstraintsMsg ctxt = let constraints :: [(Type, RealSrcSpan)] constraints = - do { Implic{ ic_given = given, ic_env = env } <- cec_encl ctxt + do { implic@Implic{ ic_given = given } <- cec_encl ctxt ; constraint <- given - ; return (varType constraint, tcl_loc env) } + ; return (varType constraint, tcl_loc (implicLclEnv implic)) } pprConstraint (constraint, loc) = ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc)) @@ -1679,7 +1683,7 @@ mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2 -- Check for skolem escape | (implic:_) <- cec_encl ctxt -- Get the innermost context - , Implic { ic_env = env, ic_skols = skols, ic_info = skol_info } <- implic + , Implic { ic_skols = skols, ic_info = skol_info } <- implic , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols , not (null esc_skols) = do { let msg = important $ misMatchMsg ct oriented ty1 ty2 @@ -1697,7 +1701,8 @@ mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2 what <+> text "variables are") <+> text "bound by" , nest 2 $ ppr skol_info - , nest 2 $ text "at" <+> ppr (tcl_loc env) ] ] + , nest 2 $ text "at" <+> + ppr (tcl_loc (implicLclEnv implic)) ] ] ; mkErrorMsgFromCt ctxt ct (mconcat [msg, tv_extra, report]) } -- Nastiest case: attempt to unify an untouchable variable @@ -1706,8 +1711,7 @@ mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2 -- meta tyvar or a SigTv, else it'd have been unified -- See Note [Error messages for untouchables] | (implic:_) <- cec_encl ctxt -- Get the innermost context - , Implic { ic_env = env, ic_given = given - , ic_tclvl = lvl, ic_info = skol_info } <- implic + , Implic { ic_given = given, ic_tclvl = lvl, ic_info = skol_info } <- implic = ASSERT2( not (isTouchableMetaTyVar lvl tv1) , ppr tv1 $$ ppr lvl ) -- See Note [Error messages for untouchables] do { let msg = important $ misMatchMsg ct oriented ty1 ty2 @@ -1716,7 +1720,8 @@ mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2 sep [ quotes (ppr tv1) <+> text "is untouchable" , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given , nest 2 $ text "bound by" <+> ppr skol_info - , nest 2 $ text "at" <+> ppr (tcl_loc env) ] + , nest 2 $ text "at" <+> + ppr (tcl_loc (implicLclEnv implic)) ] tv_extra = important $ extraTyVarEqInfo ctxt tv1 ty2 add_sig = important $ suggestAddSig ctxt ty1 ty2 ; mkErrorMsgFromCt ctxt ct $ mconcat @@ -1819,11 +1824,10 @@ pp_givens givens (g:gs) -> ppr_given (text "from the context:") g : map (ppr_given (text "or from:")) gs where - ppr_given herald (Implic { ic_given = gs, ic_info = skol_info - , ic_env = env }) + ppr_given herald implic@(Implic { ic_given = gs, ic_info = skol_info }) = hang (herald <+> pprEvVarTheta gs) 2 (sep [ text "bound by" <+> ppr skol_info - , text "at" <+> ppr (tcl_loc env) ]) + , text "at" <+> ppr (tcl_loc (implicLclEnv implic)) ]) extraTyVarEqInfo :: ReportErrCtxt -> TcTyVar -> TcType -> SDoc -- Add on extra info about skolem constants @@ -2501,12 +2505,13 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over matching_givens = mapMaybe matchable useful_givens - matchable (Implic { ic_given = evvars, ic_info = skol_info, ic_env = env }) + matchable implic@(Implic { ic_given = evvars, ic_info = skol_info }) = case ev_vars_matching of [] -> Nothing _ -> Just $ hang (pprTheta ev_vars_matching) 2 (sep [ text "bound by" <+> ppr skol_info - , text "at" <+> ppr (tcl_loc env) ]) + , text "at" <+> + ppr (tcl_loc (implicLclEnv implic)) ]) where ev_vars_matching = filter ev_var_matches (map evVarPred evvars) ev_var_matches ty = case getClassPredTys_maybe ty of Just (clas', tys') diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index cee92caca8..c00841902f 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -813,15 +813,14 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) , sc_binds `unionBags` meth_binds , sc_implics `unionBags` meth_implics ) } - ; env <- getLclEnv + ; imp <- newImplication ; emitImplication $ - newImplication { ic_tclvl = tclvl - , ic_skols = inst_tyvars - , ic_given = dfun_ev_vars - , ic_wanted = mkImplicWC sc_meth_implics - , ic_binds = dfun_ev_binds_var - , ic_env = env - , ic_info = InstSkol } + imp { ic_tclvl = tclvl + , ic_skols = inst_tyvars + , ic_given = dfun_ev_vars + , ic_wanted = mkImplicWC sc_meth_implics + , ic_binds = dfun_ev_binds_var + , ic_info = InstSkol } -- Create the result bindings ; self_dict <- newDict clas inst_tys @@ -1035,14 +1034,13 @@ checkInstConstraints thing_inside thing_inside ; ev_binds_var <- newTcEvBinds - ; env <- getLclEnv - ; let implic = newImplication { ic_tclvl = tclvl - , ic_wanted = wanted - , ic_binds = ev_binds_var - , ic_env = env - , ic_info = InstSkol } + ; implic <- newImplication + ; let implic' = implic { ic_tclvl = tclvl + , ic_wanted = wanted + , ic_binds = ev_binds_var + , ic_info = InstSkol } - ; return (implic, ev_binds_var, result) } + ; return (implic', ev_binds_var, result) } {- Note [Recursive superclasses] @@ -1265,12 +1263,19 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys ; checkMinimalDefinition ; checkMethBindMembership ; (ids, binds, mb_implics) <- set_exts exts $ + unset_warnings_deriving $ mapAndUnzip3M tc_item op_items ; return (ids, listToBag binds, listToBag (catMaybes mb_implics)) } where set_exts :: [LangExt.Extension] -> TcM a -> TcM a set_exts es thing = foldr setXOptM thing es + -- See Note [Avoid -Winaccessible-code when deriving] + unset_warnings_deriving :: TcM a -> TcM a + unset_warnings_deriving + | is_derived = unsetWOptM Opt_WarnInaccessibleCode + | otherwise = id + hs_sig_fn = mkHsSigFun sigs inst_loc = getSrcSpan dfun_id @@ -1359,6 +1364,55 @@ case, Template Haskell will provide fully resolved names (e.g., `GHC.Classes.compare`), so the renamer won't notice the sleight-of-hand going on. For this reason, we also put an extra validity check for this in the typechecker as a last resort. + +Note [Avoid -Winaccessible-code when deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-Winaccessible-code can be particularly noisy when deriving instances for +GADTs. Consider the following example (adapted from #8128): + + data T a where + MkT1 :: Int -> T Int + MkT2 :: T Bool + MkT3 :: T Bool + deriving instance Eq (T a) + deriving instance Ord (T a) + +In the derived Ord instance, GHC will generate the following code: + + instance Ord (T a) where + compare x y + = case x of + MkT2 + -> case y of + MkT1 {} -> GT + MkT2 -> EQ + _ -> LT + ... + +However, that MkT1 is unreachable, since the type indices for MkT1 and MkT2 +differ, so if -Winaccessible-code is enabled, then deriving this instance will +result in unwelcome warnings. + +One conceivable approach to fixing this issue would be to change `deriving Ord` +such that it becomes smarter about not generating unreachable cases. This, +however, would be a highly nontrivial refactor, as we'd have to propagate +through typing information everywhere in the algorithm that generates Ord +instances in order to determine which cases were unreachable. This seems like +a lot of work for minimal gain, so we have opted not to go for this approach. + +Instead, we take the much simpler approach of always disabling +-Winaccessible-code for derived code. To accomplish this, we do the following: + +1. In tcMethods (which typechecks method bindings), disable + -Winaccessible-code. +2. When creating Implications during typechecking, record the Env + (through ic_env) at the time of creation. Since the Env also stores + DynFlags, this will remember that -Winaccessible-code was disabled over + the scope of that implication. +3. After typechecking comes error reporting, where GHC must decide how to + report inaccessible code to the user, on an Implication-by-Implication + basis. If an Implication's DynFlags indicate that -Winaccessible-code was + disabled, then don't bother reporting it. That's it! -} ------------------------ diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 0a443a0639..e8f0762d94 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -93,7 +93,7 @@ module TcRnTypes( isDroppableCt, insolubleImplic, arisesFromGivens, - Implication(..), newImplication, + Implication(..), newImplication, implicLclEnv, implicDynFlags, ImplicStatus(..), isInsolubleStatus, isSolvedStatus, SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth, bumpSubGoalDepth, subGoalDepthExceeded, @@ -2509,9 +2509,18 @@ data Implication ic_no_eqs :: Bool, -- True <=> ic_givens have no equalities, for sure -- False <=> ic_givens might have equalities - ic_env :: TcLclEnv, -- Gives the source location and error context - -- for the implication, and hence for all the - -- given evidence variables + ic_env :: Env TcGblEnv TcLclEnv, + -- Records the Env at the time of creation. + -- + -- This is primarly needed for the enclosed + -- TcLclEnv, which gives the source location + -- and error context for the implication, and + -- hence for all the given evidence variables. + -- + -- The enclosed DynFlags also influences error + -- reporting. See Note [Avoid + -- -Winaccessible-code when deriving] in + -- TcInstDcls. ic_wanted :: WantedConstraints, -- The wanteds -- See Invariang (WantedInf) in TcType @@ -2531,23 +2540,40 @@ data Implication ic_status :: ImplicStatus } -newImplication :: Implication +-- | Create a new 'Implication' with as many sensible defaults for its fields +-- as possible. Note that the 'ic_tclvl', 'ic_binds', and 'ic_info' fields do +-- /not/ have sensible defaults, so they are initialized with lazy thunks that +-- will 'panic' if forced, so one should take care to initialize these fields +-- after creation. +-- +-- This is monadic purely to look up the 'Env', which is used to initialize +-- 'ic_env'. +newImplication :: TcM Implication newImplication - = Implic { -- These fields must be initialisad - ic_tclvl = panic "newImplic:tclvl" - , ic_binds = panic "newImplic:binds" - , ic_info = panic "newImplic:info" - , ic_env = panic "newImplic:env" - - -- The rest have sensible default values - , ic_skols = [] - , ic_telescope = Nothing - , ic_given = [] - , ic_wanted = emptyWC - , ic_no_eqs = False - , ic_status = IC_Unsolved - , ic_need_inner = emptyVarSet - , ic_need_outer = emptyVarSet } + = do env <- getEnv + pure $ Implic { -- These fields must be initialised + ic_tclvl = panic "newImplic:tclvl" + , ic_binds = panic "newImplic:binds" + , ic_info = panic "newImplic:info" + + -- The rest have sensible default values + , ic_env = env + , ic_skols = [] + , ic_telescope = Nothing + , ic_given = [] + , ic_wanted = emptyWC + , ic_no_eqs = False + , ic_status = IC_Unsolved + , ic_need_inner = emptyVarSet + , ic_need_outer = emptyVarSet } + +-- | Retrieve the enclosed 'TcLclEnv' from an 'Implication'. +implicLclEnv :: Implication -> TcLclEnv +implicLclEnv = env_lcl . ic_env + +-- | Retrieve the enclosed 'DynFlags' from an 'Implication'. +implicDynFlags :: Implication -> DynFlags +implicDynFlags = hsc_dflags . env_top . ic_env data ImplicStatus = IC_Solved -- All wanteds in the tree are solved, all the way down diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs index 3f0db9c012..5bf5cefe01 100644 --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -2848,19 +2848,18 @@ checkTvConstraintsTcS skol_info skol_tvs (TcS thing_inside) thing_inside new_tcs_env ; unless (null wanteds) $ - do { tcl_env <- TcM.getLclEnv - ; ev_binds_var <- TcM.newNoTcEvBinds + do { ev_binds_var <- TcM.newNoTcEvBinds + ; imp <- newImplication ; let wc = emptyWC { wc_simple = wanteds } - imp = newImplication { ic_tclvl = new_tclvl - , ic_skols = skol_tvs - , ic_wanted = wc - , ic_binds = ev_binds_var - , ic_env = tcl_env - , ic_info = skol_info } + imp' = imp { ic_tclvl = new_tclvl + , ic_skols = skol_tvs + , ic_wanted = wc + , ic_binds = ev_binds_var + , ic_info = skol_info } -- Add the implication to the work-list ; TcM.updTcRef (tcs_worklist tcs_env) - (extendWorkListImplic (unitBag imp)) } + (extendWorkListImplic (unitBag imp')) } ; return res } @@ -2888,20 +2887,19 @@ checkConstraintsTcS skol_info skol_tvs given (TcS thing_inside) ; ((res, wanteds), new_tclvl) <- TcM.pushTcLevelM $ thing_inside new_tcs_env - ; tcl_env <- TcM.getLclEnv ; ev_binds_var <- TcM.newTcEvBinds + ; imp <- newImplication ; let wc = emptyWC { wc_simple = wanteds } - imp = newImplication { ic_tclvl = new_tclvl - , ic_skols = skol_tvs - , ic_given = given - , ic_wanted = wc - , ic_binds = ev_binds_var - , ic_env = tcl_env - , ic_info = skol_info } + imp' = imp { ic_tclvl = new_tclvl + , ic_skols = skol_tvs + , ic_given = given + , ic_wanted = wc + , ic_binds = ev_binds_var + , ic_info = skol_info } -- Add the implication to the work-list ; TcM.updTcRef (tcs_worklist tcs_env) - (extendWorkListImplic (unitBag imp)) + (extendWorkListImplic (unitBag imp')) ; return (res, TcEvBinds ev_binds_var) } diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs index c57ef56409..fb5a70c94c 100644 --- a/compiler/typecheck/TcSimplify.hs +++ b/compiler/typecheck/TcSimplify.hs @@ -643,13 +643,14 @@ simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds -- bindings, so we can't just revert to the input -- constraint. - ; tc_lcl_env <- TcM.getLclEnv + ; tc_env <- TcM.getEnv ; ev_binds_var <- TcM.newTcEvBinds ; psig_theta_vars <- mapM TcM.newEvVar psig_theta ; wanted_transformed_incl_derivs <- setTcLevel rhs_tclvl $ runTcSWithEvBinds ev_binds_var $ - do { let loc = mkGivenLoc rhs_tclvl UnkSkol tc_lcl_env + do { let loc = mkGivenLoc rhs_tclvl UnkSkol $ + env_lcl tc_env psig_givens = mkGivens loc psig_theta_vars ; _ <- solveSimpleGivens psig_givens -- See Note [Add signature contexts as givens] @@ -692,7 +693,7 @@ simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds | psig_theta_var <- psig_theta_vars ] -- Now we can emil the residual constraints - ; emitResidualConstraints rhs_tclvl tc_lcl_env ev_binds_var + ; emitResidualConstraints rhs_tclvl tc_env ev_binds_var name_taus co_vars qtvs bound_theta_vars (wanted_transformed `andWC` mkSimpleWC psig_wanted) @@ -710,13 +711,13 @@ simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds -------------------- -emitResidualConstraints :: TcLevel -> TcLclEnv -> EvBindsVar +emitResidualConstraints :: TcLevel -> Env TcGblEnv TcLclEnv -> EvBindsVar -> [(Name, TcTauType)] -> VarSet -> [TcTyVar] -> [EvVar] -> WantedConstraints -> TcM () -- Emit the remaining constraints from the RHS. -- See Note [Emitting the residual implication in simplifyInfer] -emitResidualConstraints rhs_tclvl tc_lcl_env ev_binds_var +emitResidualConstraints rhs_tclvl tc_env ev_binds_var name_taus co_vars qtvs full_theta_vars wanteds | isEmptyWC wanteds = return () @@ -731,21 +732,22 @@ emitResidualConstraints rhs_tclvl tc_lcl_env ev_binds_var do { traceTc "emitResidualConstrants:simple" (ppr outer_simple) ; emitSimples outer_simple } + ; implic <- newImplication ; let inner_wanted = wanteds { wc_simple = inner_simple } - implic = mk_implic inner_wanted + implic' = mk_implic inner_wanted implic ; unless (isEmptyWC inner_wanted) $ - do { traceTc "emitResidualConstraints:implic" (ppr implic) - ; emitImplication implic } + do { traceTc "emitResidualConstraints:implic" (ppr implic') + ; emitImplication implic' } } where - mk_implic inner_wanted - = newImplication { ic_tclvl = rhs_tclvl - , ic_skols = qtvs - , ic_given = full_theta_vars - , ic_wanted = inner_wanted - , ic_binds = ev_binds_var - , ic_info = skol_info - , ic_env = tc_lcl_env } + mk_implic inner_wanted implic + = implic { ic_tclvl = rhs_tclvl + , ic_skols = qtvs + , ic_given = full_theta_vars + , ic_wanted = inner_wanted + , ic_binds = ev_binds_var + , ic_info = skol_info + , ic_env = tc_env } full_theta = map idType full_theta_vars skol_info = InferSkol [ (name, mkSigmaTy [] full_theta ty) @@ -1483,8 +1485,7 @@ solveImplication imp@(Implic { ic_tclvl = tclvl , ic_given = given_ids , ic_wanted = wanteds , ic_info = info - , ic_status = status - , ic_env = env }) + , ic_status = status }) | isSolvedStatus status = return (emptyCts, Just imp) -- Do nothing @@ -1501,7 +1502,7 @@ solveImplication imp@(Implic { ic_tclvl = tclvl -- Solve the nested constraints ; (no_given_eqs, given_insols, residual_wanted) <- nestImplicTcS ev_binds_var tclvl $ - do { let loc = mkGivenLoc tclvl info env + do { let loc = mkGivenLoc tclvl info (implicLclEnv imp) givens = mkGivens loc given_ids ; solveSimpleGivens givens diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs index 31ddf0f69d..2e66d8aba5 100644 --- a/compiler/typecheck/TcUnify.hs +++ b/compiler/typecheck/TcUnify.hs @@ -1141,17 +1141,16 @@ checkTvConstraints skol_info m_telescope thing_inside ; if isEmptyWC wanted then return () - else do { tc_lcl_env <- getLclEnv - ; ev_binds <- newNoTcEvBinds + else do { ev_binds <- newNoTcEvBinds + ; implic <- newImplication ; emitImplication $ - newImplication { ic_tclvl = tclvl - , ic_skols = skol_tvs - , ic_no_eqs = True - , ic_telescope = m_telescope - , ic_wanted = wanted - , ic_binds = ev_binds - , ic_info = skol_info - , ic_env = tc_lcl_env } } + implic { ic_tclvl = tclvl + , ic_skols = skol_tvs + , ic_no_eqs = True + , ic_telescope = m_telescope + , ic_wanted = wanted + , ic_binds = ev_binds + , ic_info = skol_info } } ; return (skol_tvs, result) } @@ -1196,16 +1195,15 @@ buildImplicationFor tclvl skol_info skol_tvs given wanted -- into scope as a skolem in an implication. This is OK, though, -- because SigTvs will always remain tyvars, even after unification. do { ev_binds_var <- newTcEvBinds - ; env <- getLclEnv - ; let implic = newImplication { ic_tclvl = tclvl - , ic_skols = skol_tvs - , ic_given = given - , ic_wanted = wanted - , ic_binds = ev_binds_var - , ic_env = env - , ic_info = skol_info } - - ; return (unitBag implic, TcEvBinds ev_binds_var) } + ; implic <- newImplication + ; let implic' = implic { ic_tclvl = tclvl + , ic_skols = skol_tvs + , ic_given = given + , ic_wanted = wanted + , ic_binds = ev_binds_var + , ic_info = skol_info } + + ; return (unitBag implic', TcEvBinds ev_binds_var) } {- ************************************************************************ diff --git a/testsuite/tests/deriving/should_compile/T15398.hs b/testsuite/tests/deriving/should_compile/T15398.hs new file mode 100644 index 0000000000..b78df1fa17 --- /dev/null +++ b/testsuite/tests/deriving/should_compile/T15398.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} + +module T15398 where + +newtype Radius a = Radius a deriving (Eq, Ord) + +data CourseLine +data OpenDistance +data EndOfSpeedSection + +data Zone k a where + Point :: (Eq a, Ord a) => Zone CourseLine a + Vector :: (Eq a, Ord a) => Zone OpenDistance a + Conical :: (Eq a, Ord a) => Radius a -> Zone EndOfSpeedSection a + +deriving instance Eq a => Eq (Zone k a) +deriving instance (Eq a, Ord a) => Ord (Zone k a) diff --git a/testsuite/tests/deriving/should_compile/T8128.stderr b/testsuite/tests/deriving/should_compile/T8128.stderr deleted file mode 100644 index 5f8b1307d1..0000000000 --- a/testsuite/tests/deriving/should_compile/T8128.stderr +++ /dev/null @@ -1,14 +0,0 @@ - -T8128.hs:9:1: warning: [-Winaccessible-code (in -Wdefault)] - • Couldn't match type ‘Int’ with ‘Bool’ - Inaccessible code in - a pattern with constructor: MkT2 :: Bool -> T Bool, - in an equation for ‘showsPrec’ - • In the pattern: MkT2 b1 - In an equation for ‘showsPrec’: - showsPrec a (MkT2 b1) - = showParen (a >= 11) ((.) (showString "MkT2 ") (showsPrec 11 b1)) - When typechecking the code for ‘showsPrec’ - in a derived instance for ‘Show (T Int)’: - To see the code I am typechecking, use -ddump-deriv - In the instance declaration for ‘Show (T Int)’ diff --git a/testsuite/tests/deriving/should_compile/T8740.stderr b/testsuite/tests/deriving/should_compile/T8740.stderr deleted file mode 100644 index 9b60741027..0000000000 --- a/testsuite/tests/deriving/should_compile/T8740.stderr +++ /dev/null @@ -1,18 +0,0 @@ - -T8740.hs:17:1: warning: [-Winaccessible-code (in -Wdefault)] - • Couldn't match type ‘Reified’ with ‘Abstract’ - Inaccessible code in - a pattern with constructor: - ElectRefAsTypeOf :: forall a. - Int -> Elect Abstract a -> Elect Abstract a, - in a case alternative - • In the pattern: ElectRefAsTypeOf {} - In a case alternative: ElectRefAsTypeOf {} -> GT - In the expression: - case b of - ElectRefAsTypeOf {} -> GT - ElectHandle b1 -> (a1 `compare` b1) - _ -> LT - When typechecking the code for ‘compare’ - in a derived instance for ‘Ord (Elect p a)’: - To see the code I am typechecking, use -ddump-deriv diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T index a224871b2a..cc0730f4e0 100644 --- a/testsuite/tests/deriving/should_compile/all.T +++ b/testsuite/tests/deriving/should_compile/all.T @@ -111,3 +111,4 @@ test('T14932', normal, compile, ['']) test('T14933', normal, compile, ['']) test('T15290c', normal, compile, ['']) test('T15290d', normal, compile, ['']) +test('T15398', normal, compile, ['']) -- cgit v1.2.1