ghc/compiler/ghci/InteractiveUI.hs

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