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.

diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index 7890091..aa179b2 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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