Refactor where an error message is generated

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index a6f2b80..d4100d0 100644 (file)
--- 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
                 -- 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
        ; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1  inst_decls

-       ; idx_tycons        <- mapAndRecoverM tcIdxTyInstDeclTL idxty_decls

 
        ; let { (local_info,
                 at_tycons_s)   = unzip local_info_tycons
 
        ; 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
 
                 -- 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 {
        ; 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)
     }}}
                   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
 
 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 []) $
 
         -- 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 }
                        ; 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 (file)
--- 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}
 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                         $
   =    -- 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
        ; 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) }
 
        ; 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"
 tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon
 
   -- "type instance"