ghc/compiler/ghci/InteractiveUI.hs

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