Commit e0e99f99 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Revert "Added ':runmonad' command to GHCi"

Two problems, for now at any rate
  a) Breaks the build with lots of errors like
        No instance for (Show (IO ())) arising from a use of `print'
  b) Discussion of the approache hasn't converged yet
     (Simon M had a number of suggestions)

This reverts commit eecd7c98.
parent eecd7c98
......@@ -6,33 +6,41 @@
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 )
......@@ -54,16 +62,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
......@@ -77,14 +85,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
......@@ -97,9 +105,9 @@ getBangStrictness _ = HsNoBang
%************************************************************************
%* *
%* *
\subsection{Data types}
%* *
%* *
%************************************************************************
This is the syntax for types as seen in type signatures.
......@@ -133,8 +141,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
......@@ -145,57 +153,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]
......@@ -324,16 +332,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.
......@@ -352,14 +360,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
......@@ -395,14 +403,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
......@@ -414,7 +422,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
......@@ -456,20 +464,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}
......@@ -492,12 +500,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
......@@ -509,8 +517,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]
......@@ -534,12 +542,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
......@@ -552,7 +560,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
......@@ -573,8 +581,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
......@@ -612,7 +620,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 $
......@@ -624,7 +632,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]
......@@ -635,3 +643,4 @@ ppr_tylit (HsNumTy i) = integer i
ppr_tylit (HsStrTy s) = text (show s)
\end{code}
......@@ -90,7 +90,6 @@ module GHC (
findModule, lookupModule,
#ifdef GHCI
isModuleTrusted,
setGHCiMonad,
setContext, getContext,
getNamesInScope,
getRdrNamesInScope,
......@@ -1331,18 +1330,6 @@ 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,7 +62,6 @@ module HscMain
, hscTcRnGetInfo
, hscCheckSafe
#ifdef GHCI
, hscIsGHCiMonad
, hscGetModuleInterface
, hscRnImportDecls
, hscTcRnLookupRdrName
......@@ -312,11 +311,6 @@ 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, ioTyConName )
import PrelNames ( gHC_PRIM )
import Packages hiding ( Version(..) )
import DynFlags
import DriverPhases
......@@ -910,9 +910,6 @@ 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
--
......@@ -976,8 +973,6 @@ 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,9 +306,6 @@ basicKnownKeyNames
, guardMName
, liftMName
, mzipName
-- GHCi Sandbox
, ghciIoClassName, ghciStepIoMName
]
genericTyConNames :: [Name]
......@@ -337,7 +334,7 @@ pRELUDE = mkBaseModule_ pRELUDE_NAME
gHC_PRIM, gHC_TYPES, gHC_GENERICS,
gHC_MAGIC,
gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING,
gHC_CLASSES, gHC_BASE, gHC_ENUM, 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,
......@@ -356,7 +353,6 @@ 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")
......@@ -975,19 +971,15 @@ 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
......@@ -1187,9 +1179,6 @@ selectorClassKey = mkPreludeClassUnique 41
singIClassNameKey, typeNatLeqClassNameKey :: Unique
singIClassNameKey = mkPreludeClassUnique 42
typeNatLeqClassNameKey = mkPreludeClassUnique 43
ghciIoClassKey :: Unique
ghciIoClassKey = mkPreludeClassUnique 44
\end{code}
%************************************************************************
......@@ -1658,11 +1647,6 @@ 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,7 +12,6 @@ module TcRnDriver (
tcRnLookupRdrName,
getModuleInterface,
tcRnDeclsi,
isGHCiMonad,
#endif
tcRnLookupName,
tcRnGetInfo,
......@@ -25,7 +24,6 @@ module TcRnDriver (
import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
#endif
import TypeRep
import DynFlags
import StaticFlags
import HsSyn
......@@ -1288,7 +1286,6 @@ 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]
......@@ -1298,15 +1295,13 @@ 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))
(nlHsApp ghciStep rn_expr)
bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it)) rn_expr
(HsVar bindIOName) noSyntaxExpr
-- [; print it]
print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
(HsVar thenIOName) noSyntaxExpr placeHolderType
......@@ -1324,7 +1319,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
......@@ -1348,26 +1343,20 @@ 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 gi_stmt -- One binder
= [mk_print_result_plan gi_stmt v]
, [v] <- collectLStmtBinders rn_stmt -- One binder
= [mk_print_result_plan rn_stmt v]
| otherwise = []
-- The plans are:
-- [stmt; print v] if one binder and not v::()
-- [stmt] otherwise
; runPlans (print_result_plan ++ [tcGhciStmts [gi_stmt]]) }
; runPlans (print_result_plan ++ [tcGhciStmts [rn_stmt]]) }
where
mk_print_result_plan stmt v
= do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
mk_print_result_plan rn_stmt v
= do { stuff@([v_id], _) <- tcGhciStmts [rn_stmt, print_v]
; v_ty <- zonkTcType (idType v_id)
; when (isUnitTy v_ty || not (isTauTy v_ty)) failM
; return stuff }
......@@ -1422,40 +1411,6 @@ 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