[project @ 2003-12-10 14:15:16 by simonmar]

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

diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index 382ce38..0d29681 100644 (file)
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -10,43 +10,45 @@ module TcTyClsDecls (
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

-import CmdLineOpts     ( DynFlags, DynFlag(..), dopt )
-import HsSyn           ( TyClDecl(..),  
-                         ConDecl(..),   Sig(..), HsPred(..), 
-                         tyClDeclName, hsTyVarNames, tyClDeclTyVars,
-                         isIfaceSigDecl, isClassDecl, isSynDecl, isClassOpSig
+import HsSyn           ( TyClDecl(..),  HsConDetails(..), HsTyVarBndr(..),
+                         ConDecl(..),   Sig(..), BangType(..), HsBang(..),
+                         tyClDeclTyVars, getBangType, getBangStrictness,
+                         LTyClDecl, tcdName, LHsTyVarBndr

                        )
                        )

-import RnHsSyn         ( RenamedTyClDecl, tyClDeclFVs )
-import BasicTypes      ( RecFlag(..), NewOrData(..), isRec )
-import HscTypes                ( implicitTyThingIds )
-
-import TcMonad
-import TcEnv           ( TcEnv, RecTcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..),
-                         tcExtendKindEnv, tcLookup, tcExtendGlobalEnv, tcExtendGlobalValEnv )
-import TcTyDecls       ( tcTyDecl1, kcConDetails )
-import TcClassDcl      ( tcClassDecl1 )
-import TcInstDcls      ( tcAddDeclCtxt )
-import TcMonoType      ( kcHsTyVars, kcHsType, kcHsLiftedSigType, kcHsContext, mkTyClTyVars )
-import TcMType         ( unifyKind, newKindVar, zonkKindEnv )
-import TcType          ( Type, Kind, mkArrowKind, liftedTypeKind, zipFunTys )
-import Variance         ( calcTyConArgVrcs )
-import Class           ( Class, mkClass, classTyCon )
-import TyCon           ( TyCon, ArgVrcs, AlgTyConFlavour(..), 
-                         tyConKind, tyConDataCons,
-                         mkSynTyCon, mkAlgTyCon, mkClassTyCon, mkForeignTyCon, 
-                         isRecursiveTyCon )
-import DataCon         ( dataConOrigArgTys )
-import Var             ( varName )
-import FiniteMap
-import Digraph         ( stronglyConnComp, SCC(..) )
-import Name            ( Name, getSrcLoc, isTyVarName )
-import NameEnv
-import NameSet
+import BasicTypes      ( RecFlag(..), NewOrData(..), StrictnessMark(..) )
+import HscTypes                ( implicitTyThings )
+import BuildTyCl       ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon )
+import TcRnMonad
+import TcEnv           ( TcTyThing(..), TyThing(..), 
+                         tcLookupLocated, tcLookupLocatedGlobal, 
+                         tcExtendGlobalEnv,
+                         tcExtendRecEnv, tcLookupTyVar )
+import TcTyDecls       ( calcTyConArgVrcs, calcRecFlags, calcCycleErrs )
+import TcClassDcl      ( tcClassSigs, tcAddDeclCtxt )
+import TcHsType                ( kcHsTyVars, kcHsLiftedSigType, kcHsSigType, kcCheckHsType, 
+                         kcHsContext, tcTyVarBndrs, tcHsKindedType, tcHsKindedContext )
+import TcMType         ( newKindVar, checkValidTheta, checkValidType, checkFreeness, 
+                         UserTypeCtxt(..), SourceTyCtxt(..) ) 
+import TcUnify         ( unifyKind )
+import TcType          ( TcKind, ThetaType, TcType, tyVarsOfType,
+                         mkArrowKind, liftedTypeKind, 
+                         tcSplitSigmaTy, tcEqType )
+import Type            ( splitTyConApp_maybe, pprThetaArrow, pprParendType )
+import FieldLabel      ( fieldLabelName, fieldLabelType )
+import Generics                ( validGenericMethodType, canDoGenerics )
+import Class           ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars )
+import TyCon           ( TyCon, ArgVrcs, DataConDetails(..), 
+                         tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon,
+                         tyConTheta, getSynTyConDefn, tyConDataCons, isSynTyCon, tyConName )
+import DataCon         ( DataCon, dataConWrapId, dataConName, dataConSig, dataConFieldLabels )
+import Var             ( TyVar, idType, idName )
+import VarSet          ( elemVarSet )
+import Name            ( Name, getSrcLoc )

 import Outputable
 import Outputable

-import Maybes          ( mapMaybe )
-import ErrUtils                ( Message )
-import HsDecls          ( getClassDeclSysNames )
-import Generics         ( mkTyConGenInfo )
+import Util            ( zipLazy, isSingleton, notNull )
+import SrcLoc          ( srcLocSpan, Located(..), unLoc )
+import ListSetOps      ( equivClasses )
+import CmdLineOpts     ( DynFlag( Opt_GlasgowExts, Opt_Generics, Opt_UnboxStrictFields ) )

 \end{code}
 
 
 \end{code}
 
 

@@ -56,27 +58,6 @@ import Generics         ( mkTyConGenInfo )
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

-The main function
-~~~~~~~~~~~~~~~~~
-\begin{code}
-tcTyAndClassDecls :: RecTcEnv          -- Knot tying stuff
-                 -> [RenamedTyClDecl]
-                 -> TcM TcEnv
-
-tcTyAndClassDecls unf_env decls
-  = sortByDependency decls             `thenTc` \ groups ->
-    tcGroups unf_env groups
-
-tcGroups unf_env []
-  = tcGetEnv   `thenNF_Tc` \ env ->
-    returnTc env
-
-tcGroups unf_env (group:groups)
-  = tcGroup unf_env group      `thenTc` \ env ->
-    tcSetEnv env               $
-    tcGroups unf_env groups
-\end{code}
-

 Dealing with a group
 ~~~~~~~~~~~~~~~~~~~~
 Consider a mutually-recursive group, binding 
 Dealing with a group
 ~~~~~~~~~~~~~~~~~~~~
 Consider a mutually-recursive group, binding 

@@ -107,117 +88,90 @@ Step 5:   tcTyClDecl1
        to tcTyClDecl1.
        
 
        to tcTyClDecl1.
        
 

-Step 6:                tcTyClDecl1 again
-       For a recursive group only, check all the decls again, just
-       but this time with the wimp flag off.  Now we can check things
-       like whether a function argument is an unlifted tuple, looking
-       through type synonyms properly.  We can't do that in Step 5.
-
-Step 7:                Extend environment
+Step 6:                Extend environment

        We extend the type environment with bindings not only for the TyCons and Classes,
        but also for their "implicit Ids" like data constructors and class selectors
 
        We extend the type environment with bindings not only for the TyCons and Classes,
        but also for their "implicit Ids" like data constructors and class selectors
 

+Step 7:                checkValidTyCl
+       For a recursive group only, check all the decls again, just
+       to check all the side conditions on validity.  We could not
+       do this before because we were in a mutually recursive knot.
+
+

 The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
 @TyThing@s.  @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
 
 \begin{code}
 The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
 @TyThing@s.  @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
 
 \begin{code}

-tcGroup :: RecTcEnv -> SCC RenamedTyClDecl -> TcM TcEnv
-tcGroup unf_env scc
-  = getDOptsTc                                                 `thenTc` \ dflags ->
-       -- Step 1
-    mapNF_Tc getInitialKind decls                              `thenNF_Tc` \ initial_kinds ->
-
-       -- Step 2
-    tcExtendKindEnv initial_kinds (mapTc kcTyClDecl decls)     `thenTc_`
-
-       -- Step 3
-    zonkKindEnv initial_kinds                  `thenNF_Tc` \ final_kinds ->
-
-       -- Tie the knot
-    traceTc (text "starting" <+> ppr final_kinds)              `thenTc_`
-    fixTc ( \ ~(rec_details_list, _, _) ->
-               -- Step 4 
-       let
-           kind_env    = mkNameEnv final_kinds
-           rec_details = mkNameEnv rec_details_list
-
-           tyclss, all_tyclss :: [TyThing]
-           tyclss = map (buildTyConOrClass dflags is_rec kind_env 
-                                                  rec_vrcs rec_details) decls
-
-               -- Add the tycons that come from the classes
-               -- We want them in the environment because 
-               -- they are mentioned in interface files
-           all_tyclss  = [ ATyCon (classTyCon clas) | AClass clas <- tyclss]
-                         ++ tyclss
-
-               -- Calculate variances, and (yes!) feed back into buildTyConOrClass.
-            rec_vrcs    = calcTyConArgVrcs [tc | ATyCon tc <- all_tyclss]
-       in
-               -- Step 5
-       tcExtendGlobalEnv all_tyclss                    $
-       mapTc (tcTyClDecl1 is_rec unf_env) decls        `thenTc` \ tycls_details ->
-
-               -- Return results
-       tcGetEnv                                        `thenNF_Tc` \ env ->
-       returnTc (tycls_details, all_tyclss, env)
-    )                                          `thenTc` \ (_, all_tyclss, env) ->
-
-    tcSetEnv env                               $
-
-    traceTc (text "ready for pass 2" <+> ppr (isRec is_rec))                   `thenTc_`
-
-       -- Step 6
-       -- For a recursive group, check all the types again,
-       -- this time with the wimp flag off
-    (if isRec is_rec then
-       mapTc_ (tcTyClDecl1 NonRecursive unf_env) decls
-     else
-       returnTc ()
-    )                                          `thenTc_`
-
-    traceTc (text "done")                      `thenTc_`
-
-       -- Step 7
-       -- Extend the environment with the final TyCons/Classes 
-       -- and their implicit Ids
-    tcExtendGlobalValEnv (implicitTyThingIds all_tyclss) tcGetEnv
-
+tcTyAndClassDecls :: [LTyClDecl Name]
+                  -> TcM TcGblEnv      -- Input env extended by types and classes 
+                                       -- and their implicit Ids,DataCons
+tcTyAndClassDecls decls
+  = do {       -- First check for cyclic type synonysm or classes
+               -- See notes with checkCycleErrs
+         checkCycleErrs decls
+
+       ; let { udecls = map unLoc decls }
+       ; tyclss <- fixM (\ rec_tyclss ->
+         do    { lcl_things <- mappM getInitialKind udecls
+                       -- Extend the local env with kinds, and
+                       -- the global env with the knot-tied results
+               ; let { gbl_things = mkGlobalThings udecls rec_tyclss }
+               ; tcExtendRecEnv gbl_things lcl_things $ do     
+
+               -- The local type environment is populated with 
+               --              {"T" -> ARecTyCon k, ...}
+               -- and the global type envt with
+               --              {"T" -> ATyCon T, ...}
+               -- where k is T's (unzonked) kind
+               --       T is the loop-tied TyCon itself
+               -- We must populate the environment with the loop-tied T's right
+               -- away, because the kind checker may "fault in" some type 
+               -- constructors that recursively mention T
+
+               -- Kind-check the declarations, returning kind-annotated decls
+               { kc_decls <- mappM kcTyClDecl decls
+
+               -- Calculate variances and rec-flag
+               ; let { calc_vrcs = calcTyConArgVrcs rec_tyclss
+                     ; calc_rec  = calcRecFlags     rec_tyclss }
+                   
+               ; mappM (tcTyClDecl calc_vrcs calc_rec) kc_decls
+           }})
+       -- Finished with knot-tying now
+       -- Extend the environment with the finished things
+       ; tcExtendGlobalEnv tyclss $ do
+
+       -- Perform the validity check
+       { traceTc (text "ready for validity check")
+       ; mappM_ checkValidTyCl decls
+       ; traceTc (text "done")
+   
+       -- Add the implicit things;
+       -- we want them in the environment because 
+       -- they may be mentioned in interface files
+       ; let { implicit_things = concatMap implicitTyThings tyclss }
+       ; traceTc ((text "Adding" <+> ppr tyclss) $$ (text "and" <+> ppr implicit_things))
+       ; tcExtendGlobalEnv implicit_things getGblEnv
+    }}
+
+mkGlobalThings :: [TyClDecl Name]      -- The decls
+              -> [TyThing]             -- Knot-tied, in 1-1 correspondence with the decls
+              -> [(Name,TyThing)]
+-- Driven by the Decls, and treating the TyThings lazily
+-- make a TypeEnv for the new things
+mkGlobalThings decls things
+  = map mk_thing (decls `zipLazy` things)

   where
   where

-    is_rec = case scc of
-               AcyclicSCC _ -> NonRecursive
-               CyclicSCC _  -> Recursive
-
-    decls = case scc of
-               AcyclicSCC decl -> [decl]
-               CyclicSCC decls -> decls
-
-tcTyClDecl1 is_rec unf_env decl
-  | isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 is_rec unf_env decl)
-  | otherwise       = tcAddDeclCtxt decl (tcTyDecl1    is_rec unf_env decl)
-\end{code}
-
-
-%************************************************************************
-%*                                                                     *
-\subsection{Step 1: Initial environment}
-%*                                                                     *
-%************************************************************************
-
-\begin{code}
-getInitialKind :: RenamedTyClDecl -> NF_TcM (Name, TcKind)
-getInitialKind decl
- = kcHsTyVars (tyClDeclTyVars decl)    `thenNF_Tc` \ arg_kinds ->
-   newKindVar                          `thenNF_Tc` \ result_kind  ->
-   returnNF_Tc (tcdName decl, mk_kind arg_kinds result_kind)
-
-mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds
+    mk_thing (ClassDecl {tcdLName = L _ name}, ~(AClass cl))
+        = (name, AClass cl)
+    mk_thing (decl, ~(ATyCon tc))
+         = (tcdName decl, ATyCon tc)

 \end{code}
 
 
 %************************************************************************
 %*                                                                     *
 \end{code}
 
 
 %************************************************************************
 %*                                                                     *

-\subsection{Step 2: Kind checking}
+               Kind checking

 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

@@ -235,253 +189,414 @@ depends on *all the uses of class D*.  For example, the use of
 Monad c in bop's type signature means that D must have kind Type->Type.
 
 \begin{code}
 Monad c in bop's type signature means that D must have kind Type->Type.
 
 \begin{code}

-kcTyClDecl :: RenamedTyClDecl -> TcM ()
+------------------------------------------------------------------------
+getInitialKind :: TyClDecl Name -> TcM (Name, TcTyThing)
+
+-- Note the lazy pattern match on the ATyCon etc
+-- Exactly the same reason as the zipLay above
+
+getInitialKind (TyData {tcdLName = L _ name})
+ = newKindVar                          `thenM` \ kind  ->
+   returnM (name, ARecTyCon kind)
+
+getInitialKind (TySynonym {tcdLName = L _ name})
+ = newKindVar                          `thenM` \ kind  ->
+   returnM (name, ARecTyCon kind)
+
+getInitialKind (ClassDecl {tcdLName = L _ name})
+ = newKindVar                          `thenM` \ kind  ->
+   returnM (name, ARecClass kind)
+

 
 

-kcTyClDecl decl@(TySynonym {tcdSynRhs = rhs})
-  = kcTyClDeclBody decl                $ \ result_kind ->
-    kcHsType rhs               `thenTc` \ rhs_kind ->
-    unifyKind result_kind rhs_kind
+------------------------------------------------------------------------
+kcTyClDecl :: LTyClDecl Name -> TcM (LTyClDecl Name)

 
 

-kcTyClDecl (ForeignType {}) = returnTc ()
+kcTyClDecl decl@(L loc d@(TySynonym {tcdSynRhs = rhs}))
+  = do         { res_kind <- newKindVar
+       ; kcTyClDeclBody decl res_kind          $ \ tvs' ->
+         do { rhs' <- kcCheckHsType rhs res_kind
+            ; return (L loc d{tcdTyVars = tvs', tcdSynRhs = rhs'}) } }

 
 

-kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls})
-  = kcTyClDeclBody decl                        $ \ result_kind ->
-    kcHsContext context                        `thenTc_` 
-    mapTc_ kc_con_decl con_decls
+kcTyClDecl decl@(L loc d@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}))
+  = kcTyClDeclBody decl liftedTypeKind $ \ tvs' ->
+    do { ctxt' <- kcHsContext ctxt     
+       ; cons' <- mappM (wrapLocM kc_con_decl) cons
+       ; return (L loc d{tcdTyVars = tvs', tcdCtxt = ctxt', tcdCons = cons'}) }

   where
   where

-    kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc)
-      = kcHsTyVars ex_tvs              `thenNF_Tc` \ kind_env ->
-       tcExtendKindEnv kind_env        $
-       kcConDetails new_or_data ex_ctxt details
-
-kcTyClDecl decl@(ClassDecl {tcdCtxt = context,  tcdSigs = class_sigs})
-  = kcTyClDeclBody decl                $ \ result_kind ->
-    kcHsContext context                `thenTc_`
-    mapTc_ kc_sig (filter isClassOpSig class_sigs)
+    kc_con_decl (ConDecl name ex_tvs ex_ctxt details)
+      = kcHsTyVars ex_tvs              $ \ ex_tvs' ->
+       do { ex_ctxt' <- kcHsContext ex_ctxt
+          ; details' <- kc_con_details details 
+          ; return (ConDecl name ex_tvs' ex_ctxt' details')}
+
+    kc_con_details (PrefixCon btys) 
+       = do { btys' <- mappM kc_larg_ty btys ; return (PrefixCon btys') }
+    kc_con_details (InfixCon bty1 bty2) 
+       = do { bty1' <- kc_larg_ty bty1; bty2' <- kc_larg_ty bty2; return (InfixCon bty1' bty2') }
+    kc_con_details (RecCon fields) 
+       = do { fields' <- mappM kc_field fields; return (RecCon fields') }
+
+    kc_field (fld, bty) = do { bty' <- kc_larg_ty bty ; return (fld, bty') }
+
+    kc_larg_ty = wrapLocM kc_arg_ty
+
+    kc_arg_ty (BangType str ty) = do { ty' <- kc_arg_ty_body ty; return (BangType str ty') }
+    kc_arg_ty_body = case new_or_data of
+                        DataType -> kcHsSigType
+                        NewType  -> kcHsLiftedSigType
+           -- Can't allow an unlifted type for newtypes, because we're effectively
+           -- going to remove the constructor while coercing it to a lifted type.
+
+kcTyClDecl decl@(L loc d@(ClassDecl {tcdCtxt = ctxt,  tcdSigs = sigs}))
+  = kcTyClDeclBody decl liftedTypeKind $ \ tvs' ->
+    do { ctxt' <- kcHsContext ctxt     
+       ; sigs' <- mappM (wrapLocM kc_sig) sigs
+       ; return (L loc d{tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs'}) }

   where
   where

-    kc_sig (ClassOpSig _ _ op_ty loc) = kcHsLiftedSigType op_ty
-
-kcTyClDeclBody :: RenamedTyClDecl -> (Kind -> TcM a) -> TcM a
--- Extend the env with bindings for the tyvars, taken from
--- the kind of the tycon/class.  Give it to the thing inside, and 
--- check the result kind matches
-kcTyClDeclBody decl thing_inside
+    kc_sig (Sig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
+                               ; return (Sig nm op_ty') }
+    kc_sig other_sig         = return other_sig
+
+kcTyClDecl decl@(L _ (ForeignType {}))
+  = return decl
+
+kcTyClDeclBody :: LTyClDecl Name -> TcKind
+              -> ([LHsTyVarBndr Name] -> TcM a)
+              -> TcM a
+  -- Extend the env with bindings for the tyvars, taken from
+  -- the kind of the tycon/class.  Give it to the thing inside, and 
+  -- check the result kind matches
+kcTyClDeclBody decl res_kind thing_inside

   = tcAddDeclCtxt decl         $
   = tcAddDeclCtxt decl         $

-    tcLookup (tcdName decl)    `thenNF_Tc` \ thing ->
-    let
-       kind = case thing of
-                 AGlobal (ATyCon tc) -> tyConKind tc
-                 AGlobal (AClass cl) -> tyConKind (classTyCon cl)
-                 AThing kind         -> kind
-               -- For some odd reason, a class doesn't include its kind
-
-       (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames (tyClDeclTyVars decl)) kind
-    in
-    tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind)
+    kcHsTyVars (tyClDeclTyVars (unLoc decl))   $ \ kinded_tvs ->
+    do         { tc_ty_thing <- tcLookupLocated (tcdLName (unLoc decl))
+       ; let { tc_kind = case tc_ty_thing of
+                           ARecClass k -> k
+                           ARecTyCon k -> k
+         }
+       ; unifyKind tc_kind (foldr (mkArrowKind . kindedTyVarKind) 
+                                  res_kind kinded_tvs)
+       ; thing_inside kinded_tvs }
+
+kindedTyVarKind (L _ (KindedTyVar _ k)) = k

 \end{code}
 
 
 %************************************************************************
 %*                                                                     *
 \end{code}
 
 
 %************************************************************************
 %*                                                                     *

-\subsection{Step 4: Building the tycon/class}
+\subsection{Type checking}

 %*                                                                     *
 %************************************************************************
 
 \begin{code}
 %*                                                                     *
 %************************************************************************
 
 \begin{code}

-buildTyConOrClass 
-       :: DynFlags
-       -> RecFlag -> NameEnv Kind
-       -> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
-       -> RenamedTyClDecl -> TyThing
-
-buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
-                 (TySynonym {tcdName = tycon_name, tcdTyVars = tyvar_names})
-  = ATyCon tycon
+tcTyClDecl :: (Name -> ArgVrcs) -> (Name -> RecFlag) 
+          -> LTyClDecl Name -> TcM TyThing
+
+tcTyClDecl calc_vrcs calc_isrec decl
+  = tcAddDeclCtxt decl (tcTyClDecl1 calc_vrcs calc_isrec (unLoc decl))
+
+tcTyClDecl1 calc_vrcs calc_isrec 
+  (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
+  =   tcTyVarBndrs tvs         $ \ tvs' -> do 
+    { rhs_ty' <- tcHsKindedType rhs_ty
+    ; return (ATyCon (buildSynTyCon tc_name tvs' rhs_ty' arg_vrcs)) }

   where
   where

-       tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
-       tycon_kind          = lookupNameEnv_NF kenv tycon_name
-       arity               = length tyvar_names
-       tyvars              = mkTyClTyVars tycon_kind tyvar_names
-       SynTyDetails rhs_ty = lookupNameEnv_NF rec_details tycon_name
-        argvrcs                    = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
-
-buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
-                 (TyData {tcdND = data_or_new, tcdName = tycon_name, tcdTyVars = tyvar_names,
-                          tcdNCons = nconstrs, tcdSysNames = sys_names})
-  = ATyCon tycon
+    arg_vrcs = calc_vrcs tc_name
+
+tcTyClDecl1 calc_vrcs calc_isrec 
+  (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
+          tcdLName = L _ tc_name, tcdCons = cons})
+  = tcTyVarBndrs tvs           $ \ tvs' -> do 
+  { ctxt'       <- tcHsKindedContext ctxt
+  ; want_generic <- doptM Opt_Generics
+  ; tycon <- fixM (\ tycon -> do 
+       { cons' <- mappM (addLocM (tcConDecl new_or_data tycon tvs' ctxt')) cons
+       ; buildAlgTyCon new_or_data tc_name tvs' ctxt' 
+                       (DataCons cons') arg_vrcs is_rec
+                       (want_generic && canDoGenerics cons')
+       })
+  ; return (ATyCon tycon)
+  }

   where
   where

-       tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
-                          data_cons nconstrs sel_ids
-                          flavour is_rec gen_info
-
-       gen_info | not (dopt Opt_Generics dflags) = Nothing
-                | otherwise = mkTyConGenInfo tycon sys_names
-
-       DataTyDetails ctxt data_cons sel_ids = lookupNameEnv_NF rec_details tycon_name
-
-       tycon_kind = lookupNameEnv_NF kenv tycon_name
-       tyvars     = mkTyClTyVars tycon_kind tyvar_names
-        argvrcs           = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
-
-       -- Watch out!  mkTyConApp asks whether the tycon is a NewType,
-       -- so flavour has to be able to answer this question without consulting rec_details
-       flavour = case data_or_new of
-                   NewType  -> NewTyCon (mkNewTyConRep tycon)
-                   DataType | all (null . dataConOrigArgTys) data_cons -> EnumTyCon
-                            | otherwise                                -> DataTyCon
-                       -- NB (null . dataConOrigArgTys).  It used to say isNullaryDataCon
-                       -- but that looks at the *representation* arity, and that in turn
-                       -- depends on deciding whether to unpack the args, and that 
-                       -- depends on whether it's a data type or a newtype --- so
-                       -- in the recursive case we can get a loop.  This version is simple!
-
-buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
-                  (ForeignType {tcdName = tycon_name, tcdExtName = tycon_ext_name})
-  = ATyCon (mkForeignTyCon tycon_name tycon_ext_name liftedTypeKind 0 [])
-
-buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
-                  (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names,
-                             tcdFDs = fundeps, tcdSysNames = name_list} )
-  = AClass clas
+    arg_vrcs = calc_vrcs tc_name
+    is_rec   = calc_isrec tc_name
+
+tcTyClDecl1 calc_vrcs calc_isrec 
+  (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs, 
+             tcdCtxt = ctxt, tcdMeths = meths,
+             tcdFDs = fundeps, tcdSigs = sigs} )
+  = tcTyVarBndrs tvs           $ \ tvs' -> do 
+  { ctxt' <- tcHsKindedContext ctxt
+  ; fds' <- mappM (addLocM tc_fundep) fundeps
+  ; sig_stuff <- tcClassSigs class_name sigs meths
+  ; clas <- fixM (\ clas ->
+               let     -- This little knot is just so we can get
+                       -- hold of the name of the class TyCon, which we
+                       -- need to look up its recursiveness and variance
+                   tycon_name = tyConName (classTyCon clas)
+                   tc_isrec = calc_isrec tycon_name
+                   tc_vrcs  = calc_vrcs  tycon_name
+               in
+               buildClass class_name tvs' ctxt' fds' 
+                          sig_stuff tc_isrec tc_vrcs)
+  ; return (AClass clas) }

   where
   where

-        (tycon_name, _, _, _) = getClassDeclSysNames name_list
-       clas = mkClass class_name tyvars fds
-                      sc_theta sc_sel_ids op_items
-                      tycon
-
-       tycon = mkClassTyCon tycon_name class_kind tyvars
-                             argvrcs dict_con
-                            clas               -- Yes!  It's a dictionary 
-                            flavour
-                            is_rec
-               -- A class can be recursive, and in the case of newtypes 
-               -- this matters.  For example
-               --      class C a where { op :: C b => a -> b -> Int }
-               -- Because C has only one operation, it is represented by
-               -- a newtype, and it should be a *recursive* newtype.
-               -- [If we don't make it a recursive newtype, we'll expand the
-               -- newtype like a synonym, but that will lead toan inifinite type
-
-       ClassDetails sc_theta sc_sel_ids op_items dict_con = lookupNameEnv_NF rec_details class_name
-
-       class_kind = lookupNameEnv_NF kenv class_name
-       tyvars     = mkTyClTyVars class_kind tyvar_names
-        argvrcs           = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
-
-       flavour = case dataConOrigArgTys dict_con of
-                       -- The tyvars in the datacon are the same as in the class
-                   [rep_ty] -> NewTyCon rep_ty
-                   other    -> DataTyCon 
-
-       -- We can find the functional dependencies right away, 
-       -- and it is vital to do so. Why?  Because in the next pass
-       -- we check for ambiguity in all the type signatures, and we
-       -- need the functional dependcies to be done by then
-       fds        = [(map lookup xs, map lookup ys) | (xs,ys) <- fundeps]
-       tyvar_env  = mkNameEnv [(varName tv, tv) | tv <- tyvars]
-       lookup     = lookupNameEnv_NF tyvar_env
-
-bogusVrcs = panic "Bogus tycon arg variances"
-\end{code}
-
-\begin{code}
-mkNewTyConRep :: TyCon         -- The original type constructor
-             -> Type           -- Chosen representation type
--- Find the representation type for this newtype TyCon
--- For a recursive type constructor we give an error thunk,
--- because we never look at the rep in that case
--- (see notes on newypes in types/TypeRep
-
-mkNewTyConRep tc
-  | isRecursiveTyCon tc = pprPanic "Attempt to get the rep of newtype" (ppr tc)
-  | otherwise          = head (dataConOrigArgTys (head (tyConDataCons tc)))
+    tc_fundep (tvs1, tvs2) = do { tvs1' <- mappM tcLookupTyVar tvs1 ;
+                               ; tvs2' <- mappM tcLookupTyVar tvs2 ;
+                               ; return (tvs1', tvs2') }
+
+
+tcTyClDecl1 calc_vrcs calc_isrec 
+  (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name})
+  = returnM (ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0 []))
+
+-----------------------------------
+tcConDecl :: NewOrData -> TyCon -> [TyVar] -> ThetaType 
+         -> ConDecl Name -> TcM DataCon
+
+tcConDecl new_or_data tycon tyvars ctxt 
+          (ConDecl name ex_tvs ex_ctxt details)
+  = tcTyVarBndrs ex_tvs                $ \ ex_tvs' -> do 
+    { ex_ctxt' <- tcHsKindedContext ex_ctxt
+    ; unbox_strict <- doptM Opt_UnboxStrictFields
+    ; let 
+       tc_datacon field_lbls btys
+         = do { let { ubtys = map unLoc btys }
+              ; arg_tys <- mappM (tcHsKindedType . getBangType) ubtys
+              ; buildDataCon (unLoc name)
+                   (argStrictness unbox_strict tycon ubtys arg_tys)
+                   (map unLoc field_lbls)
+                   tyvars ctxt ex_tvs' ex_ctxt'
+                   arg_tys tycon }
+    ; case details of
+       PrefixCon btys     -> tc_datacon [] btys
+       InfixCon bty1 bty2 -> tc_datacon [] [bty1,bty2]
+       RecCon fields      -> do { checkTc (null ex_tvs') (exRecConErr name)
+                                ; let { (field_names, btys) = unzip fields }
+                                ; tc_datacon field_names btys } }
+
+argStrictness :: Bool          -- True <=> -funbox-strict_fields
+             -> TyCon -> [BangType Name] 
+             -> [TcType] -> [StrictnessMark]
+argStrictness unbox_strict tycon btys arg_tys
+ = zipWith (chooseBoxingStrategy unbox_strict tycon) 
+          arg_tys 
+          (map getBangStrictness btys ++ repeat HsNoBang)
+
+-- We attempt to unbox/unpack a strict field when either:
+--   (i)  The field is marked '!!', or
+--   (ii) The field is marked '!', and the -funbox-strict-fields flag is on.
+
+chooseBoxingStrategy :: Bool -> TyCon -> TcType -> HsBang -> StrictnessMark
+chooseBoxingStrategy unbox_strict_fields tycon arg_ty bang
+  = case bang of
+       HsNoBang                                    -> NotMarkedStrict
+       HsStrict | unbox_strict_fields && can_unbox -> MarkedUnboxed
+       HsUnbox  | can_unbox                        -> MarkedUnboxed
+       other                                       -> MarkedStrict
+  where
+    can_unbox = case splitTyConApp_maybe arg_ty of
+                  Nothing             -> False
+                  Just (arg_tycon, _) -> not (isRecursiveTyCon tycon) &&
+                                         isProductTyCon arg_tycon

 \end{code}
 
 \end{code}
 

-

 %************************************************************************
 %*                                                                     *
 \subsection{Dependency analysis}
 %*                                                                     *
 %************************************************************************
 
 %************************************************************************
 %*                                                                     *
 \subsection{Dependency analysis}
 %*                                                                     *
 %************************************************************************
 

-Dependency analysis
-~~~~~~~~~~~~~~~~~~~
+Validity checking is done once the mutually-recursive knot has been
+tied, so we can look at things freely.
+

 \begin{code}
 \begin{code}

-sortByDependency :: [RenamedTyClDecl] -> TcM [SCC RenamedTyClDecl]
-sortByDependency decls
-  = let                -- CHECK FOR CLASS CYCLES
-       cls_sccs   = stronglyConnComp (mapMaybe mkClassEdges tycl_decls)
-       cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
-    in
-    checkTc (null cls_cycles) (classCycleErr cls_cycles)       `thenTc_`
-
-    let                -- CHECK FOR SYNONYM CYCLES
-       syn_sccs   = stronglyConnComp (filter is_syn_decl edges)
-       syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
-
-    in
-    checkTc (null syn_cycles) (typeCycleErr syn_cycles)                `thenTc_`
-
-       -- DO THE MAIN DEPENDENCY ANALYSIS
-    let
-       decl_sccs  = stronglyConnComp edges
-    in
-    returnTc decl_sccs
+checkCycleErrs :: [LTyClDecl Name] -> TcM ()
+checkCycleErrs tyclss
+  | null syn_cycles && null cls_cycles
+  = return ()
+  | otherwise
+  = do { mappM_ recSynErr syn_cycles
+       ; mappM_ recClsErr cls_cycles
+       ; failM }       -- Give up now, because later checkValidTyCl
+                       -- will loop if the synonym is recursive

   where
   where

-    tycl_decls = filter (not . isIfaceSigDecl) decls
-    edges      = map mkEdges tycl_decls
-    
-    is_syn_decl (d, _, _) = isSynDecl d
-\end{code}
+    (syn_cycles, cls_cycles) = calcCycleErrs tyclss
+
+checkValidTyCl :: LTyClDecl Name -> TcM ()
+-- We do the validity check over declarations, rather than TyThings
+-- only so that we can add a nice context with tcAddDeclCtxt
+checkValidTyCl decl
+  = tcAddDeclCtxt decl $
+    do { thing <- tcLookupLocatedGlobal (tcdLName (unLoc decl))
+       ; traceTc (text "Validity of" <+> ppr thing)    
+       ; case thing of
+           ATyCon tc -> checkValidTyCon tc
+           AClass cl -> checkValidClass cl 
+       ; traceTc (text "Done validity of" <+> ppr thing)       
+       }
+
+-------------------------
+checkValidTyCon :: TyCon -> TcM ()
+checkValidTyCon tc
+  | isSynTyCon tc 
+  = checkValidType syn_ctxt syn_rhs
+  | otherwise
+  =    -- Check the context on the data decl
+    checkValidTheta (DataTyCtxt name) (tyConTheta tc)  `thenM_` 
+       
+       -- Check arg types of data constructors
+    mappM_ checkValidDataCon data_cons                 `thenM_`

 
 

-Edges in Type/Class decls
-~~~~~~~~~~~~~~~~~~~~~~~~~
+       -- Check that fields with the same name share a type
+    mappM_ check_fields groups

 
 

-\begin{code}
-tyClDeclFTVs :: RenamedTyClDecl -> [Name]
-       -- Find the free non-tyvar vars
-tyClDeclFTVs d = foldNameSet add [] (tyClDeclFVs d)
-              where
-                add n fvs | isTyVarName n = fvs
-                          | otherwise     = n : fvs
+  where
+    syn_ctxt    = TySynCtxt name
+    name         = tyConName tc
+    (_, syn_rhs) = getSynTyConDefn tc
+    data_cons    = tyConDataCons tc
+
+    fields = [field | con <- data_cons, field <- dataConFieldLabels con]
+    groups = equivClasses cmp_name fields
+    cmp_name field1 field2 = fieldLabelName field1 `compare` fieldLabelName field2
+
+    check_fields fields@(first_field_label : other_fields)
+       -- These fields all have the same name, but are from
+       -- different constructors in the data type
+       =       -- Check that all the fields in the group have the same type
+               -- NB: this check assumes that all the constructors of a given
+               -- data type use the same type variables
+         checkTc (all (tcEqType field_ty) other_tys) (fieldTypeMisMatch field_name)
+       where
+           field_ty   = fieldLabelType first_field_label
+           field_name = fieldLabelName first_field_label
+           other_tys  = map fieldLabelType other_fields
+
+-------------------------------
+checkValidDataCon :: DataCon -> TcM ()
+checkValidDataCon con
+  = addErrCtxt (dataConCtxt con) (
+      checkValidType ctxt (idType (dataConWrapId con)) `thenM_`
+               -- This checks the argument types and
+               -- ambiguity of the existential context (if any)
+      checkFreeness ex_tvs ex_theta)
+  where
+    ctxt = ConArgCtxt (dataConName con) 
+    (_, _, ex_tvs, ex_theta, _, _) = dataConSig con

 
 

-----------------------------------------------------
--- mk_cls_edges looks only at the context of class decls
--- Its used when we are figuring out if there's a cycle in the
--- superclass hierarchy

 
 

-mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name])
+-------------------------------
+checkValidClass :: Class -> TcM ()
+checkValidClass cls
+  = do {       -- CHECK ARITY 1 FOR HASKELL 1.4
+         gla_exts <- doptM Opt_GlasgowExts

 
 

-mkClassEdges decl@(ClassDecl {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsClassP c _ <- ctxt])
-mkClassEdges other_decl                                               = Nothing
+       -- Check that the class is unary, unless GlaExs
+       ; checkTc (notNull tyvars) (nullaryClassErr cls)
+       ; checkTc (gla_exts || unary) (classArityErr cls)

 
 

-mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
-mkEdges decl = (decl, tyClDeclName decl, tyClDeclFTVs decl)
-\end{code}
+       -- Check the super-classes
+       ; checkValidTheta (ClassSCCtxt (className cls)) theta

 
 

+       -- Check the class operations
+       ; mappM_ check_op op_stuff

 
 

-%************************************************************************
-%*                                                                     *
-\subsection{Error management
-%*                                                                     *
-%************************************************************************
+       -- Check that if the class has generic methods, then the
+       -- class has only one parameter.  We can't do generic
+       -- multi-parameter type classes!
+       ; checkTc (unary || no_generics) (genericMultiParamErr cls)
+       }
+  where
+    (tyvars, theta, _, op_stuff) = classBigSig cls
+    unary      = isSingleton tyvars
+    no_generics = null [() | (_, GenDefMeth) <- op_stuff]

 
 

-\begin{code}
-typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
+    check_op (sel_id, dm) 
+      = addErrCtxt (classOpCtxt sel_id tau) $ do
+       { checkValidTheta SigmaCtxt (tail theta)
+               -- The 'tail' removes the initial (C a) from the
+               -- class itself, leaving just the method type

 
 

-typeCycleErr syn_cycles
-  = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
+       ; checkValidType (FunSigCtxt op_name) tau

 
 

-classCycleErr cls_cycles
-  = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
+               -- Check that the type mentions at least one of
+               -- the class type variables
+       ; checkTc (any (`elemVarSet` tyVarsOfType tau) tyvars)
+                 (noClassTyVarErr cls sel_id)
+
+               -- Check that for a generic method, the type of 
+               -- the method is sufficiently simple
+       ; checkTc (dm /= GenDefMeth || validGenericMethodType op_ty)
+                 (badGenericMethodType op_name op_ty)
+       }
+       where
+         op_name = idName sel_id
+         op_ty   = idType sel_id
+         (_,theta,tau) = tcSplitSigmaTy op_ty

 
 

-pp_cycle str decls
-  = hang (text str)
-        4 (vcat (map pp_decl decls))
-  where
-    pp_decl decl
-      = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
-     where
-        name = tyClDeclName decl

 
 

+
+---------------------------------------------------------------------
+fieldTypeMisMatch field_name
+  = sep [ptext SLIT("Different constructors give different types for field"), quotes (ppr field_name)]
+
+dataConCtxt con = sep [ptext SLIT("When checking the data constructor:"),
+                      nest 2 (ex_part <+> pprThetaArrow ex_theta <+> ppr con <+> arg_part)]
+  where
+    (_, _, ex_tvs, ex_theta, arg_tys, _) = dataConSig con
+    ex_part | null ex_tvs = empty
+           | otherwise   = ptext SLIT("forall") <+> hsep (map ppr ex_tvs) <> dot
+       -- The 'ex_theta' part could be non-empty, if the user (bogusly) wrote
+       --      data T a = Eq a => T a a
+       -- So we make sure to print it
+
+    fields = dataConFieldLabels con
+    arg_part | null fields = sep (map pprParendType arg_tys)
+            | otherwise   = braces (sep (punctuate comma 
+                            [ ppr n <+> dcolon <+> ppr ty 
+                            | (n,ty) <- fields `zip` arg_tys]))
+
+classOpCtxt sel_id tau = sep [ptext SLIT("When checking the class method:"),
+                             nest 2 (ppr sel_id <+> dcolon <+> ppr tau)]
+
+nullaryClassErr cls
+  = ptext SLIT("No parameters for class")  <+> quotes (ppr cls)
+
+classArityErr cls
+  = vcat [ptext SLIT("Too many parameters for class") <+> quotes (ppr cls),
+         parens (ptext SLIT("Use -fglasgow-exts to allow multi-parameter classes"))]
+
+noClassTyVarErr clas op
+  = sep [ptext SLIT("The class method") <+> quotes (ppr op),
+        ptext SLIT("mentions none of the type variables of the class") <+> 
+               ppr clas <+> hsep (map ppr (classTyVars clas))]
+
+genericMultiParamErr clas
+  = ptext SLIT("The multi-parameter class") <+> quotes (ppr clas) <+> 
+    ptext SLIT("cannot have generic methods")
+
+badGenericMethodType op op_ty
+  = hang (ptext SLIT("Generic method type is too complex"))
+       4 (vcat [ppr op <+> dcolon <+> ppr op_ty,
+               ptext SLIT("You can only use type variables, arrows, and tuples")])
+
+recSynErr tcs
+  = addSrcSpan (srcLocSpan (getSrcLoc (head tcs))) $
+    addErr (sep [ptext SLIT("Cycle in type synonym declarations:"),
+                nest 2 (vcat (map ppr_thing tcs))])
+
+recClsErr clss
+  = addSrcSpan (srcLocSpan (getSrcLoc (head clss))) $
+    addErr (sep [ptext SLIT("Cycle in class declarations (via superclasses):"),
+                nest 2 (vcat (map ppr_thing clss))])
+
+ppr_thing :: Name -> SDoc
+ppr_thing n = ppr n <+> parens (ppr (getSrcLoc n))
+
+
+exRecConErr name
+  = ptext SLIT("Can't combine named fields with locally-quantified type variables")
+    $$
+    (ptext SLIT("In the declaration of data constructor") <+> ppr name)

 \end{code}
 \end{code}