ghc/compiler/ghci/InteractiveUI.hs

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