ghc/compiler/ghci/InteractiveUI.hs

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