Improve error reporting for non-rigid GADT matches

Following suggestions from users, this patch improves the error message
when a GADT match needs a rigid type:

 tcfail172.hs:19:10:
     GADT pattern match in non-rigid context for `Nil'
-      Solution: add a type signature
+      Probable solution: add a type signature for `is_normal'
     In the pattern: Nil
     In the definition of `is_normal': is_normal Nil = True

Now GHC tries to tell you what to give a type signature *for*.
Thanks to Daniel Gorin and others for the suggestions.

diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index bcc5084..66336b6 100644 (file)
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -1020,10 +1020,10 @@ pp_dotdot = ptext (sLit " .. ")
 \begin{code}
 data HsMatchContext id  -- Context of a Match
   = FunRhs id Bool              -- Function binding for f; True <=> written infix
 \begin{code}
 data HsMatchContext id  -- Context of a Match
   = FunRhs id Bool              -- Function binding for f; True <=> written infix

-  | CaseAlt                     -- Guard on a case alternative
-  | LambdaExpr                  -- Pattern of a lambda
-  | ProcExpr                    -- Pattern of a proc
-  | PatBindRhs                  -- Pattern binding
+  | CaseAlt                     -- Patterns and guards on a case alternative
+  | LambdaExpr                  -- Patterns of a lambda
+  | ProcExpr                    -- Patterns of a proc
+  | PatBindRhs                  -- Patterns in the *guards* of a pattern binding

   | RecUpd                      -- Record update [used only in DsExpr to
                                 --    tell matchWrapper what sort of
                                 --    runtime error message to generate]
   | RecUpd                      -- Record update [used only in DsExpr to
                                 --    tell matchWrapper what sort of
                                 --    runtime error message to generate]

diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs
index 4593482..ee14eb8 100644 (file)
--- a/compiler/typecheck/TcArrows.lhs
+++ b/compiler/typecheck/TcArrows.lhs
@@ -53,7 +53,7 @@ tcProc pat cmd exp_ty
     do { ((exp_ty1, res_ty), coi) <- boxySplitAppTy exp_ty 
        ; ((arr_ty, arg_ty), coi1) <- boxySplitAppTy exp_ty1
        ; let cmd_env = CmdEnv { cmd_arr = arr_ty }
     do { ((exp_ty1, res_ty), coi) <- boxySplitAppTy exp_ty 
        ; ((arr_ty, arg_ty), coi1) <- boxySplitAppTy exp_ty1
        ; let cmd_env = CmdEnv { cmd_arr = arr_ty }

-       ; (pat', cmd') <- tcProcPat pat arg_ty res_ty $
+       ; (pat', cmd') <- tcPat ProcExpr pat arg_ty res_ty $

                          tcCmdTop cmd_env cmd []
         ; let res_coi = mkTransCoI coi (mkAppTyCoI exp_ty1 coi1 res_ty IdCo)
        ; return (pat', cmd', res_coi) 
                          tcCmdTop cmd_env cmd []
         ; let res_coi = mkTransCoI coi (mkAppTyCoI exp_ty1 coi1 res_ty IdCo)
        ; return (pat', cmd', res_coi) 

@@ -186,8 +186,8 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig
                  (kappaUnderflow cmd)
 
                -- Check the patterns, and the GRHSs inside
                  (kappaUnderflow cmd)
 
                -- Check the patterns, and the GRHSs inside

-       ; (pats', grhss') <- setSrcSpan mtch_loc                $
-                            tcLamPats pats cmd_stk res_ty      $
+       ; (pats', grhss') <- setSrcSpan mtch_loc                        $
+                            tcPats LambdaExpr pats cmd_stk res_ty      $

                             tc_grhss grhss
 
        ; let match' = L mtch_loc (Match pats' Nothing grhss')
                             tc_grhss grhss
 
        ; let match' = L mtch_loc (Match pats' Nothing grhss')

diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs
index 4748901..db9089c 100644 (file)
--- a/compiler/typecheck/TcMatches.lhs
+++ b/compiler/typecheck/TcMatches.lhs
@@ -166,7 +166,7 @@ tcMatch ctxt pat_tys rhs_ty match
   where
     tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
       = add_match_ctxt match $
   where
     tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
       = add_match_ctxt match $

-        do { (pats', grhss') <- tcLamPats pats pat_tys rhs_ty $
+        do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys rhs_ty $

                                tc_grhss ctxt maybe_rhs_sig grhss
           ; return (Match pats' Nothing grhss') }
 
                                tc_grhss ctxt maybe_rhs_sig grhss
           ; return (Match pats' Nothing grhss') }
 

@@ -326,9 +326,9 @@ tcGuardStmt _ (ExprStmt guard _ _) res_ty thing_inside
        ; thing  <- thing_inside res_ty
        ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
 
        ; thing  <- thing_inside res_ty
        ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
 

-tcGuardStmt _ (BindStmt pat rhs _ _) res_ty thing_inside
+tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside

   = do { (rhs', rhs_ty) <- tcInferRhoNC rhs    -- Stmt has a context already
   = do { (rhs', rhs_ty) <- tcInferRhoNC rhs    -- Stmt has a context already

-       ; (pat', thing)  <- tcLamPat pat rhs_ty res_ty thing_inside
+       ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat rhs_ty res_ty thing_inside

        ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 
 tcGuardStmt _ stmt _ _
        ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 
 tcGuardStmt _ stmt _ _

@@ -342,10 +342,10 @@ tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray)
         -> TcStmtChecker
 
 -- A generator, pat <- rhs
         -> TcStmtChecker
 
 -- A generator, pat <- rhs

-tcLcStmt m_tc _ (BindStmt pat rhs _ _) res_ty thing_inside
+tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside

  = do  { (rhs', pat_ty) <- withBox liftedTypeKind $ \ ty ->
                            tcMonoExpr rhs (mkTyConApp m_tc [ty])
  = do  { (rhs', pat_ty) <- withBox liftedTypeKind $ \ ty ->
                            tcMonoExpr rhs (mkTyConApp m_tc [ty])

-       ; (pat', thing)  <- tcLamPat pat pat_ty res_ty thing_inside
+       ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty thing_inside

        ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 
 -- A boolean guard
        ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 
 -- A boolean guard

@@ -463,7 +463,7 @@ tcLcStmt _ _ stmt _ _
 
 tcDoStmt :: TcStmtChecker
 
 
 tcDoStmt :: TcStmtChecker
 

-tcDoStmt _ (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
+tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside

   = do { (rhs', rhs_ty) <- tcInferRhoNC rhs
                -- We should use type *inference* for the RHS computations, 
                 -- becuase of GADTs. 
   = do { (rhs', rhs_ty) <- tcInferRhoNC rhs
                -- We should use type *inference* for the RHS computations, 
                 -- becuase of GADTs. 

@@ -489,7 +489,7 @@ tcDoStmt _ (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
                      then return noSyntaxExpr
                      else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
 
                      then return noSyntaxExpr
                      else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
 

-       ; (pat', thing) <- tcLamPat pat pat_ty new_res_ty thing_inside
+       ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty new_res_ty thing_inside

 
        ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
 
 
        ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
 

@@ -522,9 +522,9 @@ tcDoStmt _ stmt _ _
 
 tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType))      -- RHS inference
          -> TcStmtChecker
 
 tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType))      -- RHS inference
          -> TcStmtChecker

-tcMDoStmt tc_rhs _ (BindStmt pat rhs _ _) res_ty thing_inside
+tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside

   = do { (rhs', pat_ty) <- tc_rhs rhs
   = do { (rhs', pat_ty) <- tc_rhs rhs

-       ; (pat', thing)  <- tcLamPat pat pat_ty res_ty thing_inside
+       ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty thing_inside

        ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 
 tcMDoStmt tc_rhs _ (ExprStmt rhs _ _) res_ty thing_inside
        ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 
 tcMDoStmt tc_rhs _ (ExprStmt rhs _ _) res_ty thing_inside

diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index 984b2e5..b8bbed7 100644 (file)
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -6,7 +6,7 @@
 TcPat: Typechecking patterns
 
 \begin{code}
 TcPat: Typechecking patterns
 
 \begin{code}

-module TcPat ( tcLetPat, tcLamPat, tcLamPats, tcProcPat, tcOverloadedLit,
+module TcPat ( tcLetPat, tcPat, tcPats, tcOverloadedLit,

               addDataConStupidTheta, badFieldCon, polyPatSig ) where
 
 #include "HsVersions.h"
               addDataConStupidTheta, badFieldCon, polyPatSig ) where
 
 #include "HsVersions.h"

@@ -70,11 +70,12 @@ tcLetPat sig_fn pat pat_ty thing_inside
        ; return (pat', res) }
 
 -----------------
        ; return (pat', res) }
 
 -----------------

-tcLamPats :: [LPat Name]               -- Patterns,
-         -> [BoxySigmaType]            --   and their types
-         -> BoxyRhoType                -- Result type,
-         -> (BoxyRhoType -> TcM a)     --   and the checker for the body
-         -> TcM ([LPat TcId], a)
+tcPats :: HsMatchContext Name
+       -> [LPat Name]           -- Patterns,
+       -> [BoxySigmaType]       --   and their types
+       -> BoxyRhoType           -- Result type,
+       -> (BoxyRhoType -> TcM a) --   and the checker for the body
+       -> TcM ([LPat TcId], a)

 
 -- This is the externally-callable wrapper function
 -- Typecheck the patterns, extend the environment to bind the variables,
 
 -- This is the externally-callable wrapper function
 -- Typecheck the patterns, extend the environment to bind the variables,

@@ -87,17 +88,17 @@ tcLamPats :: [LPat Name]            -- Patterns,
 --   3. Check the body
 --   4. Check that no existentials escape
 
 --   3. Check the body
 --   4. Check that no existentials escape
 

-tcLamPats pats tys res_ty thing_inside
-  = tc_lam_pats LamPat (zipEqual "tcLamPats" pats tys)
+tcPats ctxt pats tys res_ty thing_inside
+  = tc_lam_pats (APat ctxt) (zipEqual "tcLamPats" pats tys)

                res_ty thing_inside
 
                res_ty thing_inside
 

-tcLamPat, tcProcPat :: LPat Name -> BoxySigmaType 
-                    -> BoxyRhoType             -- Result type
-                    -> (BoxyRhoType -> TcM a)  -- Checker for body, given
-                                               -- its result type
-                    -> TcM (LPat TcId, a)
-tcLamPat  = tc_lam_pat LamPat
-tcProcPat = tc_lam_pat ProcPat
+tcPat :: HsMatchContext Name
+      -> LPat Name -> BoxySigmaType 
+      -> BoxyRhoType             -- Result type
+      -> (BoxyRhoType -> TcM a)  -- Checker for body, given
+                                 -- its result type
+      -> TcM (LPat TcId, a)
+tcPat ctxt = tc_lam_pat (APat ctxt)

 
 tc_lam_pat :: PatCtxt -> LPat Name -> BoxySigmaType -> BoxyRhoType
            -> (BoxyRhoType -> TcM a) -> TcM (LPat TcId, a)
 
 tc_lam_pat :: PatCtxt -> LPat Name -> BoxySigmaType -> BoxyRhoType
            -> (BoxyRhoType -> TcM a) -> TcM (LPat TcId, a)

@@ -117,7 +118,7 @@ tc_lam_pats ctxt pat_ty_prs res_ty thing_inside
        ; (pats', ex_tvs, res) <- do { traceTc (text "tc_lam_pats" <+> (ppr pat_ty_prs $$ ppr res_ty)) 
                                  ; tcMultiple tc_lpat_pr pat_ty_prs init_state $ \ pstate' ->
                                    if (pat_eqs pstate' && (not $ isRigidTy res_ty))
        ; (pats', ex_tvs, res) <- do { traceTc (text "tc_lam_pats" <+> (ppr pat_ty_prs $$ ppr res_ty)) 
                                  ; tcMultiple tc_lpat_pr pat_ty_prs init_state $ \ pstate' ->
                                    if (pat_eqs pstate' && (not $ isRigidTy res_ty))

-                                    then nonRigidResult res_ty
+                                    then nonRigidResult ctxt res_ty

                                     else thing_inside res_ty }
 
        ; let tys = map snd pat_ty_prs
                                     else thing_inside res_ty }
 
        ; let tys = map snd pat_ty_prs

@@ -154,11 +155,13 @@ data PatState = PS {
   }
 
 data PatCtxt 
   }
 
 data PatCtxt 

-  = LamPat 
-  | ProcPat                            -- The pattern in (proc pat -> ...)
-                                       --      see Note [Arrows and patterns]
+  = APat (HsMatchContext Name)

   | LetPat (Name -> Maybe TcRhoType)   -- Used for let(rec) bindings
 
   | LetPat (Name -> Maybe TcRhoType)   -- Used for let(rec) bindings
 

+notProcPat :: PatCtxt -> Bool
+notProcPat (APat ProcExpr) = False
+notProcPat _              = True
+

 patSigCtxt :: PatState -> UserTypeCtxt
 patSigCtxt (PS { pat_ctxt = LetPat _ }) = BindPatSigCtxt
 patSigCtxt _                            = LamPatSigCtxt
 patSigCtxt :: PatState -> UserTypeCtxt
 patSigCtxt (PS { pat_ctxt = LetPat _ }) = BindPatSigCtxt
 patSigCtxt _                            = LamPatSigCtxt

@@ -647,8 +650,9 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
 
          else do   -- The general case, with existential, and local equality 
                     -- constraints
 
          else do   -- The general case, with existential, and local equality 
                     -- constraints

-       { checkTc (case pat_ctxt pstate of { ProcPat -> False; _ -> True })
+       { checkTc (notProcPat (pat_ctxt pstate))

                  (existentialProcPat data_con)
                  (existentialProcPat data_con)

+                 -- See Note [Arrows and patterns]

 
           -- Need to test for rigidity if *any* constraints in theta as class
           -- constraints may have superclass equality constraints.  However,
 
           -- Need to test for rigidity if *any* constraints in theta as class
           -- constraints may have superclass equality constraints.  However,

@@ -666,8 +670,8 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
              pstate' | no_equalities = pstate
                      | otherwise     = pstate { pat_eqs = True }
 
              pstate' | no_equalities = pstate
                      | otherwise     = pstate { pat_eqs = True }
 

-       ; unless no_equalities $ 
-            checkTc (isRigidTy pat_ty) (nonRigidMatch data_con)
+       ; unless no_equalities $ checkTc (isRigidTy pat_ty) $
+                                 nonRigidMatch (pat_ctxt pstate) data_con

 
        ; ((arg_pats', inner_tvs, res), lie_req) <- getLIE $
                tcConArgs data_con arg_tys' arg_pats pstate' thing_inside
 
        ; ((arg_pats', inner_tvs, res), lie_req) <- getLIE $
                tcConArgs data_con arg_tys' arg_pats pstate' thing_inside

@@ -1029,17 +1033,30 @@ lazyPatErr _ tvs
     hang (ptext (sLit "A lazy (~) pattern cannot bind existential type variables"))
        2 (vcat (map pprSkolTvBinding tvs))
 
     hang (ptext (sLit "A lazy (~) pattern cannot bind existential type variables"))
        2 (vcat (map pprSkolTvBinding tvs))
 

-nonRigidMatch :: DataCon -> SDoc
-nonRigidMatch con
+nonRigidMatch :: PatCtxt -> DataCon -> SDoc
+nonRigidMatch ctxt con

   =  hang (ptext (sLit "GADT pattern match in non-rigid context for") <+> quotes (ppr con))
   =  hang (ptext (sLit "GADT pattern match in non-rigid context for") <+> quotes (ppr con))

-       2 (ptext (sLit "Solution: add a type signature"))
-
-nonRigidResult :: Type -> TcM a
-nonRigidResult res_ty
+       2 (ptext (sLit "Probable solution: add a type signature for") <+> what ctxt)
+  where
+     what (APat (FunRhs f _)) = quotes (ppr f)
+     what (APat CaseAlt)      = ptext (sLit "the scrutinee of the case expression")
+     what (APat LambdaExpr )  = ptext (sLit "the lambda expression")
+     what (APat (StmtCtxt _)) = ptext (sLit "the right hand side of a do/comprehension binding")
+     what _other             = ptext (sLit "something")
+
+nonRigidResult :: PatCtxt -> Type -> TcM a
+nonRigidResult ctxt res_ty

   = do { env0 <- tcInitTidyEnv
        ; let (env1, res_ty') = tidyOpenType env0 res_ty
              msg = hang (ptext (sLit "GADT pattern match with non-rigid result type")
                                <+> quotes (ppr res_ty'))
   = do { env0 <- tcInitTidyEnv
        ; let (env1, res_ty') = tidyOpenType env0 res_ty
              msg = hang (ptext (sLit "GADT pattern match with non-rigid result type")
                                <+> quotes (ppr res_ty'))

-                        2 (ptext (sLit "Solution: add a type signature"))
+                        2 (ptext (sLit "Solution: add a type signature for")
+                                 <+> what ctxt )

        ; failWithTcM (env1, msg) }
        ; failWithTcM (env1, msg) }

+  where
+     what (APat (FunRhs f _)) = quotes (ppr f)
+     what (APat CaseAlt)      = ptext (sLit "the entire case expression")
+     what (APat LambdaExpr)   = ptext (sLit "the lambda exression")
+     what (APat (StmtCtxt _)) = ptext (sLit "the entire do/comprehension expression")
+     what _other              = ptext (sLit "something")

 \end{code}
 \end{code}