diff options
| -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, 207 insertions, 119 deletions
diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index 9e8d27bde0..b41070b3bc 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -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} - diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 15e488bd09..d2fdc51bb1 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -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 diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 491814f0c5..b3f79605a1 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -62,6 +62,7 @@ module HscMain , hscTcRnGetInfo , hscCheckSafe #ifdef GHCI + , hscIsGHCiMonad , hscGetModuleInterface , hscRnImportDecls , hscTcRnLookupRdrName @@ -311,6 +312,11 @@ hscTcRnGetInfo hsc_env0 name = runInteractiveHsc hsc_env0 $ do ioMsgMaybe' $ tcRnGetInfo hsc_env name #ifdef GHCI +hscIsGHCiMonad :: HscEnv -> String -> IO Name +hscIsGHCiMonad hsc_env name = + let icntxt = hsc_IC hsc_env + in runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env icntxt name + hscGetModuleInterface :: HscEnv -> Module -> IO ModIface hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do hsc_env <- getHscEnv diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index e55d78e6fd..82712e2741 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 ) +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 = [], diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 9b47edb169..c6c3ed719a 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -306,6 +306,9 @@ basicKnownKeyNames , guardMName , liftMName , mzipName + + -- GHCi Sandbox + , ghciIoClassName, ghciStepIoMName ] genericTyConNames :: [Name] @@ -334,7 +337,7 @@ pRELUDE = mkBaseModule_ pRELUDE_NAME gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC, - gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_CSTRING, + gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING, gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER_TYPE, gHC_LIST, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, gHC_CONC, gHC_IO, gHC_IO_Exception, @@ -353,6 +356,7 @@ gHC_CLASSES = mkPrimModule (fsLit "GHC.Classes") gHC_BASE = mkBaseModule (fsLit "GHC.Base") gHC_ENUM = mkBaseModule (fsLit "GHC.Enum") +gHC_GHCI = mkBaseModule (fsLit "GHC.GHCi") gHC_SHOW = mkBaseModule (fsLit "GHC.Show") gHC_READ = mkBaseModule (fsLit "GHC.Read") gHC_NUM = mkBaseModule (fsLit "GHC.Num") @@ -971,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 diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 488e65458c..65f0c0c1a8 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 0128f1809e..2e33e1f33d 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -12,6 +12,7 @@ module TcRnDriver ( tcRnLookupRdrName, getModuleInterface, tcRnDeclsi, + isGHCiMonad, #endif tcRnLookupName, tcRnGetInfo, @@ -24,6 +25,7 @@ module TcRnDriver ( import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) #endif +import TypeRep import DynFlags import StaticFlags import HsSyn @@ -1286,6 +1288,7 @@ tcUserStmt :: LStmt RdrName -> TcM PlanResult tcUserStmt (L loc (ExprStmt expr _ _ _)) = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr) -- Don't try to typecheck if the renamer fails! + ; ghciStep <- getGhciStepIO ; uniq <- newUnique ; let fresh_it = itName uniq loc matches = [mkMatch [] rn_expr emptyLocalBinds] @@ -1295,13 +1298,15 @@ tcUserStmt (L loc (ExprStmt expr _ _ _)) -- free variables, and they in turn may have free type variables -- (if we are at a breakpoint, say). We must put those free vars - -- [let it = expr] let_stmt = L loc $ LetStmt $ HsValBinds $ ValBindsOut [(NonRecursive,unitBag the_bind)] [] + -- [it <- e] - bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it)) rn_expr + bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it)) + (nlHsApp ghciStep rn_expr) (HsVar bindIOName) noSyntaxExpr + -- [; print it] print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it)) (HsVar thenIOName) noSyntaxExpr placeHolderType @@ -1319,7 +1324,7 @@ tcUserStmt (L loc (ExprStmt expr _ _ _)) -- Plan A do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it] ; it_ty <- zonkTcType (idType it_id) - ; when (isUnitTy it_ty) failM + ; when (isUnitTy $ it_ty) failM ; return stuff }, -- Plan B; a naked bind statment @@ -1343,20 +1348,26 @@ tcUserStmt rdr_stmt@(L loc _) ; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ; rnDump (ppr rn_stmt) ; + ; ghciStep <- getGhciStepIO + ; let gi_stmt + | (L loc (BindStmt pat expr op1 op2)) <- rn_stmt + = L loc $ BindStmt pat (nlHsApp ghciStep expr) op1 op2 + | otherwise = rn_stmt + ; opt_pr_flag <- doptM Opt_PrintBindResult ; let print_result_plan | opt_pr_flag -- The flag says "print result" - , [v] <- collectLStmtBinders rn_stmt -- One binder - = [mk_print_result_plan rn_stmt v] + , [v] <- collectLStmtBinders gi_stmt -- One binder + = [mk_print_result_plan gi_stmt v] | otherwise = [] -- The plans are: -- [stmt; print v] if one binder and not v::() -- [stmt] otherwise - ; runPlans (print_result_plan ++ [tcGhciStmts [rn_stmt]]) } + ; runPlans (print_result_plan ++ [tcGhciStmts [gi_stmt]]) } where - mk_print_result_plan rn_stmt v - = do { stuff@([v_id], _) <- tcGhciStmts [rn_stmt, print_v] + mk_print_result_plan stmt v + = do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v] ; v_ty <- zonkTcType (idType v_id) ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM ; return stuff } @@ -1411,6 +1422,40 @@ tcGhciStmts stmts return (ids, mkHsDictLet (EvBinds const_binds) $ noLoc (HsDo GhciStmt stmts io_ret_ty)) } + +-- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a) +getGhciStepIO :: TcM (LHsExpr Name) +getGhciStepIO = do + ghciTy <- getGHCiMonad + fresh_a <- newUnique + let a_tv = mkTcTyVarName fresh_a (fsLit "a") + ghciM = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv) + ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv) + stepTy = noLoc $ HsForAllTy Implicit + ([noLoc $ UserTyVar a_tv]) + (noLoc []) + (nlHsFunTy ghciM ioM) + step = noLoc $ ExprWithTySig (nlHsVar ghciStepIoMName) stepTy + return step + +isGHCiMonad :: HscEnv -> InteractiveContext -> String -> IO (Messages, Maybe Name) +isGHCiMonad hsc_env ictxt ty + = initTcPrintErrors hsc_env iNTERACTIVE $ + setInteractiveContext hsc_env ictxt $ do + rdrEnv <- getGlobalRdrEnv + let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty) + case occIO of + Just [n] -> do + let name = gre_name n + ghciClass <- tcLookupClass ghciIoClassName + userTyCon <- tcLookupTyCon name + let userTy = TyConApp userTyCon [] + _ <- tcLookupInstance ghciClass [userTy] + return name + + Just _ -> failWithTc $ text "Ambigous type!" + Nothing -> failWithTc $ text ("Can't find type:" ++ ty) + \end{code} tcRnExpr just finds the type of an expression diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 0d20be2949..2f821b3aae 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -486,6 +486,9 @@ setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_ins getIsGHCi :: TcRn Bool getIsGHCi = do { mod <- getModule; return (mod == iNTERACTIVE) } +getGHCiMonad :: TcRn Name +getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) } + tcIsHsBoot :: TcRn Bool tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) } diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 8d6e23c678..c576b6b5fb 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -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 |