summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/hsSyn/HsDecls.lhs2
-rw-r--r--compiler/hsSyn/HsExpr.lhs18
-rw-r--r--compiler/hsSyn/HsTypes.lhs2
-rw-r--r--compiler/main/DynFlags.hs4
-rw-r--r--compiler/main/DynFlags.hs-boot1
-rw-r--r--compiler/types/TypeRep.lhs2
-rw-r--r--compiler/utils/Outputable.lhs33
-rw-r--r--testsuite/tests/ghci/scripts/T8959.script20
-rw-r--r--testsuite/tests/ghci/scripts/T8959.stderr36
-rw-r--r--testsuite/tests/ghci/scripts/T8959.stdout6
-rwxr-xr-xtestsuite/tests/ghci/scripts/all.T1
11 files changed, 104 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
diff --git a/testsuite/tests/ghci/scripts/T8959.script b/testsuite/tests/ghci/scripts/T8959.script
new file mode 100644
index 0000000000..124b2ab2f5
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T8959.script
@@ -0,0 +1,20 @@
+: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 <- () = ()
diff --git a/testsuite/tests/ghci/scripts/T8959.stderr b/testsuite/tests/ghci/scripts/T8959.stderr
new file mode 100644
index 0000000000..b3995c3365
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T8959.stderr
@@ -0,0 +1,36 @@
+
+<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 <- () = ()
diff --git a/testsuite/tests/ghci/scripts/T8959.stdout b/testsuite/tests/ghci/scripts/T8959.stdout
new file mode 100644
index 0000000000..4631732c55
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T8959.stdout
@@ -0,0 +1,6 @@
+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
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index 1b5c47003b..b0a9912df4 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/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'])
View Lorry Controller Status