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),
-- * Exceptions
GhcException(..), showGhcException,
+ -- * Token stream manipulations
+ Token,
+ getTokenStream, getRichTokenStream,
+ showRichTokenStream, addSourceToTokens,
+
-- * Miscellaneous
--sessionHscEnv,
cyclicModuleErr,
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,
-- 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
+ ghandle (\exception -> liftIO $ do
hFlush stdout
case exception of
-- an IO exception probably isn't our fault, so don't panic
exitWith (ExitFailure 1)
) $
#else
- handle (\(SomeException exception) -> do
+ ghandle (\(SomeException exception) -> liftIO $ do
hFlush stdout
case cast exception of
-- an IO exception probably isn't our fault, so don't panic
-- 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
--
-- 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
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
-- :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
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