X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FInteractiveUI.hs;h=063b3be30955019632420a36a88a49e4e0949ba8;hb=3b6b5789852e84639be18d114cad4bde6139847e;hp=3ee44dcc15cef383d5e1483ed13689a8b1007f19;hpb=bb14c2af6576b5a470d4b7439105a5bbe2e864ca;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 3ee44dc..063b3be 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.33 2001/02/06 16:22:12 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.51 2001/02/14 11:36:07 sewardj Exp $ -- -- GHC Interactive User Interface -- @@ -7,7 +7,8 @@ -- ----------------------------------------------------------------------------- -module InteractiveUI (interactiveUI) where +{-# OPTIONS -#include "Linker.h" #-} +module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where #include "HsVersions.h" @@ -25,8 +26,10 @@ import Outputable import Util import PprType {- instance Outputable Type; do not delete -} import Panic ( GhcException(..) ) +import Config import Exception +import Dynamic #ifndef NO_READLINE import Readline #endif @@ -39,23 +42,30 @@ import CPUTime import Directory import IO import Char -import Monad ( when ) +import Monad ( when ) +import PrelGHC ( unsafeCoerce# ) +import PrelPack ( packString ) +import PrelByteArr +import Foreign ( nullPtr ) +import CString ( peekCString ) ----------------------------------------------------------------------------- ghciWelcomeMsg = "\ -\ _____ __ __ ____ _________________________________________________\n\ -\(| || || (| |) GHC Interactive, version 5.00 \n\ -\|| __ ||___|| || () For Haskell 98. \n\ -\|| |) ||---|| || || http://www.haskell.org/ghc \n\ -\|| || || || || (| Bug reports to: glasgow-haskell-bugs@haskell.org \n\ -\(|___|| || || (|__|) \\\\______________________________________________________\n" - -commands :: [(String, String -> GHCi Bool)] -commands = [ +\ ___ ___ _\n\ +\ / _ \\ /\\ /\\/ __(_)\n\ +\ / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", For Haskell 98.\n\ +\/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n\ +\\\____/\\/ /_/\\____/|_| Type :? for help.\n" + +GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)]) + +builtin_commands :: [(String, String -> GHCi Bool)] +builtin_commands = [ ("add", keepGoing addModule), ("cd", keepGoing changeDirectory), + ("def", keepGoing defineMacro), ("help", keepGoing help), ("?", keepGoing help), ("load", keepGoing loadModule), @@ -64,6 +74,7 @@ commands = [ ("set", keepGoing setOptions), ("type", keepGoing typeOfExpr), ("unset", keepGoing unsetOptions), + ("undef", keepGoing undefineMacro), ("quit", quit) ] @@ -97,15 +108,15 @@ helpText = "\ \ (eg. -v2, -fglasgow-exts, etc.)\n\ \" -interactiveUI :: CmState -> Maybe FilePath -> IO () -interactiveUI cmstate mod = do - hPutStrLn stdout ghciWelcomeMsg +interactiveUI :: CmState -> Maybe FilePath -> [LibrarySpec] -> IO () +interactiveUI cmstate mod cmdline_libs = do hFlush stdout hSetBuffering stdout NoBuffering -- link in the available packages pkgs <- getPackageInfo - linkPackages (reverse pkgs) + initLinker + linkPackages cmdline_libs (reverse pkgs) (cmstate, ok, mods) <- case mod of @@ -137,7 +148,7 @@ interactiveUI cmstate mod = do [] -> prel m:ms -> m - (unGHCi uiLoop) GHCiState{ modules = mods, + (unGHCi runGHCi) GHCiState{ modules = mods, current_module = this_mod, target = mod, cmstate = cmstate, @@ -146,49 +157,96 @@ interactiveUI cmstate mod = do return () -uiLoop :: GHCi () -uiLoop = do - st <- getGHCiState +runGHCi :: GHCi () +runGHCi = do + -- read in ./.ghci + dot_ghci <- io (IO.try (openFile "./.ghci" ReadMode)) + case dot_ghci of + Left e -> return () + Right hdl -> fileLoop hdl False + + -- read in ~/.ghci + home <- io (IO.try (getEnv "HOME")) + case home of + Left e -> return () + Right dir -> do + dot_ghci <- io (IO.try (openFile (dir ++ "/.ghci") ReadMode)) + case dot_ghci of + Left e -> return () + Right hdl -> fileLoop hdl False + + -- read commands from stdin #ifndef NO_READLINE - l <- io (readline (moduleUserString (current_module st) ++ "> ")) + readlineLoop #else - l_ok <- io (hGetLine stdin) - let l = Just l_ok + fileLoop stdin True #endif - case l of { - Nothing -> exitGHCi; - Just l -> - case remove_spaces l of { - "" -> uiLoop; - l -> do + -- and finally, exit + io $ do putStrLn "Leaving GHCi." + + +fileLoop :: Handle -> Bool -> GHCi () +fileLoop hdl prompt = do + st <- getGHCiState + when prompt (io (hPutStr hdl (moduleUserString (current_module st) ++ "> "))) + l <- io (IO.try (hGetLine hdl)) + case l of + Left e | isEOFError e -> return () + | otherwise -> throw e + Right l -> + case remove_spaces l of + "" -> fileLoop hdl prompt + l -> do quit <- runCommand l + if quit then return () else fileLoop hdl prompt + +stringLoop :: [String] -> GHCi () +stringLoop [] = return () +stringLoop (s:ss) = do + st <- getGHCiState + case remove_spaces s of + "" -> stringLoop ss + l -> do quit <- runCommand l + if quit then return () else stringLoop ss + #ifndef NO_READLINE - io (addHistory l) +readlineLoop :: GHCi () +readlineLoop = do + st <- getGHCiState + l <- io (readline (moduleUserString (current_module st) ++ "> ")) + case l of + Nothing -> return () + Just l -> + case remove_spaces l of + "" -> readlineLoop + l -> do + io (addHistory l) + quit <- runCommand l + if quit then return () else readlineLoop #endif - quit <- runCommand l - if quit then exitGHCi else uiLoop - }} - - -exitGHCi = io $ do putStrLn "Leaving GHCi." -- Top level exception handler, just prints out the exception -- and carries on. runCommand :: String -> GHCi Bool runCommand c = - ghciHandle ( - \other_exception - -> io (putStrLn (show other_exception)) >> return False - ) $ - ghciHandleDyn - (\dyn -> case dyn of - PhaseFailed phase code -> + ghciHandle ( \exception -> + (case exception of + DynException dyn -> + case fromDynamic dyn of + Nothing -> io (putStrLn ("*** Exception: (unknown)")) + Just ghc_ex -> + case ghc_ex of + PhaseFailed phase code -> io ( putStrLn ("Phase " ++ phase ++ " failed (code " ++ show code ++ ")")) - Interrupted -> io (putStrLn "Interrupted.") - _ -> io (putStrLn (show (dyn :: GhcException))) - >> return False - ) $ + Interrupted -> io (putStrLn "Interrupted.") + other -> io (putStrLn (show (ghc_ex :: GhcException))) + + other -> io (putStrLn ("*** Exception: " ++ show exception)) + + ) >> return False + ) $ + doCommand c doCommand (':' : command) = specialCommand command @@ -197,25 +255,16 @@ doCommand expr = do expr_expanded <- expandExpr expr -- io (putStrLn ( "Before: " ++ expr ++ "\nAfter: " ++ expr_expanded)) expr_ok <- timeIt (do stuff <- evalExpr expr_expanded - finishEvalExpr stuff) + finishEvalExpr expr_expanded stuff) when expr_ok (rememberExpr expr_expanded) return False --- possibly print the type and revert CAFs after evaluating an expression -finishEvalExpr Nothing = return False -finishEvalExpr (Just (unqual,ty)) - = do b <- isOptionSet ShowType - io (when b (printForUser stdout unqual (text "::" <+> ppr ty))) - b <- isOptionSet RevertCAFs - io (when b revertCAFs) - return True - --- Returned Bool indicates whether or not the expr was successfully --- parsed, renamed and typechecked. -evalExpr :: String -> GHCi (Maybe (PrintUnqualified,Type)) +-- Returns True if the expr was successfully parsed, renamed and +-- typechecked. +evalExpr :: String -> GHCi Bool evalExpr expr | null (filter (not.isSpace) expr) - = return Nothing + = return False | otherwise = do st <- getGHCiState dflags <- io (getDynFlags) @@ -223,10 +272,21 @@ evalExpr expr io (cmGetExpr (cmstate st) dflags True (current_module st) expr) setGHCiState st{cmstate = new_cmstate} case maybe_stuff of - Nothing -> return Nothing - Just (hv, unqual, ty) -> do io (cmRunExpr hv) - flushEverything - return (Just (unqual,ty)) + Nothing -> return False + Just (hv, unqual, ty) -> + do io (cmRunExpr hv) + return True + +-- possibly print the type and revert CAFs after evaluating an expression +finishEvalExpr _ False = return False +finishEvalExpr expr True + = do b <- isOptionSet ShowType + -- re-typecheck, don't wrap with print this time + when b (io (putStr ":: ") >> typeOfExpr expr) + b <- isOptionSet RevertCAFs + io (when b revertCAFs) + flushEverything + return True flushEverything :: GHCi () flushEverything @@ -239,7 +299,8 @@ specialCommand :: String -> GHCi Bool specialCommand ('!':str) = shellEscape (dropWhile isSpace str) specialCommand str = do let (cmd,rest) = break isSpace str - case [ (s,f) | (s,f) <- commands, prefixMatch cmd s ] of + cmds <- io (readIORef commands) + case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n" ++ shortHelpText) >> return False) [(_,f)] -> f (dropWhile isSpace rest) @@ -264,22 +325,76 @@ setContext "" = throwDyn (OtherError "syntax: `:m '") setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m)) = throwDyn (OtherError ("strange looking module name: `" ++ m ++ "'")) -setContext mn - = do m <- io (moduleNameToModule (mkModuleName mn)) - st <- getGHCiState - setGHCiState st{current_module = m} +setContext str + = do st <- getGHCiState + + let mn = mkModuleName str + m <- case [ m | m <- modules st, moduleName m == mn ] of + (m:_) -> return m + [] -> io (moduleNameToModule mn) + + if (isHomeModule m && m `notElem` modules st) + then throwDyn (OtherError (showSDoc (quotes (ppr (moduleName m)) + <+> text "is not currently loaded, use :load"))) + else setGHCiState st{current_module = m} moduleNameToModule :: ModuleName -> IO Module moduleNameToModule mn = do maybe_stuff <- findModule mn case maybe_stuff of - Nothing -> throwDyn (OtherError ("can't find module `" - ++ moduleNameUserString mn ++ "'")) - Just (m,_) -> return m + Nothing -> throwDyn (OtherError ("can't find module `" + ++ moduleNameUserString mn ++ "'")) + Just (m,_) -> return m changeDirectory :: String -> GHCi () changeDirectory d = io (setCurrentDirectory d) +defineMacro :: String -> GHCi () +defineMacro s = do + let (macro_name, definition) = break isSpace s + cmds <- io (readIORef commands) + if (null macro_name) + then throwDyn (OtherError "invalid macro name") + else do + if (macro_name `elem` map fst cmds) + then throwDyn (OtherError + ("command `" ++ macro_name ++ "' already defined")) + else do + + -- give the expression a type signature, so we can be sure we're getting + -- something of the right type. + let new_expr = '(' : definition ++ ") :: String -> IO String" + + -- compile the expression + st <- getGHCiState + dflags <- io (getDynFlags) + (new_cmstate, maybe_stuff) <- + io (cmGetExpr (cmstate st) dflags False (current_module st) new_expr) + setGHCiState st{cmstate = new_cmstate} + case maybe_stuff of + Nothing -> return () + Just (hv, unqual, ty) + -> io (writeIORef commands + ((macro_name, keepGoing (runMacro hv)) : cmds)) + +runMacro :: HValue{-String -> IO String-} -> String -> GHCi () +runMacro fun s = do + str <- io ((unsafeCoerce# fun :: String -> IO String) s) + stringLoop (lines str) + +undefineMacro :: String -> GHCi () +undefineMacro macro_name = do + cmds <- io (readIORef commands) + if (macro_name `elem` map fst builtin_commands) + then throwDyn (OtherError + ("command `" ++ macro_name ++ "' cannot be undefined")) + else do + if (macro_name `notElem` map fst cmds) + then throwDyn (OtherError + ("command `" ++ macro_name ++ "' not defined")) + else do + io (writeIORef commands (filter ((/= macro_name) . fst) cmds)) + loadModule :: String -> GHCi () loadModule path = timeIt (loadModule' path) @@ -538,38 +653,102 @@ setLastExpr last_expr io m = GHCi $ \s -> m >>= \a -> return (s,a) +----------------------------------------------------------------------------- +-- recursive exception handlers + +-- Don't forget to unblock async exceptions in the handler, or if we're +-- in an exception loop (eg. let a = error a in a) the ^C exception +-- may never be delivered. Thanks to Marcin for pointing out the bug. + +ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a ghciHandle h (GHCi m) = GHCi $ \s -> - Exception.catch (m s) (\e -> unGHCi (h e) s) -ghciHandleDyn h (GHCi m) = GHCi $ \s -> - Exception.catchDyn (m s) (\e -> unGHCi (h e) s) + Exception.catch (m s) + (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s) + +ghciUnblock :: GHCi a -> GHCi a +ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s) ----------------------------------------------------------------------------- -- package loader -linkPackages :: [Package] -> IO () -linkPackages pkgs = mapM_ linkPackage pkgs +-- Left: full path name of a .o file, including trailing .o +-- Right: "unadorned" name of a .DLL/.so +-- e.g. On unix "qt" denotes "libqt.so" +-- On WinDoze "burble" denotes "burble.DLL" +-- addDLL is platform-specific and adds the lib/.so/.DLL +-- prefixes plaform-dependently; we don't do that here. +type LibrarySpec + = Either FilePath String + +showLS (Left nm) = "(static) " ++ nm +showLS (Right nm) = "(dynamic) " ++ nm + +linkPackages :: [LibrarySpec] -> [Package] -> IO () +linkPackages cmdline_lib_specs pkgs + = do mapM_ linkPackage pkgs + mapM_ preloadLib cmdline_lib_specs + where + preloadLib lib_spec + = do putStr ("Loading object " ++ showLS lib_spec ++ " ... ") + case lib_spec of + Left static_ish + -> do b <- doesFileExist static_ish + if not b + then do putStr "not found.\n" + croak + else do loadObj static_ish + putStr "done.\n" + Right dll_unadorned + -> do maybe_errmsg <- addDLL dll_unadorned + if maybe_errmsg == nullPtr + then putStr "done.\n" + else do str <- peekCString maybe_errmsg + putStr ("failed (" ++ str ++ ")\n") + croak + + croak = throwDyn (OtherError "user specified .o/.so/.DLL could not be loaded.") + linkPackage :: Package -> IO () -- ignore rts and gmp for now (ToDo; better?) -linkPackage pkg | name pkg `elem` ["rts", "gmp"] = return () -linkPackage pkg = do - putStr ("Loading package " ++ name pkg ++ " ... ") - let dirs = library_dirs pkg - let objs = map (++".o") (hs_libraries pkg ++ extra_libraries pkg) - mapM (linkOneObj dirs) objs - putStr "resolving ... " - resolveObjs - putStrLn "done." - -linkOneObj dirs obj = do - filename <- findFile dirs obj - loadObj filename - -findFile [] obj = throwDyn (OtherError ("can't find " ++ obj)) -findFile (d:ds) obj = do - let path = d ++ '/':obj - b <- doesFileExist path - if b then return path else findFile ds obj +linkPackage pkg + | name pkg `elem` ["rts", "gmp"] + = return () + | otherwise + = do putStr ("Loading package " ++ name pkg ++ " ... ") + -- For each obj, try obj.o and if that fails, obj.so. + -- Complication: all the .so's must be loaded before any of the .o's. + let dirs = library_dirs pkg + let objs = hs_libraries pkg ++ extra_libraries pkg + classifieds <- mapM (locateOneObj dirs) objs + let sos_first = filter isRight classifieds + ++ filter (not.isRight) classifieds + mapM loadClassified sos_first + putStr "linking ... " + resolveObjs + putStrLn "done." + where + isRight (Right _) = True + isRight (Left _) = False + +loadClassified :: LibrarySpec -> IO () +loadClassified (Left obj_absolute_filename) + = do loadObj obj_absolute_filename +loadClassified (Right dll_unadorned) + = do maybe_errmsg <- addDLL dll_unadorned + if maybe_errmsg == nullPtr + then return () + else do str <- peekCString maybe_errmsg + throwDyn (OtherError ("can't find .o or .so/.DLL for: " + ++ dll_unadorned ++ " (" ++ str ++ ")" )) + +locateOneObj :: [FilePath] -> String -> IO LibrarySpec +locateOneObj [] obj + = return (Right obj) -- we assume +locateOneObj (d:ds) obj + = do let path = d ++ '/':obj ++ ".o" + b <- doesFileExist path + if b then return (Left path) else locateOneObj ds obj ----------------------------------------------------------------------------- -- timing & statistics