compiler/main/InteractiveEval.hs

   1 -- -----------------------------------------------------------------------------
   2 --
   3 -- (c) The University of Glasgow, 2005-2007
   4 --
   5 -- Running statements interactively
   6 --
   7 -- -----------------------------------------------------------------------------
   8
   9 module InteractiveEval (
  10 #ifdef GHCI
  11         RunResult(..), Status(..), Resume(..), History(..),
  12         runStmt, SingleStep(..),
  13         resume,
  14         abandon, abandonAll,
  15         getResumeContext,
  16         getHistorySpan,
  17         back, forward,
  18         setContext, getContext,
  19         nameSetToGlobalRdrEnv,
  20         getNamesInScope,
  21         getRdrNamesInScope,
  22         moduleIsInterpreted,
  23         getInfo,
  24         exprType,
  25         typeKind,
  26         parseName,
  27         showModule,
  28         isModuleInterpreted,
  29         compileExpr, dynCompileExpr,
  30         lookupName,
  31         obtainTerm, obtainTerm1
  32 #endif
  33         ) where
  34
  35 #ifdef GHCI
  36
  37 #include "HsVersions.h"
  38
  39 import HscMain          hiding (compileExpr)
  40 import HscTypes
  41 import TcRnDriver
  42 import Type             hiding (typeKind)
  43 import TcType           hiding (typeKind)
  44 import InstEnv
  45 import Var              hiding (setIdType)
  46 import Id
  47 import IdInfo
  48 import Name             hiding ( varName )
  49 import NameSet
  50 import RdrName
  51 import VarSet
  52 import VarEnv
  53 import ByteCodeInstr
  54 import Linker
  55 import DynFlags
  56 import Unique
  57 import Module
  58 import Panic
  59 import UniqFM
  60 import Maybes
  61 import ErrUtils
  62 import Util
  63 import SrcLoc
  64 import BreakArray
  65 import RtClosureInspect
  66 import Packages
  67 import BasicTypes
  68 import Outputable
  69
  70 import Data.Dynamic
  71 import Control.Monad
  72 import Foreign
  73 import GHC.Exts
  74 import Data.Array
  75 import Control.Exception as Exception
  76 import Control.Concurrent
  77 import Data.IORef
  78 import Foreign.StablePtr
  79
  80 -- -----------------------------------------------------------------------------
  81 -- running a statement interactively
  82
  83 data RunResult
  84   = RunOk [Name]                -- ^ names bound by this evaluation
  85   | RunFailed                   -- ^ statement failed compilation
  86   | RunException Exception      -- ^ statement raised an exception
  87   | RunBreak ThreadId [Name] BreakInfo
  88
  89 data Status
  90    = Break HValue BreakInfo ThreadId
  91           -- ^ the computation hit a breakpoint
  92    | Complete (Either Exception [HValue])
  93           -- ^ the computation completed with either an exception or a value
  94
  95 data Resume
  96    = Resume {
  97        resumeStmt      :: String,       -- the original statement
  98        resumeThreadId  :: ThreadId,     -- thread running the computation
  99        resumeBreakMVar :: MVar (),
 100        resumeStatMVar  :: MVar Status,
 101        resumeBindings  :: ([Id], TyVarSet),
 102        resumeFinalIds  :: [Id],         -- [Id] to bind on completion
 103        resumeApStack   :: HValue,       -- The object from which we can get
 104                                         -- value of the free variables.
 105        resumeBreakInfo :: BreakInfo,    -- the breakpoint we stopped at.
 106        resumeSpan      :: SrcSpan,      -- just a cache, otherwise it's a pain
 107                                         -- to fetch the ModDetails & ModBreaks
 108                                         -- to get this.
 109        resumeHistory   :: [History],
 110        resumeHistoryIx :: Int           -- 0 <==> at the top of the history
 111    }
 112
 113 getResumeContext :: Session -> IO [Resume]
 114 getResumeContext s = withSession s (return . ic_resume . hsc_IC)
 115
 116 data SingleStep
 117    = RunToCompletion
 118    | SingleStep
 119    | RunAndLogSteps
 120
 121 isStep RunToCompletion = False
 122 isStep _ = True
 123
 124 data History
 125    = History {
 126         historyApStack   :: HValue,
 127         historyBreakInfo :: BreakInfo
 128    }
 129
 130 getHistorySpan :: Session -> History -> IO SrcSpan
 131 getHistorySpan s hist = withSession s $ \hsc_env -> do
 132    let inf = historyBreakInfo hist
 133        num = breakInfo_number inf
 134    case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
 135        Just hmi -> return (modBreaks_locs (md_modBreaks (hm_details hmi)) ! num)
 136        _ -> panic "getHistorySpan"
 137
 138 {-
 139  [Main.hs:42:(1,0)-(3,52)] *Main> :history 2
 140  Foo.hs:1:3-5
 141  Bar.hs:5:23-48
 142  [Main.hs:42:(1,0)-(3,52)] *Main> :back
 143  Logged breakpoint at Foo.hs:1:3-5
 144  x :: Int
 145  y :: a
 146  _result :: [Char]
 147  [-1: Foo.hs:1:3-5] *Main> :back
 148  Logged breakpoint at Bar.hs:5:23-48
 149  z :: a
 150  _result :: Float
 151  [-2: Bar.hs:5:23-48] *Main> :forward
 152  Logged breakpoint at Foo.hs:1:3-5
 153  x :: Int
 154  y :: a
 155  _result :: [Char]
 156  [-1: Foo.hs:1:3-5] *Main> :cont
 157  .. continues
 158 -}
 159
 160 -- | Run a statement in the current interactive context.  Statement
 161 -- may bind multple values.
 162 runStmt :: Session -> String -> SingleStep -> IO RunResult
 163 runStmt (Session ref) expr step
 164    = do
 165         hsc_env <- readIORef ref
 166
 167         breakMVar  <- newEmptyMVar  -- wait on this when we hit a breakpoint
 168         statusMVar <- newEmptyMVar  -- wait on this when a computation is running
 169
 170         -- Turn off -fwarn-unused-bindings when running a statement, to hide
 171         -- warnings about the implicit bindings we introduce.
 172         let dflags'  = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
 173             hsc_env' = hsc_env{ hsc_dflags = dflags' }
 174
 175         maybe_stuff <- hscStmt hsc_env' expr
 176
 177         case maybe_stuff of
 178            Nothing -> return RunFailed
 179            Just (ids, hval) -> do
 180
 181               when (isStep step) $ setStepFlag
 182
 183               -- set the onBreakAction to be performed when we hit a
 184               -- breakpoint this is visible in the Byte Code
 185               -- Interpreter, thus it is a global variable,
 186               -- implemented with stable pointers
 187               withBreakAction breakMVar statusMVar $ do
 188
 189               let thing_to_run = unsafeCoerce# hval :: IO [HValue]
 190               status <- sandboxIO statusMVar thing_to_run
 191
 192               let ic = hsc_IC hsc_env
 193                   bindings = (ic_tmp_ids ic, ic_tyvars ic)
 194
 195               case step of
 196                 RunAndLogSteps ->
 197                         traceRunStatus expr ref bindings ids
 198                                        breakMVar statusMVar status emptyHistory
 199                 _other ->
 200                         handleRunStatus expr ref bindings ids
 201                                         breakMVar statusMVar status emptyHistory
 202
 203
 204 emptyHistory = nilBL 50 -- keep a log of length 50
 205
 206 handleRunStatus expr ref bindings final_ids breakMVar statusMVar status
 207                 history =
 208    case status of
 209       -- did we hit a breakpoint or did we complete?
 210       (Break apStack info tid) -> do
 211         hsc_env <- readIORef ref
 212         (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env apStack info
 213         let
 214             resume = Resume expr tid breakMVar statusMVar
 215                               bindings final_ids apStack info span
 216                               (toListBL history) 0
 217             hsc_env2 = pushResume hsc_env1 resume
 218         --
 219         writeIORef ref hsc_env2
 220         return (RunBreak tid names info)
 221       (Complete either_hvals) ->
 222         case either_hvals of
 223             Left e -> return (RunException e)
 224             Right hvals -> do
 225                 hsc_env <- readIORef ref
 226                 let final_ic = extendInteractiveContext (hsc_IC hsc_env)
 227                                         final_ids emptyVarSet
 228                         -- the bound Ids never have any free TyVars
 229                     final_names = map idName final_ids
 230                 writeIORef ref hsc_env{hsc_IC=final_ic}
 231                 Linker.extendLinkEnv (zip final_names hvals)
 232                 return (RunOk final_names)
 233
 234
 235 traceRunStatus expr ref bindings final_ids
 236                breakMVar statusMVar status history = do
 237   hsc_env <- readIORef ref
 238   case status of
 239      -- when tracing, if we hit a breakpoint that is not explicitly
 240      -- enabled, then we just log the event in the history and continue.
 241      (Break apStack info tid) -> do
 242         b <- isBreakEnabled hsc_env info
 243         if b
 244            then handle_normally
 245            else do
 246              let history' = consBL (History apStack info) history
 247                 -- probably better make history strict here, otherwise
 248                 -- our BoundedList will be pointless.
 249              evaluate history'
 250              setStepFlag
 251              status <- withBreakAction breakMVar statusMVar $ do
 252                        withInterruptsSentTo
 253                          (do putMVar breakMVar ()  -- awaken the stopped thread
 254                              return tid)
 255                          (takeMVar statusMVar)     -- and wait for the result
 256              traceRunStatus expr ref bindings final_ids
 257                             breakMVar statusMVar status history'
 258      _other ->
 259         handle_normally
 260   where
 261         handle_normally = handleRunStatus expr ref bindings final_ids
 262                                           breakMVar statusMVar status history
 263
 264
 265 isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool
 266 isBreakEnabled hsc_env inf =
 267    case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
 268        Just hmi -> do
 269          w <- getBreak (modBreaks_flags (md_modBreaks (hm_details hmi)))
 270                        (breakInfo_number inf)
 271          case w of Just n -> return (n /= 0); _other -> return False
 272        _ ->
 273          return False
 274
 275
 276 foreign import ccall "rts_setStepFlag" setStepFlag :: IO ()
 277
 278 -- this points to the IO action that is executed when a breakpoint is hit
 279 foreign import ccall "&breakPointIOAction"
 280         breakPointIOAction :: Ptr (StablePtr (BreakInfo -> HValue -> IO ()))
 281
 282 -- When running a computation, we redirect ^C exceptions to the running
 283 -- thread.  ToDo: we might want a way to continue even if the target
 284 -- thread doesn't die when it receives the exception... "this thread
 285 -- is not responding".
 286 sandboxIO :: MVar Status -> IO [HValue] -> IO Status
 287 sandboxIO statusMVar thing =
 288   withInterruptsSentTo
 289         (forkIO (do res <- Exception.try thing
 290                     putMVar statusMVar (Complete res)))
 291         (takeMVar statusMVar)
 292
 293 withInterruptsSentTo :: IO ThreadId -> IO r -> IO r
 294 withInterruptsSentTo io get_result = do
 295   ts <- takeMVar interruptTargetThread
 296   child <- io
 297   putMVar interruptTargetThread (child:ts)
 298   get_result `finally` modifyMVar_ interruptTargetThread (return.tail)
 299
 300 withBreakAction breakMVar statusMVar io
 301  = bracket setBreakAction resetBreakAction (\_ -> io)
 302  where
 303    setBreakAction = do
 304      stablePtr <- newStablePtr onBreak
 305      poke breakPointIOAction stablePtr
 306      return stablePtr
 307
 308    onBreak info apStack = do
 309      tid <- myThreadId
 310      putMVar statusMVar (Break apStack info tid)
 311      takeMVar breakMVar
 312
 313    resetBreakAction stablePtr = do
 314      poke breakPointIOAction noBreakStablePtr
 315      freeStablePtr stablePtr
 316
 317 noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
 318 noBreakAction info apStack = putStrLn "*** Ignoring breakpoint"
 319
 320 resume :: Session -> SingleStep -> IO RunResult
 321 resume (Session ref) step
 322  = do
 323    hsc_env <- readIORef ref
 324    let ic = hsc_IC hsc_env
 325        resume = ic_resume ic
 326
 327    case resume of
 328      [] -> throwDyn (ProgramError "not stopped at a breakpoint")
 329      (r:rs) -> do
 330         -- unbind the temporary locals by restoring the TypeEnv from
 331         -- before the breakpoint, and drop this Resume from the
 332         -- InteractiveContext.
 333         let (resume_tmp_ids, resume_tyvars) = resumeBindings r
 334             ic' = ic { ic_tmp_ids  = resume_tmp_ids,
 335                        ic_tyvars   = resume_tyvars,
 336                        ic_resume   = rs }
 337         writeIORef ref hsc_env{ hsc_IC = ic' }
 338
 339         -- remove any bindings created since the breakpoint from the
 340         -- linker's environment
 341         let new_names = map idName (filter (`notElem` resume_tmp_ids)
 342                                            (ic_tmp_ids ic))
 343         Linker.deleteFromLinkEnv new_names
 344
 345         when (isStep step) $ setStepFlag
 346         case r of
 347           Resume expr tid breakMVar statusMVar bindings
 348               final_ids apStack info _ _ _ -> do
 349                 withBreakAction breakMVar statusMVar $ do
 350                 status <- withInterruptsSentTo
 351                              (do putMVar breakMVar ()
 352                                       -- this awakens the stopped thread...
 353                                  return tid)
 354                              (takeMVar statusMVar)
 355                                       -- and wait for the result
 356                 case step of
 357                   RunAndLogSteps ->
 358                         traceRunStatus expr ref bindings final_ids
 359                                        breakMVar statusMVar status emptyHistory
 360                   _other ->
 361                         handleRunStatus expr ref bindings final_ids
 362                                         breakMVar statusMVar status emptyHistory
 363
 364
 365 back :: Session -> IO ([Name], Int, SrcSpan)
 366 back  = moveHist (+1)
 367
 368 forward :: Session -> IO ([Name], Int, SrcSpan)
 369 forward  = moveHist (subtract 1)
 370
 371 moveHist fn (Session ref) = do
 372   hsc_env <- readIORef ref
 373   case ic_resume (hsc_IC hsc_env) of
 374      [] -> throwDyn (ProgramError "not stopped at a breakpoint")
 375      (r:rs) -> do
 376         let ix = resumeHistoryIx r
 377             history = resumeHistory r
 378             new_ix = fn ix
 379         --
 380         when (new_ix >= length history) $
 381            throwDyn (ProgramError "no more logged breakpoints")
 382         when (new_ix < 0) $
 383            throwDyn (ProgramError "already at the beginning of the history")
 384
 385         let
 386           update_ic apStack info = do
 387             (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env
 388                                                 apStack info
 389             let ic = hsc_IC hsc_env1
 390                 r' = r { resumeHistoryIx = new_ix }
 391                 ic' = ic { ic_resume = r':rs }
 392
 393             writeIORef ref hsc_env1{ hsc_IC = ic' }
 394
 395             return (names, new_ix, span)
 396
 397         -- careful: we want apStack to be the AP_STACK itself, not a thunk
 398         -- around it, hence the cases are carefully constructed below to
 399         -- make this the case.  ToDo: this is v. fragile, do something better.
 400         if new_ix == 0
 401            then case r of
 402                    Resume { resumeApStack = apStack,
 403                             resumeBreakInfo = info } ->
 404                           update_ic apStack info
 405            else case history !! (new_ix - 1) of
 406                    History apStack info ->
 407                           update_ic apStack info
 408
 409 -- -----------------------------------------------------------------------------
 410 -- After stopping at a breakpoint, add free variables to the environment
 411
 412 bindLocalsAtBreakpoint
 413         :: HscEnv
 414         -> HValue
 415         -> BreakInfo
 416         -> IO (HscEnv, [Name], SrcSpan)
 417 bindLocalsAtBreakpoint hsc_env apStack info = do
 418
 419    let
 420        mod_name    = moduleName (breakInfo_module info)
 421        mod_details = fmap hm_details (lookupUFM (hsc_HPT hsc_env) mod_name)
 422        breaks      = md_modBreaks (expectJust "handlRunStatus" mod_details)
 423        index     = breakInfo_number info
 424        vars      = breakInfo_vars info
 425        result_ty = breakInfo_resty info
 426        occs      = modBreaks_vars breaks ! index
 427        span      = modBreaks_locs breaks ! index
 428
 429    -- filter out any unboxed ids; we can't bind these at the prompt
 430    let pointers = filter (\(id,_) -> isPointer id) vars
 431        isPointer id | PtrRep <- idPrimRep id = True
 432                     | otherwise              = False
 433
 434    let (ids, offsets) = unzip pointers
 435
 436    -- It might be that getIdValFromApStack fails, because the AP_STACK
 437    -- has been accidentally evaluated, or something else has gone wrong.
 438    -- So that we don't fall over in a heap when this happens, just don't
 439    -- bind any free variables instead, and we emit a warning.
 440    mb_hValues <- mapM (getIdValFromApStack apStack) offsets
 441    let filtered_ids = [ id | (id, Just _) <- zip ids mb_hValues ]
 442    when (any isNothing mb_hValues) $
 443       debugTraceMsg (hsc_dflags hsc_env) 1 $
 444           text "Warning: _result has been evaluated, some bindings have been lost"
 445
 446    new_ids <- zipWithM mkNewId occs filtered_ids
 447    let names = map idName new_ids
 448
 449    -- make an Id for _result.  We use the Unique of the FastString "_result";
 450    -- we don't care about uniqueness here, because there will only be one
 451    -- _result in scope at any time.
 452    let result_fs = FSLIT("_result")
 453        result_name = mkInternalName (getUnique result_fs)
 454                           (mkVarOccFS result_fs) span
 455        result_id   = Id.mkGlobalId VanillaGlobal result_name result_ty
 456                                    vanillaIdInfo
 457
 458    -- for each Id we're about to bind in the local envt:
 459    --    - skolemise the type variables in its type, so they can't
 460    --      be randomly unified with other types.  These type variables
 461    --      can only be resolved by type reconstruction in RtClosureInspect
 462    --    - tidy the type variables
 463    --    - globalise the Id (Ids are supposed to be Global, apparently).
 464    --
 465    let all_ids | isPointer result_id = result_id : new_ids
 466                | otherwise           = new_ids
 467        (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
 468        (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
 469        new_tyvars = unionVarSets tyvarss
 470        final_ids = zipWith setIdType all_ids tidy_tys
 471
 472    let   ictxt0 = hsc_IC hsc_env
 473          ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
 474
 475    Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
 476    Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
 477    return (hsc_env{ hsc_IC = ictxt1 }, result_name:names, span)
 478   where
 479    mkNewId :: OccName -> Id -> IO Id
 480    mkNewId occ id = do
 481      let uniq = idUnique id
 482          loc = nameSrcSpan (idName id)
 483          name = mkInternalName uniq occ loc
 484          ty = idType id
 485          new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id)
 486      return new_id
 487
 488 skolemiseTy :: Type -> (Type, TyVarSet)
 489 skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
 490   where env           = mkVarEnv (zip tyvars new_tyvar_tys)
 491         subst         = mkTvSubst emptyInScopeSet env
 492         tyvars        = varSetElems (tyVarsOfType ty)
 493         new_tyvars    = map skolemiseTyVar tyvars
 494         new_tyvar_tys = map mkTyVarTy new_tyvars
 495
 496 skolemiseTyVar :: TyVar -> TyVar
 497 skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar)
 498                                  (SkolemTv RuntimeUnkSkol)
 499
 500 getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
 501 getIdValFromApStack apStack (I# stackDepth) = do
 502    case getApStackVal# apStack (stackDepth +# 1#) of
 503                                 -- The +1 is magic!  I don't know where it comes
 504                                 -- from, but this makes things line up.  --SDM
 505         (# ok, result #) ->
 506             case ok of
 507               0# -> return Nothing -- AP_STACK not found
 508               _  -> return (Just (unsafeCoerce# result))
 509
 510 pushResume :: HscEnv -> Resume -> HscEnv
 511 pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
 512   where
 513         ictxt0 = hsc_IC hsc_env
 514         ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
 515
 516 -- -----------------------------------------------------------------------------
 517 -- Abandoning a resume context
 518
 519 abandon :: Session -> IO Bool
 520 abandon (Session ref) = do
 521    hsc_env <- readIORef ref
 522    let ic = hsc_IC hsc_env
 523        resume = ic_resume ic
 524    case resume of
 525       []    -> return False
 526       r:rs  -> do
 527          writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = rs } }
 528          abandon_ r
 529          return True
 530
 531 abandonAll :: Session -> IO Bool
 532 abandonAll (Session ref) = do
 533    hsc_env <- readIORef ref
 534    let ic = hsc_IC hsc_env
 535        resume = ic_resume ic
 536    case resume of
 537       []  -> return False
 538       rs  -> do
 539          writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = [] } }
 540          mapM_ abandon_ rs
 541          return True
 542
 543 -- when abandoning a computation we have to
 544 --      (a) kill the thread with an async exception, so that the
 545 --          computation itself is stopped, and
 546 --      (b) fill in the MVar.  This step is necessary because any
 547 --          thunks that were under evaluation will now be updated
 548 --          with the partial computation, which still ends in takeMVar,
 549 --          so any attempt to evaluate one of these thunks will block
 550 --          unless we fill in the MVar.
 551 --  See test break010.
 552 abandon_ :: Resume -> IO ()
 553 abandon_ r = do
 554   killThread (resumeThreadId r)
 555   putMVar (resumeBreakMVar r) ()
 556
 557 -- -----------------------------------------------------------------------------
 558 -- Bounded list, optimised for repeated cons
 559
 560 data BoundedList a = BL
 561                         {-# UNPACK #-} !Int  -- length
 562                         {-# UNPACK #-} !Int  -- bound
 563                         [a] -- left
 564                         [a] -- right,  list is (left ++ reverse right)
 565
 566 nilBL :: Int -> BoundedList a
 567 nilBL bound = BL 0 bound [] []
 568
 569 consBL a (BL len bound left right)
 570   | len < bound = BL (len+1) bound (a:left) right
 571   | null right  = BL len     bound [a]      $! tail (reverse left)
 572   | otherwise   = BL len     bound (a:left) $! tail right
 573
 574 toListBL (BL _ _ left right) = left ++ reverse right
 575
 576 -- lenBL (BL len _ _ _) = len
 577
 578 -- -----------------------------------------------------------------------------
 579 -- | Set the interactive evaluation context.
 580 --
 581 -- Setting the context doesn't throw away any bindings; the bindings
 582 -- we've built up in the InteractiveContext simply move to the new
 583 -- module.  They always shadow anything in scope in the current context.
 584 setContext :: Session
 585            -> [Module]  -- entire top level scope of these modules
 586            -> [Module]  -- exports only of these modules
 587            -> IO ()
 588 setContext sess@(Session ref) toplev_mods export_mods = do
 589   hsc_env <- readIORef ref
 590   let old_ic  = hsc_IC     hsc_env
 591       hpt     = hsc_HPT    hsc_env
 592   --
 593   export_env  <- mkExportEnv hsc_env export_mods
 594   toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods
 595   let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
 596   writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
 597                                             ic_exports      = export_mods,
 598                                             ic_rn_gbl_env   = all_env }}
 599
 600 -- Make a GlobalRdrEnv based on the exports of the modules only.
 601 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
 602 mkExportEnv hsc_env mods = do
 603   stuff <- mapM (getModuleExports hsc_env) mods
 604   let
 605         (_msgs, mb_name_sets) = unzip stuff
 606         gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod)
 607                | (Just avails, mod) <- zip mb_name_sets mods ]
 608   --
 609   return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
 610
 611 nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
 612 nameSetToGlobalRdrEnv names mod =
 613   mkGlobalRdrEnv [ GRE  { gre_name = name, gre_prov = vanillaProv mod }
 614                  | name <- nameSetToList names ]
 615
 616 vanillaProv :: ModuleName -> Provenance
 617 -- We're building a GlobalRdrEnv as if the user imported
 618 -- all the specified modules into the global interactive module
 619 vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
 620   where
 621     decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
 622                          is_qual = False,
 623                          is_dloc = srcLocSpan interactiveSrcLoc }
 624
 625 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
 626 mkTopLevEnv hpt modl
 627   = case lookupUFM hpt (moduleName modl) of
 628       Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++
 629                                                 showSDoc (ppr modl)))
 630       Just details ->
 631          case mi_globals (hm_iface details) of
 632                 Nothing  ->
 633                    throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
 634                                                 ++ showSDoc (ppr modl)))
 635                 Just env -> return env
 636
 637 -- | Get the interactive evaluation context, consisting of a pair of the
 638 -- set of modules from which we take the full top-level scope, and the set
 639 -- of modules from which we take just the exports respectively.
 640 getContext :: Session -> IO ([Module],[Module])
 641 getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
 642                                 return (ic_toplev_scope ic, ic_exports ic))
 643
 644 -- | Returns 'True' if the specified module is interpreted, and hence has
 645 -- its full top-level scope available.
 646 moduleIsInterpreted :: Session -> Module -> IO Bool
 647 moduleIsInterpreted s modl = withSession s $ \h ->
 648  if modulePackageId modl /= thisPackage (hsc_dflags h)
 649         then return False
 650         else case lookupUFM (hsc_HPT h) (moduleName modl) of
 651                 Just details       -> return (isJust (mi_globals (hm_iface details)))
 652                 _not_a_home_module -> return False
 653
 654 -- | Looks up an identifier in the current interactive context (for :info)
 655 getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
 656 getInfo s name = withSession s $ \hsc_env -> tcRnGetInfo hsc_env name
 657
 658 -- | Returns all names in scope in the current interactive context
 659 getNamesInScope :: Session -> IO [Name]
 660 getNamesInScope s = withSession s $ \hsc_env -> do
 661   return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
 662
 663 getRdrNamesInScope :: Session -> IO [RdrName]
 664 getRdrNamesInScope  s = withSession s $ \hsc_env -> do
 665   let
 666       ic = hsc_IC hsc_env
 667       gbl_rdrenv = ic_rn_gbl_env ic
 668       ids = ic_tmp_ids ic
 669       gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv))
 670       lcl_names = map (mkRdrUnqual.nameOccName.idName) ids
 671   --
 672   return (gbl_names ++ lcl_names)
 673
 674
 675 -- ToDo: move to RdrName
 676 greToRdrNames :: GlobalRdrElt -> [RdrName]
 677 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
 678   = case prov of
 679      LocalDef -> [unqual]
 680      Imported specs -> concat (map do_spec (map is_decl specs))
 681   where
 682     occ = nameOccName name
 683     unqual = Unqual occ
 684     do_spec decl_spec
 685         | is_qual decl_spec = [qual]
 686         | otherwise         = [unqual,qual]
 687         where qual = Qual (is_as decl_spec) occ
 688
 689 -- | Parses a string as an identifier, and returns the list of 'Name's that
 690 -- the identifier can refer to in the current interactive context.
 691 parseName :: Session -> String -> IO [Name]
 692 parseName s str = withSession s $ \hsc_env -> do
 693    maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
 694    case maybe_rdr_name of
 695         Nothing -> return []
 696         Just (L _ rdr_name) -> do
 697             mb_names <- tcRnLookupRdrName hsc_env rdr_name
 698             case mb_names of
 699                 Nothing -> return []
 700                 Just ns -> return ns
 701                 -- ToDo: should return error messages
 702
 703 -- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any
 704 -- entity known to GHC, including 'Name's defined using 'runStmt'.
 705 lookupName :: Session -> Name -> IO (Maybe TyThing)
 706 lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name
 707
 708 -- -----------------------------------------------------------------------------
 709 -- Getting the type of an expression
 710
 711 -- | Get the type of an expression
 712 exprType :: Session -> String -> IO (Maybe Type)
 713 exprType s expr = withSession s $ \hsc_env -> do
 714    maybe_stuff <- hscTcExpr hsc_env expr
 715    case maybe_stuff of
 716         Nothing -> return Nothing
 717         Just ty -> return (Just tidy_ty)
 718              where
 719                 tidy_ty = tidyType emptyTidyEnv ty
 720
 721 -- -----------------------------------------------------------------------------
 722 -- Getting the kind of a type
 723
 724 -- | Get the kind of a  type
 725 typeKind  :: Session -> String -> IO (Maybe Kind)
 726 typeKind s str = withSession s $ \hsc_env -> do
 727    maybe_stuff <- hscKcType hsc_env str
 728    case maybe_stuff of
 729         Nothing -> return Nothing
 730         Just kind -> return (Just kind)
 731
 732 -----------------------------------------------------------------------------
 733 -- cmCompileExpr: compile an expression and deliver an HValue
 734
 735 compileExpr :: Session -> String -> IO (Maybe HValue)
 736 compileExpr s expr = withSession s $ \hsc_env -> do
 737   maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
 738   case maybe_stuff of
 739         Nothing -> return Nothing
 740         Just (ids, hval) -> do
 741                         -- Run it!
 742                 hvals <- (unsafeCoerce# hval) :: IO [HValue]
 743
 744                 case (ids,hvals) of
 745                   ([n],[hv]) -> return (Just hv)
 746                   _          -> panic "compileExpr"
 747
 748 -- -----------------------------------------------------------------------------
 749 -- Compile an expression into a dynamic
 750
 751 dynCompileExpr :: Session -> String -> IO (Maybe Dynamic)
 752 dynCompileExpr ses expr = do
 753     (full,exports) <- getContext ses
 754     setContext ses full $
 755         (mkModule
 756             (stringToPackageId "base") (mkModuleName "Data.Dynamic")
 757         ):exports
 758     let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
 759     res <- withSession ses (flip hscStmt stmt)
 760     setContext ses full exports
 761     case res of
 762         Nothing -> return Nothing
 763         Just (ids, hvals) -> do
 764             vals <- (unsafeCoerce# hvals :: IO [Dynamic])
 765             case (ids,vals) of
 766                 (_:[], v:[])    -> return (Just v)
 767                 _               -> panic "dynCompileExpr"
 768
 769 -----------------------------------------------------------------------------
 770 -- show a module and it's source/object filenames
 771
 772 showModule :: Session -> ModSummary -> IO String
 773 showModule s mod_summary = withSession s $                        \hsc_env ->
 774                            isModuleInterpreted s mod_summary >>=  \interpreted ->
 775                            return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
 776
 777 isModuleInterpreted :: Session -> ModSummary -> IO Bool
 778 isModuleInterpreted s mod_summary = withSession s $ \hsc_env ->
 779   case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
 780         Nothing       -> panic "missing linkable"
 781         Just mod_info -> return (not obj_linkable)
 782                       where
 783                          obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
 784
 785 obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term
 786 obtainTerm1 sess force mb_ty x = withSession sess $ \hsc_env -> cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x)
 787
 788 obtainTerm :: Session -> Bool -> Id -> IO Term
 789 obtainTerm sess force id = withSession sess $ \hsc_env -> do
 790               hv <- Linker.getHValue hsc_env (varName id)
 791               cvObtainTerm hsc_env force (Just$ idType id) hv
 792
 793 #endif /* GHCI */