ghc/compiler/ghci/InteractiveUI.hs

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