Refactor type errors a bit
authorsimonpj@microsoft.com <unknown>
Fri, 17 Sep 2010 08:07:26 +0000 (08:07 +0000)
committersimonpj@microsoft.com <unknown>
Fri, 17 Sep 2010 08:07:26 +0000 (08:07 +0000)
Improves kind error messages in paticular

compiler/typecheck/TcCanonical.lhs
compiler/typecheck/TcErrors.lhs
compiler/typecheck/TcRnTypes.lhs
compiler/typecheck/TcSimplify.lhs
compiler/typecheck/TcUnify.lhs

index e0c8520..415365f 100644 (file)
@@ -527,7 +527,8 @@ canEqLeafOriented :: CtFlavor -> CoVar
 -- First argument is not OtherCls
 canEqLeafOriented fl cv cls1@(FunCls fn tys) s2 
   | not (kindAppResult (tyConKind fn) tys `eqKind` typeKind s2 )
-  = kindErrorTcS fl (unClassify cls1) s2
+  = do { kindErrorTcS fl (unClassify cls1) s2
+       ; return emptyCCan }
   | otherwise 
   = ASSERT2( isSynFamilyTyCon fn, ppr (unClassify cls1) )
     do { (xis1,ccs1) <- flattenMany fl tys -- flatten type function arguments
@@ -544,7 +545,8 @@ canEqLeafOriented fl cv cls1@(FunCls fn tys) s2
 canEqLeafOriented fl cv (VarCls tv) s2 
   | not (k1 `eqKind` k2 || (isMetaTyVar tv && k2 `isSubKind` k1))
       -- Establish the kind invariant for CTyEqCan
-  = kindErrorTcS fl (mkTyVarTy tv) s2
+  = do { kindErrorTcS fl (mkTyVarTy tv) s2
+       ; return emptyCCan }
 
   | otherwise
   = do { (xi2,ccs2) <- flatten fl s2      -- flatten RHS
index 533520f..b3dfb9c 100644 (file)
@@ -1,7 +1,8 @@
 \begin{code}
 module TcErrors( 
        reportUnsolved, reportUnsolvedImplication, reportUnsolvedDeriv,
-       reportUnsolvedWantedEvVars, warnDefaulting, typeExtraInfoMsg,
+       reportUnsolvedWantedEvVars, warnDefaulting, 
+       unifyCtxt, typeExtraInfoMsg, 
        kindErrorTcS, misMatchErrorTcS, flattenForAllErrorTcS,
        occursCheckErrorTcS, solverDepthErrorTcS
   ) where
@@ -81,13 +82,14 @@ reportUnsolvedDeriv unsolved loc
   | null unsolved
   = return ()
   | otherwise
-  = do { env0 <- tcInitTidyEnv
+  = setCtLoc loc $
+    do { env0 <- tcInitTidyEnv
        ; let tidy_env      = tidyFreeTyVars env0 (tyVarsOfTheta unsolved)
              tidy_unsolved = map (tidyPred tidy_env) unsolved
              err_ctxt = CEC { cec_encl  = [] 
                             , cec_extra = alt_fix
                             , cec_tidy  = tidy_env } 
-       ; reportFlat err_ctxt tidy_unsolved loc }
+       ; reportFlat err_ctxt tidy_unsolved (ctLocOrigin loc) }
   where
     alt_fix = vcat [ptext (sLit "Alternatively, use a standalone 'deriving instance' declaration,"),
                     nest 2 $ ptext (sLit "so you can specify the instance context yourself")]
@@ -153,11 +155,11 @@ reportTidyWanteds ctxt unsolved
                  where   
                      pred = wantedEvVarPred d
 
-reportFlat :: ReportErrCtxt -> [PredType] -> WantedLoc -> TcM ()
-reportFlat ctxt flats loc
-  = do { unless (null dicts) $ reportDictErrs ctxt dicts loc
-       ; unless (null eqs)   $ reportEqErrs   ctxt eqs   loc
-       ; unless (null ips)   $ reportIPErrs   ctxt ips   loc
+reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
+reportFlat ctxt flats origin
+  = do { unless (null dicts) $ reportDictErrs ctxt dicts origin
+       ; unless (null eqs)   $ reportEqErrs   ctxt eqs   
+       ; unless (null ips)   $ reportIPErrs   ctxt ips   origin
        ; ASSERT( null others ) return () }
   where
     (dicts, non_dicts) = partition isClassPred flats
@@ -168,8 +170,8 @@ reportFlat ctxt flats loc
 --      Support code 
 --------------------------------------------
 
-groupErrs :: ([PredType] -> WantedLoc -> TcM ()) -- Deal with one group
-         -> [WantedEvVar]                       -- Unsolved wanteds
+groupErrs :: ([PredType] -> CtOrigin -> TcM ()) -- Deal with one group
+         -> [WantedEvVar]                      -- Unsolved wanteds
           -> TcM ()
 -- Group together insts with the same origin
 -- We want to report them together in error messages
@@ -177,7 +179,8 @@ groupErrs :: ([PredType] -> WantedLoc -> TcM ()) -- Deal with one group
 groupErrs _ [] 
   = return ()
 groupErrs report_err (wanted : wanteds)
-  = do { setCtLoc the_loc $ report_err the_vars the_loc
+  = do { setCtLoc the_loc $ 
+          report_err the_vars (ctLocOrigin the_loc)
        ; groupErrs report_err others }
   where
    the_loc           = wantedEvVarLoc wanted
@@ -193,8 +196,8 @@ groupErrs report_err (wanted : wanteds)
        -- and it avoids need equality on InstLocs.
 
 -- Add the "arising from..." part to a message about bunch of dicts
-addArising :: WantedLoc -> SDoc -> SDoc
-addArising loc msg = msg $$ nest 2 (pprArising loc)
+addArising :: CtOrigin -> SDoc -> SDoc
+addArising orig msg = msg $$ nest 2 (pprArising orig)
 
 pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
 -- Print something like
@@ -204,7 +207,7 @@ pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
 pprWithArising [] 
   = panic "pprWithArising"
 pprWithArising [WantedEvVar ev loc] 
-  = (loc, pprEvVarTheta [ev] <+> pprArising loc)
+  = (loc, pprEvVarTheta [ev] <+> pprArising (ctLocOrigin loc))
 pprWithArising ev_vars
   = (first_loc, vcat (map ppr_one ev_vars))
   where
@@ -255,9 +258,9 @@ getUserGivens (CEC {cec_encl = ctxt})
 %************************************************************************
 
 \begin{code}
-reportIPErrs :: ReportErrCtxt -> [PredType] -> WantedLoc -> TcM ()
-reportIPErrs ctxt ips loc
-  = addErrorReport ctxt $ addArising loc msg
+reportIPErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
+reportIPErrs ctxt ips orig
+  = addErrorReport ctxt $ addArising orig msg
   where
     msg | Just givens <- getUserGivens ctxt
         = couldNotDeduce givens ips
@@ -274,32 +277,33 @@ reportIPErrs ctxt ips loc
 %************************************************************************
 
 \begin{code}
-reportEqErrs :: ReportErrCtxt -> [PredType] -> WantedLoc -> TcM ()
-reportEqErrs ctxt eqs loc = mapM_ (reportEqErr ctxt loc) eqs 
+reportEqErrs :: ReportErrCtxt -> [PredType] -> TcM ()
+reportEqErrs ctxt eqs 
+  = mapM_ report_one eqs 
+  where
+    report_one (EqPred ty1 ty2) = reportEqErr ctxt ty1 ty2
+    report_one pred             = pprPanic "reportEqErrs" (ppr pred)    
 
-reportEqErr :: ReportErrCtxt -> WantedLoc -> PredType -> TcM ()
-reportEqErr ctxt loc pred@(EqPred ty1 ty2)
-  | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt loc tv1 ty2
-  | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt loc tv2 ty1
+reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM ()
+reportEqErr ctxt ty1 ty2
+  | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2
+  | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1
   | otherwise  -- Neither side is a type variable
                -- Since the unsolved constraint is canonical, 
                -- it must therefore be of form (F tys ~ ty)
   = addErrorReport ctxt (msg $$ mkTyFunInfoMsg ty1 ty2)
   where
     msg = case getUserGivens ctxt of
-            Just givens -> couldNotDeduce givens [pred]
+            Just givens -> couldNotDeduce givens [EqPred ty1 ty2]
             Nothing     -> misMatchMsg ty1 ty2
 
-reportEqErr _ _ _ = panic "reportEqErr"          -- Must be equality pred
-
-reportTyVarEqErr :: ReportErrCtxt -> WantedLoc
-                 -> TcTyVar -> TcType -> TcM ()
-reportTyVarEqErr ctxt loc tv1 ty2
+reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM ()
+reportTyVarEqErr ctxt tv1 ty2
   | not is_meta1
   , Just tv2 <- tcGetTyVar_maybe ty2
   , isMetaTyVar tv2
   = -- sk ~ alpha: swap
-    reportTyVarEqErr ctxt loc tv2 ty1
+    reportTyVarEqErr ctxt tv2 ty1
 
   | not is_meta1
   = -- sk ~ ty, where ty isn't a meta-tyvar: mis-match
@@ -398,6 +402,20 @@ typeExtraInfoMsg env ty
   = (env1, pprSkolTvBinding tv1)
   where
 typeExtraInfoMsg env _ty = (env, empty)                -- Normal case
+
+--------------------
+unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
+unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
+  = do  { act_ty' <- zonkTcType act_ty
+        ; exp_ty' <- zonkTcType exp_ty
+        ; let (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
+              (env2, act_ty'') = tidyOpenType env1     act_ty'
+        ; return (env2, mkExpectedActualMsg act_ty'' exp_ty'') }
+
+mkExpectedActualMsg :: Type -> Type -> SDoc
+mkExpectedActualMsg act_ty exp_ty
+  = vcat [ text "Expected type" <> colon <+> ppr exp_ty
+         , text "  Actual type" <> colon <+> ppr act_ty ]
 \end{code}
 
 Note [Non-injective type functions]
@@ -418,8 +436,8 @@ Warn of loopy local equalities that were dropped.
 %************************************************************************
 
 \begin{code}
-reportDictErrs :: ReportErrCtxt -> [PredType] -> WantedLoc -> TcM ()   
-reportDictErrs ctxt wanteds loc
+reportDictErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()    
+reportDictErrs ctxt wanteds orig
   = do { inst_envs <- tcGetInstEnvs
        ; let (others, overlaps) = partitionWith (check_overlap inst_envs) wanteds
        ; unless (null others) $
@@ -442,7 +460,7 @@ reportDictErrs ctxt wanteds loc
 
     mk_overlap_msg pred (matches, unifiers)
       = ASSERT( not (null matches) )
-        vcat [ addArising loc (ptext (sLit "Overlapping instances for") 
+        vcat [ addArising orig (ptext (sLit "Overlapping instances for") 
                                <+> pprPred pred)
             ,  sep [ptext (sLit "Matching instances") <> colon,
                     nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
@@ -461,11 +479,11 @@ reportDictErrs ctxt wanteds loc
     mk_no_inst_err :: [PredType] -> SDoc
     mk_no_inst_err wanteds
       | Just givens <- getUserGivens ctxt
-      = vcat [ addArising loc $ couldNotDeduce givens wanteds
+      = vcat [ addArising orig $ couldNotDeduce givens wanteds
             , show_fixes (fix1 : fixes2) ]
 
       | otherwise      -- Top level 
-      = vcat [ addArising loc $
+      = vcat [ addArising orig $
               ptext (sLit "No instance") <> plural wanteds
                    <+> ptext (sLit "for") <+> pprTheta wanteds
             , show_fixes fixes2 ]
@@ -626,19 +644,27 @@ warnDefaulting wanteds default_ty
 %************************************************************************
 
 \begin{code}
-kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
+kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS ()
+-- If there's a kind error, we don't want to blindly say "kind error"
+-- We might, say, be unifying a skolem 'a' with a type 'Int', 
+-- in which case that's the error to report.  So we set things
+-- up to call reportEqErr, which does the business properly
 kindErrorTcS fl ty1 ty2
   = wrapErrTcS        $ 
     setCtFlavorLoc fl $ 
     do { env0 <- tcInitTidyEnv
        ; let (env1, ty1') = tidyOpenType env0 ty1
              (env2, ty2') = tidyOpenType env1 ty2
-       ; failWithTcM (env2, kindErrorMsg ty1' ty2') }
+             ctxt = CEC { cec_encl = []
+                        , cec_extra = empty
+                        , cec_tidy = env2 }
+       ; reportEqErr ctxt ty1' ty2' }
 
 misMatchErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
 misMatchErrorTcS fl ty1 ty2
-  = wrapErrTcS        $ 
-    setCtFlavorLoc fl $ 
+  = wrapErrTcS            $ 
+    setCtFlavorLocNoEq fl $  -- Don't add the "When matching t1 with t2"
+                            -- part, because it duplciates what we say now
     do { env0 <- tcInitTidyEnv
        ; let (env1, ty1') = tidyOpenType env0 ty1
              (env2, ty2') = tidyOpenType env1 ty2
@@ -669,11 +695,6 @@ occursCheckErrorTcS fl tv ty
   where
     msg = text $ "Occurs check: cannot construct the infinite type:"
 
-setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
-setCtFlavorLoc (Wanted  loc) thing = setCtLoc loc thing
-setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
-setCtFlavorLoc (Given loc)   thing = setCtLoc loc thing
-
 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
 solverDepthErrorTcS depth stack
   | null stack     -- Shouldn't happen unless you say -fcontext-stack=0
@@ -694,7 +715,7 @@ solverDepthErrorTcS depth stack
 
 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
 flattenForAllErrorTcS fl ty _bad_eqs
-  = wrapErrTcS           
+  = wrapErrTcS        $ 
     setCtFlavorLoc fl $ 
     do { env0 <- tcInitTidyEnv
        ; let (env1, ty') = tidyOpenType env0 ty 
@@ -702,3 +723,38 @@ flattenForAllErrorTcS fl ty _bad_eqs
                        , ppr ty' ]
        ; failWithTcM (env1, msg) }
 \end{code}
+
+%************************************************************************
+%*                                                                     *
+                 Setting the context
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+setCtFlavorLocNoEq :: CtFlavor -> TcM a -> TcM a
+setCtFlavorLocNoEq (Wanted  loc) thing = setCtLoc loc thing
+setCtFlavorLocNoEq (Derived loc) thing = setCtLoc loc thing
+setCtFlavorLocNoEq (Given   loc) thing = setCtLoc loc thing
+
+setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
+setCtFlavorLoc (Wanted  loc) thing = setWantedLoc loc thing
+setCtFlavorLoc (Derived loc) thing = setWantedLoc loc thing
+setCtFlavorLoc (Given   loc) thing = setGivenLoc  loc thing
+
+setWantedLoc :: WantedLoc -> TcM a -> TcM a
+setWantedLoc loc thing_inside 
+  = setCtLoc loc $
+    add_origin (ctLocOrigin loc) $ 
+    thing_inside
+  where
+    add_origin (TypeEqOrigin item) = addErrCtxtM (unifyCtxt item)
+    add_origin orig = addErrCtxt (ptext (sLit "At") <+> ppr orig)
+
+setGivenLoc :: GivenLoc -> TcM a -> TcM a
+setGivenLoc loc thing_inside 
+  = setCtLoc loc $
+    add_origin (ctLocOrigin loc) $ 
+    thing_inside
+  where
+    add_origin skol = addErrCtxt (ptext (sLit "In") <+> pprSkolInfo skol)
+\end{code}
index 7357669..ca17355 100644 (file)
@@ -848,13 +848,12 @@ ctLocOrigin (CtLoc o _ _) = o
 setCtLocOrigin :: CtLoc o -> o' -> CtLoc o'
 setCtLocOrigin (CtLoc _ s c) o = CtLoc o s c
 
-pprArising :: CtLoc CtOrigin -> SDoc
-pprArising loc = case ctLocOrigin loc of
-                   TypeEqOrigin -> empty
-                   _ -> text "arising from" <+> ppr (ctLocOrigin loc)
+pprArising :: CtOrigin -> SDoc
+pprArising (TypeEqOrigin {}) = empty
+pprArising orig              = text "arising from" <+> ppr orig
 
 pprArisingAt :: CtLoc CtOrigin -> SDoc
-pprArisingAt loc = sep [pprArising loc, text "at" <+> ppr (ctLocSpan loc)]
+pprArisingAt (CtLoc o s _) = sep [pprArising o, text "at" <+> ppr s]
 
 -------------------------------------------
 -- CtOrigin gives the origin of *wanted* constraints
@@ -864,7 +863,7 @@ data CtOrigin
 
   | SpecPragOrigin Name                -- Specialisation pragma for identifier
 
-  | TypeEqOrigin
+  | TypeEqOrigin EqOrigin
 
   | IPOccOrigin  (IPName Name) -- Occurrence of an implicit parameter
 
@@ -919,7 +918,7 @@ pprO StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration")
 pprO DefaultOrigin        = ptext (sLit "a 'default' declaration")
 pprO DoOrigin             = ptext (sLit "a do statement")
 pprO ProcOrigin                   = ptext (sLit "a proc expression")
-pprO TypeEqOrigin          = ptext (sLit "an equality")
+pprO (TypeEqOrigin eq)     = ptext (sLit "an equality") <+> ppr eq
 pprO AnnOrigin             = ptext (sLit "an annotation")
 
 instance Outputable EqOrigin where
index 535b561..d7da17f 100644 (file)
@@ -787,7 +787,8 @@ defaultTyVar untch the_tv
   , not (the_tv `elemVarSet` untch)
   , not (k `eqKind` default_k)
   = do { (ev, better_ty) <- TcSMonad.newKindConstraint (mkTyVarTy the_tv) default_k
-       ; let loc = CtLoc TypeEqOrigin (getSrcSpan the_tv) [] -- Yuk
+       ; let loc = CtLoc DefaultOrigin (getSrcSpan the_tv) [] -- Yuk
+                          -- 'DefaultOrigin' is strictly the declaration, but it's convenient
              wanted_eq  = CTyEqCan { cc_id     = ev
                                    , cc_flavor = Wanted loc
                                    , cc_tyvar  = the_tv
index 3360f5d..340be9a 100644 (file)
@@ -14,9 +14,6 @@ module TcUnify (
         -- Various unifications
   unifyType, unifyTypeList, unifyTheta, unifyKind, 
 
-        -- Occurs check error 
-  typeExtraInfoMsg, emitMisMatchErr,
-
   --------------------------------
   -- Holes
   tcInfer, 
@@ -31,7 +28,7 @@ module TcUnify (
 import HsSyn
 import TypeRep
 
-import TcErrors        ( typeExtraInfoMsg )
+import TcErrors        ( typeExtraInfoMsg, unifyCtxt )
 import TcMType
 import TcEnv
 import TcIface
@@ -526,13 +523,15 @@ uType, uType_np, uType_defer
 --------------
 -- It is always safe to defer unification to the main constraint solver
 -- See Note [Deferred unification]
-uType_defer origin ty1 ty2
+uType_defer (item : origin) ty1 ty2
   = do { co_var <- newWantedCoVar ty1 ty2
        ; traceTc "utype_defer" (vcat [ppr co_var, ppr ty1, ppr ty2, ppr origin])
-       ; loc <- getCtLoc TypeEqOrigin
+       ; loc <- getCtLoc (TypeEqOrigin item)
        ; wrapEqCtxt origin $
          emitConstraint (WcEvVar (WantedEvVar co_var loc)) 
        ; return $ ACo $ mkTyVarTy co_var }
+uType_defer [] _ _
+  = panic "uType_defer"
 
 --------------
 -- Push a new item on the origin stack (the most common case)
@@ -970,33 +969,25 @@ wrapEqCtxt :: [EqOrigin] -> TcM a -> TcM a
 -- and, if there is more than one item, the "Expected/inferred" part
 -- comes from the outermost item
 wrapEqCtxt []    thing_inside = thing_inside
-wrapEqCtxt [_]   thing_inside = thing_inside
 wrapEqCtxt items thing_inside = addErrCtxtM (unifyCtxt (last items)) thing_inside
 
 ---------------
 failWithMisMatch :: [EqOrigin] -> TcM a
 -- Generate the message when two types fail to match,
 -- going to some trouble to make it helpful.
--- The argument order is: actual type, expected type
-failWithMisMatch [] 
-  = panic "failWithMisMatch"
-failWithMisMatch origin@(item:_)
+-- We take the failing types from the top of the origin stack
+-- rather than reporting the particular ones we are looking 
+-- at right now
+failWithMisMatch (item:origin)
   = wrapEqCtxt origin $
-    emitMisMatchErr (uo_actual item) (uo_expected item)
-
-mkExpectedActualMsg :: Type -> Type -> SDoc
-mkExpectedActualMsg act_ty exp_ty
-  = nest 2 (vcat [ text "Expected type" <> colon <+> ppr exp_ty,
-                   text "  Actual type" <> colon <+> ppr act_ty ])
-
-emitMisMatchErr :: TcType -> TcType -> TcM a
-emitMisMatchErr ty_act ty_exp
-  = do { ty_act <- zonkTcType ty_act
-        ; ty_exp <- zonkTcType ty_exp
+    do { ty_act <- zonkTcType (uo_actual item)
+        ; ty_exp <- zonkTcType (uo_expected item)
         ; env0 <- tcInitTidyEnv
         ; let (env1, pp_exp) = tidyOpenType env0 ty_exp
               (env2, pp_act) = tidyOpenType env1 ty_act
         ; failWithTcM (misMatchMsg env2 pp_act pp_exp) }
+failWithMisMatch [] 
+  = panic "failWithMisMatch"
 
 misMatchMsg :: TidyEnv -> TcType -> TcType -> (TidyEnv, SDoc)
 misMatchMsg env ty_act ty_exp
@@ -1006,15 +997,6 @@ misMatchMsg env ty_act ty_exp
   where
     (env1, extra1) = typeExtraInfoMsg env  ty_exp
     (env2, extra2) = typeExtraInfoMsg env1 ty_act
-
---------------------
-unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
-unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
-  = do  { act_ty' <- zonkTcType act_ty
-        ; exp_ty' <- zonkTcType exp_ty
-        ; let (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
-              (env2, act_ty'') = tidyOpenType env1     act_ty'
-        ; return (env2, mkExpectedActualMsg act_ty'' exp_ty'') }
 \end{code}