ghc/compiler/ghci/InteractiveUI.hs

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