Better error message for empty character literal, for Trac #13450.

For empty character literal, the `''`, report error message properly
rather than just throw a "parser error" with wrong error location.

Test Plan: make test TEST="T13450 T13450TH"

Reviewers: goldfire, bgamari

Reviewed By: bgamari

Subscribers: thomie, mpickering, carter

GHC Trac Issues: #13450

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

6 files changed, 70 insertions, 10 deletions

diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index e3a05724b2..085140c174 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -88,9 +88,9 @@ import GhcPrelude
 import qualified GHC.LanguageExtensions as LangExt
 }
 
-%expect 206 -- shift/reduce conflicts
+%expect 233 -- shift/reduce conflicts
 
-{- Last updated: 11 Dec 2017
+{- Last updated: 14 Apr 2018
 
 If you modify this parser and add a conflict, please update this comment.
 You can learn more about the conflicts by passing 'happy' the -i flag:
@@ -201,6 +201,25 @@ Shift parses as (per longest-parse rule):
 
 -------------------------------------------------------------------------------
 
+state 203 contains 27 shift/reduce conflicts.
+
+        aexp2 -> TH_TY_QUOTE . tyvar
+        aexp2 -> TH_TY_QUOTE . gtycon
+    *** aexp2 -> TH_TY_QUOTE .
+
+    Conflicts: two single quotes is error syntax with specific error message.
+
+Example of ambiguity:
+    'x = '''
+    'x = ''a'
+    'x = ''T'
+
+Shift parses as (per longest-parse rule):
+    'x = ''a'
+    'x = ''T'
+
+-------------------------------------------------------------------------------
+
 state 307 contains 1 shift/reduce conflicts.
 
         rule -> STRING . rule_activation rule_forall infixexp '=' exp
@@ -230,7 +249,7 @@ Same as state 60 but without contexts.
 
 -------------------------------------------------------------------------------
 
-state 357 contains 1 shift/reduce conflicts.
+state 359 contains 1 shift/reduce conflicts.
 
         tup_exprs -> commas . tup_tail
         sysdcon_nolist -> '(' commas . ')'
@@ -245,7 +264,7 @@ if -XTupleSections is not specified.
 
 -------------------------------------------------------------------------------
 
-state 413 contains 1 shift/reduce conflicts.
+state 415 contains 1 shift/reduce conflicts.
 
         tup_exprs -> commas . tup_tail
         sysdcon_nolist -> '(#' commas . '#)'
@@ -257,7 +276,7 @@ Same as State 357 for unboxed tuples.
 
 -------------------------------------------------------------------------------
 
-state 424 contains 67 shift/reduce conflicts.
+state 426 contains 67 shift/reduce conflicts.
 
     *** exp10 -> '-' fexp .
         fexp -> fexp . aexp
@@ -267,7 +286,7 @@ Same as 147 but with a unary minus.
 
 -------------------------------------------------------------------------------
 
-state 488 contains 1 shift/reduce conflict.
+state 490 contains 1 shift/reduce conflict.
 
         oqtycon -> '(' qtyconsym . ')'
     *** qtyconop -> qtyconsym .
@@ -281,7 +300,7 @@ parenthesized infix type expression of length 1.
 
 -------------------------------------------------------------------------------
 
-state 689 contains 1 shift/reduce conflicts.
+state 691 contains 1 shift/reduce conflicts.
 
     *** aexp2 -> ipvar .
         dbind -> ipvar . '=' exp
@@ -296,7 +315,7 @@ sensible meaning, namely the lhs of an implicit binding.
 
 -------------------------------------------------------------------------------
 
-state 765 contains 1 shift/reduce conflicts.
+state 767 contains 1 shift/reduce conflicts.
 
         rule -> STRING rule_activation . rule_forall infixexp '=' exp
 
@@ -313,7 +332,7 @@ doesn't include 'forall'.
 
 -------------------------------------------------------------------------------
 
-state 1013 contains 1 shift/reduce conflicts.
+state 1015 contains 1 shift/reduce conflicts.
 
         transformqual -> 'then' 'group' . 'using' exp
         transformqual -> 'then' 'group' . 'by' exp 'using' exp
@@ -323,7 +342,7 @@ state 1013 contains 1 shift/reduce conflicts.
 
 -------------------------------------------------------------------------------
 
-state 1390 contains 1 shift/reduce conflict.
+state 1393 contains 1 shift/reduce conflict.
 
     *** atype -> tyvar .
         tv_bndr -> '(' tyvar . '::' kind ')'
@@ -2616,6 +2635,7 @@ aexp2   :: { LHsExpr GhcPs }
         | SIMPLEQUOTE  qcon     {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt True  (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
         | TH_TY_QUOTE tyvar     {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
         | TH_TY_QUOTE gtycon    {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
+        | TH_TY_QUOTE {- nothing -} {% reportEmptyDoubleQuotes (getLoc $1) }
         | '[|' exp '|]'       {% ams (sLL $1 $> $ HsBracket noExt (ExpBr noExt $2))
                                       (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3]
                                                     else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) }
@@ -3692,6 +3712,24 @@ hintExplicitForall' span = do
         , text "extension to enable explicit-forall syntax: forall <tvs>. <type>"
         ]
 
+-- When two single quotes don't followed by tyvar or gtycon, we report the
+-- error as empty character literal, or TH quote that missing proper type
+-- variable or constructor. See Trac #13450.
+reportEmptyDoubleQuotes :: SrcSpan -> P (GenLocated SrcSpan (HsExpr GhcPs))
+reportEmptyDoubleQuotes span = do
+    thEnabled <- liftM ((LangExt.TemplateHaskellQuotes `extopt`) . options) getPState
+    if thEnabled
+      then parseErrorSDoc span $ vcat
+        [ text "Parser error on `''`"
+        , text "Character literals may not be empty"
+        , text "Or perhaps you intended to use quotation syntax of TemplateHaskell,"
+        , text "but the type variable or constructor is missing"
+        ]
+      else parseErrorSDoc span $ vcat
+        [ text "Parser error on `''`"
+        , text "Character literals may not be empty"
+        ]
+
 {-
 %************************************************************************
 %*                                                                      *
diff --git a/testsuite/tests/parser/should_fail/T13450.hs b/testsuite/tests/parser/should_fail/T13450.hs
new file mode 100644
index 0000000000..b36cca0719
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T13450.hs
@@ -0,0 +1,4 @@
+module T13450 where
+
+example = foo
+  where foo = ''
diff --git a/testsuite/tests/parser/should_fail/T13450.stderr b/testsuite/tests/parser/should_fail/T13450.stderr
new file mode 100644
index 0000000000..6e0beb32cc
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T13450.stderr
@@ -0,0 +1,4 @@
+
+T13450.hs:4:15: error:
+    Parser error on `''`
+    Character literals may not be empty
diff --git a/testsuite/tests/parser/should_fail/T13450TH.hs b/testsuite/tests/parser/should_fail/T13450TH.hs
new file mode 100644
index 0000000000..c851049582
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T13450TH.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module T13450TH where
+
+example = foo
+  where foo = ''
diff --git a/testsuite/tests/parser/should_fail/T13450TH.stderr b/testsuite/tests/parser/should_fail/T13450TH.stderr
new file mode 100644
index 0000000000..11733c5c91
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T13450TH.stderr
@@ -0,0 +1,6 @@
+
+T13450TH.hs:6:15: error:
+    Parser error on `''`
+    Character literals may not be empty
+    Or perhaps you intended to use quotation syntax of TemplateHaskell,
+    but the type variable or constructor is missing
diff --git a/testsuite/tests/parser/should_fail/all.T b/testsuite/tests/parser/should_fail/all.T
index d47e0f5796..01075f2f15 100644
--- a/testsuite/tests/parser/should_fail/all.T
+++ b/testsuite/tests/parser/should_fail/all.T
@@ -106,6 +106,8 @@ test('T8501a', normal, compile_fail, [''])
 test('T8501b', normal, compile_fail, [''])
 test('T8501c', normal, compile_fail, [''])
 test('T12610', normal, compile_fail, [''])
+test('T13450', normal, compile_fail, [''])
+test('T13450TH', normal, compile_fail, [''])
 test('T14588', normal, compile_fail, [''])
 test('T14740', normal, compile_fail, [''])