ghc/compiler/ghci/InteractiveUI.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: InteractiveUI.hs,v 1.13 2000/11/22 15:51:48 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   cmstate1 <- io (cmUnload (cmstate state))
 184   (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
 185
 186   let new_state = GHCiState {
 187                         cmstate = cmstate2,
 188                         modules = mods,
 189                         current_module = case mods of
 190                                            [] -> defaultCurrentModule
 191                                            xs -> last xs,
 192                         target = Just path
 193                    }
 194   setGHCiState new_state
 195
 196   let mod_commas
 197         | null mods = text "none."
 198         | otherwise = hsep (
 199             punctuate comma (map (text.moduleNameUserString) mods)) <> text "."
 200   case ok of
 201     False ->
 202        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 203     True  ->
 204        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 205
 206 reloadModule :: String -> GHCi ()
 207 reloadModule "" = do
 208   state <- getGHCiState
 209   case target state of
 210    Nothing -> io (putStr "no current target\n")
 211    Just path
 212       -> do (new_cmstate, ok, mod) <- io (cmLoadModule (cmstate state) path)
 213             setGHCiState state{cmstate=new_cmstate}
 214 reloadModule _ = noArgs ":reload"
 215
 216 -- set options in the interpreter.  Syntax is exactly the same as the
 217 -- ghc command line, except that certain options aren't available (-C,
 218 -- -E etc.)
 219 --
 220 -- This is pretty fragile: most options won't work as expected.  ToDo:
 221 -- figure out which ones & disallow them.
 222 setOptions :: String -> GHCi ()
 223 setOptions str =
 224    io (do leftovers <- processArgs static_flags (words str) []
 225           dyn_flags <- readIORef v_InitDynFlags
 226           writeIORef v_DynFlags dyn_flags
 227           leftovers <- processArgs dynamic_flags leftovers []
 228           dyn_flags <- readIORef v_DynFlags
 229           writeIORef v_InitDynFlags dyn_flags
 230           if (not (null leftovers))
 231                 then throwDyn (OtherError ("unrecognised flags: " ++
 232                                                 unwords leftovers))
 233                 else return ()
 234    )
 235
 236 typeOfExpr :: String -> GHCi ()
 237 typeOfExpr str
 238   = do st <- getGHCiState
 239        dflags <- io (getDynFlags)
 240        (st, maybe_ty) <- io (cmTypeExpr (cmstate st) dflags
 241                                 (current_module st) str)
 242        case maybe_ty of
 243          Nothing -> return ()
 244          Just (unqual, ty) -> io (printForUser stdout unqual (ppr ty))
 245
 246 quit :: String -> GHCi ()
 247 quit _ = exitGHCi
 248
 249 shellEscape :: String -> GHCi ()
 250 shellEscape str = io (system str >> return ())
 251
 252 -----------------------------------------------------------------------------
 253 -- GHCi monad
 254
 255 data GHCiState = GHCiState
 256      {
 257         modules        :: [ModuleName],
 258         current_module :: ModuleName,
 259         target         :: Maybe FilePath,
 260         cmstate        :: CmState
 261      }
 262
 263 defaultCurrentModule = mkModuleName "Prelude"
 264
 265 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
 266
 267 instance Monad GHCi where
 268   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
 269   return a  = GHCi $ \s -> return (s,a)
 270
 271 getGHCiState   = GHCi $ \s -> return (s,s)
 272 setGHCiState s = GHCi $ \_ -> return (s,())
 273
 274 io m = GHCi $ \s -> m >>= \a -> return (s,a)
 275
 276 ghciHandle h (GHCi m) = GHCi $ \s ->
 277    Exception.catch (m s) (\e -> unGHCi (h e) s)
 278 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
 279    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
 280
 281 -----------------------------------------------------------------------------
 282 -- package loader
 283
 284 linkPackages :: [Package] -> IO ()
 285 linkPackages pkgs = mapM_ linkPackage pkgs
 286
 287 linkPackage :: Package -> IO ()
 288 -- ignore rts and gmp for now (ToDo; better?)
 289 linkPackage pkg | name pkg `elem` ["rts", "gmp"] = return ()
 290 linkPackage pkg = do
 291   putStr ("Loading package " ++ name pkg ++ " ... ")
 292   let dirs = library_dirs pkg
 293   let objs = map (++".o") (hs_libraries pkg ++ extra_libraries pkg)
 294   mapM (linkOneObj dirs) objs
 295   putStr "resolving ... "
 296   resolveObjs
 297   putStrLn "done."
 298
 299 linkOneObj dirs obj = do
 300   filename <- findFile dirs obj
 301   loadObj filename
 302
 303 findFile [] obj = throwDyn (OtherError ("can't find " ++ obj))
 304 findFile (d:ds) obj = do
 305   let path = d ++ '/':obj
 306   b <- doesFileExist path
 307   if b then return path else findFile ds obj