ghc/compiler/ghci/InteractiveUI.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: InteractiveUI.hs,v 1.30 2001/01/19 15:26:37 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 -- first, static flags
 355               leftovers <- processArgs static_flags minus_opts []
 356
 357               -- then, dynamic flags
 358               dyn_flags <- readIORef v_InitDynFlags
 359               writeIORef v_DynFlags dyn_flags
 360               leftovers <- processArgs dynamic_flags leftovers []
 361               dyn_flags <- readIORef v_DynFlags
 362               writeIORef v_InitDynFlags dyn_flags
 363
 364               if (not (null leftovers))
 365                  then throwDyn (OtherError ("unrecognised flags: " ++
 366                                                 unwords leftovers))
 367                  else return ()
 368          )
 369
 370 unsetOptions :: String -> GHCi ()
 371 unsetOptions str
 372   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 373        let opts = words str
 374            (minus_opts, rest1) = partition isMinus opts
 375            (plus_opts, rest2)  = partition isPlus rest1
 376
 377        if (not (null rest2))
 378           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 379           else do
 380
 381        mapM unsetOpt plus_opts
 382
 383        -- can't do GHC flags for now
 384        if (not (null minus_opts))
 385           then throwDyn (OtherError "can't unset GHC command-line flags")
 386           else return ()
 387
 388 isMinus ('-':s) = True
 389 isMinus _ = False
 390
 391 isPlus ('+':s) = True
 392 isPlus _ = False
 393
 394 setOpt ('+':str)
 395   = case strToGHCiOpt str of
 396         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 397         Just o  -> setOption o
 398
 399 unsetOpt ('+':str)
 400   = case strToGHCiOpt str of
 401         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 402         Just o  -> unsetOption o
 403
 404 strToGHCiOpt :: String -> (Maybe GHCiOption)
 405 strToGHCiOpt "s" = Just ShowTiming
 406 strToGHCiOpt "t" = Just ShowType
 407 strToGHCiOpt _   = Nothing
 408
 409 optToStr :: GHCiOption -> String
 410 optToStr ShowTiming = "s"
 411 optToStr ShowType   = "t"
 412
 413
 414 -----------------------------------------------------------------------------
 415 -- Code to do last-expression-entered stuff.  (a.k.a the $$ facility)
 416
 417 -- Take a string and replace $$s in it with the last expr, if any.
 418 expandExpr :: String -> GHCi String
 419 expandExpr str
 420    = do mle <- getLastExpr
 421         return (outside mle str)
 422      where
 423         outside mle ('$':'$':cs)
 424            = case mle of
 425                 Just le -> " (" ++ le ++ ") " ++ outside mle cs
 426                 Nothing -> outside mle cs
 427
 428         outside mle []           = []
 429         outside mle ('"':str)    = '"' : inside2 mle str   -- "
 430         outside mle ('\'':str)   = '\'' : inside1 mle str   -- '
 431         outside mle (c:cs)       = c : outside mle cs
 432
 433         inside2 mle ('"':cs)  = '"' : outside mle cs   -- "
 434         inside2 mle (c:cs)    = c : inside2 mle cs
 435         inside2 mle []        = []
 436
 437         inside1 mle ('\'':cs) = '\'': outside mle cs
 438         inside1 mle (c:cs)    = c : inside1 mle cs
 439         inside1 mle []        = []
 440
 441
 442 rememberExpr :: String -> GHCi ()
 443 rememberExpr str
 444    = do let cleaned = (clean . reverse . clean . reverse) str
 445         let forget_me_not | null cleaned = Nothing
 446                           | otherwise    = Just cleaned
 447         setLastExpr forget_me_not
 448      where
 449         clean = dropWhile isSpace
 450
 451
 452 -----------------------------------------------------------------------------
 453 -- GHCi monad
 454
 455 data GHCiState = GHCiState
 456      {
 457         modules        :: [Module],
 458         current_module :: Module,
 459         target         :: Maybe FilePath,
 460         cmstate        :: CmState,
 461         options        :: [GHCiOption],
 462         last_expr      :: Maybe String
 463      }
 464
 465 data GHCiOption = ShowTiming | ShowType deriving Eq
 466
 467 defaultCurrentModuleName = mkModuleName "Prelude"
 468 GLOBAL_VAR(defaultCurrentModule, error "no defaultCurrentModule", Module)
 469
 470 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
 471
 472 instance Monad GHCi where
 473   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
 474   return a  = GHCi $ \s -> return (s,a)
 475
 476 getGHCiState   = GHCi $ \s -> return (s,s)
 477 setGHCiState s = GHCi $ \_ -> return (s,())
 478
 479 isOptionSet :: GHCiOption -> GHCi Bool
 480 isOptionSet opt
 481  = do st <- getGHCiState
 482       return (opt `elem` options st)
 483
 484 setOption :: GHCiOption -> GHCi ()
 485 setOption opt
 486  = do st <- getGHCiState
 487       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 488
 489 unsetOption :: GHCiOption -> GHCi ()
 490 unsetOption opt
 491  = do st <- getGHCiState
 492       setGHCiState (st{ options = filter (/= opt) (options st) })
 493
 494 getLastExpr :: GHCi (Maybe String)
 495 getLastExpr
 496  = do st <- getGHCiState ; return (last_expr st)
 497
 498 setLastExpr :: Maybe String -> GHCi ()
 499 setLastExpr last_expr
 500  = do st <- getGHCiState ; setGHCiState (st{last_expr = last_expr})
 501
 502 io m = GHCi $ \s -> m >>= \a -> return (s,a)
 503
 504 ghciHandle h (GHCi m) = GHCi $ \s ->
 505    Exception.catch (m s) (\e -> unGHCi (h e) s)
 506 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
 507    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
 508
 509 -----------------------------------------------------------------------------
 510 -- package loader
 511
 512 linkPackages :: [Package] -> IO ()
 513 linkPackages pkgs = mapM_ linkPackage pkgs
 514
 515 linkPackage :: Package -> IO ()
 516 -- ignore rts and gmp for now (ToDo; better?)
 517 linkPackage pkg | name pkg `elem` ["rts", "gmp"] = return ()
 518 linkPackage pkg = do
 519   putStr ("Loading package " ++ name pkg ++ " ... ")
 520   let dirs = library_dirs pkg
 521   let objs = map (++".o") (hs_libraries pkg ++ extra_libraries pkg)
 522   mapM (linkOneObj dirs) objs
 523   putStr "resolving ... "
 524   resolveObjs
 525   putStrLn "done."
 526
 527 linkOneObj dirs obj = do
 528   filename <- findFile dirs obj
 529   loadObj filename
 530
 531 findFile [] obj = throwDyn (OtherError ("can't find " ++ obj))
 532 findFile (d:ds) obj = do
 533   let path = d ++ '/':obj
 534   b <- doesFileExist path
 535   if b then return path else findFile ds obj
 536
 537 -----------------------------------------------------------------------------
 538 -- timing & statistics
 539
 540 timeIt :: GHCi a -> GHCi a
 541 timeIt action
 542   = do b <- isOptionSet ShowTiming
 543        if not b
 544           then action
 545           else do allocs1 <- io $ getAllocations
 546                   time1   <- io $ getCPUTime
 547                   a <- action
 548                   allocs2 <- io $ getAllocations
 549                   time2   <- io $ getCPUTime
 550                   io $ printTimes (allocs2 - allocs1) (time2 - time1)
 551                   return a
 552
 553 foreign import "getAllocations" getAllocations :: IO Int
 554
 555 printTimes :: Int -> Integer -> IO ()
 556 printTimes allocs psecs
 557    = do let secs = (fromIntegral psecs / (10^12)) :: Float
 558             secs_str = showFFloat (Just 2) secs
 559         putStrLn (showSDoc (
 560                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 561                          int allocs <+> text "bytes")))