ghc/compiler/ghci/InteractiveUI.hs

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