[commit: ghc] ghc-kinds: Add a SrcSpan to ATDs to regain properly located error messages (9d75d27)

[José Pedro Magalhães]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : ghc-kinds

http://hackage.haskell.org/trac/ghc/changeset/9d75d27c02ba55274ddce1e37e55f203626ff207

>---------------------------------------------------------------

commit 9d75d27c02ba55274ddce1e37e55f203626ff207
Author: Jose Pedro Magalhaes <jpm at cs.uu.nl>
Date:   Wed Nov 9 11:43:30 2011 +0000

    Add a SrcSpan to ATDs to regain properly located error messages

>---------------------------------------------------------------

 compiler/iface/MkIface.lhs          |    2 +-
 compiler/iface/TcIface.lhs          |    4 +++-
 compiler/typecheck/TcInstDcls.lhs   |    2 +-
 compiler/typecheck/TcRnDriver.lhs   |    3 ++-
 compiler/typecheck/TcTyClsDecls.lhs |   10 +++++++---
 compiler/types/Class.lhs            |    5 ++++-
 6 files changed, 18 insertions(+), 8 deletions(-)

diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
old mode 100644
new mode 100755
index c251864..f45c91f
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1447,7 +1447,7 @@ classToIfaceDecl clas
       = IfaceAT (tyThingToIfaceDecl (ATyCon tc))
                 (map to_if_at_def defs)
       where
-        to_if_at_def (ATD tvs pat_tys ty)
+        to_if_at_def (ATD tvs pat_tys ty _loc)
           = IfaceATD (toIfaceTvBndrs tvs) (map toIfaceType pat_tys) (toIfaceType ty)
 
     toIfaceClassOp (sel_id, def_meth)
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index bbe3279..125b885 100755
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -502,7 +502,9 @@ tc_iface_decl _parent ignore_prags
        return tc
 
    tc_iface_at_def (IfaceATD tvs pat_tys ty) =
-       bindIfaceTyVars_AT tvs $ \tvs' -> liftM2 (ATD tvs') (mapM tcIfaceType pat_tys) (tcIfaceType ty)
+       bindIfaceTyVars_AT tvs $
+         \tvs' -> liftM2 (\pats tys -> ATD tvs' pats tys noSrcSpan)
+                           (mapM tcIfaceType pat_tys) (tcIfaceType ty)
 
    mk_doc op_name op_ty = ptext (sLit "Class op") <+> sep [ppr op_name, ppr op_ty]
 
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index b30cc61..837f382 100755
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -472,7 +472,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
                 | null defs                                  = return (Just (tyConName fam_tc), [])
                  -- No user instance, have defaults ==> instatiate them
                 | otherwise = do
-                    defs' <- forM defs $ \(ATD tvs pat_tys rhs) -> do
+                    defs' <- forM defs $ \(ATD tvs pat_tys rhs _loc) -> do
                       let mini_env_subst = mkTvSubst (mkInScopeSet (mkVarSet tvs)) mini_env
                           tvs' = varSetElems (tyVarsOfType rhs')
                           pat_tys' = substTys mini_env_subst pat_tys
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 2566f39..48f3cf8 100755
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -745,7 +745,8 @@ checkBootTyCon tc1 tc2
          = checkBootTyCon tc1 tc2 &&
            eqListBy eqATDef def_ats1 def_ats2
 
-       eqATDef (ATD tvs1 ty_pats1 ty1) (ATD tvs2 ty_pats2 ty2)
+       -- Ignore the location of the defaults
+       eqATDef (ATD tvs1 ty_pats1 ty1 _loc1) (ATD tvs2 ty_pats2 ty2 _loc2)
          = eqListBy same_kind tvs1 tvs2 &&
            eqListBy (eqTypeX env) ty_pats1 ty_pats2 &&
            eqTypeX env ty1 ty2
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 694b0a8..38d1ed3 100755
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -727,7 +727,7 @@ tcDefaultAssocDecl fam_tc (L loc decl)
     tcAddDefaultAssocDeclCtxt (tcdName decl) $
     do { traceTc "tcDefaultAssocDecl" (ppr decl)
        ; (at_tvs, at_tys, at_rhs) <- tcSynFamInstDecl fam_tc decl
-       ; return (ATD at_tvs at_tys at_rhs) }
+       ; return (ATD at_tvs at_tys at_rhs loc) }
 -- We check for well-formedness and validity later, in checkValidClass
 -------------------------
 
@@ -1410,9 +1410,13 @@ checkValidClass cls
 		-- type variable.  What a mess!
 
     check_at_defs (fam_tc, defs)
-      = do mapM_ (\(ATD _tvs pats rhs) -> checkValidFamInst pats rhs) defs
+      = do mapM_ (\(ATD _tvs pats rhs _loc) -> checkValidFamInst pats rhs) defs
            tcAddDefaultAssocDeclCtxt (tyConName fam_tc) $ 
-             mapM_ (zipWithM_ check_arg (tyConTyVars fam_tc)) (map atDefaultPats defs)
+             mapM_ (check_loc_at_def fam_tc) defs
+
+    check_loc_at_def fam_tc (ATD _tvs pats _rhs loc)
+      -- Set the location for each of the default declarations
+      = setSrcSpan loc $ zipWithM_ check_arg (tyConTyVars fam_tc) pats
 
     -- We only want to check this on the *class* TyVars,
     -- not the *family* TyVars (there may be more of these)
diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs
index f618fbf..cda98de 100755
--- a/compiler/types/Class.lhs
+++ b/compiler/types/Class.lhs
@@ -39,6 +39,7 @@ import BasicTypes
 import Unique
 import Util
 import Outputable
+import SrcLoc
 import FastString
 
 import Data.Typeable (Typeable)
@@ -109,7 +110,9 @@ data ATDefault = ATD { -- TyVars of the RHS and family arguments
                        -- The instantiated family arguments
                        atDefaultPats    :: [Type],
                        -- The RHS of the synonym
-                       atDefaultRhs     ::  Type }
+                       atDefaultRhs     :: Type,
+                       -- The source location of the synonym
+                       atDefaultSrcSpan :: SrcSpan }
 
 -- | Convert a `DefMethSpec` to a `DefMeth`, which discards the name field in
 --   the `DefMeth` constructor of the `DefMeth`.