[commit: packages/pretty] large_docs: Improve test-suite, merging in GHC tests (02503a3)
git at git.haskell.org
git at git.haskell.org
Fri Jan 23 22:49:56 UTC 2015
Repository : ssh://git@git.haskell.org/pretty
On branch : large_docs
Link : http://git.haskell.org/packages/pretty.git/commitdiff/02503a367d000f6b6d76db4ab238af134fdc92b8
>---------------------------------------------------------------
commit 02503a367d000f6b6d76db4ab238af134fdc92b8
Author: David Terei <code at davidterei.com>
Date: Thu Dec 25 23:58:45 2014 -0800
Improve test-suite, merging in GHC tests
>---------------------------------------------------------------
02503a367d000f6b6d76db4ab238af134fdc92b8
pretty.cabal | 2 ++
tests/BugSep.hs | 3 +++
tests/T3911.hs | 23 -----------------
tests/T3911.stdout | 4 ---
tests/Test.hs | 6 ++++-
tests/TestUtils.hs | 19 ++++++++++++++
tests/UnitPP1.hs | 76 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
tests/UnitT3911.hs | 25 ++++++++++++++++++
tests/all.T | 2 --
tests/pp1.hs | 18 -------------
tests/pp1.stdout | 4 ---
11 files changed, 130 insertions(+), 52 deletions(-)
diff --git a/pretty.cabal b/pretty.cabal
index e97ac11..104803e 100644
--- a/pretty.cabal
+++ b/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
diff --git a/tests/BugSep.hs b/tests/BugSep.hs
index 2047480..fe16b80 100644
--- a/tests/BugSep.hs
+++ b/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
diff --git a/tests/T3911.hs b/tests/T3911.hs
deleted file mode 100644
index 01ccb22..0000000
--- a/tests/T3911.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-
-module Main where
-
-import Text.PrettyPrint.HughesPJ
-
-xs :: [Doc]
-xs = [text "hello",
- nest 10 (text "world")]
-
-d1 :: Doc
-d1 = vcat xs
-
-d2 :: Doc
-d2 = foldr ($$) empty xs
-
-d3 :: Doc
-d3 = foldr ($+$) empty xs
-
-main :: IO ()
-main = do print d1
- print d2
- print d3
-
diff --git a/tests/T3911.stdout b/tests/T3911.stdout
deleted file mode 100644
index 7677e8d..0000000
--- a/tests/T3911.stdout
+++ /dev/null
@@ -1,4 +0,0 @@
-hello world
-hello world
-hello
- world
diff --git a/tests/Test.hs b/tests/Test.hs
index 51f659d..107e32a 100644
--- a/tests/Test.hs
+++ b/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
diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs
new file mode 100644
index 0000000..24ef7c7
--- /dev/null
+++ b/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
+
diff --git a/tests/UnitPP1.hs b/tests/UnitPP1.hs
new file mode 100644
index 0000000..31217c4
--- /dev/null
+++ b/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)"
+
diff --git a/tests/UnitT3911.hs b/tests/UnitT3911.hs
new file mode 100644
index 0000000..39aa1e2
--- /dev/null
+++ b/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"
diff --git a/tests/all.T b/tests/all.T
deleted file mode 100644
index 81e2c73..0000000
--- a/tests/all.T
+++ /dev/null
@@ -1,2 +0,0 @@
-test('pp1', [expect_broken(1062), only_ways(['normal'])], compile_and_run, [''])
-test('T3911', normal, compile_and_run, [''])
diff --git a/tests/pp1.hs b/tests/pp1.hs
deleted file mode 100644
index 384d565..0000000
--- a/tests/pp1.hs
+++ /dev/null
@@ -1,18 +0,0 @@
--- 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 Main where
-
-import Text.PrettyPrint.HughesPJ
-
-
-ncat x y = nest 4 $ cat [ x, y ]
-
-d1 = foldl1 ncat $ take 50 $ repeat $ char 'a'
-d2 = parens $ sep [ d1, text "+" , d1 ]
-
-main = print d2
-
diff --git a/tests/pp1.stdout b/tests/pp1.stdout
deleted file mode 100644
index 6915311..0000000
--- a/tests/pp1.stdout
+++ /dev/null
@@ -1,4 +0,0 @@
-This output is not what is expected, becuase the
-test "works" now, by virtue of a hack in HughesPJ.spaces.
-I'm leaving this strange output here to remind us to look
-at the root cause of the problem. Sometime.
\ No newline at end of file
More information about the ghc-commits
mailing list