ghc/compiler/ghci/InteractiveUI.hs

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