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) (srcSpanStart span)
 455        result_id   = Id.mkLocalId result_name result_ty
 456
 457    -- for each Id we're about to bind in the local envt:
 458    --    - skolemise the type variables in its type, so they can't
 459    --      be randomly unified with other types.  These type variables
 460    --      can only be resolved by type reconstruction in RtClosureInspect
 461    --    - tidy the type variables
 462    --    - globalise the Id (Ids are supposed to be Global, apparently).
 463    --
 464    let all_ids | isPointer result_id = result_id : new_ids
 465                | otherwise           = new_ids
 466        (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
 467        (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
 468        new_tyvars = unionVarSets tyvarss
 469        final_ids = zipWith setIdType all_ids tidy_tys
 470
 471    let   ictxt0 = hsc_IC hsc_env
 472          ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
 473
 474    Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
 475    Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
 476    return (hsc_env{ hsc_IC = ictxt1 }, result_name:names, span)
 477   where
 478    mkNewId :: OccName -> Id -> IO Id
 479    mkNewId occ id = do
 480      let uniq = idUnique id
 481          loc = nameSrcLoc (idName id)
 482          name = mkInternalName uniq occ loc
 483          ty = idType id
 484          new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id)
 485      return new_id
 486
 487 skolemiseTy :: Type -> (Type, TyVarSet)
 488 skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
 489   where env           = mkVarEnv (zip tyvars new_tyvar_tys)
 490         subst         = mkTvSubst emptyInScopeSet env
 491         tyvars        = varSetElems (tyVarsOfType ty)
 492         new_tyvars    = map skolemiseTyVar tyvars
 493         new_tyvar_tys = map mkTyVarTy new_tyvars
 494
 495 skolemiseTyVar :: TyVar -> TyVar
 496 skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar)
 497                                  (SkolemTv RuntimeUnkSkol)
 498
 499 getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
 500 getIdValFromApStack apStack (I# stackDepth) = do
 501    case getApStackVal# apStack (stackDepth +# 1#) of
 502                                 -- The +1 is magic!  I don't know where it comes
 503                                 -- from, but this makes things line up.  --SDM
 504         (# ok, result #) ->
 505             case ok of
 506               0# -> return Nothing -- AP_STACK not found
 507               _  -> return (Just (unsafeCoerce# result))
 508
 509 pushResume :: HscEnv -> Resume -> HscEnv
 510 pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
 511   where
 512         ictxt0 = hsc_IC hsc_env
 513         ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
 514
 515 -- -----------------------------------------------------------------------------
 516 -- Abandoning a resume context
 517
 518 abandon :: Session -> IO Bool
 519 abandon (Session ref) = do
 520    hsc_env <- readIORef ref
 521    let ic = hsc_IC hsc_env
 522        resume = ic_resume ic
 523    case resume of
 524       []    -> return False
 525       r:rs  -> do
 526          writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = rs } }
 527          abandon_ r
 528          return True
 529
 530 abandonAll :: Session -> IO Bool
 531 abandonAll (Session ref) = do
 532    hsc_env <- readIORef ref
 533    let ic = hsc_IC hsc_env
 534        resume = ic_resume ic
 535    case resume of
 536       []  -> return False
 537       rs  -> do
 538          writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = [] } }
 539          mapM_ abandon_ rs
 540          return True
 541
 542 -- when abandoning a computation we have to
 543 --      (a) kill the thread with an async exception, so that the
 544 --          computation itself is stopped, and
 545 --      (b) fill in the MVar.  This step is necessary because any
 546 --          thunks that were under evaluation will now be updated
 547 --          with the partial computation, which still ends in takeMVar,
 548 --          so any attempt to evaluate one of these thunks will block
 549 --          unless we fill in the MVar.
 550 --  See test break010.
 551 abandon_ :: Resume -> IO ()
 552 abandon_ r = do
 553   killThread (resumeThreadId r)
 554   putMVar (resumeBreakMVar r) ()
 555
 556 -- -----------------------------------------------------------------------------
 557 -- Bounded list, optimised for repeated cons
 558
 559 data BoundedList a = BL
 560                         {-# UNPACK #-} !Int  -- length
 561                         {-# UNPACK #-} !Int  -- bound
 562                         [a] -- left
 563                         [a] -- right,  list is (left ++ reverse right)
 564
 565 nilBL :: Int -> BoundedList a
 566 nilBL bound = BL 0 bound [] []
 567
 568 consBL a (BL len bound left right)
 569   | len < bound = BL (len+1) bound (a:left) right
 570   | null right  = BL len     bound [a]      $! tail (reverse left)
 571   | otherwise   = BL len     bound (a:left) $! tail right
 572
 573 toListBL (BL _ _ left right) = left ++ reverse right
 574
 575 -- lenBL (BL len _ _ _) = len
 576
 577 -- -----------------------------------------------------------------------------
 578 -- | Set the interactive evaluation context.
 579 --
 580 -- Setting the context doesn't throw away any bindings; the bindings
 581 -- we've built up in the InteractiveContext simply move to the new
 582 -- module.  They always shadow anything in scope in the current context.
 583 setContext :: Session
 584            -> [Module]  -- entire top level scope of these modules
 585            -> [Module]  -- exports only of these modules
 586            -> IO ()
 587 setContext sess@(Session ref) toplev_mods export_mods = do
 588   hsc_env <- readIORef ref
 589   let old_ic  = hsc_IC     hsc_env
 590       hpt     = hsc_HPT    hsc_env
 591   --
 592   export_env  <- mkExportEnv hsc_env export_mods
 593   toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods
 594   let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
 595   writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
 596                                             ic_exports      = export_mods,
 597                                             ic_rn_gbl_env   = all_env }}
 598
 599 -- Make a GlobalRdrEnv based on the exports of the modules only.
 600 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
 601 mkExportEnv hsc_env mods = do
 602   stuff <- mapM (getModuleExports hsc_env) mods
 603   let
 604         (_msgs, mb_name_sets) = unzip stuff
 605         gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod)
 606                | (Just avails, mod) <- zip mb_name_sets mods ]
 607   --
 608   return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
 609
 610 nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
 611 nameSetToGlobalRdrEnv names mod =
 612   mkGlobalRdrEnv [ GRE  { gre_name = name, gre_prov = vanillaProv mod }
 613                  | name <- nameSetToList names ]
 614
 615 vanillaProv :: ModuleName -> Provenance
 616 -- We're building a GlobalRdrEnv as if the user imported
 617 -- all the specified modules into the global interactive module
 618 vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
 619   where
 620     decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
 621                          is_qual = False,
 622                          is_dloc = srcLocSpan interactiveSrcLoc }
 623
 624 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
 625 mkTopLevEnv hpt modl
 626   = case lookupUFM hpt (moduleName modl) of
 627       Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++
 628                                                 showSDoc (ppr modl)))
 629       Just details ->
 630          case mi_globals (hm_iface details) of
 631                 Nothing  ->
 632                    throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
 633                                                 ++ showSDoc (ppr modl)))
 634                 Just env -> return env
 635
 636 -- | Get the interactive evaluation context, consisting of a pair of the
 637 -- set of modules from which we take the full top-level scope, and the set
 638 -- of modules from which we take just the exports respectively.
 639 getContext :: Session -> IO ([Module],[Module])
 640 getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
 641                                 return (ic_toplev_scope ic, ic_exports ic))
 642
 643 -- | Returns 'True' if the specified module is interpreted, and hence has
 644 -- its full top-level scope available.
 645 moduleIsInterpreted :: Session -> Module -> IO Bool
 646 moduleIsInterpreted s modl = withSession s $ \h ->
 647  if modulePackageId modl /= thisPackage (hsc_dflags h)
 648         then return False
 649         else case lookupUFM (hsc_HPT h) (moduleName modl) of
 650                 Just details       -> return (isJust (mi_globals (hm_iface details)))
 651                 _not_a_home_module -> return False
 652
 653 -- | Looks up an identifier in the current interactive context (for :info)
 654 getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
 655 getInfo s name = withSession s $ \hsc_env -> tcRnGetInfo hsc_env name
 656
 657 -- | Returns all names in scope in the current interactive context
 658 getNamesInScope :: Session -> IO [Name]
 659 getNamesInScope s = withSession s $ \hsc_env -> do
 660   return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
 661
 662 getRdrNamesInScope :: Session -> IO [RdrName]
 663 getRdrNamesInScope  s = withSession s $ \hsc_env -> do
 664   let
 665       ic = hsc_IC hsc_env
 666       gbl_rdrenv = ic_rn_gbl_env ic
 667       ids = ic_tmp_ids ic
 668       gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv))
 669       lcl_names = map (mkRdrUnqual.nameOccName.idName) ids
 670   --
 671   return (gbl_names ++ lcl_names)
 672
 673
 674 -- ToDo: move to RdrName
 675 greToRdrNames :: GlobalRdrElt -> [RdrName]
 676 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
 677   = case prov of
 678      LocalDef -> [unqual]
 679      Imported specs -> concat (map do_spec (map is_decl specs))
 680   where
 681     occ = nameOccName name
 682     unqual = Unqual occ
 683     do_spec decl_spec
 684         | is_qual decl_spec = [qual]
 685         | otherwise         = [unqual,qual]
 686         where qual = Qual (is_as decl_spec) occ
 687
 688 -- | Parses a string as an identifier, and returns the list of 'Name's that
 689 -- the identifier can refer to in the current interactive context.
 690 parseName :: Session -> String -> IO [Name]
 691 parseName s str = withSession s $ \hsc_env -> do
 692    maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
 693    case maybe_rdr_name of
 694         Nothing -> return []
 695         Just (L _ rdr_name) -> do
 696             mb_names <- tcRnLookupRdrName hsc_env rdr_name
 697             case mb_names of
 698                 Nothing -> return []
 699                 Just ns -> return ns
 700                 -- ToDo: should return error messages
 701
 702 -- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any
 703 -- entity known to GHC, including 'Name's defined using 'runStmt'.
 704 lookupName :: Session -> Name -> IO (Maybe TyThing)
 705 lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name
 706
 707 -- -----------------------------------------------------------------------------
 708 -- Getting the type of an expression
 709
 710 -- | Get the type of an expression
 711 exprType :: Session -> String -> IO (Maybe Type)
 712 exprType s expr = withSession s $ \hsc_env -> do
 713    maybe_stuff <- hscTcExpr hsc_env expr
 714    case maybe_stuff of
 715         Nothing -> return Nothing
 716         Just ty -> return (Just tidy_ty)
 717              where
 718                 tidy_ty = tidyType emptyTidyEnv ty
 719
 720 -- -----------------------------------------------------------------------------
 721 -- Getting the kind of a type
 722
 723 -- | Get the kind of a  type
 724 typeKind  :: Session -> String -> IO (Maybe Kind)
 725 typeKind s str = withSession s $ \hsc_env -> do
 726    maybe_stuff <- hscKcType hsc_env str
 727    case maybe_stuff of
 728         Nothing -> return Nothing
 729         Just kind -> return (Just kind)
 730
 731 -----------------------------------------------------------------------------
 732 -- cmCompileExpr: compile an expression and deliver an HValue
 733
 734 compileExpr :: Session -> String -> IO (Maybe HValue)
 735 compileExpr s expr = withSession s $ \hsc_env -> do
 736   maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
 737   case maybe_stuff of
 738         Nothing -> return Nothing
 739         Just (ids, hval) -> do
 740                         -- Run it!
 741                 hvals <- (unsafeCoerce# hval) :: IO [HValue]
 742
 743                 case (ids,hvals) of
 744                   ([n],[hv]) -> return (Just hv)
 745                   _          -> panic "compileExpr"
 746
 747 -- -----------------------------------------------------------------------------
 748 -- Compile an expression into a dynamic
 749
 750 dynCompileExpr :: Session -> String -> IO (Maybe Dynamic)
 751 dynCompileExpr ses expr = do
 752     (full,exports) <- getContext ses
 753     setContext ses full $
 754         (mkModule
 755             (stringToPackageId "base") (mkModuleName "Data.Dynamic")
 756         ):exports
 757     let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
 758     res <- withSession ses (flip hscStmt stmt)
 759     setContext ses full exports
 760     case res of
 761         Nothing -> return Nothing
 762         Just (ids, hvals) -> do
 763             vals <- (unsafeCoerce# hvals :: IO [Dynamic])
 764             case (ids,vals) of
 765                 (_:[], v:[])    -> return (Just v)
 766                 _               -> panic "dynCompileExpr"
 767
 768 -----------------------------------------------------------------------------
 769 -- show a module and it's source/object filenames
 770
 771 showModule :: Session -> ModSummary -> IO String
 772 showModule s mod_summary = withSession s $                        \hsc_env ->
 773                            isModuleInterpreted s mod_summary >>=  \interpreted ->
 774                            return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
 775
 776 isModuleInterpreted :: Session -> ModSummary -> IO Bool
 777 isModuleInterpreted s mod_summary = withSession s $ \hsc_env ->
 778   case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
 779         Nothing       -> panic "missing linkable"
 780         Just mod_info -> return (not obj_linkable)
 781                       where
 782                          obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
 783
 784 obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term
 785 obtainTerm1 sess force mb_ty x = withSession sess $ \hsc_env -> cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x)
 786
 787 obtainTerm :: Session -> Bool -> Id -> IO Term
 788 obtainTerm sess force id = withSession sess $ \hsc_env -> do
 789               hv <- Linker.getHValue hsc_env (varName id)
 790               cvObtainTerm hsc_env force (Just$ idType id) hv
 791
 792 #endif /* GHCI */