ghc/compiler/ghci/InteractiveUI.hs

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