ghc/compiler/ghci/InteractiveUI.hs

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