ghc/compiler/ghci/InteractiveUI.hs

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