ghc/compiler/ghci/InteractiveUI.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: InteractiveUI.hs,v 1.87 2001/08/15 14:41:49 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               ( 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        | isDataConWrapId id
 403        = hcat [ppr id, text " is a data constructor", showSrcLoc (idName id)]
 404        | otherwise
 405        = hcat [ppr id, text " is a variable", showSrcLoc (idName id)]
 406
 407         -- also print out the source location for home things
 408     showSrcLoc name
 409         | isHomePackageName name && isGoodSrcLoc loc
 410         = hsep [ text ", defined at", ppr loc ]
 411         | otherwise
 412         = empty
 413         where loc = nameSrcLoc name
 414
 415   cms <- infoThings (cmstate state) names
 416   setGHCiState state{ cmstate = cms }
 417   return ()
 418
 419
 420 addModule :: String -> GHCi ()
 421 addModule str = do
 422   let files = words str
 423   state <- getGHCiState
 424   dflags <- io (getDynFlags)
 425   io (revertCAFs)                       -- always revert CAFs on load/add.
 426   let new_targets = files ++ targets state
 427   (cmstate1, ok, mods) <- io (cmLoadModule (cmstate state) new_targets)
 428   setGHCiState state{ cmstate = cmstate1, targets = new_targets }
 429   modulesLoadedMsg ok mods
 430
 431 setContext :: String -> GHCi ()
 432 setContext ""
 433   = throwDyn (CmdLineError "syntax: `:m <module>'")
 434 setContext m | not (isUpper (head m)) || not (all isAlphaNumEx (tail m))
 435   = throwDyn (CmdLineError ("strange looking module name: `" ++ m ++ "'"))
 436     where
 437        isAlphaNumEx c = isAlphaNum c || c == '_'
 438 setContext str
 439   = do st <- getGHCiState
 440        new_cmstate <- io (cmSetContext (cmstate st) str)
 441        setGHCiState st{cmstate=new_cmstate}
 442
 443 changeDirectory :: String -> GHCi ()
 444 changeDirectory ('~':d) = do
 445    tilde <- io (getEnv "HOME")  -- will fail if HOME not defined
 446    io (setCurrentDirectory (tilde ++ '/':d))
 447 changeDirectory d = io (setCurrentDirectory d)
 448
 449 defineMacro :: String -> GHCi ()
 450 defineMacro s = do
 451   let (macro_name, definition) = break isSpace s
 452   cmds <- io (readIORef commands)
 453   if (null macro_name)
 454         then throwDyn (CmdLineError "invalid macro name")
 455         else do
 456   if (macro_name `elem` map fst cmds)
 457         then throwDyn (CmdLineError
 458                 ("command `" ++ macro_name ++ "' is already defined"))
 459         else do
 460
 461   -- give the expression a type signature, so we can be sure we're getting
 462   -- something of the right type.
 463   let new_expr = '(' : definition ++ ") :: String -> IO String"
 464
 465   -- compile the expression
 466   st <- getGHCiState
 467   dflags <- io getDynFlags
 468   (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
 469   setGHCiState st{cmstate = new_cmstate}
 470   case maybe_hv of
 471      Nothing -> return ()
 472      Just hv -> io (writeIORef commands --
 473                     ((macro_name, keepGoing (runMacro hv)) : cmds))
 474
 475 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
 476 runMacro fun s = do
 477   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 478   stringLoop (lines str)
 479
 480 undefineMacro :: String -> GHCi ()
 481 undefineMacro macro_name = do
 482   cmds <- io (readIORef commands)
 483   if (macro_name `elem` map fst builtin_commands)
 484         then throwDyn (CmdLineError
 485                 ("command `" ++ macro_name ++ "' cannot be undefined"))
 486         else do
 487   if (macro_name `notElem` map fst cmds)
 488         then throwDyn (CmdLineError
 489                 ("command `" ++ macro_name ++ "' not defined"))
 490         else do
 491   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
 492
 493 loadModule :: String -> GHCi ()
 494 loadModule str = timeIt (loadModule' str)
 495
 496 loadModule' str = do
 497   let files = words str
 498   state <- getGHCiState
 499   dflags <- io getDynFlags
 500   cmstate1 <- io (cmUnload (cmstate state) dflags)
 501   setGHCiState state{ cmstate = cmstate1, targets = [] }
 502   io (revertCAFs)                       -- always revert CAFs on load.
 503   (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 files)
 504   setGHCiState state{ cmstate = cmstate2, targets = files }
 505   modulesLoadedMsg ok mods
 506
 507 reloadModule :: String -> GHCi ()
 508 reloadModule "" = do
 509   state <- getGHCiState
 510   case targets state of
 511    [] -> io (putStr "no current target\n")
 512    paths
 513       -> do io (revertCAFs)             -- always revert CAFs on reload.
 514             (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) paths)
 515             setGHCiState state{ cmstate=new_cmstate }
 516             modulesLoadedMsg ok mods
 517
 518 reloadModule _ = noArgs ":reload"
 519
 520
 521 modulesLoadedMsg ok mods = do
 522   let mod_commas
 523         | null mods = text "none."
 524         | otherwise = hsep (
 525             punctuate comma (map text mods)) <> text "."
 526   case ok of
 527     False ->
 528        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 529     True  ->
 530        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 531
 532
 533 typeOfExpr :: String -> GHCi ()
 534 typeOfExpr str
 535   = do st <- getGHCiState
 536        dflags <- io getDynFlags
 537        (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
 538        setGHCiState st{cmstate = new_cmstate}
 539        case maybe_tystr of
 540           Nothing    -> return ()
 541           Just tystr -> io (putStrLn tystr)
 542
 543 quit :: String -> GHCi Bool
 544 quit _ = return True
 545
 546 shellEscape :: String -> GHCi Bool
 547 shellEscape str = io (system str >> return False)
 548
 549 ----------------------------------------------------------------------------
 550 -- Code for `:set'
 551
 552 -- set options in the interpreter.  Syntax is exactly the same as the
 553 -- ghc command line, except that certain options aren't available (-C,
 554 -- -E etc.)
 555 --
 556 -- This is pretty fragile: most options won't work as expected.  ToDo:
 557 -- figure out which ones & disallow them.
 558
 559 setOptions :: String -> GHCi ()
 560 setOptions ""
 561   = do st <- getGHCiState
 562        let opts = options st
 563        io $ putStrLn (showSDoc (
 564               text "options currently set: " <>
 565               if null opts
 566                    then text "none."
 567                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 568            ))
 569 setOptions str
 570   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 571       let (plus_opts, minus_opts)  = partition isPlus (words str)
 572       mapM setOpt plus_opts
 573
 574       -- now, the GHC flags
 575       pkgs_before <- io (readIORef v_Packages)
 576       leftovers   <- io (processArgs static_flags minus_opts [])
 577       pkgs_after  <- io (readIORef v_Packages)
 578
 579       -- update things if the users wants more packages
 580       when (pkgs_before /= pkgs_after) $
 581          newPackages (pkgs_after \\ pkgs_before)
 582
 583       -- then, dynamic flags
 584       io $ do
 585         restoreDynFlags
 586         leftovers <- processArgs dynamic_flags leftovers []
 587         saveDynFlags
 588
 589         if (not (null leftovers))
 590                 then throwDyn (CmdLineError ("unrecognised flags: " ++
 591                                                 unwords leftovers))
 592                 else return ()
 593
 594
 595 unsetOptions :: String -> GHCi ()
 596 unsetOptions str
 597   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 598        let opts = words str
 599            (minus_opts, rest1) = partition isMinus opts
 600            (plus_opts, rest2)  = partition isPlus rest1
 601
 602        if (not (null rest2))
 603           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 604           else do
 605
 606        mapM unsetOpt plus_opts
 607
 608        -- can't do GHC flags for now
 609        if (not (null minus_opts))
 610           then throwDyn (CmdLineError "can't unset GHC command-line flags")
 611           else return ()
 612
 613 isMinus ('-':s) = True
 614 isMinus _ = False
 615
 616 isPlus ('+':s) = True
 617 isPlus _ = False
 618
 619 setOpt ('+':str)
 620   = case strToGHCiOpt str of
 621         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 622         Just o  -> setOption o
 623
 624 unsetOpt ('+':str)
 625   = case strToGHCiOpt str of
 626         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 627         Just o  -> unsetOption o
 628
 629 strToGHCiOpt :: String -> (Maybe GHCiOption)
 630 strToGHCiOpt "s" = Just ShowTiming
 631 strToGHCiOpt "t" = Just ShowType
 632 strToGHCiOpt "r" = Just RevertCAFs
 633 strToGHCiOpt _   = Nothing
 634
 635 optToStr :: GHCiOption -> String
 636 optToStr ShowTiming = "s"
 637 optToStr ShowType   = "t"
 638 optToStr RevertCAFs = "r"
 639
 640 newPackages new_pkgs = do
 641   state <- getGHCiState
 642   dflags <- io getDynFlags
 643   cmstate1 <- io (cmUnload (cmstate state) dflags)
 644   setGHCiState state{ cmstate = cmstate1, targets = [] }
 645
 646   io $ do
 647     pkgs <- getPackageInfo
 648     flushPackageCache pkgs
 649
 650     new_pkg_info <- getPackageDetails new_pkgs
 651     mapM_ (linkPackage False) (reverse new_pkg_info)
 652
 653 -----------------------------------------------------------------------------
 654 -- GHCi monad
 655
 656 data GHCiState = GHCiState
 657      {
 658         targets        :: [FilePath],
 659         cmstate        :: CmState,
 660         options        :: [GHCiOption]
 661      }
 662
 663 data GHCiOption
 664         = ShowTiming            -- show time/allocs after evaluation
 665         | ShowType              -- show the type of expressions
 666         | RevertCAFs            -- revert CAFs after every evaluation
 667         deriving Eq
 668
 669 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
 670 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
 671
 672 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
 673
 674 startGHCi :: GHCi a -> GHCiState -> IO a
 675 startGHCi g state = do ref <- newIORef state; unGHCi g ref
 676
 677 instance Monad GHCi where
 678   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
 679   return a  = GHCi $ \s -> return a
 680
 681 getGHCiState   = GHCi $ \r -> readIORef r
 682 setGHCiState s = GHCi $ \r -> writeIORef r s
 683
 684 isOptionSet :: GHCiOption -> GHCi Bool
 685 isOptionSet opt
 686  = do st <- getGHCiState
 687       return (opt `elem` options st)
 688
 689 setOption :: GHCiOption -> GHCi ()
 690 setOption opt
 691  = do st <- getGHCiState
 692       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 693
 694 unsetOption :: GHCiOption -> GHCi ()
 695 unsetOption opt
 696  = do st <- getGHCiState
 697       setGHCiState (st{ options = filter (/= opt) (options st) })
 698
 699 io :: IO a -> GHCi a
 700 io m = GHCi { unGHCi = \s -> m >>= return }
 701
 702 -----------------------------------------------------------------------------
 703 -- recursive exception handlers
 704
 705 -- Don't forget to unblock async exceptions in the handler, or if we're
 706 -- in an exception loop (eg. let a = error a in a) the ^C exception
 707 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
 708
 709 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
 710 ghciHandle h (GHCi m) = GHCi $ \s ->
 711    Exception.catch (m s)
 712         (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
 713
 714 ghciUnblock :: GHCi a -> GHCi a
 715 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
 716
 717 -----------------------------------------------------------------------------
 718 -- package loader
 719
 720 -- Left: full path name of a .o file, including trailing .o
 721 -- Right: "unadorned" name of a .DLL/.so
 722 --        e.g.    On unix     "qt"  denotes "libqt.so"
 723 --                On WinDoze  "burble"  denotes "burble.DLL"
 724 --        addDLL is platform-specific and adds the lib/.so/.DLL
 725 --        suffixes platform-dependently; we don't do that here.
 726 --
 727 -- For dynamic objects only, try to find the object file in all the
 728 -- directories specified in v_Library_Paths before giving up.
 729
 730 type LibrarySpec
 731    = Either FilePath String
 732
 733 showLS (Left nm)  = "(static) " ++ nm
 734 showLS (Right nm) = "(dynamic) " ++ nm
 735
 736 linkPackages :: [LibrarySpec] -> [PackageConfig] -> IO ()
 737 linkPackages cmdline_lib_specs pkgs
 738    = do sequence_ [ linkPackage (name p `elem` loaded) p | p <- reverse pkgs ]
 739         lib_paths <- readIORef v_Library_paths
 740         mapM_ (preloadLib lib_paths) cmdline_lib_specs
 741         if (null cmdline_lib_specs)
 742            then return ()
 743            else do putStr "final link ... "
 744                    ok <- resolveObjs
 745                    if ok then putStrLn "done."
 746                          else throwDyn (InstallationError "linking extra libraries/objects failed")
 747      where
 748         -- Packages that are already linked into GHCi.  For mingw32, we only
 749         -- skip gmp and rts, since std and after need to load the msvcrt.dll
 750         -- library which std depends on.
 751         loaded
 752 #          ifndef mingw32_TARGET_OS
 753            = [ "gmp", "rts", "std", "concurrent", "posix", "text", "util" ]
 754 #          else
 755            = [ "gmp", "rts" ]
 756 #          endif
 757
 758         preloadLib :: [String] -> LibrarySpec -> IO ()
 759         preloadLib lib_paths lib_spec
 760            = do putStr ("Loading object " ++ showLS lib_spec ++ " ... ")
 761                 case lib_spec of
 762                    Left static_ish
 763                       -> do b <- preload_static lib_paths static_ish
 764                             putStrLn (if b then "done." else "not found")
 765                    Right dll_unadorned
 766                       -> -- We add "" to the set of paths to try, so that
 767                          -- if none of the real paths match, we force addDLL
 768                          -- to look in the default dynamic-link search paths.
 769                          do b <- preload_dynamic (lib_paths++[""]) dll_unadorned
 770                             when (not b) (cantFind lib_paths lib_spec)
 771                             putStrLn "done"
 772
 773         cantFind :: [String] -> LibrarySpec -> IO ()
 774         cantFind paths spec
 775            = do putStr ("failed.\nCan't find " ++ showLS spec
 776                         ++ " in directories:\n"
 777                         ++ unlines (map ("   "++) paths) )
 778                 give_up
 779
 780         -- not interested in the paths in the static case.
 781         preload_static paths name
 782            = do b <- doesFileExist name
 783                 if not b then return False
 784                          else loadObj name >> return True
 785
 786         preload_dynamic [] name
 787            = return False
 788         preload_dynamic (path:paths) rootname
 789            = do maybe_errmsg <- addDLL path rootname
 790                 if    maybe_errmsg /= nullPtr
 791                  then preload_dynamic paths rootname
 792                  else return True
 793
 794         give_up
 795            = (throwDyn . CmdLineError)
 796                 "user specified .o/.so/.DLL could not be loaded."
 797
 798
 799 linkPackage :: Bool -> PackageConfig -> IO ()
 800 -- ignore rts and gmp for now (ToDo; better?)
 801 linkPackage loaded_in_ghci pkg
 802    | name pkg `elem` ["rts", "gmp"]
 803    = return ()
 804    | otherwise
 805    = do putStr ("Loading package " ++ name pkg ++ " ... ")
 806         -- For each obj, try obj.o and if that fails, obj.so.
 807         -- Complication: all the .so's must be loaded before any of the .o's.
 808         let dirs      =  library_dirs pkg
 809         let objs      =  hs_libraries pkg ++ extra_libraries pkg
 810         classifieds   <- mapM (locateOneObj dirs) objs
 811
 812         -- Don't load the .so libs if this is a package GHCi is already
 813         -- linked against, because we'll already have the .so linked in.
 814         let (so_libs, obj_libs) = partition isRight classifieds
 815         let sos_first | loaded_in_ghci = obj_libs
 816                       | otherwise      = so_libs ++ obj_libs
 817
 818         mapM loadClassified sos_first
 819         putStr "linking ... "
 820         ok <- resolveObjs
 821         if ok then putStrLn "done."
 822               else panic ("can't load package `" ++ name pkg ++ "'")
 823      where
 824         isRight (Right _) = True
 825         isRight (Left _)  = False
 826
 827 loadClassified :: LibrarySpec -> IO ()
 828 loadClassified (Left obj_absolute_filename)
 829    = do loadObj obj_absolute_filename
 830 loadClassified (Right dll_unadorned)
 831    = do maybe_errmsg <- addDLL "" dll_unadorned -- doesn't seem right to me
 832         if    maybe_errmsg == nullPtr
 833          then return ()
 834          else do str <- peekCString maybe_errmsg
 835                  throwDyn (CmdLineError ("can't load .so/.DLL for: "
 836                                        ++ dll_unadorned ++ " (" ++ str ++ ")" ))
 837
 838 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
 839 locateOneObj []     obj
 840    = return (Right obj) -- we assume
 841 locateOneObj (d:ds) obj
 842    = do let path = d ++ '/':obj ++ ".o"
 843         b <- doesFileExist path
 844         if b then return (Left path) else locateOneObj ds obj
 845
 846 -----------------------------------------------------------------------------
 847 -- timing & statistics
 848
 849 timeIt :: GHCi a -> GHCi a
 850 timeIt action
 851   = do b <- isOptionSet ShowTiming
 852        if not b
 853           then action
 854           else do allocs1 <- io $ getAllocations
 855                   time1   <- io $ getCPUTime
 856                   a <- action
 857                   allocs2 <- io $ getAllocations
 858                   time2   <- io $ getCPUTime
 859                   io $ printTimes (allocs2 - allocs1) (time2 - time1)
 860                   return a
 861
 862 foreign import "getAllocations" getAllocations :: IO Int
 863
 864 printTimes :: Int -> Integer -> IO ()
 865 printTimes allocs psecs
 866    = do let secs = (fromIntegral psecs / (10^12)) :: Float
 867             secs_str = showFFloat (Just 2) secs
 868         putStrLn (showSDoc (
 869                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 870                          int allocs <+> text "bytes")))
 871
 872 -----------------------------------------------------------------------------
 873 -- reverting CAFs
 874
 875 foreign import revertCAFs :: IO ()      -- make it "safe", just in case