Pretty: fix potential bad formatting of error message (#10735)

This is a backport of a bug fix by Benedikt Huber for the same problem
in the pretty library (#1337), from commit
8d8866a8379c2fe8108ef034893c59e06d5e752f. The original explanation for
the fix is attached below.

Ticket #1776 originally reported an infinite loop when printing error
message. This promptly got fixed in:

  commit 2d52ee06786e5caf0c2d65a4b4bb7c45c6493190
  Author: simonpj@microsoft.com <unknown>
  Date:   Thu Mar 1 11:45:13 2007 +0000

      Do not go into an infinite loop when pretty-printer finds a
      negative indent (Trac #1176)

SPJ reports in the ticket: "So infinite loop is fixed, but the bad
formatting remains. I've added a test, tcfail177."

tcfail177 however hasn't triggered the formatting problem for years (as
Ian reported in c9e0e6067a47c574d9ff3721afe58e30ca1be3e4).

This patch updates the test to a version that at least still failed with
ghc-7.0 (from #1776#comment:7).

-------------------

From https://mail.haskell.org/pipermail/libraries/2008-June/010013.html,
by Benedikt Huber:

    Concerning ticket #1337, we have to change the formal specification of
    fill (it doesn't match the implementation):

    -- Current Specification:
    --   fill []  = empty
    --   fill [p] = p
    --   fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1)
    --                                          (fill (oneLiner p2 : ps))
    --                     `union`
    --                      p1 $$ fill ps

    Problem 1: We want to `unnest' the second argument of (p1 $$ fill ps),
    but not the first one

    In the definition above we have e.g.

    > getSecondLayout $
    >   fillDef False [text "a", text "b", text "a"]

    >> text "ab"; nilabove; nest -1; text "a"; empty
    >> |ab|
    >> |.a|

    Problem 2: The overlapping $$ should only be used for those layouts of
    p1 which aren't one liners (otherwise violating the invariant "Left
    union arg has shorter first line").

    I suggest the following specification (i believe it almost matches the
    current implementation, modulo [fillNB: fix bug #1337] (see below):

    -- Revised Specification:
    --   fill g docs = fill' 0 docs
    --   gap g       = if g then 1 else 0
    --   fill' n []  = []
    --   fill' n [p] = [p]
    --   fill' n (p1:p2:ps) =
    --      oneLiner p1 <g> (fill' (n+length p1+gap g) (oneLiner p2 : ps))
    --        `union`
    --     (p1 $*$ nest (-n) (fill' g ps))
    --
    -- $*$ is defined for layouts (One-Layout Documents) as
    --
    -- layout1 $*$ layout2 | isOneLiner layout1 = layout1 $+$ layout2
    --                     | otherwise          = layout1 $$ layout2

    I've also implemented the specification in HughesPJQuickCheck.hs,
    and checked them against the patched pretty printer.

    Concerning Bug #1337:
    ~~~~~~~~~~~~~~~~~~~~~

    If the above formal specification is fine, it is easy to fix:
    elide the nests of (oneLiner p2) [see attached patch, record bug #1337].

    > PrettyPrint(0) $ ./Bug1337
    > ....ab
    > ...c

    The (long) explanation follows below.

    <snip/>

    ===========================================================
    Explanation of Bug #1337:

    Consider

    > fcat [ nest 1 $ text "a", nest 2 $ text "b", text "c"]

    --> expected: (nest 1; text "a"; text "b"; nest -3; "c")
    --> actual  : (nest 1; text "a"; text "b"; nest -5; "c")

    Reduction:
    === (nest 1; text a) <> (fill (-2) (p2:ps))
    ==>                     (nest 2 (text "b") $+$ text "c")
    ==>                     (nest 2 (text "b")) `nilabove`
                            (nest (-3) (text "c"))
    ==> (nest 1; text a; text b; nest -5 c)

    The problem is that if we decide to layout (p1:p2:ps) as

    | p1 p2
    | ps

    (call it layout A), then we want to have

    > (p1 <> p2) $+$ ps.

    But following law <n6> this means that

    > fcat_A [p1:nest k p2:ps]

    is equivalent to

    > fcat_A [p1,p2,ps]

    so the nest of p2 has to be removed.

    This is somewhat similar to bug #667, but easier to fix
    from a semantic point of view:
    p1,p2 and ps are distinct layouts - we only have to preserve the
    individual layouts, and no combinations of them.

3 files changed, 66 insertions, 184 deletions

diff --git a/compiler/utils/Pretty.hs b/compiler/utils/Pretty.hs
index 607d265e82..99566d36ea 100644
--- a/compiler/utils/Pretty.hs
+++ b/compiler/utils/Pretty.hs
@@ -822,11 +822,14 @@ fillNB g p k ys             = fill1 g p k ys
 
 fillNBE :: Bool -> Int -> Doc -> [Doc] -> Doc
 fillNBE g k y ys
-  = nilBeside g (fill1 g ((oneLiner . reduceDoc) y) k' ys)
+  = nilBeside g (fill1 g ((elideNest . oneLiner . reduceDoc) y) k' ys)
     -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...)
     `mkUnion` nilAboveNest False k (fill g (y:ys))
   where k' = if g then k - 1 else k
 
+elideNest :: Doc -> Doc
+elideNest (Nest _ d) = d
+elideNest d          = d
 
 -- ---------------------------------------------------------------------------
 -- Selecting the best layout
diff --git a/testsuite/tests/typecheck/should_fail/tcfail177.hs b/testsuite/tests/typecheck/should_fail/tcfail177.hs
index d9e60e96fc..8d264db53d 100644
--- a/testsuite/tests/typecheck/should_fail/tcfail177.hs
+++ b/testsuite/tests/typecheck/should_fail/tcfail177.hs
@@ -2,33 +2,58 @@ module ShouldFail where
 
 -- See Trac #1176
 -- This is really a pretty-printer test, not a typechecker test
--- The more infix ops we have, the worse fsep works
+--
+-- Before ghc-7.2 the error messages looked like this (notice the wrong
+-- indentation):
 
--- Currently the error message looks ok, however
+{-
+tcfail177.hs:9:12:
+    Couldn't match expected type `Bool' with actual type `Int'
+    In the return type of a call of `foo'
+    In the expression:
+      foo
+        ["One........" ~?= "1", "Two" ~?= "2", "Thre........." ~?= "3",
+     "Four" ~?= "4", ....]
+    In an equation for `allTest1':
+        allTest1
+          = foo
+              ["One........" ~?= "1", "Two" ~?= "2", "Thre........." ~?= "3",
+         ....]
 
-allTests :: Bool
-allTests = foo
-           [a ~?= b
-           ,"Three" ~?= "3"
+tcfail177.hs:18:12:
+    Couldn't match expected type `Bool' with actual type `Int'
+    In the return type of a call of `foo'
+    In the expression:
+      foo
+        ["One........" ~?= "1", "Two.................." ~?= "2",
+       "Thre........." ~?= "3", "Four" ~?= "4", ....]
+    In an equation for `allTest2':
+        allTest2
+          = foo
+              ["One........" ~?= "1", "Two.................." ~?= "2",
+             "Thre........." ~?= "3", ....]
+-}
+
+allTest1 :: Bool
+allTest1 = foo
+           ["One........" ~?= "1"
+           ,"Two" ~?= "2"
+           ,"Thre........." ~?= "3"
            ,"Four" ~?= "4"
            ,"Five" ~?= "5"
-           ,"Five" ~?= "5"
-           ,"Five" ~?= "5"
-           ,"Five" ~?= "5"
-           ,"Five" ~?= "5"
-           ,"Five" ~?= "5"
-           ,"Two", "Two", "Two" 
-           ,"Two", "Two", "Two" 
-           ,"Two", "Two", "Two" 
-           ,"Two", "Two", "Two" 
-           ,"Two", "Two", "Two" 
-           ,"Two", "Two", "Two"] 
+           ]
 
-a=""
-b=""
+allTest2 :: Bool
+allTest2 = foo
+           ["One........" ~?= "1"
+           ,"Two.................." ~?= "2"
+           ,"Thre........." ~?= "3"
+           ,"Four" ~?= "4"
+           ,"Five" ~?= "5"
+           ]
 
 (~?=) :: a -> a -> Bool
-(~?=) = error "urk" 
+(~?=) = error "urk"
 
 foo :: a -> Int
 foo x = 0
diff --git a/testsuite/tests/typecheck/should_fail/tcfail177.stderr b/testsuite/tests/typecheck/should_fail/tcfail177.stderr
index 54d7331172..206f9ced6c 100644
--- a/testsuite/tests/typecheck/should_fail/tcfail177.stderr
+++ b/testsuite/tests/typecheck/should_fail/tcfail177.stderr
@@ -1,170 +1,24 @@
 
-tcfail177.hs:10:12:
+tcfail177.hs:38:12: error:
     Couldn't match expected type ‘Bool’ with actual type ‘Int’
     In the expression:
       foo
-        [a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]
-    In an equation for ‘allTests’:
-        allTests = foo [a ~?= b, "Three" ~?= "3", "Four" ~?= "4", ....]
+        ["One........" ~?= "1", "Two" ~?= "2", "Thre........." ~?= "3",
+         "Four" ~?= "4", ....]
+    In an equation for ‘allTest1’:
+        allTest1
+          = foo
+              ["One........" ~?= "1", "Two" ~?= "2", "Thre........." ~?= "3",
+               ....]
 
-tcfail177.hs:20:13:
-    Couldn't match expected type ‘Bool’ with actual type ‘[Char]’
-    In the expression: "Two"
-    In the first argument of ‘foo’, namely
-      ‘[a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]’
-    In the expression:
-      foo
-        [a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]
-
-tcfail177.hs:20:20:
-    Couldn't match expected type ‘Bool’ with actual type ‘[Char]’
-    In the expression: "Two"
-    In the first argument of ‘foo’, namely
-      ‘[a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]’
-    In the expression:
-      foo
-        [a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]
-
-tcfail177.hs:20:27:
-    Couldn't match expected type ‘Bool’ with actual type ‘[Char]’
-    In the expression: "Two"
-    In the first argument of ‘foo’, namely
-      ‘[a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]’
-    In the expression:
-      foo
-        [a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]
-
-tcfail177.hs:21:13:
-    Couldn't match expected type ‘Bool’ with actual type ‘[Char]’
-    In the expression: "Two"
-    In the first argument of ‘foo’, namely
-      ‘[a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]’
-    In the expression:
-      foo
-        [a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]
-
-tcfail177.hs:21:20:
-    Couldn't match expected type ‘Bool’ with actual type ‘[Char]’
-    In the expression: "Two"
-    In the first argument of ‘foo’, namely
-      ‘[a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]’
-    In the expression:
-      foo
-        [a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]
-
-tcfail177.hs:21:27:
-    Couldn't match expected type ‘Bool’ with actual type ‘[Char]’
-    In the expression: "Two"
-    In the first argument of ‘foo’, namely
-      ‘[a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]’
-    In the expression:
-      foo
-        [a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]
-
-tcfail177.hs:22:13:
-    Couldn't match expected type ‘Bool’ with actual type ‘[Char]’
-    In the expression: "Two"
-    In the first argument of ‘foo’, namely
-      ‘[a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]’
-    In the expression:
-      foo
-        [a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]
-
-tcfail177.hs:22:20:
-    Couldn't match expected type ‘Bool’ with actual type ‘[Char]’
-    In the expression: "Two"
-    In the first argument of ‘foo’, namely
-      ‘[a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]’
-    In the expression:
-      foo
-        [a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]
-
-tcfail177.hs:22:27:
-    Couldn't match expected type ‘Bool’ with actual type ‘[Char]’
-    In the expression: "Two"
-    In the first argument of ‘foo’, namely
-      ‘[a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]’
-    In the expression:
-      foo
-        [a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]
-
-tcfail177.hs:23:13:
-    Couldn't match expected type ‘Bool’ with actual type ‘[Char]’
-    In the expression: "Two"
-    In the first argument of ‘foo’, namely
-      ‘[a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]’
-    In the expression:
-      foo
-        [a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]
-
-tcfail177.hs:23:20:
-    Couldn't match expected type ‘Bool’ with actual type ‘[Char]’
-    In the expression: "Two"
-    In the first argument of ‘foo’, namely
-      ‘[a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]’
-    In the expression:
-      foo
-        [a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]
-
-tcfail177.hs:23:27:
-    Couldn't match expected type ‘Bool’ with actual type ‘[Char]’
-    In the expression: "Two"
-    In the first argument of ‘foo’, namely
-      ‘[a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]’
-    In the expression:
-      foo
-        [a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]
-
-tcfail177.hs:24:13:
-    Couldn't match expected type ‘Bool’ with actual type ‘[Char]’
-    In the expression: "Two"
-    In the first argument of ‘foo’, namely
-      ‘[a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]’
-    In the expression:
-      foo
-        [a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]
-
-tcfail177.hs:24:20:
-    Couldn't match expected type ‘Bool’ with actual type ‘[Char]’
-    In the expression: "Two"
-    In the first argument of ‘foo’, namely
-      ‘[a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]’
-    In the expression:
-      foo
-        [a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]
-
-tcfail177.hs:24:27:
-    Couldn't match expected type ‘Bool’ with actual type ‘[Char]’
-    In the expression: "Two"
-    In the first argument of ‘foo’, namely
-      ‘[a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]’
-    In the expression:
-      foo
-        [a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]
-
-tcfail177.hs:25:13:
-    Couldn't match expected type ‘Bool’ with actual type ‘[Char]’
-    In the expression: "Two"
-    In the first argument of ‘foo’, namely
-      ‘[a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]’
-    In the expression:
-      foo
-        [a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]
-
-tcfail177.hs:25:20:
-    Couldn't match expected type ‘Bool’ with actual type ‘[Char]’
-    In the expression: "Two"
-    In the first argument of ‘foo’, namely
-      ‘[a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]’
-    In the expression:
-      foo
-        [a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]
-
-tcfail177.hs:25:27:
-    Couldn't match expected type ‘Bool’ with actual type ‘[Char]’
-    In the expression: "Two"
-    In the first argument of ‘foo’, namely
-      ‘[a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]’
+tcfail177.hs:47:12: error:
+    Couldn't match expected type ‘Bool’ with actual type ‘Int’
     In the expression:
       foo
-        [a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....]
+        ["One........" ~?= "1", "Two.................." ~?= "2",
+         "Thre........." ~?= "3", "Four" ~?= "4", ....]
+    In an equation for ‘allTest2’:
+        allTest2
+          = foo
+              ["One........" ~?= "1", "Two.................." ~?= "2",
+               "Thre........." ~?= "3", ....]