Improve error messages from type-checking data constructors

This addresses Trac #2112

diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 00bc2ed..66102a6 100644 (file)
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -597,9 +597,9 @@ GADT constructor signatures
 
 \begin{code}
 tcLHsConResTy :: LHsType Name -> TcM (TyCon, [TcType])
 
 \begin{code}
 tcLHsConResTy :: LHsType Name -> TcM (TyCon, [TcType])

-tcLHsConResTy res_ty
-  = addErrCtxt (gadtResCtxt res_ty) $
-    case get_largs res_ty [] of
+tcLHsConResTy (L span res_ty)
+  = setSrcSpan span $
+    case get_args res_ty [] of

           (HsTyVar tc_name, args) 
              -> do { args' <- mapM dsHsType args
                    ; thing <- tcLookup tc_name
           (HsTyVar tc_name, args) 
              -> do { args' <- mapM dsHsType args
                    ; thing <- tcLookup tc_name

@@ -612,15 +612,11 @@ tcLHsConResTy res_ty
        -- because that causes a black hole, and for good reason.  Building
        -- the type means expanding type synonyms, and we can't do that
        -- inside the "knot".  So we have to work by steam.
        -- because that causes a black hole, and for good reason.  Building
        -- the type means expanding type synonyms, and we can't do that
        -- inside the "knot".  So we have to work by steam.

-    get_largs (L _ ty) args = get_args ty args
-    get_args (HsAppTy fun arg)                   args = get_largs fun (arg:args)
-    get_args (HsParTy ty)                        args = get_largs ty  args
+    get_args (HsAppTy (L _ fun) arg)     args = get_args fun (arg:args)
+    get_args (HsParTy (L _ ty))          args = get_args ty  args

     get_args (HsOpTy ty1 (L span tc) ty2) args = (HsTyVar tc, ty1:ty2:args)
     get_args ty                          args = (ty, args)
 
     get_args (HsOpTy ty1 (L span tc) ty2) args = (HsTyVar tc, ty1:ty2:args)
     get_args ty                          args = (ty, args)
 

-gadtResCtxt ty
-  = hang (ptext SLIT("In the result type of a data constructor:"))
-       2 (ppr ty)

 badGadtDecl ty
   = hang (ptext SLIT("Malformed constructor result type:"))
        2 (ppr ty)
 badGadtDecl ty
   = hang (ptext SLIT("Malformed constructor result type:"))
        2 (ppr ty)

diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 11e6bba..3c6c59e 100644 (file)
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -646,7 +646,7 @@ checkNoErrs main
   = do { (msgs, mb_res) <- tryTcLIE main
        ; addMessages msgs
        ; case mb_res of
   = do { (msgs, mb_res) <- tryTcLIE main
        ; addMessages msgs
        ; case mb_res of

-           Nothing   -> failM
+           Nothing  -> failM

            Just val -> return val
        } 
 
            Just val -> return val
        } 
 

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index c1e5816..f3abbe9 100644 (file)
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -812,7 +812,8 @@ tcConDecl :: Bool           -- True <=> -funbox-strict_fields
 
 tcConDecl unbox_strict existential_ok tycon tc_tvs     -- Data types
          (ConDecl name _ tvs ctxt details res_ty _)
 
 tcConDecl unbox_strict existential_ok tycon tc_tvs     -- Data types
          (ConDecl name _ tvs ctxt details res_ty _)

-  = tcTyVarBndrs tvs           $ \ tvs' -> do 
+  = addErrCtxt (dataConCtxt name)      $ 
+    tcTyVarBndrs tvs                   $ \ tvs' -> do 

     { ctxt' <- tcHsKindedContext ctxt
     ; checkTc (existential_ok || (null tvs && null (unLoc ctxt)))
              (badExistential name)
     { ctxt' <- tcHsKindedContext ctxt
     ; checkTc (existential_ok || (null tvs && null (unLoc ctxt)))
              (badExistential name)