[project @ 1996-07-25 20:43:49 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 091ce48..113c82e 100644 (file)
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -34,6 +34,7 @@ import TcDefaults     ( tcDefaults )
 import TcEnv           ( tcExtendGlobalValEnv, getEnv_LocalIds,
                          getEnv_TyCons, getEnv_Classes,
                          tcLookupLocalValueByKey, tcLookupTyConByKey )
+import SpecEnv         ( SpecEnv )
 import TcIfaceSig      ( tcInterfaceSigs )
 import TcInstDcls      ( tcInstDecls1, tcInstDecls2 )
 import TcInstUtil      ( buildInstanceEnvs, InstInfo )
@@ -56,7 +57,7 @@ import TyVar          ( SYN_IE(TyVarEnv), nullTyVarEnv )
 import Unify           ( unifyTauTy )
 import UniqFM          ( lookupUFM_Directly, lookupWithDefaultUFM_Directly,
                          filterUFM, eltsUFM )
-import Unique          ( iOTyConKey, mainIdKey, mainPrimIOIdKey )
+import Unique          ( iOTyConKey )
 import Util
 
 import FiniteMap       ( emptyFM, FiniteMap )
@@ -127,7 +128,11 @@ tcModule rn_env
        -- pragmas, which is done lazily [ie failure just drops the pragma
        -- without having any global-failure effect].
 
+    -- trace "tc1" $
+
     fixTc (\ ~(_, _, _, _, _, _, sig_ids) ->
+
+       -- trace "tc2" $
        tcExtendGlobalValEnv sig_ids (
 
        -- The knot for instance information.  This isn't used at all
@@ -139,6 +144,7 @@ tcModule rn_env
            tcTyAndClassDecls1 rec_inst_mapper ty_decls_bag cls_decls_bag
                                        `thenTc` \ env ->
 
+           --trace "tc3" $
                -- Typecheck the instance decls, includes deriving
            tcSetEnv env (
            --trace "tcInstDecls:"      $
@@ -146,11 +152,14 @@ tcModule rn_env
                         mod_name rn_env fixities 
            )                           `thenTc` \ (inst_info, deriv_binds, ddump_deriv) ->
 
+           --trace "tc4" $
            buildInstanceEnvs inst_info `thenTc` \ inst_mapper ->
 
            returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv)
 
        ) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) ->
+
+       --trace "tc5" $
        tcSetEnv env (
 
            -- Default declarations
@@ -180,11 +189,13 @@ tcModule rn_env
            --   we silently discard the pragma
        tcInterfaceSigs sigs            `thenTc` \ sig_ids ->
        tcGetEnv                        `thenNF_Tc` \ env ->
+       --trace "tc6" $
 
        returnTc (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, sig_ids)
 
     )))) `thenTc` \ (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, _) ->
 
+    --trace "tc7" $
     tcSetEnv env (                             -- to the end...
     tcSetDefaultTys defaulting_tys (           -- ditto
 
@@ -196,6 +207,7 @@ tcModule rn_env
        (val_decls `ThenBinds` deriv_binds)
        (       -- Second pass over instance declarations,
                -- to compile the bindings themselves.
+           --trace "tc8" $
            tcInstDecls2  inst_info     `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
            tcClassDecls2 cls_decls_bag `thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
            tcGetEnv                    `thenNF_Tc` \ env ->
@@ -205,14 +217,13 @@ tcModule rn_env
 
        `thenTc` \ ((val_binds, (inst_binds, cls_binds, final_env)), lie_alldecls, _) ->
 
-    checkTopLevelIds mod_name final_env        `thenTc_`
-
        -- Deal with constant or ambiguous InstIds.  How could
        -- there be ambiguous ones?  They can only arise if a
        -- top-level decl falls under the monomorphism
        -- restriction, and no subsequent decl instantiates its
        -- type.  (Usually, ambiguous type variables are resolved
        -- during the generalisation step.)
+    --trace "tc9" $
     tcSimplifyTop lie_alldecls                 `thenTc` \ const_insts ->
 
        -- Backsubstitution.  Monomorphic top-level decls may have
@@ -260,55 +271,3 @@ tcModule rn_env
     cls_decls_bag  = listToBag cls_decls
     inst_decls_bag = listToBag inst_decls
 \end{code}
-
-
-%************************************************************************
-%*                                                                     *
-\subsection{Error checking code}
-%*                                                                     *
-%************************************************************************
-
-
-checkTopLevelIds checks that Main.main or GHCmain.mainPrimIO has correct type.
-
-\begin{code}
-checkTopLevelIds :: FAST_STRING -> TcEnv s -> TcM s ()
-
-checkTopLevelIds mod final_env
-  | mod /= SLIT("Main") && mod /= SLIT("GHCmain")
-  = returnTc ()
-
-  | mod == SLIT("Main")
-  = tcSetEnv final_env (
-       tcLookupLocalValueByKey mainIdKey       `thenNF_Tc` \ maybe_main ->
-       tcLookupTyConByKey iOTyConKey           `thenNF_Tc` \ io_tc ->
-
-       case maybe_main of
-         Just main ->  tcAddErrCtxt mainCtxt $
-                       unifyTauTy (applyTyCon io_tc [unitTy])
-                                  (idType main)
-
-         Nothing -> failTc (mainNoneIdErr "Main" "main")
-    )
-
-  | mod == SLIT("GHCmain")
-  = tcSetEnv final_env (
-       tcLookupLocalValueByKey mainPrimIOIdKey `thenNF_Tc` \ maybe_prim ->
-       
-       case maybe_prim of
-         Just prim -> tcAddErrCtxt primCtxt $
-                      unifyTauTy (mkPrimIoTy unitTy)
-                                 (idType prim)
-
-         Nothing -> failTc (mainNoneIdErr "GHCmain" "mainPrimIO")
-    )
-
-mainCtxt sty
-  = ppStr "Main.main should have type IO ()"
-
-primCtxt sty
-  = ppStr "GHCmain.mainPrimIO should have type PrimIO ()"
-
-mainNoneIdErr mod n sty
-  = ppCat [ppPStr SLIT("module"), ppStr mod, ppPStr SLIT("does not contain a definition for"), ppStr n]
-\end{code}