ghc/compiler/ghci/InteractiveUI.hs

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