ghc/compiler/ghci/InteractiveUI.hs

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