ghc/compiler/ghci/InteractiveUI.hs

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