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