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 ( ...@@ -99,7 +99,7 @@ module GHC (
-- ** Get/set the current context -- ** Get/set the current context
parseImportDecl, parseImportDecl,
setContext, getContext, setContext, getContext,
setGHCiMonad, setGHCiMonad, getGHCiMonad,
#endif #endif
-- ** Inspecting the current context -- ** Inspecting the current context
getBindings, getInsts, getPrintUnqual, getBindings, getInsts, getPrintUnqual,
...@@ -124,7 +124,8 @@ module GHC ( ...@@ -124,7 +124,8 @@ module GHC (
lookupName, lookupName,
#ifdef GHCI #ifdef GHCI
-- ** Compiling expressions -- ** Compiling expressions
InteractiveEval.compileExpr, HValue, dynCompileExpr, HValue, parseExpr, compileParsedExpr,
InteractiveEval.compileExpr, dynCompileExpr,
-- ** Other -- ** Other
runTcInteractive, -- Desired by some clients (Trac #8878) runTcInteractive, -- Desired by some clients (Trac #8878)
...@@ -1457,6 +1458,10 @@ setGHCiMonad name = withSession $ \hsc_env -> do ...@@ -1457,6 +1458,10 @@ setGHCiMonad name = withSession $ \hsc_env -> do
let ic = (hsc_IC s) { ic_monad = ty } let ic = (hsc_IC s) { ic_monad = ty }
in s { hsc_IC = ic } 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 :: 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
......
...@@ -68,9 +68,10 @@ module HscMain ...@@ -68,9 +68,10 @@ module HscMain
, hscGetModuleInterface , hscGetModuleInterface
, hscRnImportDecls , hscRnImportDecls
, hscTcRnLookupRdrName , hscTcRnLookupRdrName
, hscStmt, hscStmtWithLocation , hscStmt, hscStmtWithLocation, hscParsedStmt
, hscDecls, hscDeclsWithLocation , hscDecls, hscDeclsWithLocation
, hscTcExpr, hscImport, hscKcType , hscTcExpr, hscImport, hscKcType
, hscParseExpr
, hscCompileCoreExpr , hscCompileCoreExpr
-- * Low-level exports for hooks -- * Low-level exports for hooks
, hscCompileCoreExpr' , hscCompileCoreExpr'
...@@ -1409,30 +1410,36 @@ hscStmtWithLocation :: HscEnv ...@@ -1409,30 +1410,36 @@ hscStmtWithLocation :: HscEnv
-> Int -- ^ Starting line -> Int -- ^ Starting line
-> IO (Maybe ([Id], IO [HValue], FixityEnv)) -> IO (Maybe ([Id], IO [HValue], FixityEnv))
hscStmtWithLocation hsc_env0 stmt source linenumber = hscStmtWithLocation hsc_env0 stmt source linenumber =
runInteractiveHsc hsc_env0 $ do runInteractiveHsc hsc_env0 $ do
maybe_stmt <- hscParseStmtWithLocation source linenumber stmt maybe_stmt <- hscParseStmtWithLocation source linenumber stmt
case maybe_stmt of case maybe_stmt of
Nothing -> return Nothing 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
-- Then code-gen, and link it Just parsed_stmt -> do
-- It's important NOT to have package 'interactive' as thisPackageKey hsc_env <- getHscEnv
-- for linking, else we try to link 'main' and can't find it. liftIO $ hscParsedStmt hsc_env parsed_stmt
-- Whereas the linker already knows to ignore 'interactive'
let src_span = srcLocSpan interactiveSrcLoc hscParsedStmt :: HscEnv
hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr -> GhciLStmt RdrName -- ^ The parsed statement
let hval_io = unsafeCoerce# hval :: IO [HValue] -> IO (Maybe ([Id], IO [HValue], FixityEnv))
hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do
return $ Just (ids, hval_io, fix_env) -- 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 -- | Compile a decls
hscDecls :: HscEnv hscDecls :: HscEnv
...@@ -1533,14 +1540,9 @@ hscTcExpr :: HscEnv ...@@ -1533,14 +1540,9 @@ hscTcExpr :: HscEnv
-> String -- ^ The expression -> String -- ^ The expression
-> IO Type -> IO Type
hscTcExpr hsc_env0 expr = runInteractiveHsc hsc_env0 $ do hscTcExpr hsc_env0 expr = runInteractiveHsc hsc_env0 $ do
hsc_env <- getHscEnv hsc_env <- getHscEnv
maybe_stmt <- hscParseStmt expr parsed_expr <- hscParseExpr expr
case maybe_stmt of ioMsgMaybe $ tcRnExpr hsc_env parsed_expr
Just (L _ (BodyStmt expr _ _ _)) ->
ioMsgMaybe $ tcRnExpr hsc_env expr
_ ->
throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan
(text "not an expression:" <+> quotes (text expr))
-- | Find the kind of a type -- | Find the kind of a type
-- Currently this does *not* generalise the kinds of the type -- Currently this does *not* generalise the kinds of the type
...@@ -1554,6 +1556,15 @@ hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do ...@@ -1554,6 +1556,15 @@ hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do
ty <- hscParseType str ty <- hscParseType str
ioMsgMaybe $ tcRnType hsc_env normalise ty 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 :: String -> Hsc (Maybe (GhciLStmt RdrName))
hscParseStmt = hscParseThing parseStmt hscParseStmt = hscParseThing parseStmt
......
...@@ -33,6 +33,7 @@ module InteractiveEval ( ...@@ -33,6 +33,7 @@ module InteractiveEval (
parseName, parseName,
showModule, showModule,
isModuleInterpreted, isModuleInterpreted,
parseExpr, compileParsedExpr,
compileExpr, dynCompileExpr, compileExpr, dynCompileExpr,
Term(..), obtainTermFromId, obtainTermFromVal, reconstructType, Term(..), obtainTermFromId, obtainTermFromVal, reconstructType,
-- * Depcreated API (remove in GHC 7.14) -- * Depcreated API (remove in GHC 7.14)
...@@ -72,6 +73,7 @@ import Unique ...@@ -72,6 +73,7 @@ import Unique
import UniqSupply import UniqSupply
import MonadUtils import MonadUtils
import Module import Module
import PrelNames ( toDynName )
import Panic import Panic
import UniqFM import UniqFM
import Maybes import Maybes
...@@ -81,6 +83,7 @@ import BreakArray ...@@ -81,6 +83,7 @@ import BreakArray
import RtClosureInspect import RtClosureInspect
import Outputable import Outputable
import FastString import FastString
import Bag
import System.Mem.Weak import System.Mem.Weak
import System.Directory import System.Directory
...@@ -1002,45 +1005,49 @@ typeKind normalise str = withSession $ \hsc_env -> do ...@@ -1002,45 +1005,49 @@ typeKind normalise str = withSession $ \hsc_env -> do
liftIO $ hscKcType hsc_env normalise str 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 :: GhcMonad m => String -> m HValue
compileExpr expr = withSession $ \hsc_env -> do compileExpr expr = do
Just (ids, hval, fix_env) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr) 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 updateFixityEnv fix_env
hvals <- liftIO hval hvals <- liftIO hvals_io
case (ids,hvals) of case (ids, hvals) of
([_],[hv]) -> return hv ([_expr_id], [hval]) -> return hval
_ -> panic "compileExpr" _ -> panic "compileParsedExpr"
-- -----------------------------------------------------------------------------
-- Compile an expression, run it and return the result as a dynamic
-- | Compile an expression, run it and return the result as a Dynamic.
dynCompileExpr :: GhcMonad m => String -> m Dynamic dynCompileExpr :: GhcMonad m => String -> m Dynamic
dynCompileExpr expr = do dynCompileExpr expr = do
iis <- getContext parsed_expr <- parseExpr expr
let importDecl = ImportDecl { -- > Data.Dynamic.toDyn expr
ideclSourceSrc = Nothing, let loc = getLoc parsed_expr
ideclName = noLoc (mkModuleName "Data.Dynamic"), to_dyn_expr = mkHsApp (L loc . HsVar $ getRdrName toDynName) parsed_expr
ideclPkgQual = Nothing, hval <- compileParsedExpr to_dyn_expr
ideclSource = False, return (unsafeCoerce# hval :: Dynamic)
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"
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- show a module and it's source/object filenames -- show a module and it's source/object filenames
......
...@@ -36,6 +36,8 @@ import TysWiredIn ...@@ -36,6 +36,8 @@ import TysWiredIn
import HscTypes import HscTypes
import Class import Class
import TyCon import TyCon
import Outputable
import UniqFM
import Util import Util
import {-# SOURCE #-} TcTypeNats ( typeNatTyCons ) import {-# SOURCE #-} TcTypeNats ( typeNatTyCons )
...@@ -53,13 +55,20 @@ import Data.Array ...@@ -53,13 +55,20 @@ import Data.Array
********************************************************************* -} ********************************************************************* -}
knownKeyNames :: [Name] knownKeyNames :: [Name]
knownKeyNames knownKeyNames =
= map getName wiredInThings ASSERT2( isNullUFM badNamesUFM, text "badknownKeyNames" <+> ppr badNamesUFM )
++ cTupleTyConNames names
++ basicKnownKeyNames 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 #ifdef GHCI
++ templateHaskellNames , templateHaskellNames
#endif #endif
]
{- ********************************************************************* {- *********************************************************************
* * * *
......
...@@ -170,12 +170,6 @@ isUnboundName name = name `hasKey` unboundKey ...@@ -170,12 +170,6 @@ isUnboundName name = name `hasKey` unboundKey
This section tells what the compiler knows about the association of This section tells what the compiler knows about the association of
names with uniques. These ones are the *non* wired-in ones. The names with uniques. These ones are the *non* wired-in ones. The
wired in ones are defined in TysWiredIn etc. 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] basicKnownKeyNames :: [Name]
...@@ -188,7 +182,6 @@ basicKnownKeyNames ...@@ -188,7 +182,6 @@ basicKnownKeyNames
stringTyConName, stringTyConName,
ratioDataConName, ratioDataConName,
ratioTyConName, ratioTyConName,
integerTyConName,
-- Classes. *Must* include: -- Classes. *Must* include:
-- classes that are grabbed by key (e.g., eqClassKey) -- classes that are grabbed by key (e.g., eqClassKey)
...@@ -221,6 +214,8 @@ basicKnownKeyNames ...@@ -221,6 +214,8 @@ basicKnownKeyNames
mkAppTyName, mkAppTyName,
typeLitTypeRepName, typeLitTypeRepName,
-- Dynamic
toDynName,
-- Numeric stuff -- Numeric stuff
negateName, minusName, geName, eqName, negateName, minusName, geName, eqName,
...@@ -247,8 +242,8 @@ basicKnownKeyNames ...@@ -247,8 +242,8 @@ basicKnownKeyNames
fmapName, fmapName,
joinMName, joinMName,
-- MonadRec stuff -- MonadFix
mfixName, monadFixClassName, mfixName,
-- Arrow stuff -- Arrow stuff
arrAName, composeAName, firstAName, arrAName, composeAName, firstAName,
...@@ -318,9 +313,6 @@ basicKnownKeyNames ...@@ -318,9 +313,6 @@ basicKnownKeyNames
rationalToFloatName, rationalToFloatName,
rationalToDoubleName, rationalToDoubleName,
-- MonadFix
monadFixClassName, mfixName,
-- Other classes -- Other classes
randomClassName, randomGenClassName, monadPlusClassName, randomClassName, randomGenClassName, monadPlusClassName,
...@@ -1038,7 +1030,9 @@ mkPolyTyConAppName = varQual tYPEABLE_INTERNAL (fsLit "mkPolyTyConApp") mkPol ...@@ -1038,7 +1030,9 @@ mkPolyTyConAppName = varQual tYPEABLE_INTERNAL (fsLit "mkPolyTyConApp") mkPol
mkAppTyName = varQual tYPEABLE_INTERNAL (fsLit "mkAppTy") mkAppTyKey mkAppTyName = varQual tYPEABLE_INTERNAL (fsLit "mkAppTy") mkAppTyKey
typeLitTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeLitTypeRep") typeLitTypeRepKey typeLitTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeLitTypeRep") typeLitTypeRepKey
-- Dynamic
toDynName :: Name
toDynName = varQual dYNAMIC (fsLit "toDyn") toDynIdKey
-- Class Data -- Class Data
dataClassName :: Name dataClassName :: Name
...@@ -1887,6 +1881,9 @@ mkPolyTyConAppKey = mkPreludeMiscIdUnique 504 ...@@ -1887,6 +1881,9 @@ mkPolyTyConAppKey = mkPreludeMiscIdUnique 504
mkAppTyKey = mkPreludeMiscIdUnique 505 mkAppTyKey = mkPreludeMiscIdUnique 505
typeLitTypeRepKey = mkPreludeMiscIdUnique 506 typeLitTypeRepKey = mkPreludeMiscIdUnique 506
-- Dynamic
toDynIdKey :: Unique
toDynIdKey = mkPreludeMiscIdUnique 507
{- {-
************************************************************************ ************************************************************************
......
...@@ -36,13 +36,15 @@ import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..), ...@@ -36,13 +36,15 @@ import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..),
TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc, TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,
handleSourceError ) handleSourceError )
import HsImpExp import HsImpExp
import HsSyn
import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC, import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,
setInteractivePrintName ) setInteractivePrintName )
import Module import Module
import Name import Name
import Packages ( trusted, getPackageDetails, listVisibleModuleNames, pprFlag ) import Packages ( trusted, getPackageDetails, listVisibleModuleNames, pprFlag )
import PprTyThing import PprTyThing
import RdrName ( getGRE_NameQualifier_maybes ) import PrelNames
import RdrName ( RdrName, getGRE_NameQualifier_maybes, getRdrName )
import SrcLoc import SrcLoc
import qualified Lexer import qualified Lexer
...@@ -1317,14 +1319,18 @@ defineMacro overwrite s = do ...@@ -1317,14 +1319,18 @@ defineMacro overwrite s = do
let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ] 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 -- compile the expression
handleSourceError (\e -> GHC.printException e) $ handleSourceError GHC.printException $ do
do step <- getGhciStepIO
hv <- GHC.compileExpr new_expr 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 liftIO (writeIORef macros_ref -- later defined macros have precedence
((macro_name, lift . runMacro hv, noCompletion) : filtered)) ((macro_name, lift . runMacro hv, noCompletion) : filtered))
...@@ -1353,15 +1359,27 @@ undefineMacro str = mapM_ undef (words str) ...@@ -1353,15 +1359,27 @@ undefineMacro str = mapM_ undef (words str)
-- :cmd -- :cmd
cmdCmd :: String -> GHCi () cmdCmd :: String -> GHCi ()
cmdCmd str = do cmdCmd str = handleSourceError GHC.printException $ do
let expr = '(' : str ++ ") :: IO String" step <- getGhciStepIO
handleSourceError (\e -> GHC.printException e) $ expr <- GHC.parseExpr str
do -- > ghciStepIO str :: IO String
hv <- GHC.compileExpr expr let new_expr = step `mkHsApp` expr
hv <- GHC.compileParsedExpr new_expr
cmds <- liftIO $ (unsafeCoerce# hv :: IO String) cmds <- liftIO $ (unsafeCoerce# hv :: IO String)
enqueueCommands (lines cmds) 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 -- :check
......
...@@ -713,6 +713,7 @@ mk/ghcconfig*_inplace_bin_ghc-stage2.exe.mk ...@@ -713,6 +713,7 @@ mk/ghcconfig*_inplace_bin_ghc-stage2.exe.mk
/tests/ghc-api/T8639_api /tests/ghc-api/T8639_api
/tests/ghc-api/T9595 /tests/ghc-api/T9595
/tests/ghc-api/T10052/T10052 /tests/ghc-api/T10052/T10052
/tests/ghc-api/T10508_api
/tests/ghc-api/apirecomp001/myghc /tests/ghc-api/apirecomp001/myghc
/tests/ghc-api/dynCompileExpr/dynCompileExpr /tests/ghc-api/dynCompileExpr/dynCompileExpr
/tests/ghc-api/ghcApi /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, ...@@ -8,4 +8,9 @@ test('T8639_api', normal,
test('T8628', normal, test('T8628', normal,
run_command, run_command,
['$MAKE -s --no-print-directory T8628']) ['$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'])