ghc/compiler/ghci/InteractiveUI.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: InteractiveUI.hs,v 1.26 2001/01/16 17:09:43 sewardj 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        (st, maybe_ty) <- io (cmGetExpr (cmstate st) dflags
 290                                 (current_module st) str False)
 291        case maybe_ty of
 292          Nothing -> return ()
 293          Just (_, unqual, ty) -> io (printForUser stdout unqual (ppr ty))
 294
 295 quit :: String -> GHCi Bool
 296 quit _ = return True
 297
 298 shellEscape :: String -> GHCi Bool
 299 shellEscape str = io (system str >> return False)
 300
 301 ----------------------------------------------------------------------------
 302 -- Code for `:set'
 303
 304 -- set options in the interpreter.  Syntax is exactly the same as the
 305 -- ghc command line, except that certain options aren't available (-C,
 306 -- -E etc.)
 307 --
 308 -- This is pretty fragile: most options won't work as expected.  ToDo:
 309 -- figure out which ones & disallow them.
 310
 311 setOptions :: String -> GHCi ()
 312 setOptions ""
 313   = do st <- getGHCiState
 314        let opts = options st
 315        io $ putStrLn (showSDoc (
 316               text "options currently set: " <>
 317               if null opts
 318                    then text "none."
 319                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 320            ))
 321 setOptions str
 322   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 323        let opts = words str
 324            (minus_opts, rest1) = partition isMinus opts
 325            (plus_opts, rest2)  = partition isPlus rest1
 326
 327        if (not (null rest2))
 328           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 329           else do
 330
 331        mapM setOpt plus_opts
 332
 333        -- now, the GHC flags
 334        io (do leftovers <- processArgs static_flags minus_opts []
 335               dyn_flags <- readIORef v_InitDynFlags
 336               writeIORef v_DynFlags dyn_flags
 337               leftovers <- processArgs dynamic_flags leftovers []
 338               dyn_flags <- readIORef v_DynFlags
 339               writeIORef v_InitDynFlags dyn_flags
 340               if (not (null leftovers))
 341                  then throwDyn (OtherError ("unrecognised flags: " ++
 342                                                 unwords leftovers))
 343                  else return ()
 344          )
 345
 346 unsetOptions :: String -> GHCi ()
 347 unsetOptions str
 348   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 349        let opts = words str
 350            (minus_opts, rest1) = partition isMinus opts
 351            (plus_opts, rest2)  = partition isPlus rest1
 352
 353        if (not (null rest2))
 354           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 355           else do
 356
 357        mapM unsetOpt plus_opts
 358
 359        -- can't do GHC flags for now
 360        if (not (null minus_opts))
 361           then throwDyn (OtherError "can't unset GHC command-line flags")
 362           else return ()
 363
 364 isMinus ('-':s) = True
 365 isMinus _ = False
 366
 367 isPlus ('+':s) = True
 368 isPlus _ = False
 369
 370 setOpt ('+':str)
 371   = case strToGHCiOpt str of
 372         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 373         Just o  -> setOption o
 374
 375 unsetOpt ('+':str)
 376   = case strToGHCiOpt str of
 377         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 378         Just o  -> unsetOption o
 379
 380 strToGHCiOpt :: String -> (Maybe GHCiOption)
 381 strToGHCiOpt "s" = Just ShowTiming
 382 strToGHCiOpt "t" = Just ShowType
 383 strToGHCiOpt _   = Nothing
 384
 385 optToStr :: GHCiOption -> String
 386 optToStr ShowTiming = "s"
 387 optToStr ShowType   = "t"
 388
 389
 390 -----------------------------------------------------------------------------
 391 -- Code to do last-expression-entered stuff.  (a.k.a the $$ facility)
 392
 393 -- Take a string and replace $$s in it with the last expr, if any.
 394 expandExpr :: String -> GHCi String
 395 expandExpr str
 396    = do mle <- getLastExpr
 397         return (outside mle str)
 398      where
 399         outside mle ('$':'$':cs)
 400            = case mle of
 401                 Just le -> " (" ++ le ++ ") " ++ outside mle cs
 402                 Nothing -> outside mle cs
 403
 404         outside mle []           = []
 405         outside mle ('"':str)    = '"' : inside2 mle str   -- "
 406         outside mle ('\'':str)   = '\'' : inside1 mle str   -- '
 407         outside mle (c:cs)       = c : outside mle cs
 408
 409         inside2 mle ('"':cs)  = '"' : outside mle cs   -- "
 410         inside2 mle (c:cs)    = c : inside2 mle cs
 411         inside2 mle []        = []
 412
 413         inside1 mle ('\'':cs) = '\'': outside mle cs
 414         inside1 mle (c:cs)    = c : inside1 mle cs
 415         inside1 mle []        = []
 416
 417
 418 rememberExpr :: String -> GHCi ()
 419 rememberExpr str
 420    = do let cleaned = (clean . reverse . clean . reverse) str
 421         let forget_me_not | null cleaned = Nothing
 422                           | otherwise    = Just cleaned
 423         setLastExpr forget_me_not
 424      where
 425         clean = dropWhile isSpace
 426
 427
 428 -----------------------------------------------------------------------------
 429 -- GHCi monad
 430
 431 data GHCiState = GHCiState
 432      {
 433         modules        :: [ModuleName],
 434         current_module :: ModuleName,
 435         target         :: Maybe FilePath,
 436         cmstate        :: CmState,
 437         options        :: [GHCiOption],
 438         last_expr      :: Maybe String
 439      }
 440
 441 data GHCiOption = ShowTiming | ShowType deriving Eq
 442
 443 defaultCurrentModule = mkModuleName "Prelude"
 444
 445 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
 446
 447 instance Monad GHCi where
 448   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
 449   return a  = GHCi $ \s -> return (s,a)
 450
 451 getGHCiState   = GHCi $ \s -> return (s,s)
 452 setGHCiState s = GHCi $ \_ -> return (s,())
 453
 454 isOptionSet :: GHCiOption -> GHCi Bool
 455 isOptionSet opt
 456  = do st <- getGHCiState
 457       return (opt `elem` options st)
 458
 459 setOption :: GHCiOption -> GHCi ()
 460 setOption opt
 461  = do st <- getGHCiState
 462       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 463
 464 unsetOption :: GHCiOption -> GHCi ()
 465 unsetOption opt
 466  = do st <- getGHCiState
 467       setGHCiState (st{ options = filter (/= opt) (options st) })
 468
 469 getLastExpr :: GHCi (Maybe String)
 470 getLastExpr
 471  = do st <- getGHCiState ; return (last_expr st)
 472
 473 setLastExpr :: Maybe String -> GHCi ()
 474 setLastExpr last_expr
 475  = do st <- getGHCiState ; setGHCiState (st{last_expr = last_expr})
 476
 477 io m = GHCi $ \s -> m >>= \a -> return (s,a)
 478
 479 ghciHandle h (GHCi m) = GHCi $ \s ->
 480    Exception.catch (m s) (\e -> unGHCi (h e) s)
 481 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
 482    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
 483
 484 -----------------------------------------------------------------------------
 485 -- package loader
 486
 487 linkPackages :: [Package] -> IO ()
 488 linkPackages pkgs = mapM_ linkPackage pkgs
 489
 490 linkPackage :: Package -> IO ()
 491 -- ignore rts and gmp for now (ToDo; better?)
 492 linkPackage pkg | name pkg `elem` ["rts", "gmp"] = return ()
 493 linkPackage pkg = do
 494   putStr ("Loading package " ++ name pkg ++ " ... ")
 495   let dirs = library_dirs pkg
 496   let objs = map (++".o") (hs_libraries pkg ++ extra_libraries pkg)
 497   mapM (linkOneObj dirs) objs
 498   putStr "resolving ... "
 499   resolveObjs
 500   putStrLn "done."
 501
 502 linkOneObj dirs obj = do
 503   filename <- findFile dirs obj
 504   loadObj filename
 505
 506 findFile [] obj = throwDyn (OtherError ("can't find " ++ obj))
 507 findFile (d:ds) obj = do
 508   let path = d ++ '/':obj
 509   b <- doesFileExist path
 510   if b then return path else findFile ds obj
 511
 512 -----------------------------------------------------------------------------
 513 -- timing & statistics
 514
 515 timeIt :: GHCi a -> GHCi a
 516 timeIt action
 517   = do b <- isOptionSet ShowTiming
 518        if not b
 519           then action
 520           else do allocs1 <- io $ getAllocations
 521                   time1   <- io $ getCPUTime
 522                   a <- action
 523                   allocs2 <- io $ getAllocations
 524                   time2   <- io $ getCPUTime
 525                   io $ printTimes (allocs2 - allocs1) (time2 - time1)
 526                   return a
 527
 528 foreign import "getAllocations" getAllocations :: IO Int
 529
 530 printTimes :: Int -> Integer -> IO ()
 531 printTimes allocs psecs
 532    = do let secs = (fromIntegral psecs / (10^12)) :: Float
 533             secs_str = showFFloat (Just 2) secs
 534         putStrLn (showSDoc (
 535                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 536                          int allocs <+> text "bytes")))