ghc/GhciMonad.hs

   1 {-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-}
   2 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
   3
   4 -----------------------------------------------------------------------------
   5 --
   6 -- Monadery code used in InteractiveUI
   7 --
   8 -- (c) The GHC Team 2005-2006
   9 --
  10 -----------------------------------------------------------------------------
  11
  12 module GhciMonad where
  13
  14 #include "HsVersions.h"
  15
  16 import qualified GHC
  17 import Outputable       hiding (printForUser, printForUserPartWay)
  18 import qualified Pretty
  19 import qualified Outputable
  20 import Panic            hiding (showException)
  21 import Util
  22 import DynFlags
  23 import HscTypes hiding (liftIO)
  24 import SrcLoc
  25 import Module
  26 import ObjLink
  27 import Linker
  28 import StaticFlags
  29 import qualified MonadUtils
  30 import qualified ErrUtils
  31
  32 import Exception
  33 -- import Data.Maybe
  34 import Numeric
  35 import Data.Array
  36 -- import Data.Char
  37 import Data.Int         ( Int64 )
  38 import Data.IORef
  39 -- import Data.List
  40 import System.CPUTime
  41 import System.Environment
  42 import System.IO
  43 import Control.Monad as Monad
  44 import GHC.Exts
  45
  46 import System.Console.Haskeline (CompletionFunc, InputT)
  47 import qualified System.Console.Haskeline as Haskeline
  48 import System.Console.Haskeline.Encoding
  49 import Control.Monad.Trans as Trans
  50 import qualified Data.ByteString as B
  51
  52 -----------------------------------------------------------------------------
  53 -- GHCi monad
  54
  55 type Command = (String, String -> InputT GHCi Bool, CompletionFunc GHCi)
  56
  57 data GHCiState = GHCiState
  58      {
  59         progname       :: String,
  60         args           :: [String],
  61         prompt         :: String,
  62         editor         :: String,
  63         stop           :: String,
  64         options        :: [GHCiOption],
  65         prelude        :: GHC.Module,
  66         break_ctr      :: !Int,
  67         breaks         :: ![(Int, BreakLocation)],
  68         tickarrays     :: ModuleEnv TickArray,
  69                 -- tickarrays caches the TickArray for loaded modules,
  70                 -- so that we don't rebuild it each time the user sets
  71                 -- a breakpoint.
  72         -- ":" at the GHCi prompt repeats the last command, so we
  73         -- remember is here:
  74         last_command   :: Maybe Command,
  75         cmdqueue       :: [String],
  76         remembered_ctx :: [(CtxtCmd, [String], [String])],
  77              -- we remember the :module commands between :loads, so that
  78              -- on a :reload we can replay them.  See bugs #2049,
  79              -- \#1873, #1360. Previously we tried to remember modules that
  80              -- were supposed to be in the context but currently had errors,
  81              -- but this was complicated.  Just replaying the :module commands
  82              -- seems to be the right thing.
  83         ghc_e :: Bool -- True if this is 'ghc -e' (or runghc)
  84      }
  85
  86 data CtxtCmd
  87   = SetContext
  88   | AddModules
  89   | RemModules
  90
  91 type TickArray = Array Int [(BreakIndex,SrcSpan)]
  92
  93 data GHCiOption
  94         = ShowTiming            -- show time/allocs after evaluation
  95         | ShowType              -- show the type of expressions
  96         | RevertCAFs            -- revert CAFs after every evaluation
  97         deriving Eq
  98
  99 data BreakLocation
 100    = BreakLocation
 101    { breakModule :: !GHC.Module
 102    , breakLoc    :: !SrcSpan
 103    , breakTick   :: {-# UNPACK #-} !Int
 104    , onBreakCmd  :: String
 105    }
 106
 107 instance Eq BreakLocation where
 108   loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
 109                  breakTick loc1   == breakTick loc2
 110
 111 prettyLocations :: [(Int, BreakLocation)] -> SDoc
 112 prettyLocations []   = text "No active breakpoints."
 113 prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
 114
 115 instance Outputable BreakLocation where
 116    ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
 117                 if null (onBreakCmd loc)
 118                    then empty
 119                    else doubleQuotes (text (onBreakCmd loc))
 120
 121 recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
 122 recordBreak brkLoc = do
 123    st <- getGHCiState
 124    let oldActiveBreaks = breaks st
 125    -- don't store the same break point twice
 126    case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
 127      (nm:_) -> return (True, nm)
 128      [] -> do
 129       let oldCounter = break_ctr st
 130           newCounter = oldCounter + 1
 131       setGHCiState $ st { break_ctr = newCounter,
 132                           breaks = (oldCounter, brkLoc) : oldActiveBreaks
 133                         }
 134       return (False, oldCounter)
 135
 136 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }
 137
 138 reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a
 139 reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s
 140
 141 reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a
 142 reifyGHCi f = GHCi f'
 143   where
 144     -- f' :: IORef GHCiState -> Ghc a
 145     f' gs = reifyGhc (f'' gs)
 146     -- f'' :: IORef GHCiState -> Session -> IO a
 147     f'' gs s = f (s, gs)
 148
 149 startGHCi :: GHCi a -> GHCiState -> Ghc a
 150 startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref
 151
 152 instance Monad GHCi where
 153   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
 154   return a  = GHCi $ \_ -> return a
 155
 156 instance Functor GHCi where
 157     fmap f m = m >>= return . f
 158
 159 ghciHandleGhcException :: (GhcException -> GHCi a) -> GHCi a -> GHCi a
 160 ghciHandleGhcException = handleGhcException
 161
 162 getGHCiState :: GHCi GHCiState
 163 getGHCiState   = GHCi $ \r -> liftIO $ readIORef r
 164 setGHCiState :: GHCiState -> GHCi ()
 165 setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s
 166
 167 liftGhc :: Ghc a -> GHCi a
 168 liftGhc m = GHCi $ \_ -> m
 169
 170 instance MonadUtils.MonadIO GHCi where
 171   liftIO = liftGhc . MonadUtils.liftIO
 172
 173 instance Trans.MonadIO Ghc where
 174   liftIO = MonadUtils.liftIO
 175
 176 instance GhcMonad GHCi where
 177   setSession s' = liftGhc $ setSession s'
 178   getSession    = liftGhc $ getSession
 179
 180 instance GhcMonad (InputT GHCi) where
 181   setSession = lift . setSession
 182   getSession = lift getSession
 183
 184 instance MonadUtils.MonadIO (InputT GHCi) where
 185   liftIO = Trans.liftIO
 186
 187 instance WarnLogMonad (InputT GHCi) where
 188   setWarnings = lift . setWarnings
 189   getWarnings = lift getWarnings
 190
 191 instance ExceptionMonad GHCi where
 192   gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
 193   gblock (GHCi m)   = GHCi $ \r -> gblock (m r)
 194   gunblock (GHCi m) = GHCi $ \r -> gunblock (m r)
 195
 196 instance WarnLogMonad GHCi where
 197   setWarnings warns = liftGhc $ setWarnings warns
 198   getWarnings = liftGhc $ getWarnings
 199
 200 instance MonadIO GHCi where
 201   liftIO = io
 202
 203 instance Haskeline.MonadException GHCi where
 204   catch = gcatch
 205   block = gblock
 206   unblock = gunblock
 207
 208 instance ExceptionMonad (InputT GHCi) where
 209     gcatch = Haskeline.catch
 210     gblock = Haskeline.block
 211     gunblock = Haskeline.unblock
 212
 213 -- for convenience...
 214 getPrelude :: GHCi Module
 215 getPrelude = getGHCiState >>= return . prelude
 216
 217 getDynFlags :: GhcMonad m => m DynFlags
 218 getDynFlags = do
 219   GHC.getSessionDynFlags
 220
 221 setDynFlags :: DynFlags -> GHCi [PackageId]
 222 setDynFlags dflags = do
 223   GHC.setSessionDynFlags dflags
 224
 225 isOptionSet :: GHCiOption -> GHCi Bool
 226 isOptionSet opt
 227  = do st <- getGHCiState
 228       return (opt `elem` options st)
 229
 230 setOption :: GHCiOption -> GHCi ()
 231 setOption opt
 232  = do st <- getGHCiState
 233       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 234
 235 unsetOption :: GHCiOption -> GHCi ()
 236 unsetOption opt
 237  = do st <- getGHCiState
 238       setGHCiState (st{ options = filter (/= opt) (options st) })
 239
 240 io :: IO a -> GHCi a
 241 io = MonadUtils.liftIO
 242
 243 printForUser :: SDoc -> GHCi ()
 244 printForUser doc = do
 245   unqual <- GHC.getPrintUnqual
 246   io $ Outputable.printForUser stdout unqual doc
 247
 248 printForUser' :: SDoc -> InputT GHCi ()
 249 printForUser' doc = do
 250     unqual <- GHC.getPrintUnqual
 251     Haskeline.outputStrLn $ showSDocForUser unqual doc
 252
 253 printForUserPartWay :: SDoc -> GHCi ()
 254 printForUserPartWay doc = do
 255   unqual <- GHC.getPrintUnqual
 256   io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc
 257
 258 -- We set log_action to write encoded output.
 259 -- This fails whenever GHC tries to mention an (already encoded) filename,
 260 -- but I don't know how to work around that.
 261 setLogAction :: InputT GHCi ()
 262 setLogAction = do
 263     encoder <- getEncoder
 264     dflags <- GHC.getSessionDynFlags
 265     _ <- GHC.setSessionDynFlags dflags {log_action = logAction encoder}
 266     return ()
 267   where
 268     logAction encoder severity srcSpan style msg = case severity of
 269         GHC.SevInfo -> printEncErrs encoder (msg style)
 270         GHC.SevFatal -> printEncErrs encoder (msg style)
 271         _ -> do
 272             hPutChar stderr '\n'
 273             printEncErrs encoder (ErrUtils.mkLocMessage srcSpan msg style)
 274     printEncErrs encoder doc = do
 275         str <- encoder (Pretty.showDocWith Pretty.PageMode doc)
 276         B.hPutStrLn stderr str
 277         hFlush stderr
 278
 279 runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult
 280 runStmt expr step = do
 281   st <- getGHCiState
 282   reifyGHCi $ \x ->
 283     withProgName (progname st) $
 284     withArgs (args st) $
 285       reflectGHCi x $ do
 286         GHC.handleSourceError (\e -> do GHC.printExceptionAndWarnings e
 287                                         return GHC.RunFailed) $ do
 288           GHC.runStmt expr step
 289
 290 resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult
 291 resume canLogSpan step = GHC.resume canLogSpan step
 292
 293 -- --------------------------------------------------------------------------
 294 -- timing & statistics
 295
 296 timeIt :: InputT GHCi a -> InputT GHCi a
 297 timeIt action
 298   = do b <- lift $ isOptionSet ShowTiming
 299        if not b
 300           then action
 301           else do allocs1 <- liftIO $ getAllocations
 302                   time1   <- liftIO $ getCPUTime
 303                   a <- action
 304                   allocs2 <- liftIO $ getAllocations
 305                   time2   <- liftIO $ getCPUTime
 306                   liftIO $ printTimes (fromIntegral (allocs2 - allocs1))
 307                                   (time2 - time1)
 308                   return a
 309
 310 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
 311         -- defined in ghc/rts/Stats.c
 312
 313 printTimes :: Integer -> Integer -> IO ()
 314 printTimes allocs psecs
 315    = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float
 316             secs_str = showFFloat (Just 2) secs
 317         putStrLn (showSDoc (
 318                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 319                          text (show allocs) <+> text "bytes")))
 320
 321 -----------------------------------------------------------------------------
 322 -- reverting CAFs
 323
 324 revertCAFs :: GHCi ()
 325 revertCAFs = do
 326   io $ rts_revertCAFs
 327   s <- getGHCiState
 328   when (not (ghc_e s)) $ io turnOffBuffering
 329         -- Have to turn off buffering again, because we just
 330         -- reverted stdout, stderr & stdin to their defaults.
 331
 332 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
 333         -- Make it "safe", just in case
 334
 335 -----------------------------------------------------------------------------
 336 -- To flush buffers for the *interpreted* computation we need
 337 -- to refer to *its* stdout/stderr handles
 338
 339 GLOBAL_VAR(stdin_ptr,  error "no stdin_ptr",  Ptr ())
 340 GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ())
 341 GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ())
 342
 343 -- After various attempts, I believe this is the least bad way to do
 344 -- what we want.  We know look up the address of the static stdin,
 345 -- stdout, and stderr closures in the loaded base package, and each
 346 -- time we need to refer to them we cast the pointer to a Handle.
 347 -- This avoids any problems with the CAF having been reverted, because
 348 -- we'll always get the current value.
 349 --
 350 -- The previous attempt that didn't work was to compile an expression
 351 -- like "hSetBuffering stdout NoBuffering" into an expression of type
 352 -- IO () and run this expression each time we needed it, but the
 353 -- problem is that evaluating the expression might cache the contents
 354 -- of the Handle rather than referring to it from its static address
 355 -- each time.  There's no safe workaround for this.
 356
 357 initInterpBuffering :: Ghc ()
 358 initInterpBuffering = do -- make sure these are linked
 359     dflags <- GHC.getSessionDynFlags
 360     liftIO $ do
 361       initDynLinker dflags
 362
 363         -- ToDo: we should really look up these names properly, but
 364         -- it's a fiddle and not all the bits are exposed via the GHC
 365         -- interface.
 366       mb_stdin_ptr  <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdin_closure"
 367       mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdout_closure"
 368       mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stderr_closure"
 369
 370       let f ref (Just ptr) = writeIORef ref ptr
 371           f _   Nothing    = panic "interactiveUI:setBuffering2"
 372       zipWithM_ f [stdin_ptr,stdout_ptr,stderr_ptr]
 373                   [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
 374
 375 flushInterpBuffers :: GHCi ()
 376 flushInterpBuffers
 377  = io $ do getHandle stdout_ptr >>= hFlush
 378            getHandle stderr_ptr >>= hFlush
 379
 380 turnOffBuffering :: IO ()
 381 turnOffBuffering
 382  = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr]
 383       mapM_ (\h -> hSetBuffering h NoBuffering) hdls
 384
 385 getHandle :: IORef (Ptr ()) -> IO Handle
 386 getHandle ref = do
 387   (Ptr addr) <- readIORef ref
 388   case addrToHValue# addr of (# hval #) -> return (unsafeCoerce# hval)