Use UnicodeSyntax when printing

When printing Haskell source, and UnicodeSyntax is enabled, use the
unicode sytax characters (#8959).

compiler/hsSyn/HsDecls.lhs

@@ -1236,7 +1236,7 @@ instance OutputableBndr name => Outputable (RuleDecl name) where
                nest 4 (equals <+> pprExpr (unLoc rhs) <+> text "#-}") ]
         where
           pp_forall | null ns   = empty
-                    | otherwise = text "forall" <+> fsep (map ppr ns) <> dot
+                    | otherwise = forAllLit <+> fsep (map ppr ns) <> dot
 
 instance OutputableBndr name => Outputable (RuleBndr name) where
    ppr (RuleBndr name) = ppr name

compiler/hsSyn/HsExpr.lhs

@@ -630,13 +630,13 @@ ppr_expr (HsTickPragma externalSrcLoc exp)
           ptext (sLit ")")]
 
 ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True)
-  = hsep [ppr_lexpr arrow, ptext (sLit "-<"), ppr_lexpr arg]
+  = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]
 ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False)
-  = hsep [ppr_lexpr arg, ptext (sLit ">-"), ppr_lexpr arrow]
+  = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow]
 ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True)
-  = hsep [ppr_lexpr arrow, ptext (sLit "-<<"), ppr_lexpr arg]
+  = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg]
 ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False)
-  = hsep [ppr_lexpr arg, ptext (sLit ">>-"), ppr_lexpr arrow]
+  = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]
 
 ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2])
   = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]]
@@ -849,13 +849,13 @@ ppr_cmd (HsCmdCast co cmd) = sep [ ppr_cmd cmd
                                  , ptext (sLit "|>") <+> ppr co ]
 
 ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp True)
-  = hsep [ppr_lexpr arrow, ptext (sLit "-<"), ppr_lexpr arg]
+  = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]
 ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp False)
-  = hsep [ppr_lexpr arg, ptext (sLit ">-"), ppr_lexpr arrow]
+  = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow]
 ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp True)
-  = hsep [ppr_lexpr arrow, ptext (sLit "-<<"), ppr_lexpr arg]
+  = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg]
 ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp False)
-  = hsep [ppr_lexpr arg, ptext (sLit ">>-"), ppr_lexpr arrow]
+  = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]
 
 ppr_cmd (HsCmdArrForm (L _ (HsVar v)) (Just _) [arg1, arg2])
   = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]]
@@ -1300,7 +1300,7 @@ instance (OutputableBndr idL, OutputableBndr idR, Outputable body)
 pprStmt :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
         => (StmtLR idL idR body) -> SDoc
 pprStmt (LastStmt expr _)         = ifPprDebug (ptext (sLit "[last]")) <+> ppr expr
-pprStmt (BindStmt pat expr _ _)   = hsep [ppr pat, ptext (sLit "<-"), ppr expr]
+pprStmt (BindStmt pat expr _ _)   = hsep [ppr pat, larrow, ppr expr]
 pprStmt (LetStmt binds)           = hsep [ptext (sLit "let"), pprBinds binds]
 pprStmt (BodyStmt expr _ _ _)     = ppr expr
 pprStmt (ParStmt stmtss _ _)      = sep (punctuate (ptext (sLit " | ")) (map ppr stmtss))

compiler/hsSyn/HsTypes.lhs

@@ -567,7 +567,7 @@ pprHsForAll exp qtvs cxt
     show_forall =  opt_PprStyle_Debug
                 || (not (null (hsQTvBndrs qtvs)) && is_explicit)
     is_explicit = case exp of {Explicit -> True; Implicit -> False}
-    forall_part = ptext (sLit "forall") <+> ppr qtvs <> dot
+    forall_part = forAllLit <+> ppr qtvs <> dot
 
 pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc
 pprHsContext []  = empty

compiler/main/DynFlags.hs

@@ -32,6 +32,7 @@ module DynFlags (
         wopt, wopt_set, wopt_unset,
         xopt, xopt_set, xopt_unset,
         lang_set,
+        useUnicodeSyntax,
         whenGeneratingDynamicToo, ifGeneratingDynamicToo,
         whenCannotGenerateDynamicToo,
         dynamicTooMkDynamicDynFlags,
@@ -1684,6 +1685,9 @@ lang_set dflags lang =
             extensionFlags = flattenExtensionFlags lang (extensions dflags)
           }
 
+useUnicodeSyntax :: DynFlags -> Bool
+useUnicodeSyntax = xopt Opt_UnicodeSyntax
+
 -- | Set the Haskell language standard to use
 setLanguage :: Language -> DynP ()
 setLanguage l = upd (`lang_set` Just l)

compiler/main/DynFlags.hs-boot

@@ -10,3 +10,4 @@ pprUserLength        :: DynFlags -> Int
 pprCols              :: DynFlags -> Int
 unsafeGlobalDynFlags :: DynFlags
 useUnicodeQuotes     :: DynFlags -> Bool
+useUnicodeSyntax     :: DynFlags -> Bool

compiler/types/TypeRep.lhs

@@ -650,7 +650,7 @@ pprUserForAll tvs
 
 pprForAll :: [TyVar] -> SDoc
 pprForAll []  = empty
-pprForAll tvs = ptext (sLit "forall") <+> pprTvBndrs tvs <> dot
+pprForAll tvs = forAllLit <+> pprTvBndrs tvs <> dot
 
 pprTvBndrs :: [TyVar] -> SDoc
 pprTvBndrs tvs = sep (map pprTvBndr tvs)

compiler/utils/Outputable.lhs

@@ -22,11 +22,12 @@ module Outputable (
         char,
         text, ftext, ptext, ztext,
         int, intWithCommas, integer, float, double, rational,
-        parens, cparen, brackets, braces, quotes, quote, 
+        parens, cparen, brackets, braces, quotes, quote,
         doubleQuotes, angleBrackets, paBrackets,
-        semi, comma, colon, dcolon, space, equals, dot, arrow, darrow,
+        semi, comma, colon, dcolon, space, equals, dot,
+        arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt,
         lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
-        blankLine,
+        blankLine, forAllLit,
         (<>), (<+>), hcat, hsep,
         ($$), ($+$), vcat,
         sep, cat,
@@ -73,7 +74,7 @@ module Outputable (
 
 import {-# SOURCE #-}   DynFlags( DynFlags,
                                   targetPlatform, pprUserLength, pprCols,
-                                  useUnicodeQuotes,
+                                  useUnicodeQuotes, useUnicodeSyntax,
                                   unsafeGlobalDynFlags )
 import {-# SOURCE #-}   Module( Module, ModuleName, moduleName )
 import {-# SOURCE #-}   OccName( OccName )
@@ -468,13 +469,19 @@ quotes d =
              ('\'' : _, _)       -> pp_d
              _other              -> Pretty.quotes pp_d
 
-semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
-darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
+semi, comma, colon, equals, space, dcolon, underscore, dot :: SDoc
+arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc
+lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
 
 blankLine  = docToSDoc $ Pretty.ptext (sLit "")
-dcolon     = docToSDoc $ Pretty.ptext (sLit "::")
-arrow      = docToSDoc $ Pretty.ptext (sLit "->")
-darrow     = docToSDoc $ Pretty.ptext (sLit "=>")
+dcolon     = unicodeSyntax (char '∷') (docToSDoc $ Pretty.ptext (sLit "::"))
+arrow      = unicodeSyntax (char '→') (docToSDoc $ Pretty.ptext (sLit "->"))
+larrow     = unicodeSyntax (char '←') (docToSDoc $ Pretty.ptext (sLit "<-"))
+darrow     = unicodeSyntax (char '⇒') (docToSDoc $ Pretty.ptext (sLit "=>"))
+arrowt     = unicodeSyntax (char '↣') (docToSDoc $ Pretty.ptext (sLit ">-"))
+larrowt    = unicodeSyntax (char '↢') (docToSDoc $ Pretty.ptext (sLit "-<"))
+arrowtt    = unicodeSyntax (char '⤜') (docToSDoc $ Pretty.ptext (sLit ">>-"))
+larrowtt   = unicodeSyntax (char '⤛') (docToSDoc $ Pretty.ptext (sLit "-<<"))
 semi       = docToSDoc $ Pretty.semi
 comma      = docToSDoc $ Pretty.comma
 colon      = docToSDoc $ Pretty.colon
@@ -489,6 +496,14 @@ rbrack     = docToSDoc $ Pretty.rbrack
 lbrace     = docToSDoc $ Pretty.lbrace
 rbrace     = docToSDoc $ Pretty.rbrace
 
+forAllLit :: SDoc
+forAllLit = unicodeSyntax (char '∀') (ptext (sLit "forall"))
+
+unicodeSyntax :: SDoc -> SDoc -> SDoc
+unicodeSyntax unicode plain = sdocWithDynFlags $ \dflags ->
+    if useUnicodeSyntax dflags then unicode
+                               else plain
+
 nest :: Int -> SDoc -> SDoc
 -- ^ Indent 'SDoc' some specified amount
 (<>) :: SDoc -> SDoc -> SDoc

testsuite/tests/ghci/scripts/T8959.script

+:set -XPatternGuards -XArrows -XRankNTypes
+
+:t lookup
+:t undefined :: (forall a. a -> a) -> a
+:t () >- () -< () >>- () -<< ()
+let fun foo | True <- () = ()
+
+:set -XUnicodeSyntax
+
+:t lookup
+:t undefined :: (forall a. a -> a) -> a
+:t () >- () -< () >>- () -<< ()
+let fun foo | True <- () = ()
+
+:set -XNoUnicodeSyntax
+
+:t lookup
+:t undefined :: (forall a. a -> a) -> a
+:t () >- () -< () >>- () -<< ()
+let fun foo | True <- () = ()

testsuite/tests/ghci/scripts/T8959.stderr

+
+<interactive>:1:1:
+    Arrow command found where an expression was expected:
+      () >- () -< () >>- () -<< ()
+
+<interactive>:7:15:
+    Couldn't match expected type ‘()’ with actual type ‘Bool’
+    In the pattern: True
+    In a stmt of a pattern guard for
+                   an equation for ‘fun’:
+      True <- ()
+    In an equation for ‘fun’: fun foo | True <- () = ()
+
+<interactive>:1:1:
+    Arrow command found where an expression was expected:
+      () ↣ () ↢ () ⤜ () ⤛ ()
+
+<interactive>:14:15:
+    Couldn't match expected type ‘()’ with actual type ‘Bool’
+    In the pattern: True
+    In a stmt of a pattern guard for
+                   an equation for ‘fun’:
+      True ← ()
+    In an equation for ‘fun’: fun foo | True ← () = ()
+
+<interactive>:1:1:
+    Arrow command found where an expression was expected:
+      () >- () -< () >>- () -<< ()
+
+<interactive>:21:15:
+    Couldn't match expected type ‘()’ with actual type ‘Bool’
+    In the pattern: True
+    In a stmt of a pattern guard for
+                   an equation for ‘fun’:
+      True <- ()
+    In an equation for ‘fun’: fun foo | True <- () = ()

testsuite/tests/ghci/scripts/T8959.stdout

+lookup :: Eq a => a -> [(a, b)] -> Maybe b
+undefined :: (forall a. a -> a) -> a :: (forall a1. a1 -> a1) -> a
+lookup ∷ Eq a ⇒ a → [(a, b)] → Maybe b
+undefined :: (forall a. a -> a) -> a ∷ (∀ a1. a1 → a1) → a
+lookup :: Eq a => a -> [(a, b)] -> Maybe b
+undefined :: (forall a. a -> a) -> a :: (forall a1. a1 -> a1) -> a

testsuite/tests/ghci/scripts/all.T

@@ -172,3 +172,4 @@ test('ghci059', normal, ghci_script, ['ghci059.script'])
 test('T8831', normal, ghci_script, ['T8831.script'])
 test('T8917', normal, ghci_script, ['T8917.script'])
 test('T8931', normal, ghci_script, ['T8931.script'])
+test('T8959', normal, ghci_script, ['T8959.script'])