Use UnicodeSyntax when printing

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

7 files changed, 41 insertions, 21 deletions

diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index bae804eb07..c4174db776 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/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
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 938227ce0f..aa7923f444 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/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))
diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 098d45f02f..7b7c7574b2 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/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
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 5f125ef944..ea4d008bf3 100644
--- a/compiler/main/DynFlags.hs
+++ b/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)
diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot
index 04ec5a4e7d..f3f472a31a 100644
--- a/compiler/main/DynFlags.hs-boot
+++ b/compiler/main/DynFlags.hs-boot
@@ -10,3 +10,4 @@ pprUserLength        :: DynFlags -> Int
 pprCols              :: DynFlags -> Int
 unsafeGlobalDynFlags :: DynFlags
 useUnicodeQuotes     :: DynFlags -> Bool
+useUnicodeSyntax     :: DynFlags -> Bool
diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index f7a1cd3bc9..2a38a5d9e0 100644
--- a/compiler/types/TypeRep.lhs
+++ b/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)
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index 85d3d03557..a933fee75d 100644
--- a/compiler/utils/Outputable.lhs
+++ b/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