diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2012-04-13 10:37:48 +0100 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2012-04-13 10:37:48 +0100 |
commit | e0e99f9948c1eac82cf69dd3cc30cb068e42d45e (patch) | |
tree | 1e41f64f5d84e884288b7f49745d7e5ea77c7798 | |
parent | eecd7c98c1f079c14d99ed831dff33a48ee45e67 (diff) | |
download | haskell-e0e99f9948c1eac82cf69dd3cc30cb068e42d45e.tar.gz |
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 eecd7c98c1f079c14d99ed831dff33a48ee45e67.
-rw-r--r-- | compiler/hsSyn/HsTypes.lhs | 191 | ||||
-rw-r--r-- | compiler/main/GHC.hs | 13 | ||||
-rw-r--r-- | compiler/main/HscMain.hs | 6 | ||||
-rw-r--r-- | compiler/main/HscTypes.lhs | 7 | ||||
-rw-r--r-- | compiler/prelude/PrelNames.lhs | 34 | ||||
-rw-r--r-- | compiler/typecheck/TcExpr.lhs | 2 | ||||
-rw-r--r-- | compiler/typecheck/TcRnDriver.lhs | 61 | ||||
-rw-r--r-- | compiler/typecheck/TcRnMonad.lhs | 3 | ||||
-rw-r--r-- | ghc/InteractiveUI.hs | 9 |
9 files changed, 119 insertions, 207 deletions
diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index b41070b3bc..9e8d27bde0 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -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} + diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index d2fdc51bb1..15e488bd09 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -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 diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index b3f79605a1..491814f0c5 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -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 diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 82712e2741..e55d78e6fd 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -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 = [], diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index c6c3ed719a..9b47edb169 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -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 diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 65f0c0c1a8..488e65458c 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/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} diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 2e33e1f33d..0128f1809e 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -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 - 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 diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 2f821b3aae..0d20be2949 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -486,9 +486,6 @@ 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)) } diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index c576b6b5fb..8d6e23c678 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -144,7 +144,6 @@ 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), @@ -1488,14 +1487,6 @@ 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 |