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

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'])