Add support for unicode TH quotes (#11743)
authorJosh Price <thepig247@gmail.com>
Tue, 24 May 2016 10:35:21 +0000 (12:35 +0200)
committerBen Gamari <ben@smart-cactus.org>
Tue, 24 May 2016 11:03:08 +0000 (13:03 +0200)
I've also added cases for `IToparenbar` and `ITcparenbar` (aka banana
brackets) to `isUnicode`.

Document unicode TH quote alternatives (#11743)

Test Plan: ./validate

Reviewers: austin, goldfire, bgamari

Reviewed By: bgamari

Subscribers: thomie, mpickering

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

GHC Trac Issues: #11743

compiler/parser/Lexer.x
compiler/parser/Parser.y
docs/users_guide/glasgow_exts.rst
testsuite/tests/parser/unicode/all.T
testsuite/tests/parser/unicode/arrowsyntax.hs [deleted file]
testsuite/tests/parser/unicode/brackets.hs [new file with mode: 0644]

index 4da03c6..39ce506 100644 (file)
@@ -366,14 +366,17 @@ $tab          { warnTab }
 }
 
 <0> {
-  "[|"        / { ifExtension thQuotesEnabled } { token (ITopenExpQuote NoE) }
+  "[|"        / { ifExtension thQuotesEnabled } { token (ITopenExpQuote NoE
+                                                                NormalSyntax) }
   "[||"       / { ifExtension thQuotesEnabled } { token (ITopenTExpQuote NoE) }
-  "[e|"       / { ifExtension thQuotesEnabled } { token (ITopenExpQuote HasE) }
+  "[e|"       / { ifExtension thQuotesEnabled } { token (ITopenExpQuote HasE
+                                                                NormalSyntax) }
   "[e||"      / { ifExtension thQuotesEnabled } { token (ITopenTExpQuote HasE) }
   "[p|"       / { ifExtension thQuotesEnabled } { token ITopenPatQuote }
   "[d|"       / { ifExtension thQuotesEnabled } { layout_token ITopenDecQuote }
   "[t|"       / { ifExtension thQuotesEnabled } { token ITopenTypQuote }
-  "|]"        / { ifExtension thQuotesEnabled } { token ITcloseQuote }
+  "|]"        / { ifExtension thQuotesEnabled } { token (ITcloseQuote
+                                                                NormalSyntax) }
   "||]"       / { ifExtension thQuotesEnabled } { token ITcloseTExpQuote }
   \$ @varid   / { ifExtension thEnabled } { skip_one_varid ITidEscape }
   "$$" @varid / { ifExtension thEnabled } { skip_two_varid ITidTyEscape }
@@ -386,6 +389,15 @@ $tab          { warnTab }
   -- qualified quasi-quote (#5555)
   "[" @qvarid "|"  / { ifExtension qqEnabled }
                      { lex_qquasiquote_tok }
+
+  $unigraphic -- ⟦
+    / { ifCurrentChar '⟦' `alexAndPred`
+        ifExtension (\i -> unicodeSyntaxEnabled i && thQuotesEnabled i) }
+    { token (ITopenExpQuote NoE UnicodeSyntax) }
+  $unigraphic -- ⟧
+    / { ifCurrentChar '⟧' `alexAndPred`
+        ifExtension (\i -> unicodeSyntaxEnabled i && thQuotesEnabled i) }
+    { token (ITcloseQuote UnicodeSyntax) }
 }
 
   -- See Note [Lexing type applications]
@@ -692,18 +704,18 @@ data Token
   | ITprimdouble FractionalLit
 
   -- Template Haskell extension tokens
-  | ITopenExpQuote HasE         --  [| or [e|
-  | ITopenPatQuote              --  [p|
-  | ITopenDecQuote              --  [d|
-  | ITopenTypQuote              --  [t|
-  | ITcloseQuote                --  |]
-  | ITopenTExpQuote HasE        --  [|| or [e||
-  | ITcloseTExpQuote            --  ||]
-  | ITidEscape   FastString     --  $x
-  | ITparenEscape               --  $(
-  | ITidTyEscape   FastString   --  $$x
-  | ITparenTyEscape             --  $$(
-  | ITtyQuote                   --  ''
+  | ITopenExpQuote HasE IsUnicodeSyntax --  [| or [e|
+  | ITopenPatQuote                      --  [p|
+  | ITopenDecQuote                      --  [d|
+  | ITopenTypQuote                      --  [t|
+  | ITcloseQuote IsUnicodeSyntax        --  |]
+  | ITopenTExpQuote HasE                --  [|| or [e||
+  | ITcloseTExpQuote                    --  ||]
+  | ITidEscape   FastString             --  $x
+  | ITparenEscape                       --  $(
+  | ITidTyEscape   FastString           --  $$x
+  | ITparenTyEscape                     --  $$(
+  | ITtyQuote                           --  ''
   | ITquasiQuote (FastString,FastString,RealSrcSpan)
     -- ITquasiQuote(quoter, quote, loc)
     -- represents a quasi-quote of the form
index 4502dca..e1c8559 100644 (file)
@@ -464,11 +464,11 @@ output it generates.
  DOCSECTION     { L _ (ITdocSection _ _) }
 
 -- Template Haskell
-'[|'            { L _ (ITopenExpQuote _) }
+'[|'            { L _ (ITopenExpQuote _ _) }
 '[p|'           { L _ ITopenPatQuote  }
 '[t|'           { L _ ITopenTypQuote  }
 '[d|'           { L _ ITopenDecQuote  }
-'|]'            { L _ ITcloseQuote    }
+'|]'            { L _ (ITcloseQuote _) }
 '[||'           { L _ (ITopenTExpQuote _) }
 '||]'           { L _ ITcloseTExpQuote  }
 TH_ID_SPLICE    { L _ (ITidEscape _)  }     -- $x
@@ -3206,20 +3206,24 @@ getCTYPEs             (L _ (ITctype             src)) = src
 getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l)
 
 isUnicode :: Located Token -> Bool
-isUnicode (L _ (ITforall     iu)) = iu == UnicodeSyntax
-isUnicode (L _ (ITdarrow     iu)) = iu == UnicodeSyntax
-isUnicode (L _ (ITdcolon     iu)) = iu == UnicodeSyntax
-isUnicode (L _ (ITlarrow     iu)) = iu == UnicodeSyntax
-isUnicode (L _ (ITrarrow     iu)) = iu == UnicodeSyntax
-isUnicode (L _ (ITrarrow     iu)) = iu == UnicodeSyntax
-isUnicode (L _ (ITlarrowtail iu)) = iu == UnicodeSyntax
-isUnicode (L _ (ITrarrowtail iu)) = iu == UnicodeSyntax
-isUnicode (L _ (ITLarrowtail iu)) = iu == UnicodeSyntax
-isUnicode (L _ (ITRarrowtail iu)) = iu == UnicodeSyntax
-isUnicode _                       = False
+isUnicode (L _ (ITforall         iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITdarrow         iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITdcolon         iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITlarrow         iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITrarrow         iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITrarrow         iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITlarrowtail     iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITrarrowtail     iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITLarrowtail     iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITRarrowtail     iu)) = iu == UnicodeSyntax
+isUnicode (L _ (IToparenbar      iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITcparenbar      iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITcloseQuote     iu)) = iu == UnicodeSyntax
+isUnicode _                           = False
 
 hasE :: Located Token -> Bool
-hasE (L _ (ITopenExpQuote HasE))  = True
+hasE (L _ (ITopenExpQuote HasE _))  = True
 hasE (L _ (ITopenTExpQuote HasE)) = True
 hasE _                            = False
 
index 8abb218..c48812c 100644 (file)
@@ -278,34 +278,38 @@ The language extension :ghc-flag:`-XUnicodeSyntax` enables
 Unicode characters to be used to stand for certain ASCII character
 sequences. The following alternatives are provided:
 
-+--------------+---------------+-------------+--------------------------------+
-| ASCII        | Unicode       | Code point  | Name                           |
-|              | alternative   |             |                                |
-+==============+===============+=============+================================+
-| ``::``       | ∷             | 0x2237      | PROPORTION                     |
-+--------------+---------------+-------------+--------------------------------+
-| ``=>``       | ⇒             | 0x21D2      | RIGHTWARDS DOUBLE ARROW        |
-+--------------+---------------+-------------+--------------------------------+
-| ``->``       | →             | 0x2192      | RIGHTWARDS ARROW               |
-+--------------+---------------+-------------+--------------------------------+
-| ``<-``       | ←             | 0x2190      | LEFTWARDS ARROW                |
-+--------------+---------------+-------------+--------------------------------+
-| ``>-``       | ⤚             | 0x291a      | RIGHTWARDS ARROW-TAIL          |
-+--------------+---------------+-------------+--------------------------------+
-| ``-<``       | ⤙             | 0x2919      | LEFTWARDS ARROW-TAIL           |
-+--------------+---------------+-------------+--------------------------------+
-| ``>>-``      | ⤜             | 0x291C      | RIGHTWARDS DOUBLE ARROW-TAIL   |
-+--------------+---------------+-------------+--------------------------------+
-| ``-<<``      | ⤛             | 0x291B      | LEFTWARDS DOUBLE ARROW-TAIL    |
-+--------------+---------------+-------------+--------------------------------+
-| ``*``        | ★             | 0x2605      | BLACK STAR                     |
-+--------------+---------------+-------------+--------------------------------+
-| ``forall``   | ∀             | 0x2200      | FOR ALL                        |
-+--------------+---------------+-------------+--------------------------------+
-| ``(|``       | ⦇             | 0x2987      | Z NOTATION LEFT IMAGE BRACKET  |
-+--------------+---------------+-------------+--------------------------------+
-| ``|)``       | ⦈             | 0x2988      | Z NOTATION RIGHT IMAGE BRACKET |
-+--------------+---------------+-------------+--------------------------------+
++--------------+---------------+-------------+-----------------------------------------+
+| ASCII        | Unicode       | Code point  | Name                                    |
+|              | alternative   |             |                                         |
++==============+===============+=============+=========================================+
+| ``::``       | ∷             | 0x2237      | PROPORTION                              |
++--------------+---------------+-------------+-----------------------------------------+
+| ``=>``       | ⇒             | 0x21D2      | RIGHTWARDS DOUBLE ARROW                 |
++--------------+---------------+-------------+-----------------------------------------+
+| ``->``       | →             | 0x2192      | RIGHTWARDS ARROW                        |
++--------------+---------------+-------------+-----------------------------------------+
+| ``<-``       | ←             | 0x2190      | LEFTWARDS ARROW                         |
++--------------+---------------+-------------+-----------------------------------------+
+| ``>-``       | ⤚             | 0x291a      | RIGHTWARDS ARROW-TAIL                   |
++--------------+---------------+-------------+-----------------------------------------+
+| ``-<``       | ⤙             | 0x2919      | LEFTWARDS ARROW-TAIL                    |
++--------------+---------------+-------------+-----------------------------------------+
+| ``>>-``      | ⤜             | 0x291C      | RIGHTWARDS DOUBLE ARROW-TAIL            |
++--------------+---------------+-------------+-----------------------------------------+
+| ``-<<``      | ⤛             | 0x291B      | LEFTWARDS DOUBLE ARROW-TAIL             |
++--------------+---------------+-------------+-----------------------------------------+
+| ``*``        | ★             | 0x2605      | BLACK STAR                              |
++--------------+---------------+-------------+-----------------------------------------+
+| ``forall``   | ∀             | 0x2200      | FOR ALL                                 |
++--------------+---------------+-------------+-----------------------------------------+
+| ``(|``       | ⦇             | 0x2987      | Z NOTATION LEFT IMAGE BRACKET           |
++--------------+---------------+-------------+-----------------------------------------+
+| ``|)``       | ⦈             | 0x2988      | Z NOTATION RIGHT IMAGE BRACKET          |
++--------------+---------------+-------------+-----------------------------------------+
+| ``[|``       | ⟦             | 0x27E6      | MATHEMATICAL LEFT WHITE SQUARE BRACKET  |
++--------------+---------------+-------------+-----------------------------------------+
+| ``|]``       | ⟧             | 0x27E7      | MATHEMATICAL RIGHT WHITE SQUARE BRACKET |
++--------------+---------------+-------------+-----------------------------------------+
 
 .. _magic-hash:
 
index 44adc7d..cd69f0d 100644 (file)
@@ -27,4 +27,4 @@ test('T7671', normal, compile, [''])
 test('T10907', normal, compile, [''])
 test('T7650', normal, compile, [''])
 
-test('arrowsyntax', normal, compile, [''])
+test('brackets', normal, compile, [''])
diff --git a/testsuite/tests/parser/unicode/arrowsyntax.hs b/testsuite/tests/parser/unicode/arrowsyntax.hs
deleted file mode 100644 (file)
index 05a8495..0000000
+++ /dev/null
@@ -1,34 +0,0 @@
-{-# LANGUAGE Arrows        #-}
-{-# LANGUAGE UnicodeSyntax #-}
-
--- See Trac #2978 and #10162 for details
--- This test is a unicode version of tests/arrows/should_compile/arrowform1.hs
-
-module ShouldCompile where
-
-import Control.Arrow
-
-handle :: ArrowPlus a => a (b,s) c -> a (b,(String,s)) c -> a (b,s) c
-handle f h = proc (b,s) -> (f ⤙ (b,s)) <+> (h ⤙ (b,("FAIL",s)))
-
-f :: ArrowPlus a => a (Int,Int) String
-f = proc (x,y) ->
-  ⦇handle
-    (returnA ⤙ show y)
-    (\s -> returnA ⤙ s ++ show x)
-  ⦈
-
-g :: ArrowPlus a => a (Int,Int) String
-g = proc (x,y) ->
-  ⦇handle
-    (\msg -> returnA ⤙ msg ++ show y)
-    (\s msg -> returnA ⤙ s ++ show x)
-  ⦈ ("hello " ++ show x)
-
-h :: ArrowPlus a => a (Int,Int) Int
-h = proc (x,y) ->
-  (
-    (\z -> returnA ⤙ x + z)
-    <+>
-    (\z -> returnA ⤙ y + z)
-  ) (x*y)
diff --git a/testsuite/tests/parser/unicode/brackets.hs b/testsuite/tests/parser/unicode/brackets.hs
new file mode 100644 (file)
index 0000000..33c8e3f
--- /dev/null
@@ -0,0 +1,43 @@
+{-# LANGUAGE Arrows          #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UnicodeSyntax   #-}
+
+-- See Trac #10162 and #11743 for details
+
+module ShouldCompile where
+
+import Control.Arrow
+import Language.Haskell.TH
+
+handle :: ArrowPlus a => a (b,s) c -> a (b,(String,s)) c -> a (b,s) c
+handle f h = proc (b,s) -> (f -< (b,s)) <+> (h -< (b,("FAIL",s)))
+
+f :: ArrowPlus a => a (Int,Int) String
+f = proc (x,y) ->
+  ⦇handle
+    (returnA -< show y)
+    (\s -> returnA -< s ++ show x)
+  ⦈
+
+g :: ArrowPlus a => a (Int,Int) String
+g = proc (x,y) ->
+  ⦇handle
+    (\msg -> returnA -< msg ++ show y)
+    (\s msg -> returnA -< s ++ show x)
+  ⦈ ("hello " ++ show x)
+
+h :: ArrowPlus a => a (Int,Int) Int
+h = proc (x,y) ->
+  (
+    (\z -> returnA -< x + z)
+    <+>
+    (\z -> returnA -< y + z)
+  ) (x*y)
+
+
+matches :: PatQ -> ExpQ
+matches pat = ⟦\x ->
+  case x of
+    $pat -> True
+    _    -> False
+  ⟧