ghc/compiler/ghci/InteractiveUI.hs

   1 {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: InteractiveUI.hs,v 1.122 2002/05/01 15:46:15 simonmar Exp $
   4 --
   5 -- GHC Interactive User Interface
   6 --
   7 -- (c) The GHC Team 2000
   8 --
   9 -----------------------------------------------------------------------------
  10 module InteractiveUI (
  11         interactiveUI,  -- :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
  12         LibrarySpec(..),
  13         ghciWelcomeMsg
  14    ) where
  15
  16 #include "../includes/config.h"
  17 #include "HsVersions.h"
  18
  19 import Packages
  20
  21 import CompManager
  22 import CmTypes          ( Linkable, isObjectLinkable, ModSummary(..) )
  23 import CmLink           ( findModuleLinkable_maybe )
  24
  25 import HscTypes         ( TyThing(..), showModMsg, InteractiveContext(..) )
  26 import HsSyn            ( TyClDecl(..), ConDecl(..), Sig(..) )
  27 import MkIface          ( ifaceTyThing )
  28 import DriverFlags
  29 import DriverState
  30 import DriverUtil       ( handle, remove_spaces )
  31 import Linker
  32 import Finder           ( flushPackageCache )
  33 import Util
  34 import Id               ( isRecordSelector, recordSelectorFieldLabel,
  35                           isDataConWrapId, isDataConId, idName )
  36 import Class            ( className )
  37 import TyCon            ( tyConName, tyConClass_maybe, isPrimTyCon, DataConDetails(..) )
  38 import FieldLabel       ( fieldLabelTyCon )
  39 import SrcLoc           ( isGoodSrcLoc )
  40 import Module           ( moduleName )
  41 import NameEnv          ( nameEnvElts )
  42 import Name             ( Name, isHomePackageName, nameSrcLoc, nameOccName,
  43                           NamedThing(..) )
  44 import OccName          ( isSymOcc )
  45 import BasicTypes       ( defaultFixity )
  46 import Outputable
  47 import CmdLineOpts      ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags,
  48                           restoreDynFlags, dopt_unset )
  49 import Panic            ( GhcException(..), showGhcException )
  50 import Config
  51
  52 #ifndef mingw32_TARGET_OS
  53 import Posix
  54 #endif
  55
  56 import Exception
  57 import Dynamic
  58 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
  59 import Readline
  60 #endif
  61 import Concurrent
  62 import IOExts
  63 import SystemExts
  64
  65 import Numeric
  66 import List
  67 import System
  68 import CPUTime
  69 import Directory
  70 import IO
  71 import Char
  72 import Monad
  73
  74 import GlaExts          ( unsafeCoerce# )
  75
  76 import Foreign          ( nullPtr )
  77 import CString          ( CString, peekCString, withCString )
  78
  79 -----------------------------------------------------------------------------
  80
  81 ghciWelcomeMsg = "\
  82 \   ___         ___ _\n\
  83 \  / _ \\ /\\  /\\/ __(_)\n\
  84 \ / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
  85 \/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n\
  86 \\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
  87
  88 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
  89
  90 builtin_commands :: [(String, String -> GHCi Bool)]
  91 builtin_commands = [
  92   ("add",       keepGoing addModule),
  93   ("browse",    keepGoing browseCmd),
  94   ("cd",        keepGoing changeDirectory),
  95   ("def",       keepGoing defineMacro),
  96   ("help",      keepGoing help),
  97   ("?",         keepGoing help),
  98   ("info",      keepGoing info),
  99   ("load",      keepGoing loadModule),
 100   ("module",    keepGoing setContext),
 101   ("reload",    keepGoing reloadModule),
 102   ("set",       keepGoing setCmd),
 103   ("show",      keepGoing showCmd),
 104   ("type",      keepGoing typeOfExpr),
 105   ("unset",     keepGoing unsetOptions),
 106   ("undef",     keepGoing undefineMacro),
 107   ("quit",      quit)
 108   ]
 109
 110 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 111 keepGoing a str = a str >> return False
 112
 113 shortHelpText = "use :? for help.\n"
 114
 115 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
 116 helpText = "\
 117 \ Commands available from the prompt:\n\
 118 \\n\
 119 \   <stmt>                     evaluate/run <stmt>\n\
 120 \   :add <filename> ...        add module(s) to the current target set\n\
 121 \   :browse [*]<module>        display the names defined by <module>\n\
 122 \   :cd <dir>                  change directory to <dir>\n\
 123 \   :def <cmd> <expr>          define a command :<cmd>\n\
 124 \   :help, :?                  display this list of commands\n\
 125 \   :info [<name> ...]         display information about the given names\n\
 126 \   :load <filename> ...       load module(s) and their dependents\n\
 127 \   :module [+/-] [*]<mod> ... set the context for expression evaluation\n\
 128 \   :reload                    reload the current module set\n\
 129 \\n\
 130 \   :set <option> ...          set options\n\
 131 \   :set args <arg> ...        set the arguments returned by System.getArgs\n\
 132 \   :set prog <progname>       set the value returned by System.getProgName\n\
 133 \\n\
 134 \   :show modules              show the currently loaded modules\n\
 135 \   :show bindings             show the current bindings made at the prompt\n\
 136 \\n\
 137 \   :type <expr>               show the type of <expr>\n\
 138 \   :undef <cmd>               undefine user-defined command :<cmd>\n\
 139 \   :unset <option> ...        unset options\n\
 140 \   :quit                      exit GHCi\n\
 141 \   :!<command>                run the shell command <command>\n\
 142 \\n\
 143 \ Options for `:set' and `:unset':\n\
 144 \\n\
 145 \    +r                 revert top-level expressions after each evaluation\n\
 146 \    +s                 print timing/memory stats after each evaluation\n\
 147 \    +t                 print type after evaluation\n\
 148 \    -<flags>           most GHC command line flags can also be set here\n\
 149 \                         (eg. -v2, -fglasgow-exts, etc.)\n\
 150 \"
 151
 152 interactiveUI :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
 153 interactiveUI cmstate paths cmdline_libs = do
 154    hFlush stdout
 155    hSetBuffering stdout NoBuffering
 156
 157    dflags <- getDynFlags
 158
 159    -- link in the available packages
 160    pkgs <- getPackageInfo
 161    initLinker
 162    linkPackages dflags cmdline_libs pkgs
 163
 164    (cmstate, maybe_hval)
 165         <- cmCompileExpr cmstate dflags "IO.hSetBuffering IO.stdout IO.NoBuffering Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
 166    case maybe_hval of
 167         Just hval -> unsafeCoerce# hval :: IO ()
 168         _ -> panic "interactiveUI:buffering"
 169
 170    (cmstate, maybe_hval)
 171         <- cmCompileExpr cmstate dflags "IO.hFlush IO.stderr"
 172    case maybe_hval of
 173         Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
 174         _ -> panic "interactiveUI:stderr"
 175
 176    (cmstate, maybe_hval)
 177         <- cmCompileExpr cmstate dflags "IO.hFlush IO.stdout"
 178    case maybe_hval of
 179         Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
 180         _ -> panic "interactiveUI:stdout"
 181
 182         -- We don't want the cmd line to buffer any input that might be
 183         -- intended for the program, so unbuffer stdin.
 184    hSetBuffering stdin  NoBuffering
 185
 186         -- initial context is just the Prelude
 187    cmstate <- cmSetContext cmstate dflags [] ["Prelude"]
 188
 189 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 190    Readline.initialize
 191 #endif
 192
 193    startGHCi (runGHCi paths dflags)
 194         GHCiState{ progname = "<interactive>",
 195                    args = [],
 196                    targets = paths,
 197                    cmstate = cmstate,
 198                    options = [] }
 199
 200 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 201    Readline.resetTerminal Nothing
 202 #endif
 203
 204    return ()
 205
 206
 207 runGHCi :: [FilePath] -> DynFlags -> GHCi ()
 208 runGHCi paths dflags = do
 209   read_dot_files <- io (readIORef v_Read_DotGHCi)
 210
 211   when (read_dot_files) $ do
 212     -- Read in ./.ghci.
 213     let file = "./.ghci"
 214     exists <- io (doesFileExist file)
 215     when exists $ do
 216        dir_ok  <- io (checkPerms ".")
 217        file_ok <- io (checkPerms file)
 218        when (dir_ok && file_ok) $ do
 219           either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
 220           case either_hdl of
 221              Left e    -> return ()
 222              Right hdl -> fileLoop hdl False
 223
 224   when (read_dot_files) $ do
 225     -- Read in $HOME/.ghci
 226     either_dir <- io (IO.try (getEnv "HOME"))
 227     case either_dir of
 228        Left e -> return ()
 229        Right dir -> do
 230           cwd <- io (getCurrentDirectory)
 231           when (dir /= cwd) $ do
 232              let file = dir ++ "/.ghci"
 233              ok <- io (checkPerms file)
 234              when ok $ do
 235                either_hdl <- io (IO.try (openFile file ReadMode))
 236                case either_hdl of
 237                   Left e    -> return ()
 238                   Right hdl -> fileLoop hdl False
 239
 240   -- perform a :load for files given on the GHCi command line
 241   when (not (null paths)) $
 242      ghciHandle showException $
 243         loadModule (unwords paths)
 244
 245   -- enter the interactive loop
 246   is_tty <- io (hIsTerminalDevice stdin)
 247   interactiveLoop is_tty
 248
 249   -- and finally, exit
 250   io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
 251
 252
 253 interactiveLoop is_tty = do
 254   -- ignore ^C exceptions caught here
 255   ghciHandleDyn (\e -> case e of
 256                         Interrupted -> ghciUnblock (interactiveLoop is_tty)
 257                         _other      -> return ()) $ do
 258
 259   -- read commands from stdin
 260 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 261   if (is_tty)
 262         then readlineLoop
 263         else fileLoop stdin False  -- turn off prompt for non-TTY input
 264 #else
 265   fileLoop stdin True
 266 #endif
 267
 268
 269 -- NOTE: We only read .ghci files if they are owned by the current user,
 270 -- and aren't world writable.  Otherwise, we could be accidentally
 271 -- running code planted by a malicious third party.
 272
 273 -- Furthermore, We only read ./.ghci if . is owned by the current user
 274 -- and isn't writable by anyone else.  I think this is sufficient: we
 275 -- don't need to check .. and ../.. etc. because "."  always refers to
 276 -- the same directory while a process is running.
 277
 278 checkPerms :: String -> IO Bool
 279 checkPerms name =
 280 #ifdef mingw32_TARGET_OS
 281   return True
 282 #else
 283   DriverUtil.handle (\_ -> return False) $ do
 284      st <- getFileStatus name
 285      me <- getRealUserID
 286      if fileOwner st /= me then do
 287         putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
 288         return False
 289       else do
 290         let mode =  fileMode st
 291         if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
 292            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
 293            then do
 294                putStrLn $ "*** WARNING: " ++ name ++
 295                           " is writable by someone else, IGNORING!"
 296                return False
 297           else return True
 298 #endif
 299
 300 fileLoop :: Handle -> Bool -> GHCi ()
 301 fileLoop hdl prompt = do
 302    cmstate <- getCmState
 303    (mod,imports) <- io (cmGetContext cmstate)
 304    when prompt (io (putStr (mkPrompt mod imports)))
 305    l <- io (IO.try (hGetLine hdl))
 306    case l of
 307         Left e | isEOFError e -> return ()
 308                | otherwise    -> throw e
 309         Right l ->
 310           case remove_spaces l of
 311             "" -> fileLoop hdl prompt
 312             l  -> do quit <- runCommand l
 313                      if quit then return () else fileLoop hdl prompt
 314
 315 stringLoop :: [String] -> GHCi ()
 316 stringLoop [] = return ()
 317 stringLoop (s:ss) = do
 318    case remove_spaces s of
 319         "" -> stringLoop ss
 320         l  -> do quit <- runCommand l
 321                  if quit then return () else stringLoop ss
 322
 323 mkPrompt toplevs exports
 324    = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
 325
 326 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 327 readlineLoop :: GHCi ()
 328 readlineLoop = do
 329    cmstate <- getCmState
 330    (mod,imports) <- io (cmGetContext cmstate)
 331    io yield
 332    l <- io (readline (mkPrompt mod imports))
 333    case l of
 334         Nothing -> return ()
 335         Just l  ->
 336           case remove_spaces l of
 337             "" -> readlineLoop
 338             l  -> do
 339                   io (addHistory l)
 340                   quit <- runCommand l
 341                   if quit then return () else readlineLoop
 342 #endif
 343
 344 -- Top level exception handler, just prints out the exception
 345 -- and carries on.
 346 runCommand :: String -> GHCi Bool
 347 runCommand c =
 348   ghciHandle ( \exception -> do
 349                 flushEverything
 350                 showException exception
 351                 return False
 352              ) $
 353   doCommand c
 354
 355 showException (DynException dyn) =
 356   case fromDynamic dyn of
 357     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
 358     Just Interrupted      -> io (putStrLn "Interrupted.")
 359     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
 360     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
 361     Just other_ghc_ex     -> io (print other_ghc_ex)
 362
 363 showException other_exception
 364   = io (putStrLn ("*** Exception: " ++ show other_exception))
 365
 366 doCommand (':' : command) = specialCommand command
 367 doCommand stmt
 368    = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
 369         return False
 370
 371 runStmt :: String -> GHCi [Name]
 372 runStmt stmt
 373  | null (filter (not.isSpace) stmt) = return []
 374  | otherwise
 375  = do st <- getGHCiState
 376       dflags <- io getDynFlags
 377       let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
 378       (new_cmstate, result) <-
 379         io $ withProgName (progname st) $ withArgs (args st) $
 380         cmRunStmt (cmstate st) dflags' stmt
 381       setGHCiState st{cmstate = new_cmstate}
 382       case result of
 383         CmRunFailed      -> return []
 384         CmRunException e -> showException e >> return []
 385         CmRunOk names    -> return names
 386
 387 -- possibly print the type and revert CAFs after evaluating an expression
 388 finishEvalExpr names
 389  = do b <- isOptionSet ShowType
 390       cmstate <- getCmState
 391       when b (mapM_ (showTypeOfName cmstate) names)
 392
 393       b <- isOptionSet RevertCAFs
 394       io (when b revertCAFs)
 395       flushEverything
 396       return True
 397
 398 showTypeOfName :: CmState -> Name -> GHCi ()
 399 showTypeOfName cmstate n
 400    = do maybe_str <- io (cmTypeOfName cmstate n)
 401         case maybe_str of
 402           Nothing  -> return ()
 403           Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
 404
 405 flushEverything :: GHCi ()
 406 flushEverything
 407    = io $ do Monad.join (readIORef flush_stdout)
 408              Monad.join (readIORef flush_stderr)
 409              return ()
 410
 411 specialCommand :: String -> GHCi Bool
 412 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 413 specialCommand str = do
 414   let (cmd,rest) = break isSpace str
 415   cmds <- io (readIORef commands)
 416   case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
 417      []      -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
 418                                     ++ shortHelpText) >> return False)
 419      [(_,f)] -> f (dropWhile isSpace rest)
 420      cs      -> io (hPutStrLn stdout ("prefix " ++ cmd ++
 421                                       " matches multiple commands (" ++
 422                                        foldr1 (\a b -> a ++ ',':b) (map fst cs)
 423                                          ++ ")") >> return False)
 424
 425 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
 426
 427 -----------------------------------------------------------------------------
 428 -- Commands
 429
 430 help :: String -> GHCi ()
 431 help _ = io (putStr helpText)
 432
 433 info :: String -> GHCi ()
 434 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
 435 info s = do
 436   let names = words s
 437   init_cms <- getCmState
 438   dflags <- io getDynFlags
 439   let
 440     infoThings cms [] = return cms
 441     infoThings cms (name:names) = do
 442       (cms, stuff) <- io (cmInfoThing cms dflags name)
 443       io (putStrLn (showSDocForUser unqual (
 444             vcat (intersperse (text "") (map showThing stuff))))
 445          )
 446       infoThings cms names
 447
 448     unqual = cmGetPrintUnqual init_cms
 449
 450     showThing (ty_thing, fixity)
 451         = vcat [ text "-- " <> showTyThing ty_thing,
 452                  showFixity fixity (getName ty_thing),
 453                  ppr (ifaceTyThing ty_thing) ]
 454
 455     showFixity fix name
 456         | fix == defaultFixity = empty
 457         | otherwise            = ppr fix <+>
 458                                  (if isSymOcc (nameOccName name)
 459                                         then ppr name
 460                                         else char '`' <> ppr name <> char '`')
 461
 462     showTyThing (AClass cl)
 463        = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
 464     showTyThing (ATyCon ty)
 465        | isPrimTyCon ty
 466        = hcat [ppr ty, text " is a primitive type constructor"]
 467        | otherwise
 468        = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
 469     showTyThing (AnId   id)
 470        = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
 471
 472     idDescr id
 473        | isRecordSelector id =
 474                 case tyConClass_maybe (fieldLabelTyCon (
 475                                 recordSelectorFieldLabel id)) of
 476                         Nothing -> text "record selector"
 477                         Just c  -> text "method in class " <> ppr c
 478        | isDataConWrapId id  = text "data constructor"
 479        | otherwise           = text "variable"
 480
 481         -- also print out the source location for home things
 482     showSrcLoc name
 483         | isHomePackageName name && isGoodSrcLoc loc
 484         = hsep [ text ", defined at", ppr loc ]
 485         | otherwise
 486         = empty
 487         where loc = nameSrcLoc name
 488
 489   cms <- infoThings init_cms names
 490   setCmState cms
 491   return ()
 492
 493 addModule :: String -> GHCi ()
 494 addModule str = do
 495   let files = words str
 496   state <- getGHCiState
 497   dflags <- io (getDynFlags)
 498   io (revertCAFs)                       -- always revert CAFs on load/add.
 499   let new_targets = files ++ targets state
 500   graph <- io (cmDepAnal (cmstate state) dflags new_targets)
 501   (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
 502   setGHCiState state{ cmstate = cmstate1, targets = new_targets }
 503   setContextAfterLoad mods
 504   modulesLoadedMsg ok mods dflags
 505
 506 changeDirectory :: String -> GHCi ()
 507 changeDirectory ('~':d) = do
 508    tilde <- io (getEnv "HOME")  -- will fail if HOME not defined
 509    io (setCurrentDirectory (tilde ++ '/':d))
 510 changeDirectory d = io (setCurrentDirectory d)
 511
 512 defineMacro :: String -> GHCi ()
 513 defineMacro s = do
 514   let (macro_name, definition) = break isSpace s
 515   cmds <- io (readIORef commands)
 516   if (null macro_name)
 517         then throwDyn (CmdLineError "invalid macro name")
 518         else do
 519   if (macro_name `elem` map fst cmds)
 520         then throwDyn (CmdLineError
 521                 ("command `" ++ macro_name ++ "' is already defined"))
 522         else do
 523
 524   -- give the expression a type signature, so we can be sure we're getting
 525   -- something of the right type.
 526   let new_expr = '(' : definition ++ ") :: String -> IO String"
 527
 528   -- compile the expression
 529   cms <- getCmState
 530   dflags <- io getDynFlags
 531   (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr)
 532   setCmState new_cmstate
 533   case maybe_hv of
 534      Nothing -> return ()
 535      Just hv -> io (writeIORef commands --
 536                     ((macro_name, keepGoing (runMacro hv)) : cmds))
 537
 538 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
 539 runMacro fun s = do
 540   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 541   stringLoop (lines str)
 542
 543 undefineMacro :: String -> GHCi ()
 544 undefineMacro macro_name = do
 545   cmds <- io (readIORef commands)
 546   if (macro_name `elem` map fst builtin_commands)
 547         then throwDyn (CmdLineError
 548                 ("command `" ++ macro_name ++ "' cannot be undefined"))
 549         else do
 550   if (macro_name `notElem` map fst cmds)
 551         then throwDyn (CmdLineError
 552                 ("command `" ++ macro_name ++ "' not defined"))
 553         else do
 554   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
 555
 556
 557 loadModule :: String -> GHCi ()
 558 loadModule str = timeIt (loadModule' str)
 559
 560 loadModule' str = do
 561   let files = words str
 562   state <- getGHCiState
 563   dflags <- io getDynFlags
 564
 565   -- do the dependency anal first, so that if it fails we don't throw
 566   -- away the current set of modules.
 567   graph <- io (cmDepAnal (cmstate state) dflags files)
 568
 569   -- Dependency anal ok, now unload everything
 570   cmstate1 <- io (cmUnload (cmstate state) dflags)
 571   setGHCiState state{ cmstate = cmstate1, targets = [] }
 572
 573   io (revertCAFs)  -- always revert CAFs on load.
 574   (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph)
 575   setGHCiState state{ cmstate = cmstate2, targets = files }
 576
 577   setContextAfterLoad mods
 578   modulesLoadedMsg ok mods dflags
 579
 580
 581 reloadModule :: String -> GHCi ()
 582 reloadModule "" = do
 583   state <- getGHCiState
 584   dflags <- io getDynFlags
 585   case targets state of
 586    [] -> io (putStr "no current target\n")
 587    paths -> do
 588         -- do the dependency anal first, so that if it fails we don't throw
 589         -- away the current set of modules.
 590         graph <- io (cmDepAnal (cmstate state) dflags paths)
 591
 592         io (revertCAFs)         -- always revert CAFs on reload.
 593         (cmstate1, ok, mods)
 594                 <- io (cmLoadModules (cmstate state) dflags graph)
 595         setGHCiState state{ cmstate=cmstate1 }
 596         setContextAfterLoad mods
 597         modulesLoadedMsg ok mods dflags
 598
 599 reloadModule _ = noArgs ":reload"
 600
 601 setContextAfterLoad [] = setContext prel
 602 setContextAfterLoad (m:_) = do
 603   cmstate <- getCmState
 604   b <- io (cmModuleIsInterpreted cmstate m)
 605   if b then setContext ('*':m) else setContext m
 606
 607 modulesLoadedMsg ok mods dflags =
 608   when (verbosity dflags > 0) $ do
 609    let mod_commas
 610         | null mods = text "none."
 611         | otherwise = hsep (
 612             punctuate comma (map text mods)) <> text "."
 613    case ok of
 614     False ->
 615        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 616     True  ->
 617        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 618
 619
 620 typeOfExpr :: String -> GHCi ()
 621 typeOfExpr str
 622   = do cms <- getCmState
 623        dflags <- io getDynFlags
 624        (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str)
 625        setCmState new_cmstate
 626        case maybe_tystr of
 627           Nothing    -> return ()
 628           Just tystr -> io (putStrLn tystr)
 629
 630 quit :: String -> GHCi Bool
 631 quit _ = return True
 632
 633 shellEscape :: String -> GHCi Bool
 634 shellEscape str = io (system str >> return False)
 635
 636 -----------------------------------------------------------------------------
 637 -- Browing a module's contents
 638
 639 browseCmd :: String -> GHCi ()
 640 browseCmd m =
 641   case words m of
 642     ['*':m] | looksLikeModuleName m -> browseModule m False
 643     [m]     | looksLikeModuleName m -> browseModule m True
 644     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
 645
 646 browseModule m exports_only = do
 647   cms <- getCmState
 648   dflags <- io getDynFlags
 649
 650   is_interpreted <- io (cmModuleIsInterpreted cms m)
 651   when (not is_interpreted && not exports_only) $
 652         throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
 653
 654   -- temporarily set the context to the module we're interested in,
 655   -- just so we can get an appropriate PrintUnqualified
 656   (as,bs) <- io (cmGetContext cms)
 657   cms1 <- io (if exports_only then cmSetContext cms dflags [] [prel,m]
 658                               else cmSetContext cms dflags [m] [])
 659   cms2 <- io (cmSetContext cms1 dflags as bs)
 660
 661   (cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only)
 662
 663   setCmState cms3
 664
 665   let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
 666
 667       things' = filter wantToSee things
 668
 669       wantToSee (AnId id) = not (isDataConId id || isDataConWrapId id)
 670       wantToSee _ = True
 671
 672       thing_names = map getName things
 673
 674       thingDecl thing@(AnId id)  = ifaceTyThing thing
 675
 676       thingDecl thing@(AClass c) =
 677         let rn_decl = ifaceTyThing thing in
 678         case rn_decl of
 679           ClassDecl { tcdSigs = cons } ->
 680                 rn_decl{ tcdSigs = filter methodIsVisible cons }
 681           other -> other
 682         where
 683            methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names
 684
 685       thingDecl thing@(ATyCon t) =
 686         let rn_decl = ifaceTyThing thing in
 687         case rn_decl of
 688           TyData { tcdCons = DataCons cons } ->
 689                 rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }
 690           other -> other
 691         where
 692           conIsVisible (ConDecl n _ _ _ _ _) = n `elem` thing_names
 693
 694   io (putStrLn (showSDocForUser unqual (
 695          vcat (map (ppr . thingDecl) things')))
 696    )
 697
 698   where
 699
 700 -----------------------------------------------------------------------------
 701 -- Setting the module context
 702
 703 setContext str
 704   | all sensible mods = fn mods
 705   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
 706   where
 707     (fn, mods) = case str of
 708                         '+':stuff -> (addToContext,      words stuff)
 709                         '-':stuff -> (removeFromContext, words stuff)
 710                         stuff     -> (newContext,        words stuff)
 711
 712     sensible ('*':m) = looksLikeModuleName m
 713     sensible m       = looksLikeModuleName m
 714
 715 newContext mods = do
 716   cms <- getCmState
 717   dflags <- io getDynFlags
 718   (as,bs) <- separate cms mods [] []
 719   let bs' = if null as && prel `notElem` bs then prel:bs else bs
 720   cms' <- io (cmSetContext cms dflags as bs')
 721   setCmState cms'
 722
 723 separate cmstate []           as bs = return (as,bs)
 724 separate cmstate (('*':m):ms) as bs = do
 725    b <- io (cmModuleIsInterpreted cmstate m)
 726    if b then separate cmstate ms (m:as) bs
 727         else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
 728 separate cmstate (m:ms)       as bs = separate cmstate ms as (m:bs)
 729
 730 prel = "Prelude"
 731
 732
 733 addToContext mods = do
 734   cms <- getCmState
 735   dflags <- io getDynFlags
 736   (as,bs) <- io (cmGetContext cms)
 737
 738   (as',bs') <- separate cms mods [] []
 739
 740   let as_to_add = as' \\ (as ++ bs)
 741       bs_to_add = bs' \\ (as ++ bs)
 742
 743   cms' <- io (cmSetContext cms dflags
 744                         (as ++ as_to_add) (bs ++ bs_to_add))
 745   setCmState cms'
 746
 747
 748 removeFromContext mods = do
 749   cms <- getCmState
 750   dflags <- io getDynFlags
 751   (as,bs) <- io (cmGetContext cms)
 752
 753   (as_to_remove,bs_to_remove) <- separate cms mods [] []
 754
 755   let as' = as \\ (as_to_remove ++ bs_to_remove)
 756       bs' = bs \\ (as_to_remove ++ bs_to_remove)
 757
 758   cms' <- io (cmSetContext cms dflags as' bs')
 759   setCmState cms'
 760
 761 ----------------------------------------------------------------------------
 762 -- Code for `:set'
 763
 764 -- set options in the interpreter.  Syntax is exactly the same as the
 765 -- ghc command line, except that certain options aren't available (-C,
 766 -- -E etc.)
 767 --
 768 -- This is pretty fragile: most options won't work as expected.  ToDo:
 769 -- figure out which ones & disallow them.
 770
 771 setCmd :: String -> GHCi ()
 772 setCmd ""
 773   = do st <- getGHCiState
 774        let opts = options st
 775        io $ putStrLn (showSDoc (
 776               text "options currently set: " <>
 777               if null opts
 778                    then text "none."
 779                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 780            ))
 781 setCmd str
 782   = case words str of
 783         ("args":args) -> setArgs args
 784         ("prog":prog) -> setProg prog
 785         wds -> setOptions wds
 786
 787 setArgs args = do
 788   st <- getGHCiState
 789   setGHCiState st{ args = args }
 790
 791 setProg [prog] = do
 792   st <- getGHCiState
 793   setGHCiState st{ progname = prog }
 794 setProg _ = do
 795   io (hPutStrLn stderr "syntax: :set prog <progname>")
 796
 797 setOptions wds =
 798    do -- first, deal with the GHCi opts (+s, +t, etc.)
 799       let (plus_opts, minus_opts)  = partition isPlus wds
 800       mapM setOpt plus_opts
 801
 802       -- now, the GHC flags
 803       pkgs_before <- io (readIORef v_Packages)
 804       leftovers   <- io (processArgs static_flags minus_opts [])
 805       pkgs_after  <- io (readIORef v_Packages)
 806
 807       -- update things if the users wants more packages
 808       when (pkgs_before /= pkgs_after) $
 809          newPackages (pkgs_after \\ pkgs_before)
 810
 811       -- then, dynamic flags
 812       io $ do
 813         restoreDynFlags
 814         leftovers <- processArgs dynamic_flags leftovers []
 815         saveDynFlags
 816
 817         if (not (null leftovers))
 818                 then throwDyn (CmdLineError ("unrecognised flags: " ++
 819                                                 unwords leftovers))
 820                 else return ()
 821
 822
 823 unsetOptions :: String -> GHCi ()
 824 unsetOptions str
 825   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 826        let opts = words str
 827            (minus_opts, rest1) = partition isMinus opts
 828            (plus_opts, rest2)  = partition isPlus rest1
 829
 830        if (not (null rest2))
 831           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 832           else do
 833
 834        mapM unsetOpt plus_opts
 835
 836        -- can't do GHC flags for now
 837        if (not (null minus_opts))
 838           then throwDyn (CmdLineError "can't unset GHC command-line flags")
 839           else return ()
 840
 841 isMinus ('-':s) = True
 842 isMinus _ = False
 843
 844 isPlus ('+':s) = True
 845 isPlus _ = False
 846
 847 setOpt ('+':str)
 848   = case strToGHCiOpt str of
 849         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 850         Just o  -> setOption o
 851
 852 unsetOpt ('+':str)
 853   = case strToGHCiOpt str of
 854         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 855         Just o  -> unsetOption o
 856
 857 strToGHCiOpt :: String -> (Maybe GHCiOption)
 858 strToGHCiOpt "s" = Just ShowTiming
 859 strToGHCiOpt "t" = Just ShowType
 860 strToGHCiOpt "r" = Just RevertCAFs
 861 strToGHCiOpt _   = Nothing
 862
 863 optToStr :: GHCiOption -> String
 864 optToStr ShowTiming = "s"
 865 optToStr ShowType   = "t"
 866 optToStr RevertCAFs = "r"
 867
 868 newPackages new_pkgs = do
 869   state <- getGHCiState
 870   dflags <- io getDynFlags
 871   cmstate1 <- io (cmUnload (cmstate state) dflags)
 872   setGHCiState state{ cmstate = cmstate1, targets = [] }
 873
 874   io $ do
 875     pkgs <- getPackageInfo
 876     flushPackageCache pkgs
 877
 878     new_pkg_info <- getPackageDetails new_pkgs
 879     mapM_ (linkPackage dflags) (reverse new_pkg_info)
 880
 881 -----------------------------------------------------------------------------
 882 -- code for `:show'
 883
 884 showCmd str =
 885   case words str of
 886         ["modules" ] -> showModules
 887         ["bindings"] -> showBindings
 888         _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
 889
 890 showModules = do
 891   cms <- getCmState
 892   let mg = cmGetModuleGraph cms
 893       ls = cmGetLinkables   cms
 894       maybe_linkables = map (findModuleLinkable_maybe ls)
 895                                 (map (moduleName.ms_mod) mg)
 896   zipWithM showModule mg maybe_linkables
 897   return ()
 898
 899 showModule :: ModSummary -> Maybe Linkable -> GHCi ()
 900 showModule m (Just l) = do
 901   io (putStrLn (showModMsg (isObjectLinkable l) (ms_mod m) (ms_location m)))
 902 showModule _ Nothing = panic "missing linkable"
 903
 904 showBindings = do
 905   cms <- getCmState
 906   let
 907         unqual = cmGetPrintUnqual cms
 908         showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
 909
 910   io (mapM showBinding (cmGetBindings cms))
 911   return ()
 912
 913 -----------------------------------------------------------------------------
 914 -- GHCi monad
 915
 916 data GHCiState = GHCiState
 917      {
 918         progname       :: String,
 919         args           :: [String],
 920         targets        :: [FilePath],
 921         cmstate        :: CmState,
 922         options        :: [GHCiOption]
 923      }
 924
 925 data GHCiOption
 926         = ShowTiming            -- show time/allocs after evaluation
 927         | ShowType              -- show the type of expressions
 928         | RevertCAFs            -- revert CAFs after every evaluation
 929         deriving Eq
 930
 931 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
 932 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
 933
 934 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
 935
 936 startGHCi :: GHCi a -> GHCiState -> IO a
 937 startGHCi g state = do ref <- newIORef state; unGHCi g ref
 938
 939 instance Monad GHCi where
 940   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
 941   return a  = GHCi $ \s -> return a
 942
 943 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
 944 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
 945    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
 946
 947 getGHCiState   = GHCi $ \r -> readIORef r
 948 setGHCiState s = GHCi $ \r -> writeIORef r s
 949
 950 -- for convenience...
 951 getCmState = getGHCiState >>= return . cmstate
 952 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
 953
 954 isOptionSet :: GHCiOption -> GHCi Bool
 955 isOptionSet opt
 956  = do st <- getGHCiState
 957       return (opt `elem` options st)
 958
 959 setOption :: GHCiOption -> GHCi ()
 960 setOption opt
 961  = do st <- getGHCiState
 962       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 963
 964 unsetOption :: GHCiOption -> GHCi ()
 965 unsetOption opt
 966  = do st <- getGHCiState
 967       setGHCiState (st{ options = filter (/= opt) (options st) })
 968
 969 io :: IO a -> GHCi a
 970 io m = GHCi { unGHCi = \s -> m >>= return }
 971
 972 -----------------------------------------------------------------------------
 973 -- recursive exception handlers
 974
 975 -- Don't forget to unblock async exceptions in the handler, or if we're
 976 -- in an exception loop (eg. let a = error a in a) the ^C exception
 977 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
 978
 979 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
 980 ghciHandle h (GHCi m) = GHCi $ \s ->
 981    Exception.catch (m s)
 982         (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
 983
 984 ghciUnblock :: GHCi a -> GHCi a
 985 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
 986
 987 -----------------------------------------------------------------------------
 988 -- package loader
 989
 990 -- Left: full path name of a .o file, including trailing .o
 991 -- Right: "unadorned" name of a .DLL/.so
 992 --        e.g.    On unix     "qt"  denotes "libqt.so"
 993 --                On WinDoze  "burble"  denotes "burble.DLL"
 994 --        addDLL is platform-specific and adds the lib/.so/.DLL
 995 --        suffixes platform-dependently; we don't do that here.
 996 --
 997 -- For dynamic objects only, try to find the object file in all the
 998 -- directories specified in v_Library_Paths before giving up.
 999
1000 data LibrarySpec = Object FilePath | DLL String
1001
1002 -- Packages that don't need loading, because the compiler shares them with
1003 -- the interpreted program.
1004 dont_load_these = [ "rts" ]
1005
1006 -- Packages that are already linked into GHCi.  For mingw32, we only
1007 -- skip gmp and rts, since std and after need to load the msvcrt.dll
1008 -- library which std depends on.
1009 loaded_in_ghci
1010 #          ifndef mingw32_TARGET_OS
1011            = [ "std", "concurrent", "posix", "text", "util" ]
1012 #          else
1013            = [ ]
1014 #          endif
1015
1016 showLS (Object nm)  = "(static) " ++ nm
1017 showLS (DLL nm) = "(dynamic) " ++ nm
1018
1019 linkPackages :: DynFlags -> [LibrarySpec] -> [PackageConfig] -> IO ()
1020 linkPackages dflags cmdline_lib_specs pkgs
1021    = do mapM_ (linkPackage dflags) (reverse pkgs)
1022         lib_paths <- readIORef v_Library_paths
1023         mapM_ (preloadLib dflags lib_paths) cmdline_lib_specs
1024         if (null cmdline_lib_specs)
1025            then return ()
1026            else do maybePutStr dflags "final link ... "
1027
1028                    ok <- resolveObjs
1029                    if ok then maybePutStrLn dflags "done."
1030                          else throwDyn (InstallationError
1031                                           "linking extra libraries/objects failed")
1032      where
1033         preloadLib :: DynFlags -> [String] -> LibrarySpec -> IO ()
1034         preloadLib dflags lib_paths lib_spec
1035            = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
1036                 case lib_spec of
1037                    Object static_ish
1038                       -> do b <- preload_static lib_paths static_ish
1039                             maybePutStrLn dflags (if b  then "done."
1040                                                         else "not found")
1041                    DLL dll_unadorned
1042                       -> -- We add "" to the set of paths to try, so that
1043                          -- if none of the real paths match, we force addDLL
1044                          -- to look in the default dynamic-link search paths.
1045                          do maybe_errstr <- loadDynamic (lib_paths++[""])
1046                                                             dll_unadorned
1047                             case maybe_errstr of
1048                                Nothing -> return ()
1049                                Just mm -> preloadFailed mm lib_paths lib_spec
1050                             maybePutStrLn dflags "done"
1051
1052         preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
1053         preloadFailed sys_errmsg paths spec
1054            = do maybePutStr dflags
1055                        ("failed.\nDynamic linker error message was:\n   "
1056                         ++ sys_errmsg  ++ "\nWhilst trying to load:  "
1057                         ++ showLS spec ++ "\nDirectories to search are:\n"
1058                         ++ unlines (map ("   "++) paths) )
1059                 give_up
1060
1061         -- not interested in the paths in the static case.
1062         preload_static paths name
1063            = do b <- doesFileExist name
1064                 if not b then return False
1065                          else loadObj name >> return True
1066
1067         give_up
1068            = (throwDyn . CmdLineError)
1069                 "user specified .o/.so/.DLL could not be loaded."
1070
1071 linkPackage :: DynFlags -> PackageConfig -> IO ()
1072 linkPackage dflags pkg
1073    | name pkg `elem` dont_load_these = return ()
1074    | otherwise
1075    = do
1076         let dirs      =  library_dirs pkg
1077         let libs      =  hs_libraries pkg ++ extra_libraries pkg
1078         classifieds   <- mapM (locateOneObj dirs) libs
1079
1080         -- Complication: all the .so's must be loaded before any of the .o's.
1081         let dlls = [ dll | DLL dll <- classifieds ]
1082             objs = [ obj | Object obj <- classifieds ]
1083
1084         maybePutStr dflags ("Loading package " ++ name pkg ++ " ... ")
1085
1086         -- If this package is already part of the GHCi binary, we'll already
1087         -- have the right DLLs for this package loaded, so don't try to
1088         -- load them again.
1089         when (name pkg `notElem` loaded_in_ghci) $
1090             loadDynamics dirs dlls
1091
1092         -- After loading all the DLLs, we can load the static objects.
1093         mapM loadObj objs
1094
1095         maybePutStr dflags "linking ... "
1096         ok <- resolveObjs
1097         if ok then maybePutStrLn dflags "done."
1098               else panic ("can't load package `" ++ name pkg ++ "'")
1099
1100 loadDynamics dirs [] = return ()
1101 loadDynamics dirs (dll:dlls) = do
1102   r <- loadDynamic dirs dll
1103   case r of
1104     Nothing  -> loadDynamics dirs dlls
1105     Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: "
1106                                        ++ dll ++ " (" ++ err ++ ")" ))
1107
1108 -- Try to find an object file for a given library in the given paths.
1109 -- If it isn't present, we assume it's a dynamic library.
1110 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1111 locateOneObj [] lib
1112    = return (DLL lib) -- we assume
1113 locateOneObj (d:ds) lib
1114    = do let path = d ++ '/':lib ++ ".o"
1115         b <- doesFileExist path
1116         if b then return (Object path) else locateOneObj ds lib
1117
1118 -- ----------------------------------------------------------------------------
1119 -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
1120
1121 #ifdef mingw32_TARGET_OS
1122 loadDynamic paths rootname = do
1123   -- ignore paths on windows (why? --SDM)
1124   maybe_errmsg <- addDLL rootname
1125   if maybe_errmsg == nullPtr
1126         then return Nothing
1127         else do str <- peekCString maybe_errmsg
1128                 return (Just str)
1129
1130 addDLL :: String -> String -> IO (Ptr CChar)
1131 addDLL path lib = do
1132   withCString path $ \c_path -> do
1133   withCString lib $ \c_lib -> do
1134     maybe_errmsg <- c_addDLL c_path c_lib
1135     return maybe_errmsg
1136
1137 #else
1138
1139 -- return Nothing == success, else Just error message from dlopen
1140 loadDynamic (path:paths) rootname = do
1141   let dll = path ++ '/':mkSOName rootname
1142   b <- doesFileExist dll
1143   if not b
1144      then loadDynamic paths rootname
1145      else addDLL dll
1146 loadDynamic [] rootname = do
1147         -- tried all our known library paths, let dlopen() search its
1148         -- own builtin paths now.
1149    addDLL (mkSOName rootname)
1150
1151 mkSOName root = "lib" ++ root ++ ".so"
1152
1153 addDLL :: String -> IO (Maybe String)
1154 addDLL str = do
1155   maybe_errmsg <- withCString str $ \dll -> c_addDLL dll
1156   if maybe_errmsg == nullPtr
1157         then return Nothing
1158         else do str <- peekCString maybe_errmsg
1159                 return (Just str)
1160
1161 foreign import ccall "addDLL" unsafe
1162   c_addDLL :: CString -> IO CString
1163
1164 foreign import ccall "dlerror" unsafe
1165   dlerror :: IO CString
1166
1167 #endif
1168
1169 -----------------------------------------------------------------------------
1170 -- timing & statistics
1171
1172 timeIt :: GHCi a -> GHCi a
1173 timeIt action
1174   = do b <- isOptionSet ShowTiming
1175        if not b
1176           then action
1177           else do allocs1 <- io $ getAllocations
1178                   time1   <- io $ getCPUTime
1179                   a <- action
1180                   allocs2 <- io $ getAllocations
1181                   time2   <- io $ getCPUTime
1182                   io $ printTimes (allocs2 - allocs1) (time2 - time1)
1183                   return a
1184
1185 foreign import "getAllocations" getAllocations :: IO Int
1186
1187 printTimes :: Int -> Integer -> IO ()
1188 printTimes allocs psecs
1189    = do let secs = (fromIntegral psecs / (10^12)) :: Float
1190             secs_str = showFFloat (Just 2) secs
1191         putStrLn (showSDoc (
1192                  parens (text (secs_str "") <+> text "secs" <> comma <+>
1193                          int allocs <+> text "bytes")))
1194
1195 -----------------------------------------------------------------------------
1196 -- utils
1197
1198 looksLikeModuleName [] = False
1199 looksLikeModuleName (c:cs) = isUpper c && all isAlphaNumEx cs
1200
1201 isAlphaNumEx c = isAlphaNum c || c == '_' || c == '.'
1202
1203 maybePutStr dflags s | verbosity dflags > 0 = putStr s
1204                      | otherwise            = return ()
1205
1206 maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
1207                        | otherwise            = return ()
1208
1209 -----------------------------------------------------------------------------
1210 -- reverting CAFs
1211
1212 foreign import revertCAFs :: IO ()      -- make it "safe", just in case