ghc/compiler/ghci/InteractiveUI.hs

   1 {-# OPTIONS -#include "Linker.h" #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: InteractiveUI.hs,v 1.169 2004/07/30 08:40:11 simonpj Exp $
   4 --
   5 -- GHC Interactive User Interface
   6 --
   7 -- (c) The GHC Team 2004
   8 --
   9 -----------------------------------------------------------------------------
  10 module InteractiveUI (
  11         interactiveUI,  -- :: CmState -> [FilePath] -> IO ()
  12         ghciWelcomeMsg
  13    ) where
  14
  15 #include "../includes/config.h"
  16 #include "HsVersions.h"
  17
  18 import CompManager
  19 import HscTypes         ( TyThing(..), HomeModInfo(hm_linkable), HomePackageTable,
  20                           isObjectLinkable, GhciMode(..) )
  21 import IfaceSyn         ( IfaceType, IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..), IfaceConDecl(..),
  22                           pprIfaceDeclHead, pprParendIfaceType, pprIfaceForAllPart )
  23 import FunDeps          ( pprFundeps )
  24 import DriverFlags
  25 import DriverState
  26 import DriverUtil       ( remove_spaces )
  27 import Linker           ( showLinkerState, linkPackages )
  28 import Util
  29 import Module           ( showModMsg, lookupModuleEnv )
  30 import Name             ( Name, isHomePackageName, nameSrcLoc, nameOccName,
  31                           NamedThing(..) )
  32 import OccName          ( OccName, isSymOcc, occNameUserString )
  33 import BasicTypes       ( StrictnessMark(..), Fixity, defaultFixity, SuccessFlag(..) )
  34 import Packages
  35 import Outputable
  36 import CmdLineOpts      ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags,
  37                           restoreDynFlags, dopt_unset )
  38 import Panic            hiding ( showException )
  39 import Config
  40 import SrcLoc           ( SrcLoc, isGoodSrcLoc )
  41
  42 #ifndef mingw32_HOST_OS
  43 import DriverUtil( handle )
  44 import System.Posix
  45 #if __GLASGOW_HASKELL__ > 504
  46         hiding (getEnv)
  47 #endif
  48 #endif
  49
  50 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
  51 import Control.Concurrent       ( yield )       -- Used in readline loop
  52 import System.Console.Readline as Readline
  53 #endif
  54
  55 --import SystemExts
  56
  57 import Control.Exception as Exception
  58 import Data.Dynamic
  59 import Control.Concurrent
  60
  61 import Numeric
  62 import Data.List
  63 import Data.Int         ( Int64 )
  64 import System.Cmd
  65 import System.CPUTime
  66 import System.Environment
  67 import System.Directory
  68 import System.IO as IO
  69 import Data.Char
  70 import Control.Monad as Monad
  71
  72 import GHC.Exts         ( unsafeCoerce# )
  73
  74 import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )
  75
  76 import System.Posix.Internals ( setNonBlockingFD )
  77
  78 -----------------------------------------------------------------------------
  79
  80 ghciWelcomeMsg = "\
  81 \   ___         ___ _\n\
  82 \  / _ \\ /\\  /\\/ __(_)\n\
  83 \ / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
  84 \/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n\
  85 \\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
  86
  87 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
  88
  89 builtin_commands :: [(String, String -> GHCi Bool)]
  90 builtin_commands = [
  91   ("add",       keepGoingPaths addModule),
  92   ("browse",    keepGoing browseCmd),
  93   ("cd",        keepGoing changeDirectory),
  94   ("def",       keepGoing defineMacro),
  95   ("help",      keepGoing help),
  96   ("?",         keepGoing help),
  97   ("info",      keepGoing info),
  98   ("load",      keepGoingPaths loadModule),
  99   ("module",    keepGoing setContext),
 100   ("reload",    keepGoing reloadModule),
 101   ("set",       keepGoing setCmd),
 102   ("show",      keepGoing showCmd),
 103   ("type",      keepGoing typeOfExpr),
 104   ("kind",      keepGoing kindOfType),
 105   ("unset",     keepGoing unsetOptions),
 106   ("undef",     keepGoing undefineMacro),
 107   ("quit",      quit)
 108   ]
 109
 110 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 111 keepGoing a str = a str >> return False
 112
 113 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
 114 keepGoingPaths a str = a (toArgs str) >> return False
 115
 116 shortHelpText = "use :? for help.\n"
 117
 118 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
 119 helpText = "\
 120 \ Commands available from the prompt:\n\
 121 \\n\
 122 \   <stmt>                     evaluate/run <stmt>\n\
 123 \   :add <filename> ...        add module(s) to the current target set\n\
 124 \   :browse [*]<module>        display the names defined by <module>\n\
 125 \   :cd <dir>                  change directory to <dir>\n\
 126 \   :def <cmd> <expr>          define a command :<cmd>\n\
 127 \   :help, :?                  display this list of commands\n\
 128 \   :info [<name> ...]         display information about the given names\n\
 129 \   :load <filename> ...       load module(s) and their dependents\n\
 130 \   :module [+/-] [*]<mod> ... set the context for expression evaluation\n\
 131 \   :reload                    reload the current module set\n\
 132 \\n\
 133 \   :set <option> ...          set options\n\
 134 \   :set args <arg> ...        set the arguments returned by System.getArgs\n\
 135 \   :set prog <progname>       set the value returned by System.getProgName\n\
 136 \\n\
 137 \   :show modules              show the currently loaded modules\n\
 138 \   :show bindings             show the current bindings made at the prompt\n\
 139 \\n\
 140 \   :type <expr>               show the type of <expr>\n\
 141 \   :kind <type>               show the kind of <type>\n\
 142 \   :undef <cmd>               undefine user-defined command :<cmd>\n\
 143 \   :unset <option> ...        unset options\n\
 144 \   :quit                      exit GHCi\n\
 145 \   :!<command>                run the shell command <command>\n\
 146 \\n\
 147 \ Options for `:set' and `:unset':\n\
 148 \\n\
 149 \    +r                 revert top-level expressions after each evaluation\n\
 150 \    +s                 print timing/memory stats after each evaluation\n\
 151 \    +t                 print type after evaluation\n\
 152 \    -<flags>           most GHC command line flags can also be set here\n\
 153 \                         (eg. -v2, -fglasgow-exts, etc.)\n\
 154 \"
 155
 156 interactiveUI :: [FilePath] -> Maybe String -> IO ()
 157 interactiveUI srcs maybe_expr = do
 158    dflags <- getDynFlags
 159
 160    cmstate <- cmInit Interactive dflags;
 161
 162    hFlush stdout
 163    hSetBuffering stdout NoBuffering
 164
 165         -- Initialise buffering for the *interpreted* I/O system
 166    initInterpBuffering cmstate
 167
 168         -- We don't want the cmd line to buffer any input that might be
 169         -- intended for the program, so unbuffer stdin.
 170    hSetBuffering stdin NoBuffering
 171
 172         -- initial context is just the Prelude
 173    cmstate <- cmSetContext cmstate [] ["Prelude"]
 174
 175 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 176    Readline.initialize
 177 #endif
 178
 179    startGHCi (runGHCi srcs dflags maybe_expr)
 180         GHCiState{ progname = "<interactive>",
 181                    args = [],
 182                    targets = srcs,
 183                    cmstate = cmstate,
 184                    options = [] }
 185
 186 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 187    Readline.resetTerminal Nothing
 188 #endif
 189
 190    return ()
 191
 192 runGHCi :: [FilePath] -> DynFlags -> Maybe String -> GHCi ()
 193 runGHCi paths dflags maybe_expr = do
 194   read_dot_files <- io (readIORef v_Read_DotGHCi)
 195
 196   when (read_dot_files) $ do
 197     -- Read in ./.ghci.
 198     let file = "./.ghci"
 199     exists <- io (doesFileExist file)
 200     when exists $ do
 201        dir_ok  <- io (checkPerms ".")
 202        file_ok <- io (checkPerms file)
 203        when (dir_ok && file_ok) $ do
 204           either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
 205           case either_hdl of
 206              Left e    -> return ()
 207              Right hdl -> fileLoop hdl False
 208
 209   when (read_dot_files) $ do
 210     -- Read in $HOME/.ghci
 211     either_dir <- io (IO.try (getEnv "HOME"))
 212     case either_dir of
 213        Left e -> return ()
 214        Right dir -> do
 215           cwd <- io (getCurrentDirectory)
 216           when (dir /= cwd) $ do
 217              let file = dir ++ "/.ghci"
 218              ok <- io (checkPerms file)
 219              when ok $ do
 220                either_hdl <- io (IO.try (openFile file ReadMode))
 221                case either_hdl of
 222                   Left e    -> return ()
 223                   Right hdl -> fileLoop hdl False
 224
 225   -- Perform a :load for files given on the GHCi command line
 226   when (not (null paths)) $
 227      ghciHandle showException $
 228         loadModule paths
 229
 230   -- if verbosity is greater than 0, or we are connected to a
 231   -- terminal, display the prompt in the interactive loop.
 232   is_tty <- io (hIsTerminalDevice stdin)
 233   let show_prompt = verbosity dflags > 0 || is_tty
 234
 235   case maybe_expr of
 236         Nothing ->
 237             -- enter the interactive loop
 238             interactiveLoop is_tty show_prompt
 239         Just expr -> do
 240             -- just evaluate the expression we were given
 241             runCommand expr
 242             return ()
 243
 244   -- and finally, exit
 245   io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
 246
 247
 248 interactiveLoop is_tty show_prompt = do
 249   -- Ignore ^C exceptions caught here
 250   ghciHandleDyn (\e -> case e of
 251                         Interrupted -> ghciUnblock (interactiveLoop is_tty show_prompt)
 252                         _other      -> return ()) $ do
 253
 254   -- read commands from stdin
 255 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 256   if (is_tty)
 257         then readlineLoop
 258         else fileLoop stdin show_prompt
 259 #else
 260   fileLoop stdin show_prompt
 261 #endif
 262
 263
 264 -- NOTE: We only read .ghci files if they are owned by the current user,
 265 -- and aren't world writable.  Otherwise, we could be accidentally
 266 -- running code planted by a malicious third party.
 267
 268 -- Furthermore, We only read ./.ghci if . is owned by the current user
 269 -- and isn't writable by anyone else.  I think this is sufficient: we
 270 -- don't need to check .. and ../.. etc. because "."  always refers to
 271 -- the same directory while a process is running.
 272
 273 checkPerms :: String -> IO Bool
 274 checkPerms name =
 275 #ifdef mingw32_HOST_OS
 276   return True
 277 #else
 278   DriverUtil.handle (\_ -> return False) $ do
 279      st <- getFileStatus name
 280      me <- getRealUserID
 281      if fileOwner st /= me then do
 282         putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
 283         return False
 284       else do
 285         let mode =  fileMode st
 286         if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
 287            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
 288            then do
 289                putStrLn $ "*** WARNING: " ++ name ++
 290                           " is writable by someone else, IGNORING!"
 291                return False
 292           else return True
 293 #endif
 294
 295 fileLoop :: Handle -> Bool -> GHCi ()
 296 fileLoop hdl prompt = do
 297    cmstate <- getCmState
 298    (mod,imports) <- io (cmGetContext cmstate)
 299    when prompt (io (putStr (mkPrompt mod imports)))
 300    l <- io (IO.try (hGetLine hdl))
 301    case l of
 302         Left e | isEOFError e -> return ()
 303                | otherwise    -> io (ioError e)
 304         Right l ->
 305           case remove_spaces l of
 306             "" -> fileLoop hdl prompt
 307             l  -> do quit <- runCommand l
 308                      if quit then return () else fileLoop hdl prompt
 309
 310 stringLoop :: [String] -> GHCi ()
 311 stringLoop [] = return ()
 312 stringLoop (s:ss) = do
 313    case remove_spaces s of
 314         "" -> stringLoop ss
 315         l  -> do quit <- runCommand l
 316                  if quit then return () else stringLoop ss
 317
 318 mkPrompt toplevs exports
 319    = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
 320
 321 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 322 readlineLoop :: GHCi ()
 323 readlineLoop = do
 324    cmstate <- getCmState
 325    (mod,imports) <- io (cmGetContext cmstate)
 326    io yield
 327    l <- io (readline (mkPrompt mod imports)
 328                 `finally` setNonBlockingFD 0)
 329                 -- readline sometimes puts stdin into blocking mode,
 330                 -- so we need to put it back for the IO library
 331    case l of
 332         Nothing -> return ()
 333         Just l  ->
 334           case remove_spaces l of
 335             "" -> readlineLoop
 336             l  -> do
 337                   io (addHistory l)
 338                   quit <- runCommand l
 339                   if quit then return () else readlineLoop
 340 #endif
 341
 342 runCommand :: String -> GHCi Bool
 343 runCommand c = ghciHandle handler (doCommand c)
 344
 345 -- This is the exception handler for exceptions generated by the
 346 -- user's code; it normally just prints out the exception.  The
 347 -- handler must be recursive, in case showing the exception causes
 348 -- more exceptions to be raised.
 349 --
 350 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
 351 -- raising another exception.  We therefore don't put the recursive
 352 -- handler arond the flushing operation, so if stderr is closed
 353 -- GHCi will just die gracefully rather than going into an infinite loop.
 354 handler :: Exception -> GHCi Bool
 355 handler exception = do
 356   flushInterpBuffers
 357   io installSignalHandlers
 358   ghciHandle handler (showException exception >> return False)
 359
 360 showException (DynException dyn) =
 361   case fromDynamic dyn of
 362     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
 363     Just Interrupted      -> io (putStrLn "Interrupted.")
 364     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
 365     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
 366     Just other_ghc_ex     -> io (print other_ghc_ex)
 367
 368 showException other_exception
 369   = io (putStrLn ("*** Exception: " ++ show other_exception))
 370
 371 doCommand (':' : command) = specialCommand command
 372 doCommand stmt
 373    = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
 374         return False
 375
 376 runStmt :: String -> GHCi [Name]
 377 runStmt stmt
 378  | null (filter (not.isSpace) stmt) = return []
 379  | otherwise
 380  = do st <- getGHCiState
 381       dflags <- io getDynFlags
 382       let cm_state' = cmSetDFlags (cmstate st)
 383                                   (dopt_unset dflags Opt_WarnUnusedBinds)
 384       (new_cmstate, result) <-
 385         io $ withProgName (progname st) $ withArgs (args st) $
 386              cmRunStmt cm_state' stmt
 387       setGHCiState st{cmstate = new_cmstate}
 388       case result of
 389         CmRunFailed      -> return []
 390         CmRunException e -> showException e >> return []
 391         CmRunOk names    -> return names
 392
 393 -- possibly print the type and revert CAFs after evaluating an expression
 394 finishEvalExpr names
 395  = do b <- isOptionSet ShowType
 396       cmstate <- getCmState
 397       when b (mapM_ (showTypeOfName cmstate) names)
 398
 399       flushInterpBuffers
 400       io installSignalHandlers
 401       b <- isOptionSet RevertCAFs
 402       io (when b revertCAFs)
 403       return True
 404
 405 showTypeOfName :: CmState -> Name -> GHCi ()
 406 showTypeOfName cmstate n
 407    = do maybe_str <- io (cmTypeOfName cmstate n)
 408         case maybe_str of
 409           Nothing  -> return ()
 410           Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
 411
 412 specialCommand :: String -> GHCi Bool
 413 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 414 specialCommand str = do
 415   let (cmd,rest) = break isSpace str
 416   cmds <- io (readIORef commands)
 417   case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
 418      []      -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
 419                                     ++ shortHelpText) >> return False)
 420      [(_,f)] -> f (dropWhile isSpace rest)
 421      cs      -> io (hPutStrLn stdout ("prefix " ++ cmd ++
 422                                       " matches multiple commands (" ++
 423                                        foldr1 (\a b -> a ++ ',':b) (map fst cs)
 424                                          ++ ")") >> return False)
 425
 426 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
 427
 428
 429 -----------------------------------------------------------------------------
 430 -- To flush buffers for the *interpreted* computation we need
 431 -- to refer to *its* stdout/stderr handles
 432
 433 GLOBAL_VAR(flush_interp,       error "no flush_interp", IO ())
 434 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
 435
 436 no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++
 437              " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
 438 flush_cmd  = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr"
 439
 440 initInterpBuffering :: CmState -> IO ()
 441 initInterpBuffering cmstate
 442  = do maybe_hval <- cmCompileExpr cmstate no_buf_cmd
 443
 444       case maybe_hval of
 445         Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
 446         other     -> panic "interactiveUI:setBuffering"
 447
 448       maybe_hval <- cmCompileExpr cmstate flush_cmd
 449       case maybe_hval of
 450         Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
 451         _         -> panic "interactiveUI:flush"
 452
 453       turnOffBuffering  -- Turn it off right now
 454
 455       return ()
 456
 457
 458 flushInterpBuffers :: GHCi ()
 459 flushInterpBuffers
 460  = io $ do Monad.join (readIORef flush_interp)
 461            return ()
 462
 463 turnOffBuffering :: IO ()
 464 turnOffBuffering
 465  = do Monad.join (readIORef turn_off_buffering)
 466       return ()
 467
 468 -----------------------------------------------------------------------------
 469 -- Commands
 470
 471 help :: String -> GHCi ()
 472 help _ = io (putStr helpText)
 473
 474 info :: String -> GHCi ()
 475 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
 476 info s  = do { let names = words s
 477              ; init_cms <- getCmState
 478              ; mapM_ (infoThing init_cms) names }
 479   where
 480     infoThing cms name
 481         = do { stuff <- io (cmInfoThing cms name)
 482              ; io (putStrLn (showSDocForUser (cmGetPrintUnqual cms) $
 483                    vcat (intersperse (text "") (map (showThing name) stuff)))) }
 484
 485 showThing :: String -> (IfaceDecl, Fixity, SrcLoc) -> SDoc
 486 showThing name (thing, fixity, src_loc)
 487     = vcat [ showDecl (\occ -> name == occNameUserString occ) thing,
 488              showFixity fixity,
 489              showLoc src_loc]
 490   where
 491     showFixity fix
 492         | fix == defaultFixity = empty
 493         | otherwise            = ppr fix <+> text name
 494
 495     showLoc loc -- The ppr function for SrcLocs is a bit wonky
 496         | isGoodSrcLoc loc = ptext SLIT("Defined at") <+> ppr loc
 497         | otherwise        = ppr loc
 498
 499 -- Now there is rather a lot of goop just to print declarations in a civilised way
 500 -- with "..." for the parts we are less interested in.
 501
 502 showDecl :: (OccName -> Bool) -> IfaceDecl -> SDoc
 503 showDecl want_name (IfaceForeign {ifName = tc})
 504   = ppr tc <+> ptext SLIT("is a foreign type")
 505
 506 showDecl want_name (IfaceId {ifName = var, ifType = ty})
 507   = ppr var <+> dcolon <+> ppr ty
 508
 509 showDecl want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty})
 510   = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
 511        2 (equals <+> ppr mono_ty)
 512
 513 showDecl want_name (IfaceData {ifCtxt = context, ifName = tycon,
 514                      ifTyVars = tyvars, ifCons = condecls})
 515   = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
 516        2 (add_bars (ppr_trim show_con cs))
 517   where
 518     show_con (IfaceConDecl con_name is_infix ex_tvs ex_cxt tys strs flds)
 519         | want_name tycon || want_name con_name || any want_name flds
 520         = Just (pprIfaceForAllPart ex_tvs ex_cxt (show_guts con_name is_infix tys_w_strs flds))
 521         | otherwise = Nothing
 522         where
 523           tys_w_strs = tys `zip` (strs ++ repeat NotMarkedStrict)
 524
 525     show_guts con True [ty1, ty2] flds = sep [ppr_bangty ty1, ppr con, ppr_bangty ty2]
 526     show_guts con _ tys []   = ppr_bndr con <+> sep (map ppr_bangty tys)
 527     show_guts con _ tys flds
 528         = ppr_bndr con <+> braces (sep (punctuate comma (ppr_trim show_fld (tys `zip` flds))))
 529         where
 530           show_fld (bty, fld) | want_name tycon || want_name con || want_name fld
 531                               = Just (ppr_bndr fld <+> dcolon <+> ppr_bangty bty)
 532                               | otherwise = Nothing
 533
 534     (pp_nd, cs) = case condecls of
 535                     IfAbstractTyCon -> (ptext SLIT("data"),    [])
 536                     IfDataTyCon cs  -> (ptext SLIT("data"),    cs)
 537                     IfNewTyCon c    -> (ptext SLIT("newtype"), [c])
 538
 539     add_bars []      = empty
 540     add_bars [c]     = equals <+> c
 541     add_bars (c:cs)  = equals <+> sep (c : map (char '|' <+>) cs)
 542
 543     ppr_bangty (ty, str) = ppr_str str <> pprParendIfaceType ty
 544     ppr_str MarkedStrict    = char '!'
 545     ppr_str MarkedUnboxed   = ptext SLIT("!!")
 546     ppr_str NotMarkedStrict = empty
 547
 548 showDecl want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
 549                       ifFDs = fds, ifSigs = sigs})
 550   = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars
 551                 <+> pprFundeps fds <+> ptext SLIT("where"))
 552        2 (vcat (ppr_trim show_op sigs))
 553   where
 554     show_op (IfaceClassOp op dm ty)
 555         | want_name clas || want_name op = Just (ppr_bndr op <+> dcolon <+> ppr ty)
 556         | otherwise                      = Nothing
 557
 558 ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc]
 559 ppr_trim show xs
 560   = snd (foldr go (False, []) xs)
 561   where
 562     go x (eliding, so_far)
 563         | Just doc <- show x = (False, doc : so_far)
 564         | otherwise = if eliding then (True, so_far)
 565                                  else (True, ptext SLIT("...") : so_far)
 566
 567 ppr_bndr :: OccName -> SDoc
 568 -- Wrap operators in ()
 569 ppr_bndr occ | isSymOcc occ = parens (ppr occ)
 570              | otherwise    = ppr occ
 571
 572
 573 -----------------------------------------------------------------------------
 574 -- Commands
 575
 576 addModule :: [FilePath] -> GHCi ()
 577 addModule files = do
 578   state <- getGHCiState
 579   io (revertCAFs)                       -- always revert CAFs on load/add.
 580   files <- mapM expandPath files
 581   let new_targets = files ++ targets state
 582   graph <- io (cmDepAnal (cmstate state) new_targets)
 583   (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) graph)
 584   setGHCiState state{ cmstate = cmstate1, targets = new_targets }
 585   setContextAfterLoad mods
 586   dflags <- io getDynFlags
 587   modulesLoadedMsg ok mods dflags
 588
 589 changeDirectory :: String -> GHCi ()
 590 changeDirectory dir = do
 591   state    <- getGHCiState
 592   when (targets state /= []) $
 593         io $ putStr "Warning: changing directory causes all loaded modules to be unloaded, \n\
 594         \because the search path has changed.\n"
 595   cmstate1 <- io (cmUnload (cmstate state))
 596   setGHCiState state{ cmstate = cmstate1, targets = [] }
 597   setContextAfterLoad []
 598   dir <- expandPath dir
 599   io (setCurrentDirectory dir)
 600
 601 defineMacro :: String -> GHCi ()
 602 defineMacro s = do
 603   let (macro_name, definition) = break isSpace s
 604   cmds <- io (readIORef commands)
 605   if (null macro_name)
 606         then throwDyn (CmdLineError "invalid macro name")
 607         else do
 608   if (macro_name `elem` map fst cmds)
 609         then throwDyn (CmdLineError
 610                 ("command `" ++ macro_name ++ "' is already defined"))
 611         else do
 612
 613   -- give the expression a type signature, so we can be sure we're getting
 614   -- something of the right type.
 615   let new_expr = '(' : definition ++ ") :: String -> IO String"
 616
 617   -- compile the expression
 618   cms <- getCmState
 619   maybe_hv <- io (cmCompileExpr cms new_expr)
 620   case maybe_hv of
 621      Nothing -> return ()
 622      Just hv -> io (writeIORef commands --
 623                     ((macro_name, keepGoing (runMacro hv)) : cmds))
 624
 625 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
 626 runMacro fun s = do
 627   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 628   stringLoop (lines str)
 629
 630 undefineMacro :: String -> GHCi ()
 631 undefineMacro macro_name = do
 632   cmds <- io (readIORef commands)
 633   if (macro_name `elem` map fst builtin_commands)
 634         then throwDyn (CmdLineError
 635                 ("command `" ++ macro_name ++ "' cannot be undefined"))
 636         else do
 637   if (macro_name `notElem` map fst cmds)
 638         then throwDyn (CmdLineError
 639                 ("command `" ++ macro_name ++ "' not defined"))
 640         else do
 641   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
 642
 643
 644 loadModule :: [FilePath] -> GHCi ()
 645 loadModule fs = timeIt (loadModule' fs)
 646
 647 loadModule' :: [FilePath] -> GHCi ()
 648 loadModule' files = do
 649   state <- getGHCiState
 650
 651   -- expand tildes
 652   files <- mapM expandPath files
 653
 654   -- do the dependency anal first, so that if it fails we don't throw
 655   -- away the current set of modules.
 656   graph <- io (cmDepAnal (cmstate state) files)
 657
 658   -- Dependency anal ok, now unload everything
 659   cmstate1 <- io (cmUnload (cmstate state))
 660   setGHCiState state{ cmstate = cmstate1, targets = [] }
 661
 662   io (revertCAFs)  -- always revert CAFs on load.
 663   (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 graph)
 664   setGHCiState state{ cmstate = cmstate2, targets = files }
 665
 666   setContextAfterLoad mods
 667   dflags <- io (getDynFlags)
 668   modulesLoadedMsg ok mods dflags
 669
 670
 671 reloadModule :: String -> GHCi ()
 672 reloadModule "" = do
 673   state <- getGHCiState
 674   case targets state of
 675    [] -> io (putStr "no current target\n")
 676    paths -> do
 677         -- do the dependency anal first, so that if it fails we don't throw
 678         -- away the current set of modules.
 679         graph <- io (cmDepAnal (cmstate state) paths)
 680
 681         io (revertCAFs)         -- always revert CAFs on reload.
 682         (cmstate1, ok, mods)
 683                 <- io (cmLoadModules (cmstate state) graph)
 684         setGHCiState state{ cmstate=cmstate1 }
 685         setContextAfterLoad mods
 686         dflags <- io getDynFlags
 687         modulesLoadedMsg ok mods dflags
 688
 689 reloadModule _ = noArgs ":reload"
 690
 691 setContextAfterLoad [] = setContext prel
 692 setContextAfterLoad (m:_) = do
 693   cmstate <- getCmState
 694   b <- io (cmModuleIsInterpreted cmstate m)
 695   if b then setContext ('*':m) else setContext m
 696
 697 modulesLoadedMsg ok mods dflags =
 698   when (verbosity dflags > 0) $ do
 699    let mod_commas
 700         | null mods = text "none."
 701         | otherwise = hsep (
 702             punctuate comma (map text mods)) <> text "."
 703    case ok of
 704     Failed ->
 705        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 706     Succeeded  ->
 707        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 708
 709
 710 typeOfExpr :: String -> GHCi ()
 711 typeOfExpr str
 712   = do cms <- getCmState
 713        maybe_tystr <- io (cmTypeOfExpr cms str)
 714        case maybe_tystr of
 715           Nothing    -> return ()
 716           Just tystr -> io (putStrLn tystr)
 717
 718 kindOfType :: String -> GHCi ()
 719 kindOfType str
 720   = do cms <- getCmState
 721        maybe_tystr <- io (cmKindOfType cms str)
 722        case maybe_tystr of
 723           Nothing    -> return ()
 724           Just tystr -> io (putStrLn tystr)
 725
 726 quit :: String -> GHCi Bool
 727 quit _ = return True
 728
 729 shellEscape :: String -> GHCi Bool
 730 shellEscape str = io (system str >> return False)
 731
 732 -----------------------------------------------------------------------------
 733 -- Browsing a module's contents
 734
 735 browseCmd :: String -> GHCi ()
 736 browseCmd m =
 737   case words m of
 738     ['*':m] | looksLikeModuleName m -> browseModule m False
 739     [m]     | looksLikeModuleName m -> browseModule m True
 740     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
 741
 742 browseModule m exports_only = do
 743   cms <- getCmState
 744
 745   is_interpreted <- io (cmModuleIsInterpreted cms m)
 746   when (not is_interpreted && not exports_only) $
 747         throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
 748
 749   -- Temporarily set the context to the module we're interested in,
 750   -- just so we can get an appropriate PrintUnqualified
 751   (as,bs) <- io (cmGetContext cms)
 752   cms1 <- io (if exports_only then cmSetContext cms [] [prel,m]
 753                               else cmSetContext cms [m] [])
 754   cms2 <- io (cmSetContext cms1 as bs)
 755
 756   things <- io (cmBrowseModule cms2 m exports_only)
 757
 758   let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
 759
 760   io (putStrLn (showSDocForUser unqual (
 761          vcat (map (showDecl (const True)) things)
 762       )))
 763
 764 -----------------------------------------------------------------------------
 765 -- Setting the module context
 766
 767 setContext str
 768   | all sensible mods = fn mods
 769   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
 770   where
 771     (fn, mods) = case str of
 772                         '+':stuff -> (addToContext,      words stuff)
 773                         '-':stuff -> (removeFromContext, words stuff)
 774                         stuff     -> (newContext,        words stuff)
 775
 776     sensible ('*':m) = looksLikeModuleName m
 777     sensible m       = looksLikeModuleName m
 778
 779 newContext mods = do
 780   cms <- getCmState
 781   (as,bs) <- separate cms mods [] []
 782   let bs' = if null as && prel `notElem` bs then prel:bs else bs
 783   cms' <- io (cmSetContext cms as bs')
 784   setCmState cms'
 785
 786 separate cmstate []           as bs = return (as,bs)
 787 separate cmstate (('*':m):ms) as bs = do
 788    b <- io (cmModuleIsInterpreted cmstate m)
 789    if b then separate cmstate ms (m:as) bs
 790         else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
 791 separate cmstate (m:ms)       as bs = separate cmstate ms as (m:bs)
 792
 793 prel = "Prelude"
 794
 795
 796 addToContext mods = do
 797   cms <- getCmState
 798   (as,bs) <- io (cmGetContext cms)
 799
 800   (as',bs') <- separate cms mods [] []
 801
 802   let as_to_add = as' \\ (as ++ bs)
 803       bs_to_add = bs' \\ (as ++ bs)
 804
 805   cms' <- io (cmSetContext cms
 806                         (as ++ as_to_add) (bs ++ bs_to_add))
 807   setCmState cms'
 808
 809
 810 removeFromContext mods = do
 811   cms <- getCmState
 812   (as,bs) <- io (cmGetContext cms)
 813
 814   (as_to_remove,bs_to_remove) <- separate cms mods [] []
 815
 816   let as' = as \\ (as_to_remove ++ bs_to_remove)
 817       bs' = bs \\ (as_to_remove ++ bs_to_remove)
 818
 819   cms' <- io (cmSetContext cms as' bs')
 820   setCmState cms'
 821
 822 ----------------------------------------------------------------------------
 823 -- Code for `:set'
 824
 825 -- set options in the interpreter.  Syntax is exactly the same as the
 826 -- ghc command line, except that certain options aren't available (-C,
 827 -- -E etc.)
 828 --
 829 -- This is pretty fragile: most options won't work as expected.  ToDo:
 830 -- figure out which ones & disallow them.
 831
 832 setCmd :: String -> GHCi ()
 833 setCmd ""
 834   = do st <- getGHCiState
 835        let opts = options st
 836        io $ putStrLn (showSDoc (
 837               text "options currently set: " <>
 838               if null opts
 839                    then text "none."
 840                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 841            ))
 842 setCmd str
 843   = case words str of
 844         ("args":args) -> setArgs args
 845         ("prog":prog) -> setProg prog
 846         wds -> setOptions wds
 847
 848 setArgs args = do
 849   st <- getGHCiState
 850   setGHCiState st{ args = args }
 851
 852 setProg [prog] = do
 853   st <- getGHCiState
 854   setGHCiState st{ progname = prog }
 855 setProg _ = do
 856   io (hPutStrLn stderr "syntax: :set prog <progname>")
 857
 858 setOptions wds =
 859    do -- first, deal with the GHCi opts (+s, +t, etc.)
 860       let (plus_opts, minus_opts)  = partition isPlus wds
 861       mapM_ setOpt plus_opts
 862
 863       -- now, the GHC flags
 864       pkgs_before <- io (readIORef v_ExplicitPackages)
 865       leftovers   <- io (processArgs static_flags minus_opts [])
 866       pkgs_after  <- io (readIORef v_ExplicitPackages)
 867
 868       -- update things if the users wants more packages
 869       let new_packages = pkgs_after \\ pkgs_before
 870       when (not (null new_packages)) $
 871          newPackages new_packages
 872
 873       -- don't forget about the extra command-line flags from the
 874       -- extra_ghc_opts fields in the new packages
 875       new_package_details <- io (getPackageDetails new_packages)
 876       let pkg_extra_opts = concatMap extra_ghc_opts new_package_details
 877       pkg_extra_dyn <- io (processArgs static_flags pkg_extra_opts [])
 878
 879       -- then, dynamic flags
 880       io $ do
 881         restoreDynFlags
 882         leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) []
 883         saveDynFlags
 884
 885         if (not (null leftovers))
 886                 then throwDyn (CmdLineError ("unrecognised flags: " ++
 887                                                 unwords leftovers))
 888                 else return ()
 889
 890
 891 unsetOptions :: String -> GHCi ()
 892 unsetOptions str
 893   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 894        let opts = words str
 895            (minus_opts, rest1) = partition isMinus opts
 896            (plus_opts, rest2)  = partition isPlus rest1
 897
 898        if (not (null rest2))
 899           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 900           else do
 901
 902        mapM_ unsetOpt plus_opts
 903
 904        -- can't do GHC flags for now
 905        if (not (null minus_opts))
 906           then throwDyn (CmdLineError "can't unset GHC command-line flags")
 907           else return ()
 908
 909 isMinus ('-':s) = True
 910 isMinus _ = False
 911
 912 isPlus ('+':s) = True
 913 isPlus _ = False
 914
 915 setOpt ('+':str)
 916   = case strToGHCiOpt str of
 917         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 918         Just o  -> setOption o
 919
 920 unsetOpt ('+':str)
 921   = case strToGHCiOpt str of
 922         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 923         Just o  -> unsetOption o
 924
 925 strToGHCiOpt :: String -> (Maybe GHCiOption)
 926 strToGHCiOpt "s" = Just ShowTiming
 927 strToGHCiOpt "t" = Just ShowType
 928 strToGHCiOpt "r" = Just RevertCAFs
 929 strToGHCiOpt _   = Nothing
 930
 931 optToStr :: GHCiOption -> String
 932 optToStr ShowTiming = "s"
 933 optToStr ShowType   = "t"
 934 optToStr RevertCAFs = "r"
 935
 936 newPackages new_pkgs = do       -- The new packages are already in v_Packages
 937   state    <- getGHCiState
 938   cmstate1 <- io (cmUnload (cmstate state))
 939   setGHCiState state{ cmstate = cmstate1, targets = [] }
 940   dflags   <- io getDynFlags
 941   io (linkPackages dflags new_pkgs)
 942   setContextAfterLoad []
 943
 944 -- ---------------------------------------------------------------------------
 945 -- code for `:show'
 946
 947 showCmd str =
 948   case words str of
 949         ["modules" ] -> showModules
 950         ["bindings"] -> showBindings
 951         ["linker"]   -> io showLinkerState
 952         _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
 953
 954 showModules = do
 955   cms <- getCmState
 956   let (mg, hpt) = cmGetModInfo cms
 957   mapM_ (showModule hpt) mg
 958
 959
 960 showModule :: HomePackageTable -> ModSummary -> GHCi ()
 961 showModule hpt mod_summary
 962   = case lookupModuleEnv hpt mod of
 963         Nothing       -> panic "missing linkable"
 964         Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
 965                       where
 966                          obj_linkable = isObjectLinkable (hm_linkable mod_info)
 967   where
 968     mod = ms_mod mod_summary
 969     locn = ms_location mod_summary
 970
 971 showBindings = do
 972   cms <- getCmState
 973   let
 974         unqual = cmGetPrintUnqual cms
 975 --      showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
 976         showBinding b = putStrLn (showSDocForUser unqual (ppr (getName b)))
 977
 978   io (mapM_ showBinding (cmGetBindings cms))
 979   return ()
 980
 981
 982 -----------------------------------------------------------------------------
 983 -- GHCi monad
 984
 985 data GHCiState = GHCiState
 986      {
 987         progname       :: String,
 988         args           :: [String],
 989         targets        :: [FilePath],
 990         cmstate        :: CmState,
 991         options        :: [GHCiOption]
 992      }
 993
 994 data GHCiOption
 995         = ShowTiming            -- show time/allocs after evaluation
 996         | ShowType              -- show the type of expressions
 997         | RevertCAFs            -- revert CAFs after every evaluation
 998         deriving Eq
 999
1000 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1001
1002 startGHCi :: GHCi a -> GHCiState -> IO a
1003 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1004
1005 instance Monad GHCi where
1006   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1007   return a  = GHCi $ \s -> return a
1008
1009 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1010 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1011    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1012
1013 getGHCiState   = GHCi $ \r -> readIORef r
1014 setGHCiState s = GHCi $ \r -> writeIORef r s
1015
1016 -- for convenience...
1017 getCmState = getGHCiState >>= return . cmstate
1018 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
1019
1020 isOptionSet :: GHCiOption -> GHCi Bool
1021 isOptionSet opt
1022  = do st <- getGHCiState
1023       return (opt `elem` options st)
1024
1025 setOption :: GHCiOption -> GHCi ()
1026 setOption opt
1027  = do st <- getGHCiState
1028       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1029
1030 unsetOption :: GHCiOption -> GHCi ()
1031 unsetOption opt
1032  = do st <- getGHCiState
1033       setGHCiState (st{ options = filter (/= opt) (options st) })
1034
1035 io :: IO a -> GHCi a
1036 io m = GHCi { unGHCi = \s -> m >>= return }
1037
1038 -----------------------------------------------------------------------------
1039 -- recursive exception handlers
1040
1041 -- Don't forget to unblock async exceptions in the handler, or if we're
1042 -- in an exception loop (eg. let a = error a in a) the ^C exception
1043 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1044
1045 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1046 ghciHandle h (GHCi m) = GHCi $ \s ->
1047    Exception.catch (m s)
1048         (\e -> unGHCi (ghciUnblock (h e)) s)
1049
1050 ghciUnblock :: GHCi a -> GHCi a
1051 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1052
1053 -----------------------------------------------------------------------------
1054 -- timing & statistics
1055
1056 timeIt :: GHCi a -> GHCi a
1057 timeIt action
1058   = do b <- isOptionSet ShowTiming
1059        if not b
1060           then action
1061           else do allocs1 <- io $ getAllocations
1062                   time1   <- io $ getCPUTime
1063                   a <- action
1064                   allocs2 <- io $ getAllocations
1065                   time2   <- io $ getCPUTime
1066                   io $ printTimes (fromIntegral (allocs2 - allocs1))
1067                                   (time2 - time1)
1068                   return a
1069
1070 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1071         -- defined in ghc/rts/Stats.c
1072
1073 printTimes :: Integer -> Integer -> IO ()
1074 printTimes allocs psecs
1075    = do let secs = (fromIntegral psecs / (10^12)) :: Float
1076             secs_str = showFFloat (Just 2) secs
1077         putStrLn (showSDoc (
1078                  parens (text (secs_str "") <+> text "secs" <> comma <+>
1079                          text (show allocs) <+> text "bytes")))
1080
1081 -----------------------------------------------------------------------------
1082 -- reverting CAFs
1083
1084 revertCAFs :: IO ()
1085 revertCAFs = do
1086   rts_revertCAFs
1087   turnOffBuffering
1088         -- Have to turn off buffering again, because we just
1089         -- reverted stdout, stderr & stdin to their defaults.
1090
1091 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
1092         -- Make it "safe", just in case
1093
1094 -- -----------------------------------------------------------------------------
1095 -- Utils
1096
1097 expandPath :: String -> GHCi String
1098 expandPath path =
1099   case dropWhile isSpace path of
1100    ('~':d) -> do
1101         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1102         return (tilde ++ '/':d)
1103    other ->
1104         return other