ghc/compiler/ghci/InteractiveUI.hs

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