ghc/compiler/ghci/InteractiveUI.hs

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