[project @ 2002-10-09 15:51:43 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 dc3e8b0..404d4cb 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(..),  
                          ConDecl(..),   Sig(..), HsPred(..), 
 import HsSyn           ( TyClDecl(..),  
                          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 BasicTypes      ( RecFlag(..), NewOrData(..) )

 import HscTypes                ( implicitTyThingIds )
 
 import HscTypes                ( implicitTyThingIds )
 

-import TcMonad
-import TcEnv           ( TcEnv, RecTcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..),
-                         tcExtendKindEnv, tcLookup, tcExtendGlobalEnv, tcExtendGlobalValEnv )
-import TcTyDecls       ( tcTyDecl1, kcConDetails, mkNewTyConRep )
+import TcRnMonad
+import TcEnv           ( TcTyThing(..), TyThing(..), TyThingDetails(..),
+                         tcExtendKindEnv, tcLookup, tcLookupGlobal, tcExtendGlobalEnv,
+                         isLocalThing )
+import TcTyDecls       ( tcTyDecl, kcConDetails )

 import TcClassDcl      ( tcClassDecl1 )
 import TcClassDcl      ( tcClassDecl1 )

+import TcInstDcls      ( tcAddDeclCtxt )

 import TcMonoType      ( kcHsTyVars, kcHsType, kcHsLiftedSigType, kcHsContext, mkTyClTyVars )
 import TcMonoType      ( kcHsTyVars, kcHsType, kcHsLiftedSigType, kcHsContext, mkTyClTyVars )

-import TcType          ( TcKind, newKindVar, zonkKindEnv )
-
+import TcMType         ( newKindVar, zonkKindEnv, checkValidTyCon, checkValidClass )

 import TcUnify         ( unifyKind )
 import TcUnify         ( unifyKind )

-import TcInstDcls      ( tcAddDeclCtxt )
-import Type            ( Kind, mkArrowKind, zipFunTys )
+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,23 @@ 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 [TyThing]      -- Returns newly defined things:
+                                       -- types, classes and implicit Ids
+
+tcTyAndClassDecls decls
+  = tcGroups (stronglyConnComp edges)
+  where
+    edges = map mkEdges (filter isTypeOrClassDecl decls)
+
+tcGroups []
+  = returnM []
+
+tcGroups (group:groups)
+  = tcGroup group      `thenM` \ (env, new_things1) ->
+    setGblEnv env      $
+    tcGroups groups    `thenM` \ new_things2 ->
+    returnM (new_things1 ++ new_things2)

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

@@ -107,89 +109,105 @@ 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 ->
+tcGroup :: SCC RenamedTyClDecl 
+       -> TcM (TcGblEnv,       -- Input env extended by types and classes only
+               [TyThing])      -- Things defined by this group
+                                       
+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
+    traceTc (text "ready for validity check")  `thenM_`
+    getModule                                  `thenM` \ mod ->
+    setGblEnv env (
+       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_tycons, implicit_ids, all_tyclss :: [TyThing]
+       implicit_tycons = [ATyCon (classTyCon clas) | AClass clas <- tyclss]
+       all_tyclss     = implicit_tycons ++ tyclss
+       implicit_ids   = [AnId id | id <- implicitTyThingIds all_tyclss]
+       new_things     = implicit_ids ++ all_tyclss
+    in
+    returnM (env, new_things)

 
   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,11 +218,11 @@ tcTyClDecl1 is_rec unf_env decl
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-getInitialKind :: RenamedTyClDecl -> NF_TcM (Name, TcKind)
+getInitialKind :: RenamedTyClDecl -> TcM (Name, TcKind)

 getInitialKind decl
 getInitialKind decl

- = kcHsTyVars (tcdTyVars decl) `thenNF_Tc` \ arg_kinds ->
-   newKindVar                  `thenNF_Tc` \ result_kind  ->
-   returnNF_Tc (tcdName decl, mk_kind arg_kinds result_kind)
+ = 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}

@@ -234,23 +252,25 @@ kcTyClDecl :: RenamedTyClDecl -> TcM ()
 
 kcTyClDecl decl@(TySynonym {tcdSynRhs = rhs})
   = kcTyClDeclBody decl                $ \ result_kind ->
 
 kcTyClDecl decl@(TySynonym {tcdSynRhs = rhs})
   = kcTyClDeclBody decl                $ \ result_kind ->

-    kcHsType rhs               `thenTc` \ rhs_kind ->
+    kcHsType rhs               `thenM` \ rhs_kind ->

     unifyKind result_kind rhs_kind
 
     unifyKind result_kind rhs_kind
 

+kcTyClDecl (ForeignType {}) = returnM ()
+

 kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls})
   = kcTyClDeclBody decl                        $ \ result_kind ->
 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
+    kcHsContext context                        `thenM_` 
+    mappM_ kc_con_decl (visibleDataCons con_decls)

   where
   where

-    kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details 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
 
 kcTyClDecl decl@(ClassDecl {tcdCtxt = context,  tcdSigs = class_sigs})
   = kcTyClDeclBody decl                $ \ result_kind ->
        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)
+    kcHsContext context                `thenM_`
+    mappM_ kc_sig (filter isClassOpSig class_sigs)

   where
     kc_sig (ClassOpSig _ _ op_ty loc) = kcHsLiftedSigType op_ty
 
   where
     kc_sig (ClassOpSig _ _ op_ty loc) = kcHsLiftedSigType op_ty
 

@@ -260,7 +280,7 @@ kcTyClDeclBody :: RenamedTyClDecl -> (Kind -> TcM a) -> TcM a
 -- check the result kind matches
 kcTyClDeclBody decl thing_inside
   = tcAddDeclCtxt decl         $
 -- check the result kind matches
 kcTyClDeclBody decl thing_inside
   = tcAddDeclCtxt decl         $

-    tcLookup (tcdName decl)    `thenNF_Tc` \ thing ->
+    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

@@ -268,12 +288,13 @@ kcTyClDeclBody decl 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 (tcdTyVars decl)) 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}

@@ -282,13 +303,13 @@ kcTyClDeclBody decl 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 {tcdName = tycon_name, tcdTyVars = tyvar_names})
+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

@@ -298,35 +319,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 {tcdND = data_or_new, tcdName = tycon_name, tcdTyVars = tyvar_names,
-                          tcdNCons = nconstrs, tcdSysNames = sys_names})
+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 sys_names
+                          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 {tcdName = class_name, tcdTyVars = tyvar_names,
-                             tcdFDs = fundeps, tcdSysNames = name_list} )
+                   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

@@ -335,16 +365,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

@@ -357,6 +397,38 @@ 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
+-- 
+-- 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}

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

@@ -367,43 +439,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
+
+----------------------------------------------------
+-- 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

 
 

-Edges in Type/Class decls
-~~~~~~~~~~~~~~~~~~~~~~~~~
+----------------------------------------------------
+findCycles edges = [ ds | CyclicSCC ds <- stronglyConnComp edges]

 
 

-\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
+----------------------------------------------------
+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

@@ -411,12 +500,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 {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsPClass c _ <- ctxt])
+mkClassEdges decl@(ClassDecl {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsClassP c _ <- ctxt])

 mkClassEdges other_decl                                               = Nothing
 mkClassEdges other_decl                                               = Nothing

-
-mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
-mkEdges decl = (decl, tyClDeclName decl, tyClDeclFTVs decl)

 \end{code}
 
 
 \end{code}
 
 

@@ -427,21 +512,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}