ghc/compiler/ghci/InteractiveUI.hs

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