diff options
| -rw-r--r-- | compiler/main/GHC.hs | 1 | ||||
| -rw-r--r-- | compiler/main/InteractiveEval.hs | 37 | ||||
| -rw-r--r-- | docs/users_guide/7.12.1-notes.rst | 2 | ||||
| -rw-r--r-- | ghc/GhciMonad.hs | 19 | ||||
| -rw-r--r-- | ghc/InteractiveUI.hs | 33 | ||||
| -rw-r--r-- | testsuite/.gitignore | 1 | ||||
| -rw-r--r-- | testsuite/tests/ghc-api/Makefile | 7 | ||||
| -rw-r--r-- | testsuite/tests/ghc-api/T9015.hs | 59 | ||||
| -rw-r--r-- | testsuite/tests/ghc-api/T9015.stdout | 86 | ||||
| -rw-r--r-- | testsuite/tests/ghc-api/all.T | 3 |
10 files changed, 207 insertions, 41 deletions
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index fa1c2f0beb..8e5a530700 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -130,6 +130,7 @@ module GHC ( -- ** Other runTcInteractive, -- Desired by some clients (Trac #8878) + isStmt, isImport, isDecl, -- ** The debugger SingleStep(..), diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index a6c4b397ba..6defdff1af 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -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 diff --git a/docs/users_guide/7.12.1-notes.rst b/docs/users_guide/7.12.1-notes.rst index 21ec1d39b3..88196a56c4 100644 --- a/docs/users_guide/7.12.1-notes.rst +++ b/docs/users_guide/7.12.1-notes.rst @@ -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 ~~~~~~~~ diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs index 6d068be485..7dd005b99e 100644 --- a/ghc/GhciMonad.hs +++ b/ghc/GhciMonad.hs @@ -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 diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 772b39b9bc..f7b3603b6a 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -1,5 +1,5 @@ {-# 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 diff --git a/testsuite/.gitignore b/testsuite/.gitignore index dee90124c3..07bf0bc630 100644 --- a/testsuite/.gitignore +++ b/testsuite/.gitignore @@ -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 diff --git a/testsuite/tests/ghc-api/Makefile b/testsuite/tests/ghc-api/Makefile index 8278f2ba8f..2470fbfaf2 100644 --- a/testsuite/tests/ghc-api/Makefile +++ b/testsuite/tests/ghc-api/Makefile @@ -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 diff --git a/testsuite/tests/ghc-api/T9015.hs b/testsuite/tests/ghc-api/T9015.hs new file mode 100644 index 0000000000..6f7efec8d0 --- /dev/null +++ b/testsuite/tests/ghc-api/T9015.hs @@ -0,0 +1,59 @@ +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) diff --git a/testsuite/tests/ghc-api/T9015.stdout b/testsuite/tests/ghc-api/T9015.stdout new file mode 100644 index 0000000000..7b9b6e92de --- /dev/null +++ b/testsuite/tests/ghc-api/T9015.stdout @@ -0,0 +1,86 @@ +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 diff --git a/testsuite/tests/ghc-api/all.T b/testsuite/tests/ghc-api/all.T index dee74b7e94..e3e31da70c 100644 --- a/testsuite/tests/ghc-api/all.T +++ b/testsuite/tests/ghc-api/all.T @@ -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']) |