Refactor type errors a bit

Improves kind error messages in paticular

diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index e0c8520..415365f 100644 (file)
--- a/compiler/typecheck/TcCanonical.lhs
+++ b/compiler/typecheck/TcCanonical.lhs
@@ -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 )
 -- 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
   | 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
 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
 
   | otherwise
   = do { (xi2,ccs2) <- flatten fl s2      -- flatten RHS

diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index 533520f..b3dfb9c 100644 (file)
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -1,7 +1,8 @@
 \begin{code}
 module TcErrors( 
        reportUnsolved, reportUnsolvedImplication, reportUnsolvedDeriv,
 \begin{code}
 module TcErrors( 
        reportUnsolved, reportUnsolvedImplication, reportUnsolvedDeriv,

-       reportUnsolvedWantedEvVars, warnDefaulting, typeExtraInfoMsg,
+       reportUnsolvedWantedEvVars, warnDefaulting, 
+       unifyCtxt, typeExtraInfoMsg, 

        kindErrorTcS, misMatchErrorTcS, flattenForAllErrorTcS,
        occursCheckErrorTcS, solverDepthErrorTcS
   ) where
        kindErrorTcS, misMatchErrorTcS, flattenForAllErrorTcS,
        occursCheckErrorTcS, solverDepthErrorTcS
   ) where

@@ -81,13 +82,14 @@ reportUnsolvedDeriv unsolved loc
   | null unsolved
   = return ()
   | otherwise
   | 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 } 
        ; 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")]
   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
 
                  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
        ; ASSERT( null others ) return () }
   where
     (dicts, non_dicts) = partition isClassPred flats

@@ -168,8 +170,8 @@ reportFlat ctxt flats loc
 --      Support code 
 --------------------------------------------
 
 --      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
           -> 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)
 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
        ; 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
        -- 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
 
 pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
 -- Print something like

@@ -204,7 +207,7 @@ pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
 pprWithArising [] 
   = panic "pprWithArising"
 pprWithArising [WantedEvVar ev loc] 
 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
 pprWithArising ev_vars
   = (first_loc, vcat (map ppr_one ev_vars))
   where

@@ -255,9 +258,9 @@ getUserGivens (CEC {cec_encl = ctxt})
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \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
   where
     msg | Just givens <- getUserGivens ctxt
         = couldNotDeduce givens ips

@@ -274,32 +277,33 @@ reportIPErrs ctxt ips loc
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \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
   | 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
 
             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
   | 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
 
   | 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
   = (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]
 \end{code}
 
 Note [Non-injective type functions]

@@ -418,8 +436,8 @@ Warn of loopy local equalities that were dropped.
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \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) $
   = 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) )
 
     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])]
                                <+> 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
     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 
             , 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 ]
               ptext (sLit "No instance") <> plural wanteds
                    <+> ptext (sLit "for") <+> pprTheta wanteds
             , show_fixes fixes2 ]

@@ -626,19 +644,27 @@ warnDefaulting wanteds default_ty
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \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
 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
 
 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
     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:"
 
   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
 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
 
 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 
     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}
                        , 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}

diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 7357669..ca17355 100644 (file)
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -848,13 +848,12 @@ ctLocOrigin (CtLoc o _ _) = o
 setCtLocOrigin :: CtLoc o -> o' -> CtLoc o'
 setCtLocOrigin (CtLoc _ s c) o = CtLoc o s c
 
 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 :: 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
 
 -------------------------------------------
 -- CtOrigin gives the origin of *wanted* constraints

@@ -864,7 +863,7 @@ data CtOrigin
 
   | SpecPragOrigin Name                -- Specialisation pragma for identifier
 
 
   | SpecPragOrigin Name                -- Specialisation pragma for identifier
 

-  | TypeEqOrigin
+  | TypeEqOrigin EqOrigin

 
   | IPOccOrigin  (IPName Name) -- Occurrence of an implicit parameter
 
 
   | 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 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
 pprO AnnOrigin             = ptext (sLit "an annotation")
 
 instance Outputable EqOrigin where

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 535b561..d7da17f 100644 (file)
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -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
   , 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
              wanted_eq  = CTyEqCan { cc_id     = ev
                                    , cc_flavor = Wanted loc
                                    , cc_tyvar  = the_tv

diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs
index 3360f5d..340be9a 100644 (file)
--- a/compiler/typecheck/TcUnify.lhs
+++ b/compiler/typecheck/TcUnify.lhs
@@ -14,9 +14,6 @@ module TcUnify (
         -- Various unifications
   unifyType, unifyTypeList, unifyTheta, unifyKind, 
 
         -- Various unifications
   unifyType, unifyTypeList, unifyTheta, unifyKind, 
 

-        -- Occurs check error 
-  typeExtraInfoMsg, emitMisMatchErr,
-

   --------------------------------
   -- Holes
   tcInfer, 
   --------------------------------
   -- Holes
   tcInfer, 

@@ -31,7 +28,7 @@ module TcUnify (
 import HsSyn
 import TypeRep
 
 import HsSyn
 import TypeRep
 

-import TcErrors        ( typeExtraInfoMsg )
+import TcErrors        ( typeExtraInfoMsg, unifyCtxt )

 import TcMType
 import TcEnv
 import TcIface
 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]
 --------------
 -- 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])
   = 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 }
        ; 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)
 
 --------------
 -- 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
 -- 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.
 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 $
   = 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) }
         ; 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
 
 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
   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}
 
 
 \end{code}