Add broken idempotent test

2 files changed, 63 insertions, 0 deletions

diff --git a/pfm.cabal b/pfm.cabal
index 63b292c..065ff64 100644
--- a/pfm.cabal
+++ b/pfm.cabal
@@ -47,3 +47,17 @@ executable readpfm
                , bytestring >=0.10 && <0.11
                , criterion >=1.5 && <1.6
   default-extensions: OverloadedStrings
+
+test-suite pfm-test
+  default-language: Haskell2010
+  type: exitcode-stdio-1.0
+  hs-source-dirs: test
+  main-is: Test.hs
+  ghc-options: -Wall -Werror
+  build-depends: base >=4.7 && <5
+               , pfm >=0.1 && <0.2
+               , tasty >=1.2 && <1.3
+               , tasty-hunit >=0.10 && <0.11
+               , tasty-quickcheck >=0.10 && <0.11
+               , bytestring >=0.10 && <0.11
+  default-extensions: OverloadedStrings
\ No newline at end of file
diff --git a/test/Test.hs b/test/Test.hs
new file mode 100644
index 0000000..63b846c
--- /dev/null
+++ b/test/Test.hs
@@ -0,0 +1,49 @@
+module Main where
+
+import qualified Data.ByteString.Lazy  as BL
+import           PFM
+import           Test.Tasty
+import           Test.Tasty.QuickCheck ((===))
+import qualified Test.Tasty.QuickCheck as QC
+
+newtype TestPFMImage = TestPFMImage { getPFMImage :: PFMImage }
+                     deriving (Show)
+
+newtype TestPFMColour = TestPFMColour { getPFMColour :: PFMColour }
+                     deriving (Show)
+
+newtype TestPPMImage = TestPPMImage  { getPPMImage :: PPMImage }
+                     deriving (Show)
+
+newtype TestPPMColour = TestPPMColour { getPPMColour :: PPMColour }
+                      deriving (Show)
+
+instance QC.Arbitrary TestPFMImage where
+    arbitrary = TestPFMImage <$> (PFMImage <$> QC.arbitrary <*> QC.arbitrary
+        <*> (QC.listOf1 . QC.listOf1) (getPFMColour <$> QC.arbitrary))
+
+instance QC.Arbitrary TestPPMImage where
+    arbitrary = TestPPMImage <$> (PPMImage <$> QC.arbitrary <*> QC.arbitrary
+        <*> (QC.listOf1 . QC.listOf1) (getPPMColour <$> QC.arbitrary))
+
+instance QC.Arbitrary TestPFMColour where
+    arbitrary = TestPFMColour <$> (PFMColour <$> QC.arbitrary <*> QC.arbitrary <*> QC.arbitrary)
+
+instance QC.Arbitrary TestPPMColour where
+    arbitrary = TestPPMColour <$> (PPMColour <$> QC.arbitrary <*> QC.arbitrary <*> QC.arbitrary)
+
+parserIdempotent' :: TestPFMImage -> QC.Property
+parserIdempotent' (TestPFMImage v) = p i === (p . p) i
+    where
+        encStrict = BL.toStrict . encode
+        i = encStrict v
+        p = encStrict . parse
+
+parserIdempotent :: TestTree
+parserIdempotent = QC.testProperty "parser idempotent" parserIdempotent'
+
+tests :: TestTree
+tests = testGroup "Property" [parserIdempotent]
+
+main :: IO ()
+main = defaultMain tests