In standalone deriving, we now do *not* check side conditions.
We simply generate the code and typecheck it. If there's a type
error, it's the programmer's problem.
This means that you can do 'deriving instance Show (T a)', where
T is a GADT, for example, provided of course that the boilerplate
code does in fact typecheck.
I put some work into getting a decent error message. In particular
if there's a type error in a method, GHC will show the entire code
for that method (since, after all, the user did not write it).
Most of the changes are to achieve that goal.
Still to come: changes in the documentation.
dfun_id = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
ispec = mkLocalInstance dfun_id overlap_flag
- return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds [] })
+ return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds [] False })
\end{code}
; overlap_flag <- getOverlapFlag
; let (infer_specs, given_specs) = splitEithers early_specs
- ; insts1 <- mapM (genInst overlap_flag) given_specs
+ ; insts1 <- mapM (genInst True overlap_flag) given_specs
; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $
inferInstanceContexts overlap_flag infer_specs
- ; insts2 <- mapM (genInst overlap_flag) final_specs
+ ; insts2 <- mapM (genInst False overlap_flag) final_specs
-- Generate the generic to/from functions from each type declaration
; gen_binds <- mkGenericBinds is_boot
rn_inst_info (InstInfo { iSpec = inst, iBinds = NewTypeDerived co })
= return (InstInfo { iSpec = inst, iBinds = NewTypeDerived co }, emptyFVs)
- rn_inst_info (InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs })
+ rn_inst_info (InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs standalone_deriv })
= -- Bring the right type variables into
-- scope (yuk), and rename the method binds
ASSERT( null sigs )
bindLocalNames (map Var.varName tyvars) $
do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) [] binds
- ; return (InstInfo { iSpec = inst, iBinds = VanillaInst rn_binds [] }, fvs) }
+ ; let binds' = VanillaInst rn_binds [] standalone_deriv
+ ; return (InstInfo { iSpec = inst, iBinds = binds' }, fvs) }
where
(tyvars,_,clas,_) = instanceHead inst
clas_nm = className clas
mkDataTypeEqn orig dflags tvs cls cls_tys
tycon tc_args rep_tc rep_tc_args mtheta
- = case checkSideConditions dflags cls cls_tys rep_tc of
- -- NB: pass the *representation* tycon to checkSideConditions
- CanDerive -> mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
- NonDerivableClass -> bale_out (nonStdErr cls)
- DerivableClassError msg -> bale_out msg
+ | isJust mtheta = go_for_it -- Do not test side conditions for standalone deriving
+ | otherwise = case checkSideConditions dflags cls cls_tys rep_tc of
+ -- NB: pass the *representation* tycon to checkSideConditions
+ CanDerive -> go_for_it
+ NonDerivableClass -> bale_out (nonStdErr cls)
+ DerivableClassError msg -> bale_out msg
where
+ go_for_it = mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
bale_out msg = failWithTc (derivingThingErr cls cls_tys (mkTyConApp tycon tc_args) msg)
mk_data_eqn, mk_typeable_eqn
; return (if isJust mtheta then Right spec
else Left spec) }
+ | isJust mtheta = go_for_it -- Do not check side conditions for standalone deriving
| otherwise
- = case check_conditions of
- CanDerive -> mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
- -- Use the standard H98 method
- DerivableClassError msg -> bale_out msg -- Error with standard class
+ = case checkSideConditions dflags cls cls_tys rep_tycon of
+ CanDerive -> go_for_it -- Use the standard H98 method
+ DerivableClassError msg -> bale_out msg -- Error with standard class
NonDerivableClass -- Must use newtype deriving
| newtype_deriving -> bale_out cant_derive_err -- Too hard, even with newtype deriving
| otherwise -> bale_out non_std_err -- Try newtype deriving!
where
newtype_deriving = dopt Opt_GeneralizedNewtypeDeriving dflags
- check_conditions = checkSideConditions dflags cls cls_tys rep_tycon
- bale_out msg = failWithTc (derivingThingErr cls cls_tys inst_ty msg)
+ go_for_it = mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
+ bale_out msg = failWithTc (derivingThingErr cls cls_tys inst_ty msg)
non_std_err = nonStdErr cls $$
ptext (sLit "Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension")
-- Representation tycons differ from the tycon in the instance signature in
-- case of instances for indexed families.
--
-genInst :: OverlapFlag -> DerivSpec -> TcM (InstInfo RdrName, DerivAuxBinds)
-genInst oflag spec
+genInst :: Bool -- True <=> standalone deriving
+ -> OverlapFlag
+ -> DerivSpec -> TcM (InstInfo RdrName, DerivAuxBinds)
+genInst standalone_deriv oflag spec
| ds_newtype spec
= return (InstInfo { iSpec = mkInstance oflag (ds_theta spec) spec
, iBinds = NewTypeDerived co }, [])
| otherwise
- = do { let loc = getSrcSpan (ds_name spec)
- inst = mkInstance oflag (ds_theta spec) spec
- clas = ds_cls spec
+ = do { let loc = getSrcSpan (ds_name spec)
+ inst = mkInstance oflag (ds_theta spec) spec
+ clas = ds_cls spec
-- In case of a family instance, we need to use the representation
-- tycon (after all, it has the data constructors)
; fix_env <- getFixityEnv
; let (meth_binds, aux_binds) = genDerivBinds loc fix_env clas rep_tycon
-
- -- Build the InstInfo
- ; return (InstInfo { iSpec = inst,
- iBinds = VanillaInst meth_binds [] },
- aux_binds)
+ binds = VanillaInst meth_binds [] standalone_deriv
+ ; return (InstInfo { iSpec = inst, iBinds = binds }, aux_binds)
}
where
rep_tycon = ds_tc spec
(LHsBinds a) -- Bindings for the instance methods
[LSig a] -- User pragmas recorded for generating
-- specialised instances
+ Bool -- True <=> This code came from a standalone deriving clause
| NewTypeDerived -- Used for deriving instances of newtypes, where the
CoercionI -- witness dictionary is identical to the argument
pprInstInfoDetails :: OutputableBndr a => InstInfo a -> SDoc
pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
where
- details (VanillaInst b _) = pprLHsBinds b
- details (NewTypeDerived _) = text "Derived from the representation type"
+ details (VanillaInst b _ _) = pprLHsBinds b
+ details (NewTypeDerived _) = text "Derived from the representation type"
simpleInstInfoClsTy :: InstInfo a -> (Class, Type)
simpleInstInfoClsTy info = case instanceHead (iSpec info) of
ispec = mkLocalInstance dfun overlap_flag
; return (InstInfo { iSpec = ispec,
- iBinds = VanillaInst binds uprags },
+ iBinds = VanillaInst binds uprags False },
idx_tycons)
}
where
------------------------
-- Ordinary instances
-tc_inst_decl2 dfun_id (VanillaInst monobinds uprags)
+tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv)
= do { let rigid_info = InstSkol
inst_ty = idType dfun_id
dfun_lam_vars = map instToVar dfun_dicts -- Includes equalities
prag_fn = mkPragFun uprags
loc = getSrcSpan dfun_id
- tc_meth = tcInstanceMethod loc clas inst_tyvars'
- dfun_dicts
+ tc_meth = tcInstanceMethod loc standalone_deriv
+ clas inst_tyvars' dfun_dicts
dfun_theta' inst_tys'
this_dict dfun_id
prag_fn monobinds
- Use tcValBinds to do the checking
\begin{code}
-tcInstanceMethod :: SrcSpan -> Class -> [TcTyVar] -> [Inst]
+tcInstanceMethod :: SrcSpan -> Bool -> Class -> [TcTyVar] -> [Inst]
-> TcThetaType -> [TcType]
-> Inst -> Id
-> TcPragFun -> LHsBinds Name
-- The returned inst_meth_ids all have types starting
-- forall tvs. theta => ...
-tcInstanceMethod loc clas tyvars dfun_dicts theta inst_tys
+tcInstanceMethod loc standalone_deriv clas tyvars dfun_dicts theta inst_tys
this_dict dfun_id prag_fn binds_in (sel_id, dm_info)
= do { cloned_this <- cloneDict this_dict
-- Need to clone the dict in case it is floated out, and
-- involved; otherwise overlap is not possible
-- See Note [Subtle interaction of recursion and overlap]
- tc_body rn_bind = do { (meth_id, tc_binds) <- tcInstanceMethodBody
+ tc_body rn_bind
+ = add_meth_ctxt rn_bind $
+ do { (meth_id, tc_binds) <- tcInstanceMethodBody
InstSkol clas tyvars dfun_dicts theta inst_tys
mb_this_bind sel_id
local_meth_name
meth_sig_fn meth_prag_fn rn_bind
- ; return (wrapId meth_wrapper meth_id, tc_binds) }
+ ; return (wrapId meth_wrapper meth_id, tc_binds) }
; case (findMethodBind sel_name local_meth_name binds_in, dm_info) of
-- There is a user-supplied method binding, so use it
dfun_lam_vars = map instToVar dfun_dicts
meth_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys tyvars)
+ -- For instance decls that come from standalone 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 rn_bind thing
+ | standalone_deriv = addLandmarkErrCtxt (derivBindCtxt clas inst_tys rn_bind) thing
+ | otherwise = thing
wrapId :: HsWrapper -> id -> HsExpr id
wrapId wrapper id = mkHsWrap wrapper (HsVar id)
+
+derivBindCtxt :: Class -> [Type ] -> LHsBind Name -> SDoc
+derivBindCtxt clas tys bind
+ = vcat [ ptext (sLit "When typechecking a standalone-derived method for")
+ <+> quotes (pprClassPred clas tys) <> colon
+ , nest 2 $ pprSetDepth AllTheWay $ ppr bind ]
\end{code}
Note [Default methods in instances]
where
n_pats = matchGroupArity match
doc = sep [ ptext (sLit "The lambda expression")
- <+> quotes (pprSetDepth 1 $ pprMatches (LambdaExpr :: HsMatchContext Name) match),
+ <+> quotes (pprSetDepth (PartWay 1) $
+ pprMatches (LambdaExpr :: HsMatchContext Name) match),
-- The pprSetDepth makes the abstraction print briefly
ptext (sLit "has") <+> speakNOf n_pats (ptext (sLit "argument"))]
match_ctxt = MC { mc_what = LambdaExpr,
{ ctxt <- getErrCtxt
; loc <- getSrcSpanM
; env0 <- tcInitTidyEnv
- ; ctxt_msgs <- do_ctxt env0 ctxt
- ; let real_doc = mkLocMessage loc (vcat (doc : ctxt_to_use ctxt_msgs))
+ ; err_info <- mkErrInfo env0 ctxt
+ ; let real_doc = mkLocMessage loc (doc $$ err_info)
; dumpTcRn real_doc }
dumpTcRn :: SDoc -> TcRn ()
%************************************************************************
\begin{code}
-getErrCtxt :: TcM ErrCtxt
+getErrCtxt :: TcM [ErrCtxt]
getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
-setErrCtxt :: ErrCtxt -> TcM a -> TcM a
+setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
addErrCtxt :: Message -> TcM a -> TcM a
addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a
-addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs)
+addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)
+
+addLandmarkErrCtxt :: Message -> TcM a -> TcM a
+addLandmarkErrCtxt msg = updCtxt (\ctxts -> (True, \env -> return (env,msg)) : ctxts)
-- Helper function for the above
-updCtxt :: (ErrCtxt -> ErrCtxt) -> TcM a -> TcM a
+updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
env { tcl_ctxt = upd ctxt })
addWarnTcM :: (TidyEnv, Message) -> TcM ()
addWarnTcM (env0, msg)
= do { ctxt <- getErrCtxt ;
- ctxt_msgs <- do_ctxt env0 ctxt ;
- addReport (vcat (ptext (sLit "Warning:") <+> msg : ctxt_to_use ctxt_msgs)) }
+ err_info <- mkErrInfo env0 ctxt ;
+ addReport (vcat [ptext (sLit "Warning:") <+> msg, err_info]) }
warnTc :: Bool -> Message -> TcM ()
warnTc warn_if_true warn_msg
\begin{code}
add_err_tcm :: TidyEnv -> Message -> SrcSpan
- -> [TidyEnv -> TcM (TidyEnv, SDoc)]
+ -> [ErrCtxt]
-> TcM ()
add_err_tcm tidy_env err_msg loc ctxt
- = do { ctxt_msgs <- do_ctxt tidy_env ctxt ;
- addLongErrAt loc err_msg (vcat (ctxt_to_use ctxt_msgs)) }
-
-do_ctxt :: TidyEnv -> [TidyEnv -> TcM (TidyEnv, SDoc)] -> TcM [SDoc]
-do_ctxt _ []
- = return []
-do_ctxt tidy_env (c:cs)
- = do { (tidy_env', m) <- c tidy_env ;
- ms <- do_ctxt tidy_env' cs ;
- return (m:ms) }
-
-ctxt_to_use :: [SDoc] -> [SDoc]
-ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
- | otherwise = take 3 ctxt
+ = do { err_info <- mkErrInfo tidy_env ctxt ;
+ addLongErrAt loc err_msg err_info }
+
+mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
+-- Tidy the error info, trimming excessive contexts
+mkErrInfo env ctxts
+ = go 0 env ctxts
+ where
+ go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
+ go _ _ [] = return empty
+ go n env ((is_landmark, ctxt) : ctxts)
+ | is_landmark || opt_PprStyle_Debug || n < mAX_CONTEXTS
+ = do { (env', msg) <- ctxt env
+ ; let n' = if is_landmark then n else n+1
+ ; rest <- go n' env' ctxts
+ ; return (msg $$ rest) }
+ | otherwise
+ = go n env ctxts
+
+mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts
+mAX_CONTEXTS = 3
\end{code}
debugTc is useful for monadic debugging code
-- Discarded after typecheck/rename; not passed on to desugarer
= TcLclEnv {
tcl_loc :: SrcSpan, -- Source span
- tcl_ctxt :: ErrCtxt, -- Error context
+ tcl_ctxt :: [ErrCtxt], -- Error context, innermost on top
tcl_errs :: TcRef Messages, -- Place to accumulate errors
tcl_th_ctxt :: ThStage, -- Template Haskell context
\end{code}
\begin{code}
-type ErrCtxt = [TidyEnv -> TcM (TidyEnv, Message)]
- -- Innermost first. Monadic so that we have a chance
- -- to deal with bound type variables just before error
- -- message construction
+type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, Message))
+ -- Monadic so that we have a chance
+ -- to deal with bound type variables just before error
+ -- message construction
+
+ -- Bool: True <=> this is a landmark context; do not
+ -- discard it when trimming for display
\end{code}
\begin{code}
-------------------------------------------
-data InstLoc = InstLoc InstOrigin SrcSpan ErrCtxt
+data InstLoc = InstLoc InstOrigin SrcSpan [ErrCtxt]
instLoc :: Inst -> InstLoc
instLoc inst = tci_loc inst
pprDeeperList f ds other_sty
= f ds other_sty
-pprSetDepth :: Int -> SDoc -> SDoc
-pprSetDepth n d (PprUser q _) = d (PprUser q (PartWay n))
-pprSetDepth _n d other_sty = d other_sty
+pprSetDepth :: Depth -> SDoc -> SDoc
+pprSetDepth depth doc (PprUser q _) = doc (PprUser q depth)
+pprSetDepth _depth doc other_sty = doc other_sty
getPprStyle :: (PprStyle -> SDoc) -> SDoc
getPprStyle df sty = df sty sty
projects / ghc-hetmet.git / commitdiff