X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FInteractiveUI.hs;h=68147c06c3b875ddca144dbc405fcbcb471dfcd8;hb=41d0a61d29cb0daccbcdbf96a339c06c5aa140a4;hp=3ee44dcc15cef383d5e1483ed13689a8b1007f19;hpb=bb14c2af6576b5a470d4b7439105a5bbe2e864ca;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 3ee44dc..68147c0 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.53 2001/02/27 15:26:04 simonmar 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" @@ -17,16 +18,15 @@ import ByteCodeLink import DriverFlags import DriverState import DriverUtil -import Type import Linker -import Finder -import Module -import Outputable import Util -import PprType {- instance Outputable Type; do not delete -} +import Name ( Name ) +import Outputable import Panic ( GhcException(..) ) +import Config import Exception +import Dynamic #ifndef NO_READLINE import Readline #endif @@ -39,23 +39,28 @@ import CPUTime import Directory import IO import Char -import Monad ( when ) +import Monad ( when ) +import PrelGHC ( unsafeCoerce# ) +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 +69,7 @@ commands = [ ("set", keepGoing setOptions), ("type", keepGoing typeOfExpr), ("unset", keepGoing unsetOptions), + ("undef", keepGoing undefineMacro), ("quit", quit) ] @@ -75,7 +81,7 @@ shortHelpText = "use :? for help.\n" helpText = "\ \ Commands available from the prompt:\n\ \\ -\ evaluate \n\ +\ evaluate/run \n\ \ :add add a module to the current set\n\ \ :cd change directory to \n\ \ :help, :? display this list of commands\n\ @@ -97,15 +103,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 @@ -116,130 +122,172 @@ interactiveUI cmstate mod = do Readline.initialize #endif - prel <- moduleNameToModule defaultCurrentModuleName - writeIORef defaultCurrentModule prel - dflags <- getDynFlags - (cmstate, maybe_stuff) <- cmGetExpr cmstate dflags False prel - "PrelHandle.hFlush PrelHandle.stdout" - case maybe_stuff of - Nothing -> return () - Just (hv,_,_) -> writeIORef flush_stdout hv - - (cmstate, maybe_stuff) <- cmGetExpr cmstate dflags False prel - "PrelHandle.hFlush PrelHandle.stdout" - case maybe_stuff of - Nothing -> return () - Just (hv,_,_) -> writeIORef flush_stderr hv - - let this_mod = case mods of - [] -> prel - m:ms -> m - - (unGHCi uiLoop) GHCiState{ modules = mods, - current_module = this_mod, - target = mod, - cmstate = cmstate, - options = [ShowTiming], - last_expr = Nothing} + (cmstate, maybe_hval) + <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stderr" + case maybe_hval of + Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ()) + _ -> panic "interactiveUI:stderr" + + (cmstate, maybe_hval) + <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stdout" + case maybe_hval of + Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ()) + _ -> panic "interactiveUI:stdout" + + (unGHCi runGHCi) GHCiState{ target = mod, + cmstate = cmstate, + options = [ShowTiming] } 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 + mod <- io (cmGetContext (cmstate st)) + when prompt (io (hPutStr hdl (mod ++ "> "))) + 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 + mod <- io (cmGetContext (cmstate st)) + l <- io (readline (mod ++ "> ")) + 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 doCommand ('-':'-':_) = return False -- comments, useful in scripts -doCommand expr - = do expr_expanded <- expandExpr expr - -- io (putStrLn ( "Before: " ++ expr ++ "\nAfter: " ++ expr_expanded)) - expr_ok <- timeIt (do stuff <- evalExpr expr_expanded - finishEvalExpr stuff) - when expr_ok (rememberExpr expr_expanded) +doCommand stmt + = do timeIt (do stuff <- runStmt stmt; finishEvalExpr stuff) return False +-- Returns True if the expr was successfully parsed, renamed and +-- typechecked. +runStmt :: String -> GHCi (Maybe [Name]) +runStmt stmt + | null (filter (not.isSpace) stmt) + = return Nothing + | otherwise + = do st <- getGHCiState + dflags <- io (getDynFlags) + (new_cmstate, names) <- io (cmRunStmt (cmstate st) dflags stmt) + setGHCiState st{cmstate = new_cmstate} + return (Just names) + -- possibly print the type and revert CAFs after evaluating an expression finishEvalExpr Nothing = return False -finishEvalExpr (Just (unqual,ty)) +finishEvalExpr (Just names) = do b <- isOptionSet ShowType - io (when b (printForUser stdout unqual (text "::" <+> ppr ty))) + st <- getGHCiState + when b (mapM_ (showTypeOfName (cmstate st)) names) + b <- isOptionSet RevertCAFs io (when b revertCAFs) + flushEverything return True --- Returned Bool indicates whether or not the expr was successfully --- parsed, renamed and typechecked. -evalExpr :: String -> GHCi (Maybe (PrintUnqualified,Type)) -evalExpr expr - | null (filter (not.isSpace) expr) - = return Nothing - | otherwise - = do st <- getGHCiState - dflags <- io (getDynFlags) - (new_cmstate, maybe_stuff) <- - 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)) +showTypeOfName :: CmState -> Name -> GHCi () +showTypeOfName cmstate n + = do maybe_str <- io (cmTypeOfName cmstate n) + case maybe_str of + Nothing -> return () + Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str)) flushEverything :: GHCi () flushEverything = io $ do flush_so <- readIORef flush_stdout - cmRunExpr flush_so + flush_so flush_se <- readIORef flush_stdout - cmRunExpr flush_se + flush_se + return () 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 +312,63 @@ 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} - -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 +setContext str + = do st <- getGHCiState + new_cmstate <- io (cmSetContext (cmstate st) str) + setGHCiState st{cmstate=new_cmstate} 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 ++ "' is 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_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr) + setGHCiState st{cmstate = new_cmstate} + case maybe_hv of + Nothing -> return () + Just hv -> + do funs <- io (unsafeCoerce# hv :: IO [HValue]) + case funs of + [fun] -> io (writeIORef commands + ((macro_name, keepGoing (runMacro fun)) + : cmds)) + _ -> throwDyn (OtherError "defineMacro: bizarre") + +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) @@ -288,28 +377,11 @@ loadModule' path = do cmstate1 <- io (cmUnload (cmstate state)) io (revertCAFs) -- always revert CAFs on load. (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path) - - def_mod <- io (readIORef defaultCurrentModule) - - let new_state = state{ - cmstate = cmstate2, - modules = mods, - current_module = case mods of - [] -> def_mod - xs -> head xs, - target = Just path - } + let new_state = state{ cmstate = cmstate2, + target = Just path + } setGHCiState new_state - - let mod_commas - | null mods = text "none." - | otherwise = hsep ( - punctuate comma (map (text.moduleUserString) mods)) <> text "." - case ok of - False -> - io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))) - True -> - io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas))) + modulesLoadedMsg ok mods reloadModule :: String -> GHCi () reloadModule "" = do @@ -319,27 +391,33 @@ reloadModule "" = do Just path -> do io (revertCAFs) -- always revert CAFs on reload. (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path) - def_mod <- io (readIORef defaultCurrentModule) - setGHCiState - state{cmstate=new_cmstate, - modules = mods, - current_module = case mods of - [] -> def_mod - xs -> head xs - } + setGHCiState state{ cmstate=new_cmstate } + modulesLoadedMsg ok mods reloadModule _ = noArgs ":reload" + +modulesLoadedMsg ok mods = do + let mod_commas + | null mods = text "none." + | otherwise = hsep ( + punctuate comma (map text mods)) <> text "." + case ok of + False -> + io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))) + True -> + io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas))) + + typeOfExpr :: String -> GHCi () typeOfExpr str = do st <- getGHCiState dflags <- io (getDynFlags) - (new_cmstate, maybe_ty) <- io (cmGetExpr (cmstate st) dflags False - (current_module st) str) + (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str) setGHCiState st{cmstate = new_cmstate} - case maybe_ty of - Nothing -> return () - Just (_, unqual, ty) -> io (printForUser stdout unqual (ppr ty)) + case maybe_tystr of + Nothing -> return () + Just tystr -> io (putStrLn tystr) quit :: String -> GHCi Bool quit _ = return True @@ -442,54 +520,13 @@ optToStr ShowType = "t" optToStr RevertCAFs = "r" ----------------------------------------------------------------------------- --- Code to do last-expression-entered stuff. (a.k.a the $$ facility) - --- Take a string and replace $$s in it with the last expr, if any. -expandExpr :: String -> GHCi String -expandExpr str - = do mle <- getLastExpr - return (outside mle str) - where - outside mle ('$':'$':cs) - = case mle of - Just le -> " (" ++ le ++ ") " ++ outside mle cs - Nothing -> outside mle cs - - outside mle [] = [] - outside mle ('"':str) = '"' : inside2 mle str -- " - outside mle ('\'':str) = '\'' : inside1 mle str -- ' - outside mle (c:cs) = c : outside mle cs - - inside2 mle ('"':cs) = '"' : outside mle cs -- " - inside2 mle (c:cs) = c : inside2 mle cs - inside2 mle [] = [] - - inside1 mle ('\'':cs) = '\'': outside mle cs - inside1 mle (c:cs) = c : inside1 mle cs - inside1 mle [] = [] - - -rememberExpr :: String -> GHCi () -rememberExpr str - = do let cleaned = (clean . reverse . clean . reverse) str - let forget_me_not | null cleaned = Nothing - | otherwise = Just cleaned - setLastExpr forget_me_not - where - clean = dropWhile isSpace - - ------------------------------------------------------------------------------ -- GHCi monad data GHCiState = GHCiState { - modules :: [Module], - current_module :: Module, target :: Maybe FilePath, cmstate :: CmState, - options :: [GHCiOption], - last_expr :: Maybe String + options :: [GHCiOption] } data GHCiOption @@ -498,11 +535,8 @@ data GHCiOption | RevertCAFs -- revert CAFs after every evaluation deriving Eq -defaultCurrentModuleName = mkModuleName "Prelude" -GLOBAL_VAR(defaultCurrentModule, error "no defaultCurrentModule", Module) - -GLOBAL_VAR(flush_stdout, error "no flush_stdout", HValue) -GLOBAL_VAR(flush_stderr, error "no flush_stdout", HValue) +GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ()) +GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ()) newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) } @@ -528,48 +562,104 @@ unsetOption opt = do st <- getGHCiState setGHCiState (st{ options = filter (/= opt) (options st) }) -getLastExpr :: GHCi (Maybe String) -getLastExpr - = do st <- getGHCiState ; return (last_expr st) +io m = GHCi $ \s -> m >>= \a -> return (s,a) -setLastExpr :: Maybe String -> GHCi () -setLastExpr last_expr - = do st <- getGHCiState ; setGHCiState (st{last_expr = last_expr}) +----------------------------------------------------------------------------- +-- recursive exception handlers -io m = GHCi $ \s -> m >>= \a -> return (s,a) +-- 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