X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FGhciMonad.hs;h=d5e491bbf5ccfaf3eb55db2cc27ebdab5ef8649e;hb=831a35dd00faff195cf938659c2dd736192b865f;hp=3dcdce1732d122ade5396d0566642f40bfed60e1;hpb=28a5c73a83e8f27c31cad02da07c81e4e6764303;p=ghc-hetmet.git diff --git a/compiler/ghci/GhciMonad.hs b/compiler/ghci/GhciMonad.hs index 3dcdce1..d5e491b 100644 --- a/compiler/ghci/GhciMonad.hs +++ b/compiler/ghci/GhciMonad.hs @@ -25,18 +25,17 @@ import Module import ObjLink import Linker import StaticFlags +import MonadUtils ( MonadIO, liftIO ) +import Exception import Data.Maybe import Numeric -import Control.Exception as Exception import Data.Array import Data.Char import Data.Int ( Int64 ) import Data.IORef import Data.List -import Data.Typeable import System.CPUTime -import System.Directory import System.Environment import System.IO import Control.Monad as Monad @@ -54,7 +53,6 @@ data GHCiState = GHCiState prompt :: String, editor :: String, stop :: String, - session :: GHC.Session, options :: [GHCiOption], prelude :: GHC.Module, break_ctr :: !Int, @@ -70,11 +68,10 @@ data GHCiState = GHCiState remembered_ctx :: [(CtxtCmd, [String], [String])], -- we remember the :module commands between :loads, so that -- on a :reload we can replay them. See bugs #2049, - -- #1873, #1360. Previously we tried to remember modules that + -- \#1873, #1360. Previously we tried to remember modules that -- were supposed to be in the context but currently had errors, -- but this was complicated. Just replaying the :module commands -- seems to be the right thing. - virtual_path :: FilePath, ghc_e :: Bool -- True if this is 'ghc -e' (or runghc) } @@ -128,10 +125,21 @@ recordBreak brkLoc = do } return (False, oldCounter) -newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a } +newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a } -startGHCi :: GHCi a -> GHCiState -> IO a -startGHCi g state = do ref <- newIORef state; unGHCi g ref +reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a +reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s + +reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a +reifyGHCi f = GHCi f' + where + -- f' :: IORef GHCiState -> Ghc a + f' gs = reifyGhc (f'' gs) + -- f'' :: IORef GHCiState -> Session -> IO a + f'' gs s = f (s, gs) + +startGHCi :: GHCi a -> GHCiState -> Ghc a +startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref instance Monad GHCi where (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s @@ -140,43 +148,66 @@ instance Monad GHCi where instance Functor GHCi where fmap f m = m >>= return . f -ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a -ghciHandleDyn h (GHCi m) = GHCi $ \s -> - Exception.catchDyn (m s) (\e -> unGHCi (h e) s) +ghciHandleGhcException :: (GhcException -> GHCi a) -> GHCi a -> GHCi a +ghciHandleGhcException = handleGhcException getGHCiState :: GHCi GHCiState -getGHCiState = GHCi $ \r -> readIORef r +getGHCiState = GHCi $ \r -> liftIO $ readIORef r setGHCiState :: GHCiState -> GHCi () -setGHCiState s = GHCi $ \r -> writeIORef r s +setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s + +liftGhc :: Ghc a -> GHCi a +liftGhc m = GHCi $ \_ -> m + +instance MonadIO GHCi where + liftIO m = liftGhc $ liftIO m + +instance GhcMonad GHCi where + setSession s' = liftGhc $ setSession s' + getSession = liftGhc $ getSession + +instance ExceptionMonad GHCi where + gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r) + gblock (GHCi m) = GHCi $ \r -> gblock (m r) + gunblock (GHCi m) = GHCi $ \r -> gunblock (m r) + +instance WarnLogMonad GHCi where + setWarnings warns = liftGhc $ setWarnings warns + getWarnings = liftGhc $ getWarnings -- for convenience... -getSession :: GHCi Session -getSession = getGHCiState >>= return . session getPrelude :: GHCi Module getPrelude = getGHCiState >>= return . prelude -GLOBAL_VAR(saved_sess, no_saved_sess, GHC.Session) +GLOBAL_VAR(saved_sess, no_saved_sess, Session) no_saved_sess :: Session no_saved_sess = error "no saved_ses" saveSession :: GHCi () -saveSession = getSession >>= io . writeIORef saved_sess +saveSession = + liftGhc $ do + reifyGhc $ \s -> + writeIORef saved_sess s splatSavedSession :: GHCi () splatSavedSession = io (writeIORef saved_sess no_saved_sess) -restoreSession :: IO Session -restoreSession = readIORef saved_sess +-- restoreSession :: IO Session +-- restoreSession = readIORef saved_sess + +withRestoredSession :: Ghc a -> IO a +withRestoredSession ghc = do + s <- readIORef saved_sess + reflectGhc ghc s getDynFlags :: GHCi DynFlags getDynFlags = do - s <- getSession - io (GHC.getSessionDynFlags s) + GHC.getSessionDynFlags + setDynFlags :: DynFlags -> GHCi [PackageId] setDynFlags dflags = do - s <- getSession - io (GHC.setSessionDynFlags s dflags) + GHC.setSessionDynFlags dflags isOptionSet :: GHCiOption -> GHCi Bool isOptionSet opt @@ -194,43 +225,31 @@ unsetOption opt setGHCiState (st{ options = filter (/= opt) (options st) }) io :: IO a -> GHCi a -io m = GHCi (\_ -> m) +io = liftIO printForUser :: SDoc -> GHCi () printForUser doc = do - session <- getSession - unqual <- io (GHC.getPrintUnqual session) + unqual <- GHC.getPrintUnqual io $ Outputable.printForUser stdout unqual doc printForUserPartWay :: SDoc -> GHCi () printForUserPartWay doc = do - session <- getSession - unqual <- io (GHC.getPrintUnqual session) + unqual <- GHC.getPrintUnqual io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc -withVirtualPath :: GHCi a -> GHCi a -withVirtualPath m = do - ghci_wd <- io getCurrentDirectory -- Store the cwd of GHCi - st <- getGHCiState - io$ setCurrentDirectory (virtual_path st) - result <- m -- Evaluate in the virtual wd.. - vwd <- io getCurrentDirectory - setGHCiState (st{ virtual_path = vwd}) -- Update the virtual path - io$ setCurrentDirectory ghci_wd -- ..and restore GHCi wd - return result - runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult -runStmt expr step = withVirtualPath$ do - session <- getSession - st <- getGHCiState - io$ withProgName (progname st) $ withArgs (args st) $ - GHC.runStmt session expr step - -resume :: GHC.SingleStep -> GHCi GHC.RunResult -resume step = withVirtualPath$ do - session <- getSession - io$ GHC.resume session step - +runStmt expr step = do + st <- getGHCiState + reifyGHCi $ \x -> + withProgName (progname st) $ + withArgs (args st) $ + reflectGHCi x $ do + GHC.handleSourceError (\e -> do GHC.printExceptionAndWarnings e + return GHC.RunFailed) $ do + GHC.runStmt expr step + +resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult +resume canLogSpan step = GHC.resume canLogSpan step -- -------------------------------------------------------------------------- -- timing & statistics @@ -254,7 +273,7 @@ foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64 printTimes :: Integer -> Integer -> IO () printTimes allocs psecs - = do let secs = (fromIntegral psecs / (10^12)) :: Float + = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float secs_str = showFFloat (Just 2) secs putStrLn (showSDoc ( parens (text (secs_str "") <+> text "secs" <> comma <+> @@ -296,10 +315,10 @@ GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ()) -- of the Handle rather than referring to it from its static address -- each time. There's no safe workaround for this. -initInterpBuffering :: GHC.Session -> IO () -initInterpBuffering session - = do -- make sure these are linked - dflags <- GHC.getSessionDynFlags session +initInterpBuffering :: Ghc () +initInterpBuffering = do -- make sure these are linked + dflags <- GHC.getSessionDynFlags + liftIO $ do initDynLinker dflags -- ToDo: we should really look up these names properly, but