------------------------------------------------------------------------------
--- GHCi monad
-
-data GHCiState = GHCiState
- {
- progname :: String,
- args :: [String],
- prompt :: String,
- session :: GHC.Session,
- options :: [GHCiOption]
- }
-
-data GHCiOption
- = ShowTiming -- show time/allocs after evaluation
- | ShowType -- show the type of expressions
- | RevertCAFs -- revert CAFs after every evaluation
- deriving Eq
-
-newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
-
-startGHCi :: GHCi a -> GHCiState -> IO a
-startGHCi g state = do ref <- newIORef state; unGHCi g ref
-
-instance Monad GHCi where
- (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
- return a = GHCi $ \s -> return a
-
-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)
-
-getGHCiState = GHCi $ \r -> readIORef r
-setGHCiState s = GHCi $ \r -> writeIORef r s
-
--- for convenience...
-getSession = getGHCiState >>= return . session
-
-GLOBAL_VAR(saved_sess, no_saved_sess, Session)
-no_saved_sess = error "no saved_ses"
-saveSession = getSession >>= io . writeIORef saved_sess
-splatSavedSession = io (writeIORef saved_sess no_saved_sess)
-restoreSession = readIORef saved_sess
-
-getDynFlags = do
- s <- getSession
- io (GHC.getSessionDynFlags s)
-setDynFlags dflags = do
- s <- getSession
- io (GHC.setSessionDynFlags s dflags)
-
-isOptionSet :: GHCiOption -> GHCi Bool
-isOptionSet opt
- = do st <- getGHCiState
- return (opt `elem` options st)
-
-setOption :: GHCiOption -> GHCi ()
-setOption opt
- = do st <- getGHCiState
- setGHCiState (st{ options = opt : filter (/= opt) (options st) })
-
-unsetOption :: GHCiOption -> GHCi ()
-unsetOption opt
- = do st <- getGHCiState
- setGHCiState (st{ options = filter (/= opt) (options st) })
-
-io :: IO a -> GHCi a
-io m = GHCi { unGHCi = \s -> m >>= return }
-
------------------------------------------------------------------------------
--- recursive exception handlers
-
--- Don't forget to unblock async exceptions in the handler, or if we're
--- in an exception loop (eg. let a = error a in a) the ^C exception
--- may never be delivered. Thanks to Marcin for pointing out the bug.
-
-ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
-ghciHandle h (GHCi m) = GHCi $ \s ->
- Exception.catch (m s)
- (\e -> unGHCi (ghciUnblock (h e)) s)
-
-ghciUnblock :: GHCi a -> GHCi a
-ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
-
------------------------------------------------------------------------------
--- timing & statistics
-
-timeIt :: GHCi a -> GHCi a
-timeIt action
- = do b <- isOptionSet ShowTiming
- if not b
- then action
- else do allocs1 <- io $ getAllocations
- time1 <- io $ getCPUTime
- a <- action
- allocs2 <- io $ getAllocations
- time2 <- io $ getCPUTime
- io $ printTimes (fromIntegral (allocs2 - allocs1))
- (time2 - time1)
- return a
-
-foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
- -- defined in ghc/rts/Stats.c
-
-printTimes :: Integer -> Integer -> IO ()
-printTimes allocs psecs
- = do let secs = (fromIntegral psecs / (10^12)) :: Float
- secs_str = showFFloat (Just 2) secs
- putStrLn (showSDoc (
- parens (text (secs_str "") <+> text "secs" <> comma <+>
- text (show allocs) <+> text "bytes")))
-
------------------------------------------------------------------------------
--- reverting CAFs
-
-revertCAFs :: IO ()
-revertCAFs = do
- rts_revertCAFs
- turnOffBuffering
- -- Have to turn off buffering again, because we just
- -- reverted stdout, stderr & stdin to their defaults.
-
-foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
- -- Make it "safe", just in case
-
projects / ghc-hetmet.git / blobdiff