Commit 2110037e authored by roshats's avatar roshats Committed by Ben Gamari
Browse files

Add isImport, isDecl, and isStmt functions to GHC API

Reviewers: austin, thomie, bgamari

Reviewed By: thomie, bgamari

Subscribers: mpickering, thomie

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

GHC Trac Issues: #9015
parent 91e985cd
......@@ -130,6 +130,7 @@ module GHC (
-- ** Other
runTcInteractive, -- Desired by some clients (Trac #8878)
isStmt, isImport, isDecl,
-- ** The debugger
SingleStep(..),
......
......@@ -14,6 +14,7 @@ module InteractiveEval (
Status(..), Resume(..), History(..),
execStmt, ExecOptions(..), execOptions, ExecResult(..), resumeExec,
runDecls, runDeclsWithLocation,
isStmt, isImport, isDecl,
parseImportDecl, SingleStep(..),
resume,
abandon, abandonAll,
......@@ -84,12 +85,15 @@ import RtClosureInspect
import Outputable
import FastString
import Bag
import qualified Lexer (P (..), ParseResult(..), unP, mkPState)
import qualified Parser (parseStmt, parseModule, parseDeclaration)
import System.Mem.Weak
import System.Directory
import Data.Dynamic
import Data.Either
import Data.List (find)
import StringBuffer (stringToStringBuffer)
import Control.Monad
#if __GLASGOW_HASKELL__ >= 709
import Foreign
......@@ -986,6 +990,39 @@ parseName str = withSession $ \hsc_env -> liftIO $
do { lrdr_name <- hscParseIdentifier hsc_env str
; hscTcRnLookupRdrName hsc_env lrdr_name }
-- | Returns @True@ if passed string is a statement.
isStmt :: DynFlags -> String -> Bool
isStmt dflags stmt =
case parseThing Parser.parseStmt dflags stmt of
Lexer.POk _ _ -> True
Lexer.PFailed _ _ -> False
-- | Returns @True@ if passed string is an import declaration.
isImport :: DynFlags -> String -> Bool
isImport dflags stmt =
case parseThing Parser.parseModule dflags stmt of
Lexer.POk _ thing -> hasImports thing
Lexer.PFailed _ _ -> False
where
hasImports = not . null . hsmodImports . unLoc
-- | Returns @True@ if passed string is a declaration but __/not a splice/__.
isDecl :: DynFlags -> String -> Bool
isDecl dflags stmt = do
case parseThing Parser.parseDeclaration dflags stmt of
Lexer.POk _ thing ->
case unLoc thing of
SpliceD _ -> False
_ -> True
Lexer.PFailed _ _ -> False
parseThing :: Lexer.P thing -> DynFlags -> String -> Lexer.ParseResult thing
parseThing parser dflags stmt = do
let buf = stringToStringBuffer stmt
loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
Lexer.unP parser (Lexer.mkPState dflags buf loc)
-- -----------------------------------------------------------------------------
-- Getting the type of an expression
......
......@@ -359,6 +359,8 @@ ghc
`startsVarSymASCII`, and `isVarSymChar` from `Lexeme` to the `GHC.Lemexe`
module of the `ghc-boot` library.
- Add `isImport`, `isDecl`, and `isStmt` functions.
ghc-boot
~~~~~~~~
......
......@@ -19,7 +19,7 @@ module GhciMonad (
TickArray,
getDynFlags,
isStmt, runStmt, runDecls, resume, timeIt, recordBreak, revertCAFs,
runStmt, runDecls, resume, timeIt, recordBreak, revertCAFs,
printForUser, printForUserPartWay, prettyLocations,
initInterpBuffering, turnOffBuffering, flushInterpBuffers,
......@@ -50,10 +50,6 @@ import System.IO
import Control.Monad
import GHC.Exts
import qualified Lexer (ParseResult(..), unP, mkPState)
import qualified Parser (parseStmt)
import StringBuffer (stringToStringBuffer)
import System.Console.Haskeline (CompletionFunc, InputT)
import qualified System.Console.Haskeline as Haskeline
import Control.Monad.Trans.Class
......@@ -266,19 +262,6 @@ printForUserPartWay doc = do
dflags <- getDynFlags
liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc
isStmt :: String -> GHCi Bool
isStmt stmt = do
st <- getGHCiState
dflags <- GHC.getInteractiveDynFlags
let buf = stringToStringBuffer stmt
loc = mkRealSrcLoc (fsLit "<interactive>") (line_number st) 1
parser = Parser.parseStmt
case Lexer.unP parser (Lexer.mkPState dflags buf loc) of
Lexer.POk _ _ -> return True
Lexer.PFailed _ _ -> return False
-- | Run a single Haskell expression
runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.ExecResult)
runStmt expr step = do
......
{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, TupleSections,
RecordWildCards #-}
RecordWildCards, MultiWayIf #-}
{-# OPTIONS -fno-cse #-}
-- -fno-cse is needed for GLOBAL_VAR's to behave properly
......@@ -900,23 +900,17 @@ enqueueCommands cmds = do
-- | Entry point to execute some haskell code from user.
-- The return value True indicates success, as in `runOneCommand`.
runStmt :: String -> SingleStep -> GHCi (Maybe GHC.ExecResult)
runStmt stmt step
-- empty; this should be impossible anyways since we filtered out
-- whitespace-only input in runOneCommand's noSpace
| null (filter (not.isSpace) stmt)
= return Nothing
-- import
| stmt `looks_like` "import "
= do addImportToContext stmt; return (Just (GHC.ExecComplete (Right []) 0))
| otherwise
= do
parse_res <- GhciMonad.isStmt stmt
if parse_res
then run_stmt
else run_decl
runStmt stmt step = do
dflags <- GHC.getInteractiveDynFlags
if | GHC.isStmt dflags stmt -> run_stmt
| GHC.isImport dflags stmt -> run_imports
| otherwise -> run_decl
where
run_imports = do
addImportToContext stmt
return (Just (GHC.ExecComplete (Right []) 0))
run_decl =
do _ <- liftIO $ tryIO $ hFlushAll stdin
m_result <- GhciMonad.runDecls stmt
......@@ -938,11 +932,6 @@ runStmt stmt step
Nothing -> return Nothing
Just result -> Just <$> afterRunStmt (const True) result
s `looks_like` prefix = prefix `isPrefixOf` dropWhile isSpace s
-- Ignore leading spaces (see Trac #9914), so that
-- ghci> data T = T
-- (note leading spaces) works properly
-- | Clean up the GHCi environment after a statement has run
afterRunStmt :: (SrcSpan -> Bool) -> GHC.ExecResult -> GHCi GHC.ExecResult
afterRunStmt step_here run_result = do
......
......@@ -750,6 +750,7 @@ mk/ghcconfig*_test___spaces_ghc*.exe.mk
/tests/ghc-api/T7478/T7478
/tests/ghc-api/T8628
/tests/ghc-api/T8639_api
/tests/ghc-api/T9015
/tests/ghc-api/T9595
/tests/ghc-api/apirecomp001/myghc
/tests/ghc-api/dynCompileExpr/dynCompileExpr
......
......@@ -20,6 +20,11 @@ T8628:
'$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc T8628
./T8628 "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`"
.PHONY: clean T6145 T8639_api T8628
T9015:
rm -f T9015.o T9015.hi
'$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc T9015
./T9015 "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`"
.PHONY: clean T6145 T8639_api T8628 T9015
module Main where
import GHC
import DynFlags
import System.Environment
import GhcMonad
testStrings = [
"import Data.Maybe"
, "import qualified Data.Maybe"
, "import Data.Maybe (isJust)"
, "add a b = a+b"
, "data Foo = Foo String"
, "deriving instance Show Foo"
, "{-# NOVECTORISE foo #-}"
, "{-# WARNING Foo \"Just a warning\" #-}"
, "{-# ANN foo (Just \"Hello\") #-}"
, "{-# RULES \"map/map\" forall f g xs. map f (map g xs) = map (f.g) xs #-}"
, "class HasString a where\n\
\ update :: a -> (String -> String) -> a\n\
\ upcase :: a -> a\n\
\ upcase x = update x (fmap toUpper)\n\
\ content :: a -> String\n\
\ default content :: Show a => a -> String\n\
\ content = show"
, "instance HasString Foo where\n\
\ update (Foo s) f = Foo (f s)\n\
\ content (Foo s) = s"
, "add a b"
, "let foo = add a b"
, "x <- foo y"
, "5 + 8"
, "a <-"
, "2 +"
, "@#"
]
main = do
[libdir] <- getArgs
runGhc (Just libdir) $ do
liftIO (putStrLn "Is import:")
testWithParser isImport
liftIO (putStrLn "Is declaration:")
testWithParser isDecl
liftIO (putStrLn "Is statement:")
testWithParser isStmt
where
testWithParser parser = do
dflags <- getSessionDynFlags
liftIO . putStrLn . unlines $ map (testExpr (parser dflags)) testStrings
testExpr parser expr = do
expr ++ ": " ++ show (parser expr)
Is import:
import Data.Maybe: True
import qualified Data.Maybe: True
import Data.Maybe (isJust): True
add a b = a+b: False
data Foo = Foo String: False
deriving instance Show Foo: False
{-# NOVECTORISE foo #-}: False
{-# WARNING Foo "Just a warning" #-}: False
{-# ANN foo (Just "Hello") #-}: False
{-# RULES "map/map" forall f g xs. map f (map g xs) = map (f.g) xs #-}: False
class HasString a where
update :: a -> (String -> String) -> a
upcase :: a -> a
upcase x = update x (fmap toUpper)
content :: a -> String
default content :: Show a => a -> String
content = show: False
instance HasString Foo where
update (Foo s) f = Foo (f s)
content (Foo s) = s: False
add a b: False
let foo = add a b: False
x <- foo y: False
5 + 8: False
a <-: False
2 +: False
@#: False
Is declaration:
import Data.Maybe: False
import qualified Data.Maybe: False
import Data.Maybe (isJust): False
add a b = a+b: True
data Foo = Foo String: True
deriving instance Show Foo: True
{-# NOVECTORISE foo #-}: True
{-# WARNING Foo "Just a warning" #-}: True
{-# ANN foo (Just "Hello") #-}: True
{-# RULES "map/map" forall f g xs. map f (map g xs) = map (f.g) xs #-}: True
class HasString a where
update :: a -> (String -> String) -> a
upcase :: a -> a
upcase x = update x (fmap toUpper)
content :: a -> String
default content :: Show a => a -> String
content = show: True
instance HasString Foo where
update (Foo s) f = Foo (f s)
content (Foo s) = s: True
add a b: False
let foo = add a b: False
x <- foo y: False
5 + 8: False
a <-: False
2 +: False
@#: False
Is statement:
import Data.Maybe: False
import qualified Data.Maybe: False
import Data.Maybe (isJust): False
add a b = a+b: False
data Foo = Foo String: False
deriving instance Show Foo: False
{-# NOVECTORISE foo #-}: False
{-# WARNING Foo "Just a warning" #-}: False
{-# ANN foo (Just "Hello") #-}: False
{-# RULES "map/map" forall f g xs. map f (map g xs) = map (f.g) xs #-}: False
class HasString a where
update :: a -> (String -> String) -> a
upcase :: a -> a
upcase x = update x (fmap toUpper)
content :: a -> String
default content :: Show a => a -> String
content = show: False
instance HasString Foo where
update (Foo s) f = Foo (f s)
content (Foo s) = s: False
add a b: True
let foo = add a b: True
x <- foo y: True
5 + 8: True
a <-: False
2 +: False
@#: False
......@@ -17,3 +17,6 @@ test('T10508_api', extra_run_opts('"' + config.libdir + '"'),
test('T10942', extra_run_opts('"' + config.libdir + '"'),
compile_and_run,
['-package ghc'])
test('T9015', extra_run_opts('"' + config.libdir + '"'),
compile_and_run,
['-package ghc'])
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