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

4 files changed, 154 insertions, 1 deletions

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