Commit 979785c4 authored by dterei's avatar dterei

Add experimental GHCi monad.

Modification of previous commit:
e0e99f99

Allows setting which monad GHCi runs statements in. Unsupported at this
stage.
parent 85c5dcf9
...@@ -122,6 +122,11 @@ module GHC ( ...@@ -122,6 +122,11 @@ module GHC (
#endif #endif
lookupName, lookupName,
#ifdef GHCI
-- ** EXPERIMENTAL
setGHCiMonad,
#endif
-- * Abstract syntax elements -- * Abstract syntax elements
-- ** Packages -- ** Packages
...@@ -1330,6 +1335,21 @@ isModuleTrusted :: GhcMonad m => Module -> m Bool ...@@ -1330,6 +1335,21 @@ isModuleTrusted :: GhcMonad m => Module -> m Bool
isModuleTrusted m = withSession $ \hsc_env -> isModuleTrusted m = withSession $ \hsc_env ->
liftIO $ hscCheckSafe hsc_env m noSrcSpan 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 :: GhcMonad m => History -> m SrcSpan
getHistorySpan h = withSession $ \hsc_env -> getHistorySpan h = withSession $ \hsc_env ->
return $ InteractiveEval.getHistorySpan hsc_env h return $ InteractiveEval.getHistorySpan hsc_env h
......
...@@ -62,6 +62,7 @@ module HscMain ...@@ -62,6 +62,7 @@ module HscMain
, hscTcRnGetInfo , hscTcRnGetInfo
, hscCheckSafe , hscCheckSafe
#ifdef GHCI #ifdef GHCI
, hscIsGHCiMonad
, hscGetModuleInterface , hscGetModuleInterface
, hscRnImportDecls , hscRnImportDecls
, hscTcRnLookupRdrName , hscTcRnLookupRdrName
...@@ -311,6 +312,11 @@ hscTcRnGetInfo hsc_env0 name = runInteractiveHsc hsc_env0 $ do ...@@ -311,6 +312,11 @@ hscTcRnGetInfo hsc_env0 name = runInteractiveHsc hsc_env0 $ do
ioMsgMaybe' $ tcRnGetInfo hsc_env name ioMsgMaybe' $ tcRnGetInfo hsc_env name
#ifdef GHCI #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 :: HscEnv -> Module -> IO ModIface
hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do
hsc_env <- getHscEnv hsc_env <- getHscEnv
......
...@@ -136,7 +136,7 @@ import Annotations ...@@ -136,7 +136,7 @@ import Annotations
import Class import Class
import TyCon import TyCon
import DataCon import DataCon
import PrelNames ( gHC_PRIM ) import PrelNames ( gHC_PRIM, ioTyConName )
import Packages hiding ( Version(..) ) import Packages hiding ( Version(..) )
import DynFlags import DynFlags
import DriverPhases import DriverPhases
...@@ -910,6 +910,9 @@ data InteractiveContext ...@@ -910,6 +910,9 @@ data InteractiveContext
-- ^ The 'DynFlags' used to evaluate interative expressions -- ^ The 'DynFlags' used to evaluate interative expressions
-- and statements. -- and statements.
ic_monad :: Name,
-- ^ The monad that GHCi is executing in
ic_imports :: [InteractiveImport], ic_imports :: [InteractiveImport],
-- ^ The GHCi context is extended with these imports -- ^ The GHCi context is extended with these imports
-- --
...@@ -973,6 +976,8 @@ hscDeclsWithLocation) and save them in ic_sys_vars. ...@@ -973,6 +976,8 @@ hscDeclsWithLocation) and save them in ic_sys_vars.
emptyInteractiveContext :: DynFlags -> InteractiveContext emptyInteractiveContext :: DynFlags -> InteractiveContext
emptyInteractiveContext dflags emptyInteractiveContext dflags
= InteractiveContext { ic_dflags = dflags, = InteractiveContext { ic_dflags = dflags,
-- IO monad by default
ic_monad = ioTyConName,
ic_imports = [], ic_imports = [],
ic_rn_gbl_env = emptyGlobalRdrEnv, ic_rn_gbl_env = emptyGlobalRdrEnv,
ic_tythings = [], ic_tythings = [],
......
...@@ -306,6 +306,9 @@ basicKnownKeyNames ...@@ -306,6 +306,9 @@ basicKnownKeyNames
, guardMName , guardMName
, liftMName , liftMName
, mzipName , mzipName
-- GHCi Sandbox
, ghciIoClassName, ghciStepIoMName
] ]
genericTyConNames :: [Name] genericTyConNames :: [Name]
...@@ -334,7 +337,7 @@ pRELUDE = mkBaseModule_ pRELUDE_NAME ...@@ -334,7 +337,7 @@ pRELUDE = mkBaseModule_ pRELUDE_NAME
gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_PRIM, gHC_TYPES, gHC_GENERICS,
gHC_MAGIC, 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_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER_TYPE, gHC_LIST,
gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE,
gHC_CONC, gHC_IO, gHC_IO_Exception, gHC_CONC, gHC_IO, gHC_IO_Exception,
...@@ -353,6 +356,7 @@ gHC_CLASSES = mkPrimModule (fsLit "GHC.Classes") ...@@ -353,6 +356,7 @@ gHC_CLASSES = mkPrimModule (fsLit "GHC.Classes")
gHC_BASE = mkBaseModule (fsLit "GHC.Base") gHC_BASE = mkBaseModule (fsLit "GHC.Base")
gHC_ENUM = mkBaseModule (fsLit "GHC.Enum") gHC_ENUM = mkBaseModule (fsLit "GHC.Enum")
gHC_GHCI = mkBaseModule (fsLit "GHC.GHCi")
gHC_SHOW = mkBaseModule (fsLit "GHC.Show") gHC_SHOW = mkBaseModule (fsLit "GHC.Show")
gHC_READ = mkBaseModule (fsLit "GHC.Read") gHC_READ = mkBaseModule (fsLit "GHC.Read")
gHC_NUM = mkBaseModule (fsLit "GHC.Num") gHC_NUM = mkBaseModule (fsLit "GHC.Num")
...@@ -971,6 +975,11 @@ datatypeClassName = clsQual gHC_GENERICS (fsLit "Datatype") datatypeClassKey ...@@ -971,6 +975,11 @@ datatypeClassName = clsQual gHC_GENERICS (fsLit "Datatype") datatypeClassKey
constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey
selectorClassName = clsQual gHC_GENERICS (fsLit "Selector") selectorClassKey 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 -- IO things
ioTyConName, ioDataConName, thenIOName, bindIOName, returnIOName, ioTyConName, ioDataConName, thenIOName, bindIOName, returnIOName,
failIOName :: Name failIOName :: Name
...@@ -1179,6 +1188,9 @@ selectorClassKey = mkPreludeClassUnique 41 ...@@ -1179,6 +1188,9 @@ selectorClassKey = mkPreludeClassUnique 41
singIClassNameKey, typeNatLeqClassNameKey :: Unique singIClassNameKey, typeNatLeqClassNameKey :: Unique
singIClassNameKey = mkPreludeClassUnique 42 singIClassNameKey = mkPreludeClassUnique 42
typeNatLeqClassNameKey = mkPreludeClassUnique 43 typeNatLeqClassNameKey = mkPreludeClassUnique 43
ghciIoClassKey :: Unique
ghciIoClassKey = mkPreludeClassUnique 44
\end{code} \end{code}
%************************************************************************ %************************************************************************
...@@ -1647,6 +1659,10 @@ guardMIdKey = mkPreludeMiscIdUnique 194 ...@@ -1647,6 +1659,10 @@ guardMIdKey = mkPreludeMiscIdUnique 194
liftMIdKey = mkPreludeMiscIdUnique 195 liftMIdKey = mkPreludeMiscIdUnique 195
mzipIdKey = mkPreludeMiscIdUnique 196 mzipIdKey = mkPreludeMiscIdUnique 196
-- GHCi
ghciStepIoMClassOpKey :: Unique
ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197
---------------- Template Haskell ------------------- ---------------- Template Haskell -------------------
-- USES IdUniques 200-499 -- USES IdUniques 200-499
......
...@@ -12,6 +12,7 @@ module TcRnDriver ( ...@@ -12,6 +12,7 @@ module TcRnDriver (
tcRnLookupRdrName, tcRnLookupRdrName,
getModuleInterface, getModuleInterface,
tcRnDeclsi, tcRnDeclsi,
isGHCiMonad,
#endif #endif
tcRnLookupName, tcRnLookupName,
tcRnGetInfo, tcRnGetInfo,
...@@ -24,6 +25,7 @@ module TcRnDriver ( ...@@ -24,6 +25,7 @@ module TcRnDriver (
import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
#endif #endif
import TypeRep
import DynFlags import DynFlags
import StaticFlags import StaticFlags
import HsSyn import HsSyn
...@@ -1286,6 +1288,7 @@ tcUserStmt :: LStmt RdrName -> TcM PlanResult ...@@ -1286,6 +1288,7 @@ tcUserStmt :: LStmt RdrName -> TcM PlanResult
tcUserStmt (L loc (ExprStmt expr _ _ _)) tcUserStmt (L loc (ExprStmt expr _ _ _))
= do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr) = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr)
-- Don't try to typecheck if the renamer fails! -- Don't try to typecheck if the renamer fails!
; ghciStep <- getGhciStepIO
; uniq <- newUnique ; uniq <- newUnique
; let fresh_it = itName uniq loc ; let fresh_it = itName uniq loc
matches = [mkMatch [] rn_expr emptyLocalBinds] matches = [mkMatch [] rn_expr emptyLocalBinds]
...@@ -1295,13 +1298,15 @@ tcUserStmt (L loc (ExprStmt expr _ _ _)) ...@@ -1295,13 +1298,15 @@ tcUserStmt (L loc (ExprStmt expr _ _ _))
-- free variables, and they in turn may have free type variables -- free variables, and they in turn may have free type variables
-- (if we are at a breakpoint, say). We must put those free vars -- (if we are at a breakpoint, say). We must put those free vars
-- [let it = expr] -- [let it = expr]
let_stmt = L loc $ LetStmt $ HsValBinds $ let_stmt = L loc $ LetStmt $ HsValBinds $
ValBindsOut [(NonRecursive,unitBag the_bind)] [] ValBindsOut [(NonRecursive,unitBag the_bind)] []
-- [it <- e] -- [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 (HsVar bindIOName) noSyntaxExpr
-- [; print it] -- [; print it]
print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it)) print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
(HsVar thenIOName) noSyntaxExpr placeHolderType (HsVar thenIOName) noSyntaxExpr placeHolderType
...@@ -1319,7 +1324,7 @@ tcUserStmt (L loc (ExprStmt expr _ _ _)) ...@@ -1319,7 +1324,7 @@ tcUserStmt (L loc (ExprStmt expr _ _ _))
-- Plan A -- Plan A
do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it] do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
; it_ty <- zonkTcType (idType it_id) ; it_ty <- zonkTcType (idType it_id)
; when (isUnitTy it_ty) failM ; when (isUnitTy $ it_ty) failM
; return stuff }, ; return stuff },
-- Plan B; a naked bind statment -- Plan B; a naked bind statment
...@@ -1343,20 +1348,26 @@ tcUserStmt rdr_stmt@(L loc _) ...@@ -1343,20 +1348,26 @@ tcUserStmt rdr_stmt@(L loc _)
; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs])
; rnDump (ppr rn_stmt) ; ; 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 ; opt_pr_flag <- doptM Opt_PrintBindResult
; let print_result_plan ; let print_result_plan
| opt_pr_flag -- The flag says "print result" | opt_pr_flag -- The flag says "print result"
, [v] <- collectLStmtBinders rn_stmt -- One binder , [v] <- collectLStmtBinders gi_stmt -- One binder
= [mk_print_result_plan rn_stmt v] = [mk_print_result_plan gi_stmt v]
| otherwise = [] | otherwise = []
-- The plans are: -- The plans are:
-- [stmt; print v] if one binder and not v::() -- [stmt; print v] if one binder and not v::()
-- [stmt] otherwise -- [stmt] otherwise
; runPlans (print_result_plan ++ [tcGhciStmts [rn_stmt]]) } ; runPlans (print_result_plan ++ [tcGhciStmts [gi_stmt]]) }
where where
mk_print_result_plan rn_stmt v mk_print_result_plan stmt v
= do { stuff@([v_id], _) <- tcGhciStmts [rn_stmt, print_v] = do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
; v_ty <- zonkTcType (idType v_id) ; v_ty <- zonkTcType (idType v_id)
; when (isUnitTy v_ty || not (isTauTy v_ty)) failM ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM
; return stuff } ; return stuff }
...@@ -1411,6 +1422,40 @@ tcGhciStmts stmts ...@@ -1411,6 +1422,40 @@ tcGhciStmts stmts
return (ids, mkHsDictLet (EvBinds const_binds) $ return (ids, mkHsDictLet (EvBinds const_binds) $
noLoc (HsDo GhciStmt stmts io_ret_ty)) 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} \end{code}
tcRnExpr just finds the type of an expression tcRnExpr just finds the type of an expression
......
...@@ -486,6 +486,9 @@ setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_ins ...@@ -486,6 +486,9 @@ setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_ins
getIsGHCi :: TcRn Bool getIsGHCi :: TcRn Bool
getIsGHCi = do { mod <- getModule; return (mod == iNTERACTIVE) } getIsGHCi = do { mod <- getModule; return (mod == iNTERACTIVE) }
getGHCiMonad :: TcRn Name
getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) }
tcIsHsBoot :: TcRn Bool tcIsHsBoot :: TcRn Bool
tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) } tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) }
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment