projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Packages cleanup, and allow new packages to be loaded with :set again
[ghc-hetmet.git]
/
compiler
/
main
/
HscMain.lhs
diff --git
a/compiler/main/HscMain.lhs
b/compiler/main/HscMain.lhs
index
e5b7026
..
422c270
100644
(file)
--- a/
compiler/main/HscMain.lhs
+++ b/
compiler/main/HscMain.lhs
@@
-25,11
+25,11
@@
module HscMain
#include "HsVersions.h"
#ifdef GHCI
#include "HsVersions.h"
#ifdef GHCI
-import HsSyn ( Stmt(..), LHsExpr, LStmt, LHsType )
-import Module ( Module )
+import HsSyn ( Stmt(..), LStmt, LHsType )
import CodeOutput ( outputForeignStubs )
import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
import Linker ( HValue, linkExpr )
import CodeOutput ( outputForeignStubs )
import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
import Linker ( HValue, linkExpr )
+import CoreSyn ( CoreExpr )
import CoreTidy ( tidyExpr )
import CorePrep ( corePrepExpr )
import Flattening ( flattenExpr )
import CoreTidy ( tidyExpr )
import CorePrep ( corePrepExpr )
import Flattening ( flattenExpr )
@@
-41,7
+41,7
@@
import PrelNames ( iNTERACTIVE )
import Kind ( Kind )
import CoreLint ( lintUnfolding )
import DsMeta ( templateHaskellNames )
import Kind ( Kind )
import CoreLint ( lintUnfolding )
import DsMeta ( templateHaskellNames )
-import SrcLoc ( noSrcLoc, getLoc )
+import SrcLoc ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan )
import VarEnv ( emptyTidyEnv )
#endif
import VarEnv ( emptyTidyEnv )
#endif
@@
-462,10
+462,7
@@
hscFileFrontEnd =
-------------------
-- DESUGAR
-------------------
-------------------
-- DESUGAR
-------------------
- -> do (warns, maybe_ds_result) <- {-# SCC "DeSugar" #-}
- deSugar hsc_env tc_result
- printBagOfWarnings dflags warns
- return maybe_ds_result
+ -> {-# SCC "DeSugar" #-} deSugar hsc_env tc_result
--------------------------------------------------------------
-- Simplifiers
--------------------------------------------------------------
-- Simplifiers
@@
-805,14
+802,22
@@
hscStmt hsc_env stmt
Nothing -> return Nothing ;
Just (new_ic, bound_names, tc_expr) -> do {
Nothing -> return Nothing ;
Just (new_ic, bound_names, tc_expr) -> do {
+
+ -- Desugar it
+ ; let rdr_env = ic_rn_gbl_env new_ic
+ type_env = ic_type_env new_ic
+ ; mb_ds_expr <- deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
+
+ ; case mb_ds_expr of {
+ Nothing -> return Nothing ;
+ Just ds_expr -> do {
+
-- Then desugar, code gen, and link it
-- Then desugar, code gen, and link it
- ; hval <- compileExpr hsc_env iNTERACTIVE
- (ic_rn_gbl_env new_ic)
- (ic_type_env new_ic)
- tc_expr
+ ; let src_span = srcLocSpan interactiveSrcLoc
+ ; hval <- compileExpr hsc_env src_span ds_expr
; return (Just (hsc_env{ hsc_IC=new_ic }, bound_names, hval))
; return (Just (hsc_env{ hsc_IC=new_ic }, bound_names, hval))
- }}}}}
+ }}}}}}}
hscTcExpr -- Typecheck an expression (but don't run it)
:: HscEnv
hscTcExpr -- Typecheck an expression (but don't run it)
:: HscEnv
@@
-839,10
+844,8
@@
hscKcType hsc_env str
= do { maybe_type <- hscParseType (hsc_dflags hsc_env) str
; let icontext = hsc_IC hsc_env
; case maybe_type of {
= do { maybe_type <- hscParseType (hsc_dflags hsc_env) str
; let icontext = hsc_IC hsc_env
; case maybe_type of {
- Just ty -> tcRnType hsc_env icontext ty ;
- Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an type:" <+> quotes (text str)) ;
- return Nothing } ;
- Nothing -> return Nothing } }
+ Just ty -> tcRnType hsc_env icontext ty ;
+ Nothing -> return Nothing } }
#endif
\end{code}
#endif
\end{code}
@@
-894,19
+897,12
@@
hscParseThing parser dflags str
\begin{code}
#ifdef GHCI
\begin{code}
#ifdef GHCI
-compileExpr :: HscEnv
- -> Module -> GlobalRdrEnv -> TypeEnv
- -> LHsExpr Id
- -> IO HValue
+compileExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
-compileExpr hsc_env this_mod rdr_env type_env tc_expr
+compileExpr hsc_env srcspan ds_expr
= do { let { dflags = hsc_dflags hsc_env ;
= do { let { dflags = hsc_dflags hsc_env ;
- lint_on = dopt Opt_DoCoreLinting dflags ;
- !srcspan = getLoc tc_expr }
+ lint_on = dopt Opt_DoCoreLinting dflags }
- -- Desugar it
- ; ds_expr <- deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
-
-- Flatten it
; flat_expr <- flattenExpr hsc_env ds_expr
-- Flatten it
; flat_expr <- flattenExpr hsc_env ds_expr