From 979785c489da00572b801450ead1114d33b7b2a4 Mon Sep 17 00:00:00 2001 From: David Terei Date: Tue, 24 Apr 2012 16:08:44 -0700 Subject: [PATCH] Add experimental GHCi monad. Modification of previous commit: e0e99f9948c1eac82cf69dd3cc30cb068e42d45e Allows setting which monad GHCi runs statements in. Unsupported at this stage. --- compiler/main/GHC.hs | 20 ++++++++++ compiler/main/HscMain.hs | 6 +++ compiler/main/HscTypes.lhs | 7 +++- compiler/prelude/PrelNames.lhs | 18 ++++++++- compiler/typecheck/TcRnDriver.lhs | 61 +++++++++++++++++++++++++++---- compiler/typecheck/TcRnMonad.lhs | 3 ++ 6 files changed, 105 insertions(+), 10 deletions(-) diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 15e488bd09..92ee0f4a44 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -122,6 +122,11 @@ module GHC ( #endif lookupName, +#ifdef GHCI + -- ** EXPERIMENTAL + setGHCiMonad, +#endif + -- * Abstract syntax elements -- ** Packages @@ -1330,6 +1335,21 @@ isModuleTrusted :: GhcMonad m => Module -> m Bool isModuleTrusted m = withSession $ \hsc_env -> liftIO $ hscCheckSafe hsc_env m noSrcSpan +-- | EXPERIMENTAL: DO NOT USE. +-- +-- 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. +{-# WARNING setGHCiMonad "This is experimental! Don't use." #-} +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..7c01de1c40 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,6 +975,11 @@ 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 @@ -1179,6 +1188,9 @@ selectorClassKey = mkPreludeClassUnique 41 singIClassNameKey, typeNatLeqClassNameKey :: Unique singIClassNameKey = mkPreludeClassUnique 42 typeNatLeqClassNameKey = mkPreludeClassUnique 43 + +ghciIoClassKey :: Unique +ghciIoClassKey = mkPreludeClassUnique 44 \end{code} %************************************************************************ @@ -1647,6 +1659,10 @@ guardMIdKey = mkPreludeMiscIdUnique 194 liftMIdKey = mkPreludeMiscIdUnique 195 mzipIdKey = mkPreludeMiscIdUnique 196 +-- GHCi +ghciStepIoMClassOpKey :: Unique +ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197 + ---------------- Template Haskell ------------------- -- USES IdUniques 200-499 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)) } -- GitLab