ghc/compiler/ghci/InteractiveUI.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: InteractiveUI.hs,v 1.33 2001/02/06 16:22:12 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 ('-':'-':_) = return False    -- comments, useful in scripts
 196 doCommand expr
 197    = do expr_expanded <- expandExpr expr
 198         -- io (putStrLn ( "Before: " ++ expr ++ "\nAfter:  " ++ expr_expanded))
 199         expr_ok <- timeIt (do stuff <- evalExpr expr_expanded
 200                               finishEvalExpr stuff)
 201         when expr_ok (rememberExpr expr_expanded)
 202         return False
 203
 204 -- possibly print the type and revert CAFs after evaluating an expression
 205 finishEvalExpr Nothing = return False
 206 finishEvalExpr (Just (unqual,ty))
 207  = do b <- isOptionSet ShowType
 208       io (when b (printForUser stdout unqual (text "::" <+> ppr ty)))
 209       b <- isOptionSet RevertCAFs
 210       io (when b revertCAFs)
 211       return True
 212
 213 -- Returned Bool indicates whether or not the expr was successfully
 214 -- parsed, renamed and typechecked.
 215 evalExpr :: String -> GHCi (Maybe (PrintUnqualified,Type))
 216 evalExpr expr
 217  | null (filter (not.isSpace) expr)
 218  = return Nothing
 219  | otherwise
 220  = do st <- getGHCiState
 221       dflags <- io (getDynFlags)
 222       (new_cmstate, maybe_stuff) <-
 223          io (cmGetExpr (cmstate st) dflags True (current_module st) expr)
 224       setGHCiState st{cmstate = new_cmstate}
 225       case maybe_stuff of
 226          Nothing -> return Nothing
 227          Just (hv, unqual, ty) -> do io (cmRunExpr hv)
 228                                      flushEverything
 229                                      return (Just (unqual,ty))
 230
 231 flushEverything :: GHCi ()
 232 flushEverything
 233    = io $ do flush_so <- readIORef flush_stdout
 234              cmRunExpr flush_so
 235              flush_se <- readIORef flush_stdout
 236              cmRunExpr flush_se
 237
 238 specialCommand :: String -> GHCi Bool
 239 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 240 specialCommand str = do
 241   let (cmd,rest) = break isSpace str
 242   case [ (s,f) | (s,f) <- commands, prefixMatch cmd s ] of
 243      []      -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
 244                                     ++ shortHelpText) >> return False)
 245      [(_,f)] -> f (dropWhile isSpace rest)
 246      cs      -> io (hPutStrLn stdout ("prefix " ++ cmd ++
 247                                       " matches multiple commands (" ++
 248                                        foldr1 (\a b -> a ++ ',':b) (map fst cs)
 249                                          ++ ")") >> return False)
 250
 251 noArgs c = io (hPutStrLn stdout ("command `:" ++ c ++ "' takes no arguments"))
 252
 253 -----------------------------------------------------------------------------
 254 -- Commands
 255
 256 help :: String -> GHCi ()
 257 help _ = io (putStr helpText)
 258
 259 addModule :: String -> GHCi ()
 260 addModule _ = throwDyn (OtherError ":add not implemented")
 261
 262 setContext :: String -> GHCi ()
 263 setContext ""
 264   = throwDyn (OtherError "syntax: `:m <module>'")
 265 setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m))
 266   = throwDyn (OtherError ("strange looking module name: `" ++ m ++ "'"))
 267 setContext mn
 268   = do m <- io (moduleNameToModule (mkModuleName mn))
 269        st <- getGHCiState
 270        setGHCiState st{current_module = m}
 271
 272 moduleNameToModule :: ModuleName -> IO Module
 273 moduleNameToModule mn
 274  = do maybe_stuff <- findModule mn
 275       case maybe_stuff of
 276          Nothing -> throwDyn (OtherError ("can't find module `"
 277                                             ++ moduleNameUserString mn ++ "'"))
 278          Just (m,_) -> return m
 279
 280 changeDirectory :: String -> GHCi ()
 281 changeDirectory d = io (setCurrentDirectory d)
 282
 283 loadModule :: String -> GHCi ()
 284 loadModule path = timeIt (loadModule' path)
 285
 286 loadModule' path = do
 287   state <- getGHCiState
 288   cmstate1 <- io (cmUnload (cmstate state))
 289   io (revertCAFs)                       -- always revert CAFs on load.
 290   (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
 291
 292   def_mod <- io (readIORef defaultCurrentModule)
 293
 294   let new_state = state{
 295                         cmstate = cmstate2,
 296                         modules = mods,
 297                         current_module = case mods of
 298                                            [] -> def_mod
 299                                            xs -> head xs,
 300                         target = Just path
 301                    }
 302   setGHCiState new_state
 303
 304   let mod_commas
 305         | null mods = text "none."
 306         | otherwise = hsep (
 307             punctuate comma (map (text.moduleUserString) mods)) <> text "."
 308   case ok of
 309     False ->
 310        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 311     True  ->
 312        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 313
 314 reloadModule :: String -> GHCi ()
 315 reloadModule "" = do
 316   state <- getGHCiState
 317   case target state of
 318    Nothing -> io (putStr "no current target\n")
 319    Just path
 320       -> do io (revertCAFs)             -- always revert CAFs on reload.
 321             (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
 322             def_mod <- io (readIORef defaultCurrentModule)
 323             setGHCiState
 324                state{cmstate=new_cmstate,
 325                      modules = mods,
 326                      current_module = case mods of
 327                                          [] -> def_mod
 328                                          xs -> head xs
 329                     }
 330
 331 reloadModule _ = noArgs ":reload"
 332
 333 typeOfExpr :: String -> GHCi ()
 334 typeOfExpr str
 335   = do st <- getGHCiState
 336        dflags <- io (getDynFlags)
 337        (new_cmstate, maybe_ty) <- io (cmGetExpr (cmstate st) dflags False
 338                                          (current_module st) str)
 339        setGHCiState st{cmstate = new_cmstate}
 340        case maybe_ty of
 341          Nothing -> return ()
 342          Just (_, unqual, ty) -> io (printForUser stdout unqual (ppr ty))
 343
 344 quit :: String -> GHCi Bool
 345 quit _ = return True
 346
 347 shellEscape :: String -> GHCi Bool
 348 shellEscape str = io (system str >> return False)
 349
 350 ----------------------------------------------------------------------------
 351 -- Code for `:set'
 352
 353 -- set options in the interpreter.  Syntax is exactly the same as the
 354 -- ghc command line, except that certain options aren't available (-C,
 355 -- -E etc.)
 356 --
 357 -- This is pretty fragile: most options won't work as expected.  ToDo:
 358 -- figure out which ones & disallow them.
 359
 360 setOptions :: String -> GHCi ()
 361 setOptions ""
 362   = do st <- getGHCiState
 363        let opts = options st
 364        io $ putStrLn (showSDoc (
 365               text "options currently set: " <>
 366               if null opts
 367                    then text "none."
 368                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 369            ))
 370 setOptions str
 371   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 372        let opts = words str
 373            (minus_opts, rest1) = partition isMinus opts
 374            (plus_opts, rest2)  = partition isPlus rest1
 375
 376        if (not (null rest2))
 377           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 378           else do
 379
 380        mapM setOpt plus_opts
 381
 382        -- now, the GHC flags
 383        io (do -- first, static flags
 384               leftovers <- processArgs static_flags minus_opts []
 385
 386               -- then, dynamic flags
 387               dyn_flags <- readIORef v_InitDynFlags
 388               writeIORef v_DynFlags dyn_flags
 389               leftovers <- processArgs dynamic_flags leftovers []
 390               dyn_flags <- readIORef v_DynFlags
 391               writeIORef v_InitDynFlags dyn_flags
 392
 393               if (not (null leftovers))
 394                  then throwDyn (OtherError ("unrecognised flags: " ++
 395                                                 unwords leftovers))
 396                  else return ()
 397          )
 398
 399 unsetOptions :: String -> GHCi ()
 400 unsetOptions str
 401   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 402        let opts = words str
 403            (minus_opts, rest1) = partition isMinus opts
 404            (plus_opts, rest2)  = partition isPlus rest1
 405
 406        if (not (null rest2))
 407           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 408           else do
 409
 410        mapM unsetOpt plus_opts
 411
 412        -- can't do GHC flags for now
 413        if (not (null minus_opts))
 414           then throwDyn (OtherError "can't unset GHC command-line flags")
 415           else return ()
 416
 417 isMinus ('-':s) = True
 418 isMinus _ = False
 419
 420 isPlus ('+':s) = True
 421 isPlus _ = False
 422
 423 setOpt ('+':str)
 424   = case strToGHCiOpt str of
 425         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 426         Just o  -> setOption o
 427
 428 unsetOpt ('+':str)
 429   = case strToGHCiOpt str of
 430         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 431         Just o  -> unsetOption o
 432
 433 strToGHCiOpt :: String -> (Maybe GHCiOption)
 434 strToGHCiOpt "s" = Just ShowTiming
 435 strToGHCiOpt "t" = Just ShowType
 436 strToGHCiOpt "r" = Just RevertCAFs
 437 strToGHCiOpt _   = Nothing
 438
 439 optToStr :: GHCiOption -> String
 440 optToStr ShowTiming = "s"
 441 optToStr ShowType   = "t"
 442 optToStr RevertCAFs = "r"
 443
 444 -----------------------------------------------------------------------------
 445 -- Code to do last-expression-entered stuff.  (a.k.a the $$ facility)
 446
 447 -- Take a string and replace $$s in it with the last expr, if any.
 448 expandExpr :: String -> GHCi String
 449 expandExpr str
 450    = do mle <- getLastExpr
 451         return (outside mle str)
 452      where
 453         outside mle ('$':'$':cs)
 454            = case mle of
 455                 Just le -> " (" ++ le ++ ") " ++ outside mle cs
 456                 Nothing -> outside mle cs
 457
 458         outside mle []           = []
 459         outside mle ('"':str)    = '"' : inside2 mle str   -- "
 460         outside mle ('\'':str)   = '\'' : inside1 mle str   -- '
 461         outside mle (c:cs)       = c : outside mle cs
 462
 463         inside2 mle ('"':cs)  = '"' : outside mle cs   -- "
 464         inside2 mle (c:cs)    = c : inside2 mle cs
 465         inside2 mle []        = []
 466
 467         inside1 mle ('\'':cs) = '\'': outside mle cs
 468         inside1 mle (c:cs)    = c : inside1 mle cs
 469         inside1 mle []        = []
 470
 471
 472 rememberExpr :: String -> GHCi ()
 473 rememberExpr str
 474    = do let cleaned = (clean . reverse . clean . reverse) str
 475         let forget_me_not | null cleaned = Nothing
 476                           | otherwise    = Just cleaned
 477         setLastExpr forget_me_not
 478      where
 479         clean = dropWhile isSpace
 480
 481
 482 -----------------------------------------------------------------------------
 483 -- GHCi monad
 484
 485 data GHCiState = GHCiState
 486      {
 487         modules        :: [Module],
 488         current_module :: Module,
 489         target         :: Maybe FilePath,
 490         cmstate        :: CmState,
 491         options        :: [GHCiOption],
 492         last_expr      :: Maybe String
 493      }
 494
 495 data GHCiOption
 496         = ShowTiming            -- show time/allocs after evaluation
 497         | ShowType              -- show the type of expressions
 498         | RevertCAFs            -- revert CAFs after every evaluation
 499         deriving Eq
 500
 501 defaultCurrentModuleName = mkModuleName "Prelude"
 502 GLOBAL_VAR(defaultCurrentModule, error "no defaultCurrentModule", Module)
 503
 504 GLOBAL_VAR(flush_stdout, error "no flush_stdout", HValue)
 505 GLOBAL_VAR(flush_stderr, error "no flush_stdout", HValue)
 506
 507 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
 508
 509 instance Monad GHCi where
 510   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
 511   return a  = GHCi $ \s -> return (s,a)
 512
 513 getGHCiState   = GHCi $ \s -> return (s,s)
 514 setGHCiState s = GHCi $ \_ -> return (s,())
 515
 516 isOptionSet :: GHCiOption -> GHCi Bool
 517 isOptionSet opt
 518  = do st <- getGHCiState
 519       return (opt `elem` options st)
 520
 521 setOption :: GHCiOption -> GHCi ()
 522 setOption opt
 523  = do st <- getGHCiState
 524       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 525
 526 unsetOption :: GHCiOption -> GHCi ()
 527 unsetOption opt
 528  = do st <- getGHCiState
 529       setGHCiState (st{ options = filter (/= opt) (options st) })
 530
 531 getLastExpr :: GHCi (Maybe String)
 532 getLastExpr
 533  = do st <- getGHCiState ; return (last_expr st)
 534
 535 setLastExpr :: Maybe String -> GHCi ()
 536 setLastExpr last_expr
 537  = do st <- getGHCiState ; setGHCiState (st{last_expr = last_expr})
 538
 539 io m = GHCi $ \s -> m >>= \a -> return (s,a)
 540
 541 ghciHandle h (GHCi m) = GHCi $ \s ->
 542    Exception.catch (m s) (\e -> unGHCi (h e) s)
 543 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
 544    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
 545
 546 -----------------------------------------------------------------------------
 547 -- package loader
 548
 549 linkPackages :: [Package] -> IO ()
 550 linkPackages pkgs = mapM_ linkPackage pkgs
 551
 552 linkPackage :: Package -> IO ()
 553 -- ignore rts and gmp for now (ToDo; better?)
 554 linkPackage pkg | name pkg `elem` ["rts", "gmp"] = return ()
 555 linkPackage pkg = do
 556   putStr ("Loading package " ++ name pkg ++ " ... ")
 557   let dirs = library_dirs pkg
 558   let objs = map (++".o") (hs_libraries pkg ++ extra_libraries pkg)
 559   mapM (linkOneObj dirs) objs
 560   putStr "resolving ... "
 561   resolveObjs
 562   putStrLn "done."
 563
 564 linkOneObj dirs obj = do
 565   filename <- findFile dirs obj
 566   loadObj filename
 567
 568 findFile [] obj = throwDyn (OtherError ("can't find " ++ obj))
 569 findFile (d:ds) obj = do
 570   let path = d ++ '/':obj
 571   b <- doesFileExist path
 572   if b then return path else findFile ds obj
 573
 574 -----------------------------------------------------------------------------
 575 -- timing & statistics
 576
 577 timeIt :: GHCi a -> GHCi a
 578 timeIt action
 579   = do b <- isOptionSet ShowTiming
 580        if not b
 581           then action
 582           else do allocs1 <- io $ getAllocations
 583                   time1   <- io $ getCPUTime
 584                   a <- action
 585                   allocs2 <- io $ getAllocations
 586                   time2   <- io $ getCPUTime
 587                   io $ printTimes (allocs2 - allocs1) (time2 - time1)
 588                   return a
 589
 590 foreign import "getAllocations" getAllocations :: IO Int
 591
 592 printTimes :: Int -> Integer -> IO ()
 593 printTimes allocs psecs
 594    = do let secs = (fromIntegral psecs / (10^12)) :: Float
 595             secs_str = showFFloat (Just 2) secs
 596         putStrLn (showSDoc (
 597                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 598                          int allocs <+> text "bytes")))
 599
 600 -----------------------------------------------------------------------------
 601 -- reverting CAFs
 602
 603 foreign import revertCAFs :: IO ()      -- make it "safe", just in case