InteractiveEval.hs 39.7 KB
Newer Older
1
{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, UnboxedTuples,
2
    RecordWildCards, BangPatterns #-}
3

4 5 6 7 8 9 10 11 12
-- -----------------------------------------------------------------------------
--
-- (c) The University of Glasgow, 2005-2007
--
-- Running statements interactively
--
-- -----------------------------------------------------------------------------

module InteractiveEval (
13
        Resume(..), History(..),
14 15
        execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..), resumeExec,
        runDecls, runDeclsWithLocation, runParsedDecls,
16
        isStmt, hasImport, isImport, isDecl,
vivian's avatar
vivian committed
17
        parseImportDecl, SingleStep(..),
18 19
        abandon, abandonAll,
        getResumeContext,
20
        getHistorySpan,
21
        getModBreaks,
22
        getHistoryModule,
23
        back, forward,
dterei's avatar
dterei committed
24
        setContext, getContext,
25
        availsToGlobalRdrEnv,
dterei's avatar
dterei committed
26 27 28 29 30 31 32
        getNamesInScope,
        getRdrNamesInScope,
        moduleIsInterpreted,
        getInfo,
        exprType,
        typeKind,
        parseName,
33 34
        getDocs,
        GetDocsFailure(..),
dterei's avatar
dterei committed
35
        showModule,
36
        moduleIsBootOrNotObjectLinkable,
37
        parseExpr, compileParsedExpr,
dterei's avatar
dterei committed
38
        compileExpr, dynCompileExpr,
39
        compileExprRemote, compileParsedExprRemote,
40
        Term(..), obtainTermFromId, obtainTermFromVal, reconstructType
41 42
        ) where

Ian Lynagh's avatar
Ian Lynagh committed
43 44
#include "HsVersions.h"

45 46
import GhcPrelude

47 48
import InteractiveEvalTypes

49
import GHCi
50
import GHCi.Message
51
import GHCi.RemoteTypes
52 53
import GhcMonad
import HscMain
54
import HsSyn
55 56
import HscTypes
import InstEnv
57
import IfaceEnv   ( newInteractiveBinder )
Simon Peyton Jones's avatar
Simon Peyton Jones committed
58 59
import FamInstEnv ( FamInst )
import CoreFVs    ( orphNamesOfFamInst )
60
import TyCon
61 62
import Type             hiding( typeKind )
import RepType
Simon Peyton Jones's avatar
Simon Peyton Jones committed
63
import TcType
64
import Var
65 66 67
import Id
import Name             hiding ( varName )
import NameSet
68
import Avail
69 70
import RdrName
import VarEnv
71
import ByteCodeTypes
72 73 74
import Linker
import DynFlags
import Unique
75
import UniqSupply
76
import MonadUtils
77
import Module
78
import PrelNames  ( toDynName, pretendNameIsInScope )
79
import TysWiredIn ( isCTupleTyConName )
80 81
import Panic
import Maybes
82
import ErrUtils
83 84 85
import SrcLoc
import RtClosureInspect
import Outputable
86
import FastString
87
import Bag
88
import Util
89
import qualified Lexer (P (..), ParseResult(..), unP, mkPState)
90
import qualified Parser (parseStmt, parseModule, parseDeclaration, parseImport)
91

92
import System.Directory
93
import Data.Dynamic
94
import Data.Either
95
import qualified Data.IntMap as IntMap
96
import Data.List (find,intercalate)
97 98
import Data.Map (Map)
import qualified Data.Map as Map
99
import StringBuffer (stringToStringBuffer)
100 101 102
import Control.Monad
import GHC.Exts
import Data.Array
103
import Exception
104 105 106 107

-- -----------------------------------------------------------------------------
-- running a statement interactively

108 109
getResumeContext :: GhcMonad m => m [Resume]
getResumeContext = withSession (return . ic_resume . hsc_IC)
110

111
mkHistory :: HscEnv -> ForeignHValue -> BreakInfo -> History
112
mkHistory hsc_env hval bi = History hval bi (findEnclosingDecls hsc_env bi)
113 114

getHistoryModule :: History -> Module
115 116
getHistoryModule = breakInfo_module . historyBreakInfo

117
getHistorySpan :: HscEnv -> History -> SrcSpan
118 119
getHistorySpan hsc_env History{..} =
  let BreakInfo{..} = historyBreakInfo in
niteria's avatar
niteria committed
120
  case lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module) of
121 122
    Just hmi -> modBreaks_locs (getModBreaks hmi) ! breakInfo_number
    _ -> panic "getHistorySpan"
123

124 125
getModBreaks :: HomeModInfo -> ModBreaks
getModBreaks hmi
126
  | Just linkable <- hm_linkable hmi,
127
    [BCOs cbc _] <- linkableUnlinked linkable
128
  = fromMaybe emptyModBreaks (bc_breaks cbc)
129 130 131
  | otherwise
  = emptyModBreaks -- probably object code

Simon Marlow's avatar
Simon Marlow committed
132 133 134 135
{- | Finds the enclosing top level function name -}
-- ToDo: a better way to do this would be to keep hold of the decl_path computed
-- by the coverage pass, which gives the list of lexically-enclosing bindings
-- for each tick.
Ian Lynagh's avatar
Ian Lynagh committed
136
findEnclosingDecls :: HscEnv -> BreakInfo -> [String]
137
findEnclosingDecls hsc_env (BreakInfo modl ix) =
Ian Lynagh's avatar
Ian Lynagh committed
138
   let hmi = expectJust "findEnclosingDecls" $
niteria's avatar
niteria committed
139
             lookupHpt (hsc_HPT hsc_env) (moduleName modl)
140
       mb = getModBreaks hmi
141
   in modBreaks_decls mb ! ix
142

143 144 145 146 147 148
-- | Update fixity environment in the current interactive context.
updateFixityEnv :: GhcMonad m => FixityEnv -> m ()
updateFixityEnv fix_env = do
  hsc_env <- getSession
  let ic = hsc_IC hsc_env
  setSession $ hsc_env { hsc_IC = ic { ic_fix_env = fix_env } }
149

150 151 152 153 154 155 156 157 158
-- -----------------------------------------------------------------------------
-- execStmt

-- | default ExecOptions
execOptions :: ExecOptions
execOptions = ExecOptions
  { execSingleStep = RunToCompletion
  , execSourceFile = "<interactive>"
  , execLineNumber = 1
159
  , execWrap = EvalThis -- just run the statement, don't wrap it in anything
160 161 162 163 164 165 166 167
  }

-- | Run a statement in the current interactive context.
execStmt
  :: GhcMonad m
  => String             -- ^ a statement (bind or expression)
  -> ExecOptions
  -> m ExecResult
168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185
execStmt input exec_opts@ExecOptions{..} = do
    hsc_env <- getSession

    mb_stmt <-
      liftIO $
      runInteractiveHsc hsc_env $
      hscParseStmtWithLocation execSourceFile execLineNumber input

    case mb_stmt of
      -- empty statement / comment
      Nothing -> return (ExecComplete (Right []) 0)
      Just stmt -> execStmt' stmt input exec_opts

-- | Like `execStmt`, but takes a parsed statement as argument. Useful when
-- doing preprocessing on the AST before execution, e.g. in GHCi (see
-- GHCi.UI.runStmt).
execStmt' :: GhcMonad m => GhciLStmt GhcPs -> String -> ExecOptions -> m ExecResult
execStmt' stmt stmt_text ExecOptions{..} = do
186 187
    hsc_env <- getSession

188
    -- Turn off -fwarn-unused-local-binds when running a statement, to hide
189
    -- warnings about the implicit bindings we introduce.
190 191
    -- (This is basically `mkInteractiveHscEnv hsc_env`, except we unset
    -- -wwarn-unused-local-binds)
192
    let ic       = hsc_IC hsc_env -- use the interactive dflags
193
        idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedLocalBinds
194
        hsc_env' = mkInteractiveHscEnv (hsc_env{ hsc_IC = ic{ ic_dflags = idflags' } })
195

196
    r <- liftIO $ hscParsedStmt hsc_env' stmt
197 198

    case r of
199 200 201
      Nothing ->
        -- empty statement / comment
        return (ExecComplete (Right []) 0)
202
      Just (ids, hval, fix_env) -> do
203 204
        updateFixityEnv fix_env

205
        status <-
206
          withVirtualCWD $
207 208
            liftIO $
              evalStmt hsc_env' (isStep execSingleStep) (execWrap hval)
dterei's avatar
dterei committed
209

210
        let ic = hsc_IC hsc_env
211
            bindings = (ic_tythings ic, ic_rn_gbl_env ic)
212

213 214
            size = ghciHistSize idflags'

215
        handleRunStatus execSingleStep stmt_text bindings ids
216
                        status (emptyHistory size)
217

218 219 220
runDecls :: GhcMonad m => String -> m [Name]
runDecls = runDeclsWithLocation "<interactive>" 1

Ben Gamari's avatar
Ben Gamari committed
221 222 223
-- | Run some declarations and return any user-visible names that were brought
-- into scope.
runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name]
224 225 226 227 228 229 230 231 232 233
runDeclsWithLocation source line_num input = do
    hsc_env <- getSession
    decls <- liftIO (hscParseDeclsWithLocation hsc_env source line_num input)
    runParsedDecls decls

-- | Like `runDeclsWithLocation`, but takes parsed declarations as argument.
-- Useful when doing preprocessing on the AST before execution, e.g. in GHCi
-- (see GHCi.UI.runStmt).
runParsedDecls :: GhcMonad m => [LHsDecl GhcPs] -> m [Name]
runParsedDecls decls = do
234
    hsc_env <- getSession
235
    (tyThings, ic) <- liftIO (hscParsedDecls hsc_env decls)
dterei's avatar
dterei committed
236

237 238 239
    setSession $ hsc_env { hsc_IC = ic }
    hsc_env <- getSession
    hsc_env' <- liftIO $ rttiEnvironment hsc_env
240
    setSession hsc_env'
Ben Gamari's avatar
Ben Gamari committed
241
    return $ filter (not . isDerivedOccName . nameOccName)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
242
             -- For this filter, see Note [What to show to users]
Ben Gamari's avatar
Ben Gamari committed
243
           $ map getName tyThings
244

Simon Peyton Jones's avatar
Simon Peyton Jones committed
245 246 247 248
{- Note [What to show to users]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We don't want to display internally-generated bindings to users.
Things like the coercion axiom for newtypes. These bindings all get
Gabor Greif's avatar
Gabor Greif committed
249
OccNames that users can't write, to avoid the possibility of name
Simon Peyton Jones's avatar
Simon Peyton Jones committed
250 251 252 253
clashes (in linker symbols).  That gives a convenient way to suppress
them. The relevant predicate is OccName.isDerivedOccName.
See Trac #11051 for more background and examples.
-}
254

255 256 257 258
withVirtualCWD :: GhcMonad m => m a -> m a
withVirtualCWD m = do
  hsc_env <- getSession

259 260 261 262 263
    -- a virtual CWD is only necessary when we're running interpreted code in
    -- the same process as the compiler.
  if gopt Opt_ExternalInterpreter (hsc_dflags hsc_env) then m else do

  let ic = hsc_IC hsc_env
264 265
  let set_cwd = do
        dir <- liftIO $ getCurrentDirectory
dterei's avatar
dterei committed
266
        case ic_cwd ic of
267 268 269 270 271 272 273 274 275 276 277 278 279
           Just dir -> liftIO $ setCurrentDirectory dir
           Nothing  -> return ()
        return dir

      reset_cwd orig_dir = do
        virt_dir <- liftIO $ getCurrentDirectory
        hsc_env <- getSession
        let old_IC = hsc_IC hsc_env
        setSession hsc_env{  hsc_IC = old_IC{ ic_cwd = Just virt_dir } }
        liftIO $ setCurrentDirectory orig_dir

  gbracket set_cwd reset_cwd $ \_ -> m

280
parseImportDecl :: GhcMonad m => String -> m (ImportDecl GhcPs)
281
parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr
282

283 284
emptyHistory :: Int -> BoundedList History
emptyHistory size = nilBL size
285

286 287
handleRunStatus :: GhcMonad m
                => SingleStep -> String-> ([TyThing],GlobalRdrEnv) -> [Id]
288 289
                -> EvalStatus_ [ForeignHValue] [HValueRef]
                -> BoundedList History
290
                -> m ExecResult
291

292
handleRunStatus step expr bindings final_ids status history
293 294 295 296
  | RunAndLogSteps <- step = tracing
  | otherwise              = not_tracing
 where
  tracing
297
    | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt _ccs <- status
298 299 300
    , not is_exception
    = do
       hsc_env <- getSession
301
       let hmi = expectJust "handleRunStatus" $
niteria's avatar
niteria committed
302 303
                   lookupHptDirectly (hsc_HPT hsc_env)
                                     (mkUniqueGrimily mod_uniq)
304 305 306 307 308
           modl = mi_module (hm_iface hmi)
           breaks = getModBreaks hmi

       b <- liftIO $
              breakpointStatus hsc_env (modBreaks_flags breaks) ix
309 310 311 312 313
       if b
         then not_tracing
           -- This breakpoint is explicitly enabled; we want to stop
           -- instead of just logging it.
         else do
314
           apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref
315 316 317
           let bi = BreakInfo modl ix
               !history' = mkHistory hsc_env apStack_fhv bi `consBL` history
                 -- history is strict, otherwise our BoundedList is pointless.
318 319
           fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt
           status <- liftIO $ GHCi.resumeStmt hsc_env True fhv
320
           handleRunStatus RunAndLogSteps expr bindings final_ids
321
                           status history'
322 323 324 325 326
    | otherwise
    = not_tracing

  not_tracing
    -- Hit a breakpoint
327
    | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt ccs <- status
328 329
    = do
         hsc_env <- getSession
330 331
         resume_ctxt_fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt
         apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref
332
         let hmi = expectJust "handleRunStatus" $
niteria's avatar
niteria committed
333 334
                     lookupHptDirectly (hsc_HPT hsc_env)
                                       (mkUniqueGrimily mod_uniq)
335 336 337
             modl = mi_module (hm_iface hmi)
             bp | is_exception = Nothing
                | otherwise = Just (BreakInfo modl ix)
338
         (hsc_env1, names, span, decl) <- liftIO $
339
           bindLocalsAtBreakpoint hsc_env apStack_fhv bp
340 341
         let
           resume = Resume
342
             { resumeStmt = expr, resumeContext = resume_ctxt_fhv
343
             , resumeBindings = bindings, resumeFinalIds = final_ids
344 345
             , resumeApStack = apStack_fhv
             , resumeBreakInfo = bp
346
             , resumeSpan = span, resumeHistory = toListBL history
347 348
             , resumeDecl = decl
             , resumeCCS = ccs
349 350
             , resumeHistoryIx = 0 }
           hsc_env2 = pushResume hsc_env1 resume
Simon Peyton Jones's avatar
Simon Peyton Jones committed
351

352
         setSession hsc_env2
353
         return (ExecBreak names bp)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
354

355
    -- Completed successfully
356
    | EvalComplete allocs (EvalSuccess hvals) <- status
357
    = do hsc_env <- getSession
358
         let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids
359
             final_names = map getName final_ids
360 361
         liftIO $ Linker.extendLinkEnv (zip final_names hvals)
         hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
362
         setSession hsc_env'
363
         return (ExecComplete (Right final_names) allocs)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
364

365 366 367 368
    -- Completed with an exception
    | EvalComplete alloc (EvalException e) <- status
    = return (ExecComplete (Left (fromSerializableException e)) alloc)

369
    | otherwise
370
    = panic "not_tracing" -- actually exhaustive, but GHC can't tell
371

372

373 374
resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m ExecResult
resumeExec canLogSpan step
375
 = do
376
   hsc_env <- getSession
377 378 379 380
   let ic = hsc_IC hsc_env
       resume = ic_resume ic

   case resume of
381 382
     [] -> liftIO $
           throwGhcExceptionIO (ProgramError "not stopped at a breakpoint")
383 384 385 386
     (r:rs) -> do
        -- unbind the temporary locals by restoring the TypeEnv from
        -- before the breakpoint, and drop this Resume from the
        -- InteractiveContext.
387 388 389
        let (resume_tmp_te,resume_rdr_env) = resumeBindings r
            ic' = ic { ic_tythings = resume_tmp_te,
                       ic_rn_gbl_env = resume_rdr_env,
390
                       ic_resume   = rs }
391
        setSession hsc_env{ hsc_IC = ic' }
dterei's avatar
dterei committed
392 393

        -- remove any bindings created since the breakpoint from the
394
        -- linker's environment
395 396 397 398
        let old_names = map getName resume_tmp_te
            new_names = [ n | thing <- ic_tythings ic
                            , let n = getName thing
                            , not (n `elem` old_names) ]
399
        liftIO $ Linker.deleteFromLinkEnv new_names
dterei's avatar
dterei committed
400 401

        case r of
402
          Resume { resumeStmt = expr, resumeContext = fhv
403
                 , resumeBindings = bindings, resumeFinalIds = final_ids
404
                 , resumeApStack = apStack, resumeBreakInfo = mb_brkpt
405
                 , resumeSpan = span
406
                 , resumeHistory = hist } -> do
407
               withVirtualCWD $ do
408
                status <- liftIO $ GHCi.resumeStmt hsc_env (isStep step) fhv
409
                let prevHistoryLst = fromListBL 50 hist
410
                    hist' = case mb_brkpt of
411
                       Nothing -> prevHistoryLst
412
                       Just bi
413
                         | not $canLogSpan span -> prevHistoryLst
414
                         | otherwise -> mkHistory hsc_env apStack bi `consBL`
415
                                                        fromListBL 50 hist
416
                handleRunStatus step expr bindings final_ids status hist'
417

418
back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)
419
back n = moveHist (+n)
420

421
forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)
422
forward n = moveHist (subtract n)
423

424
moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan, String)
425 426
moveHist fn = do
  hsc_env <- getSession
427
  case ic_resume (hsc_IC hsc_env) of
428 429
     [] -> liftIO $
           throwGhcExceptionIO (ProgramError "not stopped at a breakpoint")
430 431 432 433 434
     (r:rs) -> do
        let ix = resumeHistoryIx r
            history = resumeHistory r
            new_ix = fn ix
        --
435
        when (history `lengthLessThan` new_ix) $ liftIO $
436 437 438
           throwGhcExceptionIO (ProgramError "no more logged breakpoints")
        when (new_ix < 0) $ liftIO $
           throwGhcExceptionIO (ProgramError "already at the beginning of the history")
439 440

        let
441
          update_ic apStack mb_info = do
442 443
            (hsc_env1, names, span, decl) <-
              liftIO $ bindLocalsAtBreakpoint hsc_env apStack mb_info
dterei's avatar
dterei committed
444
            let ic = hsc_IC hsc_env1
445 446
                r' = r { resumeHistoryIx = new_ix }
                ic' = ic { ic_resume = r':rs }
dterei's avatar
dterei committed
447

448
            setSession hsc_env1{ hsc_IC = ic' }
dterei's avatar
dterei committed
449

450
            return (names, new_ix, span, decl)
451 452 453 454 455

        -- careful: we want apStack to be the AP_STACK itself, not a thunk
        -- around it, hence the cases are carefully constructed below to
        -- make this the case.  ToDo: this is v. fragile, do something better.
        if new_ix == 0
dterei's avatar
dterei committed
456 457
           then case r of
                   Resume { resumeApStack = apStack,
458 459
                            resumeBreakInfo = mb_brkpt } ->
                          update_ic apStack mb_brkpt
dterei's avatar
dterei committed
460
           else case history !! (new_ix - 1) of
461 462 463
                   History{..} ->
                     update_ic historyApStack (Just historyBreakInfo)

464 465 466

-- -----------------------------------------------------------------------------
-- After stopping at a breakpoint, add free variables to the environment
467

468
result_fs :: FastString
469
result_fs = fsLit "_result"
470

471 472
bindLocalsAtBreakpoint
        :: HscEnv
473
        -> ForeignHValue
474
        -> Maybe BreakInfo
475
        -> IO (HscEnv, [Name], SrcSpan, String)
476 477 478 479 480 481

-- Nothing case: we stopped when an exception was raised, not at a
-- breakpoint.  We have no location information or local variables to
-- bind, all we can do is bind a local variable to the exception
-- value.
bindLocalsAtBreakpoint hsc_env apStack Nothing = do
482
   let exn_occ = mkVarOccFS (fsLit "_exception")
483
       span    = mkGeneralSrcSpan (fsLit "<unknown>")
484 485 486 487 488 489
   exn_name <- newInteractiveBinder hsc_env exn_occ span

   let e_fs    = fsLit "e"
       e_name  = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
       e_tyvar = mkRuntimeUnkTyVar e_name liftedTypeKind
       exn_id  = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
490 491

       ictxt0 = hsc_IC hsc_env
492
       ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id]
493
   --
494
   Linker.extendLinkEnv [(exn_name, apStack)]
495
   return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "<exception thrown>")
496 497 498

-- Just case: we stopped at a breakpoint, we have information about the location
-- of the breakpoint and the free variables of the expression.
499
bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
dterei's avatar
dterei committed
500 501
   let
       hmi       = expectJust "bindLocalsAtBreakpoint" $
niteria's avatar
niteria committed
502
                     lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module)
503
       breaks    = getModBreaks hmi
504 505 506 507 508 509 510
       info      = expectJust "bindLocalsAtBreakpoint2" $
                     IntMap.lookup breakInfo_number (modBreaks_breakInfo breaks)
       vars      = cgb_vars info
       result_ty = cgb_resty info
       occs      = modBreaks_vars breaks ! breakInfo_number
       span      = modBreaks_locs breaks ! breakInfo_number
       decl      = intercalate "." $ modBreaks_decls breaks ! breakInfo_number
511

512 513 514
           -- Filter out any unboxed ids;
           -- we can't bind these at the prompt
       pointers = filter (\(id,_) -> isPointer id) vars
515 516 517
       isPointer id | [rep] <- typePrimRep (idType id)
                    , isGcPtrRep rep                   = True
                    | otherwise                        = False
518

519 520
       (ids, offsets) = unzip pointers

niteria's avatar
niteria committed
521
       free_tvs = tyCoVarsOfTypesList (result_ty:map idType ids)
522 523 524 525 526

   -- It might be that getIdValFromApStack fails, because the AP_STACK
   -- has been accidentally evaluated, or something else has gone wrong.
   -- So that we don't fall over in a heap when this happens, just don't
   -- bind any free variables instead, and we emit a warning.
527 528
   mb_hValues <-
      mapM (getBreakpointVar hsc_env apStack_fhv . fromIntegral) offsets
529 530
   when (any isNothing mb_hValues) $
      debugTraceMsg (hsc_dflags hsc_env) 1 $
dterei's avatar
dterei committed
531
          text "Warning: _result has been evaluated, some bindings have been lost"
532

533 534 535 536
   us <- mkSplitUniqSupply 'I'   -- Dodgy; will give the same uniques every time
   let tv_subst     = newTyVars us free_tvs
       filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
       (_,tidy_tys) = tidyOpenTypes emptyTidyEnv $
537
                      map (substTy tv_subst . idType) filtered_ids
538 539 540 541

   new_ids     <- zipWith3M mkNewId occs tidy_tys filtered_ids
   result_name <- newInteractiveBinder hsc_env (mkVarOccFS result_fs) span

542
   let result_id = Id.mkVanillaGlobal result_name
543
                     (substTy tv_subst result_ty)
544 545 546 547
       result_ok = isPointer result_id

       final_ids | result_ok = result_id : new_ids
                 | otherwise = new_ids
548
       ictxt0 = hsc_IC hsc_env
549
       ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids
550
       names  = map idName new_ids
551

552
   let fhvs = catMaybes mb_hValues
553 554
   Linker.extendLinkEnv (zip names fhvs)
   when result_ok $ Linker.extendLinkEnv [(result_name, apStack_fhv)]
555
   hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
556
   return (hsc_env1, if result_ok then result_name:names else names, span, decl)
557
  where
558
        -- We need a fresh Unique for each Id we bind, because the linker
559 560 561
        -- state is single-threaded and otherwise we'd spam old bindings
        -- whenever we stop at a breakpoint.  The InteractveContext is properly
        -- saved/restored, but not the linker state.  See #1743, test break026.
562 563 564 565
   mkNewId :: OccName -> Type -> Id -> IO Id
   mkNewId occ ty old_id
     = do { name <- newInteractiveBinder hsc_env occ (getSrcSpan old_id)
          ; return (Id.mkVanillaGlobalWithInfo name ty (idInfo old_id)) }
566

niteria's avatar
niteria committed
567
   newTyVars :: UniqSupply -> [TcTyVar] -> TCvSubst
568
     -- Similarly, clone the type variables mentioned in the types
niteria's avatar
niteria committed
569
     -- we have here, *and* make them all RuntimeUnk tyvars
570
   newTyVars us tvs
niteria's avatar
niteria committed
571
     = mkTvSubstPrs [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv)))
niteria's avatar
niteria committed
572
                    | (tv, uniq) <- tvs `zip` uniqsFromSupply us
niteria's avatar
niteria committed
573
                    , let name = setNameUnique (tyVarName tv) uniq ]
574

dterei's avatar
dterei committed
575
rttiEnvironment :: HscEnv -> IO HscEnv
576
rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
577
   let tmp_ids = [id | AnId id <- ic_tythings ic]
dterei's avatar
dterei committed
578
       incompletelyTypedIds =
579
           [id | id <- tmp_ids
pepe's avatar
pepe committed
580
               , not $ noSkolems id
581
               , (occNameFS.nameOccName.idName) id /= result_fs]
pepe's avatar
pepe committed
582 583 584
   hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
   return hsc_env'
    where
585
     noSkolems = noFreeVarsOfType . idType
pepe's avatar
pepe committed
586
     improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
587
      let tmp_ids = [id | AnId id <- ic_tythings ic]
pepe's avatar
pepe committed
588 589 590 591 592 593 594 595 596
          Just id = find (\i -> idName i == name) tmp_ids
      if noSkolems id
         then return hsc_env
         else do
           mb_new_ty <- reconstructType hsc_env 10 id
           let old_ty = idType id
           case mb_new_ty of
             Nothing -> return hsc_env
             Just new_ty -> do
597
              case improveRTTIType hsc_env old_ty new_ty of
pepe's avatar
pepe committed
598 599 600 601
               Nothing -> return $
                        WARN(True, text (":print failed to calculate the "
                                           ++ "improvement for a type")) hsc_env
               Just subst -> do
602
                 let dflags = hsc_dflags hsc_env
603 604 605
                 dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI"
                   (fsep [text "RTTI Improvement for", ppr id, equals,
                          ppr subst])
pepe's avatar
pepe committed
606

607
                 let ic' = substInteractiveContext ic subst
pepe's avatar
pepe committed
608 609
                 return hsc_env{hsc_IC=ic'}

610 611 612 613 614 615 616 617 618
pushResume :: HscEnv -> Resume -> HscEnv
pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
  where
        ictxt0 = hsc_IC hsc_env
        ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }

-- -----------------------------------------------------------------------------
-- Abandoning a resume context

619 620 621
abandon :: GhcMonad m => m Bool
abandon = do
   hsc_env <- getSession
622 623 624 625
   let ic = hsc_IC hsc_env
       resume = ic_resume ic
   case resume of
      []    -> return False
dterei's avatar
dterei committed
626
      r:rs  -> do
627
         setSession hsc_env{ hsc_IC = ic { ic_resume = rs } }
628
         liftIO $ abandonStmt hsc_env (resumeContext r)
629 630
         return True

631 632 633
abandonAll :: GhcMonad m => m Bool
abandonAll = do
   hsc_env <- getSession
634 635 636
   let ic = hsc_IC hsc_env
       resume = ic_resume ic
   case resume of
637
      []  -> return False
dterei's avatar
dterei committed
638
      rs  -> do
639
         setSession hsc_env{ hsc_IC = ic { ic_resume = [] } }
640
         liftIO $ mapM_ (abandonStmt hsc_env. resumeContext) rs
641 642 643 644 645 646 647 648 649 650 651
         return True

-- -----------------------------------------------------------------------------
-- Bounded list, optimised for repeated cons

data BoundedList a = BL
                        {-# UNPACK #-} !Int  -- length
                        {-# UNPACK #-} !Int  -- bound
                        [a] -- left
                        [a] -- right,  list is (left ++ reverse right)

652 653 654
nilBL :: Int -> BoundedList a
nilBL bound = BL 0 bound [] []

655
consBL :: a -> BoundedList a -> BoundedList a
656 657
consBL a (BL len bound left right)
  | len < bound = BL (len+1) bound (a:left) right
658 659
  | null right  = BL len     bound [a]      $! tail (reverse left)
  | otherwise   = BL len     bound (a:left) $! tail right
660

661
toListBL :: BoundedList a -> [a]
662 663
toListBL (BL _ _ left right) = left ++ reverse right

664
fromListBL :: Int -> [a] -> BoundedList a
665 666
fromListBL bound l = BL (length l) bound l []

667
-- lenBL (BL len _ _ _) = len
668 669 670 671

-- -----------------------------------------------------------------------------
-- | Set the interactive evaluation context.
--
Simon Peyton Jones's avatar
Simon Peyton Jones committed
672 673
-- (setContext imports) sets the ic_imports field (which in turn
-- determines what is in scope at the prompt) to 'imports', and
Gabor Greif's avatar
Gabor Greif committed
674
-- constructs the ic_rn_glb_env environment to reflect it.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
675 676 677 678
--
-- We retain in scope all the things defined at the prompt, and kept
-- in ic_tythings.  (Indeed, they shadow stuff from ic_imports.)

679 680 681
setContext :: GhcMonad m => [InteractiveImport] -> m ()
setContext imports
  = do { hsc_env <- getSession
Ian Lynagh's avatar
Ian Lynagh committed
682
       ; let dflags = hsc_dflags hsc_env
683 684
       ; all_env_err <- liftIO $ findGlobalRdrEnv hsc_env imports
       ; case all_env_err of
685 686
           Left (mod, err) ->
               liftIO $ throwGhcExceptionIO (formatError dflags mod err)
687
           Right all_env -> do {
688 689
       ; let old_ic         = hsc_IC hsc_env
             !final_rdr_env = all_env `icExtendGblRdrEnv` ic_tythings old_ic
690
       ; setSession
691
         hsc_env{ hsc_IC = old_ic { ic_imports    = imports
692 693
                                  , ic_rn_gbl_env = final_rdr_env }}}}
  where
Ian Lynagh's avatar
Ian Lynagh committed
694
    formatError dflags mod err = ProgramError . showSDoc dflags $
695 696
      text "Cannot add module" <+> ppr mod <+>
      text "to context:" <+> text err
697

698 699
findGlobalRdrEnv :: HscEnv -> [InteractiveImport]
                 -> IO (Either (ModuleName, String) GlobalRdrEnv)
700 701
-- Compute the GlobalRdrEnv for the interactive context
findGlobalRdrEnv hsc_env imports
702
  = do { idecls_env <- hscRnImportDecls hsc_env idecls
dterei's avatar
dterei committed
703
                    -- This call also loads any orphan modules
704 705
       ; return $ case partitionEithers (map mkEnv imods) of
           ([], imods_env) -> Right (foldr plusGlobalRdrEnv idecls_env imods_env)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
706
           (err : _, _)    -> Left err }
707
  where
708
    idecls :: [LImportDecl GhcPs]
709 710
    idecls = [noLoc d | IIDecl d <- imports]

711
    imods :: [ModuleName]
712 713
    imods = [m | IIModule m <- imports]

714 715 716 717
    mkEnv mod = case mkTopLevEnv (hsc_HPT hsc_env) mod of
      Left err -> Left (mod, err)
      Right env -> Right env

718 719
availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv
availsToGlobalRdrEnv mod_name avails
720
  = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) avails)
721
  where
722 723
      -- We're building a GlobalRdrEnv as if the user imported
      -- all the specified modules into the global interactive module
724
    imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll}
dterei's avatar
dterei committed
725 726 727
    decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
                         is_qual = False,
                         is_dloc = srcLocSpan interactiveSrcLoc }
728

729
mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv
730
mkTopLevEnv hpt modl
niteria's avatar
niteria committed
731
  = case lookupHpt hpt modl of
732
      Nothing -> Left "not a home module"
733
      Just details ->
dterei's avatar
dterei committed
734
         case mi_globals (hm_iface details) of
735 736
                Nothing  -> Left "not interpreted"
                Just env -> Right env
737 738 739 740

-- | Get the interactive evaluation context, consisting of a pair of the
-- set of modules from which we take the full top-level scope, and the set
-- of modules from which we take just the exports respectively.
741
getContext :: GhcMonad m => m [InteractiveImport]
742
getContext = withSession $ \HscEnv{ hsc_IC=ic } ->
743
             return (ic_imports ic)
744

745
-- | Returns @True@ if the specified module is interpreted, and hence has
746
-- its full top-level scope available.
747 748
moduleIsInterpreted :: GhcMonad m => Module -> m Bool
moduleIsInterpreted modl = withSession $ \h ->
749
 if moduleUnitId modl /= thisPackage (hsc_dflags h)
750
        then return False
niteria's avatar
niteria committed
751
        else case lookupHpt (hsc_HPT h) (moduleName modl) of
752 753 754 755
                Just details       -> return (isJust (mi_globals (hm_iface details)))
                _not_a_home_module -> return False

-- | Looks up an identifier in the current interactive context (for :info)
dterei's avatar
dterei committed
756
-- Filter the instances by the ones whose tycons (or clases resp)
757 758
-- are in scope (qualified or otherwise).  Otherwise we list a whole lot too many!
-- The exact choice of which ones to show, and which to hide, is a judgement call.
dterei's avatar
dterei committed
759
--      (see Trac #1581)
760 761
getInfo :: GhcMonad m => Bool -> Name
        -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst], SDoc))
762
getInfo allInfo name
763
  = withSession $ \hsc_env ->
764
    do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name
Thomas Schilling's avatar
Thomas Schilling committed
765 766
       case mb_stuff of
         Nothing -> return Nothing
767
         Just (thing, fixity, cls_insts, fam_insts, docs) -> do
Thomas Schilling's avatar
Thomas Schilling committed
768
           let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
769 770 771 772 773

           -- Filter the instances based on whether the constituent names of their
           -- instance heads are all in scope.
           let cls_insts' = filter (plausible rdr_env . orphNamesOfClsInst) cls_insts
               fam_insts' = filter (plausible rdr_env . orphNamesOfFamInst) fam_insts
774
           return (Just (thing, fixity, cls_insts', fam_insts', docs))
775
  where
776
    plausible rdr_env names
777 778
          -- Dfun involving only names that are in ic_rn_glb_env
        = allInfo
niteria's avatar
niteria committed
779
       || nameSetAll ok names
dterei's avatar
dterei committed
780 781
        where   -- A name is ok if it's in the rdr_env,
                -- whether qualified or not
782 783 784 785
          ok n | n == name              = True
                       -- The one we looked for in the first place!
               | pretendNameIsInScope n = True
               | isBuiltInSyntax n      = True
786
               | isCTupleTyConName n    = True
787
               | isExternalName n       = isJust (lookupGRE_Name rdr_env n)
788
               | otherwise              = True
789 790

-- | Returns all names in scope in the current interactive context
791 792
getNamesInScope :: GhcMonad m => m [Name]
getNamesInScope = withSession $ \hsc_env -> do
793 794
  return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))

795 796
-- | Returns all 'RdrName's in scope in the current interactive
-- context, excluding any that are internally-generated.
797 798
getRdrNamesInScope :: GhcMonad m => m [RdrName]
getRdrNamesInScope = withSession $ \hsc_env -> do
dterei's avatar
dterei committed
799
  let
800 801
      ic = hsc_IC hsc_env
      gbl_rdrenv = ic_rn_gbl_env ic
802
      gbl_names = concatMap greRdrNames $ globalRdrEnvElts gbl_rdrenv
803 804
  -- Exclude internally generated names; see e.g. Trac #11328
  return (filter (not . isDerivedOccName . rdrNameOcc) gbl_names)
805 806 807 808


-- | Parses a string as an identifier, and returns the list of 'Name's that
-- the identifier can refer to in the current interactive context.
809
parseName :: GhcMonad m => String -> m [Name]
810 811 812
parseName str = withSession $ \hsc_env -> liftIO $
   do { lrdr_name <- hscParseIdentifier hsc_env str
      ; hscTcRnLookupRdrName hsc_env lrdr_name }
813

814 815 816 817 818
-- | Returns @True@ if passed string is a statement.
isStmt :: DynFlags -> String -> Bool
isStmt dflags stmt =
  case parseThing Parser.parseStmt dflags stmt of
    Lexer.POk _ _ -> True
819
    Lexer.PFailed _ _ _ -> False
820

821 822 823
-- | Returns @True@ if passed string has an import declaration.
hasImport :: DynFlags -> String -> Bool
hasImport dflags stmt =
824 825
  case parseThing Parser.parseModule dflags stmt of
    Lexer.POk _ thing -> hasImports thing
826
    Lexer.PFailed _ _ _ -> False
827 828 829
  where
    hasImports = not . null . hsmodImports . unLoc

830 831 832 833 834
-- | Returns @True@ if passed string is an import declaration.
isImport :: DynFlags -> String -> Bool
isImport dflags stmt =
  case parseThing Parser.parseImport dflags stmt of
    Lexer.POk _ _ -> True
835
    Lexer.PFailed _ _ _ -> False
836

837 838 839 840 841 842
-- | Returns @True@ if passed string is a declaration but __/not a splice/__.
isDecl :: DynFlags -> String -> Bool
isDecl dflags stmt = do
  case parseThing Parser.parseDeclaration dflags stmt of
    Lexer.POk _ thing ->
      case unLoc thing of
843
        SpliceD _ _ -> False
844
        _ -> True
845
    Lexer.PFailed _ _ _ -> False
846 847 848 849 850 851 852 853

parseThing :: Lexer.P thing -> DynFlags -> String -> Lexer.ParseResult thing
parseThing parser dflags stmt = do
  let buf = stringToStringBuffer stmt
      loc = mkRealSrcLoc (fsLit "<interactive>") 1 1

  Lexer.unP parser (Lexer.mkPState dflags buf loc)

854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917
getDocs :: GhcMonad m
        => Name
        -> m (Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString))
           -- TODO: What about docs for constructors etc.?
getDocs name =
  withSession $ \hsc_env -> do
     case nameModule_maybe name of
       Nothing -> pure (Left (NameHasNoModule name))
       Just mod -> do
         if isInteractiveModule mod
           then pure (Left InteractiveName)
           else do
             ModIface { mi_doc_hdr = mb_doc_hdr
                      , mi_decl_docs = DeclDocMap dmap
                      , mi_arg_docs = ArgDocMap amap
                      } <- liftIO $ hscGetModuleInterface hsc_env mod
             if isNothing mb_doc_hdr && Map.null dmap && Map.null amap
               then pure (Left (NoDocsInIface mod compiled))
               else pure (Right ( Map.lookup name dmap
                                , Map.findWithDefault Map.empty name amap))
  where
    compiled =
      -- TODO: Find a more direct indicator.
      case nameSrcLoc name of
        RealSrcLoc {} -> False
        UnhelpfulLoc {} -> True

-- | Failure modes for 'getDocs'.

-- TODO: Find a way to differentiate between modules loaded without '-haddock'
-- and modules that contain no docs.
data GetDocsFailure

    -- | 'nameModule_maybe' returned 'Nothing'.
  = NameHasNoModule Name

    -- | This is probably because the module was loaded without @-haddock@,
    -- but it's also possible that the entire module contains no documentation.
  | NoDocsInIface
      Module
      Bool -- ^ 'True': The module was compiled.
           -- 'False': The module was :loaded.

    -- | The 'Name' was defined interactively.
  | InteractiveName

instance Outputable GetDocsFailure where
  ppr (NameHasNoModule name) =
    quotes (ppr name) <+> text "has no module where we could look for docs."
  ppr (NoDocsInIface mod compiled) = vcat
    [ text "Can't find any documentation for" <+> ppr mod <> char '.'
    , text "This is probably because the module was"
        <+> text (if compiled then "compiled" else "loaded")
        <+> text "without '-haddock',"
    , text "but it's also possible that the module contains no documentation."
    , text ""
    , if compiled
        then text "Try re-compiling with '-haddock'."
        else text "Try running ':set -haddock' and :load the file again."
        -- TODO: Figure out why :reload doesn't load the docs and maybe fix it.
    ]
  ppr InteractiveName =
    text "Docs are unavailable for interactive declarations."

918 919 920 921
-- -----------------------------------------------------------------------------
-- Getting the type of an expression

-- | Get the type of an expression
922 923 924 925
-- Returns the type as described by 'TcRnExprMode'
exprType :: GhcMonad m => TcRnExprMode -> String -> m Type
exprType mode expr = withSession $ \hsc_env -> do
   ty <- liftIO $ hscTcExpr hsc_env mode expr
926
   return $ tidyType emptyTidyEnv ty
927 928 929 930 931

-- -----------------------------------------------------------------------------
-- Getting the kind of a type

-- | Get the kind of a  type
932 933 934
typeKind  :: GhcMonad m => Bool -> String -> m (Type, Kind)
typeKind normalise str = withSession $ \hsc_env -> do
   liftIO $ hscKcType hsc_env normalise str
935 936

-----------------------------------------------------------------------------
Gabor Greif's avatar
Gabor Greif committed
937
-- Compile an expression, run it, and deliver the result
938

939 940
-- | Parse an expression, the parsed expression can be further processed and
-- passed to compileParsedExpr.
941
parseExpr :: GhcMonad m => String -> m (LHsExpr GhcPs)
942 943 944
parseExpr expr = withSession $ \hsc_env -> do
  liftIO $ runInteractiveHsc hsc_env $ hscParseExpr expr

Gabor Greif's avatar
Gabor Greif committed
945
-- | Compile an expression, run it, and deliver the re