ghc/compiler/ghci/InteractiveUI.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: InteractiveUI.hs,v 1.2 2000/11/16 11:39:37 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 import CompManager
  13 import CmStaticInfo
  14 import DriverUtil
  15 import DriverState
  16 import Linker
  17 import Module
  18 import Panic
  19 import Util
  20
  21 import Exception
  22 import Readline
  23 import IOExts
  24
  25 import System
  26 import Directory
  27 import IO
  28 import Char
  29
  30 -----------------------------------------------------------------------------
  31
  32 ghciWelcomeMsg = "\
  33 \ _____  __   __  ____         _________________________________________________\n\
  34 \(|      ||   || (|  |)        GHC Interactive, version 5.00                    \n\
  35 \||  __  ||___|| ||     ()     For Haskell 98.                                  \n\
  36 \||   |) ||---|| ||     ||     http://www.haskell.org/ghc                       \n\
  37 \||   || ||   || ||     (|     Bug reports to: glasgow-haskell-bugs@haskell.org \n\
  38 \(|___|| ||   || (|__|) \\\\______________________________________________________\n"
  39
  40 commands :: [(String, String -> GHCi ())]
  41 commands = [
  42   ("cd",        changeDirectory),
  43   ("help",      help),
  44   ("?",         help),
  45   ("load",      loadModule),
  46   ("reload",    reloadModule),
  47   ("set",       setOptions),
  48   ("type",      typeOfExpr),
  49   ("quit",      quit),
  50   ("!",         shellEscape)
  51   ]
  52
  53 shortHelpText = "use :? for help.\n"
  54
  55 helpText = "\
  56 \   <expr>              evaluate <expr>\n\
  57 \   :cd <dir>           change directory to <dir>\n\
  58 \   :help               display this list of commands\n\
  59 \   :?                  display this list of commands\n\
  60 \   :load <filename>    load a module (and it dependents)\n\
  61 \   :reload             reload the current program\n\
  62 \   :set <opetion> ...  set options\n\
  63 \   :type <expr>        show the type of <expr>\n\
  64 \   :quit               exit GHCi\n\
  65 \   :!<command>         run the shell command <command>\n\
  66 \"
  67
  68 interactiveUI :: CmState -> IO ()
  69 interactiveUI st = do
  70    hPutStrLn stdout ghciWelcomeMsg
  71    hFlush stdout
  72    hSetBuffering stdout NoBuffering
  73
  74    -- link in the available packages
  75    pkgs <- getPackageInfo
  76    linkPackages (reverse pkgs)
  77
  78 #ifndef NO_READLINE
  79    Readline.initialize
  80 #endif
  81    _ <- (unGHCi uiLoop) GHCiState{ current_module = mkModuleName "Prelude",
  82                                    target = Nothing,
  83                                    cmstate = st }
  84    return ()
  85
  86 uiLoop :: GHCi ()
  87 uiLoop = do
  88   st <- getGHCiState
  89 #ifndef NO_READLINE
  90   l <- io (readline (moduleNameUserString (current_module st)  ++ ">"))
  91 #else
  92   l <- io (hGetLine stdin)
  93 #endif
  94   case l of
  95     Nothing -> return ()
  96     Just "" -> uiLoop
  97     Just l  -> do
  98 #ifndef NO_READLINE
  99           io (addHistory l)
 100 #endif
 101           runCommand l
 102           uiLoop
 103
 104 runCommand c = myCatch (doCommand c)
 105                         (\e -> io (hPutStr stdout ("Error: " ++ show e)))
 106
 107 doCommand (':' : command) = specialCommand command
 108 doCommand expr = do
 109   io (hPutStrLn stdout ("Run expression: " ++ expr))
 110   return ()
 111
 112 specialCommand str = do
 113   let (cmd,rest) = break isSpace str
 114   case [ (s,f) | (s,f) <- commands, prefixMatch cmd s ] of
 115      []      -> io $ hPutStr stdout ("uknown command `:" ++ cmd ++ "'\n"
 116                                     ++ shortHelpText)
 117      [(_,f)] -> f rest
 118      cs      -> io $ hPutStrLn stdout ("prefix " ++ cmd ++
 119                                        " matches multiple commands (" ++
 120                                        foldr1 (\a b -> a ++ ',':b) (map fst cs) ++ ")")
 121
 122 noArgs c = io (hPutStrLn stdout ("command `:" ++ c ++ "' takes no arguments"))
 123
 124 -----------------------------------------------------------------------------
 125 -- Commands
 126
 127 -- ToDo: don't forget to catch errors
 128
 129 help :: String -> GHCi ()
 130 help _ = io (putStr helpText)
 131
 132 changeDirectory :: String -> GHCi ()
 133 changeDirectory = io . setCurrentDirectory
 134
 135 loadModule :: String -> GHCi ()
 136 loadModule path = do
 137   state <- getGHCiState
 138   (new_cmstate, mod) <- io (cmLoadModule (cmstate state) ({-ToDo!!-}mkModuleName path))
 139   setGHCiState state{cmstate=new_cmstate, target=Just path}
 140
 141 reloadModule :: String -> GHCi ()
 142 reloadModule "" = do
 143   state <- getGHCiState
 144   case target state of
 145         Nothing -> io (putStr "no current target\n")
 146         Just path -> do (new_cmstate, mod) <- io (cmLoadModule (cmstate state) (mkModuleName path))
 147                         setGHCiState state{cmstate=new_cmstate}
 148 reloadModule _ = noArgs ":reload"
 149
 150 setOptions :: String -> GHCi ()
 151 setOptions = panic "setOptions"
 152
 153 typeOfExpr :: String -> GHCi ()
 154 typeOfExpr = panic "typeOfExpr"
 155
 156 quit :: String -> GHCi ()
 157 quit _ = return ()
 158
 159 shellEscape :: String -> GHCi ()
 160 shellEscape str = io (system str >> return ())
 161
 162 -----------------------------------------------------------------------------
 163 -- GHCi monad
 164
 165 data GHCiState = GHCiState
 166      {
 167         current_module :: ModuleName,
 168         target         :: Maybe FilePath,
 169         cmstate        :: CmState
 170      }
 171
 172 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
 173
 174 instance Monad GHCi where
 175   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
 176   return a  = GHCi $ \s -> return (s,a)
 177
 178 getGHCiState   = GHCi $ \s -> return (s,s)
 179 setGHCiState s = GHCi $ \_ -> return (s,())
 180
 181 io m = GHCi $ \s -> m >>= \a -> return (s,a)
 182
 183 myCatch (GHCi m) h = GHCi $ \s -> Exception.catch (m s) (\e -> unGHCi (h e) s)
 184
 185 -----------------------------------------------------------------------------
 186 -- package loader
 187
 188 linkPackages :: [Package] -> IO ()
 189 linkPackages pkgs = mapM_ linkPackage pkgs
 190
 191 linkPackage :: Package -> IO ()
 192 -- ignore rts and gmp for now (ToDo; better?)
 193 linkPackage pkg | name pkg `elem` ["rts", "gmp"] = return ()
 194 linkPackage pkg = do
 195   putStr ("Loading package " ++ name pkg ++ " ... ")
 196   let dirs = library_dirs pkg
 197   let objs = map (++".o") (hs_libraries pkg ++ extra_libraries pkg)
 198   mapM (linkOneObj dirs) objs
 199   putStr "resolving ... "
 200   resolveObjs
 201   putStrLn "done."
 202
 203 linkOneObj dirs obj = do
 204   filename <- findFile dirs obj
 205   loadObj filename
 206
 207 findFile [] obj = throwDyn (OtherError ("can't find " ++ obj))
 208 findFile (d:ds) obj = do
 209   let path = d ++ '/':obj
 210   b <- doesFileExist path
 211   if b then return path else findFile ds obj
 212
 213