Move ReadP tests from comments in the implementation into an actual U…

…nitTest file.

Cabal/Cabal.cabal

@@ -141,7 +141,9 @@ test-suite unit-tests
         base,
         test-framework,
         test-framework-hunit,
+        test-framework-quickcheck2,
         HUnit,
+        QuickCheck,
         Cabal
   Default-Language: Haskell98
 

Cabal/Distribution/Compat/ReadP.hs

@@ -19,6 +19,8 @@
 -- This version of ReadP has been locally hacked to make it H98, by
 -- Martin Sj&#xF6;gren <mailto:[email protected]>
 --
+-- The unit tests have been moved to UnitTest.Distribution.Compat.ReadP, by
+-- Mark Lentczner <mailto:[email protected]>
 -----------------------------------------------------------------------------
 
 module Distribution.Compat.ReadP
@@ -64,9 +66,6 @@ module Distribution.Compat.ReadP
   ReadS,      -- :: *; = String -> [(a,String)]
   readP_to_S, -- :: ReadP a -> ReadS a
   readS_to_P  -- :: ReadS a -> ReadP a
-
-  -- * Properties
-  -- $properties
   )
  where
 
@@ -378,93 +377,5 @@ readS_to_P :: ReadS a -> ReadP r a
 readS_to_P r =
   R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s']))
 
--- ---------------------------------------------------------------------------
--- QuickCheck properties that hold for the combinators
-
-{- $properties
-The following are QuickCheck specifications of what the combinators do.
-These can be seen as formal specifications of the behavior of the
-combinators.
-
-We use bags to give semantics to the combinators.
-
->  type Bag a = [a]
-
-Equality on bags does not care about the order of elements.
-
->  (=~) :: Ord a => Bag a -> Bag a -> Bool
->  xs =~ ys = sort xs == sort ys
-
-A special equality operator to avoid unresolved overloading
-when testing the properties.
-
->  (=~.) :: Bag (Int,String) -> Bag (Int,String) -> Bool
->  (=~.) = (=~)
-
-Here follow the properties:
-
->  prop_Get_Nil =
->    readP_to_S get [] =~ []
->
->  prop_Get_Cons c s =
->    readP_to_S get (c:s) =~ [(c,s)]
->
->  prop_Look s =
->    readP_to_S look s =~ [(s,s)]
->
->  prop_Fail s =
->    readP_to_S pfail s =~. []
->
->  prop_Return x s =
->    readP_to_S (return x) s =~. [(x,s)]
->
->  prop_Bind p k s =
->    readP_to_S (p >>= k) s =~.
->      [ ys''
->      | (x,s') <- readP_to_S p s
->      , ys''   <- readP_to_S (k (x::Int)) s'
->      ]
->
->  prop_Plus p q s =
->    readP_to_S (p +++ q) s =~.
->      (readP_to_S p s ++ readP_to_S q s)
->
->  prop_LeftPlus p q s =
->    readP_to_S (p <++ q) s =~.
->      (readP_to_S p s +<+ readP_to_S q s)
->   where
->    [] +<+ ys = ys
->    xs +<+ _  = xs
->
->  prop_Gather s =
->    forAll readPWithoutReadS $ \p ->
->      readP_to_S (gather p) s =~
->	 [ ((pre,x::Int),s')
->	 | (x,s') <- readP_to_S p s
->	 , let pre = take (length s - length s') s
->	 ]
->
->  prop_String_Yes this s =
->    readP_to_S (string this) (this ++ s) =~
->      [(this,s)]
->
->  prop_String_Maybe this s =
->    readP_to_S (string this) s =~
->      [(this, drop (length this) s) | this `isPrefixOf` s]
->
->  prop_Munch p s =
->    readP_to_S (munch p) s =~
->      [(takeWhile p s, dropWhile p s)]
->
->  prop_Munch1 p s =
->    readP_to_S (munch1 p) s =~
->      [(res,s') | let (res,s') = (takeWhile p s, dropWhile p s), not (null res)]
->
->  prop_Choice ps s =
->    readP_to_S (choice ps) s =~.
->      readP_to_S (foldr (+++) pfail ps) s
->
->  prop_ReadS r s =
->    readP_to_S (readS_to_P r) s =~. r s
--}
+
 

Cabal/tests/UnitTests.hs

@@ -5,8 +5,13 @@ module Main
 import Test.Framework
 import Test.Framework.Providers.HUnit
 
+import qualified UnitTests.Distribution.Compat.ReadP
+
 tests :: [Test]
-tests = []
+tests = [
+    testGroup "Distribution.Compat.ReadP"
+        UnitTests.Distribution.Compat.ReadP.tests
+    ]
 
 main :: IO ()
 main = defaultMain tests

Cabal/tests/UnitTests/Distribution/Compat/ReadP.hs

@@ -0,0 +1,140 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Distribution.Compat.ReadP
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  [email protected]
+-- Portability :  portable
+--
+-- This code was originally in Distribution.Compat.ReadP. Please see that file
+-- for provenace. The tests have been integrated into the test framework.
+-- Some properties cannot be tested, as they hold over arbitrary ReadP values,
+-- and we don't have a good Arbitrary instance (nor Show instance) for ReadP.
+--
+module UnitTests.Distribution.Compat.ReadP
+    ( tests
+    -- * Properties
+    -- $properties
+    ) where
+
+import Data.List
+import Distribution.Compat.ReadP
+
+import Test.Framework
+import Test.Framework.Providers.HUnit
+import Test.Framework.Providers.QuickCheck2
+
+tests =
+    [ testProperty "Get Nil" prop_Get_Nil
+    , testProperty "Get Cons" prop_Get_Cons
+    , testProperty "Look" prop_Look
+    , testProperty "Fail" prop_Fail
+    , testProperty "Return" prop_Return
+    --, testProperty "Bind" prop_Bind
+    --, testProperty "Plus" prop_Plus
+    --, testProperty "LeftPlus" prop_LeftPlus
+    --, testProperty "Gather" prop_Gather
+    , testProperty "String Yes" prop_String_Yes
+    , testProperty "String Maybe" prop_String_Maybe
+    , testProperty "Munch" (prop_Munch evenChar)
+    , testProperty "Munch1" (prop_Munch1 evenChar)
+    --, testProperty "Choice" prop_Choice
+    --, testProperty "ReadS" prop_ReadS
+    ]
+
+-- ---------------------------------------------------------------------------
+-- QuickCheck properties that hold for the combinators
+
+{- $properties
+The following are QuickCheck specifications of what the combinators do.
+These can be seen as formal specifications of the behavior of the
+combinators.
+
+We use bags to give semantics to the combinators.
+-}
+
+type Bag a = [a]
+
+-- Equality on bags does not care about the order of elements.
+
+(=~) :: Ord a => Bag a -> Bag a -> Bool
+xs =~ ys = sort xs == sort ys
+
+-- A special equality operator to avoid unresolved overloading
+-- when testing the properties.
+
+(=~.) :: Bag (Int,String) -> Bag (Int,String) -> Bool
+(=~.) = (=~)
+
+-- Here follow the properties:
+
+prop_Get_Nil =
+  readP_to_S get [] =~ []
+
+prop_Get_Cons c s =
+  readP_to_S get (c:s) =~ [(c,s)]
+
+prop_Look s =
+  readP_to_S look s =~ [(s,s)]
+
+prop_Fail s =
+  readP_to_S pfail s =~. []
+
+prop_Return x s =
+  readP_to_S (return x) s =~. [(x,s)]
+
+prop_Bind p k s =
+  readP_to_S (p >>= k) s =~.
+    [ ys''
+    | (x,s') <- readP_to_S p s
+    , ys''   <- readP_to_S (k (x::Int)) s'
+    ]
+
+prop_Plus p q s =
+  readP_to_S (p +++ q) s =~.
+    (readP_to_S p s ++ readP_to_S q s)
+
+prop_LeftPlus p q s =
+  readP_to_S (p <++ q) s =~.
+    (readP_to_S p s +<+ readP_to_S q s)
+ where
+  [] +<+ ys = ys
+  xs +<+ _  = xs
+
+{-
+prop_Gather s =
+  forAll readPWithoutReadS $ \p ->
+    readP_to_S (gather p) s =~
+  [ ((pre,x::Int),s')
+  | (x,s') <- readP_to_S p s
+  , let pre = take (length s - length s') s
+  ]
+-}
+
+prop_String_Yes this s =
+  readP_to_S (string this) (this ++ s) =~
+    [(this,s)]
+
+prop_String_Maybe this s =
+  readP_to_S (string this) s =~
+    [(this, drop (length this) s) | this `isPrefixOf` s]
+
+prop_Munch p s =
+  readP_to_S (munch p) s =~
+    [(takeWhile p s, dropWhile p s)]
+
+prop_Munch1 p s =
+  readP_to_S (munch1 p) s =~
+    [(res,s') | let (res,s') = (takeWhile p s, dropWhile p s), not (null res)]
+
+prop_Choice ps s =
+  readP_to_S (choice ps) s =~.
+    readP_to_S (foldr (+++) pfail ps) s
+
+prop_ReadS r s =
+  readP_to_S (readS_to_P r) s =~. r s
+
+evenChar :: Char -> Bool
+evenChar = even . fromEnum
+