[project @ 2000-09-28 16:49:36 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcTyClsDecls.lhs

diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index a194ed3..f0518d3 100644 (file)
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -12,12 +12,12 @@ module TcTyClsDecls (
 
 import HsSyn           ( HsDecl(..), TyClDecl(..),
                          HsType(..), HsTyVarBndr,
-                         ConDecl(..), ConDetails(..), BangType(..),
+                         ConDecl(..), ConDetails(..), 
                          Sig(..), HsPred(..), HsTupCon(..),
                          tyClDeclName, hsTyVarNames, isClassDecl, isSynDecl, isClassOpSig, getBangType
                        )
 import RnHsSyn         ( RenamedHsDecl, RenamedTyClDecl, listTyCon_name )
-import BasicTypes      ( RecFlag(..), NewOrData(..), Arity )
+import BasicTypes      ( RecFlag(..), NewOrData(..) )
 
 import TcMonad
 import TcEnv           ( ValueEnv, TyThing(..), TyThingDetails(..), tyThingKind,
@@ -26,7 +26,7 @@ import TcEnv          ( ValueEnv, TyThing(..), TyThingDetails(..), tyThingKind,
 import TcTyDecls       ( tcTyDecl1, kcConDetails, mkNewTyConRep )
 import TcClassDcl      ( tcClassDecl1 )
 import TcMonoType      ( kcHsTyVars, kcHsType, kcHsBoxedSigType, kcHsContext, mkTyClTyVars )
-import TcType          ( TcKind, newKindVar, newKindVars, zonkKindEnv )
+import TcType          ( TcKind, newKindVar, zonkKindEnv )
 
 import TcUnify         ( unifyKind )
 import Type            ( Kind, mkArrowKind, boxedTypeKind, zipFunTys )
@@ -34,18 +34,15 @@ import Variance         ( calcTyConArgVrcs )
 import Class           ( Class, mkClass, classTyCon )
 import TyCon           ( TyCon, ArgVrcs, AlgTyConFlavour(..), mkSynTyCon, mkAlgTyCon, mkClassTyCon )
 import DataCon         ( isNullaryDataCon )
-import Var             ( TyVar, tyVarKind, varName )
-import VarEnv
+import Var             ( varName )
 import FiniteMap
-import Bag     
 import Digraph         ( stronglyConnComp, SCC(..) )
 import Name            ( Name, NamedThing(..), NameEnv, getSrcLoc, isTvOcc, nameOccName,
                          mkNameEnv, lookupNameEnv_NF
                        )
 import Outputable
 import Maybes          ( mapMaybe, catMaybes )
-import UniqSet         ( UniqSet, emptyUniqSet,
-                         unitUniqSet, unionUniqSets, 
+import UniqSet         ( emptyUniqSet, unitUniqSet, unionUniqSets, 
                          unionManyUniqSets, uniqSetToList ) 
 import ErrUtils                ( Message )
 import Unique          ( Unique, Uniquable(..) )
@@ -131,7 +128,7 @@ tcGroup unf_env scc
            rec_details = mkNameEnv rec_details_list
 
            tyclss, all_tyclss :: [(Name, TyThing)]
-           tyclss      = map (buildTyConOrClass is_rec kind_env rec_vrcs rec_details) decls
+           tyclss = map (buildTyConOrClass is_rec kind_env rec_vrcs rec_details) decls
 
                -- Add the tycons that come from the classes
                -- We want them in the environment because 
@@ -148,7 +145,7 @@ tcGroup unf_env scc
        mapTc (tcTyClDecl1 unf_env) decls       `thenTc` \ tycls_details ->
        tcGetEnv                                `thenNF_Tc` \ env -> 
        returnTc (tycls_details, env)
-    )                                                          `thenTc` \ (_, env) ->
+    )                                          `thenTc` \ (_, env) ->
     returnTc env
   where
     is_rec = case scc of
@@ -162,8 +159,11 @@ tcGroup unf_env scc
 tcTyClDecl1  :: ValueEnv -> RenamedTyClDecl -> TcM s (Name, TyThingDetails)
 
 tcTyClDecl1 unf_env decl
-  | isClassDecl decl = tcClassDecl1 unf_env decl
-  | otherwise       = tcTyDecl1 decl
+  = tcAddDeclCtxt decl                 $
+    if isClassDecl decl then
+       tcClassDecl1 unf_env decl
+    else
+       tcTyDecl1 decl
 \end{code}
 
 
@@ -240,7 +240,7 @@ kcTyClDecl decl@(ClassDecl context class_name
     kcHsContext context                        `thenTc_`
     mapTc_ kc_sig (filter isClassOpSig class_sigs)
   where
-    kc_sig (ClassOpSig _ _ _ op_ty loc) = tcAddSrcLoc loc (kcHsBoxedSigType op_ty)
+    kc_sig (ClassOpSig _ _ op_ty loc) = tcAddSrcLoc loc (kcHsBoxedSigType op_ty)
 
 kcTyClDeclBody :: Name -> [HsTyVarBndr Name]   -- Kind of the tycon/cls and its tyvars
               -> (Kind -> TcM s a)             -- Thing inside
@@ -426,7 +426,6 @@ get_con (ConDecl _ _ _ ctxt details _)
 ----------------------------------------------------
 get_con_details (VanillaCon btys)    = unionManyUniqSets (map get_bty btys)
 get_con_details (InfixCon bty1 bty2) = unionUniqSets (get_bty bty1) (get_bty bty2)
-get_con_details (NewCon ty _)        = get_ty ty
 get_con_details (RecCon nbtys)       = unionManyUniqSets (map (get_bty.snd) nbtys)
 
 ----------------------------------------------------
@@ -452,13 +451,12 @@ get_tys tys = unionManyUniqSets (map get_ty tys)
 get_sigs sigs
   = unionManyUniqSets (map get_sig sigs)
   where 
-    get_sig (ClassOpSig _ _ _ ty _) = get_ty ty
-    get_sig (FixSig _)             = emptyUniqSet
+    get_sig (ClassOpSig _ _ ty _) = get_ty ty
+    get_sig (FixSig _)           = emptyUniqSet
     get_sig other = panic "TcTyClsDecls:get_sig"
 
 ----------------------------------------------------
 set_name name = unitUniqSet (getUnique name)
-set_to_bag set = listToBag (uniqSetToList set)
 \end{code}
 
 
@@ -478,8 +476,8 @@ tcAddDeclCtxt decl thing_inside
        = case decl of
            (ClassDecl _ name _ _ _ _ _ _ _ _ _ loc) -> (name, loc, "class")
            (TySynonym name _ _ loc)                 -> (name, loc, "type synonym")
-           (TyData NewType  _ name _ _ _ _ _ loc)   -> (name, loc, "data type")
-           (TyData DataType _ name _ _ _ _ _ loc)   -> (name, loc, "newtype")
+           (TyData NewType  _ name _ _ _ _ _ loc)   -> (name, loc, "newtype")
+           (TyData DataType _ name _ _ _ _ _ loc)   -> (name, loc, "data type")
 
      ctxt = hsep [ptext SLIT("In the"), text thing, 
                  ptext SLIT("declaration for"), quotes (ppr name)]
@@ -502,4 +500,5 @@ pp_cycle str decls
       = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
      where
         name = tyClDeclName decl
+
 \end{code}