Improve test-suite, merging in GHC tests

pretty.cabal

@@ -49,6 +49,8 @@ Test-Suite test-pretty
     other-modules:
         TestGenerators
         TestStructures
+        UnitPP1
+        UnitT3911
     extensions: CPP, BangPatterns, DeriveGeneric
     include-dirs: src/Text/PrettyPrint
 

tests/BugSep.hs

@@ -1,3 +1,6 @@
+-- | Demonstration of ambiguity in HughesPJ library at this time. GHC's
+-- internal copy has a different answer than we currently do, preventing them
+-- using our library.
 module Main (main) where
 
 import Text.PrettyPrint.HughesPJ

tests/Test.hs

@@ -1,4 +1,3 @@
-{-# OPTIONS -XStandaloneDeriving -XDeriveDataTypeable -XPackageImports #-}
 -----------------------------------------------------------------------------
 -- Module      :  HughesPJQuickCheck
 -- Copyright   :  (c) 2008 Benedikt Huber
@@ -16,6 +15,9 @@ import PrettyTestVersion
 import TestGenerators
 import TestStructures
 
+import UnitPP1
+import UnitT3911
+
 import Control.Monad
 import Data.Char (isSpace)
 import Data.List (intersperse)
@@ -31,6 +33,8 @@ main = do
     check_non_prims -- hpc full coverage
     check_rendering
     check_list_def
+    testPP1
+    testT3911
 
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 -- Utility functions

tests/TestUtils.hs

@@ -0,0 +1,19 @@
+-- | Test-suite framework and utility functions.
+module TestUtils (
+    simpleMatch
+  ) where
+
+import Control.Monad
+import System.Exit
+
+simpleMatch :: String -> String -> String -> IO ()
+simpleMatch test expected actual =
+  when (actual /= expected) $ do
+    putStrLn $ "Test `" ++ test ++ "' failed!"
+    putStrLn "-----------------------------"
+    putStrLn $ "Expected: " ++ expected
+    putStrLn "-----------------------------"
+    putStrLn $ "Actual: " ++ actual
+    putStrLn "-----------------------------"
+    exitFailure
+

tests/UnitPP1.hs

@@ -0,0 +1,76 @@
+-- This code used to print an infinite string, by calling 'spaces'
+-- with a negative argument.  There's a patch in the library now,
+-- which makes 'spaces' do something sensible when called with a negative
+-- argument, but it really should not happen at all.
+
+module UnitPP1 where
+
+import TestUtils
+
+import Text.PrettyPrint.HughesPJ
+
+ncat :: Doc -> Doc -> Doc
+ncat x y = nest 4 $ cat [ x, y ]
+
+d1, d2 :: Doc
+d1 = foldl1 ncat $ take 50 $ repeat $ char 'a'
+d2 = parens $  sep [ d1, text "+" , d1 ]
+
+testPP1 :: IO ()
+testPP1 = simpleMatch "PP1" expected out
+  where out = show d2
+
+expected :: String
+expected =
+  "(aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\n\
++                                                                                                                                                                                                   a\n\
+ a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a\n\
+a)"
+

tests/UnitT3911.hs

@@ -0,0 +1,25 @@
+module UnitT3911 where
+
+import Text.PrettyPrint.HughesPJ
+
+import TestUtils
+
+xs :: [Doc]
+xs = [text "hello",
+      nest 10 (text "world")]
+
+d1, d2, d3 :: Doc
+d1 = vcat xs
+d2 = foldr ($$) empty xs
+d3 = foldr ($+$) empty xs
+
+testT3911 :: IO ()
+testT3911 = simpleMatch "T3911" expected out
+  where out = show d1 ++ "\n" ++ show d2 ++ "\n" ++ show d3
+
+expected :: String
+expected =
+  "hello     world\n\
+hello     world\n\
+hello\n\
+          world"