ghc/compiler/ghci/InteractiveUI.hs

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