[commit: ghc] master: Pretty: fix a broken invariant (#10735) (5d57087)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/5d57087e314bd484dbe14958f9b422be3ac6641a/ghc

>---------------------------------------------------------------

commit 5d57087e314bd484dbe14958f9b422be3ac6641a
Author: Thomas Miedema <thomasmiedema at gmail.com>
Date:   Wed Aug 5 11:31:21 2015 +0200

    Pretty: fix a broken invariant (#10735)
    
    This is a backport of a bug fix from
    6cfbd0444981c074bae10a3cf72733bcb8597bef in libraries/pretty:
    
        Fix a broken invariant
        Patch from #694,  for the problem "empty is an identity for <> and $$" is
        currently broken by eg. isEmpty (empty<>empty)"


>---------------------------------------------------------------

5d57087e314bd484dbe14958f9b422be3ac6641a
 compiler/utils/Pretty.hs | 18 ++++++++++++++----
 1 file changed, 14 insertions(+), 4 deletions(-)

diff --git a/compiler/utils/Pretty.hs b/compiler/utils/Pretty.hs
index 99566d3..d07bd3d 100644
--- a/compiler/utils/Pretty.hs
+++ b/compiler/utils/Pretty.hs
@@ -623,12 +623,17 @@ union_ = Union
 -- * @(x '$$' y) '<>' z = x '$$' (y '<>' z)@, if @y@ non-empty.
 --
 ($$) :: Doc -> Doc -> Doc
-p $$  q = Above p False q
+p $$  q = above_ p False q
 
 -- | Above, with no overlapping.
 -- '$+$' is associative, with identity 'empty'.
 ($+$) :: Doc -> Doc -> Doc
-p $+$ q = Above p True q
+p $+$ q = above_ p True q
+
+above_ :: Doc -> Bool -> Doc -> Doc
+above_ p _ Empty = p
+above_ Empty _ q = q
+above_ p g q     = Above p g q
 
 above :: Doc -> Bool -> RDoc -> RDoc
 above (Above p g1 q1)  g2 q2 = above p g1 (above q1 g2 q2)
@@ -679,12 +684,17 @@ nilAboveNest g k q           | not g && k > 0      -- No newline if no overlap
 -- | Beside.
 -- '<>' is associative, with identity 'empty'.
 (<>) :: Doc -> Doc -> Doc
-p <>  q = Beside p False q
+p <>  q = beside_ p False q
 
 -- | Beside, separated by space, unless one of the arguments is 'empty'.
 -- '<+>' is associative, with identity 'empty'.
 (<+>) :: Doc -> Doc -> Doc
-p <+> q = Beside p True  q
+p <+> q = beside_ p True  q
+
+beside_ :: Doc -> Bool -> Doc -> Doc
+beside_ p _ Empty = p
+beside_ Empty _ q = q
+beside_ p g q     = Beside p g q
 
 -- Specification: beside g p q = p <g> q
 beside :: Doc -> Bool -> RDoc -> RDoc