[project @ 2001-04-26 11:08:32 by sewardj]
[ghc-hetmet.git] / ghc / compiler / ghci / InteractiveUI.hs
1 -----------------------------------------------------------------------------
2 -- $Id: InteractiveUI.hs,v 1.63 2001/04/26 11:08:32 sewardj Exp $
3 --
4 -- GHC Interactive User Interface
5 --
6 -- (c) The GHC Team 2000
7 --
8 -----------------------------------------------------------------------------
9
10 {-# OPTIONS -#include "Linker.h" #-}
11 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
12
13 #include "../includes/config.h"
14 #include "HsVersions.h"
15
16 import CompManager
17 import CmStaticInfo
18 import ByteCodeLink
19 import DriverFlags
20 import DriverState
21 import DriverUtil
22 import Linker
23 import Util
24 import Name             ( Name )
25 import Outputable
26 import CmdLineOpts      ( DynFlag(..), dopt_unset )
27 import Panic            ( GhcException(..) )
28 import Config
29
30 import Exception
31 import Dynamic
32 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
33 import Readline 
34 #endif
35 import IOExts
36
37 import Numeric
38 import List
39 import System
40 import CPUTime
41 import Directory
42 import IO
43 import Char
44 import Monad            ( when )
45
46 import PrelGHC          ( unsafeCoerce# )
47 import Foreign          ( nullPtr )
48 import CString          ( peekCString )
49
50 -----------------------------------------------------------------------------
51
52 ghciWelcomeMsg = "\ 
53 \   ___         ___ _\n\ 
54 \  / _ \\ /\\  /\\/ __(_)\n\ 
55 \ / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", For Haskell 98.\n\ 
56 \/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n\ 
57 \\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
58
59 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
60
61 builtin_commands :: [(String, String -> GHCi Bool)]
62 builtin_commands = [
63   ("add",       keepGoing addModule),
64   ("cd",        keepGoing changeDirectory),
65   ("def",       keepGoing defineMacro),
66   ("help",      keepGoing help),
67   ("?",         keepGoing help),
68   ("load",      keepGoing loadModule),
69   ("module",    keepGoing setContext),
70   ("reload",    keepGoing reloadModule),
71   ("set",       keepGoing setOptions),
72   ("type",      keepGoing typeOfExpr),
73   ("unset",     keepGoing unsetOptions),
74   ("undef",     keepGoing undefineMacro),
75   ("quit",      quit)
76   ]
77
78 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
79 keepGoing a str = a str >> return False
80
81 shortHelpText = "use :? for help.\n"
82
83 helpText = "\ 
84 \ Commands available from the prompt:\n\ 
85 \\  
86 \   <stmt>              evaluate/run <stmt>\n\ 
87 \   :cd <dir>           change directory to <dir>\n\ 
88 \   :def <cmd> <expr>   define a command :<cmd>\n\ 
89 \   :help, :?           display this list of commands\n\ 
90 \   :load <filename>    load a module (and it dependents)\n\ 
91 \   :module <mod>       set the context for expression evaluation to <mod>\n\ 
92 \   :reload             reload the current module set\n\ 
93 \   :set <option> ...   set options\n\ 
94 \   :undef <name>       undefine user-defined command :<name>\n\ 
95 \   :type <expr>        show the type of <expr>\n\ 
96 \   :unset <option> ... unset options\n\ 
97 \   :quit               exit GHCi\n\ 
98 \   :!<command>         run the shell command <command>\n\ 
99 \\ 
100 \ Options for `:set' and `:unset':\n\ 
101 \\ 
102 \    +r                 revert top-level expressions after each evaluation\n\ 
103 \    +s                 print timing/memory stats after each evaluation\n\ 
104 \    +t                 print type after evaluation\n\ 
105 \    -<flags>           most GHC command line flags can also be set here\n\ 
106 \                         (eg. -v2, -fglasgow-exts, etc.)\n\ 
107 \"
108  --ToDo   :add <filename>     add a module to the current set\n\ 
109
110 interactiveUI :: CmState -> Maybe FilePath -> [LibrarySpec] -> IO ()
111 interactiveUI cmstate mod cmdline_libs = do
112    hFlush stdout
113    hSetBuffering stdout NoBuffering
114
115    -- link in the available packages
116    pkgs <- getPackageInfo
117    initLinker
118    linkPackages cmdline_libs (reverse pkgs)
119
120    (cmstate, ok, mods) <-
121         case mod of
122              Nothing  -> return (cmstate, True, [])
123              Just m -> cmLoadModule cmstate m
124
125 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
126    Readline.initialize
127 #endif
128
129    dflags <- getDynFlags
130
131    (cmstate, maybe_hval) 
132         <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stderr"
133    case maybe_hval of
134         Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
135         _ -> panic "interactiveUI:stderr"
136
137    (cmstate, maybe_hval) 
138         <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stdout"
139    case maybe_hval of
140         Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
141         _ -> panic "interactiveUI:stdout"
142
143    (unGHCi runGHCi) GHCiState{ target = mod,
144                                cmstate = cmstate,
145                                options = [] }
146    return ()
147
148
149 runGHCi :: GHCi ()
150 runGHCi = do
151   -- read in ./.ghci
152   dot_ghci <- io (IO.try (openFile "./.ghci" ReadMode))
153   case dot_ghci of
154         Left e -> return ()
155         Right hdl -> fileLoop hdl False
156   
157   -- read in ~/.ghci
158   home <- io (IO.try (getEnv "HOME"))
159   case home of
160    Left e  -> return ()
161    Right dir -> do
162         cwd <- io (getCurrentDirectory)
163         when (dir /= cwd) $ do
164           dot_ghci <- io (IO.try (openFile (dir ++ "/.ghci") ReadMode))
165           case dot_ghci of
166              Left e -> return ()
167              Right hdl -> fileLoop hdl False
168
169   -- read commands from stdin
170 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
171   readlineLoop
172 #else
173   fileLoop stdin True
174 #endif
175
176   -- and finally, exit
177   io $ do putStrLn "Leaving GHCi." 
178
179
180 fileLoop :: Handle -> Bool -> GHCi ()
181 fileLoop hdl prompt = do
182    st <- getGHCiState
183    mod <- io (cmGetContext (cmstate st))
184    when prompt (io (hPutStr hdl (mod ++ "> ")))
185    l <- io (IO.try (hGetLine hdl))
186    case l of
187         Left e | isEOFError e -> return ()
188                | otherwise    -> throw e
189         Right l -> 
190           case remove_spaces l of
191             "" -> fileLoop hdl prompt
192             l  -> do quit <- runCommand l
193                      if quit then return () else fileLoop hdl prompt
194
195 stringLoop :: [String] -> GHCi ()
196 stringLoop [] = return ()
197 stringLoop (s:ss) = do
198    st <- getGHCiState
199    case remove_spaces s of
200         "" -> stringLoop ss
201         l  -> do quit <- runCommand l
202                  if quit then return () else stringLoop ss
203
204 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
205 readlineLoop :: GHCi ()
206 readlineLoop = do
207    st <- getGHCiState
208    mod <- io (cmGetContext (cmstate st))
209    l <- io (readline (mod ++ "> "))
210    case l of
211         Nothing -> return ()
212         Just l  ->
213           case remove_spaces l of
214             "" -> readlineLoop
215             l  -> do
216                   io (addHistory l)
217                   quit <- runCommand l
218                   if quit then return () else readlineLoop
219 #endif
220
221 -- Top level exception handler, just prints out the exception 
222 -- and carries on.
223 runCommand :: String -> GHCi Bool
224 runCommand c = 
225   ghciHandle ( \exception -> 
226         (case exception of
227            DynException dyn -> 
228               case fromDynamic dyn of
229                 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
230                 Just ghc_ex -> 
231                   case ghc_ex of
232                     PhaseFailed phase code ->
233                         io ( putStrLn ("Phase " ++ phase ++ " failed (code "
234                                         ++ show code ++ ")"))
235                     Interrupted -> io (putStrLn "Interrupted.")
236                         -- omit the location for CmdLineError
237                     CmdLineError s -> io (putStrLn s)
238                     other -> io (putStrLn (show (ghc_ex :: GhcException)))
239
240            other -> io (putStrLn ("*** Exception: " ++ show exception))
241
242         ) >> return False
243      ) $
244
245    doCommand c
246
247 doCommand (':' : command) = specialCommand command
248 doCommand stmt
249    = do timeIt (do stuff <- runStmt stmt; finishEvalExpr stuff)
250         return False
251
252 -- Returns True if the expr was successfully parsed, renamed and
253 -- typechecked.
254 runStmt :: String -> GHCi (Maybe [Name])
255 runStmt stmt
256  | null (filter (not.isSpace) stmt)
257  = return Nothing
258  | otherwise
259  = do st <- getGHCiState
260       dflags <- io (getDynFlags)
261       let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
262       (new_cmstate, names) <- io (cmRunStmt (cmstate st) dflags' stmt)
263       setGHCiState st{cmstate = new_cmstate}
264       return (Just names)
265
266 -- possibly print the type and revert CAFs after evaluating an expression
267 finishEvalExpr Nothing = return False
268 finishEvalExpr (Just names)
269  = do b <- isOptionSet ShowType
270       st <- getGHCiState
271       when b (mapM_ (showTypeOfName (cmstate st)) names)
272
273       b <- isOptionSet RevertCAFs
274       io (when b revertCAFs)
275       flushEverything
276       return True
277
278 showTypeOfName :: CmState -> Name -> GHCi ()
279 showTypeOfName cmstate n
280    = do maybe_str <- io (cmTypeOfName cmstate n)
281         case maybe_str of
282           Nothing  -> return ()
283           Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
284
285 flushEverything :: GHCi ()
286 flushEverything
287    = io $ do flush_so <- readIORef flush_stdout
288              flush_so
289              flush_se <- readIORef flush_stdout
290              flush_se
291              return ()
292
293 specialCommand :: String -> GHCi Bool
294 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
295 specialCommand str = do
296   let (cmd,rest) = break isSpace str
297   cmds <- io (readIORef commands)
298   case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
299      []      -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n" 
300                                     ++ shortHelpText) >> return False)
301      [(_,f)] -> f (dropWhile isSpace rest)
302      cs      -> io (hPutStrLn stdout ("prefix " ++ cmd ++ 
303                                       " matches multiple commands (" ++ 
304                                        foldr1 (\a b -> a ++ ',':b) (map fst cs)
305                                          ++ ")") >> return False)
306
307 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
308
309 -----------------------------------------------------------------------------
310 -- Commands
311
312 help :: String -> GHCi ()
313 help _ = io (putStr helpText)
314
315 addModule :: String -> GHCi ()
316 addModule _ = throwDyn (InstallationError ":add not implemented")
317
318 setContext :: String -> GHCi ()
319 setContext ""
320   = throwDyn (CmdLineError "syntax: `:m <module>'")
321 setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m))
322   = throwDyn (CmdLineError ("strange looking module name: `" ++ m ++ "'"))
323 setContext str
324   = do st <- getGHCiState
325        new_cmstate <- io (cmSetContext (cmstate st) str)
326        setGHCiState st{cmstate=new_cmstate}
327
328 changeDirectory :: String -> GHCi ()
329 changeDirectory ('~':d) = do
330    tilde <- io (getEnv "HOME")  -- will fail if HOME not defined
331    io (setCurrentDirectory (tilde ++ '/':d))
332 changeDirectory d = io (setCurrentDirectory d)
333
334 defineMacro :: String -> GHCi ()
335 defineMacro s = do
336   let (macro_name, definition) = break isSpace s
337   cmds <- io (readIORef commands)
338   if (null macro_name) 
339         then throwDyn (CmdLineError "invalid macro name") 
340         else do
341   if (macro_name `elem` map fst cmds) 
342         then throwDyn (CmdLineError 
343                 ("command `" ++ macro_name ++ "' is already defined"))
344         else do
345
346   -- give the expression a type signature, so we can be sure we're getting
347   -- something of the right type.
348   let new_expr = '(' : definition ++ ") :: String -> IO String"
349
350   -- compile the expression
351   st <- getGHCiState
352   dflags <- io (getDynFlags)
353   (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
354   setGHCiState st{cmstate = new_cmstate}
355   case maybe_hv of
356      Nothing -> return ()
357      Just hv -> io (writeIORef commands --
358                     ((macro_name, keepGoing (runMacro hv)) : cmds))
359
360 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
361 runMacro fun s = do
362   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
363   stringLoop (lines str)
364
365 undefineMacro :: String -> GHCi ()
366 undefineMacro macro_name = do
367   cmds <- io (readIORef commands)
368   if (macro_name `elem` map fst builtin_commands) 
369         then throwDyn (CmdLineError
370                 ("command `" ++ macro_name ++ "' cannot be undefined"))
371         else do
372   if (macro_name `notElem` map fst cmds) 
373         then throwDyn (CmdLineError 
374                 ("command `" ++ macro_name ++ "' not defined"))
375         else do
376   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
377
378 loadModule :: String -> GHCi ()
379 loadModule path = timeIt (loadModule' path)
380
381 loadModule' path = do
382   state <- getGHCiState
383   cmstate1 <- io (cmUnload (cmstate state))
384   io (revertCAFs)                       -- always revert CAFs on load.
385   (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
386   let new_state = state{ cmstate = cmstate2,
387                          target = Just path
388                        }
389   setGHCiState new_state
390   modulesLoadedMsg ok mods
391
392 reloadModule :: String -> GHCi ()
393 reloadModule "" = do
394   state <- getGHCiState
395   case target state of
396    Nothing -> io (putStr "no current target\n")
397    Just path
398       -> do io (revertCAFs)             -- always revert CAFs on reload.
399             (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
400             setGHCiState state{ cmstate=new_cmstate }
401             modulesLoadedMsg ok mods
402
403 reloadModule _ = noArgs ":reload"
404
405
406 modulesLoadedMsg ok mods = do
407   let mod_commas 
408         | null mods = text "none."
409         | otherwise = hsep (
410             punctuate comma (map text mods)) <> text "."
411   case ok of
412     False -> 
413        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
414     True  -> 
415        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
416
417
418 typeOfExpr :: String -> GHCi ()
419 typeOfExpr str 
420   = do st <- getGHCiState
421        dflags <- io (getDynFlags)
422        (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
423        setGHCiState st{cmstate = new_cmstate}
424        case maybe_tystr of
425           Nothing    -> return ()
426           Just tystr -> io (putStrLn tystr)
427
428 quit :: String -> GHCi Bool
429 quit _ = return True
430
431 shellEscape :: String -> GHCi Bool
432 shellEscape str = io (system str >> return False)
433
434 ----------------------------------------------------------------------------
435 -- Code for `:set'
436
437 -- set options in the interpreter.  Syntax is exactly the same as the
438 -- ghc command line, except that certain options aren't available (-C,
439 -- -E etc.)
440 --
441 -- This is pretty fragile: most options won't work as expected.  ToDo:
442 -- figure out which ones & disallow them.
443
444 setOptions :: String -> GHCi ()
445 setOptions ""
446   = do st <- getGHCiState
447        let opts = options st
448        io $ putStrLn (showSDoc (
449               text "options currently set: " <> 
450               if null opts
451                    then text "none."
452                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
453            ))
454 setOptions str
455   = do -- first, deal with the GHCi opts (+s, +t, etc.)
456        let opts = words str
457            (minus_opts, rest1) = partition isMinus opts
458            (plus_opts, rest2)  = partition isPlus rest1
459
460        if (not (null rest2)) 
461           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
462           else do
463
464        mapM setOpt plus_opts
465
466        -- now, the GHC flags
467        io (do -- first, static flags
468               leftovers <- processArgs static_flags minus_opts []
469
470               -- then, dynamic flags
471               dyn_flags <- readIORef v_InitDynFlags
472               writeIORef v_DynFlags dyn_flags
473               leftovers <- processArgs dynamic_flags leftovers []
474               dyn_flags <- readIORef v_DynFlags
475               writeIORef v_InitDynFlags dyn_flags
476
477               if (not (null leftovers))
478                  then throwDyn (CmdLineError ("unrecognised flags: " ++ 
479                                                 unwords leftovers))
480                  else return ()
481          )
482
483 unsetOptions :: String -> GHCi ()
484 unsetOptions str
485   = do -- first, deal with the GHCi opts (+s, +t, etc.)
486        let opts = words str
487            (minus_opts, rest1) = partition isMinus opts
488            (plus_opts, rest2)  = partition isPlus rest1
489
490        if (not (null rest2)) 
491           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
492           else do
493
494        mapM unsetOpt plus_opts
495  
496        -- can't do GHC flags for now
497        if (not (null minus_opts))
498           then throwDyn (CmdLineError "can't unset GHC command-line flags")
499           else return ()
500
501 isMinus ('-':s) = True
502 isMinus _ = False
503
504 isPlus ('+':s) = True
505 isPlus _ = False
506
507 setOpt ('+':str)
508   = case strToGHCiOpt str of
509         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
510         Just o  -> setOption o
511
512 unsetOpt ('+':str)
513   = case strToGHCiOpt str of
514         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
515         Just o  -> unsetOption o
516
517 strToGHCiOpt :: String -> (Maybe GHCiOption)
518 strToGHCiOpt "s" = Just ShowTiming
519 strToGHCiOpt "t" = Just ShowType
520 strToGHCiOpt "r" = Just RevertCAFs
521 strToGHCiOpt _   = Nothing
522
523 optToStr :: GHCiOption -> String
524 optToStr ShowTiming = "s"
525 optToStr ShowType   = "t"
526 optToStr RevertCAFs = "r"
527
528 -----------------------------------------------------------------------------
529 -- GHCi monad
530
531 data GHCiState = GHCiState
532      { 
533         target         :: Maybe FilePath,
534         cmstate        :: CmState,
535         options        :: [GHCiOption]
536      }
537
538 data GHCiOption 
539         = ShowTiming            -- show time/allocs after evaluation
540         | ShowType              -- show the type of expressions
541         | RevertCAFs            -- revert CAFs after every evaluation
542         deriving Eq
543
544 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
545 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
546
547 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
548
549 instance Monad GHCi where
550   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
551   return a  = GHCi $ \s -> return (s,a)
552
553 getGHCiState   = GHCi $ \s -> return (s,s)
554 setGHCiState s = GHCi $ \_ -> return (s,())
555
556 isOptionSet :: GHCiOption -> GHCi Bool
557 isOptionSet opt
558  = do st <- getGHCiState
559       return (opt `elem` options st)
560
561 setOption :: GHCiOption -> GHCi ()
562 setOption opt
563  = do st <- getGHCiState
564       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
565
566 unsetOption :: GHCiOption -> GHCi ()
567 unsetOption opt
568  = do st <- getGHCiState
569       setGHCiState (st{ options = filter (/= opt) (options st) })
570
571 io m = GHCi $ \s -> m >>= \a -> return (s,a)
572
573 -----------------------------------------------------------------------------
574 -- recursive exception handlers
575
576 -- Don't forget to unblock async exceptions in the handler, or if we're
577 -- in an exception loop (eg. let a = error a in a) the ^C exception
578 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
579
580 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
581 ghciHandle h (GHCi m) = GHCi $ \s -> 
582    Exception.catch (m s) 
583         (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
584
585 ghciUnblock :: GHCi a -> GHCi a
586 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
587
588 -----------------------------------------------------------------------------
589 -- package loader
590
591 -- Left: full path name of a .o file, including trailing .o
592 -- Right: "unadorned" name of a .DLL/.so
593 --        e.g.    On unix     "qt"  denotes "libqt.so"
594 --                On WinDoze  "burble"  denotes "burble.DLL"
595 --        addDLL is platform-specific and adds the lib/.so/.DLL
596 --        prefixes plaform-dependently; we don't do that here.
597 type LibrarySpec
598    = Either FilePath String
599
600 showLS (Left nm)  = "(static) " ++ nm
601 showLS (Right nm) = "(dynamic) " ++ nm
602
603 linkPackages :: [LibrarySpec] -> [PackageConfig] -> IO ()
604 linkPackages cmdline_lib_specs pkgs
605    = do mapM_ linkPackage pkgs
606         mapM_ preloadLib cmdline_lib_specs
607      where
608         preloadLib lib_spec
609            = do putStr ("Loading object " ++ showLS lib_spec ++ " ... ")
610                 case lib_spec of
611                    Left static_ish
612                       -> do b <- doesFileExist static_ish
613                             if    not b
614                              then do putStr "not found.\n"
615                                      croak
616                              else do loadObj static_ish
617                                      putStr "done.\n"
618                    Right dll_unadorned
619                       -> do maybe_errmsg <- addDLL dll_unadorned
620                             if    maybe_errmsg == nullPtr
621                              then putStr "done.\n"
622                              else do str <- peekCString maybe_errmsg
623                                      putStr ("failed (" ++ str ++ ")\n")
624                                      croak
625
626         croak = throwDyn (CmdLineError "user specified .o/.so/.DLL could not be loaded.")
627
628
629 linkPackage :: PackageConfig -> IO ()
630 -- ignore rts and gmp for now (ToDo; better?)
631 linkPackage pkg 
632    | name pkg `elem` ["rts", "gmp"] 
633    = return ()
634    | otherwise
635    = do putStr ("Loading package " ++ name pkg ++ " ... ")
636         -- For each obj, try obj.o and if that fails, obj.so.
637         -- Complication: all the .so's must be loaded before any of the .o's.  
638         let dirs      =  library_dirs pkg
639         let objs      =  hs_libraries pkg ++ extra_libraries pkg
640         classifieds   <- mapM (locateOneObj dirs) objs
641         let sos_first = filter isRight classifieds 
642                         ++ filter (not.isRight) classifieds
643         mapM loadClassified sos_first
644         putStr "linking ... "
645         resolveObjs
646         putStrLn "done."
647      where
648         isRight (Right _) = True
649         isRight (Left _)  = False
650
651 loadClassified :: LibrarySpec -> IO ()
652 loadClassified (Left obj_absolute_filename)
653    = do loadObj obj_absolute_filename
654 loadClassified (Right dll_unadorned)
655    = do maybe_errmsg <- addDLL dll_unadorned
656         if    maybe_errmsg == nullPtr
657          then return ()
658          else do str <- peekCString maybe_errmsg
659                  throwDyn (CmdLineError ("can't find .o or .so/.DLL for: " 
660                                        ++ dll_unadorned ++ " (" ++ str ++ ")" ))
661
662 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
663 locateOneObj []     obj 
664    = return (Right obj) -- we assume
665 locateOneObj (d:ds) obj 
666    = do let path = d ++ '/':obj ++ ".o"
667         b <- doesFileExist path
668         if b then return (Left path) else locateOneObj ds obj
669
670 -----------------------------------------------------------------------------
671 -- timing & statistics
672
673 timeIt :: GHCi a -> GHCi a
674 timeIt action
675   = do b <- isOptionSet ShowTiming
676        if not b 
677           then action 
678           else do allocs1 <- io $ getAllocations
679                   time1   <- io $ getCPUTime
680                   a <- action
681                   allocs2 <- io $ getAllocations
682                   time2   <- io $ getCPUTime
683                   io $ printTimes (allocs2 - allocs1) (time2 - time1)
684                   return a
685
686 foreign import "getAllocations" getAllocations :: IO Int
687
688 printTimes :: Int -> Integer -> IO ()
689 printTimes allocs psecs
690    = do let secs = (fromIntegral psecs / (10^12)) :: Float
691             secs_str = showFFloat (Just 2) secs
692         putStrLn (showSDoc (
693                  parens (text (secs_str "") <+> text "secs" <> comma <+> 
694                          int allocs <+> text "bytes")))
695
696 -----------------------------------------------------------------------------
697 -- reverting CAFs
698         
699 foreign import revertCAFs :: IO ()      -- make it "safe", just in case