From ba16e1bfde86cc6d8fafa9be8a33b3b6172f262f Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Wed, 27 Aug 2008 15:33:22 +0000 Subject: [PATCH] Fix Trac #745: improve error recoevery for type signatures It turns out that fixing Trac #745 is easy using mapAndRecoverM, and tidies up the code nicely in several places. Hurrah. --- compiler/typecheck/TcBinds.lhs | 2 +- compiler/typecheck/TcInstDcls.lhs | 46 ++++++++++++++++------------------- compiler/typecheck/TcRnMonad.lhs | 2 +- compiler/typecheck/TcTyClsDecls.lhs | 8 +++--- 4 files changed, 26 insertions(+), 32 deletions(-) diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 7890091..aa179b2 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -154,7 +154,7 @@ tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside ; ty_sigs = filter isVanillaLSig sigs ; sig_fn = mkTcSigFun ty_sigs } - ; poly_ids <- mapM tcTySig ty_sigs + ; poly_ids <- checkNoErrs (mapAndRecoverM tcTySig ty_sigs) -- No recovery from bad signatures, because the type sigs -- may bind type variables, so proceeding without them -- can lead to a cascade of errors diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index fc42481..8ff44ad 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -149,13 +149,12 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- (1) Do class and family instance declarations ; let { idxty_decls = filter (isFamInstDecl . unLoc) tycl_decls } - ; local_info_tycons <- mapM tcLocalInstDecl1 inst_decls - ; idx_tycons <- mapM tcIdxTyInstDeclTL idxty_decls + ; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1 inst_decls + ; idx_tycons <- mapAndRecoverM tcIdxTyInstDeclTL idxty_decls - ; let { (local_infos, - at_tycons) = unzip local_info_tycons - ; local_info = concat local_infos - ; at_idx_tycon = concat at_tycons ++ catMaybes idx_tycons + ; let { (local_info, + at_tycons_s) = unzip local_info_tycons + ; at_idx_tycon = concat at_tycons_s ++ idx_tycons ; clas_decls = filter (isClassDecl.unLoc) tycl_decls ; implicit_things = concatMap implicitTyThings at_idx_tycon } @@ -204,12 +203,11 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls addErr $ assocInClassErr (tcdName decl) ; return tything } - isAssocFamily (Just (ATyCon tycon)) = + isAssocFamily (ATyCon tycon) = case tyConFamInst_maybe tycon of Nothing -> panic "isAssocFamily: no family?!?" Just (fam, _) -> isTyConAssoc fam - isAssocFamily (Just _ ) = panic "isAssocFamily: no tycon?!?" - isAssocFamily Nothing = False + isAssocFamily _ = panic "isAssocFamily: no tycon?!?" assocInClassErr :: Name -> SDoc assocInClassErr name = @@ -231,15 +229,13 @@ addFamInsts tycons thing_inside \begin{code} tcLocalInstDecl1 :: LInstDecl Name - -> TcM ([InstInfo Name], [TyThing]) -- [] if there was an error + -> TcM (InstInfo Name, [TyThing]) -- A source-file instance declaration -- Type-check all the stuff before the "where" -- -- We check for respectable instance type, and context tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) - = -- Prime error recovery, set source location - recoverM (return ([], [])) $ - setSrcSpan loc $ + = setSrcSpan loc $ addErrCtxt (instDeclCtxt1 poly_ty) $ do { is_boot <- tcIsHsBoot @@ -248,14 +244,16 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) ; (tyvars, theta, tau) <- tcHsInstHead poly_ty - -- Next, process any associated types. - ; idx_tycons <- mapM tcFamInstDecl ats - -- Now, check the validity of the instance. ; (clas, inst_tys) <- checkValidInstHead tau ; checkValidInstance tyvars theta clas inst_tys - ; checkValidAndMissingATs clas (tyvars, inst_tys) - (zip ats idx_tycons) + + -- Next, process any associated types. + ; idx_tycons <- recoverM (return []) $ + do { idx_tycons <- checkNoErrs $ mapAndRecoverM tcFamInstDecl ats + ; checkValidAndMissingATs clas (tyvars, inst_tys) + (zip ats idx_tycons) + ; return idx_tycons } -- Finally, construct the Core representation of the instance. -- (This no longer includes the associated types.) @@ -267,9 +265,9 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) dfun = mkDictFunId dfun_name tyvars theta' clas inst_tys ispec = mkLocalInstance dfun overlap_flag - ; return ([InstInfo { iSpec = ispec, - iBinds = VanillaInst binds uprags }], - catMaybes idx_tycons) + ; return (InstInfo { iSpec = ispec, + iBinds = VanillaInst binds uprags }, + idx_tycons) } where -- We pass in the source form and the type checked form of the ATs. We @@ -278,7 +276,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) checkValidAndMissingATs :: Class -> ([TyVar], [TcType]) -- instance types -> [(LTyClDecl Name, -- source form of AT - Maybe TyThing)] -- Core form of AT + TyThing)] -- Core form of AT -> TcM () checkValidAndMissingATs clas inst_tys ats = do { -- Issue a warning for each class AT that is not defined in this @@ -296,9 +294,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) ; mapM_ (checkIndexes clas inst_tys) ats } - checkIndexes _ _ (_, Nothing) = - return () -- skip, we already had an error here - checkIndexes clas inst_tys (hsAT, Just (ATyCon tycon)) = + checkIndexes clas inst_tys (hsAT, ATyCon tycon) = -- !!!TODO: check that this does the Right Thing for indexed synonyms, too! checkIndexes' clas inst_tys hsAT (tyConTyVars tycon, diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 2b7e567..309ce5b 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -575,7 +575,7 @@ mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b] -- Drop elements of the input that fail, so the result -- list can be shorter than the argument list mapAndRecoverM _ [] = return [] -mapAndRecoverM f (x:xs) = do { mb_r <- tryM (f x) +mapAndRecoverM f (x:xs) = do { mb_r <- try_m (f x) ; rs <- mapAndRecoverM f xs ; return (case mb_r of Left _ -> rs diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index c959233..5a2f773 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -244,10 +244,9 @@ lot of kinding and type checking code with ordinary algebraic data types (and GADTs). \begin{code} -tcFamInstDecl :: LTyClDecl Name -> TcM (Maybe TyThing) -- Nothing if error +tcFamInstDecl :: LTyClDecl Name -> TcM TyThing tcFamInstDecl (L loc decl) = -- Prime error recovery, set source location - recoverM (return Nothing) $ setSrcSpan loc $ tcAddDeclCtxt decl $ do { -- type families require -XTypeFamilies and can't be in an @@ -261,8 +260,7 @@ tcFamInstDecl (L loc decl) ; tc <- tcFamInstDecl1 decl ; checkValidTyCon tc -- Remember to check validity; -- no recursion to worry about here - ; return (Just (ATyCon tc)) - } + ; return (ATyCon tc) } tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon @@ -1076,10 +1074,10 @@ checkValidDataCon tc con = setSrcSpan (srcLocSpan (getSrcLoc con)) $ addErrCtxt (dataConCtxt con) $ do { checkTc (dataConTyCon con == tc) (badDataConTyCon con) - ; checkValidType ctxt (dataConUserType con) ; checkValidMonoType (dataConOrigResTy con) -- Disallow MkT :: T (forall a. a->a) -- Reason: it's really the argument of an equality constraint + ; checkValidType ctxt (dataConUserType con) ; when (isNewTyCon tc) (checkNewDataCon con) } where -- 1.7.10.4