ApiAnnotations : quoted type variables missing leading quote

The HsOpTy can be constructed for a promoted type operator, in which case it has the following form

        | btype SIMPLEQUOTE qconop type     { sLL $1 $> $ mkHsOpTy $1 $3 $4 }
        | btype SIMPLEQUOTE varop  type     { sLL $1 $> $ mkHsOpTy $1 $3 $4 }

The SIMPLEQUOTE does not get an annotation, so cannot be reproduced via the API Annotations.

Also, in

splice_exp :: { LHsExpr RdrName }
        : TH_ID_SPLICE          { sL1 $1 $ mkHsSpliceE
                                        (sL1 $1 $ HsVar (mkUnqual varName
                                                        (getTH_ID_SPLICE $1))) }
        | '$(' exp ')'          {% ams (sLL $1 $> $ mkHsSpliceE $2) [mo $1,mc $3] }
        | TH_ID_TY_SPLICE       { sL1 $1 $ mkHsSpliceTE
                                        (sL1 $1 $ HsVar (mkUnqual varName
                                                     (getTH_ID_TY_SPLICE $1))) }
        | '$$(' exp ')'         {% ams (sLL $1 $> $ mkHsSpliceTE $2) [mo $1,mc $3] }

the TH_ID_SPLICE and TH_ID_TY_SPLICE positions are lost.

Reviewed By: austin

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

GHC Trac Issues: #10268

7 files changed, 192 insertions, 0 deletions

diff --git a/testsuite/tests/ghc-api/annotations/.gitignore b/testsuite/tests/ghc-api/annotations/.gitignore
index d142368851..3c1f510777 100644
--- a/testsuite/tests/ghc-api/annotations/.gitignore
+++ b/testsuite/tests/ghc-api/annotations/.gitignore
@@ -4,6 +4,7 @@ comments
 exampleTest
 listcomps
 t10255
+t10268
 *.hi
 *.o
 *.run.*
diff --git a/testsuite/tests/ghc-api/annotations/Makefile b/testsuite/tests/ghc-api/annotations/Makefile
index 08a6d4979c..d74d3c2aff 100644
--- a/testsuite/tests/ghc-api/annotations/Makefile
+++ b/testsuite/tests/ghc-api/annotations/Makefile
@@ -37,3 +37,10 @@ t10255:
 	./t10255 "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`"
 
 .PHONY: clean annotations parseTree comments exampleTest listcomps t10255
+
+T10268:
+	rm -f t10268.o t10268.hi
+	'$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc t10268
+	./t10268 "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`"
+
+.PHONY: clean annotations parseTree comments exampleTest listcomps
diff --git a/testsuite/tests/ghc-api/annotations/T10268.stderr b/testsuite/tests/ghc-api/annotations/T10268.stderr
new file mode 100644
index 0000000000..de983a26bf
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/T10268.stderr
@@ -0,0 +1,10 @@
+
+Test10268.hs:5:6:
+    Not in scope: ‘footemplate’
+    In the untyped splice: $footemplate
+
+Test10268.hs:7:14:
+    Not in scope: type constructor or class ‘Pattern’
+
+Test10268.hs:10:10:
+    Not in scope: type constructor or class ‘Pattern’
diff --git a/testsuite/tests/ghc-api/annotations/T10268.stdout b/testsuite/tests/ghc-api/annotations/T10268.stdout
new file mode 100644
index 0000000000..f3cfbc1880
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/T10268.stdout
@@ -0,0 +1,55 @@
+---Problems---------------------
+[
+]
+
+--------------------------------
+[
+(AK Test10268.hs:1:1 AnnModule = [Test10268.hs:3:1-6])
+
+(AK Test10268.hs:1:1 AnnWhere = [Test10268.hs:3:18-22])
+
+(AK Test10268.hs:5:1-17 AnnEqual = [Test10268.hs:5:4])
+
+(AK Test10268.hs:5:1-17 AnnFunId = [Test10268.hs:5:1-2])
+
+(AK Test10268.hs:5:1-17 AnnSemi = [Test10268.hs:7:1])
+
+(AK Test10268.hs:5:6-17 AnnThIdSplice = [Test10268.hs:5:6-17])
+
+(AK Test10268.hs:7:1-27 AnnDcolon = [Test10268.hs:7:6-7])
+
+(AK Test10268.hs:7:1-27 AnnSemi = [Test10268.hs:8:1])
+
+(AK Test10268.hs:7:9-27 AnnRarrow = [Test10268.hs:7:11-12])
+
+(AK Test10268.hs:7:22-25 AnnCloseS = [Test10268.hs:7:25])
+
+(AK Test10268.hs:7:22-25 AnnOpenS = [Test10268.hs:7:23])
+
+(AK Test10268.hs:7:22-25 AnnSimpleQuote = [Test10268.hs:7:22])
+
+(AK Test10268.hs:8:1-16 AnnEqual = [Test10268.hs:8:6])
+
+(AK Test10268.hs:8:1-16 AnnFunId = [Test10268.hs:8:1-4])
+
+(AK Test10268.hs:8:1-16 AnnSemi = [Test10268.hs:10:1])
+
+(AK Test10268.hs:10:1-22 AnnDcolon = [Test10268.hs:10:7-8])
+
+(AK Test10268.hs:10:1-22 AnnSemi = [Test10268.hs:11:1])
+
+(AK Test10268.hs:10:18-20 AnnCloseS = [Test10268.hs:10:20])
+
+(AK Test10268.hs:10:18-20 AnnOpenS = [Test10268.hs:10:19])
+
+(AK Test10268.hs:10:18-20 AnnSimpleQuote = [Test10268.hs:10:18])
+
+(AK Test10268.hs:11:1-17 AnnEqual = [Test10268.hs:11:7])
+
+(AK Test10268.hs:11:1-17 AnnFunId = [Test10268.hs:11:1-5])
+
+(AK Test10268.hs:11:1-17 AnnSemi = [Test10268.hs:12:1])
+
+(AK <no location info> AnnEofPos = [Test10268.hs:12:1])
+]
+
diff --git a/testsuite/tests/ghc-api/annotations/Test10268.hs b/testsuite/tests/ghc-api/annotations/Test10268.hs
new file mode 100644
index 0000000000..04cc0e7e0e
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/Test10268.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE TemplateHaskell,TypeOperators,DataKinds #-}
+
+module Test10268 where
+
+th = $footemplate
+
+give :: b -> Pattern '[b] a
+give = undefined
+
+pfail :: Pattern '[] a
+pfail = undefined
diff --git a/testsuite/tests/ghc-api/annotations/all.T b/testsuite/tests/ghc-api/annotations/all.T
index ed888a3471..c8df1c403d 100644
--- a/testsuite/tests/ghc-api/annotations/all.T
+++ b/testsuite/tests/ghc-api/annotations/all.T
@@ -4,3 +4,4 @@ test('comments',    normal, run_command, ['$MAKE -s --no-print-directory comment
 test('exampleTest', normal, run_command, ['$MAKE -s --no-print-directory exampleTest'])
 test('listcomps',   normal, run_command, ['$MAKE -s --no-print-directory listcomps'])
 test('T10255',      normal, run_command, ['$MAKE -s --no-print-directory t10255'])
+test('T10268',      normal, run_command, ['$MAKE -s --no-print-directory T10268'])
diff --git a/testsuite/tests/ghc-api/annotations/t10268.hs b/testsuite/tests/ghc-api/annotations/t10268.hs
new file mode 100644
index 0000000000..f956ef1809
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/t10268.hs
@@ -0,0 +1,107 @@
+{-# LANGUAGE RankNTypes #-}
+
+-- This program must be called with GHC's libdir as the single command line
+-- argument.
+module Main where
+
+-- import Data.Generics
+import Data.Data
+import Data.List
+import System.IO
+import GHC
+import BasicTypes
+import DynFlags
+import MonadUtils
+import Outputable
+import ApiAnnotation
+import Bag (filterBag,isEmptyBag)
+import System.Directory (removeFile)
+import System.Environment( getArgs )
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import Data.Dynamic ( fromDynamic,Dynamic )
+
+main::IO()
+main = do
+        [libdir] <- getArgs
+        testOneFile libdir "Test10268"
+
+testOneFile libdir fileName = do
+       ((anns,cs),p) <- runGhc (Just libdir) $ do
+                        dflags <- getSessionDynFlags
+                        setSessionDynFlags dflags
+                        let mn =mkModuleName fileName
+                        addTarget Target { targetId = TargetModule mn
+                                         , targetAllowObjCode = True
+                                         , targetContents = Nothing }
+                        load LoadAllTargets
+                        modSum <- getModSummary mn
+                        p <- parseModule modSum
+                        return (pm_annotations p,p)
+
+       let spans = Set.fromList $ getAllSrcSpans (pm_parsed_source p)
+
+       -- putStrLn (pp spans)
+           problems = filter (\(s,a) -> not (Set.member s spans))
+                             $ getAnnSrcSpans (anns,cs)
+       putStrLn "---Problems---------------------"
+       putStrLn (intercalate "\n" [showAnns $ Map.fromList $ map snd problems])
+       putStrLn "--------------------------------"
+       putStrLn (intercalate "\n" [showAnns anns])
+
+    where
+      getAnnSrcSpans :: ApiAnns -> [(SrcSpan,(ApiAnnKey,[SrcSpan]))]
+      getAnnSrcSpans (anns,_) = map (\a@((ss,_),_) -> (ss,a)) $ Map.toList anns
+
+      getAllSrcSpans :: (Data t) => t -> [SrcSpan]
+      getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast
+        where
+          getSrcSpan :: SrcSpan -> [SrcSpan]
+          getSrcSpan ss = [ss]
+
+
+showAnns anns = "[\n" ++ (intercalate "\n"
+   $ map (\((s,k),v)
+              -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n"))
+   $ Map.toList anns)
+    ++ "]\n"
+
+pp a = showPpr unsafeGlobalDynFlags a
+
+
+-- ---------------------------------------------------------------------
+
+-- Copied from syb for the test
+
+
+-- | Generic queries of type \"r\",
+--   i.e., take any \"a\" and return an \"r\"
+--
+type GenericQ r = forall a. Data a => a -> r
+
+
+-- | Make a generic query;
+--   start from a type-specific case;
+--   return a constant otherwise
+--
+mkQ :: ( Typeable a
+       , Typeable b
+       )
+    => r
+    -> (b -> r)
+    -> a
+    -> r
+(r `mkQ` br) a = case cast a of
+                        Just b  -> br b
+                        Nothing -> r
+
+
+
+-- | Summarise all nodes in top-down, left-to-right order
+everything :: (r -> r -> r) -> GenericQ r -> GenericQ r
+
+-- Apply f to x to summarise top-level node;
+-- use gmapQ to recurse into immediate subterms;
+-- use ordinary foldl to reduce list of intermediate results
+
+everything k f x = foldl k (f x) (gmapQ (everything k f) x)