X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FHscMain.lhs;h=8d2fa59419096b78ea7f5ac4529577c1790d9840;hb=266c5c7999e778abf02f36c680a90c2893bbe4d7;hp=8187bab03dc57442ce801a8173979a100f76c504;hpb=1004a5a31ae62ab53000f6d1248f117a6c22c5e5;p=ghc-hetmet.git diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 8187bab..8d2fa59 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -6,9 +6,11 @@ \begin{code} module HscMain ( - HscResult(..), hscMain, newHscEnv, hscBufferFrontEnd + HscResult(..), HscCheckResult(..) , + hscMain, newHscEnv, hscCmmFile, hscBufferFrontEnd #ifdef GHCI - , hscStmt, hscTcExpr, hscKcType, hscThing, + , hscStmt, hscTcExpr, hscKcType + , hscGetInfo, GetInfoResult , compileExpr #endif ) where @@ -17,19 +19,19 @@ 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 ) @@ -37,11 +39,15 @@ import DsMeta ( templateHaskellNames ) import BasicTypes ( Fixity ) #endif +import RdrName ( RdrName ) +import HsSyn ( HsModule ) +import SrcLoc ( SrcLoc, noSrcLoc, 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 ) @@ -57,6 +63,7 @@ import CoreToStg ( coreToStg ) import Name ( Name, NamedThing(..) ) import SimplStg ( stg2stg ) import CodeGen ( codeGen ) +import CmmParse ( parseCmmFile ) import CodeOutput ( codeOutput ) import CmdLineOpts @@ -124,7 +131,7 @@ data HscResult = HscFail -- In IDE mode: we just do the static/dynamic checks - | HscChecked + | HscChecked HscCheckResult -- Concluded that it wasn't necessary | HscNoRecomp ModDetails -- new details (HomeSymbolTable additions) @@ -139,6 +146,13 @@ data HscResult (Maybe CompiledByteCode) +-- The result when we're just checking (in an IDE editor, for example) +data HscCheckResult + = HscParsed (Located (HsModule RdrName)) + -- renaming/typechecking failed, here's the parse tree + | HscTypechecked TcGblEnv + -- renaming/typechecking succeeded + -- What to do when we have compiler error or warning messages type MessageAction = Messages -> IO () @@ -176,10 +190,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" }; @@ -187,9 +201,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 ; @@ -202,15 +215,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 @@ -325,7 +338,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 { ------------------- @@ -362,16 +375,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 (HscParsed rdr_module)) + -- space leak on rdr_module! + Just r -> return (HscChecked (HscTypechecked r)) hscFrontEnd hsc_env msg_act rdr_module = do { @@ -449,6 +468,18 @@ hscBackEnd dflags } +hscCmmFile :: DynFlags -> FilePath -> IO Bool +hscCmmFile dflags filename = do + maybe_cmm <- parseCmmFile dflags filename + case maybe_cmm of + Nothing -> return False + Just cmm -> do + codeOutput dflags no_mod NoStubs noDependencies [cmm] + return True + where + no_mod = panic "hscCmmFile: no_mod" + + myParseModule dflags src_filename = do -------------------------- Parser ---------------- showPass dflags "Parser" @@ -561,7 +592,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 } ; } } @@ -575,7 +606,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} @@ -627,23 +658,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}