netpbm 0.2.0 → 0.2.1

raw patch · 3 files changed

+133/−24 lines, 3 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• netpbm.cabal +1/−1
• src/Graphics/Netpbm.hs +23/−15
• test/Main.hs +109/−8

@@ -1,5 +1,5 @@ name:          netpbm-version:       0.2.0+version:       0.2.1 license:       MIT copyright:     2013 Niklas Hambüchen <mail@nh2.me> author:        Niklas Hambüchen <mail@nh2.me>

@@ -13,6 +13,7 @@ , PPM (..) , PpmPixelRGB8 , PpmPixelRGB16+, PPMHeader (..) , PpmPixelData (..) , parsePPM , PpmParseResult@@ -50,15 +51,18 @@  -- | A PPM file with type, dimensions, and image data. data PPM = PPM {-  ppmType :: PPMType-, ppmWidth  :: {-# UNPACK #-} !Int-, ppmHeight :: {-# UNPACK #-} !Int+  ppmHeader :: PPMHeader , ppmData   :: PpmPixelData } +data PPMHeader = PPMHeader {+  ppmType   :: PPMType+, ppmWidth  :: Int+, ppmHeight :: Int+} deriving (Eq, Show)  instance Show PPM where-  show PPM { ppmType, ppmWidth, ppmHeight } = "PPM " ++ show ppmType ++ " image " ++ dim+  show PPM { ppmHeader = PPMHeader { ppmType, ppmWidth, ppmHeight } } = "PPM " ++ show ppmType ++ " image " ++ dim     where       dim = show (ppmWidth, ppmHeight) @@ -162,9 +166,11 @@   skipSpace   comments   width <- decimalC+  comments   skipSpace   comments   height <- decimalC+  comments   skipSpace   comments   maxColorVal <- decimalC@@ -174,12 +180,13 @@   _ <- A8.satisfy isSpace -- obligatory SINGLE whitespace   -- Starting from here, comments are not allowed any more   raster <- if maxColorVal < 256 -- 1 or 2 bytes per pixel+      -- TODO check if values are smaller than maxColorVal       then PpmPixelDataRGB8 <$> (U.replicateM (height * width) $              PpmPixelRGB8 <$> anyWord8 <*> anyWord8 <*> anyWord8)       else PpmPixelDataRGB16 <$> (U.replicateM (height * width) $              PpmPixelRGB16 <$> anyWord16be <*> anyWord16be <*> anyWord16be) -  return $ PPM ppmType width height raster+  return $ PPM (PPMHeader ppmType width height) raster    where     isValidColorVal v = v > 0 && v < 65536@@ -187,10 +194,10 @@     comment = "#" .*> A.takeWhile isNotNewline <* endOfLine     isNotNewline w = w /= 10 && w /= 13     -- Decimal, possibly with comments interleaved,-    -- but starting with a digit.+    -- but starting and ending with a digit.     -- See the notes about comments above.     decimalC :: Parser Int-    decimalC = foldl' shiftDecimalChar 0 <$> many1' (digit <* comments)+    decimalC = foldl' shiftDecimalChar 0 <$> ((:) <$> digit <*> many (comments *> digit))     shiftDecimalChar a d = a * 10 + ord d - (48 :: Int)  @@ -219,14 +226,15 @@ -- and potentially an unparsable rest input. parsePPM :: ByteString -> PpmParseResult parsePPM bs = case parse imagesParser bs of-  Done ""   images -> Right (images, Nothing)-  Done rest images -> Right (images, Just rest)-  Fail _ _ e       -> Left e   -- The image file ByteStrings are not terminated by '\0',   -- so Attoparsec will issue a Partial result when it   -- parses to EOF. Passing in "" signalizes EOF.-  Partial cont -> case cont "" of-    Done ""   images -> Right (images, Nothing)-    Done rest images -> Right (images, Just rest)-    Partial _        -> error "parsePPM bug: Got a partial result after end of input"-    Fail _ _ e       -> Left e+  Partial cont -> resultToEither (cont "")+  r            -> resultToEither r+  where+    -- Assumes a Partial result has already been fed with "" (another Partial cannot happen)+    resultToEither r = case r of+      Done ""   images -> Right (images, Nothing)+      Done rest images -> Right (images, Just rest)+      Partial _        -> error "parsePPM bug: Got a partial result after end of input"+      Fail _ cs e      -> Left $ e ++ "; contexts: " ++ show cs

@@ -1,4 +1,4 @@-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NamedFieldPuns, OverloadedStrings #-}  import qualified Data.ByteString as BS import           Control.Applicative@@ -11,17 +11,23 @@  checkSinglePPM :: PPMType -> (Int, Int) -> PpmParseResult -> Assertion checkSinglePPM typ size parseResult = case parseResult of-  Right ([PPM { ppmType, ppmWidth, ppmHeight }], rest) -> (ppmType, (ppmWidth, ppmHeight), rest) `shouldBe` (typ, size, Nothing)+  Right ([PPM { ppmHeader = PPMHeader { ppmType, ppmWidth, ppmHeight } }], rest) -> (ppmType, (ppmWidth, ppmHeight), rest) `shouldBe` (typ, size, Nothing)   Right (ppms, _)                                      -> assertFailure $ "expected only one image, but got " ++ show (length ppms)-  _                                                    -> assertFailure "image parse failed"+  Left e                                               -> assertFailure $ "image parse failed: " ++ e  +shouldNotParse :: PpmParseResult -> Assertion+shouldNotParse res = case res of+  Left _ -> return ()+  Right r -> assertFailure $ "should not parse, but parses as: " ++ show r++ parse :: FilePath -> IO PpmParseResult parse f = parsePPM <$> BS.readFile f   parseTestFile :: String -> String -> (PpmParseResult -> Assertion) -> Spec-parseTestFile name desc check = it ("parses " ++ desc ++ " (" ++ name ++ ")") $+parseTestFile name desc check = it (desc ++ " (" ++ name ++ ")") $   parse ("test/ppms/" ++ name) >>= check  @@ -41,8 +47,103 @@     parseTestFile "testimg.ppm" "the color file from the netpbm test suite" $       checkSinglePPM P6 (227,149) -    parseTestFile "face.ppm" "a PPM with a trailing newline" $-      checkSinglePPM P6 (512,512)+    describe "more test files from the internet" $ do+      forM_+        [ ("boxes_1.ppm", (63,63))+        , ("boxes_2.ppm", (63,63))+        , ("house_1.ppm", (111,132))+        , ("house_2.ppm", (111,132))+        , ("moreboxes_1.ppm", (63,63))+        , ("moreboxes_2.ppm", (63,63))+        , ("sign_1.ppm", (99,99))+        , ("sign_2.ppm", (99,99))+        , ("stop_1.ppm", (99,99))+        , ("stop_2.ppm", (99,99))+        , ("synth_1.ppm", (100,100))+        , ("synth_2.ppm", (100,100))+        , ("tree_1.ppm", (133,133))+        , ("tree_2.ppm", (133,133))+        , ("west_1.ppm", (366,216))+        , ("west_2.ppm", (366,216))+        ] $ \(f, size) ->+          parseTestFile ("internet/set1/" ++ f) "from the internet" $+            checkSinglePPM P6 size -    -- parseTestFile "gitlogo-double.ppm" "a multi-image file" $ do-    --   checkSinglePPM P6 (220,92)++    parseTestFile "gitlogo-double.ppm" "a multi-image file" $ do+      \res -> case res of+        Right ([ PPM { ppmHeader = h1 }+               , PPM { ppmHeader = h2 }], rest) -> do h1 `shouldBe` PPMHeader P6 220 92+                                                      h2 `shouldBe` PPMHeader P6 220 92+                                                      rest `shouldBe` Nothing+        Right r                                    -> assertFailure $ "parsed unexpected: " ++ show r+        Left e                                     -> assertFailure $ "did not parse: " ++ e+++    describe "comments" $ do++      parseTestFile "gitlogo-comments.ppm" "comments as a sane user would write them" $+        checkSinglePPM P6 (220,92)++      parseTestFile "gitlogo-comment-after-magic-number.ppm" "a comment directly after the P6" $+        checkSinglePPM P6 (220,92)++      parseTestFile "gitlogo-only-spaces-in-header.ppm" "only spaces as header separators" $+        checkSinglePPM P6 (220,92)++      parseTestFile "gitlogo-comment-is-data.ppm" "the user thinks they wrote a comment, but it's actually parsed as data" $+        \res -> case res of+          Right ([PPM { ppmHeader }], Just rest) -> do ppmHeader `shouldBe` PPMHeader P6 220 92+                                                       rest `shouldBe` "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\n"+          Right r                                -> assertFailure $ "parsed unexpected: " ++ show r+          Left e                                 -> assertFailure $ "did not parse: " ++ e+++    describe "weird files that are still OK with the spec" $ do++      parseTestFile "weird/gitlogo-width-0.ppm" "width '00' set in an image" $+        \res -> case res of+          Right ([PPM { ppmHeader }], Just rest) -> do ppmHeader `shouldBe` PPMHeader P6 220 0+                                                       assertBool "missing rest" (BS.length rest > 200)+          Right r                                -> assertFailure $ "parsed unexpected: " ++ show r+          Left e                                 -> assertFailure $ "did not parse: " ++ e++      parseTestFile "weird/gitlogo-comments-everywhere.ppm" "comments inside numbers" $+        checkSinglePPM P6 (220,92)+++    describe "partially valid files of which we parse as much as we can" $ do++      parseTestFile "graceful/face.ppm" "a PPM with a trailing newline" $+        checkSinglePPM P6 (512,512)++      parseTestFile "graceful/gitlogo-one-and-a-half.ppm" "a multi-image file where the second image is chopped off" $+        \res -> case res of+          Right ([PPM { ppmHeader }], Just rest) -> do ppmHeader `shouldBe` PPMHeader P6 220 92+                                                       assertBool "missing rest" (BS.length rest > 200)+          Right r                                -> assertFailure $ "parsed unexpected: " ++ show r+          Left e                                 -> assertFailure $ "did not parse: " ++ e++      parseTestFile "graceful/gitlogo-double-with-whitespace-in-between.ppm" "a multi-image file with whitespace between the images" $+        \res -> case res of+          Right ([ PPM { ppmHeader = h1 }+                 , PPM { ppmHeader = h2 }], rest) -> do h1 `shouldBe` PPMHeader P6 220 92+                                                        h2 `shouldBe` PPMHeader P6 220 92+                                                        rest `shouldBe` Nothing+          Right r                                 -> assertFailure $ "parsed unexpected: " ++ show r+          Left e                                  -> assertFailure $ "did not parse: " ++ e+++    describe "negative examples" $ do++      parseTestFile "bad/gitlogo-garbage-in-numbers.ppm" "ascii characters in a number" shouldNotParse++      parseTestFile "bad/gitlogo-width--1.ppm" "width '-1' set in an image" shouldNotParse++      parseTestFile "bad/gitlogo-not-enough-data.ppm" "not containing (width * height) bytes" shouldNotParse++      parseTestFile "bad/gitlogo-comment-in-magic-number.ppm" "comment inside magic number" shouldNotParse++      parseTestFile "bad/gitlogo-comment-user-error.ppm" "a comment accidentally being put to close to a number, eating the following whitespace" $ shouldNotParse++      parseTestFile "bad/gitlogo-comment-without-following-extra-newline-before-data-block.ppm" "no non-comment whitespace before data block" shouldNotParse