Commit 74ae5989 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Defer errors in derived instances

Fixes Trac #9576.  Turned out to be pretty easy.
parent c23beffd
......@@ -481,7 +481,7 @@ renameDeriv is_boot inst_infos bagBinds
{ ib_binds = binds
, ib_pragmas = sigs
, ib_extensions = exts -- only for type-checking
, ib_standalone_deriving = sa } })
, ib_derived = sa } })
= -- Bring the right type variables into
-- scope (yuk), and rename the method binds
ASSERT( null sigs )
......@@ -490,7 +490,7 @@ renameDeriv is_boot inst_infos bagBinds
; let binds' = InstBindings { ib_binds = rn_binds
, ib_pragmas = []
, ib_extensions = exts
, ib_standalone_deriving = sa }
, ib_derived = sa }
; return (inst_info { iBinds = binds' }, fvs) }
where
(tyvars, _) = tcSplitForAllTys (idType (instanceDFunId inst))
......@@ -1897,9 +1897,11 @@ simplifyDeriv pred tvs theta
| otherwise = Right ct
where p = ctPred ct
-- We never want to defer these errors because they are errors in the
-- compiler! Hence the `False` below
; reportAllUnsolved (residual_wanted { wc_flat = bad })
-- If we are deferring type errors, simply ignore any insoluble
-- constraints. Tney'll come up again when we typecheck the
-- generated instance declaration
; defer <- goptM Opt_DeferTypeErrors
; unless defer (reportAllUnsolved (residual_wanted { wc_flat = bad }))
; let min_theta = mkMinimalBySCs (bagToList good)
; return (substTheta subst_skol min_theta) }
......@@ -2057,7 +2059,7 @@ genInst :: Bool -- True <=> standalone deriving
-> CommonAuxiliaries
-> DerivSpec ThetaType
-> TcM (InstInfo RdrName, BagDerivStuff, Maybe Name)
genInst standalone_deriv default_oflag comauxs
genInst _standalone_deriv default_oflag comauxs
spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args
, ds_theta = theta, ds_newtype = is_newtype, ds_tys = tys
, ds_overlap = overlap_mode
......@@ -2072,7 +2074,7 @@ genInst standalone_deriv default_oflag comauxs
, ib_pragmas = []
, ib_extensions = [ Opt_ImpredicativeTypes
, Opt_RankNTypes ]
, ib_standalone_deriving = standalone_deriv } }
, ib_derived = True } }
, emptyBag
, Just $ getName $ head $ tyConDataCons rep_tycon ) }
-- See Note [Newtype deriving and unused constructors]
......@@ -2087,7 +2089,7 @@ genInst standalone_deriv default_oflag comauxs
{ ib_binds = meth_binds
, ib_pragmas = []
, ib_extensions = []
, ib_standalone_deriving = standalone_deriv } }
, ib_derived = True } }
; return ( inst_info, deriv_stuff, Nothing ) }
where
oflag = setOverlapModeMaybe default_oflag overlap_mode
......
......@@ -724,23 +724,24 @@ iDFunId info = instanceDFunId (iSpec info)
data InstBindings a
= InstBindings
{ ib_binds :: (LHsBinds a) -- Bindings for the instance methods
, ib_pragmas :: [LSig a] -- User pragmas recorded for generating
, ib_pragmas :: [LSig a] -- User pragmas recorded for generating
-- specialised instances
, ib_extensions :: [ExtensionFlag] -- any extra extensions that should
-- be enabled when type-checking this
-- instance; needed for
-- GeneralizedNewtypeDeriving
, ib_standalone_deriving :: Bool
-- True <=> This code came from a standalone deriving clause
-- Used only to improve error messages
, ib_derived :: Bool
-- True <=> This code was generated by GHC from a deriving clause
-- or standalone deriving declaration
-- Used only to improve error messages
}
instance OutputableBndr a => Outputable (InstInfo a) where
ppr = pprInstInfoDetails
pprInstInfoDetails :: OutputableBndr a => InstInfo a -> SDoc
pprInstInfoDetails info
pprInstInfoDetails info
= hang (pprInstanceHdr (iSpec info) <+> ptext (sLit "where"))
2 (details (iBinds info))
where
......
......@@ -137,7 +137,7 @@ metaTyConsToDerivStuff tc metaDts =
d_binds = InstBindings { ib_binds = dBinds
, ib_pragmas = []
, ib_extensions = []
, ib_standalone_deriving = False }
, ib_derived = True }
d_mkInst = DerivInst (InstInfo { iSpec = d_inst, iBinds = d_binds })
-- Constructor
......@@ -147,7 +147,7 @@ metaTyConsToDerivStuff tc metaDts =
c_binds = [ InstBindings { ib_binds = c
, ib_pragmas = []
, ib_extensions = []
, ib_standalone_deriving = False }
, ib_derived = True }
| c <- cBinds ]
c_mkInst = [ DerivInst (InstInfo { iSpec = is, iBinds = bs })
| (is,bs) <- myZip1 c_insts c_binds ]
......@@ -159,7 +159,7 @@ metaTyConsToDerivStuff tc metaDts =
s_binds = [ [ InstBindings { ib_binds = s
, ib_pragmas = []
, ib_extensions = []
, ib_standalone_deriving = False }
, ib_derived = True }
| s <- ss ] | ss <- sBinds ]
s_mkInst = map (map (\(is,bs) -> DerivInst (InstInfo { iSpec = is
, iBinds = bs})))
......
......@@ -561,7 +561,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
{ ib_binds = binds
, ib_pragmas = uprags
, ib_extensions = []
, ib_standalone_deriving = False } }
, ib_derived = False } }
; return ( [inst_info], tyfam_insts0 ++ concat tyfam_insts1 ++ datafam_insts) }
......@@ -1205,8 +1205,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
op_items (InstBindings { ib_binds = binds
, ib_pragmas = sigs
, ib_extensions = exts
, ib_standalone_deriving
= standalone_deriv })
, ib_derived = is_derived })
= do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds)
; let hs_sig_fn = mkHsSigFun sigs
; checkMinimalDefinition
......@@ -1220,15 +1219,15 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
tc_item sig_fn (sel_id, dm_info)
= case findMethodBind (idName sel_id) binds of
Just (user_bind, bndr_loc)
-> tc_body sig_fn sel_id standalone_deriv user_bind bndr_loc
-> tc_body sig_fn sel_id user_bind bndr_loc
Nothing -> do { traceTc "tc_def" (ppr sel_id)
; tc_default sig_fn sel_id dm_info }
----------------------
tc_body :: HsSigFun -> Id -> Bool -> LHsBind Name
tc_body :: HsSigFun -> Id -> LHsBind Name
-> SrcSpan -> TcM (TcId, LHsBind Id)
tc_body sig_fn sel_id generated_code rn_bind bndr_loc
= add_meth_ctxt sel_id generated_code rn_bind $
tc_body sig_fn sel_id rn_bind bndr_loc
= add_meth_ctxt sel_id rn_bind $
do { traceTc "tc_item" (ppr sel_id <+> ppr (idType sel_id))
; (meth_id, local_meth_sig) <- setSrcSpan bndr_loc $
mkMethIds sig_fn clas tyvars dfun_ev_vars
......@@ -1248,8 +1247,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
tc_default sig_fn sel_id (GenDefMeth dm_name)
= do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name
; tc_body sig_fn sel_id False {- Not generated code? -}
meth_bind inst_loc }
; tc_body sig_fn sel_id meth_bind inst_loc }
tc_default sig_fn sel_id NoDefMeth -- No default method at all
= do { traceTc "tc_def: warn" (ppr sel_id)
......@@ -1331,12 +1329,12 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
inst_loc = getSrcSpan dfun_id
-- For instance decls that come from standalone deriving clauses
-- For instance decls that come from deriving clauses
-- we want to print out the full source code if there's an error
-- because otherwise the user won't see the code at all
add_meth_ctxt sel_id generated_code rn_bind thing
| generated_code = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys rn_bind) thing
| otherwise = thing
add_meth_ctxt sel_id rn_bind thing
| is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys rn_bind) thing
| otherwise = thing
----------------------
......@@ -1369,7 +1367,7 @@ wrapId wrapper id = mkHsWrap wrapper (HsVar id)
derivBindCtxt :: Id -> Class -> [Type ] -> LHsBind Name -> SDoc
derivBindCtxt sel_id clas tys _bind
= vcat [ ptext (sLit "When typechecking the code for ") <+> quotes (ppr sel_id)
, nest 2 (ptext (sLit "in a standalone derived instance for")
, nest 2 (ptext (sLit "in a derived instance for")
<+> quotes (pprClassPred clas tys) <> colon)
, nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ]
......
......@@ -9,6 +9,6 @@ T4846.hs:29:1:
In an equation for ‘mkExpr’:
mkExpr = GHC.Prim.coerce (mkExpr :: Expr Bool) :: Expr BOOL
When typechecking the code for ‘mkExpr’
in a standalone derived instance for ‘B BOOL’:
in a derived instance for ‘B BOOL’:
To see the code I am typechecking, use -ddump-deriv
In the instance declaration for ‘B BOOL’
......@@ -5,6 +5,6 @@ drvfail011.hs:8:1:
In the expression: ((a1 == b1))
In an equation for ‘==’: (==) (T1 a1) (T1 b1) = ((a1 == b1))
When typechecking the code for ‘==’
in a standalone derived instance for ‘Eq (T a)’:
in a derived instance for ‘Eq (T a)’:
To see the code I am typechecking, use -ddump-deriv
In the instance declaration for ‘Eq (T a)’
{-# OPTIONS_GHC -fdefer-type-errors #-}
module Main where
data Foo = MkFoo
data Bar = MkBar Foo deriving Show
main = do { print True; print (MkBar MkFoo) }
T9576: T9576.hs:6:31:
No instance for (Show Foo) arising from a use of ‘showsPrec’
In the second argument of ‘(.)’, namely ‘(showsPrec 11 b1)’
In the second argument of ‘showParen’, namely
‘((.) (showString "MkBar ") (showsPrec 11 b1))’
In the expression:
showParen ((a >= 11)) ((.) (showString "MkBar ") (showsPrec 11 b1))
When typechecking the code for ‘showsPrec’
in a derived instance for ‘Show Bar’:
To see the code I am typechecking, use -ddump-deriv
(deferred type error)
......@@ -36,4 +36,5 @@ test('T5628', exit_code(1), compile_and_run, [''])
test('T5712', normal, compile_and_run, [''])
test('T7931', normal, compile_and_run, [''])
test('T8280', normal, compile_and_run, [''])
test('T9576', exit_code(1), compile_and_run, [''])
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