ghc/compiler/ghci/InteractiveUI.hs

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