ghc/compiler/ghci/InteractiveUI.hs

   1 {-# OPTIONS -#include "Linker.h" #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: InteractiveUI.hs,v 1.194 2005/03/18 13:38:31 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(..),
  20                           IfaceConDecl(..), IfaceType,
  21                           pprIfaceDeclHead, pprParendIfaceType,
  22                           pprIfaceForAllPart, pprIfaceType )
  23 import FunDeps          ( pprFundeps )
  24 import Util             ( removeSpaces )
  25 import Linker           ( showLinkerState, linkPackages )
  26 import Util
  27 import Name             ( Name, NamedThing(..) )
  28 import OccName          ( OccName, parenSymOcc, occNameUserString )
  29 import BasicTypes       ( StrictnessMark(..), defaultFixity, SuccessFlag(..) )
  30 import Outputable
  31 import DynFlags ( DynFlags(..), DynFlag(..), dopt )
  32 import Panic            hiding ( showException )
  33 import Config
  34 import SrcLoc           ( SrcLoc, isGoodSrcLoc )
  35
  36 #ifndef mingw32_HOST_OS
  37 import Util             ( 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              ; dflags <- getDynFlags
 501              ; let exts = dopt Opt_GlasgowExts dflags
 502              ; mapM_ (infoThing exts init_cms) names }
 503   where
 504     infoThing exts cms name
 505         = do { stuff <- io (cmGetInfo cms name)
 506              ; io (putStrLn (showSDocForUser (cmGetPrintUnqual cms) $
 507                    vcat (intersperse (text "") (map (showThing exts) stuff)))) }
 508
 509 showThing :: Bool -> GetInfoResult -> SDoc
 510 showThing exts (wanted_str, thing, fixity, src_loc, insts)
 511     = vcat [ showWithLoc src_loc (showDecl exts want_name thing),
 512              show_fixity fixity,
 513              vcat (map show_inst insts)]
 514   where
 515     want_name occ = wanted_str == occNameUserString occ
 516
 517     show_fixity fix
 518         | fix == defaultFixity = empty
 519         | otherwise            = ppr fix <+> text wanted_str
 520
 521     show_inst (inst_ty, loc)
 522         = showWithLoc loc (ptext SLIT("instance") <+> ppr inst_ty)
 523
 524 showWithLoc :: SrcLoc -> SDoc -> SDoc
 525 showWithLoc loc doc
 526     = hang doc 2 (char '\t' <> show_loc loc)
 527                 -- The tab tries to make them line up a bit
 528   where
 529     show_loc loc        -- The ppr function for SrcLocs is a bit wonky
 530         | isGoodSrcLoc loc = comment <+> ptext SLIT("Defined at") <+> ppr loc
 531         | otherwise        = comment <+> ppr loc
 532     comment = ptext SLIT("--")
 533
 534
 535 -- Now there is rather a lot of goop just to print declarations in a
 536 -- civilised way with "..." for the parts we are less interested in.
 537
 538 showDecl :: Bool -> (OccName -> Bool) -> IfaceDecl -> SDoc
 539 showDecl exts want_name (IfaceForeign {ifName = tc})
 540   = ppr tc <+> ptext SLIT("is a foreign type")
 541
 542 showDecl exts want_name (IfaceId {ifName = var, ifType = ty})
 543   = ppr var <+> dcolon <+> showType exts ty
 544
 545 showDecl exts want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty})
 546   = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
 547        2 (equals <+> ppr mono_ty)
 548
 549 showDecl exts want_name (IfaceData {ifName = tycon,
 550                      ifTyVars = tyvars, ifCons = condecls})
 551   = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
 552        2 (add_bars (ppr_trim show_con cs))
 553   where
 554     show_con (IfVanillaCon { ifConOcc = con_name, ifConInfix = is_infix, ifConArgTys = tys,
 555                              ifConStricts = strs, ifConFields = flds})
 556         | want_name tycon || want_name con_name || any want_name flds
 557         = Just (show_guts con_name is_infix tys_w_strs flds)
 558         | otherwise = Nothing
 559         where
 560           tys_w_strs = tys `zip` (strs ++ repeat NotMarkedStrict)
 561     show_con (IfGadtCon { ifConOcc = con_name, ifConTyVars = tvs, ifConCtxt = theta,
 562                           ifConArgTys = arg_tys, ifConResTys = res_tys, ifConStricts = strs })
 563         | want_name tycon || want_name con_name
 564         = Just (ppr_bndr con_name <+> colon <+> pprIfaceForAllPart tvs theta pp_tau)
 565         | otherwise = Nothing
 566         where
 567           tys_w_strs = arg_tys `zip` (strs ++ repeat NotMarkedStrict)
 568           pp_tau = foldr add pp_res_ty tys_w_strs
 569           pp_res_ty = ppr_bndr tycon <+> hsep (map pprParendIfaceType res_tys)
 570           add bty pp_ty = ppr_bangty bty <+> arrow <+> pp_ty
 571
 572     show_guts con True [ty1, ty2] flds = sep [ppr_bangty ty1, ppr con, ppr_bangty ty2]
 573     show_guts con _ tys []   = ppr_bndr con <+> sep (map ppr_bangty tys)
 574     show_guts con _ tys flds
 575         = ppr_bndr con <+> braces (sep (punctuate comma (ppr_trim show_fld (tys `zip` flds))))
 576         where
 577           show_fld (bty, fld) | want_name tycon || want_name con || want_name fld
 578                               = Just (ppr_bndr fld <+> dcolon <+> ppr_bangty bty)
 579                               | otherwise = Nothing
 580
 581     (pp_nd, context, cs) = case condecls of
 582                     IfAbstractTyCon           -> (ptext SLIT("data"), [],   [])
 583                     IfDataTyCon (Just cxt) cs -> (ptext SLIT("data"), cxt, cs)
 584                     IfDataTyCon Nothing cs    -> (ptext SLIT("data"), [],  cs)
 585                     IfNewTyCon c              -> (ptext SLIT("newtype"), [], [c])
 586
 587     add_bars []      = empty
 588     add_bars [c]     = equals <+> c
 589     add_bars (c:cs)  = equals <+> sep (c : map (char '|' <+>) cs)
 590
 591     ppr_bangty (ty, str) = ppr_str str <> pprParendIfaceType ty
 592     ppr_str MarkedStrict    = char '!'
 593     ppr_str MarkedUnboxed   = ptext SLIT("!!")
 594     ppr_str NotMarkedStrict = empty
 595
 596 showDecl exts want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
 597                       ifFDs = fds, ifSigs = sigs})
 598   = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars
 599                 <+> pprFundeps fds <+> opt_where)
 600        2 (vcat (ppr_trim show_op sigs))
 601   where
 602     opt_where | null sigs = empty
 603               | otherwise = ptext SLIT("where")
 604     show_op (IfaceClassOp op dm ty)
 605         | want_name clas || want_name op
 606         = Just (ppr_bndr op <+> dcolon <+> showType exts ty)
 607         | otherwise
 608         = Nothing
 609
 610 showType :: Bool -> IfaceType -> SDoc
 611 showType True  ty = pprIfaceType ty -- -fglasgow-exts: print with the foralls
 612 showType False ty = ppr ty          -- otherwise, print without the foralls
 613
 614 ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc]
 615 ppr_trim show xs
 616   = snd (foldr go (False, []) xs)
 617   where
 618     go x (eliding, so_far)
 619         | Just doc <- show x = (False, doc : so_far)
 620         | otherwise = if eliding then (True, so_far)
 621                                  else (True, ptext SLIT("...") : so_far)
 622
 623 ppr_bndr :: OccName -> SDoc
 624 -- Wrap operators in ()
 625 ppr_bndr occ = parenSymOcc occ (ppr occ)
 626
 627
 628 -----------------------------------------------------------------------------
 629 -- Commands
 630
 631 addModule :: [FilePath] -> GHCi ()
 632 addModule files = do
 633   state <- getGHCiState
 634   io (revertCAFs)                       -- always revert CAFs on load/add.
 635   files <- mapM expandPath files
 636   let new_targets = files ++ targets state
 637   graph <- io (cmDepAnal (cmstate state) new_targets)
 638   (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) graph)
 639   setGHCiState state{ cmstate = cmstate1, targets = new_targets }
 640   setContextAfterLoad mods
 641   dflags <- getDynFlags
 642   modulesLoadedMsg ok mods dflags
 643
 644 changeDirectory :: String -> GHCi ()
 645 changeDirectory dir = do
 646   state    <- getGHCiState
 647   when (targets state /= []) $
 648         io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
 649   cmstate1 <- io (cmUnload (cmstate state))
 650   setGHCiState state{ cmstate = cmstate1, targets = [] }
 651   setContextAfterLoad []
 652   dir <- expandPath dir
 653   io (setCurrentDirectory dir)
 654
 655 defineMacro :: String -> GHCi ()
 656 defineMacro s = do
 657   let (macro_name, definition) = break isSpace s
 658   cmds <- io (readIORef commands)
 659   if (null macro_name)
 660         then throwDyn (CmdLineError "invalid macro name")
 661         else do
 662   if (macro_name `elem` map fst cmds)
 663         then throwDyn (CmdLineError
 664                 ("command '" ++ macro_name ++ "' is already defined"))
 665         else do
 666
 667   -- give the expression a type signature, so we can be sure we're getting
 668   -- something of the right type.
 669   let new_expr = '(' : definition ++ ") :: String -> IO String"
 670
 671   -- compile the expression
 672   cms <- getCmState
 673   maybe_hv <- io (cmCompileExpr cms new_expr)
 674   case maybe_hv of
 675      Nothing -> return ()
 676      Just hv -> io (writeIORef commands --
 677                     ((macro_name, keepGoing (runMacro hv)) : cmds))
 678
 679 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
 680 runMacro fun s = do
 681   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 682   stringLoop (lines str)
 683
 684 undefineMacro :: String -> GHCi ()
 685 undefineMacro macro_name = do
 686   cmds <- io (readIORef commands)
 687   if (macro_name `elem` map fst builtin_commands)
 688         then throwDyn (CmdLineError
 689                 ("command '" ++ macro_name ++ "' cannot be undefined"))
 690         else do
 691   if (macro_name `notElem` map fst cmds)
 692         then throwDyn (CmdLineError
 693                 ("command '" ++ macro_name ++ "' not defined"))
 694         else do
 695   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
 696
 697
 698 loadModule :: [FilePath] -> GHCi ()
 699 loadModule fs = timeIt (loadModule' fs)
 700
 701 loadModule' :: [FilePath] -> GHCi ()
 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
 724
 725 reloadModule :: String -> GHCi ()
 726 reloadModule "" = do
 727   state <- getGHCiState
 728   case targets state of
 729    [] -> io (putStr "no current target\n")
 730    paths -> do
 731         -- do the dependency anal first, so that if it fails we don't throw
 732         -- away the current set of modules.
 733         graph <- io (cmDepAnal (cmstate state) paths)
 734
 735         io (revertCAFs)         -- always revert CAFs on reload.
 736         (cmstate1, ok, mods)
 737                 <- io (cmLoadModules (cmstate state) graph)
 738         setGHCiState state{ cmstate=cmstate1 }
 739         setContextAfterLoad mods
 740         dflags <- getDynFlags
 741         modulesLoadedMsg ok mods dflags
 742
 743 reloadModule _ = noArgs ":reload"
 744
 745 setContextAfterLoad [] = setContext prel
 746 setContextAfterLoad (m:_) = do
 747   cmstate <- getCmState
 748   b <- io (cmModuleIsInterpreted cmstate m)
 749   if b then setContext ('*':m) else setContext m
 750
 751 modulesLoadedMsg ok mods dflags =
 752   when (verbosity dflags > 0) $ do
 753    let mod_commas
 754         | null mods = text "none."
 755         | otherwise = hsep (
 756             punctuate comma (map text mods)) <> text "."
 757    case ok of
 758     Failed ->
 759        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 760     Succeeded  ->
 761        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 762
 763
 764 typeOfExpr :: String -> GHCi ()
 765 typeOfExpr str
 766   = do cms <- getCmState
 767        maybe_tystr <- io (cmTypeOfExpr cms str)
 768        case maybe_tystr of
 769           Nothing    -> return ()
 770           Just tystr -> io (putStrLn tystr)
 771
 772 kindOfType :: String -> GHCi ()
 773 kindOfType str
 774   = do cms <- getCmState
 775        maybe_tystr <- io (cmKindOfType cms str)
 776        case maybe_tystr of
 777           Nothing    -> return ()
 778           Just tystr -> io (putStrLn tystr)
 779
 780 quit :: String -> GHCi Bool
 781 quit _ = return True
 782
 783 shellEscape :: String -> GHCi Bool
 784 shellEscape str = io (system str >> return False)
 785
 786 -----------------------------------------------------------------------------
 787 -- Browsing a module's contents
 788
 789 browseCmd :: String -> GHCi ()
 790 browseCmd m =
 791   case words m of
 792     ['*':m] | looksLikeModuleName m -> browseModule m False
 793     [m]     | looksLikeModuleName m -> browseModule m True
 794     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
 795
 796 browseModule m exports_only = do
 797   cms <- getCmState
 798
 799   is_interpreted <- io (cmModuleIsInterpreted cms m)
 800   when (not is_interpreted && not exports_only) $
 801         throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
 802
 803   -- Temporarily set the context to the module we're interested in,
 804   -- just so we can get an appropriate PrintUnqualified
 805   (as,bs) <- io (cmGetContext cms)
 806   cms1 <- io (if exports_only then cmSetContext cms [] [prel,m]
 807                               else cmSetContext cms [m] [])
 808   cms2 <- io (cmSetContext cms1 as bs)
 809
 810   things <- io (cmBrowseModule cms2 m exports_only)
 811
 812   let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
 813
 814   dflags <- getDynFlags
 815   let exts = dopt Opt_GlasgowExts dflags
 816   io (putStrLn (showSDocForUser unqual (
 817          vcat (map (showDecl exts (const True)) things)
 818       )))
 819
 820 -----------------------------------------------------------------------------
 821 -- Setting the module context
 822
 823 setContext str
 824   | all sensible mods = fn mods
 825   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
 826   where
 827     (fn, mods) = case str of
 828                         '+':stuff -> (addToContext,      words stuff)
 829                         '-':stuff -> (removeFromContext, words stuff)
 830                         stuff     -> (newContext,        words stuff)
 831
 832     sensible ('*':m) = looksLikeModuleName m
 833     sensible m       = looksLikeModuleName m
 834
 835 newContext mods = do
 836   cms <- getCmState
 837   (as,bs) <- separate cms mods [] []
 838   let bs' = if null as && prel `notElem` bs then prel:bs else bs
 839   cms' <- io (cmSetContext cms as bs')
 840   setCmState cms'
 841
 842 separate cmstate []           as bs = return (as,bs)
 843 separate cmstate (('*':m):ms) as bs = do
 844    b <- io (cmModuleIsInterpreted cmstate m)
 845    if b then separate cmstate ms (m:as) bs
 846         else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
 847 separate cmstate (m:ms)       as bs = separate cmstate ms as (m:bs)
 848
 849 prel = "Prelude"
 850
 851
 852 addToContext mods = do
 853   cms <- getCmState
 854   (as,bs) <- io (cmGetContext cms)
 855
 856   (as',bs') <- separate cms mods [] []
 857
 858   let as_to_add = as' \\ (as ++ bs)
 859       bs_to_add = bs' \\ (as ++ bs)
 860
 861   cms' <- io (cmSetContext cms
 862                         (as ++ as_to_add) (bs ++ bs_to_add))
 863   setCmState cms'
 864
 865
 866 removeFromContext mods = do
 867   cms <- getCmState
 868   (as,bs) <- io (cmGetContext cms)
 869
 870   (as_to_remove,bs_to_remove) <- separate cms mods [] []
 871
 872   let as' = as \\ (as_to_remove ++ bs_to_remove)
 873       bs' = bs \\ (as_to_remove ++ bs_to_remove)
 874
 875   cms' <- io (cmSetContext cms as' bs')
 876   setCmState cms'
 877
 878 ----------------------------------------------------------------------------
 879 -- Code for `:set'
 880
 881 -- set options in the interpreter.  Syntax is exactly the same as the
 882 -- ghc command line, except that certain options aren't available (-C,
 883 -- -E etc.)
 884 --
 885 -- This is pretty fragile: most options won't work as expected.  ToDo:
 886 -- figure out which ones & disallow them.
 887
 888 setCmd :: String -> GHCi ()
 889 setCmd ""
 890   = do st <- getGHCiState
 891        let opts = options st
 892        io $ putStrLn (showSDoc (
 893               text "options currently set: " <>
 894               if null opts
 895                    then text "none."
 896                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 897            ))
 898 setCmd str
 899   = case words str of
 900         ("args":args) -> setArgs args
 901         ("prog":prog) -> setProg prog
 902         wds -> setOptions wds
 903
 904 setArgs args = do
 905   st <- getGHCiState
 906   setGHCiState st{ args = args }
 907
 908 setProg [prog] = do
 909   st <- getGHCiState
 910   setGHCiState st{ progname = prog }
 911 setProg _ = do
 912   io (hPutStrLn stderr "syntax: :set prog <progname>")
 913
 914 setOptions wds =
 915    do -- first, deal with the GHCi opts (+s, +t, etc.)
 916       let (plus_opts, minus_opts)  = partition isPlus wds
 917       mapM_ setOpt plus_opts
 918
 919       -- now, the GHC flags
 920       leftovers <- io $ processStaticFlags minus_opts
 921
 922       -- then, dynamic flags
 923       dflags <- getDynFlags
 924       (dflags',leftovers) <- io $ processDynamicFlags leftovers dflags
 925       setDynFlags dflags'
 926
 927         -- update things if the users wants more packages
 928 {- TODO:
 929         let new_packages = pkgs_after \\ pkgs_before
 930         when (not (null new_packages)) $
 931            newPackages new_packages
 932 -}
 933
 934       if (not (null leftovers))
 935                 then throwDyn (CmdLineError ("unrecognised flags: " ++
 936                                                 unwords leftovers))
 937                 else return ()
 938
 939
 940 unsetOptions :: String -> GHCi ()
 941 unsetOptions str
 942   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 943        let opts = words str
 944            (minus_opts, rest1) = partition isMinus opts
 945            (plus_opts, rest2)  = partition isPlus rest1
 946
 947        if (not (null rest2))
 948           then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
 949           else do
 950
 951        mapM_ unsetOpt plus_opts
 952
 953        -- can't do GHC flags for now
 954        if (not (null minus_opts))
 955           then throwDyn (CmdLineError "can't unset GHC command-line flags")
 956           else return ()
 957
 958 isMinus ('-':s) = True
 959 isMinus _ = False
 960
 961 isPlus ('+':s) = True
 962 isPlus _ = False
 963
 964 setOpt ('+':str)
 965   = case strToGHCiOpt str of
 966         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
 967         Just o  -> setOption o
 968
 969 unsetOpt ('+':str)
 970   = case strToGHCiOpt str of
 971         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
 972         Just o  -> unsetOption o
 973
 974 strToGHCiOpt :: String -> (Maybe GHCiOption)
 975 strToGHCiOpt "s" = Just ShowTiming
 976 strToGHCiOpt "t" = Just ShowType
 977 strToGHCiOpt "r" = Just RevertCAFs
 978 strToGHCiOpt _   = Nothing
 979
 980 optToStr :: GHCiOption -> String
 981 optToStr ShowTiming = "s"
 982 optToStr ShowType   = "t"
 983 optToStr RevertCAFs = "r"
 984
 985 newPackages new_pkgs = do       -- The new packages are already in v_Packages
 986   state    <- getGHCiState
 987   cmstate1 <- io (cmUnload (cmstate state))
 988   setGHCiState state{ cmstate = cmstate1, targets = [] }
 989   dflags   <- getDynFlags
 990   io (linkPackages dflags new_pkgs)
 991   setContextAfterLoad []
 992
 993 -- ---------------------------------------------------------------------------
 994 -- code for `:show'
 995
 996 showCmd str =
 997   case words str of
 998         ["modules" ] -> showModules
 999         ["bindings"] -> showBindings
1000         ["linker"]   -> io showLinkerState
1001         _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
1002
1003 showModules
1004   = do  { cms <- getCmState
1005         ; let show_one ms = io (putStrLn (cmShowModule cms ms))
1006         ; mapM_ show_one (cmGetModuleGraph cms) }
1007
1008 showBindings = do
1009   cms <- getCmState
1010   let
1011         unqual = cmGetPrintUnqual cms
1012 --      showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
1013         showBinding b = putStrLn (showSDocForUser unqual (ppr (getName b)))
1014
1015   io (mapM_ showBinding (cmGetBindings cms))
1016   return ()
1017
1018
1019 -----------------------------------------------------------------------------
1020 -- GHCi monad
1021
1022 data GHCiState = GHCiState
1023      {
1024         progname       :: String,
1025         args           :: [String],
1026         targets        :: [FilePath],
1027         cmstate        :: CmState,
1028         options        :: [GHCiOption]
1029      }
1030
1031 data GHCiOption
1032         = ShowTiming            -- show time/allocs after evaluation
1033         | ShowType              -- show the type of expressions
1034         | RevertCAFs            -- revert CAFs after every evaluation
1035         deriving Eq
1036
1037 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1038
1039 startGHCi :: GHCi a -> GHCiState -> IO a
1040 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1041
1042 instance Monad GHCi where
1043   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1044   return a  = GHCi $ \s -> return a
1045
1046 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1047 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1048    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1049
1050 getGHCiState   = GHCi $ \r -> readIORef r
1051 setGHCiState s = GHCi $ \r -> writeIORef r s
1052
1053 -- for convenience...
1054 getCmState = getGHCiState >>= return . cmstate
1055 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
1056
1057 getDynFlags = getCmState >>= return . cmGetDFlags
1058
1059 setDynFlags dflags = do s <- getCmState; setCmState (cmSetDFlags s dflags)
1060
1061 isOptionSet :: GHCiOption -> GHCi Bool
1062 isOptionSet opt
1063  = do st <- getGHCiState
1064       return (opt `elem` options st)
1065
1066 setOption :: GHCiOption -> GHCi ()
1067 setOption opt
1068  = do st <- getGHCiState
1069       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1070
1071 unsetOption :: GHCiOption -> GHCi ()
1072 unsetOption opt
1073  = do st <- getGHCiState
1074       setGHCiState (st{ options = filter (/= opt) (options st) })
1075
1076 io :: IO a -> GHCi a
1077 io m = GHCi { unGHCi = \s -> m >>= return }
1078
1079 -----------------------------------------------------------------------------
1080 -- recursive exception handlers
1081
1082 -- Don't forget to unblock async exceptions in the handler, or if we're
1083 -- in an exception loop (eg. let a = error a in a) the ^C exception
1084 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1085
1086 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1087 ghciHandle h (GHCi m) = GHCi $ \s ->
1088    Exception.catch (m s)
1089         (\e -> unGHCi (ghciUnblock (h e)) s)
1090
1091 ghciUnblock :: GHCi a -> GHCi a
1092 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1093
1094 -----------------------------------------------------------------------------
1095 -- timing & statistics
1096
1097 timeIt :: GHCi a -> GHCi a
1098 timeIt action
1099   = do b <- isOptionSet ShowTiming
1100        if not b
1101           then action
1102           else do allocs1 <- io $ getAllocations
1103                   time1   <- io $ getCPUTime
1104                   a <- action
1105                   allocs2 <- io $ getAllocations
1106                   time2   <- io $ getCPUTime
1107                   io $ printTimes (fromIntegral (allocs2 - allocs1))
1108                                   (time2 - time1)
1109                   return a
1110
1111 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1112         -- defined in ghc/rts/Stats.c
1113
1114 printTimes :: Integer -> Integer -> IO ()
1115 printTimes allocs psecs
1116    = do let secs = (fromIntegral psecs / (10^12)) :: Float
1117             secs_str = showFFloat (Just 2) secs
1118         putStrLn (showSDoc (
1119                  parens (text (secs_str "") <+> text "secs" <> comma <+>
1120                          text (show allocs) <+> text "bytes")))
1121
1122 -----------------------------------------------------------------------------
1123 -- reverting CAFs
1124
1125 revertCAFs :: IO ()
1126 revertCAFs = do
1127   rts_revertCAFs
1128   turnOffBuffering
1129         -- Have to turn off buffering again, because we just
1130         -- reverted stdout, stderr & stdin to their defaults.
1131
1132 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
1133         -- Make it "safe", just in case
1134
1135 -- -----------------------------------------------------------------------------
1136 -- Utils
1137
1138 expandPath :: String -> GHCi String
1139 expandPath path =
1140   case dropWhile isSpace path of
1141    ('~':d) -> do
1142         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1143         return (tilde ++ '/':d)
1144    other ->
1145         return other