From 193627349898ca7d7b44a3b583d895f23851b038 Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Tue, 13 Jul 2010 11:57:33 +0000
Subject: [PATCH] Refactor where an error message is generated

---
 compiler/typecheck/TcInstDcls.lhs   |   34 +++++++---------------------------
 compiler/typecheck/TcTyClsDecls.lhs |   22 ++++++++++++++++++++--
 2 files changed, 27 insertions(+), 29 deletions(-)

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index a6f2b80..d4100d0 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -314,9 +314,9 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
                 -- round)
 
                 -- (1) Do class and family instance declarations
-       ; let { idxty_decls = filter (isFamInstDecl . unLoc) tycl_decls }
+       ; idx_tycons        <- mapAndRecoverM (tcFamInstDecl TopLevel) $
+       	 		      filter (isFamInstDecl . unLoc) tycl_decls 
        ; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1  inst_decls
-       ; idx_tycons        <- mapAndRecoverM tcIdxTyInstDeclTL idxty_decls
 
        ; let { (local_info,
                 at_tycons_s)   = unzip local_info_tycons
@@ -335,9 +335,9 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
 
                 -- Next, construct the instance environment so far, consisting
                 -- of
-                --   a) local instance decls
-                --   b) generic instances
-                --   c) local family instance decls
+                --   (a) local instance decls
+                --   (b) generic instances
+                --   (c) local family instance decls
        ; addInsts local_info         $
          addInsts generic_inst_info  $
          addFamInsts at_idx_tycons   $ do {
@@ -357,27 +357,6 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
                   generic_inst_info ++ deriv_inst_info ++ local_info,
                   aux_binds `plusHsValBinds` deriv_binds)
     }}}
-  where
-    -- Make sure that toplevel type instance are not for associated types.
-    -- !!!TODO: Need to perform this check for the TyThing of type functions,
-    --          too.
-    tcIdxTyInstDeclTL ldecl@(L loc decl) =
-      do { tything <- tcFamInstDecl ldecl
-         ; setSrcSpan loc $
-             when (isAssocFamily tything) $
-               addErr $ assocInClassErr (tcdName decl)
-         ; return tything
-         }
-    isAssocFamily (ATyCon tycon) =
-      case tyConFamInst_maybe tycon of
-        Nothing       -> panic "isAssocFamily: no family?!?"
-        Just (fam, _) -> isTyConAssoc fam
-    isAssocFamily _ = panic "isAssocFamily: no tycon?!?"
-
-assocInClassErr :: Name -> SDoc
-assocInClassErr name =
-  ptext (sLit "Associated type") <+> quotes (ppr name) <+>
-  ptext (sLit "must be inside a class instance")
 
 addInsts :: [InstInfo Name] -> TcM a -> TcM a
 addInsts infos thing_inside
@@ -414,7 +393,8 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
 
         -- Next, process any associated types.
         ; idx_tycons <- recoverM (return []) $
-	  	     do { idx_tycons <- checkNoErrs $ mapAndRecoverM tcFamInstDecl ats
+	  	     do { idx_tycons <- checkNoErrs $ 
+                                        mapAndRecoverM (tcFamInstDecl NotTopLevel) ats
 		     	; checkValidAndMissingATs clas (tyvars, inst_tys)
                           			  (zip ats idx_tycons)
 			; return idx_tycons }
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 83f05da..1998911 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -247,8 +247,8 @@ lot of kinding and type checking code with ordinary algebraic data types (and
 GADTs).
 
 \begin{code}
-tcFamInstDecl :: LTyClDecl Name -> TcM TyThing
-tcFamInstDecl (L loc decl)
+tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyThing
+tcFamInstDecl top_lvl (L loc decl)
   =	-- Prime error recovery, set source location
     setSrcSpan loc				$
     tcAddDeclCtxt decl				$
@@ -263,8 +263,26 @@ tcFamInstDecl (L loc decl)
        ; tc <- tcFamInstDecl1 decl
        ; checkValidTyCon tc	-- Remember to check validity;
 				-- no recursion to worry about here
+
+       -- Check that toplevel type instances are not for associated types.
+       ; when (isTopLevel top_lvl && isAssocFamily tc)
+              (addErr $ assocInClassErr (tcdName decl))
+
        ; return (ATyCon tc) }
 
+isAssocFamily :: TyCon -> Bool	-- Is an assocaited type
+isAssocFamily tycon
+  = case tyConFamInst_maybe tycon of
+          Nothing       -> panic "isAssocFamily: no family?!?"
+          Just (fam, _) -> isTyConAssoc fam
+
+assocInClassErr :: Name -> SDoc
+assocInClassErr name
+ = ptext (sLit "Associated type") <+> quotes (ppr name) <+>
+   ptext (sLit "must be inside a class instance")
+
+
+
 tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon
 
   -- "type instance"
-- 
1.7.10.4