Commit 819e1f2c authored by Joachim Breitner's avatar Joachim Breitner

Use UnicodeSyntax when printing

When printing Haskell source, and UnicodeSyntax is enabled, use the
unicode sytax characters (#8959).
parent 1178fa4a
......@@ -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
......
......@@ -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))
......
......@@ -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
......
......@@ -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)
......
......@@ -10,3 +10,4 @@ pprUserLength :: DynFlags -> Int
pprCols :: DynFlags -> Int
unsafeGlobalDynFlags :: DynFlags
useUnicodeQuotes :: DynFlags -> Bool
useUnicodeSyntax :: DynFlags -> Bool
......@@ -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)
......
......@@ -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
......
: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 <- () = ()
<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 <- () = ()
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
......@@ -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'])
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment