import ObjLink
import Linker
import StaticFlags
+import MonadUtils ( MonadIO, liftIO )
+import Exception
import Data.Maybe
import Numeric
-import 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
prompt :: String,
editor :: String,
stop :: String,
- session :: GHC.Session,
options :: [GHCiOption],
prelude :: GHC.Module,
break_ctr :: !Int,
-- 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)
}
}
return (False, oldCounter)
-newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
+newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }
+
+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 -> IO a
-startGHCi g state = do ref <- newIORef state; unGHCi g ref
+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
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
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
+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 :: GHC.SingleStep -> GHCi GHC.RunResult
-resume step = withVirtualPath$ do
- session <- getSession
- io$ GHC.resume session step
-
+resume step = GHC.resume step
-- --------------------------------------------------------------------------
-- timing & statistics
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 <+>
-- 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
projects / ghc-hetmet.git / blobdiff