-----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.41 2001/02/11 14:33:27 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.49 2001/02/13 18:37:53 qrczak Exp $
--
-- GHC Interactive User Interface
--
--
-----------------------------------------------------------------------------
-module InteractiveUI (interactiveUI) where
+{-# OPTIONS -#include "Linker.h" #-}
+module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
#include "HsVersions.h"
import Directory
import IO
import Char
-import Monad ( when )
+import Monad ( when )
import PrelGHC ( unsafeCoerce# )
+import PrelPack ( packString )
+import PrelByteArr
+import Foreign ( Ptr, nullPtr )
-----------------------------------------------------------------------------
\ (eg. -v2, -fglasgow-exts, etc.)\n\
\"
-interactiveUI :: CmState -> Maybe FilePath -> IO ()
-interactiveUI cmstate mod = do
- hPutStrLn stdout ghciWelcomeMsg
+interactiveUI :: CmState -> Maybe FilePath -> [String] -> 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
= 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)
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
= throwDyn (OtherError "syntax: `:m <module>'")
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
+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")))
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)
-----------------------------------------------------------------------------
-- package loader
-linkPackages :: [Package] -> IO ()
-linkPackages pkgs = mapM_ linkPackage pkgs
+linkPackages :: [String] -> [Package] -> IO ()
+linkPackages cmdline_libs pkgs
+ = do mapM preloadLib cmdline_libs
+ mapM_ linkPackage pkgs
+ where
+ preloadLib orig_name
+ = do putStr ("Loading object " ++ orig_name ++ " ... ")
+ case classify orig_name 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 dll_ok <- addDLL dll_unadorned
+ if dll_ok
+ then putStr "done.\n"
+ else do putStr "not found.\n"
+ croak
+
+ croak = throwDyn (OtherError "user specified .o/.so/.DLL cannot be found.")
+
+ classify a_lib
+ = let a_libr = reverse a_lib
+ in
+ case map toLower a_libr of
+ ('o':'.':_)
+ -> Left a_lib
+ ('o':'s':'.':_)
+ -> (Right . zap_leading_lib
+ . reverse . drop 3 . reverse) a_lib
+ ('l':'l':'d':'.':_)
+ -> (Right . reverse . drop 4 . reverse) a_lib
+ other
+ -> -- Main.beginInteractive should not have let this through
+ pprPanic "linkPackages" (text (show a_lib))
+
+ zap_leading_lib str
+ = if take 3 str == "lib" then drop 3 str else str
+
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 :: Either FilePath String -> IO ()
+loadClassified (Left obj_absolute_filename)
+ = do loadObj obj_absolute_filename
+loadClassified (Right dll_unadorned)
+ = do dll_ok <- addDLL dll_unadorned
+ if dll_ok
+ then return ()
+ else throwDyn (OtherError ("can't find .o or .so/.DLL for: "
+ ++ dll_unadorned))
+
+locateOneObj :: [FilePath] -> String -> IO (Either FilePath String)
+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