ghc/compiler/ghci/InteractiveUI.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: InteractiveUI.hs,v 1.18 2000/11/27 12:52:36 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 -> head 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, mods) <- io (cmLoadModule (cmstate state) path)
 245             setGHCiState
 246                state{cmstate=new_cmstate,
 247                      modules = mods,
 248                      current_module = case mods of
 249                                          [] -> defaultCurrentModule
 250                                          xs -> head xs
 251                     }
 252
 253
 254 reloadModule _ = noArgs ":reload"
 255
 256 typeOfExpr :: String -> GHCi ()
 257 typeOfExpr str
 258   = do st <- getGHCiState
 259        dflags <- io (getDynFlags)
 260        (st, maybe_ty) <- io (cmGetExpr (cmstate st) dflags
 261                                 (current_module st) str)
 262        case maybe_ty of
 263          Nothing -> return ()
 264          Just (_, unqual, ty) -> io (printForUser stdout unqual (ppr ty))
 265
 266 quit :: String -> GHCi ()
 267 quit _ = exitGHCi
 268
 269 shellEscape :: String -> GHCi ()
 270 shellEscape str = io (system str >> return ())
 271
 272 ----------------------------------------------------------------------------
 273 -- Code for `:set'
 274
 275 -- set options in the interpreter.  Syntax is exactly the same as the
 276 -- ghc command line, except that certain options aren't available (-C,
 277 -- -E etc.)
 278 --
 279 -- This is pretty fragile: most options won't work as expected.  ToDo:
 280 -- figure out which ones & disallow them.
 281
 282 setOptions :: String -> GHCi ()
 283 setOptions ""
 284   = do st <- getGHCiState
 285        let opts = options st
 286        io $ putStrLn (showSDoc (
 287               text "options currently set: " <>
 288               if null opts
 289                    then text "none."
 290                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 291            ))
 292 setOptions str
 293   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 294        let opts = words str
 295            (minus_opts, rest1) = partition isMinus opts
 296            (plus_opts, rest2)  = partition isPlus rest1
 297
 298        if (not (null rest2))
 299           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 300           else do
 301
 302        mapM setOpt plus_opts
 303
 304        -- now, the GHC flags
 305        io (do leftovers <- processArgs static_flags minus_opts []
 306               dyn_flags <- readIORef v_InitDynFlags
 307               writeIORef v_DynFlags dyn_flags
 308               leftovers <- processArgs dynamic_flags leftovers []
 309               dyn_flags <- readIORef v_DynFlags
 310               writeIORef v_InitDynFlags dyn_flags
 311               if (not (null leftovers))
 312                  then throwDyn (OtherError ("unrecognised flags: " ++
 313                                                 unwords leftovers))
 314                  else return ()
 315          )
 316
 317 unsetOptions :: String -> GHCi ()
 318 unsetOptions str
 319   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 320        let opts = words str
 321            (minus_opts, rest1) = partition isMinus opts
 322            (plus_opts, rest2)  = partition isPlus rest1
 323
 324        if (not (null rest2))
 325           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 326           else do
 327
 328        mapM unsetOpt plus_opts
 329
 330        -- can't do GHC flags for now
 331        if (not (null minus_opts))
 332           then throwDyn (OtherError "can't unset GHC command-line flags")
 333           else return ()
 334
 335 isMinus ('-':s) = True
 336 isMinus _ = False
 337
 338 isPlus ('+':s) = True
 339 isPlus _ = False
 340
 341 setOpt ('+':str)
 342   = case strToGHCiOpt str of
 343         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 344         Just o  -> setOption o
 345
 346 unsetOpt ('+':str)
 347   = case strToGHCiOpt str of
 348         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 349         Just o  -> unsetOption o
 350
 351 strToGHCiOpt :: String -> (Maybe GHCiOption)
 352 strToGHCiOpt "s" = Just ShowTiming
 353 strToGHCiOpt "t" = Just ShowType
 354 strToGHCiOpt _   = Nothing
 355
 356 optToStr :: GHCiOption -> String
 357 optToStr ShowTiming = "s"
 358 optToStr ShowType   = "t"
 359
 360 -----------------------------------------------------------------------------
 361 -- GHCi monad
 362
 363 data GHCiState = GHCiState
 364      {
 365         modules        :: [ModuleName],
 366         current_module :: ModuleName,
 367         target         :: Maybe FilePath,
 368         cmstate        :: CmState,
 369         options        :: [GHCiOption]
 370      }
 371
 372 data GHCiOption = ShowTiming | ShowType deriving Eq
 373
 374 defaultCurrentModule = mkModuleName "Prelude"
 375
 376 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
 377
 378 instance Monad GHCi where
 379   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
 380   return a  = GHCi $ \s -> return (s,a)
 381
 382 getGHCiState   = GHCi $ \s -> return (s,s)
 383 setGHCiState s = GHCi $ \_ -> return (s,())
 384
 385 isOptionSet :: GHCiOption -> GHCi Bool
 386 isOptionSet opt
 387  = do st <- getGHCiState
 388       return (opt `elem` options st)
 389
 390 setOption :: GHCiOption -> GHCi ()
 391 setOption opt
 392  = do st <- getGHCiState
 393       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 394
 395 unsetOption :: GHCiOption -> GHCi ()
 396 unsetOption opt
 397  = do st <- getGHCiState
 398       setGHCiState (st{ options = filter (/= opt) (options st) })
 399
 400 io m = GHCi $ \s -> m >>= \a -> return (s,a)
 401
 402 ghciHandle h (GHCi m) = GHCi $ \s ->
 403    Exception.catch (m s) (\e -> unGHCi (h e) s)
 404 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
 405    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
 406
 407 -----------------------------------------------------------------------------
 408 -- package loader
 409
 410 linkPackages :: [Package] -> IO ()
 411 linkPackages pkgs = mapM_ linkPackage pkgs
 412
 413 linkPackage :: Package -> IO ()
 414 -- ignore rts and gmp for now (ToDo; better?)
 415 linkPackage pkg | name pkg `elem` ["rts", "gmp"] = return ()
 416 linkPackage pkg = do
 417   putStr ("Loading package " ++ name pkg ++ " ... ")
 418   let dirs = library_dirs pkg
 419   let objs = map (++".o") (hs_libraries pkg ++ extra_libraries pkg)
 420   mapM (linkOneObj dirs) objs
 421   putStr "resolving ... "
 422   resolveObjs
 423   putStrLn "done."
 424
 425 linkOneObj dirs obj = do
 426   filename <- findFile dirs obj
 427   loadObj filename
 428
 429 findFile [] obj = throwDyn (OtherError ("can't find " ++ obj))
 430 findFile (d:ds) obj = do
 431   let path = d ++ '/':obj
 432   b <- doesFileExist path
 433   if b then return path else findFile ds obj
 434
 435 -----------------------------------------------------------------------------
 436 -- timing & statistics
 437
 438 timeIt :: GHCi a -> GHCi a
 439 timeIt action
 440   = do b <- isOptionSet ShowTiming
 441        if not b
 442           then action
 443           else do allocs1 <- io $ getAllocations
 444                   time1   <- io $ getCPUTime
 445                   a <- action
 446                   allocs2 <- io $ getAllocations
 447                   time2   <- io $ getCPUTime
 448                   io $ printTimes (allocs2 - allocs1) (time2 - time1)
 449                   return a
 450
 451 foreign import "getAllocations" getAllocations :: IO Int
 452
 453 printTimes :: Int -> Integer -> IO ()
 454 printTimes allocs psecs
 455    = do let secs = (fromIntegral psecs / (10^12)) :: Float
 456             secs_str = showFFloat (Just 2) secs
 457         putStrLn (showSDoc (
 458                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 459                          int allocs <+> text "bytes")))