Added ':runmonad' command to GHCi
authorDavid Terei <davidterei@gmail.com>
Wed, 1 Feb 2012 03:48:00 +0000 (19:48 -0800)
committerDavid Terei <davidterei@gmail.com>
Fri, 13 Apr 2012 01:06:35 +0000 (18:06 -0700)
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/hsSyn/HsTypes.lhs
compiler/main/GHC.hs
compiler/main/HscMain.hs
compiler/main/HscTypes.lhs
compiler/prelude/PrelNames.lhs
compiler/typecheck/TcExpr.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcRnMonad.lhs
ghc/InteractiveUI.hs

index 9e8d27b..b41070b 100644 (file)
@@ -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}
 
-
index 15e488b..d2fdc51 100644 (file)
@@ -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
index 491814f..b3f7960 100644 (file)
@@ -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
index e55d78e..82712e2 100644 (file)
@@ -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   = [],
index 9b47edb..c6c3ed7 100644 (file)
@@ -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
index 488e654..65f0c0c 100644 (file)
@@ -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}
 
 
index 0128f18..2e33e1f 100644 (file)
@@ -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
index 0d20be2..2f821b3 100644 (file)
@@ -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)) }
 
index 8d6e23c..c576b6b 100644 (file)
@@ -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