From 7b42ece52049756e046729a7c6f43b544bfd9ea6 Mon Sep 17 00:00:00 2001
From: Alfredo Di Napoli <alfredo.dinapoli@gmail.com>
Date: Sat, 13 Jul 2019 18:07:17 +0200
Subject: [PATCH] Line wrap when pp long expressions (fixes #16874)
This commit fixes #16874 by using `fsep` rather than `sep` when pretty
printing long patterns and expressions.
---
compiler/hsSyn/HsExpr.hs | 2 +-
compiler/hsSyn/HsPat.hs | 2 +-
testsuite/tests/typecheck/should_fail/T16874.hs | 12 ++++++++++++
testsuite/tests/typecheck/should_fail/T16874.stderr | 12 ++++++++++++
testsuite/tests/typecheck/should_fail/all.T | 1 +
5 files changed, 27 insertions(+), 2 deletions(-)
create mode 100644 testsuite/tests/typecheck/should_fail/T16874.hs
create mode 100644 testsuite/tests/typecheck/should_fail/T16874.stderr
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index 6bfdad16003b..69379bc1ad91 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -1077,7 +1077,7 @@ ppr_apps (HsApp _ (L _ fun) arg) args
= ppr_apps fun (Left arg : args)
ppr_apps (HsAppType _ (L _ fun) arg) args
= ppr_apps fun (Right arg : args)
-ppr_apps fun args = hang (ppr_expr fun) 2 (sep (map pp args))
+ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (map pp args))
where
pp (Left arg) = ppr arg
-- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg })))
diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs
index 9f8d2a5ed48c..06270e8a895e 100644
--- a/compiler/hsSyn/HsPat.hs
+++ b/compiler/hsSyn/HsPat.hs
@@ -584,7 +584,7 @@ pprUserCon c details = pprPrefixOcc c <+> pprConArgs details
pprConArgs :: (OutputableBndrId (GhcPass p))
=> HsConPatDetails (GhcPass p) -> SDoc
-pprConArgs (PrefixCon pats) = sep (map (pprParendLPat appPrec) pats)
+pprConArgs (PrefixCon pats) = fsep (map (pprParendLPat appPrec) pats)
pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1
, pprParendLPat appPrec p2 ]
pprConArgs (RecCon rpats) = ppr rpats
diff --git a/testsuite/tests/typecheck/should_fail/T16874.hs b/testsuite/tests/typecheck/should_fail/T16874.hs
new file mode 100644
index 000000000000..422340078efd
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T16874.hs
@@ -0,0 +1,12 @@
+
+module Main where
+
+type A = Int
+data D = D A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A
+
+test :: D -> D
+test (D a b c d e f g h i j k l m n o p q r s t u v w x y z aa bb cc dd ee ff gg hh ii jj kk ll mm nn)
+ = D a b c d e f g h i j k l m n o p q r s t u v w x y z aa bb cc dd ee ff gg hh ii jj kk ll mm nn
+
+main :: IO ()
+main = print ()
diff --git a/testsuite/tests/typecheck/should_fail/T16874.stderr b/testsuite/tests/typecheck/should_fail/T16874.stderr
new file mode 100644
index 000000000000..7c9d7ef6d5c9
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T16874.stderr
@@ -0,0 +1,12 @@
+
+T16874.hs:8:7: error:
+ • The constructor ‘D’ should have 41 arguments, but has been given 40
+ • In the pattern:
+ D a b c d e f g h i j k l m n o p q r s t u v w x y z aa bb cc dd
+ ee ff gg hh ii jj kk ll mm nn
+ In an equation for ‘test’:
+ test
+ (D a b c d e f g h i j k l m n o p q r s t u v w x y z aa bb cc dd
+ ee ff gg hh ii jj kk ll mm nn)
+ = D a b c d e f g h i j k l m n o p q r s t u v w x y z aa bb cc dd
+ ee ff gg hh ii jj kk ll mm nn
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index fd6790bb4645..fc49dbbb68a0 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -527,6 +527,7 @@ test('T15883e', normal, compile_fail, [''])
test('T16821', normal, compile_fail, [''])
test('T16829a', normal, compile_fail, [''])
test('T16829b', normal, compile_fail, [''])
+test('T16874', normal, compile_fail, [''])
test('UnliftedNewtypesFail', normal, compile_fail, [''])
test('UnliftedNewtypesNotEnabled', normal, compile_fail, [''])
test('UnliftedNewtypesCoerceFail', normal, compile_fail, [''])
--
GitLab