[project @ 2003-02-19 15:54:05 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 8d575da..d978e3c 100644 (file)
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -10,43 +10,44 @@ module TcTyClsDecls (
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

-import CmdLineOpts     ( DynFlags, DynFlag(..), dopt )
-import HsSyn           ( TyClDecl(..),  HsTyVarBndr,
+import HsSyn           ( TyClDecl(..),  

                          ConDecl(..),   Sig(..), HsPred(..), 
                          ConDecl(..),   Sig(..), HsPred(..), 

-                         tyClDeclName, hsTyVarNames, 
-                         isIfaceSigDecl, isClassDecl, isSynDecl, isClassOpSig
+                         tyClDeclName, hsTyVarNames, tyClDeclTyVars,
+                         isTypeOrClassDecl, isClassDecl, isSynDecl, isClassOpSig

                        )
 import RnHsSyn         ( RenamedTyClDecl, tyClDeclFVs )
                        )
 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, mkNewTyConRep )
+import BasicTypes      ( RecFlag(..), NewOrData(..) )
+import HscTypes                ( implicitTyThings )
+
+import TcRnMonad
+import TcEnv           ( TcTyThing(..), TyThing(..), TyThingDetails(..),
+                         tcExtendKindEnv, tcLookup, tcLookupGlobal, tcExtendGlobalEnv,
+                         isLocalThing )
+import TcTyDecls       ( tcTyDecl, kcConDetails )

 import TcClassDcl      ( tcClassDecl1 )
 import TcClassDcl      ( tcClassDecl1 )

-import TcMonoType      ( kcHsTyVars, kcHsType, kcHsBoxedSigType, kcHsContext, mkTyClTyVars )
-import TcType          ( TcKind, newKindVar, zonkKindEnv )
-
-import TcUnify         ( unifyKind )

 import TcInstDcls      ( tcAddDeclCtxt )
 import TcInstDcls      ( tcAddDeclCtxt )

-import Type            ( Kind, mkArrowKind, boxedTypeKind, zipFunTys )
+import TcMonoType      ( kcHsTyVars, kcHsType, kcHsLiftedSigType, kcHsContext, mkTyClTyVars )
+import TcMType         ( newKindVar, zonkKindEnv, checkValidTyCon, checkValidClass )
+import TcUnify         ( unifyKind )
+import TcType          ( Type, Kind, TcKind, mkArrowKind, liftedTypeKind, zipFunTys )
+import Type            ( splitTyConApp_maybe )

 import Variance         ( calcTyConArgVrcs )
 import Class           ( Class, mkClass, classTyCon )
 import Variance         ( calcTyConArgVrcs )
 import Class           ( Class, mkClass, classTyCon )

-import TyCon           ( TyCon, tyConKind, ArgVrcs, AlgTyConFlavour(..), 
-                         mkSynTyCon, mkAlgTyCon, mkClassTyCon )
-import DataCon         ( isNullaryDataCon )
+import TyCon           ( TyCon, ArgVrcs, AlgTyConFlavour(..), DataConDetails(..), visibleDataCons,
+                         tyConKind, tyConTyVars, tyConDataCons, isNewTyCon,
+                         mkSynTyCon, mkAlgTyCon, mkClassTyCon, mkForeignTyCon
+                       )
+import TysWiredIn      ( unitTy )
+import Subst           ( substTyWith )
+import DataCon         ( dataConOrigArgTys )

 import Var             ( varName )
 import FiniteMap
 import Digraph         ( stronglyConnComp, SCC(..) )
 import Var             ( varName )
 import FiniteMap
 import Digraph         ( stronglyConnComp, SCC(..) )

-import Name            ( Name, getSrcLoc, isTyVarName )
-import Name            ( NameEnv, mkNameEnv, lookupNameEnv_NF )
+import Name            ( Name )
+import NameEnv

 import NameSet
 import Outputable
 import Maybes          ( mapMaybe )
 import NameSet
 import Outputable
 import Maybes          ( mapMaybe )

-import ErrUtils                ( Message )
-import HsDecls          ( getClassDeclSysNames )
-import Generics         ( mkTyConGenInfo )

 \end{code}
 
 
 \end{code}
 
 

@@ -59,22 +60,20 @@ import Generics         ( mkTyConGenInfo )
 The main function
 ~~~~~~~~~~~~~~~~~
 \begin{code}
 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
+tcTyAndClassDecls :: [RenamedTyClDecl]
+                 -> TcM TcGblEnv       -- Returns extended environment
+
+tcTyAndClassDecls decls
+  = tcGroups (stronglyConnComp edges)
+  where
+    edges = map mkEdges (filter isTypeOrClassDecl decls)
+
+tcGroups [] = getGblEnv
+
+tcGroups (group:groups)
+  = tcGroup group      `thenM` \ env ->
+    setGblEnv env      $
+    tcGroups groups

 \end{code}
 
 Dealing with a group
 \end{code}
 
 Dealing with a group

@@ -107,89 +106,102 @@ 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 unboxed 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 ->
+tcGroup :: SCC RenamedTyClDecl 
+       -> TcM TcGblEnv         -- Input env extended by types and classes 
+                               -- and their implicit Ids,DataCons
+                                       
+tcGroup scc
+  =    -- Step 1
+    mappM getInitialKind decls                 `thenM` \ initial_kinds ->

 
        -- Step 2
 
        -- Step 2

-    tcExtendKindEnv initial_kinds (mapTc kcTyClDecl decls)     `thenTc_`
+    tcExtendKindEnv initial_kinds (mappM kcTyClDecl decls)     `thenM_`

 
        -- Step 3
 
        -- Step 3

-    zonkKindEnv initial_kinds                  `thenNF_Tc` \ final_kinds ->
+    zonkKindEnv initial_kinds          `thenM` \ final_kinds ->
+
+       -- Check for loops; if any are found, bale out now
+       -- because the compiler itself will loop otherwise!
+    checkNoErrs (checkLoops scc)       `thenM` \ is_rec_tycon ->

 
        -- Tie the knot
 
        -- Tie the knot

-    fixTc ( \ ~(rec_details_list, _, _) ->
+    traceTc (text "starting" <+> ppr final_kinds)              `thenM_`
+    fixM ( \ ~(rec_details_list, _, rec_all_tyclss) ->

                -- Step 4 
        let
            kind_env    = mkNameEnv final_kinds
            rec_details = mkNameEnv 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
+               -- Calculate variances, and feed into buildTyConOrClass
+            rec_vrcs = calcTyConArgVrcs [tc | ATyCon tc <- rec_all_tyclss]

 
 

-               -- 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
+           build_one = buildTyConOrClass is_rec_tycon kind_env
+                                         rec_vrcs rec_details
+           tyclss = map build_one decls

 
 

-               -- Calculate variances, and (yes!) feed back into buildTyConOrClass.
-            rec_vrcs    = calcTyConArgVrcs [tc | ATyCon tc <- all_tyclss]

        in
                -- Step 5
        in
                -- Step 5

-       tcExtendGlobalEnv all_tyclss                    $
-       mapTc (tcTyClDecl1 is_rec unf_env) decls        `thenTc` \ tycls_details ->
+               -- Extend the environment with the final 
+               -- TyCons/Classes and check the decls
+       tcExtendGlobalEnv tyclss        $
+       mappM tcTyClDecl1 decls         `thenM` \ tycls_details ->

 
                -- Return results
 
                -- Return results

-       tcGetEnv                                        `thenNF_Tc` \ env ->
-       returnTc (tycls_details, all_tyclss, env)
-    )                                          `thenTc` \ (_, all_tyclss, env) ->
-
-    tcSetEnv env                               $
-
-       -- 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_`
-
-       -- Step 7
-       -- Extend the environment with the final TyCons/Classes 
-       -- and their implicit Ids
-    tcExtendGlobalValEnv (implicitTyThingIds all_tyclss) tcGetEnv
+       getGblEnv                               `thenM` \ env ->
+       returnM (tycls_details, env, tyclss)
+    )                                          `thenM` \ (_, env, tyclss) ->
+
+       -- Step 7: Check validity
+    setGblEnv env                              $
+
+    traceTc (text "ready for validity check")  `thenM_`
+    getModule                                  `thenM` \ mod ->
+    mappM_ (checkValidTyCl mod) decls          `thenM_`
+    traceTc (text "done")                      `thenM_`
+   
+    let                -- Add the tycons that come from the classes
+               -- We want them in the environment because 
+               -- they are mentioned in interface files
+       implicit_things = implicitTyThings tyclss
+    in
+    traceTc ((text "Adding" <+> ppr tyclss) $$ (text "and" <+> ppr implicit_things))   `thenM_`
+    tcExtendGlobalEnv implicit_things getGblEnv

 
   where
 
   where

-    is_rec = case scc of
-               AcyclicSCC _ -> NonRecursive
-               CyclicSCC _  -> Recursive
-

     decls = case scc of
                AcyclicSCC decl -> [decl]
                CyclicSCC decls -> decls
 
     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)
+tcTyClDecl1 decl
+  | isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 decl)
+  | otherwise       = tcAddDeclCtxt decl (tcTyDecl     decl)
+
+-- We do the validity check over declarations, rather than TyThings
+-- only so that we can add a nice context with tcAddDeclCtxt
+checkValidTyCl this_mod decl
+  = tcLookupGlobal (tcdName decl)      `thenM` \ thing ->
+    if not (isLocalThing this_mod thing) then
+       -- Don't bother to check validity for non-local things
+       returnM ()
+    else
+    tcAddDeclCtxt decl $
+    case thing of
+       ATyCon tc -> checkValidTyCon tc
+       AClass cl -> checkValidClass cl

 \end{code}
 
 
 \end{code}
 
 

@@ -200,19 +212,11 @@ tcTyClDecl1 is_rec unf_env decl
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-getInitialKind :: RenamedTyClDecl -> NF_TcM (Name, TcKind)
-getInitialKind (TySynonym name tyvars _ _)
- = kcHsTyVars tyvars   `thenNF_Tc` \ arg_kinds ->
-   newKindVar          `thenNF_Tc` \ result_kind  ->
-   returnNF_Tc (name, mk_kind arg_kinds result_kind)
-
-getInitialKind (TyData _ _ name tyvars _ _ _ _ _ _)
- = kcHsTyVars tyvars   `thenNF_Tc` \ arg_kinds ->
-   returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
-
-getInitialKind (ClassDecl _ name tyvars _ _ _ _ _ )
- = kcHsTyVars tyvars   `thenNF_Tc` \ arg_kinds ->
-   returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
+getInitialKind :: RenamedTyClDecl -> TcM (Name, TcKind)
+getInitialKind decl
+ = kcHsTyVars (tyClDeclTyVars decl)    `thenM` \ arg_kinds ->
+   newKindVar                          `thenM` \ result_kind  ->
+   returnM (tcdName decl, mk_kind arg_kinds result_kind)

 
 mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds
 \end{code}
 
 mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds
 \end{code}

@@ -240,42 +244,37 @@ Monad c in bop's type signature means that D must have kind Type->Type.
 \begin{code}
 kcTyClDecl :: RenamedTyClDecl -> TcM ()
 
 \begin{code}
 kcTyClDecl :: RenamedTyClDecl -> TcM ()
 

-kcTyClDecl decl@(TySynonym tycon_name hs_tyvars rhs loc)
-  = tcAddDeclCtxt decl                 $
-    kcTyClDeclBody tycon_name hs_tyvars        $ \ result_kind ->
-    kcHsType rhs                       `thenTc` \ rhs_kind ->
+kcTyClDecl decl@(TySynonym {tcdSynRhs = rhs})
+  = kcTyClDeclBody decl                $ \ result_kind ->
+    kcHsType rhs               `thenM` \ rhs_kind ->

     unifyKind result_kind rhs_kind
 
     unifyKind result_kind rhs_kind
 

-kcTyClDecl decl@(TyData new_or_data context tycon_name hs_tyvars con_decls _ _ loc _ _)
-  = tcAddDeclCtxt decl                 $
-    kcTyClDeclBody tycon_name hs_tyvars        $ \ result_kind ->
-    kcHsContext context                        `thenTc_` 
-    mapTc_ kc_con_decl con_decls
+kcTyClDecl (ForeignType {}) = returnM ()
+
+kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls})
+  = kcTyClDeclBody decl                        $ \ result_kind ->
+    kcHsContext context                        `thenM_` 
+    mappM_ kc_con_decl (visibleDataCons con_decls)

   where
   where

-    kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc)
-      = tcAddSrcLoc loc                        $
-       kcHsTyVars ex_tvs               `thenNF_Tc` \ kind_env ->
+    kc_con_decl (ConDecl _ ex_tvs ex_ctxt details loc)
+      = kcHsTyVars ex_tvs              `thenM` \ kind_env ->

        tcExtendKindEnv kind_env        $
        kcConDetails new_or_data ex_ctxt details
 
        tcExtendKindEnv kind_env        $
        kcConDetails new_or_data ex_ctxt details
 

-kcTyClDecl decl@(ClassDecl context class_name
-                          hs_tyvars fundeps class_sigs
-                          _ _ loc)
-  = tcAddDeclCtxt decl                 $
-    kcTyClDeclBody class_name hs_tyvars        $ \ result_kind ->
-    kcHsContext context                        `thenTc_`
-    mapTc_ kc_sig (filter isClassOpSig class_sigs)
+kcTyClDecl decl@(ClassDecl {tcdCtxt = context,  tcdSigs = class_sigs})
+  = kcTyClDeclBody decl                $ \ result_kind ->
+    kcHsContext context                `thenM_`
+    mappM_ kc_sig (filter isClassOpSig class_sigs)

   where
   where

-    kc_sig (ClassOpSig _ _ op_ty loc) = tcAddSrcLoc loc (kcHsBoxedSigType op_ty)
+    kc_sig (ClassOpSig _ _ op_ty loc) = kcHsLiftedSigType op_ty

 
 

-kcTyClDeclBody :: Name -> [HsTyVarBndr Name]   -- Kind of the tycon/cls and its tyvars
-              -> (Kind -> TcM a)               -- Thing inside
-              -> TcM a
+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
 -- 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 tc_name hs_tyvars thing_inside
-  = tcLookup tc_name           `thenNF_Tc` \ thing ->
+kcTyClDeclBody decl thing_inside
+  = tcAddDeclCtxt decl         $
+    tcLookup (tcdName decl)    `thenM` \ thing ->

     let
        kind = case thing of
                  AGlobal (ATyCon tc) -> tyConKind tc
     let
        kind = case thing of
                  AGlobal (ATyCon tc) -> tyConKind tc

@@ -283,12 +282,13 @@ kcTyClDeclBody tc_name hs_tyvars thing_inside
                  AThing kind         -> kind
                -- For some odd reason, a class doesn't include its kind
 
                  AThing kind         -> kind
                -- For some odd reason, a class doesn't include its kind
 

-       (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames hs_tyvars) kind
+       (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames (tyClDeclTyVars decl)) kind

     in
     tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind)
 \end{code}
 
 
     in
     tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind)
 \end{code}
 
 

+

 %************************************************************************
 %*                                                                     *
 \subsection{Step 4: Building the tycon/class}
 %************************************************************************
 %*                                                                     *
 \subsection{Step 4: Building the tycon/class}

@@ -297,13 +297,13 @@ kcTyClDeclBody tc_name hs_tyvars thing_inside
 
 \begin{code}
 buildTyConOrClass 
 
 \begin{code}
 buildTyConOrClass 

-       :: DynFlags
-       -> RecFlag -> NameEnv Kind
+       :: (Name -> AlgTyConFlavour -> RecFlag) -- Whether it's recursive
+       -> NameEnv Kind

        -> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
        -> RenamedTyClDecl -> TyThing
 
        -> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
        -> RenamedTyClDecl -> TyThing
 

-buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
-                 (TySynonym tycon_name tyvar_names rhs src_loc)
+buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
+    (TySynonym {tcdName = tycon_name, tcdTyVars = tyvar_names})

   = ATyCon tycon
   where
        tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
   = ATyCon tycon
   where
        tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs

@@ -313,35 +313,44 @@ buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
        SynTyDetails rhs_ty = lookupNameEnv_NF rec_details tycon_name
         argvrcs                    = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 
        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 data_or_new context tycon_name tyvar_names _ nconstrs _ src_loc name1 name2)
+buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
+    (TyData {tcdND = data_or_new, tcdName = tycon_name, 
+            tcdTyVars = tyvar_names})

   = ATyCon tycon
   where
        tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
   = ATyCon tycon
   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 name1 name2
+                          data_cons sel_ids flavour 
+                          (rec_tycon tycon_name flavour) gen_info

 
 

-       DataTyDetails ctxt data_cons sel_ids = lookupNameEnv_NF rec_details tycon_name
+       DataTyDetails ctxt data_cons sel_ids gen_info = 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
 
 
        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
        flavour = case data_or_new of

-                       NewType -> NewTyCon (mkNewTyConRep tycon)
-                       DataType | all isNullaryDataCon data_cons -> EnumTyCon
-                                | otherwise                      -> DataTyCon
-
-buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
-                  (ClassDecl context class_name
-                            tyvar_names fundeps class_sigs def_methods
-                            name_list src_loc)
+                   NewType  -> NewTyCon (mkNewTyConRep tycon)
+                   DataType | all_nullary data_cons -> EnumTyCon
+                            | otherwise             -> DataTyCon
+
+       all_nullary (DataCons cons) = all (null . dataConOrigArgTys) cons
+       all_nullary other           = False     -- Safe choice for unknown data types
+                       -- 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 rec_tycon kenv rec_vrcs rec_details
+  (ForeignType {tcdName = tycon_name, tcdExtName = tycon_ext_name})
+  = ATyCon (mkForeignTyCon tycon_name tycon_ext_name liftedTypeKind 0 [])
+
+buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
+  (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names, tcdFDs = fundeps} )

   = AClass clas
   where
   = AClass clas
   where

-        (tycon_name, _, _, _) = getClassDeclSysNames name_list

        clas = mkClass class_name tyvars fds
                       sc_theta sc_sel_ids op_items
                       tycon
        clas = mkClass class_name tyvars fds
                       sc_theta sc_sel_ids op_items
                       tycon

@@ -350,16 +359,26 @@ buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
                              argvrcs dict_con
                             clas               -- Yes!  It's a dictionary 
                             flavour
                              argvrcs dict_con
                             clas               -- Yes!  It's a dictionary 
                             flavour

-
-       ClassDetails sc_theta sc_sel_ids op_items dict_con = lookupNameEnv_NF rec_details class_name
+                            (rec_tycon class_name flavour)
+               -- 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 tycon_name 
+               = 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
 
        class_kind = lookupNameEnv_NF kenv class_name
        tyvars     = mkTyClTyVars class_kind tyvar_names
         argvrcs           = lookupWithDefaultFM rec_vrcs bogusVrcs tycon

-       n_fields   = length sc_sel_ids + length op_items

 
 

-       flavour | n_fields == 1 = NewTyCon (mkNewTyConRep tycon)
-               | otherwise     = DataTyCon
+       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 can find the functional dependencies right away, 
        -- and it is vital to do so. Why?  Because in the next pass

@@ -372,6 +391,40 @@ buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
 bogusVrcs = panic "Bogus tycon arg variances"
 \end{code}
 
 bogusVrcs = panic "Bogus tycon arg variances"
 \end{code}
 

+\begin{code}
+mkNewTyConRep :: TyCon         -- The original type constructor
+             -> Type           -- Chosen representation type
+                               -- (guaranteed not to be another newtype)
+
+-- Find the representation type for this newtype TyCon
+-- Remember that the representation type is the ultimate representation
+-- type, looking through other newtypes.
+-- 
+-- The non-recursive newtypes are easy, because they look transparent
+-- to splitTyConApp_maybe, but recursive ones really are represented as
+-- TyConApps (see TypeRep).
+-- 
+-- The trick is to to deal correctly with recursive newtypes
+-- such as     newtype T = MkT T
+
+mkNewTyConRep tc
+  = go [] tc
+  where
+       -- Invariant: tc is a NewTyCon
+       --            tcs have been seen before
+    go tcs tc 
+       | tc `elem` tcs = unitTy
+       | otherwise
+       = let
+             rep_ty = head (dataConOrigArgTys (head (tyConDataCons tc)))
+         in
+         case splitTyConApp_maybe rep_ty of
+                       Nothing -> rep_ty 
+                       Just (tc', tys) | not (isNewTyCon tc') -> rep_ty
+                                       | otherwise            -> go1 (tc:tcs) tc' tys
+
+    go1 tcs tc tys = substTyWith (tyConTyVars tc) tys (go tcs tc)
+\end{code}

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

@@ -382,43 +435,60 @@ bogusVrcs = panic "Bogus tycon arg variances"
 Dependency analysis
 ~~~~~~~~~~~~~~~~~~~
 \begin{code}
 Dependency analysis
 ~~~~~~~~~~~~~~~~~~~
 \begin{code}

-sortByDependency :: [RenamedTyClDecl] -> TcM [SCC RenamedTyClDecl]
-sortByDependency decls
+checkLoops :: SCC RenamedTyClDecl
+          -> TcM (Name -> AlgTyConFlavour -> RecFlag)
+-- Check for illegal loops, 
+--     a) type synonyms
+--     b) superclass hierarchy
+--
+-- Also return a function that says which tycons are recursive.
+-- Remember: 
+--     a newtype is recursive if it is part of a recursive
+--             group consisting only of newtype and synonyms
+
+checkLoops (AcyclicSCC _)
+  = returnM (\ _ _ -> NonRecursive)
+
+checkLoops (CyclicSCC decls)

   = let                -- CHECK FOR CLASS CYCLES
   = let                -- CHECK FOR CLASS CYCLES

-       cls_sccs   = stronglyConnComp (mapMaybe mkClassEdges tycl_decls)
-       cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
+       cls_edges  = mapMaybe mkClassEdges decls
+       cls_cycles = findCycles cls_edges

     in
     in

-    checkTc (null cls_cycles) (classCycleErr cls_cycles)       `thenTc_`
+    mapM_ (cycleErr "class") cls_cycles                `thenM_`

 
     let                -- CHECK FOR SYNONYM CYCLES
 
     let                -- CHECK FOR SYNONYM CYCLES

-       syn_sccs   = stronglyConnComp (filter is_syn_decl edges)
-       syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
-
+       syn_edges  = map mkEdges (filter isSynDecl decls)
+       syn_cycles = findCycles syn_edges

     in
     in

-    checkTc (null syn_cycles) (typeCycleErr syn_cycles)                `thenTc_`
+    mapM_ (cycleErr "type synonym") syn_cycles `thenM_`

 
 

-       -- DO THE MAIN DEPENDENCY ANALYSIS
-    let
-       decl_sccs  = stronglyConnComp edges
+    let        -- CHECK FOR NEWTYPE CYCLES
+       newtype_edges  = map mkEdges (filter is_nt_cycle_decl decls)
+       newtype_cycles = findCycles newtype_edges
+       rec_newtypes   = mkNameSet [tcdName d | ds <- newtype_cycles, d <- ds]
+
+       rec_tycon name (NewTyCon _)
+         | name `elemNameSet` rec_newtypes = Recursive
+         | otherwise                       = NonRecursive
+       rec_tycon name other_flavour = Recursive

     in
     in

-    returnTc decl_sccs
-  where
-    tycl_decls = filter (not . isIfaceSigDecl) decls
-    edges      = map mkEdges tycl_decls
-    
-    is_syn_decl (d, _, _) = isSynDecl d
-\end{code}
+    returnM rec_tycon

 
 

-Edges in Type/Class decls
-~~~~~~~~~~~~~~~~~~~~~~~~~
+----------------------------------------------------
+-- A class with one op and no superclasses, or vice versa,
+--             is treated just like a newtype.
+-- It's a bit unclean that this test is repeated in buildTyConOrClass
+is_nt_cycle_decl (TySynonym {})                                     = True
+is_nt_cycle_decl (TyData {tcdND = NewType})                 = True
+is_nt_cycle_decl (ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs}) = length ctxt + length sigs == 1
+is_nt_cycle_decl other                                      = False

 
 

-\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
+----------------------------------------------------
+findCycles edges = [ ds | CyclicSCC ds <- stronglyConnComp edges]
+
+----------------------------------------------------
+mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
+mkEdges decl = (decl, tyClDeclName decl, nameSetToList (tyClDeclFVs decl))

 
 ----------------------------------------------------
 -- mk_cls_edges looks only at the context of class decls
 
 ----------------------------------------------------
 -- mk_cls_edges looks only at the context of class decls

@@ -426,12 +496,8 @@ tyClDeclFTVs d = foldNameSet add [] (tyClDeclFVs d)
 -- superclass hierarchy
 
 mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name])
 -- superclass hierarchy
 
 mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name])

-
-mkClassEdges decl@(ClassDecl ctxt name _ _ _ _ _ _) = Just (decl, name, [c | HsPClass c _ <- ctxt])
-mkClassEdges other_decl                                    = Nothing
-
-mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
-mkEdges decl = (decl, tyClDeclName decl, tyClDeclFTVs decl)
+mkClassEdges decl@(ClassDecl {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsClassP c _ <- ctxt])
+mkClassEdges other_decl                                               = Nothing

 \end{code}
 
 
 \end{code}
 
 

@@ -442,21 +508,17 @@ mkEdges decl = (decl, tyClDeclName decl, tyClDeclFTVs decl)
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
-
-typeCycleErr syn_cycles
-  = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
+cycleErr :: String -> [RenamedTyClDecl] -> TcM ()

 
 

-classCycleErr cls_cycles
-  = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
+cycleErr kind_of_decl decls
+  = addErrAt loc (ppr_cycle kind_of_decl decls)
+  where
+    loc = tcdLoc (head decls)

 
 

-pp_cycle str decls
-  = hang (text str)
+ppr_cycle kind_of_decl decls
+  = hang (ptext SLIT("Cycle in") <+> text kind_of_decl <+> ptext SLIT("declarations:"))

         4 (vcat (map pp_decl decls))
   where
         4 (vcat (map pp_decl decls))
   where

-    pp_decl decl
-      = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
-     where
-        name = tyClDeclName decl
-
+    pp_decl decl = hsep [quotes (ppr (tcdName decl)), 
+                        ptext SLIT("at"), ppr (tcdLoc decl)]

 \end{code}
 \end{code}