ghc/compiler/ghci/InteractiveUI.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: InteractiveUI.hs,v 1.7 2000/11/21 10:48:20 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              (new_cmstate, maybe_hvalue) <-
 133                 io (cmGetExpr (cmstate st) dflags mod expr)
 134              setGHCiState st{cmstate = new_cmstate}
 135              case maybe_hvalue of
 136                 Nothing -> return ()
 137                 Just hv -> io (cmRunExpr hv)
 138 {-
 139   let (mod,'.':str) = break (=='.') expr
 140   case cmLookupSymbol (mkOrig varName (mkModuleName mod) (_PK_ str)) (cmstate st) of
 141         Nothing -> io (putStrLn "nothing.")
 142         Just e  -> io (
 143   return ()
 144 -}
 145
 146 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 147 specialCommand str = do
 148   let (cmd,rest) = break isSpace str
 149   case [ (s,f) | (s,f) <- commands, prefixMatch cmd s ] of
 150      []      -> io $ hPutStr stdout ("uknown command `:" ++ cmd ++ "'\n"
 151                                     ++ shortHelpText)
 152      [(_,f)] -> f (dropWhile isSpace rest)
 153      cs      -> io $ hPutStrLn stdout ("prefix " ++ cmd ++
 154                                        " matches multiple commands (" ++
 155                                        foldr1 (\a b -> a ++ ',':b) (map fst cs)
 156                                          ++ ")")
 157
 158 noArgs c = io (hPutStrLn stdout ("command `:" ++ c ++ "' takes no arguments"))
 159
 160 -----------------------------------------------------------------------------
 161 -- Commands
 162
 163 help :: String -> GHCi ()
 164 help _ = io (putStr helpText)
 165
 166 changeDirectory :: String -> GHCi ()
 167 changeDirectory = io . setCurrentDirectory
 168
 169 loadModule :: String -> GHCi ()
 170 loadModule path = do
 171   state <- getGHCiState
 172   (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
 173
 174   let new_state = GHCiState {
 175                         cmstate = new_cmstate,
 176                         modules = mods,
 177                         current_module = case mods of
 178                                            [] -> Nothing
 179                                            xs -> Just (last xs),
 180                         target = Just path
 181                    }
 182   setGHCiState new_state
 183
 184   let mod_commas
 185         | null mods = text "none."
 186         | otherwise = hsep (
 187             punctuate comma (map (text.moduleNameUserString) mods)) <> text "."
 188   case ok of
 189     False ->
 190        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 191     True  ->
 192        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 193
 194 reloadModule :: String -> GHCi ()
 195 reloadModule "" = do
 196   state <- getGHCiState
 197   case target state of
 198    Nothing -> io (putStr "no current target\n")
 199    Just path -> do (new_cmstate, ok, mod)
 200                         <- io (cmLoadModule (cmstate state) path)
 201                    setGHCiState state{cmstate=new_cmstate}
 202 reloadModule _ = noArgs ":reload"
 203
 204 -- set options in the interpreter.  Syntax is exactly the same as the
 205 -- ghc command line, except that certain options aren't available (-C,
 206 -- -E etc.)
 207 --
 208 -- This is pretty fragile: most options won't work as expected.  ToDo:
 209 -- figure out which ones & disallow them.
 210 setOptions :: String -> GHCi ()
 211 setOptions str =
 212    io (do leftovers <- processArgs static_flags (words str) []
 213           dyn_flags <- readIORef v_InitDynFlags
 214           writeIORef v_DynFlags dyn_flags
 215           leftovers <- processArgs dynamic_flags leftovers []
 216           dyn_flags <- readIORef v_DynFlags
 217           writeIORef v_InitDynFlags dyn_flags
 218           if (not (null leftovers))
 219                 then throwDyn (OtherError ("unrecognised flags: " ++
 220                                                 unwords leftovers))
 221                 else return ()
 222    )
 223
 224 typeOfExpr :: String -> GHCi ()
 225 typeOfExpr = panic "typeOfExpr"
 226
 227 quit :: String -> GHCi ()
 228 quit _ = return ()
 229
 230 shellEscape :: String -> GHCi ()
 231 shellEscape str = io (system str >> return ())
 232
 233 -----------------------------------------------------------------------------
 234 -- GHCi monad
 235
 236 data GHCiState = GHCiState
 237      {
 238         modules        :: [ModuleName],
 239         current_module :: Maybe ModuleName,
 240         target         :: Maybe FilePath,
 241         cmstate        :: CmState
 242      }
 243
 244 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
 245
 246 instance Monad GHCi where
 247   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
 248   return a  = GHCi $ \s -> return (s,a)
 249
 250 getGHCiState   = GHCi $ \s -> return (s,s)
 251 setGHCiState s = GHCi $ \_ -> return (s,())
 252
 253 io m = GHCi $ \s -> m >>= \a -> return (s,a)
 254
 255 ghciHandle h (GHCi m) = GHCi $ \s ->
 256    Exception.catch (m s) (\e -> unGHCi (h e) s)
 257 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
 258    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
 259
 260 -----------------------------------------------------------------------------
 261 -- package loader
 262
 263 linkPackages :: [Package] -> IO ()
 264 linkPackages pkgs = mapM_ linkPackage pkgs
 265
 266 linkPackage :: Package -> IO ()
 267 -- ignore rts and gmp for now (ToDo; better?)
 268 linkPackage pkg | name pkg `elem` ["rts", "gmp"] = return ()
 269 linkPackage pkg = do
 270   putStr ("Loading package " ++ name pkg ++ " ... ")
 271   let dirs = library_dirs pkg
 272   let objs = map (++".o") (hs_libraries pkg ++ extra_libraries pkg)
 273   mapM (linkOneObj dirs) objs
 274   putStr "resolving ... "
 275   resolveObjs
 276   putStrLn "done."
 277
 278 linkOneObj dirs obj = do
 279   filename <- findFile dirs obj
 280   loadObj filename
 281
 282 findFile [] obj = throwDyn (OtherError ("can't find " ++ obj))
 283 findFile (d:ds) obj = do
 284   let path = d ++ '/':obj
 285   b <- doesFileExist path
 286   if b then return path else findFile ds obj