[project @ 2002-03-29 21:39:36 by sof]

[ghc-hetmet.git] / ghc / compiler / rename / RnSource.lhs

diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index b02f49b..5b0bf5a 100644 (file)
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -32,6 +32,7 @@ import RnEnv          ( lookupTopBndrRn, lookupOccRn, lookupIfaceName,
 import RnMonad
 
 import Class           ( FunDep, DefMeth (..) )
+import TyCon           ( DataConDetails(..), visibleDataCons )
 import DataCon         ( dataConId )
 import Name            ( Name, NamedThing(..) )
 import NameSet
@@ -45,6 +46,7 @@ import SrcLoc         ( SrcLoc )
 import CmdLineOpts     ( DynFlag(..) )
                                -- Warn of unused for-all'd tyvars
 import Maybes          ( maybeToBool )
+import Maybe            ( maybe )
 \end{code}
 
 @rnSourceDecl@ `renames' declarations.
@@ -284,13 +286,22 @@ rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc
   where
     doc_str = text "In the interface signature for" <+> quotes (ppr name)
 
+rnTyClDecl (CoreDecl {tcdName = name, tcdType = ty, tcdRhs = rhs, tcdLoc = loc})
+  = pushSrcLocRn loc $
+    lookupTopBndrRn name               `thenRn` \ name' ->
+    rnHsType doc_str ty                        `thenRn` \ ty' ->
+    rnCoreExpr rhs                      `thenRn` \ rhs' ->
+    returnRn (CoreDecl {tcdName = name', tcdType = ty', tcdRhs = rhs', tcdLoc = loc})
+  where
+    doc_str = text "In the Core declaration for" <+> quotes (ppr name)
+
 rnTyClDecl (ForeignType {tcdName = name, tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
   = pushSrcLocRn loc                   $
     lookupTopBndrRn name               `thenRn` \ name' ->
     returnRn (ForeignType {tcdName = name', tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
 
 rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
-                   tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = nconstrs,
+                   tcdTyVars = tyvars, tcdCons = condecls, 
                    tcdDerivs = derivs, tcdLoc = src_loc, tcdSysNames = sys_names})
   = pushSrcLocRn src_loc $
     lookupTopBndrRn tycon                      `thenRn` \ tycon' ->
@@ -299,24 +310,14 @@ rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
     rn_derivs derivs                           `thenRn` \ derivs' ->
     checkDupOrQualNames data_doc con_names     `thenRn_`
 
-       -- Check that there's at least one condecl,
-       -- or else we're reading an interface file, or -fglasgow-exts
-    (if null condecls then
-       doptRn Opt_GlasgowExts  `thenRn` \ glaExts ->
-       getModeRn               `thenRn` \ mode ->
-       checkRn (glaExts || isInterfaceMode mode)
-               (emptyConDeclsErr tycon)
-     else returnRn ()
-    )                                          `thenRn_` 
-
-    mapRn rnConDecl condecls                   `thenRn` \ condecls' ->
+    rnConDecls tycon' condecls                 `thenRn` \ condecls' ->
     mapRn lookupSysBinder sys_names            `thenRn` \ sys_names' ->
     returnRn (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon',
-                     tcdTyVars = tyvars', tcdCons = condecls', tcdNCons = nconstrs,
+                     tcdTyVars = tyvars', tcdCons = condecls', 
                      tcdDerivs = derivs', tcdLoc = src_loc, tcdSysNames = sys_names'})
   where
     data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
-    con_names = map conDeclName condecls
+    con_names = map conDeclName (visibleDataCons condecls)
 
     rn_derivs Nothing   = returnRn Nothing
     rn_derivs (Just ds) = rnContext data_doc ds        `thenRn` \ ds' -> returnRn (Just ds')
@@ -433,6 +434,15 @@ finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc})        -- G
   where
     meth_doc = text "In the default-methods for class" <+> ppr (tcdName rn_cls_decl)
 
+finishSourceTyClDecl _ tycl_decl@(TyData {tcdDerivs = derivings})
+  -- Derivings are returned here so that they don't form part of the tyClDeclFVs.
+  -- This is important, because tyClDeclFVs should contain only the
+  -- FVs that are `needed' by the interface file declaration, and
+  -- derivings do not appear in this.  It also means that the tcGroups
+  -- are smaller, which turned out to be important for the usage inference. KSW 2002-02.
+  = returnRn (tycl_decl,
+              maybe emptyFVs extractHsCtxtTyNames derivings)
+
 finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs)
        -- Not a class declaration
 \end{code}
@@ -448,6 +458,23 @@ finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs)
 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
 conDeclName (ConDecl n _ _ _ _ l) = (n,l)
 
+rnConDecls :: Name -> DataConDetails RdrNameConDecl -> RnMS (DataConDetails RenamedConDecl)
+rnConDecls tycon Unknown     = returnRn Unknown
+rnConDecls tycon (HasCons n) = returnRn (HasCons n)
+rnConDecls tycon (DataCons condecls)
+  =    -- Check that there's at least one condecl,
+       -- or else we're reading an interface file, or -fglasgow-exts
+    (if null condecls then
+       doptRn Opt_GlasgowExts  `thenRn` \ glaExts ->
+       getModeRn               `thenRn` \ mode ->
+       checkRn (glaExts || isInterfaceMode mode)
+               (emptyConDeclsErr tycon)
+     else returnRn ()
+    )                                          `thenRn_` 
+
+    mapRn rnConDecl condecls                   `thenRn` \ condecls' ->
+    returnRn (DataCons condecls')
+
 rnConDecl :: RdrNameConDecl -> RnMS RenamedConDecl
 rnConDecl (ConDecl name wkr tvs cxt details locn)
   = pushSrcLocRn locn $