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