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

(cherry picked from commit 15aafc7fb61d2cbf95f2a564762399e82fe44e9c)

9 files changed, 219 insertions, 16 deletions

diff --git a/compiler/parser/ApiAnnotation.hs b/compiler/parser/ApiAnnotation.hs
index e8ad8ea879..babd93a0ab 100644
--- a/compiler/parser/ApiAnnotation.hs
+++ b/compiler/parser/ApiAnnotation.hs
@@ -228,6 +228,7 @@ data AnnKeywordId
     | AnnMinus -- ^ '-'
     | AnnModule
     | AnnNewtype
+    | AnnName -- ^ where a name loses its location in the AST, this carries it
     | AnnOf
     | AnnOpen   -- ^ '(\#' or '{-\# LANGUAGE' etc
     | AnnOpenC   -- ^ '{'
@@ -242,8 +243,11 @@ data AnnKeywordId
     | AnnRole
     | AnnSafe
     | AnnSemi -- ^ ';'
+    | AnnSimpleQuote -- ^ '''
     | AnnStatic -- ^ 'static'
     | AnnThen
+    | AnnThIdSplice -- ^ '$'
+    | AnnThIdTySplice -- ^ '$$'
     | AnnTilde -- ^ '~'
     | AnnTildehsh -- ^ '~#'
     | AnnType
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 98457915ef..cfc9c693f5 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1487,8 +1487,10 @@ type :: { LHsType RdrName }
         | btype '~'      btype          {% ams (sLL $1 $> $ HsEqTy $1 $3)
                                                [mj AnnTilde $2] }
                                         -- see Note [Promotion]
-        | btype SIMPLEQUOTE qconop type     { sLL $1 $> $ mkHsOpTy $1 $3 $4 }
-        | btype SIMPLEQUOTE varop  type     { sLL $1 $> $ mkHsOpTy $1 $3 $4 }
+        | btype SIMPLEQUOTE qconop type  {% ams (sLL $1 $> $ mkHsOpTy $1 $3 $4)
+                                                [mj AnnSimpleQuote $2] }
+        | btype SIMPLEQUOTE varop  type  {% ams (sLL $1 $> $ mkHsOpTy $1 $3 $4)
+                                                [mj AnnSimpleQuote $2] }
 
 typedoc :: { LHsType RdrName }
         : btype                          { $1 }
@@ -1505,8 +1507,10 @@ typedoc :: { LHsType RdrName }
         | btype '~'      btype           {% ams (sLL $1 $> $ HsEqTy $1 $3)
                                                 [mj AnnTilde $2] }
                                         -- see Note [Promotion]
-        | btype SIMPLEQUOTE qconop type     { sLL $1 $> $ mkHsOpTy $1 $3 $4 }
-        | btype SIMPLEQUOTE varop  type     { sLL $1 $> $ mkHsOpTy $1 $3 $4 }
+        | btype SIMPLEQUOTE qconop type  {% ams (sLL $1 $> $ mkHsOpTy $1 $3 $4)
+                                                [mj AnnSimpleQuote $2] }
+        | btype SIMPLEQUOTE varop  type  {% ams (sLL $1 $> $ mkHsOpTy $1 $3 $4)
+                                                [mj AnnSimpleQuote $2] }
 
 btype :: { LHsType RdrName }
         : btype atype                   { sLL $1 $> $ HsAppTy $1 $2 }
@@ -1549,15 +1553,16 @@ atype :: { LHsType RdrName }
         | TH_ID_SPLICE                { sLL $1 $> $ mkHsSpliceTy $ sL1 $1 $ HsVar $
                                         mkUnqual varName (getTH_ID_SPLICE $1) }
                                       -- see Note [Promotion] for the followings
-        | SIMPLEQUOTE qcon_nowiredlist { sLL $1 $> $ HsTyVar $ unLoc $2 }
+        | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar $ unLoc $2) [mj AnnSimpleQuote $1,mj AnnName $2] }
         | SIMPLEQUOTE  '(' ctype ',' comma_types1 ')'
                              {% addAnnotation (gl $3) AnnComma (gl $4) >>
                                 ams (sLL $1 $> $ HsExplicitTupleTy [] ($3 : $5))
-                                    [mop $2,mcp $6] }
+                                    [mj AnnSimpleQuote $1,mop $2,mcp $6] }
         | SIMPLEQUOTE  '[' comma_types0 ']'     {% ams (sLL $1 $> $ HsExplicitListTy
                                                             placeHolderKind $3)
-                                                       [mos $2,mcs $4] }
-        | SIMPLEQUOTE var                       { sLL $1 $> $ HsTyVar $ unLoc $2 }
+                                                       [mj AnnSimpleQuote $1,mos $2,mcs $4] }
+        | SIMPLEQUOTE var                       {% ams (sLL $1 $> $ HsTyVar $ unLoc $2)
+                                                       [mj AnnSimpleQuote $1,mj AnnName $2] }
 
         -- Two or more [ty, ty, ty] must be a promoted list type, just as
         -- if you had written '[ty, ty, ty]
@@ -2165,10 +2170,10 @@ aexp2   :: { LHsExpr RdrName }
         -- Template Haskell Extension
         | splice_exp            { $1 }
 
-        | SIMPLEQUOTE  qvar     { sLL $1 $> $ HsBracket (VarBr True  (unLoc $2)) }
-        | SIMPLEQUOTE  qcon     { sLL $1 $> $ HsBracket (VarBr True  (unLoc $2)) }
-        | TH_TY_QUOTE tyvar     { sLL $1 $> $ HsBracket (VarBr False (unLoc $2)) }
-        | TH_TY_QUOTE gtycon    { sLL $1 $> $ HsBracket (VarBr False (unLoc $2)) }
+        | SIMPLEQUOTE  qvar     {% ams (sLL $1 $> $ HsBracket (VarBr True  (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
+        | SIMPLEQUOTE  qcon     {% ams (sLL $1 $> $ HsBracket (VarBr True  (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
+        | TH_TY_QUOTE tyvar     {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThIdSplice $1,mj AnnName $2] }
+        | TH_TY_QUOTE gtycon    {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThIdSplice $1,mj AnnName $2] }
         | '[|' exp '|]'       {% ams (sLL $1 $> $ HsBracket (ExpBr $2)) [mo $1,mc $3] }
         | '[||' exp '||]'     {% ams (sLL $1 $> $ HsBracket (TExpBr $2)) [mo $1,mc $3]}
         | '[t|' ctype '|]'    {% checkNoPartialType
@@ -2188,13 +2193,15 @@ aexp2   :: { LHsExpr RdrName }
                                           [mo $1,mc $4] }
 
 splice_exp :: { LHsExpr RdrName }
-        : TH_ID_SPLICE          { sL1 $1 $ mkHsSpliceE
+        : TH_ID_SPLICE          {% ams (sL1 $1 $ mkHsSpliceE
                                         (sL1 $1 $ HsVar (mkUnqual varName
-                                                        (getTH_ID_SPLICE $1))) }
+                                                        (getTH_ID_SPLICE $1))))
+                                       [mj AnnThIdSplice $1] }
         | '$(' exp ')'          {% ams (sLL $1 $> $ mkHsSpliceE $2) [mo $1,mc $3] }
-        | TH_ID_TY_SPLICE       { sL1 $1 $ mkHsSpliceTE
+        | TH_ID_TY_SPLICE       {% ams (sL1 $1 $ mkHsSpliceTE
                                         (sL1 $1 $ HsVar (mkUnqual varName
-                                                     (getTH_ID_TY_SPLICE $1))) }
+                                                     (getTH_ID_TY_SPLICE $1))))
+                                       [mj AnnThIdTySplice $1] }
         | '$$(' exp ')'         {% ams (sLL $1 $> $ mkHsSpliceTE $2) [mo $1,mc $3] }
 
 cmdargs :: { [LHsCmdTop RdrName] }
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)