A little refactoring, plus improve error locations

Fixes some sub-items of Trac #597

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 3466cbf..5d2b829 100644 (file)
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -440,8 +440,7 @@ deriveStandalone (L loc (DerivDecl deriv_ty))
               <+> text "tvs:" <+> ppr tvs
               <+> text "theta:" <+> ppr theta
               <+> text "tau:" <+> ppr tau)
               <+> text "tvs:" <+> ppr tvs
               <+> text "theta:" <+> ppr theta
               <+> text "tau:" <+> ppr tau)

-       ; (cls, inst_tys) <- checkValidInstHead tau
-       ; checkValidInstance tvs theta cls inst_tys
+       ; (cls, inst_tys) <- checkValidInstance deriv_ty tvs theta tau

                -- C.f. TcInstDcls.tcLocalInstDecl1
 
        ; let cls_tys = take (length inst_tys - 1) inst_tys
                -- C.f. TcInstDcls.tcLocalInstDecl1
 
        ; let cls_tys = take (length inst_tys - 1) inst_tys

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index c4c5d58..6ffa9d9 100644 (file)
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -410,8 +410,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
         ; (tyvars, theta, tau) <- tcHsInstHead poly_ty
 
         -- Now, check the validity of the instance.
         ; (tyvars, theta, tau) <- tcHsInstHead poly_ty
 
         -- Now, check the validity of the instance.

-        ; (clas, inst_tys) <- checkValidInstHead tau
-        ; checkValidInstance tyvars theta clas inst_tys
+        ; (clas, inst_tys) <- checkValidInstance poly_ty tyvars theta tau

 
         -- Next, process any associated types.
         ; idx_tycons <- recoverM (return []) $
 
         -- Next, process any associated types.
         ; idx_tycons <- recoverM (return []) $

diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 6d6d102..492cbf9 100644 (file)
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -70,7 +70,8 @@ import TyCon
 import Var
 
 -- others:
 import Var
 
 -- others:

-import TcRnMonad          -- TcType, amongst others
+import HsSyn           -- HsType
+import TcRnMonad        -- TcType, amongst others

 import FunDeps
 import Name
 import VarEnv
 import FunDeps
 import Name
 import VarEnv

@@ -1638,11 +1639,15 @@ instTypeErr pp_ty msg
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

-

 \begin{code}
 \begin{code}

-checkValidInstance :: [TyVar] -> ThetaType -> Class -> [TcType] -> TcM ()
-checkValidInstance tyvars theta clas inst_tys
-  = do { undecidable_ok <- doptM Opt_UndecidableInstances
+checkValidInstance :: LHsType Name -> [TyVar] -> ThetaType -> Type 
+                   -> TcM (Class, [TcType])
+checkValidInstance hs_type tyvars theta tau
+  = setSrcSpan (getLoc hs_type) $
+    do { (clas, inst_tys) <- setSrcSpan head_loc $
+                              checkValidInstHead tau
+
+        ; undecidable_ok <- doptM Opt_UndecidableInstances

 
        ; checkValidTheta InstThetaCtxt theta
        ; checkAmbiguity tyvars theta (tyVarsOfTypes inst_tys)
 
        ; checkValidTheta InstThetaCtxt theta
        ; checkAmbiguity tyvars theta (tyVarsOfTypes inst_tys)

@@ -1656,10 +1661,17 @@ checkValidInstance tyvars theta clas inst_tys
        -- The Coverage Condition
        ; checkTc (undecidable_ok || checkInstCoverage clas inst_tys)
                  (instTypeErr (pprClassPred clas inst_tys) msg)
        -- The Coverage Condition
        ; checkTc (undecidable_ok || checkInstCoverage clas inst_tys)
                  (instTypeErr (pprClassPred clas inst_tys) msg)

+
+        ; return (clas, inst_tys)

        }
   where
     msg  = parens (vcat [ptext (sLit "the Coverage Condition fails for one of the functional dependencies;"),
                         undecidableMsg])
        }
   where
     msg  = parens (vcat [ptext (sLit "the Coverage Condition fails for one of the functional dependencies;"),
                         undecidableMsg])

+
+       -- The location of the "head" of the instance
+    head_loc = case hs_type of
+                 L _ (HsForAllTy _ _ _ (L loc _)) -> loc
+                 L loc _                          -> loc

 \end{code}
 
 Termination test: the so-called "Paterson conditions" (see Section 5 of
 \end{code}
 
 Termination test: the so-called "Paterson conditions" (see Section 5 of

@@ -1727,7 +1739,6 @@ Notice that this instance (just) satisfies the Paterson termination
 conditions.  Then we *could* derive an instance decl like this:
 
        instance (C Int a, Eq b, Eq c) => Eq (T a b c) 
 conditions.  Then we *could* derive an instance decl like this:
 
        instance (C Int a, Eq b, Eq c) => Eq (T a b c) 

-

 even though there is no instance for (C Int a), because there just
 *might* be an instance for, say, (C Int Bool) at a site where we
 need the equality instance for T's.  
 even though there is no instance for (C Int a), because there just
 *might* be an instance for, say, (C Int Bool) at a site where we
 need the equality instance for T's.