ghc/compiler/ghci/InteractiveUI.hs

   1 {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: InteractiveUI.hs,v 1.101 2001/10/31 12:51:08 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
  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(..) )
  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 ->
 324         io (putStrLn ("*** Exception: (unknown)"))
 325     Just (PhaseFailed phase code) ->
 326         io (putStrLn ("Phase " ++ phase ++ " failed (code "
 327                        ++ show code ++ ")"))
 328     Just Interrupted ->
 329         io (putStrLn "Interrupted.")
 330     Just (CmdLineError s) ->
 331         io (putStrLn s)  -- omit the location for CmdLineError
 332     Just other_ghc_ex ->
 333         io (putStrLn (show other_ghc_ex))
 334 showException other_exception
 335   = io (putStrLn ("*** Exception: " ++ show other_exception))
 336
 337 doCommand (':' : command) = specialCommand command
 338 doCommand stmt
 339    = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
 340         return False
 341
 342 runStmt :: String -> GHCi [Name]
 343 runStmt stmt
 344  | null (filter (not.isSpace) stmt) = return []
 345  | otherwise
 346  = do st <- getGHCiState
 347       dflags <- io getDynFlags
 348       let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
 349       (new_cmstate, result) <-
 350         io $ withProgName (progname st) $ withArgs (args st) $
 351         cmRunStmt (cmstate st) dflags' stmt
 352       setGHCiState st{cmstate = new_cmstate}
 353       case result of
 354         CmRunFailed      -> return []
 355         CmRunException e -> showException e >> return []
 356         CmRunDeadlocked  -> io (putStrLn "Deadlocked.") >> return []
 357         CmRunOk names    -> return names
 358
 359 -- possibly print the type and revert CAFs after evaluating an expression
 360 finishEvalExpr names
 361  = do b <- isOptionSet ShowType
 362       st <- getGHCiState
 363       when b (mapM_ (showTypeOfName (cmstate st)) names)
 364
 365       b <- isOptionSet RevertCAFs
 366       io (when b revertCAFs)
 367       flushEverything
 368       return True
 369
 370 showTypeOfName :: CmState -> Name -> GHCi ()
 371 showTypeOfName cmstate n
 372    = do maybe_str <- io (cmTypeOfName cmstate n)
 373         case maybe_str of
 374           Nothing  -> return ()
 375           Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
 376
 377 flushEverything :: GHCi ()
 378 flushEverything
 379    = io $ do Monad.join (readIORef flush_stdout)
 380              Monad.join (readIORef flush_stderr)
 381              return ()
 382
 383 specialCommand :: String -> GHCi Bool
 384 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 385 specialCommand str = do
 386   let (cmd,rest) = break isSpace str
 387   cmds <- io (readIORef commands)
 388   case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
 389      []      -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
 390                                     ++ shortHelpText) >> return False)
 391      [(_,f)] -> f (dropWhile isSpace rest)
 392      cs      -> io (hPutStrLn stdout ("prefix " ++ cmd ++
 393                                       " matches multiple commands (" ++
 394                                        foldr1 (\a b -> a ++ ',':b) (map fst cs)
 395                                          ++ ")") >> return False)
 396
 397 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
 398
 399 -----------------------------------------------------------------------------
 400 -- Commands
 401
 402 help :: String -> GHCi ()
 403 help _ = io (putStr helpText)
 404
 405 info :: String -> GHCi ()
 406 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
 407 info s = do
 408   let names = words s
 409   state <- getGHCiState
 410   dflags <- io getDynFlags
 411   let
 412     infoThings cms [] = return cms
 413     infoThings cms (name:names) = do
 414       (cms, unqual, stuff) <- io (cmInfoThing cms dflags name)
 415       io (putStrLn (showSDocForUser unqual (
 416             vcat (intersperse (text "") (map showThing stuff))))
 417          )
 418       infoThings cms names
 419
 420     showThing (ty_thing, fixity)
 421         = vcat [ text "-- " <> showTyThing ty_thing,
 422                  showFixity fixity (getName ty_thing),
 423                  ppr (ifaceTyThing ty_thing) ]
 424
 425     showFixity fix name
 426         | fix == defaultFixity = empty
 427         | otherwise            = ppr fix <+>
 428                                  (if isSymOcc (nameOccName name)
 429                                         then ppr name
 430                                         else char '`' <> ppr name <> char '`')
 431
 432     showTyThing (AClass cl)
 433        = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
 434     showTyThing (ATyCon ty)
 435        | isPrimTyCon ty
 436        = hcat [ppr ty, text " is a primitive type constructor"]
 437        | otherwise
 438        = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
 439     showTyThing (AnId   id)
 440        = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
 441
 442     idDescr id
 443        | isRecordSelector id =
 444                 case tyConClass_maybe (fieldLabelTyCon (
 445                                 recordSelectorFieldLabel id)) of
 446                         Nothing -> text "record selector"
 447                         Just c  -> text "method in class " <> ppr c
 448        | isDataConWrapId id  = text "data constructor"
 449        | otherwise           = text "variable"
 450
 451         -- also print out the source location for home things
 452     showSrcLoc name
 453         | isHomePackageName name && isGoodSrcLoc loc
 454         = hsep [ text ", defined at", ppr loc ]
 455         | otherwise
 456         = empty
 457         where loc = nameSrcLoc name
 458
 459   cms <- infoThings (cmstate state) names
 460   setGHCiState state{ cmstate = cms }
 461   return ()
 462
 463
 464 addModule :: String -> GHCi ()
 465 addModule str = do
 466   let files = words str
 467   state <- getGHCiState
 468   dflags <- io (getDynFlags)
 469   io (revertCAFs)                       -- always revert CAFs on load/add.
 470   let new_targets = files ++ targets state
 471   (cmstate1, ok, mods) <- io (cmLoadModule (cmstate state) new_targets)
 472   setGHCiState state{ cmstate = cmstate1, targets = new_targets }
 473   modulesLoadedMsg ok mods
 474
 475 setContext :: String -> GHCi ()
 476 setContext ""
 477   = throwDyn (CmdLineError "syntax: `:m <module>'")
 478 setContext m | not (isUpper (head m)) || not (all isAlphaNumEx (tail m))
 479   = throwDyn (CmdLineError ("strange looking module name: `" ++ m ++ "'"))
 480     where
 481        isAlphaNumEx c = isAlphaNum c || c == '_'
 482 setContext str
 483   = do st <- getGHCiState
 484        new_cmstate <- io (cmSetContext (cmstate st) str)
 485        setGHCiState st{cmstate=new_cmstate}
 486
 487 changeDirectory :: String -> GHCi ()
 488 changeDirectory ('~':d) = do
 489    tilde <- io (getEnv "HOME")  -- will fail if HOME not defined
 490    io (setCurrentDirectory (tilde ++ '/':d))
 491 changeDirectory d = io (setCurrentDirectory d)
 492
 493 defineMacro :: String -> GHCi ()
 494 defineMacro s = do
 495   let (macro_name, definition) = break isSpace s
 496   cmds <- io (readIORef commands)
 497   if (null macro_name)
 498         then throwDyn (CmdLineError "invalid macro name")
 499         else do
 500   if (macro_name `elem` map fst cmds)
 501         then throwDyn (CmdLineError
 502                 ("command `" ++ macro_name ++ "' is already defined"))
 503         else do
 504
 505   -- give the expression a type signature, so we can be sure we're getting
 506   -- something of the right type.
 507   let new_expr = '(' : definition ++ ") :: String -> IO String"
 508
 509   -- compile the expression
 510   st <- getGHCiState
 511   dflags <- io getDynFlags
 512   (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
 513   setGHCiState st{cmstate = new_cmstate}
 514   case maybe_hv of
 515      Nothing -> return ()
 516      Just hv -> io (writeIORef commands --
 517                     ((macro_name, keepGoing (runMacro hv)) : cmds))
 518
 519 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
 520 runMacro fun s = do
 521   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 522   stringLoop (lines str)
 523
 524 undefineMacro :: String -> GHCi ()
 525 undefineMacro macro_name = do
 526   cmds <- io (readIORef commands)
 527   if (macro_name `elem` map fst builtin_commands)
 528         then throwDyn (CmdLineError
 529                 ("command `" ++ macro_name ++ "' cannot be undefined"))
 530         else do
 531   if (macro_name `notElem` map fst cmds)
 532         then throwDyn (CmdLineError
 533                 ("command `" ++ macro_name ++ "' not defined"))
 534         else do
 535   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
 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   cmstate1 <- io (cmUnload (cmstate state) dflags)
 545   setGHCiState state{ cmstate = cmstate1, targets = [] }
 546   io (revertCAFs)                       -- always revert CAFs on load.
 547   (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 files)
 548   setGHCiState state{ cmstate = cmstate2, targets = files }
 549   modulesLoadedMsg ok mods
 550
 551 reloadModule :: String -> GHCi ()
 552 reloadModule "" = do
 553   state <- getGHCiState
 554   case targets state of
 555    [] -> io (putStr "no current target\n")
 556    paths
 557       -> do io (revertCAFs)             -- always revert CAFs on reload.
 558             (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) paths)
 559             setGHCiState state{ cmstate=new_cmstate }
 560             modulesLoadedMsg ok mods
 561
 562 reloadModule _ = noArgs ":reload"
 563
 564
 565 modulesLoadedMsg ok mods = do
 566   let mod_commas
 567         | null mods = text "none."
 568         | otherwise = hsep (
 569             punctuate comma (map text mods)) <> text "."
 570   case ok of
 571     False ->
 572        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 573     True  ->
 574        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 575
 576
 577 typeOfExpr :: String -> GHCi ()
 578 typeOfExpr str
 579   = do st <- getGHCiState
 580        dflags <- io getDynFlags
 581        (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
 582        setGHCiState st{cmstate = new_cmstate}
 583        case maybe_tystr of
 584           Nothing    -> return ()
 585           Just tystr -> io (putStrLn tystr)
 586
 587 quit :: String -> GHCi Bool
 588 quit _ = return True
 589
 590 shellEscape :: String -> GHCi Bool
 591 shellEscape str = io (system str >> return False)
 592
 593 ----------------------------------------------------------------------------
 594 -- Code for `:set'
 595
 596 -- set options in the interpreter.  Syntax is exactly the same as the
 597 -- ghc command line, except that certain options aren't available (-C,
 598 -- -E etc.)
 599 --
 600 -- This is pretty fragile: most options won't work as expected.  ToDo:
 601 -- figure out which ones & disallow them.
 602
 603 setCmd :: String -> GHCi ()
 604 setCmd ""
 605   = do st <- getGHCiState
 606        let opts = options st
 607        io $ putStrLn (showSDoc (
 608               text "options currently set: " <>
 609               if null opts
 610                    then text "none."
 611                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 612            ))
 613 setCmd str
 614   = case words str of
 615         ("args":args) -> setArgs args
 616         ("prog":prog) -> setProg prog
 617         wds -> setOptions wds
 618
 619 setArgs args = do
 620   st <- getGHCiState
 621   setGHCiState st{ args = args }
 622
 623 setProg [prog] = do
 624   st <- getGHCiState
 625   setGHCiState st{ progname = prog }
 626 setProg _ = do
 627   io (hPutStrLn stderr "syntax: :set prog <progname>")
 628
 629 setOptions wds =
 630    do -- first, deal with the GHCi opts (+s, +t, etc.)
 631       let (plus_opts, minus_opts)  = partition isPlus wds
 632       mapM setOpt plus_opts
 633
 634       -- now, the GHC flags
 635       pkgs_before <- io (readIORef v_Packages)
 636       leftovers   <- io (processArgs static_flags minus_opts [])
 637       pkgs_after  <- io (readIORef v_Packages)
 638
 639       -- update things if the users wants more packages
 640       when (pkgs_before /= pkgs_after) $
 641          newPackages (pkgs_after \\ pkgs_before)
 642
 643       -- then, dynamic flags
 644       io $ do
 645         restoreDynFlags
 646         leftovers <- processArgs dynamic_flags leftovers []
 647         saveDynFlags
 648
 649         if (not (null leftovers))
 650                 then throwDyn (CmdLineError ("unrecognised flags: " ++
 651                                                 unwords leftovers))
 652                 else return ()
 653
 654
 655 unsetOptions :: String -> GHCi ()
 656 unsetOptions str
 657   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 658        let opts = words str
 659            (minus_opts, rest1) = partition isMinus opts
 660            (plus_opts, rest2)  = partition isPlus rest1
 661
 662        if (not (null rest2))
 663           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 664           else do
 665
 666        mapM unsetOpt plus_opts
 667
 668        -- can't do GHC flags for now
 669        if (not (null minus_opts))
 670           then throwDyn (CmdLineError "can't unset GHC command-line flags")
 671           else return ()
 672
 673 isMinus ('-':s) = True
 674 isMinus _ = False
 675
 676 isPlus ('+':s) = True
 677 isPlus _ = False
 678
 679 setOpt ('+':str)
 680   = case strToGHCiOpt str of
 681         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 682         Just o  -> setOption o
 683
 684 unsetOpt ('+':str)
 685   = case strToGHCiOpt str of
 686         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 687         Just o  -> unsetOption o
 688
 689 strToGHCiOpt :: String -> (Maybe GHCiOption)
 690 strToGHCiOpt "s" = Just ShowTiming
 691 strToGHCiOpt "t" = Just ShowType
 692 strToGHCiOpt "r" = Just RevertCAFs
 693 strToGHCiOpt _   = Nothing
 694
 695 optToStr :: GHCiOption -> String
 696 optToStr ShowTiming = "s"
 697 optToStr ShowType   = "t"
 698 optToStr RevertCAFs = "r"
 699
 700 newPackages new_pkgs = do
 701   state <- getGHCiState
 702   dflags <- io getDynFlags
 703   cmstate1 <- io (cmUnload (cmstate state) dflags)
 704   setGHCiState state{ cmstate = cmstate1, targets = [] }
 705
 706   io $ do
 707     pkgs <- getPackageInfo
 708     flushPackageCache pkgs
 709
 710     new_pkg_info <- getPackageDetails new_pkgs
 711     mapM_ linkPackage (reverse new_pkg_info)
 712
 713 -----------------------------------------------------------------------------
 714 -- GHCi monad
 715
 716 data GHCiState = GHCiState
 717      {
 718         progname       :: String,
 719         args           :: [String],
 720         targets        :: [FilePath],
 721         cmstate        :: CmState,
 722         options        :: [GHCiOption]
 723      }
 724
 725 data GHCiOption
 726         = ShowTiming            -- show time/allocs after evaluation
 727         | ShowType              -- show the type of expressions
 728         | RevertCAFs            -- revert CAFs after every evaluation
 729         deriving Eq
 730
 731 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
 732 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
 733
 734 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
 735
 736 startGHCi :: GHCi a -> GHCiState -> IO a
 737 startGHCi g state = do ref <- newIORef state; unGHCi g ref
 738
 739 instance Monad GHCi where
 740   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
 741   return a  = GHCi $ \s -> return a
 742
 743 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
 744 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
 745    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
 746
 747 getGHCiState   = GHCi $ \r -> readIORef r
 748 setGHCiState s = GHCi $ \r -> writeIORef r s
 749
 750 isOptionSet :: GHCiOption -> GHCi Bool
 751 isOptionSet opt
 752  = do st <- getGHCiState
 753       return (opt `elem` options st)
 754
 755 setOption :: GHCiOption -> GHCi ()
 756 setOption opt
 757  = do st <- getGHCiState
 758       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 759
 760 unsetOption :: GHCiOption -> GHCi ()
 761 unsetOption opt
 762  = do st <- getGHCiState
 763       setGHCiState (st{ options = filter (/= opt) (options st) })
 764
 765 io :: IO a -> GHCi a
 766 io m = GHCi { unGHCi = \s -> m >>= return }
 767
 768 -----------------------------------------------------------------------------
 769 -- recursive exception handlers
 770
 771 -- Don't forget to unblock async exceptions in the handler, or if we're
 772 -- in an exception loop (eg. let a = error a in a) the ^C exception
 773 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
 774
 775 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
 776 ghciHandle h (GHCi m) = GHCi $ \s ->
 777    Exception.catch (m s)
 778         (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
 779
 780 ghciUnblock :: GHCi a -> GHCi a
 781 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
 782
 783 -----------------------------------------------------------------------------
 784 -- package loader
 785
 786 -- Left: full path name of a .o file, including trailing .o
 787 -- Right: "unadorned" name of a .DLL/.so
 788 --        e.g.    On unix     "qt"  denotes "libqt.so"
 789 --                On WinDoze  "burble"  denotes "burble.DLL"
 790 --        addDLL is platform-specific and adds the lib/.so/.DLL
 791 --        suffixes platform-dependently; we don't do that here.
 792 --
 793 -- For dynamic objects only, try to find the object file in all the
 794 -- directories specified in v_Library_Paths before giving up.
 795
 796 type LibrarySpec
 797    = Either FilePath String
 798
 799 showLS (Left nm)  = "(static) " ++ nm
 800 showLS (Right nm) = "(dynamic) " ++ nm
 801
 802 linkPackages :: [LibrarySpec] -> [PackageConfig] -> IO ()
 803 linkPackages cmdline_lib_specs pkgs
 804    = do mapM_ linkPackage (reverse pkgs)
 805         lib_paths <- readIORef v_Library_paths
 806         mapM_ (preloadLib lib_paths) cmdline_lib_specs
 807         if (null cmdline_lib_specs)
 808            then return ()
 809            else do putStr "final link ... "
 810                    ok <- resolveObjs
 811                    if ok then putStrLn "done."
 812                          else throwDyn (InstallationError "linking extra libraries/objects failed")
 813      where
 814         preloadLib :: [String] -> LibrarySpec -> IO ()
 815         preloadLib lib_paths lib_spec
 816            = do putStr ("Loading object " ++ showLS lib_spec ++ " ... ")
 817                 case lib_spec of
 818                    Left static_ish
 819                       -> do b <- preload_static lib_paths static_ish
 820                             putStrLn (if b then "done." else "not found")
 821                    Right dll_unadorned
 822                       -> -- We add "" to the set of paths to try, so that
 823                          -- if none of the real paths match, we force addDLL
 824                          -- to look in the default dynamic-link search paths.
 825                          do b <- preload_dynamic (lib_paths++[""]) dll_unadorned
 826                             when (not b) (cantFind lib_paths lib_spec)
 827                             putStrLn "done"
 828
 829         cantFind :: [String] -> LibrarySpec -> IO ()
 830         cantFind paths spec
 831            = do putStr ("failed.\nCan't find " ++ showLS spec
 832                         ++ " in directories:\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         preload_dynamic [] name
 843            = return False
 844         preload_dynamic (path:paths) rootname
 845            = do maybe_errmsg <- addDLL path rootname
 846                 if    maybe_errmsg /= nullPtr
 847                  then preload_dynamic paths rootname
 848                  else return True
 849
 850         give_up
 851            = (throwDyn . CmdLineError)
 852                 "user specified .o/.so/.DLL could not be loaded."
 853
 854 -- Packages that don't need loading, because the compiler shares them with
 855 -- the interpreted program.
 856 dont_load_these = [ "gmp", "rts" ]
 857
 858 -- Packages that are already linked into GHCi.  For mingw32, we only
 859 -- skip gmp and rts, since std and after need to load the msvcrt.dll
 860 -- library which std depends on.
 861 loaded_in_ghci
 862 #          ifndef mingw32_TARGET_OS
 863            = [ "std", "concurrent", "posix", "text", "util" ]
 864 #          else
 865            = [ ]
 866 #          endif
 867
 868 linkPackage :: PackageConfig -> IO ()
 869 linkPackage pkg
 870    | name pkg `elem` dont_load_these = return ()
 871    | otherwise
 872    = do
 873         -- For each obj, try obj.o and if that fails, obj.so.
 874         -- Complication: all the .so's must be loaded before any of the .o's.
 875         let dirs      =  library_dirs pkg
 876         let objs      =  hs_libraries pkg ++ extra_libraries pkg
 877         classifieds   <- mapM (locateOneObj dirs) objs
 878
 879         -- Don't load the .so libs if this is a package GHCi is already
 880         -- linked against, because we'll already have the .so linked in.
 881         let (so_libs, obj_libs) = partition isRight classifieds
 882         let sos_first | name pkg `elem` loaded_in_ghci = obj_libs
 883                       | otherwise                      = so_libs ++ obj_libs
 884
 885         putStr ("Loading package " ++ name pkg ++ " ... ")
 886         mapM loadClassified sos_first
 887         putStr "linking ... "
 888         ok <- resolveObjs
 889         if ok then putStrLn "done."
 890               else panic ("can't load package `" ++ name pkg ++ "'")
 891      where
 892         isRight (Right _) = True
 893         isRight (Left _)  = False
 894
 895 loadClassified :: LibrarySpec -> IO ()
 896 loadClassified (Left obj_absolute_filename)
 897    = do loadObj obj_absolute_filename
 898 loadClassified (Right dll_unadorned)
 899    = do maybe_errmsg <- addDLL "" dll_unadorned -- doesn't seem right to me
 900         if    maybe_errmsg == nullPtr
 901          then return ()
 902          else do str <- peekCString maybe_errmsg
 903                  throwDyn (CmdLineError ("can't load .so/.DLL for: "
 904                                        ++ dll_unadorned ++ " (" ++ str ++ ")" ))
 905
 906 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
 907 locateOneObj []     obj
 908    = return (Right obj) -- we assume
 909 locateOneObj (d:ds) obj
 910    = do let path = d ++ '/':obj ++ ".o"
 911         b <- doesFileExist path
 912         if b then return (Left path) else locateOneObj ds obj
 913
 914 -----------------------------------------------------------------------------
 915 -- timing & statistics
 916
 917 timeIt :: GHCi a -> GHCi a
 918 timeIt action
 919   = do b <- isOptionSet ShowTiming
 920        if not b
 921           then action
 922           else do allocs1 <- io $ getAllocations
 923                   time1   <- io $ getCPUTime
 924                   a <- action
 925                   allocs2 <- io $ getAllocations
 926                   time2   <- io $ getCPUTime
 927                   io $ printTimes (allocs2 - allocs1) (time2 - time1)
 928                   return a
 929
 930 foreign import "getAllocations" getAllocations :: IO Int
 931
 932 printTimes :: Int -> Integer -> IO ()
 933 printTimes allocs psecs
 934    = do let secs = (fromIntegral psecs / (10^12)) :: Float
 935             secs_str = showFFloat (Just 2) secs
 936         putStrLn (showSDoc (
 937                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 938                          int allocs <+> text "bytes")))
 939
 940 -----------------------------------------------------------------------------
 941 -- reverting CAFs
 942
 943 foreign import revertCAFs :: IO ()      -- make it "safe", just in case