ghc/compiler/ghci/InteractiveUI.hs

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