[project @ 1996-04-20 10:37:06 by partain]

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

diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index 4daf3b4..1f2b513 100644 (file)
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -15,7 +15,8 @@ import Ubiq
 import HsSyn           ( HsModule(..), HsBinds(..), Bind, HsExpr,
                          TyDecl, SpecDataSig, ClassDecl, InstDecl,
                          SpecInstSig, DefaultDecl, Sig, Fake, InPat,
-                         FixityDecl, IE, ImportedInterface )
+                         FixityDecl, IE, ImportDecl
+                       )
 import RnHsSyn         ( RenamedHsModule(..), RenamedFixityDecl(..) )
 import TcHsSyn         ( TypecheckedHsBinds(..), TypecheckedHsExpr(..),
                          TcIdOcc(..), zonkBinds, zonkInst, zonkId )
@@ -38,13 +39,12 @@ import Bag          ( listToBag )
 import Class           ( GenClass )
 import Id              ( GenId, isDataCon, isMethodSelId, idType )
 import Maybes          ( catMaybes )
-import Name            ( Name(..) )
-import Outputable      ( isExported )
+import Name            ( isExported, isLocallyDefined )
 import PrelInfo                ( unitTy, mkPrimIoTy )
 import Pretty
 import RnUtils         ( GlobalNameMappers(..), GlobalNameMapper(..) )
 import TyCon           ( TyCon )
-import Type            ( applyTyCon )
+import Type            ( mkSynTy )
 import Unify           ( unifyTauTy )
 import UniqFM          ( lookupUFM_Directly, lookupWithDefaultUFM_Directly,
                          filterUFM, eltsUFM )
@@ -61,7 +61,8 @@ tycon_specs = emptyFM
 \begin{code}
 tcModule :: GlobalNameMappers          -- final renamer info for derivings
         -> RenamedHsModule             -- input
-        -> TcM s ((TypecheckedHsBinds, -- binds from class decls; does NOT
+        -> TcM s ((TypecheckedHsBinds, -- record selector binds
+                   TypecheckedHsBinds, -- binds from class decls; does NOT
                                        -- include default-methods bindings
                    TypecheckedHsBinds, -- binds from instance decls; INCLUDES
                                        -- class default-methods binds
@@ -81,7 +82,7 @@ tcModule :: GlobalNameMappers         -- final renamer info for derivings
                   PprStyle -> Pretty)  -- -ddump-deriving info
 
 tcModule renamer_name_funs
-       (HsModule mod_name exports imports fixities
+       (HsModule mod_name verion exports imports fixities
                  ty_decls specdata_sigs cls_decls inst_decls specinst_sigs
                  default_decls val_decls sigs src_loc)
 
@@ -94,30 +95,30 @@ tcModule renamer_name_funs
        -- pragmas, which is done lazily [ie failure just drops the pragma
        -- without having any global-failure effect].
 
-    fixTc (\ ~(_, _, _, _, _, sig_ids) ->
+    fixTc (\ ~(_, _, _, _, _, _, sig_ids) ->
        tcExtendGlobalValEnv sig_ids (
 
        -- The knot for instance information.  This isn't used at all
        -- till we type-check value declarations
-       fixTc ( \ ~(rec_inst_mapper, _, _, _, _) ->
+       fixTc ( \ ~(rec_inst_mapper, _, _, _, _, _) ->
 
             -- Type-check the type and class decls
-           trace "tcTyAndClassDecls:"  $
+           --trace "tcTyAndClassDecls:"        $
            tcTyAndClassDecls1 rec_inst_mapper ty_decls_bag cls_decls_bag
-                                       `thenTc` \ env ->
+                                       `thenTc` \ (env, record_binds) ->
 
                -- Typecheck the instance decls, includes deriving
            tcSetEnv env (
-           trace "tcInstDecls:"        $
+           --trace "tcInstDecls:"      $
            tcInstDecls1 inst_decls_bag specinst_sigs
                         mod_name renamer_name_funs fixities 
            )                           `thenTc` \ (inst_info, deriv_binds, ddump_deriv) ->
 
            buildInstanceEnvs inst_info `thenTc` \ inst_mapper ->
 
-           returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv)
+           returnTc (inst_mapper, env, record_binds, inst_info, deriv_binds, ddump_deriv)
 
-       ) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) ->
+       ) `thenTc` \ (_, env, record_binds, inst_info, deriv_binds, ddump_deriv) ->
        tcSetEnv env (
 
            -- Default declarations
@@ -132,16 +133,16 @@ tcModule renamer_name_funs
            --   we silently discard the pragma
        tcInterfaceSigs sigs            `thenTc` \ sig_ids ->
 
-       returnTc (env, inst_info, deriv_binds, ddump_deriv, defaulting_tys, sig_ids)
+       returnTc (env, inst_info, record_binds, deriv_binds, ddump_deriv, defaulting_tys, sig_ids)
 
-    )))) `thenTc` \ (env, inst_info, deriv_binds, ddump_deriv, defaulting_tys, _) ->
+    )))) `thenTc` \ (env, inst_info, record_binds, deriv_binds, ddump_deriv, defaulting_tys, _) ->
 
     tcSetEnv env (                             -- to the end...
     tcSetDefaultTys defaulting_tys (           -- ditto
 
        -- Value declarations next.
        -- We also typecheck any extra binds that came out of the "deriving" process
-    trace "tcBinds:"                   $
+    --trace "tcBinds:"                 $
     tcBindsAndThen
        (\ binds1 (binds2, thing) -> (binds1 `ThenBinds` binds2, thing))
        (val_decls `ThenBinds` deriv_binds)
@@ -181,6 +182,7 @@ tcModule renamer_name_funs
        -- simplification step may have instantiated some
        -- ambiguous types.  So, sadly, we need to back-substitute
        -- over the whole bunch of bindings.
+    zonkBinds record_binds             `thenNF_Tc` \ record_binds' ->
     zonkBinds val_binds                        `thenNF_Tc` \ val_binds' ->
     zonkBinds inst_binds               `thenNF_Tc` \ inst_binds' ->
     zonkBinds cls_binds                        `thenNF_Tc` \ cls_binds' ->
@@ -189,7 +191,7 @@ tcModule renamer_name_funs
 
        -- FINISHED AT LAST
     returnTc (
-       (cls_binds', inst_binds', val_binds', const_insts'),
+       (record_binds', cls_binds', inst_binds', val_binds', const_insts'),
 
             -- the next collection is just for mkInterface
        (fixities, exported_ids', tycons, classes, inst_info),
@@ -231,7 +233,7 @@ checkTopLevelIds mod final_env
        
        case (maybe_main, maybe_prim) of
          (Just main, Nothing) -> tcAddErrCtxt mainCtxt $
-                                 unifyTauTy (applyTyCon io_tc [unitTy])
+                                 unifyTauTy (mkSynTy io_tc [unitTy])
                                             (idType main)
 
          (Nothing, Just prim) -> tcAddErrCtxt primCtxt $
@@ -252,7 +254,5 @@ mainBothIdErr sty
   = ppStr "module Main contains definitions for both main and mainPrimIO"
 
 mainNoneIdErr sty
-  = panic "ToDo: sort out mainIdKey"
- -- ppStr "module Main does not contain a definition for main (or mainPrimIO)"
-
+  = ppStr "module Main does not contain a definition for main (or mainPrimIO)"
 \end{code}