X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FHscMain.lhs;h=d2731054bfc4e3fefee55e724594c88093320c0a;hb=a3e01707ebc2e7180840b5ab3534f818b43c2873;hp=7b1a1025717d014fd3fe0f4598c6db03effde6b3;hpb=423d477bfecd490de1449c59325c8776f91d7aac;p=ghc-hetmet.git diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 7b1a102..d273105 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -6,9 +6,11 @@ \begin{code} module HscMain ( - HscResult(..), hscMain, newHscEnv, hscCmmFile, hscBufferFrontEnd + HscResult(..), + hscMain, newHscEnv, hscCmmFile, hscBufferFrontEnd #ifdef GHCI - , hscStmt, hscTcExpr, hscKcType, hscThing, + , hscStmt, hscTcExpr, hscKcType + , hscGetInfo, GetInfoResult , compileExpr #endif ) where @@ -17,31 +19,36 @@ module HscMain ( #ifdef GHCI import HsSyn ( Stmt(..), LStmt, LHsExpr, LHsType ) -import IfaceSyn ( IfaceDecl ) +import IfaceSyn ( IfaceDecl, IfaceInst ) import CodeOutput ( outputForeignStubs ) import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) import Linker ( HValue, linkExpr ) import TidyPgm ( tidyCoreExpr ) import CorePrep ( corePrepExpr ) import Flattening ( flattenExpr ) -import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnThing, tcRnType ) -import RdrName ( RdrName ) +import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnGetInfo, tcRnType ) +import RdrName ( rdrNameOcc ) +import OccName ( occNameUserString ) import Type ( Type ) import PrelNames ( iNTERACTIVE ) import StringBuffer ( stringToStringBuffer ) -import SrcLoc ( SrcLoc, noSrcLoc, Located(..) ) import Kind ( Kind ) import Var ( Id ) import CoreLint ( lintUnfolding ) import DsMeta ( templateHaskellNames ) import BasicTypes ( Fixity ) +import SrcLoc ( SrcLoc, noSrcLoc ) #endif +import RdrName ( RdrName ) +import HsSyn ( HsModule ) +import SrcLoc ( Located(..) ) import StringBuffer ( hGetStringBuffer ) import Parser import Lexer ( P(..), ParseResult(..), mkPState ) import SrcLoc ( mkSrcLoc ) import TcRnDriver ( tcRnModule, tcRnExtCore ) +import TcRnTypes ( TcGblEnv ) import TcIface ( typecheckIface ) import IfaceEnv ( initNameCache ) import LoadIface ( ifaceStats, initExternalPackageState ) @@ -126,6 +133,8 @@ data HscResult -- In IDE mode: we just do the static/dynamic checks | HscChecked + (Located (HsModule RdrName)) -- parse tree + (Maybe TcGblEnv) -- typechecker output, if succeeded -- Concluded that it wasn't necessary | HscNoRecomp ModDetails -- new details (HomeSymbolTable additions) @@ -177,10 +186,10 @@ hscMain hsc_env msg_act mod location -- hscNoRecomp definitely expects to have the old interface available hscNoRecomp hsc_env msg_act have_object mod location (Just old_iface) - | hsc_mode hsc_env == OneShot + | isOneShot (hsc_mode hsc_env) = do { - when (verbosity (hsc_dflags hsc_env) > 0) $ - hPutStrLn stderr "compilation IS NOT required"; + compilationProgressMsg (hsc_dflags hsc_env) $ + "compilation IS NOT required"; dumpIfaceStats hsc_env ; let { bomb = panic "hscNoRecomp:OneShot" }; @@ -188,9 +197,8 @@ hscNoRecomp hsc_env msg_act have_object } | otherwise = do { - when (verbosity (hsc_dflags hsc_env) >= 1) $ - hPutStrLn stderr ("Skipping " ++ - showModMsg have_object mod location); + compilationProgressMsg (hsc_dflags hsc_env) $ + ("Skipping " ++ showModMsg have_object mod location); new_details <- _scc_ "tcRnIface" typecheckIface hsc_env old_iface ; @@ -203,15 +211,15 @@ hscRecomp hsc_env msg_act have_object mod location maybe_checked_iface = do { -- what target are we shooting for? - ; let one_shot = hsc_mode hsc_env == OneShot + ; let one_shot = isOneShot (hsc_mode hsc_env) ; let dflags = hsc_dflags hsc_env ; let toInterp = dopt_HscLang dflags == HscInterpreted ; let toCore = isJust (ml_hs_file location) && isExtCoreFilename (fromJust (ml_hs_file location)) - ; when (not one_shot && verbosity dflags >= 1) $ - hPutStrLn stderr ("Compiling " ++ - showModMsg (not toInterp) mod location); + ; when (not one_shot) $ + compilationProgressMsg dflags $ + ("Compiling " ++ showModMsg (not toInterp) mod location); ; front_res <- if toCore then hscCoreFrontEnd hsc_env msg_act location @@ -326,7 +334,7 @@ hscCoreFrontEnd hsc_env msg_act location = do { ------------------- ; inp <- readFile (expectJust "hscCoreFrontEnd:hspp" (ml_hspp_file location)) ; case parseCore inp 1 of - FailP s -> hPutStrLn stderr s >> return (Left HscFail) + FailP s -> putMsg s{-ToDo: wrong-} >> return (Left HscFail) OkP rdr_module -> do { ------------------- @@ -363,16 +371,22 @@ hscFileFrontEnd hsc_env msg_act location = do { hscBufferFrontEnd :: HscEnv -> StringBuffer -> MessageAction -> IO HscResult hscBufferFrontEnd hsc_env buffer msg_act = do let loc = mkSrcLoc (mkFastString "*edit*") 1 0 + showPass (hsc_dflags hsc_env) "Parser" case unP parseModule (mkPState buffer loc (hsc_dflags hsc_env)) of PFailed span err -> do - msg_act (emptyBag, unitBag (mkPlainErrMsg span err)) - return HscFail - POk _ rdr_module -> do - r <- hscFrontEnd hsc_env msg_act rdr_module - case r of - Left r -> return r - Right _ -> return HscChecked - + msg_act (emptyBag, unitBag (mkPlainErrMsg span err)) + return HscFail + POk _ rdr_module -> do + hscBufferTypecheck hsc_env rdr_module msg_act + +hscBufferTypecheck hsc_env rdr_module msg_act = do + (tc_msgs, maybe_tc_result) <- _scc_ "Typecheck-Rename" + tcRnModule hsc_env rdr_module + msg_act tc_msgs + case maybe_tc_result of + Nothing -> return (HscChecked rdr_module Nothing) + Just r -> return (HscChecked rdr_module (Just r)) + -- space leak on rdr_module! hscFrontEnd hsc_env msg_act rdr_module = do { @@ -574,7 +588,7 @@ hscTcExpr hsc_env icontext expr Nothing -> return Nothing ; -- Parse error Just (Just (L _ (ExprStmt expr _))) -> tcRnExpr hsc_env icontext expr ; - Just other -> do { hPutStrLn stderr ("not an expression: `" ++ expr ++ "'") ; + Just other -> do { errorMsg ("not an expression: `" ++ expr ++ "'") ; return Nothing } ; } } @@ -588,7 +602,7 @@ hscKcType hsc_env icontext str = do { maybe_type <- hscParseType (hsc_dflags hsc_env) str ; case maybe_type of { Just ty -> tcRnType hsc_env icontext ty ; - Just other -> do { hPutStrLn stderr ("not an type: `" ++ str ++ "'") ; + Just other -> do { errorMsg ("not an type: `" ++ str ++ "'") ; return Nothing } ; Nothing -> return Nothing } } \end{code} @@ -640,23 +654,29 @@ hscParseThing parser dflags str \begin{code} #ifdef GHCI -hscThing -- like hscStmt, but deals with a single identifier +type GetInfoResult = (String, (IfaceDecl, Fixity, SrcLoc, [(IfaceInst,SrcLoc)])) + +hscGetInfo -- like hscStmt, but deals with a single identifier :: HscEnv -> InteractiveContext -- Context for compiling -> String -- The identifier - -> IO [(IfaceDecl, Fixity, SrcLoc)] + -> IO [GetInfoResult] -hscThing hsc_env ic str +hscGetInfo hsc_env ic str = do maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str case maybe_rdr_name of { Nothing -> return []; Just (L _ rdr_name) -> do - maybe_tc_result <- tcRnThing hsc_env ic rdr_name + maybe_tc_result <- tcRnGetInfo hsc_env ic rdr_name + + let -- str' is the the naked occurrence name + -- after stripping off qualification and parens (+) + str' = occNameUserString (rdrNameOcc rdr_name) case maybe_tc_result of { Nothing -> return [] ; - Just things -> return things + Just things -> return [(str', t) | t <- things] }} #endif \end{code}