X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Fmain%2FGHC.hs;h=38208a0c693efb0b7b1ce38e45fb4983dff3f61e;hb=421b380e75a04f4e1e8e110b46a4bf872e006f79;hp=472f587e56dd2e063710dc1ac1d81c190de44575;hpb=6091f224f4f0a2921ca62739b3c6c5540d27269c;p=ghc-hetmet.git diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 472f587..38208a0 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -53,6 +53,7 @@ module GHC ( parsedSource, coreModule, compileToCoreModule, compileToCoreSimplified, compileCoreToObj, + getModSummary, -- * Parsing Haddock comments parseHaddockComment, @@ -106,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), @@ -198,6 +199,11 @@ module GHC ( -- * Exceptions GhcException(..), showGhcException, + -- * Token stream manipulations + Token, + getTokenStream, getRichTokenStream, + showRichTokenStream, addSourceToTokens, + -- * Miscellaneous --sessionHscEnv, cyclicModuleErr, @@ -269,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, @@ -291,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) @@ -304,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 @@ -1006,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 @@ -1188,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 @@ -1717,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 @@ -2182,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 @@ -2440,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 @@ -2476,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