ghc/compiler/ghci/InteractiveUI.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: InteractiveUI.hs,v 1.6 2000/11/20 16:51:35 simonmar 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 Panic
  23 import Util
  24
  25 import Exception
  26 import Readline
  27 import IOExts
  28
  29 import System
  30 import Directory
  31 import IO
  32 import Char
  33
  34 -----------------------------------------------------------------------------
  35
  36 ghciWelcomeMsg = "\
  37 \ _____  __   __  ____         _________________________________________________\n\
  38 \(|      ||   || (|  |)        GHC Interactive, version 5.00                    \n\
  39 \||  __  ||___|| ||     ()     For Haskell 98.                                  \n\
  40 \||   |) ||---|| ||     ||     http://www.haskell.org/ghc                       \n\
  41 \||   || ||   || ||     (|     Bug reports to: glasgow-haskell-bugs@haskell.org \n\
  42 \(|___|| ||   || (|__|) \\\\______________________________________________________\n"
  43
  44 commands :: [(String, String -> GHCi ())]
  45 commands = [
  46   ("cd",        changeDirectory),
  47   ("help",      help),
  48   ("?",         help),
  49   ("load",      loadModule),
  50   ("reload",    reloadModule),
  51   ("set",       setOptions),
  52   ("type",      typeOfExpr),
  53   ("quit",      quit)
  54   ]
  55
  56 shortHelpText = "use :? for help.\n"
  57
  58 helpText = "\
  59 \   <expr>              evaluate <expr>\n\
  60 \   :cd <dir>           change directory to <dir>\n\
  61 \   :help               display this list of commands\n\
  62 \   :?                  display this list of commands\n\
  63 \   :load <filename>    load a module (and it dependents)\n\
  64 \   :reload             reload the current program\n\
  65 \   :set <opetion> ...  set options\n\
  66 \   :type <expr>        show the type of <expr>\n\
  67 \   :quit               exit GHCi\n\
  68 \   :!<command>         run the shell command <command>\n\
  69 \"
  70
  71 interactiveUI :: CmState -> IO ()
  72 interactiveUI st = do
  73    hPutStrLn stdout ghciWelcomeMsg
  74    hFlush stdout
  75    hSetBuffering stdout NoBuffering
  76
  77    -- link in the available packages
  78    pkgs <- getPackageInfo
  79    linkPackages (reverse pkgs)
  80
  81 #ifndef NO_READLINE
  82    Readline.initialize
  83 #endif
  84    _ <- (unGHCi uiLoop) GHCiState{ modules = [],
  85                                    current_module = Nothing,
  86                                    target = Nothing,
  87                                    cmstate = st }
  88    return ()
  89
  90 uiLoop :: GHCi ()
  91 uiLoop = do
  92   st <- getGHCiState
  93 #ifndef NO_READLINE
  94   l <- io (readline (mkPrompt (current_module st) ++ "> "))
  95 #else
  96   l <- io (hGetLine stdin)
  97 #endif
  98   case l of
  99     Nothing -> return ()
 100     Just "" -> uiLoop
 101     Just l  -> do
 102 #ifndef NO_READLINE
 103           io (addHistory l)
 104 #endif
 105           runCommand l
 106           uiLoop
 107
 108 mkPrompt Nothing = ""
 109 mkPrompt (Just mod_name) = moduleNameUserString mod_name
 110
 111 -- Top level exception handler, just prints out the exception
 112 -- and carries on.
 113 runCommand c =
 114   ghciHandle ( \other_exception ->io (putStrLn (show other_exception) )) $
 115   ghciHandleDyn
 116     (\dyn -> case dyn of
 117                 PhaseFailed phase code ->
 118                         io ( putStrLn ("Phase " ++ phase ++ " failed (code "
 119                                         ++ show code ++ ")"))
 120                 Interrupted -> io (putStrLn "Interrupted.")
 121                 _ -> io (putStrLn (show (dyn :: BarfKind)))
 122     ) $
 123    doCommand c
 124
 125 doCommand (':' : command) = specialCommand command
 126 doCommand expr = do
 127   st <- getGHCiState
 128   case current_module st of
 129         Nothing -> throwDyn (OtherError "no module context in which to run the expression")
 130         Just mod -> do
 131              dflags <- io (readIORef v_DynFlags)
 132              (st, maybe_hvalue) <-
 133                 io (cmGetExpr (cmstate st) dflags mod expr)
 134              case maybe_hvalue of
 135                 Nothing -> return ()
 136                 Just hv -> io (cmRunExpr hv)
 137 {-
 138   let (mod,'.':str) = break (=='.') expr
 139   case cmLookupSymbol (mkOrig varName (mkModuleName mod) (_PK_ str)) (cmstate st) of
 140         Nothing -> io (putStrLn "nothing.")
 141         Just e  -> io (
 142   return ()
 143 -}
 144
 145 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 146 specialCommand str = do
 147   let (cmd,rest) = break isSpace str
 148   case [ (s,f) | (s,f) <- commands, prefixMatch cmd s ] of
 149      []      -> io $ hPutStr stdout ("uknown command `:" ++ cmd ++ "'\n"
 150                                     ++ shortHelpText)
 151      [(_,f)] -> f (dropWhile isSpace rest)
 152      cs      -> io $ hPutStrLn stdout ("prefix " ++ cmd ++
 153                                        " matches multiple commands (" ++
 154                                        foldr1 (\a b -> a ++ ',':b) (map fst cs)
 155                                          ++ ")")
 156
 157 noArgs c = io (hPutStrLn stdout ("command `:" ++ c ++ "' takes no arguments"))
 158
 159 -----------------------------------------------------------------------------
 160 -- Commands
 161
 162 help :: String -> GHCi ()
 163 help _ = io (putStr helpText)
 164
 165 changeDirectory :: String -> GHCi ()
 166 changeDirectory = io . setCurrentDirectory
 167
 168 loadModule :: String -> GHCi ()
 169 loadModule path = do
 170   state <- getGHCiState
 171   (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
 172
 173   let new_state = GHCiState {
 174                         cmstate = new_cmstate,
 175                         modules = mods,
 176                         current_module = case mods of
 177                                            [] -> Nothing
 178                                            xs -> Just (last xs),
 179                         target = Just path
 180                    }
 181   setGHCiState new_state
 182
 183   let mod_commas
 184         | null mods = text "none."
 185         | otherwise = hsep (
 186             punctuate comma (map (text.moduleNameUserString) mods)) <> text "."
 187   case ok of
 188     False ->
 189        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 190     True  ->
 191        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 192
 193 reloadModule :: String -> GHCi ()
 194 reloadModule "" = do
 195   state <- getGHCiState
 196   case target state of
 197    Nothing -> io (putStr "no current target\n")
 198    Just path -> do (new_cmstate, ok, mod)
 199                         <- io (cmLoadModule (cmstate state) path)
 200                    setGHCiState state{cmstate=new_cmstate}
 201 reloadModule _ = noArgs ":reload"
 202
 203 -- set options in the interpreter.  Syntax is exactly the same as the
 204 -- ghc command line, except that certain options aren't available (-C,
 205 -- -E etc.)
 206 --
 207 -- This is pretty fragile: most options won't work as expected.  ToDo:
 208 -- figure out which ones & disallow them.
 209 setOptions :: String -> GHCi ()
 210 setOptions str =
 211    io (do leftovers <- processArgs static_flags (words str) []
 212           dyn_flags <- readIORef v_InitDynFlags
 213           writeIORef v_DynFlags dyn_flags
 214           leftovers <- processArgs dynamic_flags leftovers []
 215           dyn_flags <- readIORef v_DynFlags
 216           writeIORef v_InitDynFlags dyn_flags
 217           if (not (null leftovers))
 218                 then throwDyn (OtherError ("unrecognised flags: " ++
 219                                                 unwords leftovers))
 220                 else return ()
 221    )
 222
 223 typeOfExpr :: String -> GHCi ()
 224 typeOfExpr = panic "typeOfExpr"
 225
 226 quit :: String -> GHCi ()
 227 quit _ = return ()
 228
 229 shellEscape :: String -> GHCi ()
 230 shellEscape str = io (system str >> return ())
 231
 232 -----------------------------------------------------------------------------
 233 -- GHCi monad
 234
 235 data GHCiState = GHCiState
 236      {
 237         modules        :: [ModuleName],
 238         current_module :: Maybe ModuleName,
 239         target         :: Maybe FilePath,
 240         cmstate        :: CmState
 241      }
 242
 243 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
 244
 245 instance Monad GHCi where
 246   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
 247   return a  = GHCi $ \s -> return (s,a)
 248
 249 getGHCiState   = GHCi $ \s -> return (s,s)
 250 setGHCiState s = GHCi $ \_ -> return (s,())
 251
 252 io m = GHCi $ \s -> m >>= \a -> return (s,a)
 253
 254 ghciHandle h (GHCi m) = GHCi $ \s ->
 255    Exception.catch (m s) (\e -> unGHCi (h e) s)
 256 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
 257    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
 258
 259 -----------------------------------------------------------------------------
 260 -- package loader
 261
 262 linkPackages :: [Package] -> IO ()
 263 linkPackages pkgs = mapM_ linkPackage pkgs
 264
 265 linkPackage :: Package -> IO ()
 266 -- ignore rts and gmp for now (ToDo; better?)
 267 linkPackage pkg | name pkg `elem` ["rts", "gmp"] = return ()
 268 linkPackage pkg = do
 269   putStr ("Loading package " ++ name pkg ++ " ... ")
 270   let dirs = library_dirs pkg
 271   let objs = map (++".o") (hs_libraries pkg ++ extra_libraries pkg)
 272   mapM (linkOneObj dirs) objs
 273   putStr "resolving ... "
 274   resolveObjs
 275   putStrLn "done."
 276
 277 linkOneObj dirs obj = do
 278   filename <- findFile dirs obj
 279   loadObj filename
 280
 281 findFile [] obj = throwDyn (OtherError ("can't find " ++ obj))
 282 findFile (d:ds) obj = do
 283   let path = d ++ '/':obj
 284   b <- doesFileExist path
 285   if b then return path else findFile ds obj