Add experimental GHCi monad.

Modification of previous commit:
e0e99f99

Allows setting which monad GHCi runs statements in. Unsupported at this
stage.

compiler/main/GHC.hs

@@ -122,6 +122,11 @@ module GHC (
 #endif
         lookupName,
 
+#ifdef GHCI
+        -- ** EXPERIMENTAL
+        setGHCiMonad,
+#endif
+
         -- * Abstract syntax elements
 
         -- ** Packages
@@ -1330,6 +1335,21 @@ isModuleTrusted :: GhcMonad m => Module -> m Bool
 isModuleTrusted m = withSession $ \hsc_env ->
     liftIO $ hscCheckSafe hsc_env m noSrcSpan
 
+-- | EXPERIMENTAL: DO NOT USE.
+-- 
+-- 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.
+{-# WARNING setGHCiMonad "This is experimental! Don't use." #-}
+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,6 +975,11 @@ 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
@@ -1179,6 +1188,9 @@ selectorClassKey    = mkPreludeClassUnique 41
 singIClassNameKey, typeNatLeqClassNameKey :: Unique
 singIClassNameKey       = mkPreludeClassUnique 42
 typeNatLeqClassNameKey  = mkPreludeClassUnique 43
+
+ghciIoClassKey :: Unique
+ghciIoClassKey = mkPreludeClassUnique 44
 \end{code}
 
 %************************************************************************
@@ -1647,6 +1659,10 @@ guardMIdKey     = mkPreludeMiscIdUnique 194
 liftMIdKey      = mkPreludeMiscIdUnique 195
 mzipIdKey       = mkPreludeMiscIdUnique 196
 
+-- GHCi
+ghciStepIoMClassOpKey :: Unique
+ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197
+
 
 ---------------- Template Haskell -------------------
 --      USES IdUniques 200-499

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