Commit eecd7c98 authored by dterei's avatar dterei
Browse files

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.
parent 295717d0
......@@ -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}
......@@ -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
......
......@@ -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
......
......@@ -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 = [],
......
......@@ -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
......
......@@ -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}
......
......@@ -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