ghc/compiler/ghci/InteractiveUI.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: InteractiveUI.hs,v 1.12 2000/11/22 11:12:52 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   ("add",       addModule),
  47   ("cd",        changeDirectory),
  48   ("help",      help),
  49   ("?",         help),
  50   ("load",      loadModule),
  51   ("module",    setContext),
  52   ("reload",    reloadModule),
  53   ("set",       setOptions),
  54   ("type",      typeOfExpr),
  55   ("quit",      quit)
  56   ]
  57
  58 shortHelpText = "use :? for help.\n"
  59
  60 helpText = "\
  61 \   <expr>              evaluate <expr>\n\
  62 \   :add <filename>     add a module to the current set\n\
  63 \   :cd <dir>           change directory to <dir>\n\
  64 \   :help, :?           display this list of commands\n\
  65 \   :load <filename>    load a module (and it dependents)\n\
  66 \   :module <mod>       set the context for expression evaluation to <mod>\n\
  67 \   :reload             reload the current module set\n\
  68 \   :set <option> ...   set options\n\
  69 \   :type <expr>        show the type of <expr>\n\
  70 \   :quit               exit GHCi\n\
  71 \   :!<command>         run the shell command <command>\n\
  72 \"
  73
  74 interactiveUI :: CmState -> IO ()
  75 interactiveUI st = do
  76    hPutStrLn stdout ghciWelcomeMsg
  77    hFlush stdout
  78    hSetBuffering stdout NoBuffering
  79
  80    -- link in the available packages
  81    pkgs <- getPackageInfo
  82    linkPackages (reverse pkgs)
  83
  84 #ifndef NO_READLINE
  85    Readline.initialize
  86 #endif
  87    _ <- (unGHCi uiLoop) GHCiState{ modules = [],
  88                                    current_module = defaultCurrentModule,
  89                                    target = Nothing,
  90                                    cmstate = st }
  91    return ()
  92
  93 uiLoop :: GHCi ()
  94 uiLoop = do
  95   st <- getGHCiState
  96 #ifndef NO_READLINE
  97   l <- io (readline (moduleNameUserString (current_module st) ++ "> "))
  98 #else
  99   l <- io (hGetLine stdin)
 100 #endif
 101   case l of
 102     Nothing -> exitGHCi
 103     Just "" -> uiLoop
 104     Just l  -> do
 105 #ifndef NO_READLINE
 106           io (addHistory l)
 107 #endif
 108           runCommand l
 109           uiLoop
 110
 111 exitGHCi = io $ do putStrLn "Leaving GHCi."; exitWith ExitSuccess
 112
 113 -- Top level exception handler, just prints out the exception
 114 -- and carries on.
 115 runCommand c =
 116   ghciHandle ( \other_exception ->io (putStrLn (show other_exception) )) $
 117   ghciHandleDyn
 118     (\dyn -> case dyn of
 119                 PhaseFailed phase code ->
 120                         io ( putStrLn ("Phase " ++ phase ++ " failed (code "
 121                                         ++ show code ++ ")"))
 122                 Interrupted -> io (putStrLn "Interrupted.")
 123                 _ -> io (putStrLn (show (dyn :: BarfKind)))
 124     ) $
 125    doCommand c
 126
 127 doCommand (':' : command) = specialCommand command
 128 doCommand expr
 129  = do st <- getGHCiState
 130       dflags <- io (getDynFlags)
 131       (new_cmstate, maybe_hvalue) <-
 132          io (cmGetExpr (cmstate st) dflags (current_module st) expr)
 133       setGHCiState st{cmstate = new_cmstate}
 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 ("unknown 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 addModule :: String -> GHCi ()
 166 addModule _ = throwDyn (OtherError ":add not implemented")
 167
 168 setContext :: String -> GHCi ()
 169 setContext ""
 170   = throwDyn (OtherError "syntax: `:m <module>'")
 171 setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m))
 172   = throwDyn (OtherError ("strange looking module name: `" ++ m ++ "'"))
 173 setContext m
 174   = do st <- getGHCiState
 175        setGHCiState st{current_module = mkModuleName m}
 176
 177 changeDirectory :: String -> GHCi ()
 178 changeDirectory = io . setCurrentDirectory
 179
 180 loadModule :: String -> GHCi ()
 181 loadModule path = do
 182   state <- getGHCiState
 183   (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
 184
 185   let new_state = GHCiState {
 186                         cmstate = new_cmstate,
 187                         modules = mods,
 188                         current_module = case mods of
 189                                            [] -> defaultCurrentModule
 190                                            xs -> last xs,
 191                         target = Just path
 192                    }
 193   setGHCiState new_state
 194
 195   let mod_commas
 196         | null mods = text "none."
 197         | otherwise = hsep (
 198             punctuate comma (map (text.moduleNameUserString) mods)) <> text "."
 199   case ok of
 200     False ->
 201        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 202     True  ->
 203        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 204
 205 reloadModule :: String -> GHCi ()
 206 reloadModule "" = do
 207   state <- getGHCiState
 208   case target state of
 209    Nothing -> io (putStr "no current target\n")
 210    Just path -> do (new_cmstate, ok, mod)
 211                         <- io (cmLoadModule (cmstate state) path)
 212                    setGHCiState state{cmstate=new_cmstate}
 213 reloadModule _ = noArgs ":reload"
 214
 215 -- set options in the interpreter.  Syntax is exactly the same as the
 216 -- ghc command line, except that certain options aren't available (-C,
 217 -- -E etc.)
 218 --
 219 -- This is pretty fragile: most options won't work as expected.  ToDo:
 220 -- figure out which ones & disallow them.
 221 setOptions :: String -> GHCi ()
 222 setOptions str =
 223    io (do leftovers <- processArgs static_flags (words str) []
 224           dyn_flags <- readIORef v_InitDynFlags
 225           writeIORef v_DynFlags dyn_flags
 226           leftovers <- processArgs dynamic_flags leftovers []
 227           dyn_flags <- readIORef v_DynFlags
 228           writeIORef v_InitDynFlags dyn_flags
 229           if (not (null leftovers))
 230                 then throwDyn (OtherError ("unrecognised flags: " ++
 231                                                 unwords leftovers))
 232                 else return ()
 233    )
 234
 235 typeOfExpr :: String -> GHCi ()
 236 typeOfExpr str
 237   = do st <- getGHCiState
 238        dflags <- io (getDynFlags)
 239        (st, maybe_ty) <- io (cmTypeExpr (cmstate st) dflags
 240                                 (current_module st) str)
 241        case maybe_ty of
 242          Nothing -> return ()
 243          Just (unqual, ty) -> io (printForUser stdout unqual (ppr ty))
 244
 245 quit :: String -> GHCi ()
 246 quit _ = exitGHCi
 247
 248 shellEscape :: String -> GHCi ()
 249 shellEscape str = io (system str >> return ())
 250
 251 -----------------------------------------------------------------------------
 252 -- GHCi monad
 253
 254 data GHCiState = GHCiState
 255      {
 256         modules        :: [ModuleName],
 257         current_module :: ModuleName,
 258         target         :: Maybe FilePath,
 259         cmstate        :: CmState
 260      }
 261
 262 defaultCurrentModule = mkModuleName "Prelude"
 263
 264 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
 265
 266 instance Monad GHCi where
 267   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
 268   return a  = GHCi $ \s -> return (s,a)
 269
 270 getGHCiState   = GHCi $ \s -> return (s,s)
 271 setGHCiState s = GHCi $ \_ -> return (s,())
 272
 273 io m = GHCi $ \s -> m >>= \a -> return (s,a)
 274
 275 ghciHandle h (GHCi m) = GHCi $ \s ->
 276    Exception.catch (m s) (\e -> unGHCi (h e) s)
 277 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
 278    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
 279
 280 -----------------------------------------------------------------------------
 281 -- package loader
 282
 283 linkPackages :: [Package] -> IO ()
 284 linkPackages pkgs = mapM_ linkPackage pkgs
 285
 286 linkPackage :: Package -> IO ()
 287 -- ignore rts and gmp for now (ToDo; better?)
 288 linkPackage pkg | name pkg `elem` ["rts", "gmp"] = return ()
 289 linkPackage pkg = do
 290   putStr ("Loading package " ++ name pkg ++ " ... ")
 291   let dirs = library_dirs pkg
 292   let objs = map (++".o") (hs_libraries pkg ++ extra_libraries pkg)
 293   mapM (linkOneObj dirs) objs
 294   putStr "resolving ... "
 295   resolveObjs
 296   putStrLn "done."
 297
 298 linkOneObj dirs obj = do
 299   filename <- findFile dirs obj
 300   loadObj filename
 301
 302 findFile [] obj = throwDyn (OtherError ("can't find " ++ obj))
 303 findFile (d:ds) obj = do
 304   let path = d ++ '/':obj
 305   b <- doesFileExist path
 306   if b then return path else findFile ds obj