ghc/compiler/ghci/InteractiveUI.hs

   1 {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: InteractiveUI.hs,v 1.107 2002/01/22 13:04:13 simonmar Exp $
   4 --
   5 -- GHC Interactive User Interface
   6 --
   7 -- (c) The GHC Team 2000
   8 --
   9 -----------------------------------------------------------------------------
  10 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
  11
  12 #include "../includes/config.h"
  13 #include "HsVersions.h"
  14
  15 import Packages
  16 import CompManager
  17 import HscTypes         ( TyThing(..) )
  18 import MkIface          ( ifaceTyThing )
  19 import DriverFlags
  20 import DriverState
  21 import DriverUtil       ( handle, remove_spaces )
  22 import Linker
  23 import Finder           ( flushPackageCache )
  24 import Util
  25 import Id               ( isRecordSelector, recordSelectorFieldLabel,
  26                           isDataConWrapId, idName )
  27 import Class            ( className )
  28 import TyCon            ( tyConName, tyConClass_maybe, isPrimTyCon )
  29 import FieldLabel       ( fieldLabelTyCon )
  30 import SrcLoc           ( isGoodSrcLoc )
  31 import Name             ( Name, isHomePackageName, nameSrcLoc, nameOccName,
  32                           NamedThing(..) )
  33 import OccName          ( isSymOcc )
  34 import BasicTypes       ( defaultFixity )
  35 import Outputable
  36 import CmdLineOpts      ( DynFlag(..), getDynFlags, saveDynFlags, restoreDynFlags,
  37                           dopt_unset )
  38 import Panic            ( GhcException(..), showGhcException )
  39 import Config
  40
  41 #ifndef mingw32_TARGET_OS
  42 import Posix
  43 #endif
  44
  45 import Exception
  46 import Dynamic
  47 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
  48 import Readline
  49 #endif
  50 import Concurrent
  51 import IOExts
  52 import SystemExts
  53
  54 import Numeric
  55 import List
  56 import System
  57 import CPUTime
  58 import Directory
  59 import IO
  60 import Char
  61 import Monad            ( when, join )
  62
  63 import PrelGHC          ( unsafeCoerce# )
  64 import Foreign          ( nullPtr )
  65 import CString          ( peekCString )
  66
  67 -----------------------------------------------------------------------------
  68
  69 ghciWelcomeMsg = "\
  70 \   ___         ___ _\n\
  71 \  / _ \\ /\\  /\\/ __(_)\n\
  72 \ / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
  73 \/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n\
  74 \\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
  75
  76 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
  77
  78 builtin_commands :: [(String, String -> GHCi Bool)]
  79 builtin_commands = [
  80   ("add",       keepGoing addModule),
  81   ("cd",        keepGoing changeDirectory),
  82   ("def",       keepGoing defineMacro),
  83   ("help",      keepGoing help),
  84   ("?",         keepGoing help),
  85   ("info",      keepGoing info),
  86   ("import",    keepGoing importModules),
  87   ("load",      keepGoing loadModule),
  88   ("module",    keepGoing setContext),
  89   ("reload",    keepGoing reloadModule),
  90   ("set",       keepGoing setCmd),
  91   ("type",      keepGoing typeOfExpr),
  92   ("unset",     keepGoing unsetOptions),
  93   ("undef",     keepGoing undefineMacro),
  94   ("quit",      quit)
  95   ]
  96
  97 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
  98 keepGoing a str = a str >> return False
  99
 100 shortHelpText = "use :? for help.\n"
 101
 102 helpText = "\
 103 \ Commands available from the prompt:\n\
 104 \\
 105 \   <stmt>                 evaluate/run <stmt>\n\
 106 \   :add <filename> ...    add module(s) to the current target set\n\
 107 \   :cd <dir>              change directory to <dir>\n\
 108 \   :def <cmd> <expr>      define a command :<cmd>\n\
 109 \   :help, :?              display this list of commands\n\
 110 \   :info [<name> ...]     display information about the given names\n\
 111 \   :load <filename> ...   load module(s) and their dependents\n\
 112 \   :module <mod>          set the context for expression evaluation to <mod>\n\
 113 \   :reload                reload the current module set\n\
 114 \   :set <option> ...      set options\n\
 115 \   :set args <arg> ...    set the arguments returned by System.getArgs\n\
 116 \   :set prog <progname>   set the value returned by System.getProgName\n\
 117 \   :undef <cmd>           undefine user-defined command :<cmd>\n\
 118 \   :type <expr>           show the type of <expr>\n\
 119 \   :unset <option> ...    unset options\n\
 120 \   :quit                  exit GHCi\n\
 121 \   :!<command>            run the shell command <command>\n\
 122 \\
 123 \ Options for `:set' and `:unset':\n\
 124 \\
 125 \    +r                 revert top-level expressions after each evaluation\n\
 126 \    +s                 print timing/memory stats after each evaluation\n\
 127 \    +t                 print type after evaluation\n\
 128 \    -<flags>           most GHC command line flags can also be set here\n\
 129 \                         (eg. -v2, -fglasgow-exts, etc.)\n\
 130 \"
 131
 132 interactiveUI :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
 133 interactiveUI cmstate paths cmdline_libs = do
 134    hFlush stdout
 135    hSetBuffering stdout NoBuffering
 136
 137    -- link in the available packages
 138    pkgs <- getPackageInfo
 139    initLinker
 140    linkPackages cmdline_libs pkgs
 141
 142    dflags <- getDynFlags
 143
 144    (cmstate, maybe_hval)
 145         <- cmCompileExpr cmstate dflags "IO.hSetBuffering IO.stdout IO.NoBuffering Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
 146    case maybe_hval of
 147         Just hval -> unsafeCoerce# hval :: IO ()
 148         _ -> panic "interactiveUI:buffering"
 149
 150    (cmstate, maybe_hval)
 151         <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stderr"
 152    case maybe_hval of
 153         Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
 154         _ -> panic "interactiveUI:stderr"
 155
 156    (cmstate, maybe_hval)
 157         <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stdout"
 158    case maybe_hval of
 159         Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
 160         _ -> panic "interactiveUI:stdout"
 161
 162         -- initial context is just the Prelude
 163    cmstate <- cmSetContext cmstate dflags [] ["Prelude"]
 164
 165 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 166    Readline.initialize
 167 #endif
 168
 169    startGHCi (runGHCi paths)
 170         GHCiState{ progname = "<interactive>",
 171                    args = [],
 172                    targets = paths,
 173                    cmstate = cmstate,
 174                    options = [] }
 175
 176 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 177    Readline.resetTerminal Nothing
 178 #endif
 179
 180    return ()
 181
 182
 183 runGHCi :: [FilePath] -> GHCi ()
 184 runGHCi paths = do
 185   read_dot_files <- io (readIORef v_Read_DotGHCi)
 186
 187   when (read_dot_files) $ do
 188     -- Read in ./.ghci.
 189     let file = "./.ghci"
 190     exists <- io (doesFileExist file)
 191     when exists $ do
 192        dir_ok  <- io (checkPerms ".")
 193        file_ok <- io (checkPerms file)
 194        when (dir_ok && file_ok) $ do
 195           either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
 196           case either_hdl of
 197              Left e    -> return ()
 198              Right hdl -> fileLoop hdl False
 199
 200   when (read_dot_files) $ do
 201     -- Read in $HOME/.ghci
 202     either_dir <- io (IO.try (getEnv "HOME"))
 203     case either_dir of
 204        Left e -> return ()
 205        Right dir -> do
 206           cwd <- io (getCurrentDirectory)
 207           when (dir /= cwd) $ do
 208              let file = dir ++ "/.ghci"
 209              ok <- io (checkPerms file)
 210              when ok $ do
 211                either_hdl <- io (IO.try (openFile file ReadMode))
 212                case either_hdl of
 213                   Left e    -> return ()
 214                   Right hdl -> fileLoop hdl False
 215
 216   -- perform a :load for files given on the GHCi command line
 217   when (not (null paths)) $
 218      ghciHandle showException $
 219         loadModule (unwords paths)
 220
 221   -- enter the interactive loop
 222   interactiveLoop
 223
 224   -- and finally, exit
 225   io $ do putStrLn "Leaving GHCi."
 226
 227
 228 interactiveLoop = do
 229   -- ignore ^C exceptions caught here
 230   ghciHandleDyn (\e -> case e of Interrupted -> ghciUnblock interactiveLoop
 231                                  _other      -> return ()) $ do
 232
 233   -- read commands from stdin
 234 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 235   readlineLoop
 236 #else
 237   fileLoop stdin True
 238 #endif
 239
 240
 241 -- NOTE: We only read .ghci files if they are owned by the current user,
 242 -- and aren't world writable.  Otherwise, we could be accidentally
 243 -- running code planted by a malicious third party.
 244
 245 -- Furthermore, We only read ./.ghci if . is owned by the current user
 246 -- and isn't writable by anyone else.  I think this is sufficient: we
 247 -- don't need to check .. and ../.. etc. because "."  always refers to
 248 -- the same directory while a process is running.
 249
 250 checkPerms :: String -> IO Bool
 251 checkPerms name =
 252   handle (\_ -> return False) $ do
 253 #ifdef mingw32_TARGET_OS
 254      doesFileExist name
 255 #else
 256      st <- getFileStatus name
 257      me <- getRealUserID
 258      if fileOwner st /= me then do
 259         putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
 260         return False
 261       else do
 262         let mode =  fileMode st
 263         if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
 264            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
 265            then do
 266                putStrLn $ "*** WARNING: " ++ name ++
 267                           " is writable by someone else, IGNORING!"
 268                return False
 269           else return True
 270 #endif
 271
 272 fileLoop :: Handle -> Bool -> GHCi ()
 273 fileLoop hdl prompt = do
 274    st <- getGHCiState
 275    (mod,imports) <- io (cmGetContext (cmstate st))
 276    when prompt (io (putStr (mkPrompt mod imports)))
 277    l <- io (IO.try (hGetLine hdl))
 278    case l of
 279         Left e | isEOFError e -> return ()
 280                | otherwise    -> throw e
 281         Right l ->
 282           case remove_spaces l of
 283             "" -> fileLoop hdl prompt
 284             l  -> do quit <- runCommand l
 285                      if quit then return () else fileLoop hdl prompt
 286
 287 stringLoop :: [String] -> GHCi ()
 288 stringLoop [] = return ()
 289 stringLoop (s:ss) = do
 290    st <- getGHCiState
 291    case remove_spaces s of
 292         "" -> stringLoop ss
 293         l  -> do quit <- runCommand l
 294                  if quit then return () else stringLoop ss
 295
 296 mkPrompt toplevs exports
 297    =  concat (intersperse "," toplevs)
 298    ++ (if not (null exports)
 299         then "[" ++ concat (intersperse "," exports) ++ "]"
 300         else "")
 301    ++ "> "
 302
 303 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 304 readlineLoop :: GHCi ()
 305 readlineLoop = do
 306    st <- getGHCiState
 307    (mod,imports) <- io (cmGetContext (cmstate st))
 308    io yield
 309    l <- io (readline (mkPrompt mod imports))
 310    case l of
 311         Nothing -> return ()
 312         Just l  ->
 313           case remove_spaces l of
 314             "" -> readlineLoop
 315             l  -> do
 316                   io (addHistory l)
 317                   quit <- runCommand l
 318                   if quit then return () else readlineLoop
 319 #endif
 320
 321 -- Top level exception handler, just prints out the exception
 322 -- and carries on.
 323 runCommand :: String -> GHCi Bool
 324 runCommand c =
 325   ghciHandle ( \exception -> do
 326                 flushEverything
 327                 showException exception
 328                 return False
 329              ) $
 330   doCommand c
 331
 332 showException (DynException dyn) =
 333   case fromDynamic dyn of
 334     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
 335     Just Interrupted      -> io (putStrLn "Interrupted.")
 336     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
 337     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
 338     Just other_ghc_ex     -> io (print other_ghc_ex)
 339
 340 showException other_exception
 341   = io (putStrLn ("*** Exception: " ++ show other_exception))
 342
 343 doCommand (':' : command) = specialCommand command
 344 doCommand stmt
 345    = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
 346         return False
 347
 348 runStmt :: String -> GHCi [Name]
 349 runStmt stmt
 350  | null (filter (not.isSpace) stmt) = return []
 351  | otherwise
 352  = do st <- getGHCiState
 353       dflags <- io getDynFlags
 354       let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
 355       (new_cmstate, result) <-
 356         io $ withProgName (progname st) $ withArgs (args st) $
 357         cmRunStmt (cmstate st) dflags' stmt
 358       setGHCiState st{cmstate = new_cmstate}
 359       case result of
 360         CmRunFailed      -> return []
 361         CmRunException e -> showException e >> return []
 362         CmRunDeadlocked  -> io (putStrLn "Deadlocked.") >> return []
 363         CmRunOk names    -> return names
 364
 365 -- possibly print the type and revert CAFs after evaluating an expression
 366 finishEvalExpr names
 367  = do b <- isOptionSet ShowType
 368       st <- getGHCiState
 369       when b (mapM_ (showTypeOfName (cmstate st)) names)
 370
 371       b <- isOptionSet RevertCAFs
 372       io (when b revertCAFs)
 373       flushEverything
 374       return True
 375
 376 showTypeOfName :: CmState -> Name -> GHCi ()
 377 showTypeOfName cmstate n
 378    = do maybe_str <- io (cmTypeOfName cmstate n)
 379         case maybe_str of
 380           Nothing  -> return ()
 381           Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
 382
 383 flushEverything :: GHCi ()
 384 flushEverything
 385    = io $ do Monad.join (readIORef flush_stdout)
 386              Monad.join (readIORef flush_stderr)
 387              return ()
 388
 389 specialCommand :: String -> GHCi Bool
 390 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 391 specialCommand str = do
 392   let (cmd,rest) = break isSpace str
 393   cmds <- io (readIORef commands)
 394   case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
 395      []      -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
 396                                     ++ shortHelpText) >> return False)
 397      [(_,f)] -> f (dropWhile isSpace rest)
 398      cs      -> io (hPutStrLn stdout ("prefix " ++ cmd ++
 399                                       " matches multiple commands (" ++
 400                                        foldr1 (\a b -> a ++ ',':b) (map fst cs)
 401                                          ++ ")") >> return False)
 402
 403 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
 404
 405 -----------------------------------------------------------------------------
 406 -- Commands
 407
 408 help :: String -> GHCi ()
 409 help _ = io (putStr helpText)
 410
 411 info :: String -> GHCi ()
 412 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
 413 info s = do
 414   let names = words s
 415   state <- getGHCiState
 416   dflags <- io getDynFlags
 417   let
 418     infoThings cms [] = return cms
 419     infoThings cms (name:names) = do
 420       (cms, unqual, stuff) <- io (cmInfoThing cms dflags name)
 421       io (putStrLn (showSDocForUser unqual (
 422             vcat (intersperse (text "") (map showThing stuff))))
 423          )
 424       infoThings cms names
 425
 426     showThing (ty_thing, fixity)
 427         = vcat [ text "-- " <> showTyThing ty_thing,
 428                  showFixity fixity (getName ty_thing),
 429                  ppr (ifaceTyThing ty_thing) ]
 430
 431     showFixity fix name
 432         | fix == defaultFixity = empty
 433         | otherwise            = ppr fix <+>
 434                                  (if isSymOcc (nameOccName name)
 435                                         then ppr name
 436                                         else char '`' <> ppr name <> char '`')
 437
 438     showTyThing (AClass cl)
 439        = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
 440     showTyThing (ATyCon ty)
 441        | isPrimTyCon ty
 442        = hcat [ppr ty, text " is a primitive type constructor"]
 443        | otherwise
 444        = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
 445     showTyThing (AnId   id)
 446        = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
 447
 448     idDescr id
 449        | isRecordSelector id =
 450                 case tyConClass_maybe (fieldLabelTyCon (
 451                                 recordSelectorFieldLabel id)) of
 452                         Nothing -> text "record selector"
 453                         Just c  -> text "method in class " <> ppr c
 454        | isDataConWrapId id  = text "data constructor"
 455        | otherwise           = text "variable"
 456
 457         -- also print out the source location for home things
 458     showSrcLoc name
 459         | isHomePackageName name && isGoodSrcLoc loc
 460         = hsep [ text ", defined at", ppr loc ]
 461         | otherwise
 462         = empty
 463         where loc = nameSrcLoc name
 464
 465   cms <- infoThings (cmstate state) names
 466   setGHCiState state{ cmstate = cms }
 467   return ()
 468
 469 addModule :: String -> GHCi ()
 470 addModule str = do
 471   let files = words str
 472   state <- getGHCiState
 473   dflags <- io (getDynFlags)
 474   io (revertCAFs)                       -- always revert CAFs on load/add.
 475   let new_targets = files ++ targets state
 476   graph <- io (cmDepAnal (cmstate state) dflags new_targets)
 477   (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
 478   setGHCiState state{ cmstate = cmstate1, targets = new_targets }
 479   setContextAfterLoad mods
 480   modulesLoadedMsg ok mods
 481
 482 changeDirectory :: String -> GHCi ()
 483 changeDirectory ('~':d) = do
 484    tilde <- io (getEnv "HOME")  -- will fail if HOME not defined
 485    io (setCurrentDirectory (tilde ++ '/':d))
 486 changeDirectory d = io (setCurrentDirectory d)
 487
 488 defineMacro :: String -> GHCi ()
 489 defineMacro s = do
 490   let (macro_name, definition) = break isSpace s
 491   cmds <- io (readIORef commands)
 492   if (null macro_name)
 493         then throwDyn (CmdLineError "invalid macro name")
 494         else do
 495   if (macro_name `elem` map fst cmds)
 496         then throwDyn (CmdLineError
 497                 ("command `" ++ macro_name ++ "' is already defined"))
 498         else do
 499
 500   -- give the expression a type signature, so we can be sure we're getting
 501   -- something of the right type.
 502   let new_expr = '(' : definition ++ ") :: String -> IO String"
 503
 504   -- compile the expression
 505   st <- getGHCiState
 506   dflags <- io getDynFlags
 507   (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
 508   setGHCiState st{cmstate = new_cmstate}
 509   case maybe_hv of
 510      Nothing -> return ()
 511      Just hv -> io (writeIORef commands --
 512                     ((macro_name, keepGoing (runMacro hv)) : cmds))
 513
 514 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
 515 runMacro fun s = do
 516   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 517   stringLoop (lines str)
 518
 519 undefineMacro :: String -> GHCi ()
 520 undefineMacro macro_name = do
 521   cmds <- io (readIORef commands)
 522   if (macro_name `elem` map fst builtin_commands)
 523         then throwDyn (CmdLineError
 524                 ("command `" ++ macro_name ++ "' cannot be undefined"))
 525         else do
 526   if (macro_name `notElem` map fst cmds)
 527         then throwDyn (CmdLineError
 528                 ("command `" ++ macro_name ++ "' not defined"))
 529         else do
 530   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
 531
 532
 533 importModules :: String -> GHCi ()
 534 importModules str = return ()
 535
 536
 537 loadModule :: String -> GHCi ()
 538 loadModule str = timeIt (loadModule' str)
 539
 540 loadModule' str = do
 541   let files = words str
 542   state <- getGHCiState
 543   dflags <- io getDynFlags
 544
 545   -- do the dependency anal first, so that if it fails we don't throw
 546   -- away the current set of modules.
 547   graph <- io (cmDepAnal (cmstate state) dflags files)
 548
 549   -- Dependency anal ok, now unload everything
 550   cmstate1 <- io (cmUnload (cmstate state) dflags)
 551   setGHCiState state{ cmstate = cmstate1, targets = [] }
 552
 553   io (revertCAFs)  -- always revert CAFs on load.
 554   (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph)
 555   setGHCiState state{ cmstate = cmstate2, targets = files }
 556
 557   setContextAfterLoad mods
 558   modulesLoadedMsg ok mods
 559
 560
 561 reloadModule :: String -> GHCi ()
 562 reloadModule "" = do
 563   state <- getGHCiState
 564   dflags <- io getDynFlags
 565   case targets state of
 566    [] -> io (putStr "no current target\n")
 567    paths -> do
 568         -- do the dependency anal first, so that if it fails we don't throw
 569         -- away the current set of modules.
 570         graph <- io (cmDepAnal (cmstate state) dflags paths)
 571
 572         io (revertCAFs)         -- always revert CAFs on reload.
 573         (cmstate1, ok, mods)
 574                 <- io (cmLoadModules (cmstate state) dflags graph)
 575         setGHCiState state{ cmstate=cmstate1 }
 576         setContextAfterLoad mods
 577         modulesLoadedMsg ok mods
 578
 579 reloadModule _ = noArgs ":reload"
 580
 581 setContextAfterLoad [] = setContext prel
 582 setContextAfterLoad (m:_) = setContext m
 583
 584 modulesLoadedMsg ok mods = do
 585   let mod_commas
 586         | null mods = text "none."
 587         | otherwise = hsep (
 588             punctuate comma (map text mods)) <> text "."
 589   case ok of
 590     False ->
 591        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 592     True  ->
 593        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 594
 595
 596 typeOfExpr :: String -> GHCi ()
 597 typeOfExpr str
 598   = do st <- getGHCiState
 599        dflags <- io getDynFlags
 600        (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
 601        setGHCiState st{cmstate = new_cmstate}
 602        case maybe_tystr of
 603           Nothing    -> return ()
 604           Just tystr -> io (putStrLn tystr)
 605
 606 quit :: String -> GHCi Bool
 607 quit _ = return True
 608
 609 shellEscape :: String -> GHCi Bool
 610 shellEscape str = io (system str >> return False)
 611
 612 -----------------------------------------------------------------------------
 613 -- Setting the module context
 614
 615 setContext str
 616  | all sensible  mods = newContext mods -- default is to set the empty context
 617  | all plusminus mods = adjustContext mods
 618  | otherwise
 619    = throwDyn (CmdLineError "syntax:  :module M1 .. Mn | :module [+/-]M1 ... [+/-]Mn")
 620  where
 621     mods = words str
 622
 623     sensible (c:cs) = isUpper c && all isAlphaNumEx cs
 624     isAlphaNumEx c = isAlphaNum c || c == '_'
 625
 626     plusminus ('-':mod) = sensible mod
 627     plusminus ('+':mod) = sensible mod
 628     plusminus _ = False
 629
 630 newContext mods = do
 631   state@GHCiState{cmstate=cmstate} <- getGHCiState
 632   dflags <- io getDynFlags
 633
 634   let separate [] as bs = return (as,bs)
 635       separate (m:ms) as bs = do
 636          b <- io (cmModuleIsInterpreted cmstate m)
 637          if b then separate ms (m:as) bs
 638               else separate ms as (m:bs)
 639
 640   (as,bs) <- separate mods [] []
 641   let bs' = if null as && prel `notElem` bs then prel:bs else bs
 642   cmstate' <- io (cmSetContext cmstate dflags as bs')
 643   setGHCiState state{cmstate=cmstate'}
 644
 645 prel = "Prelude"
 646
 647 adjustContext mods = do
 648   state@GHCiState{cmstate=cmstate} <- getGHCiState
 649   dflags <- io getDynFlags
 650
 651   let adjust [] as bs = return (as,bs)
 652       adjust (('-':m) : ms) as bs
 653         | m `elem` as  = adjust ms (delete m as) bs
 654         | m `elem` bs  = adjust ms as (delete m bs)
 655         | otherwise = throwDyn (CmdLineError ("module `" ++ m ++ "' is not currently in scope"))
 656       adjust (('+':m) : ms) as bs
 657         | m `elem` as || m `elem` bs = adjust ms as bs -- continue silently
 658         | otherwise = do b <- io (cmModuleIsInterpreted cmstate m)
 659                          if b then adjust ms (m:as) bs
 660                               else adjust ms as (m:bs)
 661
 662   (as,bs) <- io (cmGetContext cmstate)
 663   (as,bs) <- adjust mods as bs
 664   let bs' = if null as && prel `notElem` bs then prel:bs else bs
 665   cmstate' <- io (cmSetContext cmstate dflags as bs')
 666   setGHCiState state{cmstate=cmstate'}
 667
 668 ----------------------------------------------------------------------------
 669 -- Code for `:set'
 670
 671 -- set options in the interpreter.  Syntax is exactly the same as the
 672 -- ghc command line, except that certain options aren't available (-C,
 673 -- -E etc.)
 674 --
 675 -- This is pretty fragile: most options won't work as expected.  ToDo:
 676 -- figure out which ones & disallow them.
 677
 678 setCmd :: String -> GHCi ()
 679 setCmd ""
 680   = do st <- getGHCiState
 681        let opts = options st
 682        io $ putStrLn (showSDoc (
 683               text "options currently set: " <>
 684               if null opts
 685                    then text "none."
 686                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 687            ))
 688 setCmd str
 689   = case words str of
 690         ("args":args) -> setArgs args
 691         ("prog":prog) -> setProg prog
 692         wds -> setOptions wds
 693
 694 setArgs args = do
 695   st <- getGHCiState
 696   setGHCiState st{ args = args }
 697
 698 setProg [prog] = do
 699   st <- getGHCiState
 700   setGHCiState st{ progname = prog }
 701 setProg _ = do
 702   io (hPutStrLn stderr "syntax: :set prog <progname>")
 703
 704 setOptions wds =
 705    do -- first, deal with the GHCi opts (+s, +t, etc.)
 706       let (plus_opts, minus_opts)  = partition isPlus wds
 707       mapM setOpt plus_opts
 708
 709       -- now, the GHC flags
 710       pkgs_before <- io (readIORef v_Packages)
 711       leftovers   <- io (processArgs static_flags minus_opts [])
 712       pkgs_after  <- io (readIORef v_Packages)
 713
 714       -- update things if the users wants more packages
 715       when (pkgs_before /= pkgs_after) $
 716          newPackages (pkgs_after \\ pkgs_before)
 717
 718       -- then, dynamic flags
 719       io $ do
 720         restoreDynFlags
 721         leftovers <- processArgs dynamic_flags leftovers []
 722         saveDynFlags
 723
 724         if (not (null leftovers))
 725                 then throwDyn (CmdLineError ("unrecognised flags: " ++
 726                                                 unwords leftovers))
 727                 else return ()
 728
 729
 730 unsetOptions :: String -> GHCi ()
 731 unsetOptions str
 732   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 733        let opts = words str
 734            (minus_opts, rest1) = partition isMinus opts
 735            (plus_opts, rest2)  = partition isPlus rest1
 736
 737        if (not (null rest2))
 738           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 739           else do
 740
 741        mapM unsetOpt plus_opts
 742
 743        -- can't do GHC flags for now
 744        if (not (null minus_opts))
 745           then throwDyn (CmdLineError "can't unset GHC command-line flags")
 746           else return ()
 747
 748 isMinus ('-':s) = True
 749 isMinus _ = False
 750
 751 isPlus ('+':s) = True
 752 isPlus _ = False
 753
 754 setOpt ('+':str)
 755   = case strToGHCiOpt str of
 756         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 757         Just o  -> setOption o
 758
 759 unsetOpt ('+':str)
 760   = case strToGHCiOpt str of
 761         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 762         Just o  -> unsetOption o
 763
 764 strToGHCiOpt :: String -> (Maybe GHCiOption)
 765 strToGHCiOpt "s" = Just ShowTiming
 766 strToGHCiOpt "t" = Just ShowType
 767 strToGHCiOpt "r" = Just RevertCAFs
 768 strToGHCiOpt _   = Nothing
 769
 770 optToStr :: GHCiOption -> String
 771 optToStr ShowTiming = "s"
 772 optToStr ShowType   = "t"
 773 optToStr RevertCAFs = "r"
 774
 775 newPackages new_pkgs = do
 776   state <- getGHCiState
 777   dflags <- io getDynFlags
 778   cmstate1 <- io (cmUnload (cmstate state) dflags)
 779   setGHCiState state{ cmstate = cmstate1, targets = [] }
 780
 781   io $ do
 782     pkgs <- getPackageInfo
 783     flushPackageCache pkgs
 784
 785     new_pkg_info <- getPackageDetails new_pkgs
 786     mapM_ linkPackage (reverse new_pkg_info)
 787
 788 -----------------------------------------------------------------------------
 789 -- GHCi monad
 790
 791 data GHCiState = GHCiState
 792      {
 793         progname       :: String,
 794         args           :: [String],
 795         targets        :: [FilePath],
 796         cmstate        :: CmState,
 797         options        :: [GHCiOption]
 798      }
 799
 800 data GHCiOption
 801         = ShowTiming            -- show time/allocs after evaluation
 802         | ShowType              -- show the type of expressions
 803         | RevertCAFs            -- revert CAFs after every evaluation
 804         deriving Eq
 805
 806 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
 807 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
 808
 809 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
 810
 811 startGHCi :: GHCi a -> GHCiState -> IO a
 812 startGHCi g state = do ref <- newIORef state; unGHCi g ref
 813
 814 instance Monad GHCi where
 815   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
 816   return a  = GHCi $ \s -> return a
 817
 818 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
 819 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
 820    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
 821
 822 getGHCiState   = GHCi $ \r -> readIORef r
 823 setGHCiState s = GHCi $ \r -> writeIORef r s
 824
 825 isOptionSet :: GHCiOption -> GHCi Bool
 826 isOptionSet opt
 827  = do st <- getGHCiState
 828       return (opt `elem` options st)
 829
 830 setOption :: GHCiOption -> GHCi ()
 831 setOption opt
 832  = do st <- getGHCiState
 833       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 834
 835 unsetOption :: GHCiOption -> GHCi ()
 836 unsetOption opt
 837  = do st <- getGHCiState
 838       setGHCiState (st{ options = filter (/= opt) (options st) })
 839
 840 io :: IO a -> GHCi a
 841 io m = GHCi { unGHCi = \s -> m >>= return }
 842
 843 -----------------------------------------------------------------------------
 844 -- recursive exception handlers
 845
 846 -- Don't forget to unblock async exceptions in the handler, or if we're
 847 -- in an exception loop (eg. let a = error a in a) the ^C exception
 848 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
 849
 850 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
 851 ghciHandle h (GHCi m) = GHCi $ \s ->
 852    Exception.catch (m s)
 853         (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
 854
 855 ghciUnblock :: GHCi a -> GHCi a
 856 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
 857
 858 -----------------------------------------------------------------------------
 859 -- package loader
 860
 861 -- Left: full path name of a .o file, including trailing .o
 862 -- Right: "unadorned" name of a .DLL/.so
 863 --        e.g.    On unix     "qt"  denotes "libqt.so"
 864 --                On WinDoze  "burble"  denotes "burble.DLL"
 865 --        addDLL is platform-specific and adds the lib/.so/.DLL
 866 --        suffixes platform-dependently; we don't do that here.
 867 --
 868 -- For dynamic objects only, try to find the object file in all the
 869 -- directories specified in v_Library_Paths before giving up.
 870
 871 type LibrarySpec
 872    = Either FilePath String
 873
 874 showLS (Left nm)  = "(static) " ++ nm
 875 showLS (Right nm) = "(dynamic) " ++ nm
 876
 877 linkPackages :: [LibrarySpec] -> [PackageConfig] -> IO ()
 878 linkPackages cmdline_lib_specs pkgs
 879    = do mapM_ linkPackage (reverse pkgs)
 880         lib_paths <- readIORef v_Library_paths
 881         mapM_ (preloadLib lib_paths) cmdline_lib_specs
 882         if (null cmdline_lib_specs)
 883            then return ()
 884            else do putStr "final link ... "
 885                    ok <- resolveObjs
 886                    if ok then putStrLn "done."
 887                          else throwDyn (InstallationError
 888                                           "linking extra libraries/objects failed")
 889      where
 890         preloadLib :: [String] -> LibrarySpec -> IO ()
 891         preloadLib lib_paths lib_spec
 892            = do putStr ("Loading object " ++ showLS lib_spec ++ " ... ")
 893                 case lib_spec of
 894                    Left static_ish
 895                       -> do b <- preload_static lib_paths static_ish
 896                             putStrLn (if b then "done." else "not found")
 897                    Right dll_unadorned
 898                       -> -- We add "" to the set of paths to try, so that
 899                          -- if none of the real paths match, we force addDLL
 900                          -- to look in the default dynamic-link search paths.
 901                          do maybe_errstr <- preload_dynamic (lib_paths++[""])
 902                                                             dll_unadorned
 903                             case maybe_errstr of
 904                                Nothing -> return ()
 905                                Just mm -> preloadFailed mm lib_paths lib_spec
 906                             putStrLn "done"
 907
 908         preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
 909         preloadFailed sys_errmsg paths spec
 910            = do putStr ("failed.\nDynamic linker error message was:\n   "
 911                         ++ sys_errmsg  ++ "\nWhilst trying to load:  "
 912                         ++ showLS spec ++ "\nDirectories to search are:\n"
 913                         ++ unlines (map ("   "++) paths) )
 914                 give_up
 915
 916         -- not interested in the paths in the static case.
 917         preload_static paths name
 918            = do b <- doesFileExist name
 919                 if not b then return False
 920                          else loadObj name >> return True
 921
 922         -- return Nothing == success, else Just error message from addDLL
 923         preload_dynamic [] name
 924            = return Nothing
 925         preload_dynamic (path:paths) rootname
 926            = do -- addDLL returns NULL on success
 927                 maybe_errmsg <- addDLL path rootname
 928                 if    maybe_errmsg == nullPtr
 929                  then preload_dynamic paths rootname
 930                  else do str <- peekCString maybe_errmsg
 931                          return (Just str)
 932
 933         give_up
 934            = (throwDyn . CmdLineError)
 935                 "user specified .o/.so/.DLL could not be loaded."
 936
 937 -- Packages that don't need loading, because the compiler shares them with
 938 -- the interpreted program.
 939 dont_load_these = [ "gmp", "rts" ]
 940
 941 -- Packages that are already linked into GHCi.  For mingw32, we only
 942 -- skip gmp and rts, since std and after need to load the msvcrt.dll
 943 -- library which std depends on.
 944 loaded_in_ghci
 945 #          ifndef mingw32_TARGET_OS
 946            = [ "std", "concurrent", "posix", "text", "util" ]
 947 #          else
 948            = [ ]
 949 #          endif
 950
 951 linkPackage :: PackageConfig -> IO ()
 952 linkPackage pkg
 953    | name pkg `elem` dont_load_these = return ()
 954    | otherwise
 955    = do
 956         -- For each obj, try obj.o and if that fails, obj.so.
 957         -- Complication: all the .so's must be loaded before any of the .o's.
 958         let dirs      =  library_dirs pkg
 959         let objs      =  hs_libraries pkg ++ extra_libraries pkg
 960         classifieds   <- mapM (locateOneObj dirs) objs
 961
 962         -- Don't load the .so libs if this is a package GHCi is already
 963         -- linked against, because we'll already have the .so linked in.
 964         let (so_libs, obj_libs) = partition isRight classifieds
 965         let sos_first | name pkg `elem` loaded_in_ghci = obj_libs
 966                       | otherwise                      = so_libs ++ obj_libs
 967
 968         putStr ("Loading package " ++ name pkg ++ " ... ")
 969         mapM loadClassified sos_first
 970         putStr "linking ... "
 971         ok <- resolveObjs
 972         if ok then putStrLn "done."
 973               else panic ("can't load package `" ++ name pkg ++ "'")
 974      where
 975         isRight (Right _) = True
 976         isRight (Left _)  = False
 977
 978 loadClassified :: LibrarySpec -> IO ()
 979 loadClassified (Left obj_absolute_filename)
 980    = do loadObj obj_absolute_filename
 981 loadClassified (Right dll_unadorned)
 982    = do maybe_errmsg <- addDLL "" dll_unadorned -- doesn't seem right to me
 983         if    maybe_errmsg == nullPtr
 984          then return ()
 985          else do str <- peekCString maybe_errmsg
 986                  throwDyn (CmdLineError ("can't load .so/.DLL for: "
 987                                        ++ dll_unadorned ++ " (" ++ str ++ ")" ))
 988
 989 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
 990 locateOneObj []     obj
 991    = return (Right obj) -- we assume
 992 locateOneObj (d:ds) obj
 993    = do let path = d ++ '/':obj ++ ".o"
 994         b <- doesFileExist path
 995         if b then return (Left path) else locateOneObj ds obj
 996
 997 -----------------------------------------------------------------------------
 998 -- timing & statistics
 999
1000 timeIt :: GHCi a -> GHCi a
1001 timeIt action
1002   = do b <- isOptionSet ShowTiming
1003        if not b
1004           then action
1005           else do allocs1 <- io $ getAllocations
1006                   time1   <- io $ getCPUTime
1007                   a <- action
1008                   allocs2 <- io $ getAllocations
1009                   time2   <- io $ getCPUTime
1010                   io $ printTimes (allocs2 - allocs1) (time2 - time1)
1011                   return a
1012
1013 foreign import "getAllocations" getAllocations :: IO Int
1014
1015 printTimes :: Int -> Integer -> IO ()
1016 printTimes allocs psecs
1017    = do let secs = (fromIntegral psecs / (10^12)) :: Float
1018             secs_str = showFFloat (Just 2) secs
1019         putStrLn (showSDoc (
1020                  parens (text (secs_str "") <+> text "secs" <> comma <+>
1021                          int allocs <+> text "bytes")))
1022
1023 -----------------------------------------------------------------------------
1024 -- reverting CAFs
1025
1026 foreign import revertCAFs :: IO ()      -- make it "safe", just in case