ghc/compiler/ghci/InteractiveUI.hs

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