ghc/compiler/ghci/InteractiveUI.hs

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