ApiAnnotations : ITopenExpQuote needs SourceText
authorAlan Zimmerman <alan.zimm@gmail.com>
Mon, 16 Nov 2015 19:10:39 +0000 (21:10 +0200)
committerAlan Zimmerman <alan.zimm@gmail.com>
Mon, 16 Nov 2015 19:10:39 +0000 (21:10 +0200)
Summary:
In the lexer, ITopenExpQuote can be recognised for '[e|' or '[|'.

The token definition needs to capture the original SourceText, and pass
it through to ExpBr, which also needs a SrcText field.

It is easier to simply add a flag  to the token identifying the variant
and to generate a different AnnKeywordId based on this.

Test Plan: ./validate

Reviewers: mpickering, bgamari, austin

Reviewed By: bgamari

Subscribers: thomie

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

GHC Trac Issues: #10276

compiler/parser/ApiAnnotation.hs
compiler/parser/Lexer.x
compiler/parser/Parser.y
testsuite/tests/ghc-api/annotations/Makefile
testsuite/tests/ghc-api/annotations/T10276.stderr [new file with mode: 0644]
testsuite/tests/ghc-api/annotations/T10276.stdout [new file with mode: 0644]
testsuite/tests/ghc-api/annotations/Test10276.hs [new file with mode: 0644]
testsuite/tests/ghc-api/annotations/all.T

index c5ba453..f734796 100644 (file)
@@ -9,6 +9,7 @@ module ApiAnnotation (
   AnnotationComment(..),
   IsUnicodeSyntax(..),
   unicodeAnn,
+  HasE(..),
   LRdrName -- Exists for haddocks only
   ) where
 
@@ -238,6 +239,7 @@ data AnnKeywordId
     | AnnOf
     | AnnOpen   -- ^ '(\#' or '{-\# LANGUAGE' etc
     | AnnOpenC   -- ^ '{'
+    | AnnOpenE   -- ^ '[e|' or '[e||'
     | AnnOpenP   -- ^ '('
     | AnnOpenPE   -- ^ '$('
     | AnnOpenPTE   -- ^ '$$('
@@ -331,3 +333,14 @@ unicodeAnn AnnRarrowtail = AnnRarrowtailU
 unicodeAnn AnnStar       = AnnStarU
 unicodeAnn ann           = ann
 -- What about '*'?
+
+
+-- | Some template haskell tokens have two variants, one with an `e` the other
+-- not:
+--
+-- >  [| or [e|
+-- >  [|| or [e||
+--
+-- This type indicates whether the 'e' is present or not.
+data HasE = HasE | NoE
+     deriving (Eq, Ord, Data, Typeable, Show)
index 0bf26ce..041ad74 100644 (file)
@@ -365,10 +365,10 @@ $tab          { warnTab }
 }
 
 <0> {
-  "[|"        / { ifExtension thEnabled } { token ITopenExpQuote }
-  "[||"       / { ifExtension thEnabled } { token ITopenTExpQuote }
-  "[e|"       / { ifExtension thEnabled } { token ITopenExpQuote }
-  "[e||"      / { ifExtension thEnabled } { token ITopenTExpQuote }
+  "[|"        / { ifExtension thEnabled } { token (ITopenExpQuote NoE) }
+  "[||"       / { ifExtension thEnabled } { token (ITopenTExpQuote NoE) }
+  "[e|"       / { ifExtension thEnabled } { token (ITopenExpQuote HasE) }
+  "[e||"      / { ifExtension thEnabled } { token (ITopenTExpQuote HasE) }
   "[p|"       / { ifExtension thEnabled } { token ITopenPatQuote }
   "[d|"       / { ifExtension thEnabled } { layout_token ITopenDecQuote }
   "[t|"       / { ifExtension thEnabled } { token ITopenTypQuote }
@@ -647,12 +647,12 @@ data Token
   | ITprimdouble FractionalLit
 
   -- Template Haskell extension tokens
-  | ITopenExpQuote              --  [| or [e|
+  | ITopenExpQuote HasE         --  [| or [e|
   | ITopenPatQuote              --  [p|
   | ITopenDecQuote              --  [d|
   | ITopenTypQuote              --  [t|
   | ITcloseQuote                --  |]
-  | ITopenTExpQuote             --  [||
+  | ITopenTExpQuote HasE        --  [|| or [e||
   | ITcloseTExpQuote            --  ||]
   | ITidEscape   FastString     --  $x
   | ITparenEscape               --  $(
index bf6e753..795c4d2 100644 (file)
@@ -468,12 +468,12 @@ output it generates.
  DOCSECTION     { L _ (ITdocSection _ _) }
 
 -- Template Haskell
-'[|'            { L _ ITopenExpQuote  }
+'[|'            { L _ (ITopenExpQuote _) }
 '[p|'           { L _ ITopenPatQuote  }
 '[t|'           { L _ ITopenTypQuote  }
 '[d|'           { L _ ITopenDecQuote  }
 '|]'            { L _ ITcloseQuote    }
-'[||'           { L _ ITopenTExpQuote   }
+'[||'           { L _ (ITopenTExpQuote _) }
 '||]'           { L _ ITcloseTExpQuote  }
 TH_ID_SPLICE    { L _ (ITidEscape _)  }     -- $x
 '$('            { L _ ITparenEscape   }     -- $( exp )
@@ -2302,8 +2302,10 @@ aexp2   :: { LHsExpr RdrName }
         | 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 AnnThTyQuote $1,mj AnnName $2] }
         | TH_TY_QUOTE gtycon    {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $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]}
+        | '[|' exp '|]'       {% ams (sLL $1 $> $ HsBracket (ExpBr $2))
+                                      (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) }
+        | '[||' exp '||]'     {% ams (sLL $1 $> $ HsBracket (TExpBr $2))
+                                      (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) }
         | '[t|' ctype '|]'    {% ams (sLL $1 $> $ HsBracket (TypBr $2)) [mo $1,mc $3] }
         | '[p|' infixexp '|]' {% checkPattern empty $2 >>= \p ->
                                       ams (sLL $1 $> $ HsBracket (PatBr p))
@@ -3208,6 +3210,11 @@ isUnicode (L _ (ITLarrowtail iu)) = iu == UnicodeSyntax
 isUnicode (L _ (ITRarrowtail iu)) = iu == UnicodeSyntax
 isUnicode _                       = False
 
+hasE :: Located Token -> Bool
+hasE (L _ (ITopenExpQuote HasE))  = True
+hasE (L _ (ITopenTExpQuote HasE)) = True
+hasE _                            = False
+
 getSCC :: Located Token -> P FastString
 getSCC lt = do let s = getSTRING lt
                    err = "Spaces are not allowed in SCCs"
index 631e7e3..d0b9c2f 100644 (file)
@@ -106,3 +106,7 @@ T10313:
 .PHONY: T11018
 T11018:
        $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test11018
+
+.PHONY: T10276
+T10276:
+       $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10276
diff --git a/testsuite/tests/ghc-api/annotations/T10276.stderr b/testsuite/tests/ghc-api/annotations/T10276.stderr
new file mode 100644 (file)
index 0000000..d79fc3a
--- /dev/null
@@ -0,0 +1,78 @@
+
+Test10276.hs:10:3: error:
+    ‘qqExp’ is not a (visible) method of class ‘QQExp’
+
+Test10276.hs:11:29: error:
+    Not in scope: ‘M.empty’
+    No module named ‘M’ is imported.
+    In the Template Haskell quotation
+      [|| fst
+          $ runState
+              ($$(qqExpM x))
+              ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||]
+
+Test10276.hs:11:46: error:
+    Not in scope: type constructor or class ‘M.Map’
+    No module named ‘M’ is imported.
+    In the Template Haskell quotation
+      [|| fst
+          $ runState
+              ($$(qqExpM x))
+              ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||]
+
+Test10276.hs:11:52: error:
+    Not in scope: type constructor or class ‘L.Name’
+    No module named ‘L’ is imported.
+    In the Template Haskell quotation
+      [|| fst
+          $ runState
+              ($$(qqExpM x))
+              ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||]
+
+Test10276.hs:11:60: error:
+    Not in scope: type constructor or class ‘L.Operand’
+    No module named ‘L’ is imported.
+    In the Template Haskell quotation
+      [|| fst
+          $ runState
+              ($$(qqExpM x))
+              ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||]
+
+Test10276.hs:14:3: error:
+    ‘qqExp’ is not a (visible) method of class ‘QQExp2’
+
+Test10276.hs:15:29: error:
+    Not in scope: ‘M.empty’
+    No module named ‘M’ is imported.
+    In the Template Haskell quotation
+      [|| fst
+          $ runState
+              ($$(qqExpM x))
+              ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||]
+
+Test10276.hs:15:46: error:
+    Not in scope: type constructor or class ‘M.Map’
+    No module named ‘M’ is imported.
+    In the Template Haskell quotation
+      [|| fst
+          $ runState
+              ($$(qqExpM x))
+              ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||]
+
+Test10276.hs:15:52: error:
+    Not in scope: type constructor or class ‘L.Name’
+    No module named ‘L’ is imported.
+    In the Template Haskell quotation
+      [|| fst
+          $ runState
+              ($$(qqExpM x))
+              ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||]
+
+Test10276.hs:15:60: error:
+    Not in scope: type constructor or class ‘L.Operand’
+    No module named ‘L’ is imported.
+    In the Template Haskell quotation
+      [|| fst
+          $ runState
+              ($$(qqExpM x))
+              ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||]
diff --git a/testsuite/tests/ghc-api/annotations/T10276.stdout b/testsuite/tests/ghc-api/annotations/T10276.stdout
new file mode 100644 (file)
index 0000000..14179a6
--- /dev/null
@@ -0,0 +1,63 @@
+---Problems (should be empty list)---
+[]
+---Annotations-----------------------
+-- SrcSpan the annotation is attached to, AnnKeywordId,
+--    list of locations the keyword item appears in
+[
+((Test10276.hs:1:1,AnnModule), [Test10276.hs:4:1-6]),
+((Test10276.hs:1:1,AnnWhere), [Test10276.hs:4:18-22]),
+((Test10276.hs:6:1-14,AnnEqual), [Test10276.hs:6:4]),
+((Test10276.hs:6:1-14,AnnFunId), [Test10276.hs:6:1-2]),
+((Test10276.hs:6:1-14,AnnSemi), [Test10276.hs:7:1]),
+((Test10276.hs:6:6-14,AnnClose), [Test10276.hs:6:13-14]),
+((Test10276.hs:6:6-14,AnnOpen), [Test10276.hs:6:6-7]),
+((Test10276.hs:7:1-15,AnnEqual), [Test10276.hs:7:4]),
+((Test10276.hs:7:1-15,AnnFunId), [Test10276.hs:7:1-2]),
+((Test10276.hs:7:1-15,AnnSemi), [Test10276.hs:9:1]),
+((Test10276.hs:7:6-15,AnnClose), [Test10276.hs:7:14-15]),
+((Test10276.hs:7:6-15,AnnOpenE), [Test10276.hs:7:6-8]),
+((Test10276.hs:(9,1)-(11,74),AnnClass), [Test10276.hs:9:1-5]),
+((Test10276.hs:(9,1)-(11,74),AnnSemi), [Test10276.hs:13:1]),
+((Test10276.hs:(9,1)-(11,74),AnnWhere), [Test10276.hs:9:17-21]),
+((Test10276.hs:(10,3)-(11,74),AnnEqual), [Test10276.hs:10:11]),
+((Test10276.hs:(10,3)-(11,74),AnnFunId), [Test10276.hs:10:3-7]),
+((Test10276.hs:(10,13)-(11,74),AnnClose), [Test10276.hs:11:72-74]),
+((Test10276.hs:(10,13)-(11,74),AnnOpen), [Test10276.hs:10:13-15]),
+((Test10276.hs:(10,16)-(11,71),AnnVal), [Test10276.hs:10:20]),
+((Test10276.hs:10:31-42,AnnCloseP), [Test10276.hs:10:42]),
+((Test10276.hs:10:31-42,AnnOpenPTE), [Test10276.hs:10:31-33]),
+((Test10276.hs:11:25-71,AnnCloseP), [Test10276.hs:11:71]),
+((Test10276.hs:11:25-71,AnnOpenP), [Test10276.hs:11:25]),
+((Test10276.hs:11:26-36,AnnCloseP), [Test10276.hs:11:36]),
+((Test10276.hs:11:26-36,AnnOpenP), [Test10276.hs:11:26]),
+((Test10276.hs:11:26-70,AnnDcolon), [Test10276.hs:11:38-39]),
+((Test10276.hs:11:27,AnnComma), [Test10276.hs:11:28]),
+((Test10276.hs:11:41-70,AnnCloseP), [Test10276.hs:11:70]),
+((Test10276.hs:11:41-70,AnnOpenP), [Test10276.hs:11:41]),
+((Test10276.hs:11:42-44,AnnComma), [Test10276.hs:11:45]),
+((Test10276.hs:11:59-69,AnnCloseS), [Test10276.hs:11:69]),
+((Test10276.hs:11:59-69,AnnOpenS), [Test10276.hs:11:59]),
+((Test10276.hs:(13,1)-(15,74),AnnClass), [Test10276.hs:13:1-5]),
+((Test10276.hs:(13,1)-(15,74),AnnSemi), [Test10276.hs:16:1]),
+((Test10276.hs:(13,1)-(15,74),AnnWhere), [Test10276.hs:13:18-22]),
+((Test10276.hs:(14,3)-(15,74),AnnEqual), [Test10276.hs:14:11]),
+((Test10276.hs:(14,3)-(15,74),AnnFunId), [Test10276.hs:14:3-7]),
+((Test10276.hs:(14,13)-(15,74),AnnClose), [Test10276.hs:15:72-74]),
+((Test10276.hs:(14,13)-(15,74),AnnOpenE), [Test10276.hs:14:13-16]),
+((Test10276.hs:(14,17)-(15,71),AnnVal), [Test10276.hs:14:21]),
+((Test10276.hs:14:32-43,AnnCloseP), [Test10276.hs:14:43]),
+((Test10276.hs:14:32-43,AnnOpenPTE), [Test10276.hs:14:32-34]),
+((Test10276.hs:15:25-71,AnnCloseP), [Test10276.hs:15:71]),
+((Test10276.hs:15:25-71,AnnOpenP), [Test10276.hs:15:25]),
+((Test10276.hs:15:26-36,AnnCloseP), [Test10276.hs:15:36]),
+((Test10276.hs:15:26-36,AnnOpenP), [Test10276.hs:15:26]),
+((Test10276.hs:15:26-70,AnnDcolon), [Test10276.hs:15:38-39]),
+((Test10276.hs:15:27,AnnComma), [Test10276.hs:15:28]),
+((Test10276.hs:15:41-70,AnnCloseP), [Test10276.hs:15:70]),
+((Test10276.hs:15:41-70,AnnOpenP), [Test10276.hs:15:41]),
+((Test10276.hs:15:42-44,AnnComma), [Test10276.hs:15:45]),
+((Test10276.hs:15:59-69,AnnCloseS), [Test10276.hs:15:69]),
+((Test10276.hs:15:59-69,AnnOpenS), [Test10276.hs:15:59]),
+((<no location info>,AnnEofPos), [Test10276.hs:16:1])
+]
+
diff --git a/testsuite/tests/ghc-api/annotations/Test10276.hs b/testsuite/tests/ghc-api/annotations/Test10276.hs
new file mode 100644 (file)
index 0000000..dcf2549
--- /dev/null
@@ -0,0 +1,15 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Test10276 where
+
+f1 = [| bar |]
+f2 = [e| bar |]
+
+class QQExp a b where
+  qqExp x = [||fst $ runState $$(qqExpM x)
+                        ((0,M.empty) :: (Int,M.Map L.Name [L.Operand]))||]
+
+class QQExp2 a b where
+  qqExp x = [e||fst $ runState $$(qqExpM x)
+                        ((0,M.empty) :: (Int,M.Map L.Name [L.Operand]))||]
index 591f5bf..c7c8542 100644 (file)
@@ -19,4 +19,5 @@ test('T10396',      normal, run_command, ['$MAKE -s --no-print-directory T10396'
 test('T10399',      normal, run_command, ['$MAKE -s --no-print-directory T10399'])
 test('T10313',      normal, run_command, ['$MAKE -s --no-print-directory T10313'])
 test('T11018',      normal, run_command, ['$MAKE -s --no-print-directory T11018'])
-test('bundle-export',      normal, run_command, ['$MAKE -s --no-print-directory bundle-export'])
+test('bundle-export', normal, run_command, ['$MAKE -s --no-print-directory bundle-export'])
+test('T10276',      normal, run_command, ['$MAKE -s --no-print-directory T10276'])