ghc/compiler/ghci/InteractiveUI.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: InteractiveUI.hs,v 1.32 2001/02/06 11:57:30 simonmar Exp $
   3 --
   4 -- GHC Interactive User Interface
   5 --
   6 -- (c) The GHC Team 2000
   7 --
   8 -----------------------------------------------------------------------------
   9
  10 module InteractiveUI (interactiveUI) where
  11
  12 #include "HsVersions.h"
  13
  14 import CompManager
  15 import CmStaticInfo
  16 import ByteCodeLink
  17 import DriverFlags
  18 import DriverState
  19 import DriverUtil
  20 import Type
  21 import Linker
  22 import Finder
  23 import Module
  24 import Outputable
  25 import Util
  26 import PprType          {- instance Outputable Type; do not delete -}
  27 import Panic            ( GhcException(..) )
  28
  29 import Exception
  30 #ifndef NO_READLINE
  31 import Readline
  32 #endif
  33 import IOExts
  34
  35 import Numeric
  36 import List
  37 import System
  38 import CPUTime
  39 import Directory
  40 import IO
  41 import Char
  42 import Monad ( when )
  43
  44
  45 -----------------------------------------------------------------------------
  46
  47 ghciWelcomeMsg = "\
  48 \ _____  __   __  ____         _________________________________________________\n\
  49 \(|      ||   || (|  |)        GHC Interactive, version 5.00                    \n\
  50 \||  __  ||___|| ||     ()     For Haskell 98.                                  \n\
  51 \||   |) ||---|| ||     ||     http://www.haskell.org/ghc                       \n\
  52 \||   || ||   || ||     (|     Bug reports to: glasgow-haskell-bugs@haskell.org \n\
  53 \(|___|| ||   || (|__|) \\\\______________________________________________________\n"
  54
  55 commands :: [(String, String -> GHCi Bool)]
  56 commands = [
  57   ("add",       keepGoing addModule),
  58   ("cd",        keepGoing changeDirectory),
  59   ("help",      keepGoing help),
  60   ("?",         keepGoing help),
  61   ("load",      keepGoing loadModule),
  62   ("module",    keepGoing setContext),
  63   ("reload",    keepGoing reloadModule),
  64   ("set",       keepGoing setOptions),
  65   ("type",      keepGoing typeOfExpr),
  66   ("unset",     keepGoing unsetOptions),
  67   ("quit",      quit)
  68   ]
  69
  70 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
  71 keepGoing a str = a str >> return False
  72
  73 shortHelpText = "use :? for help.\n"
  74
  75 helpText = "\
  76 \ Commands available from the prompt:\n\
  77 \\
  78 \   <expr>              evaluate <expr>\n\
  79 \   :add <filename>     add a module to the current set\n\
  80 \   :cd <dir>           change directory to <dir>\n\
  81 \   :help, :?           display this list of commands\n\
  82 \   :load <filename>    load a module (and it dependents)\n\
  83 \   :module <mod>       set the context for expression evaluation to <mod>\n\
  84 \   :reload             reload the current module set\n\
  85 \   :set <option> ...   set options\n\
  86 \   :unset <option> ... unset options\n\
  87 \   :type <expr>        show the type of <expr>\n\
  88 \   :quit               exit GHCi\n\
  89 \   :!<command>         run the shell command <command>\n\
  90 \\
  91 \ Options for `:set' and `:unset':\n\
  92 \\
  93 \    +s                 print timing/memory stats after each evaluation\n\
  94 \    +t                 print type after evaluation\n\
  95 \    +r                 revert top-level expressions after each evaluation\n\
  96 \    -<flags>           most GHC command line flags can also be set here\n\
  97 \                         (eg. -v2, -fglasgow-exts, etc.)\n\
  98 \"
  99
 100 interactiveUI :: CmState -> Maybe FilePath -> IO ()
 101 interactiveUI cmstate mod = do
 102    hPutStrLn stdout ghciWelcomeMsg
 103    hFlush stdout
 104    hSetBuffering stdout NoBuffering
 105
 106    -- link in the available packages
 107    pkgs <- getPackageInfo
 108    linkPackages (reverse pkgs)
 109
 110    (cmstate, ok, mods) <-
 111         case mod of
 112              Nothing  -> return (cmstate, True, [])
 113              Just m -> cmLoadModule cmstate m
 114
 115 #ifndef NO_READLINE
 116    Readline.initialize
 117 #endif
 118
 119    prel <- moduleNameToModule defaultCurrentModuleName
 120    writeIORef defaultCurrentModule prel
 121
 122    dflags <- getDynFlags
 123
 124    (cmstate, maybe_stuff) <- cmGetExpr cmstate dflags False prel
 125                                 "PrelHandle.hFlush PrelHandle.stdout"
 126    case maybe_stuff of
 127         Nothing -> return ()
 128         Just (hv,_,_) -> writeIORef flush_stdout hv
 129
 130    (cmstate, maybe_stuff) <- cmGetExpr cmstate dflags False prel
 131                                 "PrelHandle.hFlush PrelHandle.stdout"
 132    case maybe_stuff of
 133         Nothing -> return ()
 134         Just (hv,_,_) -> writeIORef flush_stderr hv
 135
 136    let this_mod = case mods of
 137                       []   -> prel
 138                       m:ms -> m
 139
 140    (unGHCi uiLoop) GHCiState{ modules = mods,
 141                               current_module = this_mod,
 142                               target = mod,
 143                               cmstate = cmstate,
 144                               options = [ShowTiming],
 145                               last_expr = Nothing}
 146    return ()
 147
 148
 149 uiLoop :: GHCi ()
 150 uiLoop = do
 151   st <- getGHCiState
 152 #ifndef NO_READLINE
 153   l <- io (readline (moduleUserString (current_module st) ++ "> "))
 154 #else
 155   l_ok <- io (hGetLine stdin)
 156   let l = Just l_ok
 157 #endif
 158   case l of {
 159     Nothing -> exitGHCi;
 160     Just l ->
 161
 162   case remove_spaces l of {
 163     "" -> uiLoop;
 164     l  -> do
 165 #ifndef NO_READLINE
 166           io (addHistory l)
 167 #endif
 168           quit <- runCommand l
 169           if quit then exitGHCi else uiLoop
 170    }}
 171
 172
 173 exitGHCi = io $ do putStrLn "Leaving GHCi."
 174
 175 -- Top level exception handler, just prints out the exception
 176 -- and carries on.
 177 runCommand :: String -> GHCi Bool
 178 runCommand c =
 179   ghciHandle (
 180      \other_exception
 181         -> io (putStrLn (show other_exception)) >> return False
 182   ) $
 183   ghciHandleDyn
 184     (\dyn -> case dyn of
 185                 PhaseFailed phase code ->
 186                         io ( putStrLn ("Phase " ++ phase ++ " failed (code "
 187                                         ++ show code ++ ")"))
 188                 Interrupted -> io (putStrLn "Interrupted.")
 189                 _ -> io (putStrLn (show (dyn :: GhcException)))
 190              >> return False
 191     ) $
 192    doCommand c
 193
 194 doCommand (':' : command) = specialCommand command
 195 doCommand expr
 196    = do expr_expanded <- expandExpr expr
 197         -- io (putStrLn ( "Before: " ++ expr ++ "\nAfter:  " ++ expr_expanded))
 198         expr_ok <- timeIt (do stuff <- evalExpr expr_expanded
 199                               finishEvalExpr stuff)
 200         when expr_ok (rememberExpr expr_expanded)
 201         return False
 202
 203 -- possibly print the type and revert CAFs after evaluating an expression
 204 finishEvalExpr Nothing = return False
 205 finishEvalExpr (Just (unqual,ty))
 206  = do b <- isOptionSet ShowType
 207       io (when b (printForUser stdout unqual (text "::" <+> ppr ty)))
 208       b <- isOptionSet RevertCAFs
 209       io (when b revertCAFs)
 210       return True
 211
 212 -- Returned Bool indicates whether or not the expr was successfully
 213 -- parsed, renamed and typechecked.
 214 evalExpr :: String -> GHCi (Maybe (PrintUnqualified,Type))
 215 evalExpr expr
 216  | null (filter (not.isSpace) expr)
 217  = return Nothing
 218  | otherwise
 219  = do st <- getGHCiState
 220       dflags <- io (getDynFlags)
 221       (new_cmstate, maybe_stuff) <-
 222          io (cmGetExpr (cmstate st) dflags True (current_module st) expr)
 223       setGHCiState st{cmstate = new_cmstate}
 224       case maybe_stuff of
 225          Nothing -> return Nothing
 226          Just (hv, unqual, ty) -> do io (cmRunExpr hv)
 227                                      flushEverything
 228                                      return (Just (unqual,ty))
 229
 230 flushEverything :: GHCi ()
 231 flushEverything
 232    = io $ do flush_so <- readIORef flush_stdout
 233              cmRunExpr flush_so
 234              flush_se <- readIORef flush_stdout
 235              cmRunExpr flush_se
 236
 237 specialCommand :: String -> GHCi Bool
 238 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 239 specialCommand str = do
 240   let (cmd,rest) = break isSpace str
 241   case [ (s,f) | (s,f) <- commands, prefixMatch cmd s ] of
 242      []      -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
 243                                     ++ shortHelpText) >> return False)
 244      [(_,f)] -> f (dropWhile isSpace rest)
 245      cs      -> io (hPutStrLn stdout ("prefix " ++ cmd ++
 246                                       " matches multiple commands (" ++
 247                                        foldr1 (\a b -> a ++ ',':b) (map fst cs)
 248                                          ++ ")") >> return False)
 249
 250 noArgs c = io (hPutStrLn stdout ("command `:" ++ c ++ "' takes no arguments"))
 251
 252 -----------------------------------------------------------------------------
 253 -- Commands
 254
 255 help :: String -> GHCi ()
 256 help _ = io (putStr helpText)
 257
 258 addModule :: String -> GHCi ()
 259 addModule _ = throwDyn (OtherError ":add not implemented")
 260
 261 setContext :: String -> GHCi ()
 262 setContext ""
 263   = throwDyn (OtherError "syntax: `:m <module>'")
 264 setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m))
 265   = throwDyn (OtherError ("strange looking module name: `" ++ m ++ "'"))
 266 setContext mn
 267   = do m <- io (moduleNameToModule (mkModuleName mn))
 268        st <- getGHCiState
 269        setGHCiState st{current_module = m}
 270
 271 moduleNameToModule :: ModuleName -> IO Module
 272 moduleNameToModule mn
 273  = do maybe_stuff <- findModule mn
 274       case maybe_stuff of
 275          Nothing -> throwDyn (OtherError ("can't find module `"
 276                                             ++ moduleNameUserString mn ++ "'"))
 277          Just (m,_) -> return m
 278
 279 changeDirectory :: String -> GHCi ()
 280 changeDirectory d = io (setCurrentDirectory d)
 281
 282 loadModule :: String -> GHCi ()
 283 loadModule path = timeIt (loadModule' path)
 284
 285 loadModule' path = do
 286   state <- getGHCiState
 287   cmstate1 <- io (cmUnload (cmstate state))
 288   io (revertCAFs)                       -- always revert CAFs on load.
 289   (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
 290
 291   def_mod <- io (readIORef defaultCurrentModule)
 292
 293   let new_state = state{
 294                         cmstate = cmstate2,
 295                         modules = mods,
 296                         current_module = case mods of
 297                                            [] -> def_mod
 298                                            xs -> head xs,
 299                         target = Just path
 300                    }
 301   setGHCiState new_state
 302
 303   let mod_commas
 304         | null mods = text "none."
 305         | otherwise = hsep (
 306             punctuate comma (map (text.moduleUserString) mods)) <> text "."
 307   case ok of
 308     False ->
 309        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 310     True  ->
 311        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 312
 313 reloadModule :: String -> GHCi ()
 314 reloadModule "" = do
 315   state <- getGHCiState
 316   case target state of
 317    Nothing -> io (putStr "no current target\n")
 318    Just path
 319       -> do io (revertCAFs)             -- always revert CAFs on reload.
 320             (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
 321             def_mod <- io (readIORef defaultCurrentModule)
 322             setGHCiState
 323                state{cmstate=new_cmstate,
 324                      modules = mods,
 325                      current_module = case mods of
 326                                          [] -> def_mod
 327                                          xs -> head xs
 328                     }
 329
 330 reloadModule _ = noArgs ":reload"
 331
 332 typeOfExpr :: String -> GHCi ()
 333 typeOfExpr str
 334   = do st <- getGHCiState
 335        dflags <- io (getDynFlags)
 336        (new_cmstate, maybe_ty) <- io (cmGetExpr (cmstate st) dflags False
 337                                          (current_module st) str)
 338        setGHCiState st{cmstate = new_cmstate}
 339        case maybe_ty of
 340          Nothing -> return ()
 341          Just (_, unqual, ty) -> io (printForUser stdout unqual (ppr ty))
 342
 343 quit :: String -> GHCi Bool
 344 quit _ = return True
 345
 346 shellEscape :: String -> GHCi Bool
 347 shellEscape str = io (system str >> return False)
 348
 349 ----------------------------------------------------------------------------
 350 -- Code for `:set'
 351
 352 -- set options in the interpreter.  Syntax is exactly the same as the
 353 -- ghc command line, except that certain options aren't available (-C,
 354 -- -E etc.)
 355 --
 356 -- This is pretty fragile: most options won't work as expected.  ToDo:
 357 -- figure out which ones & disallow them.
 358
 359 setOptions :: String -> GHCi ()
 360 setOptions ""
 361   = do st <- getGHCiState
 362        let opts = options st
 363        io $ putStrLn (showSDoc (
 364               text "options currently set: " <>
 365               if null opts
 366                    then text "none."
 367                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 368            ))
 369 setOptions str
 370   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 371        let opts = words str
 372            (minus_opts, rest1) = partition isMinus opts
 373            (plus_opts, rest2)  = partition isPlus rest1
 374
 375        if (not (null rest2))
 376           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 377           else do
 378
 379        mapM setOpt plus_opts
 380
 381        -- now, the GHC flags
 382        io (do -- first, static flags
 383               leftovers <- processArgs static_flags minus_opts []
 384
 385               -- then, dynamic flags
 386               dyn_flags <- readIORef v_InitDynFlags
 387               writeIORef v_DynFlags dyn_flags
 388               leftovers <- processArgs dynamic_flags leftovers []
 389               dyn_flags <- readIORef v_DynFlags
 390               writeIORef v_InitDynFlags dyn_flags
 391
 392               if (not (null leftovers))
 393                  then throwDyn (OtherError ("unrecognised flags: " ++
 394                                                 unwords leftovers))
 395                  else return ()
 396          )
 397
 398 unsetOptions :: String -> GHCi ()
 399 unsetOptions str
 400   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 401        let opts = words str
 402            (minus_opts, rest1) = partition isMinus opts
 403            (plus_opts, rest2)  = partition isPlus rest1
 404
 405        if (not (null rest2))
 406           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 407           else do
 408
 409        mapM unsetOpt plus_opts
 410
 411        -- can't do GHC flags for now
 412        if (not (null minus_opts))
 413           then throwDyn (OtherError "can't unset GHC command-line flags")
 414           else return ()
 415
 416 isMinus ('-':s) = True
 417 isMinus _ = False
 418
 419 isPlus ('+':s) = True
 420 isPlus _ = False
 421
 422 setOpt ('+':str)
 423   = case strToGHCiOpt str of
 424         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 425         Just o  -> setOption o
 426
 427 unsetOpt ('+':str)
 428   = case strToGHCiOpt str of
 429         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 430         Just o  -> unsetOption o
 431
 432 strToGHCiOpt :: String -> (Maybe GHCiOption)
 433 strToGHCiOpt "s" = Just ShowTiming
 434 strToGHCiOpt "t" = Just ShowType
 435 strToGHCiOpt "r" = Just RevertCAFs
 436 strToGHCiOpt _   = Nothing
 437
 438 optToStr :: GHCiOption -> String
 439 optToStr ShowTiming = "s"
 440 optToStr ShowType   = "t"
 441 optToStr RevertCAFs = "r"
 442
 443 -----------------------------------------------------------------------------
 444 -- Code to do last-expression-entered stuff.  (a.k.a the $$ facility)
 445
 446 -- Take a string and replace $$s in it with the last expr, if any.
 447 expandExpr :: String -> GHCi String
 448 expandExpr str
 449    = do mle <- getLastExpr
 450         return (outside mle str)
 451      where
 452         outside mle ('$':'$':cs)
 453            = case mle of
 454                 Just le -> " (" ++ le ++ ") " ++ outside mle cs
 455                 Nothing -> outside mle cs
 456
 457         outside mle []           = []
 458         outside mle ('"':str)    = '"' : inside2 mle str   -- "
 459         outside mle ('\'':str)   = '\'' : inside1 mle str   -- '
 460         outside mle (c:cs)       = c : outside mle cs
 461
 462         inside2 mle ('"':cs)  = '"' : outside mle cs   -- "
 463         inside2 mle (c:cs)    = c : inside2 mle cs
 464         inside2 mle []        = []
 465
 466         inside1 mle ('\'':cs) = '\'': outside mle cs
 467         inside1 mle (c:cs)    = c : inside1 mle cs
 468         inside1 mle []        = []
 469
 470
 471 rememberExpr :: String -> GHCi ()
 472 rememberExpr str
 473    = do let cleaned = (clean . reverse . clean . reverse) str
 474         let forget_me_not | null cleaned = Nothing
 475                           | otherwise    = Just cleaned
 476         setLastExpr forget_me_not
 477      where
 478         clean = dropWhile isSpace
 479
 480
 481 -----------------------------------------------------------------------------
 482 -- GHCi monad
 483
 484 data GHCiState = GHCiState
 485      {
 486         modules        :: [Module],
 487         current_module :: Module,
 488         target         :: Maybe FilePath,
 489         cmstate        :: CmState,
 490         options        :: [GHCiOption],
 491         last_expr      :: Maybe String
 492      }
 493
 494 data GHCiOption
 495         = ShowTiming            -- show time/allocs after evaluation
 496         | ShowType              -- show the type of expressions
 497         | RevertCAFs            -- revert CAFs after every evaluation
 498         deriving Eq
 499
 500 defaultCurrentModuleName = mkModuleName "Prelude"
 501 GLOBAL_VAR(defaultCurrentModule, error "no defaultCurrentModule", Module)
 502
 503 GLOBAL_VAR(flush_stdout, error "no flush_stdout", HValue)
 504 GLOBAL_VAR(flush_stderr, error "no flush_stdout", HValue)
 505
 506 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
 507
 508 instance Monad GHCi where
 509   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
 510   return a  = GHCi $ \s -> return (s,a)
 511
 512 getGHCiState   = GHCi $ \s -> return (s,s)
 513 setGHCiState s = GHCi $ \_ -> return (s,())
 514
 515 isOptionSet :: GHCiOption -> GHCi Bool
 516 isOptionSet opt
 517  = do st <- getGHCiState
 518       return (opt `elem` options st)
 519
 520 setOption :: GHCiOption -> GHCi ()
 521 setOption opt
 522  = do st <- getGHCiState
 523       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 524
 525 unsetOption :: GHCiOption -> GHCi ()
 526 unsetOption opt
 527  = do st <- getGHCiState
 528       setGHCiState (st{ options = filter (/= opt) (options st) })
 529
 530 getLastExpr :: GHCi (Maybe String)
 531 getLastExpr
 532  = do st <- getGHCiState ; return (last_expr st)
 533
 534 setLastExpr :: Maybe String -> GHCi ()
 535 setLastExpr last_expr
 536  = do st <- getGHCiState ; setGHCiState (st{last_expr = last_expr})
 537
 538 io m = GHCi $ \s -> m >>= \a -> return (s,a)
 539
 540 ghciHandle h (GHCi m) = GHCi $ \s ->
 541    Exception.catch (m s) (\e -> unGHCi (h e) s)
 542 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
 543    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
 544
 545 -----------------------------------------------------------------------------
 546 -- package loader
 547
 548 linkPackages :: [Package] -> IO ()
 549 linkPackages pkgs = mapM_ linkPackage pkgs
 550
 551 linkPackage :: Package -> IO ()
 552 -- ignore rts and gmp for now (ToDo; better?)
 553 linkPackage pkg | name pkg `elem` ["rts", "gmp"] = return ()
 554 linkPackage pkg = do
 555   putStr ("Loading package " ++ name pkg ++ " ... ")
 556   let dirs = library_dirs pkg
 557   let objs = map (++".o") (hs_libraries pkg ++ extra_libraries pkg)
 558   mapM (linkOneObj dirs) objs
 559   putStr "resolving ... "
 560   resolveObjs
 561   putStrLn "done."
 562
 563 linkOneObj dirs obj = do
 564   filename <- findFile dirs obj
 565   loadObj filename
 566
 567 findFile [] obj = throwDyn (OtherError ("can't find " ++ obj))
 568 findFile (d:ds) obj = do
 569   let path = d ++ '/':obj
 570   b <- doesFileExist path
 571   if b then return path else findFile ds obj
 572
 573 -----------------------------------------------------------------------------
 574 -- timing & statistics
 575
 576 timeIt :: GHCi a -> GHCi a
 577 timeIt action
 578   = do b <- isOptionSet ShowTiming
 579        if not b
 580           then action
 581           else do allocs1 <- io $ getAllocations
 582                   time1   <- io $ getCPUTime
 583                   a <- action
 584                   allocs2 <- io $ getAllocations
 585                   time2   <- io $ getCPUTime
 586                   io $ printTimes (allocs2 - allocs1) (time2 - time1)
 587                   return a
 588
 589 foreign import "getAllocations" getAllocations :: IO Int
 590
 591 printTimes :: Int -> Integer -> IO ()
 592 printTimes allocs psecs
 593    = do let secs = (fromIntegral psecs / (10^12)) :: Float
 594             secs_str = showFFloat (Just 2) secs
 595         putStrLn (showSDoc (
 596                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 597                          int allocs <+> text "bytes")))
 598
 599 -----------------------------------------------------------------------------
 600 -- reverting CAFs
 601
 602 foreign import revertCAFs :: IO ()      -- make it "safe", just in case