pure-zlib-0.8.0: test/Test.hs

import Codec.Compression.Zlib
import Codec.Compression.Zlib.Deflate
import Data.ByteString.Lazy (readFile)
import Data.Char (ord)
import Data.List (isPrefixOf)
import System.FilePath
import Test.Tasty
import Test.Tasty.HUnit
import Prelude hiding (readFile)

-- -----------------------------------------------------------------------------

rfcSimpleTestLengths :: [(Int, Int)]
rfcSimpleTestLengths =
  [ (ord 'A', 3)
  , (ord 'B', 3)
  , (ord 'C', 3)
  , (ord 'D', 3)
  , (ord 'E', 3)
  , (ord 'F', 2)
  , (ord 'G', 4)
  , (ord 'H', 4)
  ]

rfcSimpleTestResults :: [(Int, Int, Int)]
rfcSimpleTestResults =
  [ (ord 'A', 3, 2) --  010
  , (ord 'B', 3, 3) --  011
  , (ord 'C', 3, 4) --  100
  , (ord 'D', 3, 5) --  101
  , (ord 'E', 3, 6) --  110
  , (ord 'F', 2, 0) --   00
  , (ord 'G', 4, 14) -- 1110
  , (ord 'H', 4, 15) -- 1111
  ]

fixedHuffmanLengths :: [(Int, Int)]
fixedHuffmanLengths =
  ( [(x, 8) | x <- [0 .. 143]]
    ++ [(x, 9) | x <- [144 .. 255]]
      ++ [(x, 7) | x <- [256 .. 279]]
      ++ [(x, 8) | x <- [280 .. 287]]
  )

fixedHuffmanResults :: [(Int, Int, Int)]
fixedHuffmanResults =
  ( [(fst x, 8, snd x) | x <- zip [0 .. 143] [48 .. 191]]
    ++ [(fst x, 9, snd x) | x <- zip [144 .. 255] [400 .. 511]] --  00110000 through  10111111
      ++ [(fst x, 7, snd x) | x <- zip [256 .. 279] [0 .. 23]] -- 110010000 through 111111111
      ++ [(fst x, 8, snd x) | x <- zip [280 .. 287] [192 .. 199]] --   0000000 through   0010111
      --  11000000 through  11000111
  )

-- -----------------------------------------------------------------------------

testCases :: [FilePath]
testCases =
  [ "randtest1"
  , "randtest2"
  , "randtest3"
  , "rfctest1"
  , "rfctest2"
  , "rfctest3"
  , "zerotest1"
  , "zerotest2"
  , "zerotest3"
  ]

buildGoldTestCases :: IO TestTree
buildGoldTestCases =
  do
    trees <- mapM buildGoldTest testCases
    return (testGroup "Decompression Tests" trees)

buildGoldTest :: FilePath -> IO TestTree
buildGoldTest test =
  do
    let compressedFile = "test" </> "test-cases" </> test <.> "z"
        goldFile = "test" </> "test-cases" </> test <.> "gold"
    compressedBStr <- readFile compressedFile
    goldBStr <- readFile goldFile
    return
      ( testCase
          (toTestCaseName test)
          (assertEqual test (Right goldBStr) (decompress compressedBStr))
      )

toTestCaseName :: FilePath -> String
toTestCaseName fpath = prefix ++ suffix
 where
  prefix
    | "zero" `isPrefixOf` fpath = "Zero test #"
    | "rand" `isPrefixOf` fpath = "Random test #"
    | "rfc" `isPrefixOf` fpath = "RFC test #"
    | otherwise = error "Bad test case prefix."
  suffix = [last fpath]

-- -----------------------------------------------------------------------------

zlibTests :: IO TestTree
zlibTests =
  do
    decompTests <- buildGoldTestCases
    return $
      testGroup
        "DEFLATE / ZLib Algorithm Testing"
        [ testCase
            "RFC 1951 Code Generation Test"
            ( assertEqual
                ""
                (computeCodeValues rfcSimpleTestLengths)
                rfcSimpleTestResults
            )
        , testCase
            "Fixed Huffman lengths make right tree"
            ( assertEqual
                ""
                (computeCodeValues fixedHuffmanLengths)
                fixedHuffmanResults
            )
        , decompTests
        ]

main :: IO ()
main = defaultMain =<< zlibTests