projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Wibbles
[ghc-hetmet.git]
/
compiler
/
typecheck
/
TcRnDriver.lhs
diff --git
a/compiler/typecheck/TcRnDriver.lhs
b/compiler/typecheck/TcRnDriver.lhs
index
649807e
..
c4b3517
100644
(file)
--- a/
compiler/typecheck/TcRnDriver.lhs
+++ b/
compiler/typecheck/TcRnDriver.lhs
@@
-9,10
+9,10
@@
module TcRnDriver (
#ifdef GHCI
tcRnStmt, tcRnExpr, tcRnType,
tcRnLookupRdrName,
#ifdef GHCI
tcRnStmt, tcRnExpr, tcRnType,
tcRnLookupRdrName,
- tcRnLookupName,
- tcRnGetInfo,
getModuleExports,
#endif
getModuleExports,
#endif
+ tcRnLookupName,
+ tcRnGetInfo,
tcRnModule,
tcTopSrcDecls,
tcRnExtCore
tcRnModule,
tcTopSrcDecls,
tcRnExtCore
@@
-72,6
+72,7
@@
import Outputable
import DataCon
import Type
import Class
import DataCon
import Type
import Class
+import TcType
import Data.List ( sortBy )
#ifdef GHCI
import Data.List ( sortBy )
#ifdef GHCI
@@
-84,7
+85,6
@@
import IfaceEnv
import MkId
import BasicTypes
import TidyPgm ( globaliseAndTidyId )
import MkId
import BasicTypes
import TidyPgm ( globaliseAndTidyId )
-import TcType ( isUnitTy, isTauTy, tyClsNamesOfDFunHead )
import TysWiredIn ( unitTy, mkListTy )
#endif
import TysWiredIn ( unitTy, mkListTy )
#endif
@@
-297,7
+297,7
@@
tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
-- any mutually recursive types are done right
-- Just discard the auxiliary bindings; they are generated
-- only for Haskell source code, and should already be in Core
-- any mutually recursive types are done right
-- Just discard the auxiliary bindings; they are generated
-- only for Haskell source code, and should already be in Core
- (tcg_env, _aux_binds) <- tcTyAndClassDecls emptyModDetails rn_decls ;
+ (tcg_env, _aux_binds, _dm_ids) <- tcTyAndClassDecls emptyModDetails rn_decls ;
setGblEnv tcg_env $ do {
-- Make the new type env available to stuff slurped from interface files
setGblEnv tcg_env $ do {
-- Make the new type env available to stuff slurped from interface files
@@
-485,8
+485,10
@@
tcRnHsBootDecls decls
-- Typecheck type/class decls
; traceTc (text "Tc2")
-- Typecheck type/class decls
; traceTc (text "Tc2")
- ; (tcg_env, aux_binds) <- tcTyAndClassDecls emptyModDetails tycl_decls
- ; setGblEnv tcg_env $ do {
+ ; (tcg_env, aux_binds, dm_ids)
+ <- tcTyAndClassDecls emptyModDetails tycl_decls
+ ; setGblEnv tcg_env $
+ tcExtendIdEnv dm_ids $ do {
-- Typecheck instance decls
-- Family instance declarations are rejected here
-- Typecheck instance decls
-- Family instance declarations are rejected here
@@
-821,10
+823,12
@@
tcTopSrcDecls boot_details
-- The latter come in via tycl_decls
traceTc (text "Tc2") ;
-- The latter come in via tycl_decls
traceTc (text "Tc2") ;
- (tcg_env, aux_binds) <- tcTyAndClassDecls boot_details tycl_decls ;
+ (tcg_env, aux_binds, dm_ids) <- tcTyAndClassDecls boot_details tycl_decls ;
-- If there are any errors, tcTyAndClassDecls fails here
-- If there are any errors, tcTyAndClassDecls fails here
- setGblEnv tcg_env $ do {
+ setGblEnv tcg_env $
+ tcExtendIdEnv dm_ids $ do {
+
-- Source-language instances, including derivings,
-- and import the supporting declarations
traceTc (text "Tc3") ;
-- Source-language instances, including derivings,
-- and import the supporting declarations
traceTc (text "Tc3") ;
@@
-854,13
+858,12
@@
tcTopSrcDecls boot_details
(tc_val_binds, tcl_env) <- setLclTypeEnv tcl_env $
tcTopBinds val_binds;
(tc_val_binds, tcl_env) <- setLclTypeEnv tcl_env $
tcTopBinds val_binds;
+ setLclTypeEnv tcl_env $ do { -- Environment doesn't change now
+
-- Second pass over class and instance declarations,
traceTc (text "Tc6") ;
-- Second pass over class and instance declarations,
traceTc (text "Tc6") ;
- (inst_binds, tcl_env) <- setLclTypeEnv tcl_env $
- tcInstDecls2 tycl_decls inst_infos ;
- showLIE (text "after instDecls2") ;
-
- setLclTypeEnv tcl_env $ do { -- Environment doesn't change now
+ inst_binds <- tcInstDecls2 tycl_decls inst_infos ;
+ showLIE (text "after instDecls2") ;
-- Foreign exports
traceTc (text "Tc7") ;
-- Foreign exports
traceTc (text "Tc7") ;
@@
-1015,7
+1018,6
@@
get two defns for 'main' in the interface file!
%*********************************************************
\begin{code}
%*********************************************************
\begin{code}
-#ifdef GHCI
setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
setInteractiveContext hsc_env icxt thing_inside
= let -- Initialise the tcg_inst_env with instances from all home modules.
setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
setInteractiveContext hsc_env icxt thing_inside
= let -- Initialise the tcg_inst_env with instances from all home modules.
@@
-1046,6
+1048,7
@@
setInteractiveContext hsc_env icxt thing_inside
\begin{code}
\begin{code}
+#ifdef GHCI
tcRnStmt :: HscEnv
-> InteractiveContext
-> LStmt RdrName
tcRnStmt :: HscEnv
-> InteractiveContext
-> LStmt RdrName
@@
-1341,7
+1344,7
@@
getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe [AvailInfo])
getModuleExports hsc_env mod
= let
ic = hsc_IC hsc_env
getModuleExports hsc_env mod
= let
ic = hsc_IC hsc_env
- checkMods = ic_toplev_scope ic ++ ic_exports ic
+ checkMods = ic_toplev_scope ic ++ map fst (ic_exports ic)
in
initTc hsc_env HsSrcFile False iNTERACTIVE (tcGetModuleExports mod checkMods)
in
initTc hsc_env HsSrcFile False iNTERACTIVE (tcGetModuleExports mod checkMods)
@@
-1401,6
+1404,7
@@
lookup_rdr_name rdr_name = do {
return good_names
}
return good_names
}
+#endif
tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing)
tcRnLookupName hsc_env name
tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing)
tcRnLookupName hsc_env name
@@
-1421,8
+1425,8
@@
tcRnLookupName' name = do
_ -> panic "tcRnLookupName'"
tcRnGetInfo :: HscEnv
_ -> panic "tcRnLookupName'"
tcRnGetInfo :: HscEnv
- -> Name
- -> IO (Messages, Maybe (TyThing, Fixity, [Instance]))
+ -> Name
+ -> IO (Messages, Maybe (TyThing, Fixity, [Instance]))
-- Used to implement :info in GHCi
--
-- Used to implement :info in GHCi
--
@@
-1432,8
+1436,14
@@
tcRnGetInfo :: HscEnv
-- *and* as a type or class constructor;
-- hence the call to dataTcOccs, and we return up to two results
tcRnGetInfo hsc_env name
-- *and* as a type or class constructor;
-- hence the call to dataTcOccs, and we return up to two results
tcRnGetInfo hsc_env name
- = initTcPrintErrors hsc_env iNTERACTIVE $
- let ictxt = hsc_IC hsc_env in
+ = initTcPrintErrors hsc_env iNTERACTIVE $
+ tcRnGetInfo' hsc_env name
+
+tcRnGetInfo' :: HscEnv
+ -> Name
+ -> TcRn (TyThing, Fixity, [Instance])
+tcRnGetInfo' hsc_env name
+ = let ictxt = hsc_IC hsc_env in
setInteractiveContext hsc_env ictxt $ do
-- Load the interface for all unqualified types and classes
setInteractiveContext hsc_env ictxt $ do
-- Load the interface for all unqualified types and classes
@@
-1482,7
+1492,6
@@
loadUnqualIfaces ictxt
isTcOcc (nameOccName name), -- Types and classes only
unQualOK gre ] -- In scope unqualified
doc = ptext (sLit "Need interface for module whose export(s) are in scope unqualified")
isTcOcc (nameOccName name), -- Types and classes only
unQualOK gre ] -- In scope unqualified
doc = ptext (sLit "Need interface for module whose export(s) are in scope unqualified")
-#endif /* GHCI */
\end{code}
%************************************************************************
\end{code}
%************************************************************************