ghc/compiler/ghci/InteractiveUI.hs

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