ghc/compiler/ghci/InteractiveUI.hs

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