Add unicode syntax for banana brackets

Summary:
Add "⦇" and "⦈" as unicode alternatives for "(|" and "|)" respectively.

This must be implemented differently than other unicode additions
because ⦇" and "⦈" are interpretted as a $unigraphic rather than
a $unisymbol.

Test Plan: validate

Reviewers: goldfire, bgamari, austin

Reviewed By: bgamari, austin

Subscribers: thomie, mpickering

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

GHC Trac Issues: #10162

6 files changed, 72 insertions, 19 deletions

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 650b302b54..4eb8fd35a2 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -395,8 +395,17 @@ $tab          { warnTab }
 
 <0> {
   "(|" / { ifExtension arrowsEnabled `alexAndPred` notFollowedBySymbol }
-                                        { special IToparenbar }
-  "|)" / { ifExtension arrowsEnabled }  { special ITcparenbar }
+                                        { special (IToparenbar NormalSyntax) }
+  "|)" / { ifExtension arrowsEnabled }  { special (ITcparenbar NormalSyntax) }
+
+  $unigraphic -- ⦇
+    / { ifCurrentChar '⦇' `alexAndPred`
+        ifExtension (\i -> unicodeSyntaxEnabled i && arrowsEnabled i) }
+    { special (IToparenbar UnicodeSyntax) }
+  $unigraphic -- ⦈
+    / { ifCurrentChar '⦈' `alexAndPred`
+        ifExtension (\i -> unicodeSyntaxEnabled i && arrowsEnabled i) }
+    { special (ITcparenbar UnicodeSyntax) }
 }
 
 <0> {
@@ -704,8 +713,8 @@ data Token
   -- Arrow notation extension
   | ITproc
   | ITrec
-  | IToparenbar                  --  (|
-  | ITcparenbar                  --  |)
+  | IToparenbar  IsUnicodeSyntax --  (|
+  | ITcparenbar  IsUnicodeSyntax --  |)
   | ITlarrowtail IsUnicodeSyntax --  -<
   | ITrarrowtail IsUnicodeSyntax --  >-
   | ITLarrowtail IsUnicodeSyntax --  -<<
@@ -942,6 +951,10 @@ followedByDigit :: AlexAccPred ExtsBitmap
 followedByDigit _ _ _ (AI _ buf)
   = afterOptionalSpace buf (\b -> nextCharIs b (`elem` ['0'..'9']))
 
+ifCurrentChar :: Char -> AlexAccPred ExtsBitmap
+ifCurrentChar char _ (AI _ buf) _ _
+  = nextCharIs buf (== char)
+
 -- We must reject doc comments as being ordinary comments everywhere.
 -- In some cases the doc comment will be selected as the lexeme due to
 -- maximal munch, but not always, because the nested comment rule is
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index a640bcb849..0b11b04a5e 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -427,8 +427,8 @@ output it generates.
  ')'            { L _ ITcparen }
  '(#'           { L _ IToubxparen }
  '#)'           { L _ ITcubxparen }
- '(|'           { L _ IToparenbar }
- '|)'           { L _ ITcparenbar }
+ '(|'           { L _ (IToparenbar _) }
+ '|)'           { L _ (ITcparenbar _) }
  ';'            { L _ ITsemi }
  ','            { L _ ITcomma }
  '`'            { L _ ITbackquote }
diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst
index a4a08302a9..978fe8b195 100644
--- a/docs/users_guide/glasgow_exts.rst
+++ b/docs/users_guide/glasgow_exts.rst
@@ -302,6 +302,10 @@ sequences. The following alternatives are provided:
 +--------------+---------------+-------------+--------------------------------+
 | ``forall``   | ∀             | 0x2200      | FOR ALL                        |
 +--------------+---------------+-------------+--------------------------------+
+| ``(|``       | ⦇             | 0x2987      | Z NOTATION LEFT IMAGE BRACKET  |
++--------------+---------------+-------------+--------------------------------+
+| ``|)``       | ⦈             | 0x2988      | Z NOTATION RIGHT IMAGE BRACKET |
++--------------+---------------+-------------+--------------------------------+
 
 .. _magic-hash:
 
diff --git a/testsuite/tests/arrows/should_compile/arrowform1.hs b/testsuite/tests/arrows/should_compile/arrowform1.hs
index 70b9669ef1..c41e6c7a0a 100644
--- a/testsuite/tests/arrows/should_compile/arrowform1.hs
+++ b/testsuite/tests/arrows/should_compile/arrowform1.hs
@@ -9,22 +9,22 @@ 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)
-	|)
+  (|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)
+  (|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)
+  (
+    (\z -> returnA -< x + z)
+    <+>
+    (\z -> returnA -< y + z)
+  ) (x*y)
diff --git a/testsuite/tests/parser/unicode/all.T b/testsuite/tests/parser/unicode/all.T
index 36554cc143..6876fe777c 100644
--- a/testsuite/tests/parser/unicode/all.T
+++ b/testsuite/tests/parser/unicode/all.T
@@ -26,3 +26,5 @@ test('T7671', normal, compile, [''])
 # supported by the test suite (see 10907)
 test('T10907', normal, compile, [''])
 test('T7650', normal, compile, [''])
+
+test('arrowsyntax', normal, compile, [''])
\ No newline at end of file
diff --git a/testsuite/tests/parser/unicode/arrowsyntax.hs b/testsuite/tests/parser/unicode/arrowsyntax.hs
new file mode 100644
index 0000000000..05a8495167
--- /dev/null
+++ b/testsuite/tests/parser/unicode/arrowsyntax.hs
@@ -0,0 +1,34 @@
+{-# 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)