ghc/compiler/ghci/InteractiveUI.hs

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