ghc/compiler/ghci/InteractiveUI.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: InteractiveUI.hs,v 1.24 2000/12/18 12:43:04 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 DriverUtil
  18 import DriverState
  19 import Linker
  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
  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    return ()
 123
 124 uiLoop :: GHCi ()
 125 uiLoop = do
 126   st <- getGHCiState
 127 #ifndef NO_READLINE
 128   l <- io (readline (moduleNameUserString (current_module st) ++ "> "))
 129 #else
 130   l_ok <- io (hGetLine stdin)
 131   let l = Just l_ok
 132 #endif
 133   case l of
 134     Nothing -> exitGHCi
 135     Just "" -> uiLoop
 136     Just l  -> do
 137 #ifndef NO_READLINE
 138           io (addHistory l)
 139 #endif
 140           quit <- runCommand l
 141           if quit then exitGHCi else uiLoop
 142
 143 exitGHCi = io $ do putStrLn "Leaving GHCi."
 144
 145 -- Top level exception handler, just prints out the exception
 146 -- and carries on.
 147 runCommand :: String -> GHCi Bool
 148 runCommand c =
 149   ghciHandle (
 150      \other_exception
 151         -> io (putStrLn (show other_exception)) >> return False
 152   ) $
 153   ghciHandleDyn
 154     (\dyn -> case dyn of
 155                 PhaseFailed phase code ->
 156                         io ( putStrLn ("Phase " ++ phase ++ " failed (code "
 157                                         ++ show code ++ ")"))
 158                 Interrupted -> io (putStrLn "Interrupted.")
 159                 _ -> io (putStrLn (show (dyn :: GhcException)))
 160              >> return False
 161     ) $
 162    doCommand c
 163
 164 doCommand (':' : command) = specialCommand command
 165 doCommand expr            = timeIt (evalExpr expr) >> return False
 166
 167 evalExpr expr
 168  = do st <- getGHCiState
 169       dflags <- io (getDynFlags)
 170       (new_cmstate, maybe_stuff) <-
 171          io (cmGetExpr (cmstate st) dflags (current_module st) expr)
 172       setGHCiState st{cmstate = new_cmstate}
 173       case maybe_stuff of
 174          Nothing -> return ()
 175          Just (hv, unqual, ty)
 176            -> do io (cmRunExpr hv)
 177                  b <- isOptionSet ShowType
 178                  if b then io (printForUser stdout unqual (text "::" <+> ppr ty))
 179                       else return ()
 180
 181 {-
 182   let (mod,'.':str) = break (=='.') expr
 183   case cmLookupSymbol (mkOrig varName (mkModuleName mod) (_PK_ str)) (cmstate st) of
 184         Nothing -> io (putStrLn "nothing.")
 185         Just e  -> io (
 186   return ()
 187 -}
 188
 189 specialCommand :: String -> GHCi Bool
 190 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 191 specialCommand str = do
 192   let (cmd,rest) = break isSpace str
 193   case [ (s,f) | (s,f) <- commands, prefixMatch cmd s ] of
 194      []      -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
 195                                     ++ shortHelpText) >> return False)
 196      [(_,f)] -> f (dropWhile isSpace rest)
 197      cs      -> io (hPutStrLn stdout ("prefix " ++ cmd ++
 198                                       " matches multiple commands (" ++
 199                                        foldr1 (\a b -> a ++ ',':b) (map fst cs)
 200                                          ++ ")") >> return False)
 201
 202 noArgs c = io (hPutStrLn stdout ("command `:" ++ c ++ "' takes no arguments"))
 203
 204 -----------------------------------------------------------------------------
 205 -- Commands
 206
 207 help :: String -> GHCi ()
 208 help _ = io (putStr helpText)
 209
 210 addModule :: String -> GHCi ()
 211 addModule _ = throwDyn (OtherError ":add not implemented")
 212
 213 setContext :: String -> GHCi ()
 214 setContext ""
 215   = throwDyn (OtherError "syntax: `:m <module>'")
 216 setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m))
 217   = throwDyn (OtherError ("strange looking module name: `" ++ m ++ "'"))
 218 setContext m
 219   = do st <- getGHCiState
 220        setGHCiState st{current_module = mkModuleName m}
 221
 222 changeDirectory :: String -> GHCi ()
 223 changeDirectory d = io (setCurrentDirectory d)
 224
 225 loadModule :: String -> GHCi ()
 226 loadModule path = timeIt (loadModule' path)
 227
 228 loadModule' path = do
 229   state <- getGHCiState
 230   cmstate1 <- io (cmUnload (cmstate state))
 231   (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
 232
 233   let new_state = state{
 234                         cmstate = cmstate2,
 235                         modules = mods,
 236                         current_module = case mods of
 237                                            [] -> defaultCurrentModule
 238                                            xs -> head xs,
 239                         target = Just path
 240                    }
 241   setGHCiState new_state
 242
 243   let mod_commas
 244         | null mods = text "none."
 245         | otherwise = hsep (
 246             punctuate comma (map (text.moduleNameUserString) mods)) <> text "."
 247   case ok of
 248     False ->
 249        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 250     True  ->
 251        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 252
 253 reloadModule :: String -> GHCi ()
 254 reloadModule "" = do
 255   state <- getGHCiState
 256   case target state of
 257    Nothing -> io (putStr "no current target\n")
 258    Just path
 259       -> do (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
 260             setGHCiState
 261                state{cmstate=new_cmstate,
 262                      modules = mods,
 263                      current_module = case mods of
 264                                          [] -> defaultCurrentModule
 265                                          xs -> head xs
 266                     }
 267
 268
 269 reloadModule _ = noArgs ":reload"
 270
 271 typeOfExpr :: String -> GHCi ()
 272 typeOfExpr str
 273   = do st <- getGHCiState
 274        dflags <- io (getDynFlags)
 275        (st, maybe_ty) <- io (cmGetExpr (cmstate st) dflags
 276                                 (current_module st) str)
 277        case maybe_ty of
 278          Nothing -> return ()
 279          Just (_, unqual, ty) -> io (printForUser stdout unqual (ppr ty))
 280
 281 quit :: String -> GHCi Bool
 282 quit _ = return True
 283
 284 shellEscape :: String -> GHCi Bool
 285 shellEscape str = io (system str >> return False)
 286
 287 ----------------------------------------------------------------------------
 288 -- Code for `:set'
 289
 290 -- set options in the interpreter.  Syntax is exactly the same as the
 291 -- ghc command line, except that certain options aren't available (-C,
 292 -- -E etc.)
 293 --
 294 -- This is pretty fragile: most options won't work as expected.  ToDo:
 295 -- figure out which ones & disallow them.
 296
 297 setOptions :: String -> GHCi ()
 298 setOptions ""
 299   = do st <- getGHCiState
 300        let opts = options st
 301        io $ putStrLn (showSDoc (
 302               text "options currently set: " <>
 303               if null opts
 304                    then text "none."
 305                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 306            ))
 307 setOptions str
 308   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 309        let opts = words str
 310            (minus_opts, rest1) = partition isMinus opts
 311            (plus_opts, rest2)  = partition isPlus rest1
 312
 313        if (not (null rest2))
 314           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 315           else do
 316
 317        mapM setOpt plus_opts
 318
 319        -- now, the GHC flags
 320        io (do leftovers <- processArgs static_flags minus_opts []
 321               dyn_flags <- readIORef v_InitDynFlags
 322               writeIORef v_DynFlags dyn_flags
 323               leftovers <- processArgs dynamic_flags leftovers []
 324               dyn_flags <- readIORef v_DynFlags
 325               writeIORef v_InitDynFlags dyn_flags
 326               if (not (null leftovers))
 327                  then throwDyn (OtherError ("unrecognised flags: " ++
 328                                                 unwords leftovers))
 329                  else return ()
 330          )
 331
 332 unsetOptions :: String -> GHCi ()
 333 unsetOptions str
 334   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 335        let opts = words str
 336            (minus_opts, rest1) = partition isMinus opts
 337            (plus_opts, rest2)  = partition isPlus rest1
 338
 339        if (not (null rest2))
 340           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 341           else do
 342
 343        mapM unsetOpt plus_opts
 344
 345        -- can't do GHC flags for now
 346        if (not (null minus_opts))
 347           then throwDyn (OtherError "can't unset GHC command-line flags")
 348           else return ()
 349
 350 isMinus ('-':s) = True
 351 isMinus _ = False
 352
 353 isPlus ('+':s) = True
 354 isPlus _ = False
 355
 356 setOpt ('+':str)
 357   = case strToGHCiOpt str of
 358         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 359         Just o  -> setOption o
 360
 361 unsetOpt ('+':str)
 362   = case strToGHCiOpt str of
 363         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 364         Just o  -> unsetOption o
 365
 366 strToGHCiOpt :: String -> (Maybe GHCiOption)
 367 strToGHCiOpt "s" = Just ShowTiming
 368 strToGHCiOpt "t" = Just ShowType
 369 strToGHCiOpt _   = Nothing
 370
 371 optToStr :: GHCiOption -> String
 372 optToStr ShowTiming = "s"
 373 optToStr ShowType   = "t"
 374
 375 -----------------------------------------------------------------------------
 376 -- GHCi monad
 377
 378 data GHCiState = GHCiState
 379      {
 380         modules        :: [ModuleName],
 381         current_module :: ModuleName,
 382         target         :: Maybe FilePath,
 383         cmstate        :: CmState,
 384         options        :: [GHCiOption]
 385      }
 386
 387 data GHCiOption = ShowTiming | ShowType deriving Eq
 388
 389 defaultCurrentModule = mkModuleName "Prelude"
 390
 391 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
 392
 393 instance Monad GHCi where
 394   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
 395   return a  = GHCi $ \s -> return (s,a)
 396
 397 getGHCiState   = GHCi $ \s -> return (s,s)
 398 setGHCiState s = GHCi $ \_ -> return (s,())
 399
 400 isOptionSet :: GHCiOption -> GHCi Bool
 401 isOptionSet opt
 402  = do st <- getGHCiState
 403       return (opt `elem` options st)
 404
 405 setOption :: GHCiOption -> GHCi ()
 406 setOption opt
 407  = do st <- getGHCiState
 408       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 409
 410 unsetOption :: GHCiOption -> GHCi ()
 411 unsetOption opt
 412  = do st <- getGHCiState
 413       setGHCiState (st{ options = filter (/= opt) (options st) })
 414
 415 io m = GHCi $ \s -> m >>= \a -> return (s,a)
 416
 417 ghciHandle h (GHCi m) = GHCi $ \s ->
 418    Exception.catch (m s) (\e -> unGHCi (h e) s)
 419 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
 420    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
 421
 422 -----------------------------------------------------------------------------
 423 -- package loader
 424
 425 linkPackages :: [Package] -> IO ()
 426 linkPackages pkgs = mapM_ linkPackage pkgs
 427
 428 linkPackage :: Package -> IO ()
 429 -- ignore rts and gmp for now (ToDo; better?)
 430 linkPackage pkg | name pkg `elem` ["rts", "gmp"] = return ()
 431 linkPackage pkg = do
 432   putStr ("Loading package " ++ name pkg ++ " ... ")
 433   let dirs = library_dirs pkg
 434   let objs = map (++".o") (hs_libraries pkg ++ extra_libraries pkg)
 435   mapM (linkOneObj dirs) objs
 436   putStr "resolving ... "
 437   resolveObjs
 438   putStrLn "done."
 439
 440 linkOneObj dirs obj = do
 441   filename <- findFile dirs obj
 442   loadObj filename
 443
 444 findFile [] obj = throwDyn (OtherError ("can't find " ++ obj))
 445 findFile (d:ds) obj = do
 446   let path = d ++ '/':obj
 447   b <- doesFileExist path
 448   if b then return path else findFile ds obj
 449
 450 -----------------------------------------------------------------------------
 451 -- timing & statistics
 452
 453 timeIt :: GHCi a -> GHCi a
 454 timeIt action
 455   = do b <- isOptionSet ShowTiming
 456        if not b
 457           then action
 458           else do allocs1 <- io $ getAllocations
 459                   time1   <- io $ getCPUTime
 460                   a <- action
 461                   allocs2 <- io $ getAllocations
 462                   time2   <- io $ getCPUTime
 463                   io $ printTimes (allocs2 - allocs1) (time2 - time1)
 464                   return a
 465
 466 foreign import "getAllocations" getAllocations :: IO Int
 467
 468 printTimes :: Int -> Integer -> IO ()
 469 printTimes allocs psecs
 470    = do let secs = (fromIntegral psecs / (10^12)) :: Float
 471             secs_str = showFFloat (Just 2) secs
 472         putStrLn (showSDoc (
 473                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 474                          int allocs <+> text "bytes")))