Commit d20031d4 authored by Simon Marlow's avatar Simon Marlow
Browse files

Add parseExpr and compileParsedExpr and use them in GHC API and GHCi

Summary:
This commit brings following changes and fixes:

 * Implement parseExpr and compileParsedExpr;
 * Fix compileExpr and dynCompilerExpr, which returned `()` for empty expr;
 * Fix :def and :cmd, which didn't work if `IO` or `String` is not in scope;
 * Use GHCiMonad instead IO in :def and :cmd;
 * Clean PrelInfo: delete dead comment and duplicate entries, add assertion.

See new tests for more details.

Test Plan: ./validate

Reviewers: austin, dterei, simonmar

Reviewed By: simonmar

Subscribers: thomie, bgamari

Differential Revision: https://phabricator.haskell.org/D974

GHC Trac Issues: #10508
parent c14bd017
......@@ -99,7 +99,7 @@ module GHC (
-- ** Get/set the current context
parseImportDecl,
setContext, getContext,
setGHCiMonad,
setGHCiMonad, getGHCiMonad,
#endif
-- ** Inspecting the current context
getBindings, getInsts, getPrintUnqual,
......@@ -124,7 +124,8 @@ module GHC (
lookupName,
#ifdef GHCI
-- ** Compiling expressions
InteractiveEval.compileExpr, HValue, dynCompileExpr,
HValue, parseExpr, compileParsedExpr,
InteractiveEval.compileExpr, dynCompileExpr,
-- ** Other
runTcInteractive, -- Desired by some clients (Trac #8878)
......@@ -1457,6 +1458,10 @@ setGHCiMonad name = withSession $ \hsc_env -> do
let ic = (hsc_IC s) { ic_monad = ty }
in s { hsc_IC = ic }
-- | Get the monad GHCi lifts user statements into.
getGHCiMonad :: GhcMonad m => m Name
getGHCiMonad = fmap (ic_monad . hsc_IC) getSession
getHistorySpan :: GhcMonad m => History -> m SrcSpan
getHistorySpan h = withSession $ \hsc_env ->
return $ InteractiveEval.getHistorySpan hsc_env h
......
......@@ -68,9 +68,10 @@ module HscMain
, hscGetModuleInterface
, hscRnImportDecls
, hscTcRnLookupRdrName
, hscStmt, hscStmtWithLocation
, hscStmt, hscStmtWithLocation, hscParsedStmt
, hscDecls, hscDeclsWithLocation
, hscTcExpr, hscImport, hscKcType
, hscParseExpr
, hscCompileCoreExpr
-- * Low-level exports for hooks
, hscCompileCoreExpr'
......@@ -1409,30 +1410,36 @@ hscStmtWithLocation :: HscEnv
-> Int -- ^ Starting line
-> IO (Maybe ([Id], IO [HValue], FixityEnv))
hscStmtWithLocation hsc_env0 stmt source linenumber =
runInteractiveHsc hsc_env0 $ do
runInteractiveHsc hsc_env0 $ do
maybe_stmt <- hscParseStmtWithLocation source linenumber stmt
case maybe_stmt of
Nothing -> return Nothing
Just parsed_stmt -> do
-- Rename and typecheck it
hsc_env <- getHscEnv
(ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env parsed_stmt
-- Desugar it
ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr
liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr)
handleWarnings
Nothing -> return Nothing
-- Then code-gen, and link it
-- It's important NOT to have package 'interactive' as thisPackageKey
-- for linking, else we try to link 'main' and can't find it.
-- Whereas the linker already knows to ignore 'interactive'
let src_span = srcLocSpan interactiveSrcLoc
hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
let hval_io = unsafeCoerce# hval :: IO [HValue]
return $ Just (ids, hval_io, fix_env)
Just parsed_stmt -> do
hsc_env <- getHscEnv
liftIO $ hscParsedStmt hsc_env parsed_stmt
hscParsedStmt :: HscEnv
-> GhciLStmt RdrName -- ^ The parsed statement
-> IO (Maybe ([Id], IO [HValue], FixityEnv))
hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do
-- Rename and typecheck it
(ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env stmt
-- Desugar it
ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr
liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr)
handleWarnings
-- Then code-gen, and link it
-- It's important NOT to have package 'interactive' as thisPackageKey
-- for linking, else we try to link 'main' and can't find it.
-- Whereas the linker already knows to ignore 'interactive'
let src_span = srcLocSpan interactiveSrcLoc
hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
let hvals_io = unsafeCoerce# hval :: IO [HValue]
return $ Just (ids, hvals_io, fix_env)
-- | Compile a decls
hscDecls :: HscEnv
......@@ -1533,14 +1540,9 @@ hscTcExpr :: HscEnv
-> String -- ^ The expression
-> IO Type
hscTcExpr hsc_env0 expr = runInteractiveHsc hsc_env0 $ do
hsc_env <- getHscEnv
maybe_stmt <- hscParseStmt expr
case maybe_stmt of
Just (L _ (BodyStmt expr _ _ _)) ->
ioMsgMaybe $ tcRnExpr hsc_env expr
_ ->
throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan
(text "not an expression:" <+> quotes (text expr))
hsc_env <- getHscEnv
parsed_expr <- hscParseExpr expr
ioMsgMaybe $ tcRnExpr hsc_env parsed_expr
-- | Find the kind of a type
-- Currently this does *not* generalise the kinds of the type
......@@ -1554,6 +1556,15 @@ hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do
ty <- hscParseType str
ioMsgMaybe $ tcRnType hsc_env normalise ty
hscParseExpr :: String -> Hsc (LHsExpr RdrName)
hscParseExpr expr = do
hsc_env <- getHscEnv
maybe_stmt <- hscParseStmt expr
case maybe_stmt of
Just (L _ (BodyStmt expr _ _ _)) -> return expr
_ -> throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan
(text "not an expression:" <+> quotes (text expr))
hscParseStmt :: String -> Hsc (Maybe (GhciLStmt RdrName))
hscParseStmt = hscParseThing parseStmt
......
......@@ -33,6 +33,7 @@ module InteractiveEval (
parseName,
showModule,
isModuleInterpreted,
parseExpr, compileParsedExpr,
compileExpr, dynCompileExpr,
Term(..), obtainTermFromId, obtainTermFromVal, reconstructType,
-- * Depcreated API (remove in GHC 7.14)
......@@ -72,6 +73,7 @@ import Unique
import UniqSupply
import MonadUtils
import Module
import PrelNames ( toDynName )
import Panic
import UniqFM
import Maybes
......@@ -81,6 +83,7 @@ import BreakArray
import RtClosureInspect
import Outputable
import FastString
import Bag
import System.Mem.Weak
import System.Directory
......@@ -1002,45 +1005,49 @@ typeKind normalise str = withSession $ \hsc_env -> do
liftIO $ hscKcType hsc_env normalise str
-----------------------------------------------------------------------------
-- Compile an expression, run it and deliver the resulting HValue
-- Compile an expression, run it and deliver the result
-- | Parse an expression, the parsed expression can be further processed and
-- passed to compileParsedExpr.
parseExpr :: GhcMonad m => String -> m (LHsExpr RdrName)
parseExpr expr = withSession $ \hsc_env -> do
liftIO $ runInteractiveHsc hsc_env $ hscParseExpr expr
-- | Compile an expression, run it and deliver the resulting HValue.
compileExpr :: GhcMonad m => String -> m HValue
compileExpr expr = withSession $ \hsc_env -> do
Just (ids, hval, fix_env) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr)
compileExpr expr = do
parsed_expr <- parseExpr expr
compileParsedExpr parsed_expr
-- | Compile an parsed expression (before renaming), run it and deliver
-- the resulting HValue.
compileParsedExpr :: GhcMonad m => LHsExpr RdrName -> m HValue
compileParsedExpr expr@(L loc _) = withSession $ \hsc_env -> do
-- > let _compileParsedExpr = expr
-- Create let stmt from expr to make hscParsedStmt happy.
-- We will ignore the returned [Id], namely [expr_id], and not really
-- create a new binding.
let expr_fs = fsLit "_compileParsedExpr"
expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc
let_stmt = L loc . LetStmt . HsValBinds $
ValBindsIn (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) []
Just (ids, hvals_io, fix_env) <- liftIO $ hscParsedStmt hsc_env let_stmt
updateFixityEnv fix_env
hvals <- liftIO hval
case (ids,hvals) of
([_],[hv]) -> return hv
_ -> panic "compileExpr"
-- -----------------------------------------------------------------------------
-- Compile an expression, run it and return the result as a dynamic
hvals <- liftIO hvals_io
case (ids, hvals) of
([_expr_id], [hval]) -> return hval
_ -> panic "compileParsedExpr"
-- | Compile an expression, run it and return the result as a Dynamic.
dynCompileExpr :: GhcMonad m => String -> m Dynamic
dynCompileExpr expr = do
iis <- getContext
let importDecl = ImportDecl {
ideclSourceSrc = Nothing,
ideclName = noLoc (mkModuleName "Data.Dynamic"),
ideclPkgQual = Nothing,
ideclSource = False,
ideclSafe = False,
ideclQualified = True,
ideclImplicit = False,
ideclAs = Nothing,
ideclHiding = Nothing
}
setContext (IIDecl importDecl : iis)
let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
Just (ids, hvals, fix_env) <- withSession $ \hsc_env ->
liftIO $ hscStmt hsc_env stmt
setContext iis
updateFixityEnv fix_env
vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic])
case (ids,vals) of
(_:[], v:[]) -> return v
_ -> panic "dynCompileExpr"
parsed_expr <- parseExpr expr
-- > Data.Dynamic.toDyn expr
let loc = getLoc parsed_expr
to_dyn_expr = mkHsApp (L loc . HsVar $ getRdrName toDynName) parsed_expr
hval <- compileParsedExpr to_dyn_expr
return (unsafeCoerce# hval :: Dynamic)
-----------------------------------------------------------------------------
-- show a module and it's source/object filenames
......
......@@ -36,6 +36,8 @@ import TysWiredIn
import HscTypes
import Class
import TyCon
import Outputable
import UniqFM
import Util
import {-# SOURCE #-} TcTypeNats ( typeNatTyCons )
......@@ -53,13 +55,20 @@ import Data.Array
********************************************************************* -}
knownKeyNames :: [Name]
knownKeyNames
= map getName wiredInThings
++ cTupleTyConNames
++ basicKnownKeyNames
knownKeyNames =
ASSERT2( isNullUFM badNamesUFM, text "badknownKeyNames" <+> ppr badNamesUFM )
names
where
badNamesUFM = filterUFM (\ns -> length ns > 1) namesUFM
namesUFM = foldl (\m n -> addToUFM_Acc (:) singleton m n n) emptyUFM names
names = concat
[ map getName wiredInThings
, cTupleTyConNames
, basicKnownKeyNames
#ifdef GHCI
++ templateHaskellNames
, templateHaskellNames
#endif
]
{- *********************************************************************
* *
......
......@@ -170,12 +170,6 @@ isUnboundName name = name `hasKey` unboundKey
This section tells what the compiler knows about the association of
names with uniques. These ones are the *non* wired-in ones. The
wired in ones are defined in TysWiredIn etc.
The names for DPH can come from one of multiple backend packages. At the point where
'basicKnownKeyNames' is used, we don't know which backend it will be. Hence, we list
the names for multiple backends. That works out fine, although they use the same uniques,
as we are guaranteed to only load one backend; hence, only one of the different names
sharing a unique will be used.
-}
basicKnownKeyNames :: [Name]
......@@ -188,7 +182,6 @@ basicKnownKeyNames
stringTyConName,
ratioDataConName,
ratioTyConName,
integerTyConName,
-- Classes. *Must* include:
-- classes that are grabbed by key (e.g., eqClassKey)
......@@ -221,6 +214,8 @@ basicKnownKeyNames
mkAppTyName,
typeLitTypeRepName,
-- Dynamic
toDynName,
-- Numeric stuff
negateName, minusName, geName, eqName,
......@@ -247,8 +242,8 @@ basicKnownKeyNames
fmapName,
joinMName,
-- MonadRec stuff
mfixName,
-- MonadFix
monadFixClassName, mfixName,
-- Arrow stuff
arrAName, composeAName, firstAName,
......@@ -318,9 +313,6 @@ basicKnownKeyNames
rationalToFloatName,
rationalToDoubleName,
-- MonadFix
monadFixClassName, mfixName,
-- Other classes
randomClassName, randomGenClassName, monadPlusClassName,
......@@ -1038,7 +1030,9 @@ mkPolyTyConAppName = varQual tYPEABLE_INTERNAL (fsLit "mkPolyTyConApp") mkPol
mkAppTyName = varQual tYPEABLE_INTERNAL (fsLit "mkAppTy") mkAppTyKey
typeLitTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeLitTypeRep") typeLitTypeRepKey
-- Dynamic
toDynName :: Name
toDynName = varQual dYNAMIC (fsLit "toDyn") toDynIdKey
-- Class Data
dataClassName :: Name
......@@ -1887,6 +1881,9 @@ mkPolyTyConAppKey = mkPreludeMiscIdUnique 504
mkAppTyKey = mkPreludeMiscIdUnique 505
typeLitTypeRepKey = mkPreludeMiscIdUnique 506
-- Dynamic
toDynIdKey :: Unique
toDynIdKey = mkPreludeMiscIdUnique 507
{-
************************************************************************
......
......@@ -36,13 +36,15 @@ import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..),
TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,
handleSourceError )
import HsImpExp
import HsSyn
import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,
setInteractivePrintName )
import Module
import Name
import Packages ( trusted, getPackageDetails, listVisibleModuleNames, pprFlag )
import PprTyThing
import RdrName ( getGRE_NameQualifier_maybes )
import PrelNames
import RdrName ( RdrName, getGRE_NameQualifier_maybes, getRdrName )
import SrcLoc
import qualified Lexer
......@@ -1317,14 +1319,18 @@ defineMacro overwrite s = do
let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
-- give the expression a type signature, so we can be sure we're getting
-- something of the right type.
let new_expr = '(' : definition ++ ") :: String -> IO String"
-- compile the expression
handleSourceError (\e -> GHC.printException e) $
do
hv <- GHC.compileExpr new_expr
handleSourceError GHC.printException $ do
step <- getGhciStepIO
expr <- GHC.parseExpr definition
-- > ghciStepIO . definition :: String -> IO String
let stringTy = nlHsTyVar $ getRdrName stringTyConName
ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy
body = nlHsVar compose_RDR `mkHsApp` step `mkHsApp` expr
tySig = stringTy `nlHsFunTy` ioM
new_expr = L (getLoc expr) $ ExprWithTySig body tySig PlaceHolder
hv <- GHC.compileParsedExpr new_expr
liftIO (writeIORef macros_ref -- later defined macros have precedence
((macro_name, lift . runMacro hv, noCompletion) : filtered))
......@@ -1353,15 +1359,27 @@ undefineMacro str = mapM_ undef (words str)
-- :cmd
cmdCmd :: String -> GHCi ()
cmdCmd str = do
let expr = '(' : str ++ ") :: IO String"
handleSourceError (\e -> GHC.printException e) $
do
hv <- GHC.compileExpr expr
cmdCmd str = handleSourceError GHC.printException $ do
step <- getGhciStepIO
expr <- GHC.parseExpr str
-- > ghciStepIO str :: IO String
let new_expr = step `mkHsApp` expr
hv <- GHC.compileParsedExpr new_expr
cmds <- liftIO $ (unsafeCoerce# hv :: IO String)
enqueueCommands (lines cmds)
return ()
-- | Generate a typed ghciStepIO expression
-- @ghciStepIO :: Ty String -> IO String@.
getGhciStepIO :: GHCi (LHsExpr RdrName)
getGhciStepIO = do
ghciTyConName <- GHC.getGHCiMonad
let stringTy = nlHsTyVar $ getRdrName stringTyConName
ghciM = nlHsTyVar (getRdrName ghciTyConName) `nlHsAppTy` stringTy
ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy
body = nlHsVar (getRdrName ghciStepIoMName)
tySig = ghciM `nlHsFunTy` ioM
return $ noLoc $ ExprWithTySig body tySig PlaceHolder
-----------------------------------------------------------------------------
-- :check
......
......@@ -713,6 +713,7 @@ mk/ghcconfig*_inplace_bin_ghc-stage2.exe.mk
/tests/ghc-api/T8639_api
/tests/ghc-api/T9595
/tests/ghc-api/T10052/T10052
/tests/ghc-api/T10508_api
/tests/ghc-api/apirecomp001/myghc
/tests/ghc-api/dynCompileExpr/dynCompileExpr
/tests/ghc-api/ghcApi
......
module Main where
import DynFlags
import GHC
import Control.Monad (forM_)
import Control.Monad.IO.Class (liftIO)
import System.Environment (getArgs)
main :: IO ()
main = do
[libdir] <- getArgs
runGhc (Just libdir) $ do
dflags <- getSessionDynFlags
setSessionDynFlags $ dflags
`gopt_unset` Opt_ImplicitImportQualified
`xopt_unset` Opt_ImplicitPrelude
forM_ exprs $ \expr ->
handleSourceError printException $ do
dyn <- dynCompileExpr expr
liftIO $ print dyn
where
exprs =
[ ""
, "(),()"
, "()"
, "\"test\""
, unlines [ "[()]"
, " :: [()]"
]
]
<no location info>: error: not an expression: ‘’
<interactive>:1:3: error: parse error on input ‘,’
......@@ -8,4 +8,9 @@ test('T8639_api', normal,
test('T8628', normal,
run_command,
['$MAKE -s --no-print-directory T8628'])
test('T9595', extra_run_opts('"' + config.libdir + '"'), compile_and_run, ['-package ghc'])
test('T9595', extra_run_opts('"' + config.libdir + '"'),
compile_and_run,
['-package ghc'])
test('T10508_api', extra_run_opts('"' + config.libdir + '"'),
compile_and_run,
['-package ghc'])
-- :cmd accepts an expr of type 'IO String'
let cmd = return "0"
:cmd cmd
-- works with multiline mode, handles indention correctly
:{
:cmd return $ unlines
[ "1"
, "2"
]
:}
-- it should work even 'IO' or 'String' is not in scope
import Prelude ()
:cmd cmd
-- or even when a different 'String' is in scope
import Prelude
type String = ShowS
:def macro \_ -> return id
:macro
<interactive>:1:15:
Couldn't match type ‘a0 -> a0’ with ‘[Char]’
Expected type: Prelude.String
Actual type: a0 -> a0
Probable cause: ‘id’ is applied to too few arguments
In the first argument of ‘return’, namely ‘id’
In the expression: return id
\ No newline at end of file
0
1
2
0
unknown command ':macro'
use :? for help.
......@@ -221,3 +221,4 @@ test('T10110', normal, ghci_script, ['T10110.script'])
test('T10322', normal, ghci_script, ['T10322.script'])
test('T10466', normal, ghci_script, ['T10466.script'])
test('T10501', normal, ghci_script, ['T10501.script'])
test('T10508', normal, ghci_script, ['T10508.script'])
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