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       _:rs  -> do
 526          writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = rs } }
 527          return True
 528
 529 abandonAll :: Session -> IO Bool
 530 abandonAll (Session ref) = do
 531    hsc_env <- readIORef ref
 532    let ic = hsc_IC hsc_env
 533        resume = ic_resume ic
 534    case resume of
 535       []    -> return False
 536       _:rs  -> do
 537          writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = [] } }
 538          return True
 539
 540 -- -----------------------------------------------------------------------------
 541 -- Bounded list, optimised for repeated cons
 542
 543 data BoundedList a = BL
 544                         {-# UNPACK #-} !Int  -- length
 545                         {-# UNPACK #-} !Int  -- bound
 546                         [a] -- left
 547                         [a] -- right,  list is (left ++ reverse right)
 548
 549 nilBL :: Int -> BoundedList a
 550 nilBL bound = BL 0 bound [] []
 551
 552 consBL a (BL len bound left right)
 553   | len < bound = BL (len+1) bound (a:left) right
 554   | null right  = BL len     bound [a]      $! tail (reverse left)
 555   | otherwise   = BL len     bound (a:left) $! tail right
 556
 557 toListBL (BL _ _ left right) = left ++ reverse right
 558
 559 -- lenBL (BL len _ _ _) = len
 560
 561 -- -----------------------------------------------------------------------------
 562 -- | Set the interactive evaluation context.
 563 --
 564 -- Setting the context doesn't throw away any bindings; the bindings
 565 -- we've built up in the InteractiveContext simply move to the new
 566 -- module.  They always shadow anything in scope in the current context.
 567 setContext :: Session
 568            -> [Module]  -- entire top level scope of these modules
 569            -> [Module]  -- exports only of these modules
 570            -> IO ()
 571 setContext sess@(Session ref) toplev_mods export_mods = do
 572   hsc_env <- readIORef ref
 573   let old_ic  = hsc_IC     hsc_env
 574       hpt     = hsc_HPT    hsc_env
 575   --
 576   export_env  <- mkExportEnv hsc_env export_mods
 577   toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods
 578   let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
 579   writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
 580                                             ic_exports      = export_mods,
 581                                             ic_rn_gbl_env   = all_env }}
 582
 583 -- Make a GlobalRdrEnv based on the exports of the modules only.
 584 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
 585 mkExportEnv hsc_env mods = do
 586   stuff <- mapM (getModuleExports hsc_env) mods
 587   let
 588         (_msgs, mb_name_sets) = unzip stuff
 589         gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod)
 590                | (Just avails, mod) <- zip mb_name_sets mods ]
 591   --
 592   return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
 593
 594 nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
 595 nameSetToGlobalRdrEnv names mod =
 596   mkGlobalRdrEnv [ GRE  { gre_name = name, gre_prov = vanillaProv mod }
 597                  | name <- nameSetToList names ]
 598
 599 vanillaProv :: ModuleName -> Provenance
 600 -- We're building a GlobalRdrEnv as if the user imported
 601 -- all the specified modules into the global interactive module
 602 vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
 603   where
 604     decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
 605                          is_qual = False,
 606                          is_dloc = srcLocSpan interactiveSrcLoc }
 607
 608 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
 609 mkTopLevEnv hpt modl
 610   = case lookupUFM hpt (moduleName modl) of
 611       Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++
 612                                                 showSDoc (ppr modl)))
 613       Just details ->
 614          case mi_globals (hm_iface details) of
 615                 Nothing  ->
 616                    throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
 617                                                 ++ showSDoc (ppr modl)))
 618                 Just env -> return env
 619
 620 -- | Get the interactive evaluation context, consisting of a pair of the
 621 -- set of modules from which we take the full top-level scope, and the set
 622 -- of modules from which we take just the exports respectively.
 623 getContext :: Session -> IO ([Module],[Module])
 624 getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
 625                                 return (ic_toplev_scope ic, ic_exports ic))
 626
 627 -- | Returns 'True' if the specified module is interpreted, and hence has
 628 -- its full top-level scope available.
 629 moduleIsInterpreted :: Session -> Module -> IO Bool
 630 moduleIsInterpreted s modl = withSession s $ \h ->
 631  if modulePackageId modl /= thisPackage (hsc_dflags h)
 632         then return False
 633         else case lookupUFM (hsc_HPT h) (moduleName modl) of
 634                 Just details       -> return (isJust (mi_globals (hm_iface details)))
 635                 _not_a_home_module -> return False
 636
 637 -- | Looks up an identifier in the current interactive context (for :info)
 638 getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
 639 getInfo s name = withSession s $ \hsc_env -> tcRnGetInfo hsc_env name
 640
 641 -- | Returns all names in scope in the current interactive context
 642 getNamesInScope :: Session -> IO [Name]
 643 getNamesInScope s = withSession s $ \hsc_env -> do
 644   return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
 645
 646 getRdrNamesInScope :: Session -> IO [RdrName]
 647 getRdrNamesInScope  s = withSession s $ \hsc_env -> do
 648   let
 649       ic = hsc_IC hsc_env
 650       gbl_rdrenv = ic_rn_gbl_env ic
 651       ids = ic_tmp_ids ic
 652       gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv))
 653       lcl_names = map (mkRdrUnqual.nameOccName.idName) ids
 654   --
 655   return (gbl_names ++ lcl_names)
 656
 657
 658 -- ToDo: move to RdrName
 659 greToRdrNames :: GlobalRdrElt -> [RdrName]
 660 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
 661   = case prov of
 662      LocalDef -> [unqual]
 663      Imported specs -> concat (map do_spec (map is_decl specs))
 664   where
 665     occ = nameOccName name
 666     unqual = Unqual occ
 667     do_spec decl_spec
 668         | is_qual decl_spec = [qual]
 669         | otherwise         = [unqual,qual]
 670         where qual = Qual (is_as decl_spec) occ
 671
 672 -- | Parses a string as an identifier, and returns the list of 'Name's that
 673 -- the identifier can refer to in the current interactive context.
 674 parseName :: Session -> String -> IO [Name]
 675 parseName s str = withSession s $ \hsc_env -> do
 676    maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
 677    case maybe_rdr_name of
 678         Nothing -> return []
 679         Just (L _ rdr_name) -> do
 680             mb_names <- tcRnLookupRdrName hsc_env rdr_name
 681             case mb_names of
 682                 Nothing -> return []
 683                 Just ns -> return ns
 684                 -- ToDo: should return error messages
 685
 686 -- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any
 687 -- entity known to GHC, including 'Name's defined using 'runStmt'.
 688 lookupName :: Session -> Name -> IO (Maybe TyThing)
 689 lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name
 690
 691 -- -----------------------------------------------------------------------------
 692 -- Getting the type of an expression
 693
 694 -- | Get the type of an expression
 695 exprType :: Session -> String -> IO (Maybe Type)
 696 exprType s expr = withSession s $ \hsc_env -> do
 697    maybe_stuff <- hscTcExpr hsc_env expr
 698    case maybe_stuff of
 699         Nothing -> return Nothing
 700         Just ty -> return (Just tidy_ty)
 701              where
 702                 tidy_ty = tidyType emptyTidyEnv ty
 703
 704 -- -----------------------------------------------------------------------------
 705 -- Getting the kind of a type
 706
 707 -- | Get the kind of a  type
 708 typeKind  :: Session -> String -> IO (Maybe Kind)
 709 typeKind s str = withSession s $ \hsc_env -> do
 710    maybe_stuff <- hscKcType hsc_env str
 711    case maybe_stuff of
 712         Nothing -> return Nothing
 713         Just kind -> return (Just kind)
 714
 715 -----------------------------------------------------------------------------
 716 -- cmCompileExpr: compile an expression and deliver an HValue
 717
 718 compileExpr :: Session -> String -> IO (Maybe HValue)
 719 compileExpr s expr = withSession s $ \hsc_env -> do
 720   maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
 721   case maybe_stuff of
 722         Nothing -> return Nothing
 723         Just (ids, hval) -> do
 724                         -- Run it!
 725                 hvals <- (unsafeCoerce# hval) :: IO [HValue]
 726
 727                 case (ids,hvals) of
 728                   ([n],[hv]) -> return (Just hv)
 729                   _          -> panic "compileExpr"
 730
 731 -- -----------------------------------------------------------------------------
 732 -- Compile an expression into a dynamic
 733
 734 dynCompileExpr :: Session -> String -> IO (Maybe Dynamic)
 735 dynCompileExpr ses expr = do
 736     (full,exports) <- getContext ses
 737     setContext ses full $
 738         (mkModule
 739             (stringToPackageId "base") (mkModuleName "Data.Dynamic")
 740         ):exports
 741     let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
 742     res <- withSession ses (flip hscStmt stmt)
 743     setContext ses full exports
 744     case res of
 745         Nothing -> return Nothing
 746         Just (ids, hvals) -> do
 747             vals <- (unsafeCoerce# hvals :: IO [Dynamic])
 748             case (ids,vals) of
 749                 (_:[], v:[])    -> return (Just v)
 750                 _               -> panic "dynCompileExpr"
 751
 752 -----------------------------------------------------------------------------
 753 -- show a module and it's source/object filenames
 754
 755 showModule :: Session -> ModSummary -> IO String
 756 showModule s mod_summary = withSession s $                        \hsc_env ->
 757                            isModuleInterpreted s mod_summary >>=  \interpreted ->
 758                            return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
 759
 760 isModuleInterpreted :: Session -> ModSummary -> IO Bool
 761 isModuleInterpreted s mod_summary = withSession s $ \hsc_env ->
 762   case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
 763         Nothing       -> panic "missing linkable"
 764         Just mod_info -> return (not obj_linkable)
 765                       where
 766                          obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
 767
 768 obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term
 769 obtainTerm1 sess force mb_ty x = withSession sess $ \hsc_env -> cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x)
 770
 771 obtainTerm :: Session -> Bool -> Id -> IO (Maybe Term)
 772 obtainTerm sess force id = withSession sess $ \hsc_env -> do
 773               mb_v <- Linker.getHValue (varName id)
 774               case mb_v of
 775                 Just v  -> fmap Just$ cvObtainTerm hsc_env force (Just$ idType id) v
 776                 Nothing -> return Nothing
 777
 778 #endif /* GHCI */