ghc/compiler/ghci/InteractiveUI.hs

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