From aa0c0de94e25aa64139688f8e4c4ba51ddca6f54 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Thu, 23 Jul 2009 13:01:45 +0000 Subject: [PATCH] Fix Trac #3012: allow more free-wheeling in standalone deriving 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. --- compiler/typecheck/TcClassDcl.lhs | 2 +- compiler/typecheck/TcDeriv.lhs | 52 +++++++++++++++++----------------- compiler/typecheck/TcEnv.lhs | 5 ++-- compiler/typecheck/TcInstDcls.lhs | 30 ++++++++++++++------ compiler/typecheck/TcMatches.lhs | 3 +- compiler/typecheck/TcRnMonad.lhs | 56 ++++++++++++++++++++++--------------- compiler/typecheck/TcRnTypes.lhs | 15 ++++++---- compiler/utils/Outputable.lhs | 6 ++-- 8 files changed, 100 insertions(+), 69 deletions(-) diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 04a9f2b..18d2022 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -533,7 +533,7 @@ mkGenericInstance clas (hs_ty, binds) = do 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} diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index e121cc6..a24f147 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -288,12 +288,12 @@ tcDeriving tycl_decls inst_decls deriv_decls ; 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 @@ -353,13 +353,14 @@ renameDeriv is_boot gen_binds insts 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 @@ -651,12 +652,14 @@ mkDataTypeEqn :: InstOrigin 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 @@ -1022,18 +1025,18 @@ mkNewTypeEqn orig dflags tvs ; 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") @@ -1347,26 +1350,25 @@ the renamer. What a great hack! -- 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 diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index d1a10cf..055fc2c 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -640,6 +640,7 @@ data InstBindings a (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 @@ -655,8 +656,8 @@ pprInstInfo info = vcat [ptext (sLit "InstInfo:") <+> ppr (idType (iDFunId info) 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 diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 3272f96..c35e2d6 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -432,7 +432,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) ispec = mkLocalInstance dfun overlap_flag ; return (InstInfo { iSpec = ispec, - iBinds = VanillaInst binds uprags }, + iBinds = VanillaInst binds uprags False }, idx_tycons) } where @@ -698,7 +698,7 @@ tc_inst_decl2 dfun_id (NewTypeDerived coi) ------------------------ -- 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 @@ -730,8 +730,8 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags) 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 @@ -814,7 +814,7 @@ tcInstanceMethod - 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 @@ -823,7 +823,7 @@ tcInstanceMethod :: SrcSpan -> Class -> [TcTyVar] -> [Inst] -- 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 @@ -838,12 +838,14 @@ tcInstanceMethod loc clas tyvars dfun_dicts theta inst_tys -- 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 @@ -901,9 +903,21 @@ tcInstanceMethod loc clas tyvars dfun_dicts theta inst_tys 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] diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index db9089c..3e0e8c0 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -110,7 +110,8 @@ tcMatchLambda match res_ty 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, diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index a8146ba..386eae8 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -363,8 +363,8 @@ traceOptTcRn flag doc = ifOptM flag $ do { 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 () @@ -681,20 +681,23 @@ failIfErrsM = ifErrsM failM (return ()) %************************************************************************ \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 }) @@ -763,8 +766,8 @@ addWarnTc msg = do { env0 <- tcInitTidyEnv 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 @@ -801,23 +804,30 @@ tcInitTidyEnv \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 diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 19432fa..fd7e954 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -333,7 +333,7 @@ data TcLclEnv -- Changes as we move inside an expression -- 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 @@ -516,10 +516,13 @@ instance Outputable RefinementVisibility where \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} @@ -876,7 +879,7 @@ functions that deal with it. \begin{code} ------------------------------------------- -data InstLoc = InstLoc InstOrigin SrcSpan ErrCtxt +data InstLoc = InstLoc InstOrigin SrcSpan [ErrCtxt] instLoc :: Inst -> InstLoc instLoc inst = tci_loc inst diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index bdad4d3..5842c63 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -229,9 +229,9 @@ pprDeeperList f ds (PprUser q (PartWay n)) 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 -- 1.7.10.4