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.

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

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

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   = [],

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

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}
 
 

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

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)) }
 

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),
@@ -1486,6 +1487,14 @@ isSafeModule m = do
         where state = pkgState dflags
               part pkg = trusted $ getPackageDetails state pkg
 
+-----------------------------------------------------------------------------
+-- :runmonad
+
+-- Set the monad GHCi should execute in
+
+setRunMonad :: String -> GHCi ()
+setRunMonad name = GHC.setGHCiMonad name
+
 -----------------------------------------------------------------------------
 -- :browse