ghc/compiler/ghci/InteractiveUI.hs

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