Added ':runmonad' command to GHCi

This command allows you to lift user stmts in GHCi into an IO monad
that implements the GHC.GHCi.GHCiSandboxIO type class. This allows for
easy sandboxing of GHCi using :runmonad and Safe Haskell.

Longer term it would be nice to allow a more general model for the Monad
than GHCiSandboxIO but delaying this for the moment.

9 files changed, 207 insertions, 119 deletions

diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 9e8d27bde0..b41070b3bc 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -6,41 +6,33 @@
 HsTypes: Abstract syntax: user-defined types
 
 \begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
 {-# LANGUAGE DeriveDataTypeable #-}
-
 module HsTypes (
-	HsType(..), LHsType, HsKind, LHsKind,
-	HsBndrSig(..), HsTyVarBndr(..), LHsTyVarBndr,
-	HsTupleSort(..), HsExplicitFlag(..),
-	HsContext, LHsContext,
-	HsQuasiQuote(..),
+        HsType(..), LHsType, HsKind, LHsKind,
+        HsBndrSig(..), HsTyVarBndr(..), LHsTyVarBndr,
+        HsTupleSort(..), HsExplicitFlag(..),
+        HsContext, LHsContext,
+        HsQuasiQuote(..),
         HsTyWrapper(..),
         HsTyLit(..),
 
-	LBangType, BangType, HsBang(..), 
+        LBangType, BangType, HsBang(..), 
         getBangType, getBangStrictness, 
 
-	ConDeclField(..), pprConDeclFields,
-	
-	mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs,
-	hsTyVarName, hsTyVarNames, 
-	hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
-	splitHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe,
+        ConDeclField(..), pprConDeclFields,
+        
+        mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs,
+        hsTyVarName, hsTyVarNames, 
+        hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
+        splitHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe,
         splitHsForAllTy, splitLHsForAllTy,
         splitHsClassTy_maybe, splitLHsClassTy_maybe,
         splitHsFunType,
-	splitHsAppTys, mkHsAppTys, mkHsOpTy,
+        splitHsAppTys, mkHsAppTys, mkHsOpTy,
         placeHolderBndrs,
 
-	-- Printing
-	pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context,
+        -- Printing
+        pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context,
     ) where
 
 import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice )
@@ -62,16 +54,16 @@ import Data.Data
 
 
 %************************************************************************
-%*									*
-	Quasi quotes; used in types and elsewhere
-%*									*
+%*                                                                      *
+        Quasi quotes; used in types and elsewhere
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
 data HsQuasiQuote id = HsQuasiQuote 
-		       	   id		-- The quasi-quoter
-		       	   SrcSpan	-- The span of the enclosed string
-		       	   FastString	-- The enclosed string
+                           id           -- The quasi-quoter
+                           SrcSpan      -- The span of the enclosed string
+                           FastString   -- The enclosed string
   deriving (Data, Typeable)
 
 instance OutputableBndr id => Outputable (HsQuasiQuote id) where
@@ -85,14 +77,14 @@ ppr_qq (HsQuasiQuote quoter _ quote) =
 
 
 %************************************************************************
-%*									*
+%*                                                                      *
 \subsection{Bang annotations}
-%*									*
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
 type LBangType name = Located (BangType name)
-type BangType name  = HsType name	-- Bangs are in the HsType data type
+type BangType name  = HsType name       -- Bangs are in the HsType data type
 
 getBangType :: LHsType a -> LHsType a
 getBangType (L _ (HsBangTy _ ty)) = ty
@@ -105,9 +97,9 @@ getBangStrictness _                    = HsNoBang
 
 
 %************************************************************************
-%*									*
+%*                                                                      *
 \subsection{Data types}
-%*									*
+%*                                                                      *
 %************************************************************************
 
 This is the syntax for types as seen in type signatures.
@@ -141,8 +133,8 @@ placeHolderBndrs :: [Name]
 placeHolderBndrs = panic "placeHolderBndrs"
 
 data HsTyVarBndr name
-  = UserTyVar		-- No explicit kinding
-         name 		-- See Note [Printing KindedTyVars]
+  = UserTyVar           -- No explicit kinding
+         name           -- See Note [Printing KindedTyVars]
 
   | KindedTyVar
          name
@@ -153,57 +145,57 @@ data HsTyVarBndr name
   deriving (Data, Typeable)
 
 data HsType name
-  = HsForAllTy	HsExplicitFlag   	-- Renamer leaves this flag unchanged, to record the way
-					-- the user wrote it originally, so that the printer can
-					-- print it as the user wrote it
-		[LHsTyVarBndr name]	-- See Note [HsForAllTy tyvar binders]
-		(LHsContext name)
-		(LHsType name)
-
-  | HsTyVar		name		-- Type variable, type constructor, or data constructor
+  = HsForAllTy  HsExplicitFlag          -- Renamer leaves this flag unchanged, to record the way
+                                        -- the user wrote it originally, so that the printer can
+                                        -- print it as the user wrote it
+                [LHsTyVarBndr name]     -- See Note [HsForAllTy tyvar binders]
+                (LHsContext name)
+                (LHsType name)
+
+  | HsTyVar             name            -- Type variable, type constructor, or data constructor
                                         -- see Note [Promotions (HsTyVar)]
 
-  | HsAppTy		(LHsType name)
-			(LHsType name)
+  | HsAppTy             (LHsType name)
+                        (LHsType name)
 
-  | HsFunTy		(LHsType name)   -- function type
-			(LHsType name)
+  | HsFunTy             (LHsType name)   -- function type
+                        (LHsType name)
 
-  | HsListTy		(LHsType name)	-- Element type
+  | HsListTy            (LHsType name)  -- Element type
 
-  | HsPArrTy		(LHsType name)	-- Elem. type of parallel array: [:t:]
+  | HsPArrTy            (LHsType name)  -- Elem. type of parallel array: [:t:]
 
-  | HsTupleTy		HsTupleSort
-			[LHsType name]	-- Element types (length gives arity)
+  | HsTupleTy           HsTupleSort
+                        [LHsType name]  -- Element types (length gives arity)
 
-  | HsOpTy		(LHsType name) (LHsTyOp name) (LHsType name)
+  | HsOpTy              (LHsType name) (LHsTyOp name) (LHsType name)
 
-  | HsParTy		(LHsType name)   -- See Note [Parens in HsSyn] in HsExpr
-	-- Parenthesis preserved for the precedence re-arrangement in RnTypes
-	-- It's important that a * (b + c) doesn't get rearranged to (a*b) + c!
+  | HsParTy             (LHsType name)   -- See Note [Parens in HsSyn] in HsExpr
+        -- Parenthesis preserved for the precedence re-arrangement in RnTypes
+        -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c!
 
-  | HsIParamTy		(IPName name)    -- (?x :: ty)
+  | HsIParamTy          (IPName name)    -- (?x :: ty)
                         (LHsType name)   -- Implicit parameters as they occur in contexts
 
   | HsEqTy              (LHsType name)   -- ty1 ~ ty2
                         (LHsType name)   -- Always allowed even without TypeOperators, and has special kinding rule
 
-  | HsKindSig		(LHsType name)	-- (ty :: kind)
-			(LHsKind name)  -- A type with a kind signature
+  | HsKindSig           (LHsType name)  -- (ty :: kind)
+                        (LHsKind name)  -- A type with a kind signature
 
-  | HsQuasiQuoteTy	(HsQuasiQuote name)
+  | HsQuasiQuoteTy      (HsQuasiQuote name)
 
-  | HsSpliceTy		(HsSplice name) 
-                        FreeVars  	-- Variables free in the splice (filled in by renamer)
-			PostTcKind
+  | HsSpliceTy          (HsSplice name) 
+                        FreeVars        -- Variables free in the splice (filled in by renamer)
+                        PostTcKind
 
   | HsDocTy             (LHsType name) LHsDocString -- A documented type
 
-  | HsBangTy	HsBang (LHsType name)	-- Bang-style type annotations 
-  | HsRecTy [ConDeclField name]	        -- Only in data type declarations
+  | HsBangTy    HsBang (LHsType name)   -- Bang-style type annotations 
+  | HsRecTy [ConDeclField name]         -- Only in data type declarations
 
-  | HsCoreTy Type	-- An escape hatch for tunnelling a *closed* 
-    	       		-- Core Type through HsSyn.  
+  | HsCoreTy Type       -- An escape hatch for tunnelling a *closed* 
+                        -- Core Type through HsSyn.  
 
   | HsExplicitListTy     -- A promoted explicit list
         PostTcKind       -- See Note [Promoted lists and tuples]
@@ -332,16 +324,16 @@ data HsTupleSort = HsUnboxedTuple
 
 data HsExplicitFlag = Explicit | Implicit deriving (Data, Typeable)
 
-data ConDeclField name	-- Record fields have Haddoc docs on them
+data ConDeclField name  -- Record fields have Haddoc docs on them
   = ConDeclField { cd_fld_name :: Located name,
-		   cd_fld_type :: LBangType name, 
-		   cd_fld_doc  :: Maybe LHsDocString }
+                   cd_fld_type :: LBangType name, 
+                   cd_fld_doc  :: Maybe LHsDocString }
   deriving (Data, Typeable)
 
 -----------------------
 -- Combine adjacent for-alls. 
 -- The following awkward situation can happen otherwise:
---	f :: forall a. ((Num a) => Int)
+--      f :: forall a. ((Num a) => Int)
 -- might generate HsForAll (Just [a]) [] (HsForAll Nothing [Num a] t)
 -- Then a isn't discovered as ambiguous, and we abstract the AbsBinds wrt []
 -- but the export list abstracts f wrt [a].  Disaster.
@@ -360,14 +352,14 @@ mkHsForAllTy exp tvs ctxt ty = HsForAllTy exp tvs ctxt ty
 
 -- mk_forall_ty makes a pure for-all type (no context)
 mk_forall_ty :: HsExplicitFlag -> [LHsTyVarBndr name] -> LHsType name -> HsType name
-mk_forall_ty exp  tvs  (L _ (HsParTy ty))		    = mk_forall_ty exp tvs ty
+mk_forall_ty exp  tvs  (L _ (HsParTy ty))                   = mk_forall_ty exp tvs ty
 mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 tvs2 ctxt ty)) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ tvs2) ctxt ty
-mk_forall_ty exp  tvs  ty			            = HsForAllTy exp tvs (noLoc []) ty
-	-- Even if tvs is empty, we still make a HsForAll!
-	-- In the Implicit case, this signals the place to do implicit quantification
-	-- In the Explicit case, it prevents implicit quantification	
-	--	(see the sigtype production in Parser.y.pp)
-	-- 	so that (forall. ty) isn't implicitly quantified
+mk_forall_ty exp  tvs  ty                                   = HsForAllTy exp tvs (noLoc []) ty
+        -- Even if tvs is empty, we still make a HsForAll!
+        -- In the Implicit case, this signals the place to do implicit quantification
+        -- In the Explicit case, it prevents implicit quantification    
+        --      (see the sigtype production in Parser.y.pp)
+        --      so that (forall. ty) isn't implicitly quantified
 
 plus :: HsExplicitFlag -> HsExplicitFlag -> HsExplicitFlag
 Implicit `plus` Implicit = Implicit
@@ -403,14 +395,14 @@ hsLTyVarLocNames = map hsLTyVarLocName
 \begin{code}
 splitHsAppTys :: LHsType n -> [LHsType n] -> (LHsType n, [LHsType n])
 splitHsAppTys (L _ (HsAppTy f a)) as = splitHsAppTys f (a:as)
-splitHsAppTys f          	  as = (f,as)
+splitHsAppTys f                   as = (f,as)
 
 mkHsAppTys :: OutputableBndr n => LHsType n -> [LHsType n] -> HsType n
 mkHsAppTys fun_ty [] = pprPanic "mkHsAppTys" (ppr fun_ty)
 mkHsAppTys fun_ty (arg_ty:arg_tys)
   = foldl mk_app (HsAppTy fun_ty arg_ty) arg_tys
   where
-    mk_app fun arg = HsAppTy (noLoc fun) arg	
+    mk_app fun arg = HsAppTy (noLoc fun) arg    
        -- Add noLocs for inner nodes of the application; 
        -- they are never used 
 
@@ -422,7 +414,7 @@ splitHsInstDeclTy_maybe ty
 splitLHsInstDeclTy_maybe
     :: LHsType name 
     -> Maybe ([LHsTyVarBndr name], HsContext name, Located name, [LHsType name])
-	-- Split up an instance decl type, returning the pieces
+        -- Split up an instance decl type, returning the pieces
 splitLHsInstDeclTy_maybe inst_ty = do
     let (tvs, cxt, ty) = splitLHsForAllTy inst_ty
     (cls, tys) <- splitLHsClassTy_maybe ty
@@ -464,20 +456,20 @@ splitLHsClassTy_maybe ty
 
 -- Splits HsType into the (init, last) parts
 -- Breaks up any parens in the result type: 
---	splitHsFunType (a -> (b -> c)) = ([a,b], c)
+--      splitHsFunType (a -> (b -> c)) = ([a,b], c)
 splitHsFunType :: LHsType name -> ([LHsType name], LHsType name)
 splitHsFunType (L _ (HsFunTy x y)) = (x:args, res)
   where
   (args, res) = splitHsFunType y
 splitHsFunType (L _ (HsParTy ty))  = splitHsFunType ty
-splitHsFunType other 	   	   = ([], other)
+splitHsFunType other               = ([], other)
 \end{code}
 
 
 %************************************************************************
-%*									*
+%*                                                                      *
 \subsection{Pretty printing}
-%*									*
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
@@ -500,12 +492,12 @@ pprHsForAll exp tvs cxt
   | otherwise   = pprHsContext (unLoc cxt)
   where
     show_forall =  opt_PprStyle_Debug
-		|| (not (null tvs) && is_explicit)
+                || (not (null tvs) && is_explicit)
     is_explicit = case exp of {Explicit -> True; Implicit -> False}
     forall_part = ptext (sLit "forall") <+> interppSP tvs <> dot
 
 pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc
-pprHsContext []	        = empty
+pprHsContext []         = empty
 pprHsContext [L _ pred] = ppr pred <+> darrow
 pprHsContext cxt        = ppr_hs_context cxt <+> darrow
 
@@ -517,8 +509,8 @@ pprConDeclFields :: OutputableBndr name => [ConDeclField name] -> SDoc
 pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
   where
     ppr_fld (ConDeclField { cd_fld_name = n, cd_fld_type = ty, 
-			    cd_fld_doc = doc })
-  	= ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
+                            cd_fld_doc = doc })
+        = ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
 \end{code}
 
 Note [Printing KindedTyVars]
@@ -542,12 +534,12 @@ pREC_OP  = 2  -- Used for arg of any infix operator
 pREC_CON = 3  -- Used for arg of type applicn:
               -- always parenthesise unless atomic
 
-maybeParen :: Int 	-- Precedence of context
-	   -> Int	-- Precedence of top-level operator
-	   -> SDoc -> SDoc	-- Wrap in parens if (ctxt >= op)
+maybeParen :: Int       -- Precedence of context
+           -> Int       -- Precedence of top-level operator
+           -> SDoc -> SDoc      -- Wrap in parens if (ctxt >= op)
 maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p
-			       | otherwise	      = p
-	
+                               | otherwise            = p
+        
 -- printing works more-or-less as for Types
 
 pprHsType, pprParendHsType :: (OutputableBndr name) => HsType name -> SDoc
@@ -560,7 +552,7 @@ pprParendHsType ty = ppr_mono_ty pREC_CON ty
 -- (b) Drop top-level for-all type variables in user style
 --     since they are implicit in Haskell
 prepare :: PprStyle -> HsType name -> HsType name
-prepare sty (HsParTy ty)	  = prepare sty (unLoc ty)
+prepare sty (HsParTy ty)          = prepare sty (unLoc ty)
 prepare _   ty                    = ty
 
 ppr_mono_lty :: (OutputableBndr name) => Int -> LHsType name -> SDoc
@@ -581,8 +573,8 @@ ppr_mono_ty _    (HsTupleTy con tys) = tupleParens std_con (interpp'SP tys)
                     HsUnboxedTuple -> UnboxedTuple
                     _              -> BoxedTuple
 ppr_mono_ty _    (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> ppr kind)
-ppr_mono_ty _    (HsListTy ty)	     = brackets (ppr_mono_lty pREC_TOP ty)
-ppr_mono_ty _    (HsPArrTy ty)	     = paBrackets (ppr_mono_lty pREC_TOP ty)
+ppr_mono_ty _    (HsListTy ty)       = brackets (ppr_mono_lty pREC_TOP ty)
+ppr_mono_ty _    (HsPArrTy ty)       = paBrackets (ppr_mono_lty pREC_TOP ty)
 ppr_mono_ty prec (HsIParamTy n ty)   = maybeParen prec pREC_FUN (ppr n <+> dcolon <+> ppr_mono_lty pREC_TOP ty)
 ppr_mono_ty _    (HsSpliceTy s _ _)  = pprSplice s
 ppr_mono_ty _    (HsCoreTy ty)       = ppr ty
@@ -620,7 +612,7 @@ ppr_mono_ty _         (HsParTy ty)
   = parens (ppr_mono_lty pREC_TOP ty)
   -- Put the parens in where the user did
   -- But we still use the precedence stuff to add parens because
-  --	toHsType doesn't put in any HsParTys, so we may still need them
+  --    toHsType doesn't put in any HsParTys, so we may still need them
 
 ppr_mono_ty ctxt_prec (HsDocTy ty doc) 
   = maybeParen ctxt_prec pREC_OP $
@@ -632,7 +624,7 @@ ppr_mono_ty ctxt_prec (HsDocTy ty doc)
 ppr_fun_ty :: (OutputableBndr name) => Int -> LHsType name -> LHsType name -> SDoc
 ppr_fun_ty ctxt_prec ty1 ty2
   = let p1 = ppr_mono_lty pREC_FUN ty1
-	p2 = ppr_mono_lty pREC_TOP ty2
+        p2 = ppr_mono_lty pREC_TOP ty2
     in
     maybeParen ctxt_prec pREC_FUN $
     sep [p1, ptext (sLit "->") <+> p2]
@@ -643,4 +635,3 @@ ppr_tylit (HsNumTy i) = integer i
 ppr_tylit (HsStrTy s) = text (show s)
 \end{code}
 
-
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 15e488bd09..d2fdc51bb1 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -90,6 +90,7 @@ module GHC (
         findModule, lookupModule,
 #ifdef GHCI
         isModuleTrusted,
+        setGHCiMonad,
         setContext, getContext, 
         getNamesInScope,
         getRdrNamesInScope,
@@ -1330,6 +1331,18 @@ isModuleTrusted :: GhcMonad m => Module -> m Bool
 isModuleTrusted m = withSession $ \hsc_env ->
     liftIO $ hscCheckSafe hsc_env m noSrcSpan
 
+-- | Set the monad GHCi lifts user statements into.
+--
+-- Checks that a type (in string form) is an instance of the
+-- @GHC.GHCi.GHCiSandboxIO@ type class. Sets it to be the GHCi monad if it is,
+-- throws an error otherwise.
+setGHCiMonad :: GhcMonad m => String -> m ()
+setGHCiMonad name = withSession $ \hsc_env -> do
+    ty <- liftIO $ hscIsGHCiMonad hsc_env name
+    modifySession $ \s ->
+        let ic = (hsc_IC s) { ic_monad = ty }
+        in s { hsc_IC = ic }
+
 getHistorySpan :: GhcMonad m => History -> m SrcSpan
 getHistorySpan h = withSession $ \hsc_env ->
     return $ InteractiveEval.getHistorySpan hsc_env h
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 491814f0c5..b3f79605a1 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -62,6 +62,7 @@ module HscMain
     , hscTcRnGetInfo
     , hscCheckSafe
 #ifdef GHCI
+    , hscIsGHCiMonad
     , hscGetModuleInterface
     , hscRnImportDecls
     , hscTcRnLookupRdrName
@@ -311,6 +312,11 @@ hscTcRnGetInfo hsc_env0 name = runInteractiveHsc hsc_env0 $ do
   ioMsgMaybe' $ tcRnGetInfo hsc_env name
 
 #ifdef GHCI
+hscIsGHCiMonad :: HscEnv -> String -> IO Name
+hscIsGHCiMonad hsc_env name =
+    let icntxt   = hsc_IC hsc_env
+    in runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env icntxt name
+
 hscGetModuleInterface :: HscEnv -> Module -> IO ModIface
 hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do
   hsc_env <- getHscEnv
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index e55d78e6fd..82712e2741 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -136,7 +136,7 @@ import Annotations
 import Class
 import TyCon
 import DataCon
-import PrelNames        ( gHC_PRIM )
+import PrelNames        ( gHC_PRIM, ioTyConName )
 import Packages hiding  ( Version(..) )
 import DynFlags
 import DriverPhases
@@ -910,6 +910,9 @@ data InteractiveContext
              -- ^ The 'DynFlags' used to evaluate interative expressions
              -- and statements.
 
+         ic_monad      :: Name,
+             -- ^ The monad that GHCi is executing in
+
          ic_imports    :: [InteractiveImport],
              -- ^ The GHCi context is extended with these imports
              --
@@ -973,6 +976,8 @@ hscDeclsWithLocation) and save them in ic_sys_vars.
 emptyInteractiveContext :: DynFlags -> InteractiveContext
 emptyInteractiveContext dflags
   = InteractiveContext { ic_dflags     = dflags,
+                         -- IO monad by default
+                         ic_monad      = ioTyConName,
                          ic_imports    = [],
                          ic_rn_gbl_env = emptyGlobalRdrEnv,
                          ic_tythings   = [],
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 9b47edb169..c6c3ed719a 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -306,6 +306,9 @@ basicKnownKeyNames
         , guardMName
         , liftMName
         , mzipName
+
+        -- GHCi Sandbox
+        , ghciIoClassName, ghciStepIoMName
     ]
 
 genericTyConNames :: [Name]
@@ -334,7 +337,7 @@ pRELUDE         = mkBaseModule_ pRELUDE_NAME
 
 gHC_PRIM, gHC_TYPES, gHC_GENERICS,
     gHC_MAGIC,
-    gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_CSTRING,
+    gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING,
     gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER_TYPE, gHC_LIST,
     gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE,
     gHC_CONC, gHC_IO, gHC_IO_Exception,
@@ -353,6 +356,7 @@ gHC_CLASSES     = mkPrimModule (fsLit "GHC.Classes")
 
 gHC_BASE        = mkBaseModule (fsLit "GHC.Base")
 gHC_ENUM        = mkBaseModule (fsLit "GHC.Enum")
+gHC_GHCI        = mkBaseModule (fsLit "GHC.GHCi")
 gHC_SHOW        = mkBaseModule (fsLit "GHC.Show")
 gHC_READ        = mkBaseModule (fsLit "GHC.Read")
 gHC_NUM         = mkBaseModule (fsLit "GHC.Num")
@@ -971,15 +975,19 @@ datatypeClassName = clsQual gHC_GENERICS (fsLit "Datatype") datatypeClassKey
 constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey
 selectorClassName = clsQual gHC_GENERICS (fsLit "Selector") selectorClassKey
 
+-- GHCi things
+ghciIoClassName, ghciStepIoMName :: Name
+ghciIoClassName = clsQual gHC_GHCI (fsLit "GHCiSandboxIO") ghciIoClassKey
+ghciStepIoMName = methName gHC_GHCI (fsLit "ghciStepIO") ghciStepIoMClassOpKey
+
 -- IO things
-ioTyConName, ioDataConName, thenIOName, bindIOName, returnIOName,
-    failIOName :: Name
-ioTyConName       = tcQual  gHC_TYPES (fsLit "IO") ioTyConKey
-ioDataConName     = conName gHC_TYPES (fsLit "IO") ioDataConKey
-thenIOName        = varQual gHC_BASE (fsLit "thenIO") thenIOIdKey
-bindIOName        = varQual gHC_BASE (fsLit "bindIO") bindIOIdKey
-returnIOName      = varQual gHC_BASE (fsLit "returnIO") returnIOIdKey
-failIOName        = varQual gHC_IO (fsLit "failIO") failIOIdKey
+ioTyConName, ioDataConName, thenIOName, bindIOName, returnIOName, failIOName :: Name
+ioTyConName   = tcQual  gHC_TYPES (fsLit "IO") ioTyConKey
+ioDataConName = conName gHC_TYPES (fsLit "IO") ioDataConKey
+thenIOName    = varQual gHC_BASE (fsLit "thenIO") thenIOIdKey
+bindIOName    = varQual gHC_BASE (fsLit "bindIO") bindIOIdKey
+returnIOName  = varQual gHC_BASE (fsLit "returnIO") returnIOIdKey
+failIOName    = varQual gHC_IO (fsLit "failIO") failIOIdKey
 
 -- IO things
 printName :: Name
@@ -1179,6 +1187,9 @@ selectorClassKey    = mkPreludeClassUnique 41
 singIClassNameKey, typeNatLeqClassNameKey :: Unique
 singIClassNameKey       = mkPreludeClassUnique 42
 typeNatLeqClassNameKey  = mkPreludeClassUnique 43
+
+ghciIoClassKey :: Unique
+ghciIoClassKey        = mkPreludeClassUnique 44
 \end{code}
 
 %************************************************************************
@@ -1647,6 +1658,11 @@ guardMIdKey     = mkPreludeMiscIdUnique 194
 liftMIdKey      = mkPreludeMiscIdUnique 195
 mzipIdKey       = mkPreludeMiscIdUnique 196
 
+-- GHCi
+ghciStepIoMClassOpKey, ghciShowIoMClassOpKey :: Unique
+ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197
+ghciShowIoMClassOpKey = mkPreludeMiscIdUnique 198
+
 
 ---------------- Template Haskell -------------------
 --      USES IdUniques 200-499
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 488e65458c..65f0c0c1a8 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -939,7 +939,7 @@ tcSyntaxOp :: CtOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
 -- This version assumes res_ty is a monotype
 tcSyntaxOp orig (HsVar op) res_ty = do { (expr, rho) <- tcInferIdWithOrig orig op
                                        ; tcWrapResult expr rho res_ty }
-tcSyntaxOp _ other 	   _      = pprPanic "tcSyntaxOp" (ppr other) 
+tcSyntaxOp _ other 	   _      = pprPanic "tcSyntaxOp: " (ppr other) 
 \end{code}
 
 
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 0128f1809e..2e33e1f33d 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -12,6 +12,7 @@ module TcRnDriver (
         tcRnLookupRdrName,
         getModuleInterface,
         tcRnDeclsi,
+        isGHCiMonad,
 #endif
         tcRnLookupName,
         tcRnGetInfo,
@@ -24,6 +25,7 @@ module TcRnDriver (
 import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
 #endif
 
+import TypeRep
 import DynFlags
 import StaticFlags
 import HsSyn
@@ -1286,6 +1288,7 @@ tcUserStmt :: LStmt RdrName -> TcM PlanResult
 tcUserStmt (L loc (ExprStmt expr _ _ _))
   = do  { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr)
                -- Don't try to typecheck if the renamer fails!
+        ; ghciStep <- getGhciStepIO
         ; uniq <- newUnique
         ; let fresh_it  = itName uniq loc
               matches   = [mkMatch [] rn_expr emptyLocalBinds]
@@ -1295,13 +1298,15 @@ tcUserStmt (L loc (ExprStmt expr _ _ _))
                           -- free variables, and they in turn may have free type variables
                           -- (if we are at a breakpoint, say).  We must put those free vars
 
-
               -- [let it = expr]
               let_stmt  = L loc $ LetStmt $ HsValBinds $
                           ValBindsOut [(NonRecursive,unitBag the_bind)] []
+
               -- [it <- e]
-              bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it)) rn_expr
+              bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it))
+                                           (nlHsApp ghciStep rn_expr)
                                            (HsVar bindIOName) noSyntaxExpr
+
               -- [; print it]
               print_it  = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
                                            (HsVar thenIOName) noSyntaxExpr placeHolderType
@@ -1319,7 +1324,7 @@ tcUserStmt (L loc (ExprStmt expr _ _ _))
                     -- Plan A
                     do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
                        ; it_ty <- zonkTcType (idType it_id)
-                       ; when (isUnitTy it_ty) failM
+                       ; when (isUnitTy $ it_ty) failM
                        ; return stuff },
 
                         -- Plan B; a naked bind statment
@@ -1343,20 +1348,26 @@ tcUserStmt rdr_stmt@(L loc _)
        ; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs])
        ; rnDump (ppr rn_stmt) ;
 
+       ; ghciStep <- getGhciStepIO
+       ; let gi_stmt
+               | (L loc (BindStmt pat expr op1 op2)) <- rn_stmt
+                           = L loc $ BindStmt pat (nlHsApp ghciStep expr) op1 op2
+               | otherwise = rn_stmt
+
        ; opt_pr_flag <- doptM Opt_PrintBindResult
        ; let print_result_plan
                | opt_pr_flag                         -- The flag says "print result"   
-               , [v] <- collectLStmtBinders rn_stmt  -- One binder
-                           =  [mk_print_result_plan rn_stmt v]
+               , [v] <- collectLStmtBinders gi_stmt  -- One binder
+                           =  [mk_print_result_plan gi_stmt v]
                | otherwise = []
 
         -- The plans are:
         --      [stmt; print v]         if one binder and not v::()
         --      [stmt]                  otherwise
-       ; runPlans (print_result_plan ++ [tcGhciStmts [rn_stmt]]) }
+       ; runPlans (print_result_plan ++ [tcGhciStmts [gi_stmt]]) }
   where
-    mk_print_result_plan rn_stmt v
-      = do { stuff@([v_id], _) <- tcGhciStmts [rn_stmt, print_v]
+    mk_print_result_plan stmt v
+      = do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
            ; v_ty <- zonkTcType (idType v_id)
            ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM
            ; return stuff }
@@ -1411,6 +1422,40 @@ tcGhciStmts stmts
         return (ids, mkHsDictLet (EvBinds const_binds) $
                      noLoc (HsDo GhciStmt stmts io_ret_ty))
     }
+
+-- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a)
+getGhciStepIO :: TcM (LHsExpr Name)
+getGhciStepIO = do
+    ghciTy <- getGHCiMonad
+    fresh_a <- newUnique
+    let a_tv   = mkTcTyVarName fresh_a (fsLit "a")
+        ghciM  = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv)
+        ioM    = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv)
+        stepTy = noLoc $ HsForAllTy Implicit
+                      ([noLoc $ UserTyVar a_tv])
+                      (noLoc [])
+                      (nlHsFunTy ghciM ioM)
+        step   = noLoc $ ExprWithTySig (nlHsVar ghciStepIoMName) stepTy
+    return step
+
+isGHCiMonad :: HscEnv -> InteractiveContext -> String -> IO (Messages, Maybe Name)
+isGHCiMonad hsc_env ictxt ty
+  = initTcPrintErrors hsc_env iNTERACTIVE $
+    setInteractiveContext hsc_env ictxt $ do
+        rdrEnv <- getGlobalRdrEnv
+        let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty)
+        case occIO of
+            Just [n] -> do
+                let name = gre_name n
+                ghciClass <- tcLookupClass ghciIoClassName 
+                userTyCon <- tcLookupTyCon name
+                let userTy = TyConApp userTyCon []
+                _ <- tcLookupInstance ghciClass [userTy]
+                return name
+
+            Just _  -> failWithTc $ text "Ambigous type!"
+            Nothing -> failWithTc $ text ("Can't find type:" ++ ty)
+
 \end{code}
 
 tcRnExpr just finds the type of an expression
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 0d20be2949..2f821b3aae 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -486,6 +486,9 @@ setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_ins
 getIsGHCi :: TcRn Bool
 getIsGHCi = do { mod <- getModule; return (mod == iNTERACTIVE) }
 
+getGHCiMonad :: TcRn Name
+getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) }
+
 tcIsHsBoot :: TcRn Bool
 tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) }
 
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index 8d6e23c678..c576b6b5fb 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -144,6 +144,7 @@ builtin_commands = [
   ("quit",      quit,                           noCompletion),
   ("reload",    keepGoing' reloadModule,        noCompletion),
   ("run",       keepGoing runRun,               completeFilename),
+  ("runmonad",  keepGoing setRunMonad,          noCompletion),
   ("script",    keepGoing' scriptCmd,           completeFilename),
   ("set",       keepGoing setCmd,               completeSetOptions),
   ("seti",      keepGoing setiCmd,              completeSeti),
@@ -1487,6 +1488,14 @@ isSafeModule m = do
               part pkg = trusted $ getPackageDetails state pkg
 
 -----------------------------------------------------------------------------
+-- :runmonad
+
+-- Set the monad GHCi should execute in
+
+setRunMonad :: String -> GHCi ()
+setRunMonad name = GHC.setGHCiMonad name
+
+-----------------------------------------------------------------------------
 -- :browse
 
 -- Browsing a module's contents