X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=38208a0c693efb0b7b1ce38e45fb4983dff3f61e;hb=421b380e75a04f4e1e8e110b46a4bf872e006f79;hp=595ba67e2c78458b5abd1e1a8539e733d5c21bd8;hpb=1c7d0ac0a433f85effeb5e9cfb6b303c26b201d1;p=ghc-hetmet.git diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 595ba67..38208a0 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -43,7 +43,8 @@ module GHC ( -- * Loading\/compiling the program depanal, - load, loadWithCompiler, LoadHowMuch(..), SuccessFlag(..), -- also does depanal + load, loadWithLogger, LoadHowMuch(..), SuccessFlag(..), -- also does depanal + defaultWarnErrLogger, WarnErrLogger, workingDirectoryChanged, parseModule, typecheckModule, desugarModule, loadModule, ParsedModule, TypecheckedModule, DesugaredModule, -- all abstract @@ -52,6 +53,7 @@ module GHC ( parsedSource, coreModule, compileToCoreModule, compileToCoreSimplified, compileCoreToObj, + getModSummary, -- * Parsing Haddock comments parseHaddockComment, @@ -105,7 +107,7 @@ module GHC ( isModuleInterpreted, InteractiveEval.compileExpr, HValue, dynCompileExpr, lookupName, - GHC.obtainTerm, GHC.obtainTerm1, GHC.obtainTermB, reconstructType, + GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType, modInfoModBreaks, ModBreaks(..), BreakIndex, BreakInfo(breakInfo_number, breakInfo_module), @@ -197,6 +199,11 @@ module GHC ( -- * Exceptions GhcException(..), showGhcException, + -- * Token stream manipulations + Token, + getTokenStream, getRichTokenStream, + showRichTokenStream, addSourceToTokens, + -- * Miscellaneous --sessionHscEnv, cyclicModuleErr, @@ -268,13 +275,14 @@ import Bag ( unitBag, listToBag, emptyBag, isEmptyBag ) import ErrUtils import MonadUtils import Util -import StringBuffer ( StringBuffer, hGetStringBuffer ) +import StringBuffer ( StringBuffer, hGetStringBuffer, nextChar ) import Outputable import BasicTypes import Maybes ( expectJust, mapCatMaybes ) import HaddockParse import HaddockLex ( tokenise ) import FastString +import Lexer import Control.Concurrent import System.Directory ( getModificationTime, doesFileExist, @@ -290,9 +298,6 @@ import Data.IORef import System.FilePath import System.IO import System.IO.Error ( try, isDoesNotExistError ) -#if __GLASGOW_HASKELL__ >= 609 -import Data.Typeable (cast) -#endif import Prelude hiding (init) @@ -303,51 +308,36 @@ import Prelude hiding (init) -- Unless you want to handle exceptions yourself, you should wrap this around -- the top level of your program. The default handlers output the error -- message(s) to stderr and exit cleanly. -defaultErrorHandler :: DynFlags -> IO a -> IO a +defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => DynFlags -> m a -> m a defaultErrorHandler dflags inner = -- top-level exception handler: any unrecognised exception is a compiler bug. -#if __GLASGOW_HASKELL__ < 609 - handle (\exception -> do - hFlush stdout - case exception of - -- an IO exception probably isn't our fault, so don't panic - IOException _ -> - fatalErrorMsg dflags (text (show exception)) - AsyncException StackOverflow -> - fatalErrorMsg dflags (text "stack overflow: use +RTS -K to increase it") - ExitException _ -> throw exception - _ -> - fatalErrorMsg dflags (text (show (Panic (show exception)))) - exitWith (ExitFailure 1) - ) $ -#else - handle (\(SomeException exception) -> do + ghandle (\exception -> liftIO $ do hFlush stdout - case cast exception of + case fromException exception of -- an IO exception probably isn't our fault, so don't panic Just (ioe :: IOException) -> fatalErrorMsg dflags (text (show ioe)) - _ -> case cast exception of + _ -> case fromException exception of Just StackOverflow -> fatalErrorMsg dflags (text "stack overflow: use +RTS -K to increase it") - _ -> case cast exception of + _ -> case fromException exception of Just (ex :: ExitCode) -> throw ex _ -> fatalErrorMsg dflags (text (show (Panic (show exception)))) exitWith (ExitFailure 1) ) $ -#endif -- program errors: messages with locations attached. Sometimes it is -- convenient to just throw these as exceptions. handleErrMsg - (\em -> do printBagOfErrors dflags (unitBag em) - exitWith (ExitFailure 1)) $ + (\em -> liftIO $ do + printBagOfErrors dflags (unitBag em) + exitWith (ExitFailure 1)) $ -- error messages propagated as exceptions handleGhcException - (\ge -> do + (\ge -> liftIO $ do hFlush stdout case ge of PhaseFailed _ code -> exitWith code @@ -651,47 +641,38 @@ data LoadHowMuch | LoadUpTo ModuleName | LoadDependenciesOf ModuleName --- | Try to load the program. Calls 'loadWithCompiler' with the default +-- | Try to load the program. Calls 'loadWithLogger' with the default -- compiler that just immediately logs all warnings and errors. load :: GhcMonad m => LoadHowMuch -> m SuccessFlag load how_much = - loadWithCompiler defaultCompiler how_much - where - defaultCompiler env mod_summary mod_index mod_count - mb_old_iface mb_linkable = - handleSourceError logErrorsAndRethrowException $ do - home_mod_info <- compile env mod_summary mod_index mod_count - mb_old_iface mb_linkable - printWarnings - return home_mod_info - - logErrorsAndRethrowException err = do - printExceptionAndWarnings err - throw err + loadWithLogger defaultWarnErrLogger how_much + +-- | A function called to log warnings and errors. +type WarnErrLogger = GhcMonad m => Maybe SourceError -> m () + +defaultWarnErrLogger :: WarnErrLogger +defaultWarnErrLogger Nothing = printWarnings +defaultWarnErrLogger (Just e) = printExceptionAndWarnings e -- | Try to load the program. If a Module is supplied, then just -- attempt to load up to this target. If no Module is supplied, -- then try to load all targets. -- --- The first argument is a function that is called to compile a single module. --- The arguments are the same as 'DriverPipeline.compile'. Use this function --- to intercept warns and errors from a single module compilation. (Don't --- forget to actually call 'DriverPipeline.compile' inside that function. --- XXX: this could be enforced by changing 'ModuleCompiler' to return a static --- capability which can only be obtained by calling 'DriverPipeline.compile'.) - -loadWithCompiler :: GhcMonad m => ModuleCompiler -> LoadHowMuch -> m SuccessFlag -loadWithCompiler module_compiler how_much = do +-- The first argument is a function that is called after compiling each +-- module to print wanrings and errors. + +loadWithLogger :: GhcMonad m => WarnErrLogger -> LoadHowMuch -> m SuccessFlag +loadWithLogger logger how_much = do -- Dependency analysis first. Note that this fixes the module graph: -- even if we don't get a fully successful upsweep, the full module -- graph is still retained in the Session. We can tell which modules -- were successfully loaded by inspecting the Session's HPT. mod_graph <- depanal [] False - load2 how_much mod_graph module_compiler + load2 how_much mod_graph logger -load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] -> ModuleCompiler +load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] -> WarnErrLogger -> m SuccessFlag -load2 how_much mod_graph mod_comp = do +load2 how_much mod_graph logger = do guessOutputFile hsc_env <- getSession @@ -818,7 +799,7 @@ load2 how_much mod_graph mod_comp = do liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") 2 (ppr mg)) (upsweep_ok, hsc_env1, modsUpswept) - <- upsweep mod_comp + <- upsweep logger (hsc_env { hsc_HPT = emptyHomePackageTable }) pruned_hpt stable_mods cleanup mg @@ -1014,19 +995,27 @@ type TypecheckedSource = LHsBinds Id -- - default methods are turned into top-level decls. -- - dictionary bindings +-- | Return the 'ModSummary' of a module with the given name. +-- +-- The module must be part of the module graph (see 'hsc_mod_graph' and +-- 'ModuleGraph'). If this is not the case, this function will throw a +-- 'GhcApiError'. +-- +-- This function ignores boot modules and requires that there is only one +-- non-boot module with the given name. getModSummary :: GhcMonad m => ModuleName -> m ModSummary getModSummary mod = do mg <- liftM hsc_mod_graph getSession - case [ ms | ms <- mg, ms_mod_name ms == mod ] of + case [ ms | ms <- mg, ms_mod_name ms == mod, not (isBootSummary ms) ] of [] -> throw $ mkApiErr (text "Module not part of module graph") - (ms:_) -> return ms + [ms] -> return ms + multiple -> throw $ mkApiErr (text "getModSummary is ambiguous: " <+> ppr multiple) -- | Parse a module. -- -- Throws a 'SourceError' on parse error. -parseModule :: GhcMonad m => ModuleName -> m ParsedModule -parseModule mod = do - ms <- getModSummary mod +parseModule :: GhcMonad m => ModSummary -> m ParsedModule +parseModule ms = do hsc_env0 <- getSession let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms } rdr_module <- parseFile hsc_env ms @@ -1196,9 +1185,8 @@ compileCore simplify fn = do Just modSummary -> do -- Now we have the module name; -- parse, typecheck and desugar the module - let mod = ms_mod_name modSummary mod_guts <- coreModule `fmap` - (desugarModule =<< typecheckModule =<< parseModule mod) + (desugarModule =<< typecheckModule =<< parseModule modSummary) liftM gutsToCoreModule $ if simplify then do @@ -1426,7 +1414,7 @@ findPartiallyCompletedCycles modsDone theGraph upsweep :: GhcMonad m => - ModuleCompiler -- ^ See argument to 'loadWithCompiler'. + WarnErrLogger -- ^ Called to print warnings and errors. -> HscEnv -- ^ Includes initially-empty HPT -> HomePackageTable -- ^ HPT from last time round (pruned) -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability) @@ -1436,7 +1424,7 @@ upsweep HscEnv, -- With an updated HPT [ModSummary]) -- Mods which succeeded -upsweep mod_comp hsc_env old_hpt stable_mods cleanup sccs = do +upsweep logger hsc_env old_hpt stable_mods cleanup sccs = do (res, hsc_env, done) <- upsweep' hsc_env old_hpt [] sccs 1 (length sccs) return (res, hsc_env, reverse done) where @@ -1457,13 +1445,18 @@ upsweep mod_comp hsc_env old_hpt stable_mods cleanup sccs = do -- (moduleEnvElts (hsc_HPT hsc_env))) mb_mod_info - <- gtry $ gfinally - (upsweep_mod mod_comp hsc_env old_hpt stable_mods mod mod_index nmods) - (liftIO cleanup) -- Remove unwanted tmp files between compilations + <- handleSourceError + (\err -> do logger (Just err); return Nothing) $ do + mod_info <- upsweep_mod hsc_env old_hpt stable_mods + mod mod_index nmods + logger Nothing -- log warnings + return (Just mod_info) + + liftIO cleanup -- Remove unwanted tmp files between compilations case mb_mod_info of - Left (_ :: SomeException) -> return (Failed, hsc_env, done) - Right mod_info -> do + Nothing -> return (Failed, hsc_env, done) + Just mod_info -> do let this_mod = ms_mod_name mod -- Add new info to hsc_env @@ -1488,22 +1481,10 @@ upsweep mod_comp hsc_env old_hpt stable_mods cleanup sccs = do upsweep' hsc_env2 old_hpt1 done' mods (mod_index+1) nmods --- | Same type as 'DriverPipeline.compile'. See its documentation for --- argument description. -type ModuleCompiler = GhcMonad m => - HscEnv - -> ModSummary - -> Int - -> Int - -> Maybe ModIface - -> Maybe Linkable - -> m HomeModInfo - -- | Compile a single module. Always produce a Linkable for it if -- successful. If no compilation happened, return the old Linkable. upsweep_mod :: GhcMonad m => - ModuleCompiler - -> HscEnv + HscEnv -> HomePackageTable -> ([ModuleName],[ModuleName]) -> ModSummary @@ -1511,7 +1492,7 @@ upsweep_mod :: GhcMonad m => -> Int -- total number of modules -> m HomeModInfo -upsweep_mod compile hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods +upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods = let this_mod_name = ms_mod_name summary this_mod = ms_mod summary @@ -1732,7 +1713,7 @@ topSortModuleGraph -- -- True: eliminate the hi-boot nodes, and instead pretend -- the a source-import of Foo is an import of Foo --- The resulting graph has no hi-boot nodes, but can by cyclic +-- The resulting graph has no hi-boot nodes, but can be cyclic topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph @@ -2197,7 +2178,7 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) local_opts = getOptions dflags buf src_fn -- (dflags', leftovers, warns) - <- parseDynamicFlags dflags local_opts + <- parseDynamicNoPackageFlags dflags local_opts liftIO $ checkProcessArgsResult leftovers -- XXX: throws exceptions liftIO $ handleFlagWarnings dflags' warns -- XXX: throws exceptions @@ -2455,12 +2436,85 @@ pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a)) -- :browse will use either lm_toplev or inspect lm_interface, depending -- on whether the module is interpreted or not. --- This is for reconstructing refactored source code --- Calls the lexer repeatedly. --- ToDo: add comment tokens to token stream -getTokenStream :: Session -> Module -> IO [Located Token] #endif +-- Extract the filename, stringbuffer content and dynflags associed to a module +-- +-- XXX: Explain pre-conditions +getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags) +getModuleSourceAndFlags mod = do + m <- getModSummary (moduleName mod) + case ml_hs_file $ ms_location m of + Nothing -> throw $ mkApiErr (text "No source available for module " <+> ppr mod) + Just sourceFile -> do + source <- liftIO $ hGetStringBuffer sourceFile + return (sourceFile, source, ms_hspp_opts m) + + +-- | Return module source as token stream, including comments. +-- +-- The module must be in the module graph and its source must be available. +-- Throws a 'HscTypes.SourceError' on parse error. +getTokenStream :: GhcMonad m => Module -> m [Located Token] +getTokenStream mod = do + (sourceFile, source, flags) <- getModuleSourceAndFlags mod + let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0 + case lexTokenStream source startLoc flags of + POk _ ts -> return ts + PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err) + +-- | Give even more information on the source than 'getTokenStream' +-- This function allows reconstructing the source completely with +-- 'showRichTokenStream'. +getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)] +getRichTokenStream mod = do + (sourceFile, source, flags) <- getModuleSourceAndFlags mod + let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0 + case lexTokenStream source startLoc flags of + POk _ ts -> return $ addSourceToTokens startLoc source ts + PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err) + +-- | Given a source location and a StringBuffer corresponding to this +-- location, return a rich token stream with the source associated to the +-- tokens. +addSourceToTokens :: SrcLoc -> StringBuffer -> [Located Token] + -> [(Located Token, String)] +addSourceToTokens _ _ [] = [] +addSourceToTokens loc buf (t@(L span _) : ts) + | not (isGoodSrcSpan span) = (t,"") : addSourceToTokens loc buf ts + | otherwise = (t,str) : addSourceToTokens newLoc newBuf ts + where + (newLoc, newBuf, str) = go "" loc buf + start = srcSpanStart span + end = srcSpanEnd span + go acc loc buf | loc < start = go acc nLoc nBuf + | start <= loc && loc < end = go (ch:acc) nLoc nBuf + | otherwise = (loc, buf, reverse acc) + where (ch, nBuf) = nextChar buf + nLoc = advanceSrcLoc loc ch + + +-- | Take a rich token stream such as produced from 'getRichTokenStream' and +-- return source code almost identical to the original code (except for +-- insignificant whitespace.) +showRichTokenStream :: [(Located Token, String)] -> String +showRichTokenStream ts = go startLoc ts "" + where sourceFile = srcSpanFile (getLoc . fst . head $ ts) + startLoc = mkSrcLoc sourceFile 0 0 + go _ [] = id + go loc ((L span _, str):ts) + | not (isGoodSrcSpan span) = go loc ts + | locLine == tokLine = ((replicate (tokCol - locCol) ' ') ++) + . (str ++) + . go tokEnd ts + | otherwise = ((replicate (tokLine - locLine) '\n') ++) + . ((replicate tokCol ' ') ++) + . (str ++) + . go tokEnd ts + where (locLine, locCol) = (srcLocLine loc, srcLocCol loc) + (tokLine, tokCol) = (srcSpanStartLine span, srcSpanStartCol span) + tokEnd = srcSpanEnd span + -- ----------------------------------------------------------------------------- -- Interactive evaluation @@ -2491,18 +2545,14 @@ getHistorySpan :: GhcMonad m => History -> m SrcSpan getHistorySpan h = withSession $ \hsc_env -> return$ InteractiveEval.getHistorySpan hsc_env h -obtainTerm :: GhcMonad m => Bool -> Id -> m Term -obtainTerm force id = withSession $ \hsc_env -> - liftIO $ InteractiveEval.obtainTerm hsc_env force id - -obtainTerm1 :: GhcMonad m => Bool -> Maybe Type -> a -> m Term -obtainTerm1 force mb_ty a = +obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term +obtainTermFromVal bound force ty a = withSession $ \hsc_env -> - liftIO $ InteractiveEval.obtainTerm1 hsc_env force mb_ty a + liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a -obtainTermB :: GhcMonad m => Int -> Bool -> Id -> m Term -obtainTermB bound force id = +obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term +obtainTermFromId bound force id = withSession $ \hsc_env -> - liftIO $ InteractiveEval.obtainTermB hsc_env bound force id + liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id #endif