-mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
-mkTopLevEnv hpt modl
- = case lookupModuleEnv hpt modl of
- Nothing ->
- throwDyn (ProgramError ("mkTopLevEnv: not a home module "
- ++ showSDoc (pprModule modl)))
- Just details ->
- case mi_globals (hm_iface details) of
- Nothing ->
- throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
- ++ showSDoc (pprModule modl)))
- Just env -> return env
-
--- | 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.
-getContext :: Session -> IO ([Module],[Module])
-getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
- return (ic_toplev_scope ic, ic_exports ic))
-
--- | Returns 'True' if the specified module is interpreted, and hence has
--- its full top-level scope available.
-moduleIsInterpreted :: Session -> Module -> IO Bool
-moduleIsInterpreted s modl = withSession s $ \h ->
- case lookupModuleEnv (hsc_HPT h) modl of
- 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)
-getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
-getInfo s name = withSession s $ \hsc_env -> tcRnGetInfo hsc_env name
-
--- | Returns all names in scope in the current interactive context
-getNamesInScope :: Session -> IO [Name]
-getNamesInScope s = withSession s $ \hsc_env -> do
- return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
-
-getRdrNamesInScope :: Session -> IO [RdrName]
-getRdrNamesInScope s = withSession s $ \hsc_env -> do
- let env = ic_rn_gbl_env (hsc_IC hsc_env)
- return (concat (map greToRdrNames (globalRdrEnvElts env)))
-
--- ToDo: move to RdrName
-greToRdrNames :: GlobalRdrElt -> [RdrName]
-greToRdrNames GRE{ gre_name = name, gre_prov = prov }
- = case prov of
- LocalDef -> [unqual]
- Imported specs -> concat (map do_spec (map is_decl specs))
- where
- occ = nameOccName name
- unqual = Unqual occ
- do_spec decl_spec
- | is_qual decl_spec = [qual]
- | otherwise = [unqual,qual]
- where qual = Qual (is_as decl_spec) occ
-
--- | Parses a string as an identifier, and returns the list of 'Name's that
--- the identifier can refer to in the current interactive context.
-parseName :: Session -> String -> IO [Name]
-parseName s str = withSession s $ \hsc_env -> do
- maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
- case maybe_rdr_name of
- Nothing -> return []
- Just (L _ rdr_name) -> do
- mb_names <- tcRnLookupRdrName hsc_env rdr_name
- case mb_names of
- Nothing -> return []
- Just ns -> return ns
- -- ToDo: should return error messages
-
--- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any
--- entity known to GHC, including 'Name's defined using 'runStmt'.
-lookupName :: Session -> Name -> IO (Maybe TyThing)
-lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name
-
--- -----------------------------------------------------------------------------
--- Getting the type of an expression
-
--- | Get the type of an expression
-exprType :: Session -> String -> IO (Maybe Type)
-exprType s expr = withSession s $ \hsc_env -> do
- maybe_stuff <- hscTcExpr hsc_env expr
- case maybe_stuff of
- Nothing -> return Nothing
- Just ty -> return (Just tidy_ty)
- where
- tidy_ty = tidyType emptyTidyEnv ty
-
--- -----------------------------------------------------------------------------
--- Getting the kind of a type
-
--- | Get the kind of a type
-typeKind :: Session -> String -> IO (Maybe Kind)
-typeKind s str = withSession s $ \hsc_env -> do
- maybe_stuff <- hscKcType hsc_env str
- case maybe_stuff of
- Nothing -> return Nothing
- Just kind -> return (Just kind)
-
------------------------------------------------------------------------------
--- cmCompileExpr: compile an expression and deliver an HValue
-
-compileExpr :: Session -> String -> IO (Maybe HValue)
-compileExpr s expr = withSession s $ \hsc_env -> do
- maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
- case maybe_stuff of
- Nothing -> return Nothing
- Just (new_ic, names, hval) -> do
- -- Run it!
- hvals <- (unsafeCoerce# hval) :: IO [HValue]
-
- case (names,hvals) of
- ([n],[hv]) -> return (Just hv)
- _ -> panic "compileExpr"
-
--- -----------------------------------------------------------------------------
--- running a statement interactively
-
-data RunResult
- = RunOk [Name] -- ^ names bound by this evaluation
- | RunFailed -- ^ statement failed compilation
- | RunException Exception -- ^ statement raised an exception
-
--- | Run a statement in the current interactive context. Statemenet
--- may bind multple values.
-runStmt :: Session -> String -> IO RunResult
-runStmt (Session ref) expr
- = do
- hsc_env <- readIORef ref
-
- -- Turn off -fwarn-unused-bindings when running a statement, to hide
- -- warnings about the implicit bindings we introduce.
- let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
- hsc_env' = hsc_env{ hsc_dflags = dflags' }
-
- maybe_stuff <- hscStmt hsc_env' expr
-
- case maybe_stuff of
- Nothing -> return RunFailed
- Just (new_hsc_env, names, hval) -> do
-
- let thing_to_run = unsafeCoerce# hval :: IO [HValue]
- either_hvals <- sandboxIO thing_to_run
-
- case either_hvals of
- Left e -> do
- -- on error, keep the *old* interactive context,
- -- so that 'it' is not bound to something
- -- that doesn't exist.
- return (RunException e)
-
- Right hvals -> do
- -- Get the newly bound things, and bind them.
- -- Don't need to delete any shadowed bindings;
- -- the new ones override the old ones.
- extendLinkEnv (zip names hvals)
-
- writeIORef ref new_hsc_env
- return (RunOk names)
-
--- When running a computation, we redirect ^C exceptions to the running
--- thread. ToDo: we might want a way to continue even if the target
--- thread doesn't die when it receives the exception... "this thread
--- is not responding".
-sandboxIO :: IO a -> IO (Either Exception a)
-sandboxIO thing = do
- m <- newEmptyMVar
- ts <- takeMVar interruptTargetThread
- child <- forkIO (do res <- Exception.try thing; putMVar m res)
- putMVar interruptTargetThread (child:ts)
- takeMVar m `finally` modifyMVar_ interruptTargetThread (return.tail)
-
-{-
--- This version of sandboxIO runs the expression in a completely new
--- RTS main thread. It is disabled for now because ^C exceptions
--- won't be delivered to the new thread, instead they'll be delivered
--- to the (blocked) GHCi main thread.
-
--- SLPJ: when re-enabling this, reflect a wrong-stat error as an exception
-
-sandboxIO :: IO a -> IO (Either Int (Either Exception a))
-sandboxIO thing = do
- st_thing <- newStablePtr (Exception.try thing)
- alloca $ \ p_st_result -> do
- stat <- rts_evalStableIO st_thing p_st_result
- freeStablePtr st_thing
- if stat == 1
- then do st_result <- peek p_st_result
- result <- deRefStablePtr st_result
- freeStablePtr st_result
- return (Right result)
- else do
- return (Left (fromIntegral stat))
projects / ghc-hetmet.git / blobdiff