ghc/compiler/ghci/InteractiveUI.hs

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