ghc/compiler/ghci/InteractiveUI.hs

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