[project @ 2003-02-12 15:01:31 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 948eca5..d978e3c 100644 (file)
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -16,8 +16,8 @@ import HsSyn          ( TyClDecl(..),
                          isTypeOrClassDecl, isClassDecl, isSynDecl, isClassOpSig
                        )
 import RnHsSyn         ( RenamedTyClDecl, tyClDeclFVs )
-import BasicTypes      ( RecFlag(..), isNonRec, NewOrData(..) )
-import HscTypes                ( implicitTyThingIds )
+import BasicTypes      ( RecFlag(..), NewOrData(..) )
+import HscTypes                ( implicitTyThings )
 
 import TcRnMonad
 import TcEnv           ( TcTyThing(..), TyThing(..), TyThingDetails(..),
@@ -43,12 +43,11 @@ import DataCon              ( dataConOrigArgTys )
 import Var             ( varName )
 import FiniteMap
 import Digraph         ( stronglyConnComp, SCC(..) )
-import Name            ( Name, getSrcLoc )
+import Name            ( Name )
 import NameEnv
 import NameSet
 import Outputable
 import Maybes          ( mapMaybe )
-import ErrUtils                ( Message )
 \end{code}
 
 
@@ -62,22 +61,19 @@ The main function
 ~~~~~~~~~~~~~~~~~
 \begin{code}
 tcTyAndClassDecls :: [RenamedTyClDecl]
-                 -> TcM [TyThing]      -- Returns newly defined things:
-                                       -- types, classes and implicit Ids
+                 -> TcM TcGblEnv       -- Returns extended environment
 
 tcTyAndClassDecls decls
   = tcGroups (stronglyConnComp edges)
   where
     edges = map mkEdges (filter isTypeOrClassDecl decls)
 
-tcGroups []
-  = returnM []
+tcGroups [] = getGblEnv
 
 tcGroups (group:groups)
-  = tcGroup group      `thenM` \ (env, new_things1) ->
+  = tcGroup group      `thenM` \ env ->
     setGblEnv env      $
-    tcGroups groups    `thenM` \ new_things2 ->
-    returnM (new_things1 ++ new_things2)
+    tcGroups groups
 \end{code}
 
 Dealing with a group
@@ -125,21 +121,22 @@ The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
 
 \begin{code}
 tcGroup :: SCC RenamedTyClDecl 
-       -> TcM (TcGblEnv,       -- Input env extended by types and classes only
-               [TyThing])      -- Things defined by this group
+       -> TcM TcGblEnv         -- Input env extended by types and classes 
+                               -- and their implicit Ids,DataCons
                                        
 tcGroup scc
   =    -- Step 1
-    mappM getInitialKind decls                                 `thenM` \ initial_kinds ->
+    mappM getInitialKind decls                 `thenM` \ initial_kinds ->
 
        -- Step 2
     tcExtendKindEnv initial_kinds (mappM kcTyClDecl decls)     `thenM_`
 
        -- Step 3
-    zonkKindEnv initial_kinds                  `thenM` \ final_kinds ->
+    zonkKindEnv initial_kinds          `thenM` \ final_kinds ->
 
-       -- Check for loops
-    checkLoops is_rec decls                    `thenM` \ is_rec_tycon ->
+       -- 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
     traceTc (text "starting" <+> ppr final_kinds)              `thenM_`
@@ -169,29 +166,22 @@ tcGroup scc
     )                                          `thenM` \ (_, env, tyclss) ->
 
        -- Step 7: Check validity
+    setGblEnv env                              $
+
     traceTc (text "ready for validity check")  `thenM_`
     getModule                                  `thenM` \ mod ->
-    setGblEnv env (
-       mappM_ (checkValidTyCl mod) decls
-    )                                          `thenM_`
+    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
+       implicit_things = implicitTyThings tyclss
     in
-    returnM (env, new_things)
+    traceTc ((text "Adding" <+> ppr tyclss) $$ (text "and" <+> ppr implicit_things))   `thenM_`
+    tcExtendGlobalEnv implicit_things getGblEnv
 
   where
-    is_rec = case scc of
-               AcyclicSCC _ -> NonRecursive
-               CyclicSCC _  -> Recursive
-
     decls = case scc of
                AcyclicSCC decl -> [decl]
                CyclicSCC decls -> decls
@@ -407,6 +397,8 @@ mkNewTyConRep :: TyCon              -- The original type constructor
                                -- (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
@@ -443,7 +435,7 @@ mkNewTyConRep tc
 Dependency analysis
 ~~~~~~~~~~~~~~~~~~~
 \begin{code}
-checkLoops :: RecFlag -> [RenamedTyClDecl] 
+checkLoops :: SCC RenamedTyClDecl
           -> TcM (Name -> AlgTyConFlavour -> RecFlag)
 -- Check for illegal loops, 
 --     a) type synonyms
@@ -454,11 +446,10 @@ checkLoops :: RecFlag -> [RenamedTyClDecl]
 --     a newtype is recursive if it is part of a recursive
 --             group consisting only of newtype and synonyms
 
-checkLoops is_rec decls
-  | isNonRec is_rec 
+checkLoops (AcyclicSCC _)
   = returnM (\ _ _ -> NonRecursive)
 
-  | otherwise  -- Recursive group
+checkLoops (CyclicSCC decls)
   = let                -- CHECK FOR CLASS CYCLES
        cls_edges  = mapMaybe mkClassEdges decls
        cls_cycles = findCycles cls_edges