ghc/compiler/ghci/InteractiveUI.hs

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