- Nothing -> return (cmstate{ pcs=new_pcs }, [])
- Just (new_ic, ids, bcos) -> do
- hval <- linkExpr pls bcos
- hvals <- unsafeCoerce# hval :: IO [HValue]
- let names = map idName ids
- new_pls <- updateClosureEnv pls (zip names hvals)
- return (cmstate{ pcs=new_pcs, pls=new_pls, ic=new_ic }, names)
-
- -- ToDo: check that the module we passed in is sane/exists?
- where
- CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls } = cmstate
-#endif
+ Nothing -> return (cmstate, CmRunFailed)
+ Just (new_ic, 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 ( cmstate, CmRunException 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)
+
+ return (cmstate{ cm_ic=new_ic },
+ CmRunOk names)
+
+
+-- We run the statement in a "sandbox" to protect the rest of the
+-- system from anything the expression might do. For now, this
+-- consists of just wrapping it in an exception handler, but see below
+-- for another version.
+
+sandboxIO :: IO a -> IO (Either Exception a)
+sandboxIO thing = Exception.try thing
+
+{-
+-- 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))
+
+foreign import "rts_evalStableIO" {- safe -}
+ rts_evalStableIO :: StablePtr (IO a) -> Ptr (StablePtr a) -> IO CInt
+ -- more informative than the C type!
+-}
+
+-----------------------------------------------------------------------------
+-- cmTypeOfExpr: returns a string representing the type of an expression
+
+cmTypeOfExpr :: CmState -> String -> IO (Maybe String)
+cmTypeOfExpr cmstate expr
+ = do maybe_stuff <- hscTcExpr (cm_hsc cmstate) (cm_ic cmstate) expr
+
+ case maybe_stuff of
+ Nothing -> return Nothing
+ Just ty -> return (Just res_str)
+ where
+ res_str = showSDocForUser unqual (text expr <+> dcolon <+> ppr tidy_ty)
+ unqual = icPrintUnqual (cm_ic cmstate)
+ tidy_ty = tidyType emptyTidyEnv ty
+
+
+-----------------------------------------------------------------------------
+-- cmKindOfType: returns a string representing the kind of a type
+
+cmKindOfType :: CmState -> String -> IO (Maybe String)
+cmKindOfType cmstate str
+ = do maybe_stuff <- hscKcType (cm_hsc cmstate) (cm_ic cmstate) str
+ case maybe_stuff of
+ Nothing -> return Nothing
+ Just kind -> return (Just res_str)
+ where
+ res_str = showSDocForUser unqual (text str <+> dcolon <+> ppr kind)
+ unqual = icPrintUnqual (cm_ic cmstate)