{-# LANGUAGE OverloadedStrings, NamedFieldPuns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, MultiParamTypeClasses, TemplateHaskell #-}


-- | Parsing the netpbm image formates (PBM, PGM and PPM, both ASCII and binary) from 'ByteString's.
--
-- All netpbm image formats are implemented (P1 - P6).
--
-- To parse one of these formats, use `parsePPM`.
--
-- See also: <http://www.imagemagick.org/Usage/formats/#netpbm>
module Graphics.Netpbm (
  PPMType (..)
, PPM (..)
, PpmPixelRGB8 (..)
, PpmPixelRGB16 (..)
, PbmPixel (..)
, PgmPixel8 (..)
, PgmPixel16 (..)
, PPMHeader (..)
, PpmPixelData (..)
, pixelVectorToList
, pixelDataToIntList
, parsePPM
, PpmParseResult
-- TODO expose attoparsec functions in .Internal package
) where

import           Control.Monad
import           Control.Applicative
import           Data.Attoparsec.ByteString as A
import           Data.Attoparsec.ByteString.Char8 as A8
import           Data.Attoparsec.Binary (anyWord16be)
import           Data.Bits (testBit)
import           Data.ByteString (ByteString)
import           Data.Char (chr, ord)
import           Data.List (foldl')
import           Data.Word (Word8, Word16)
import           Foreign.Storable.Record as Store
import           Foreign.Storable (Storable (..))

import qualified Data.Vector.Storable as S
import           Data.Vector.Storable ((!))
import qualified Data.Vector.Storable.Mutable as SM

import Data.Vector.Unboxed.Deriving


-- | The netpbm image type of an image.
data PPMType = P1 -- ^ ASCII bitmap
             | P2 -- ^ ASCII greymap
             | P3 -- ^ ASCII pixmap (color)
             | P4 -- ^ binary bitmap
             | P5 -- ^ binary greymap
             | P6 -- ^ binary pixmap (color)
             deriving (PPMType -> PPMType -> Bool
(PPMType -> PPMType -> Bool)
-> (PPMType -> PPMType -> Bool) -> Eq PPMType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PPMType -> PPMType -> Bool
$c/= :: PPMType -> PPMType -> Bool
== :: PPMType -> PPMType -> Bool
$c== :: PPMType -> PPMType -> Bool
Eq, Int -> PPMType -> ShowS
[PPMType] -> ShowS
PPMType -> String
(Int -> PPMType -> ShowS)
-> (PPMType -> String) -> ([PPMType] -> ShowS) -> Show PPMType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PPMType] -> ShowS
$cshowList :: [PPMType] -> ShowS
show :: PPMType -> String
$cshow :: PPMType -> String
showsPrec :: Int -> PPMType -> ShowS
$cshowsPrec :: Int -> PPMType -> ShowS
Show, Int -> PPMType
PPMType -> Int
PPMType -> [PPMType]
PPMType -> PPMType
PPMType -> PPMType -> [PPMType]
PPMType -> PPMType -> PPMType -> [PPMType]
(PPMType -> PPMType)
-> (PPMType -> PPMType)
-> (Int -> PPMType)
-> (PPMType -> Int)
-> (PPMType -> [PPMType])
-> (PPMType -> PPMType -> [PPMType])
-> (PPMType -> PPMType -> [PPMType])
-> (PPMType -> PPMType -> PPMType -> [PPMType])
-> Enum PPMType
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: PPMType -> PPMType -> PPMType -> [PPMType]
$cenumFromThenTo :: PPMType -> PPMType -> PPMType -> [PPMType]
enumFromTo :: PPMType -> PPMType -> [PPMType]
$cenumFromTo :: PPMType -> PPMType -> [PPMType]
enumFromThen :: PPMType -> PPMType -> [PPMType]
$cenumFromThen :: PPMType -> PPMType -> [PPMType]
enumFrom :: PPMType -> [PPMType]
$cenumFrom :: PPMType -> [PPMType]
fromEnum :: PPMType -> Int
$cfromEnum :: PPMType -> Int
toEnum :: Int -> PPMType
$ctoEnum :: Int -> PPMType
pred :: PPMType -> PPMType
$cpred :: PPMType -> PPMType
succ :: PPMType -> PPMType
$csucc :: PPMType -> PPMType
Enum, Eq PPMType
Eq PPMType
-> (PPMType -> PPMType -> Ordering)
-> (PPMType -> PPMType -> Bool)
-> (PPMType -> PPMType -> Bool)
-> (PPMType -> PPMType -> Bool)
-> (PPMType -> PPMType -> Bool)
-> (PPMType -> PPMType -> PPMType)
-> (PPMType -> PPMType -> PPMType)
-> Ord PPMType
PPMType -> PPMType -> Bool
PPMType -> PPMType -> Ordering
PPMType -> PPMType -> PPMType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PPMType -> PPMType -> PPMType
$cmin :: PPMType -> PPMType -> PPMType
max :: PPMType -> PPMType -> PPMType
$cmax :: PPMType -> PPMType -> PPMType
>= :: PPMType -> PPMType -> Bool
$c>= :: PPMType -> PPMType -> Bool
> :: PPMType -> PPMType -> Bool
$c> :: PPMType -> PPMType -> Bool
<= :: PPMType -> PPMType -> Bool
$c<= :: PPMType -> PPMType -> Bool
< :: PPMType -> PPMType -> Bool
$c< :: PPMType -> PPMType -> Bool
compare :: PPMType -> PPMType -> Ordering
$ccompare :: PPMType -> PPMType -> Ordering
$cp1Ord :: Eq PPMType
Ord)


-- | A PPM file with type, dimensions, and image data.
data PPM = PPM {
  PPM -> PPMHeader
ppmHeader :: PPMHeader
, PPM -> PpmPixelData
ppmData   :: PpmPixelData
}

-- | Meta information about the image: The exact PPM format and dimensions.
data PPMHeader = PPMHeader {
  PPMHeader -> PPMType
ppmType   :: !PPMType
, PPMHeader -> Int
ppmWidth  :: !Int
, PPMHeader -> Int
ppmHeight :: !Int
} deriving (PPMHeader -> PPMHeader -> Bool
(PPMHeader -> PPMHeader -> Bool)
-> (PPMHeader -> PPMHeader -> Bool) -> Eq PPMHeader
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PPMHeader -> PPMHeader -> Bool
$c/= :: PPMHeader -> PPMHeader -> Bool
== :: PPMHeader -> PPMHeader -> Bool
$c== :: PPMHeader -> PPMHeader -> Bool
Eq, Int -> PPMHeader -> ShowS
[PPMHeader] -> ShowS
PPMHeader -> String
(Int -> PPMHeader -> ShowS)
-> (PPMHeader -> String)
-> ([PPMHeader] -> ShowS)
-> Show PPMHeader
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PPMHeader] -> ShowS
$cshowList :: [PPMHeader] -> ShowS
show :: PPMHeader -> String
$cshow :: PPMHeader -> String
showsPrec :: Int -> PPMHeader -> ShowS
$cshowsPrec :: Int -> PPMHeader -> ShowS
Show)

instance Show PPM where
  show :: PPM -> String
show PPM { ppmHeader :: PPM -> PPMHeader
ppmHeader = PPMHeader { PPMType
ppmType :: PPMType
ppmType :: PPMHeader -> PPMType
ppmType, Int
ppmWidth :: Int
ppmWidth :: PPMHeader -> Int
ppmWidth, Int
ppmHeight :: Int
ppmHeight :: PPMHeader -> Int
ppmHeight } } = String
"PPM " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PPMType -> String
forall a. Show a => a -> String
show PPMType
ppmType String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" image " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
dim
    where
      dim :: String
dim = (Int, Int) -> String
forall a. Show a => a -> String
show (Int
ppmWidth, Int
ppmHeight)


-- | A pixel containing three 8-bit color components, RGB.
data PpmPixelRGB8 = PpmPixelRGB8 {-# UNPACK #-} !Word8 -- Red
                                 {-# UNPACK #-} !Word8 -- Green
                                 {-# UNPACK #-} !Word8 -- Blue
                                 deriving (PpmPixelRGB8 -> PpmPixelRGB8 -> Bool
(PpmPixelRGB8 -> PpmPixelRGB8 -> Bool)
-> (PpmPixelRGB8 -> PpmPixelRGB8 -> Bool) -> Eq PpmPixelRGB8
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PpmPixelRGB8 -> PpmPixelRGB8 -> Bool
$c/= :: PpmPixelRGB8 -> PpmPixelRGB8 -> Bool
== :: PpmPixelRGB8 -> PpmPixelRGB8 -> Bool
$c== :: PpmPixelRGB8 -> PpmPixelRGB8 -> Bool
Eq, Int -> PpmPixelRGB8 -> ShowS
[PpmPixelRGB8] -> ShowS
PpmPixelRGB8 -> String
(Int -> PpmPixelRGB8 -> ShowS)
-> (PpmPixelRGB8 -> String)
-> ([PpmPixelRGB8] -> ShowS)
-> Show PpmPixelRGB8
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PpmPixelRGB8] -> ShowS
$cshowList :: [PpmPixelRGB8] -> ShowS
show :: PpmPixelRGB8 -> String
$cshow :: PpmPixelRGB8 -> String
showsPrec :: Int -> PpmPixelRGB8 -> ShowS
$cshowsPrec :: Int -> PpmPixelRGB8 -> ShowS
Show)

-- | A pixel containing three 16-bit color components, RGB.
data PpmPixelRGB16 = PpmPixelRGB16 {-# UNPACK #-} !Word16 -- Red
                                   {-# UNPACK #-} !Word16 -- Green
                                   {-# UNPACK #-} !Word16 -- Blue
                                   deriving (PpmPixelRGB16 -> PpmPixelRGB16 -> Bool
(PpmPixelRGB16 -> PpmPixelRGB16 -> Bool)
-> (PpmPixelRGB16 -> PpmPixelRGB16 -> Bool) -> Eq PpmPixelRGB16
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PpmPixelRGB16 -> PpmPixelRGB16 -> Bool
$c/= :: PpmPixelRGB16 -> PpmPixelRGB16 -> Bool
== :: PpmPixelRGB16 -> PpmPixelRGB16 -> Bool
$c== :: PpmPixelRGB16 -> PpmPixelRGB16 -> Bool
Eq, Int -> PpmPixelRGB16 -> ShowS
[PpmPixelRGB16] -> ShowS
PpmPixelRGB16 -> String
(Int -> PpmPixelRGB16 -> ShowS)
-> (PpmPixelRGB16 -> String)
-> ([PpmPixelRGB16] -> ShowS)
-> Show PpmPixelRGB16
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PpmPixelRGB16] -> ShowS
$cshowList :: [PpmPixelRGB16] -> ShowS
show :: PpmPixelRGB16 -> String
$cshow :: PpmPixelRGB16 -> String
showsPrec :: Int -> PpmPixelRGB16 -> ShowS
$cshowsPrec :: Int -> PpmPixelRGB16 -> ShowS
Show)

-- | A pixel containing black or white.
newtype PbmPixel = PbmPixel Bool -- False = black, True = white
                 deriving (PbmPixel -> PbmPixel -> Bool
(PbmPixel -> PbmPixel -> Bool)
-> (PbmPixel -> PbmPixel -> Bool) -> Eq PbmPixel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PbmPixel -> PbmPixel -> Bool
$c/= :: PbmPixel -> PbmPixel -> Bool
== :: PbmPixel -> PbmPixel -> Bool
$c== :: PbmPixel -> PbmPixel -> Bool
Eq, Int -> PbmPixel -> ShowS
[PbmPixel] -> ShowS
PbmPixel -> String
(Int -> PbmPixel -> ShowS)
-> (PbmPixel -> String) -> ([PbmPixel] -> ShowS) -> Show PbmPixel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PbmPixel] -> ShowS
$cshowList :: [PbmPixel] -> ShowS
show :: PbmPixel -> String
$cshow :: PbmPixel -> String
showsPrec :: Int -> PbmPixel -> ShowS
$cshowsPrec :: Int -> PbmPixel -> ShowS
Show)

-- | A pixel containing an 8-bit greyscale value.
data PgmPixel8 = PgmPixel8 {-# UNPACK #-} !Word8
                           deriving (PgmPixel8 -> PgmPixel8 -> Bool
(PgmPixel8 -> PgmPixel8 -> Bool)
-> (PgmPixel8 -> PgmPixel8 -> Bool) -> Eq PgmPixel8
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PgmPixel8 -> PgmPixel8 -> Bool
$c/= :: PgmPixel8 -> PgmPixel8 -> Bool
== :: PgmPixel8 -> PgmPixel8 -> Bool
$c== :: PgmPixel8 -> PgmPixel8 -> Bool
Eq, Int -> PgmPixel8 -> ShowS
[PgmPixel8] -> ShowS
PgmPixel8 -> String
(Int -> PgmPixel8 -> ShowS)
-> (PgmPixel8 -> String)
-> ([PgmPixel8] -> ShowS)
-> Show PgmPixel8
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PgmPixel8] -> ShowS
$cshowList :: [PgmPixel8] -> ShowS
show :: PgmPixel8 -> String
$cshow :: PgmPixel8 -> String
showsPrec :: Int -> PgmPixel8 -> ShowS
$cshowsPrec :: Int -> PgmPixel8 -> ShowS
Show)

-- | A pixel containing a 16-bit greyscale value.
data PgmPixel16 = PgmPixel16 {-# UNPACK #-} !Word16
                             deriving (PgmPixel16 -> PgmPixel16 -> Bool
(PgmPixel16 -> PgmPixel16 -> Bool)
-> (PgmPixel16 -> PgmPixel16 -> Bool) -> Eq PgmPixel16
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PgmPixel16 -> PgmPixel16 -> Bool
$c/= :: PgmPixel16 -> PgmPixel16 -> Bool
== :: PgmPixel16 -> PgmPixel16 -> Bool
$c== :: PgmPixel16 -> PgmPixel16 -> Bool
Eq, Int -> PgmPixel16 -> ShowS
[PgmPixel16] -> ShowS
PgmPixel16 -> String
(Int -> PgmPixel16 -> ShowS)
-> (PgmPixel16 -> String)
-> ([PgmPixel16] -> ShowS)
-> Show PgmPixel16
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PgmPixel16] -> ShowS
$cshowList :: [PgmPixel16] -> ShowS
show :: PgmPixel16 -> String
$cshow :: PgmPixel16 -> String
showsPrec :: Int -> PgmPixel16 -> ShowS
$cshowsPrec :: Int -> PgmPixel16 -> ShowS
Show)

-- | Image data, either 8 or 16 bits.
-- TODO rename to PNM
data PpmPixelData = PpmPixelDataRGB8 (S.Vector PpmPixelRGB8)   -- ^ For 8-bit PPMs.
                  | PpmPixelDataRGB16 (S.Vector PpmPixelRGB16) -- ^ For 16-bit PPMs.
                  | PbmPixelData (S.Vector PbmPixel)           -- ^ For 1-bit PBMs.
                  | PgmPixelData8 (S.Vector PgmPixel8)         -- ^ For 8-bit PGMs.
                  | PgmPixelData16 (S.Vector PgmPixel16)       -- ^ For 16-bit PGMs.


-- | Converts a vector of pixels to a list for convenience.
pixelVectorToList :: (Storable a) => S.Vector a -> [a]
pixelVectorToList :: Vector a -> [a]
pixelVectorToList = Vector a -> [a]
forall a. Storable a => Vector a -> [a]
S.toList


-- | Converts pixel data to a list of positive `Int`s.
--
-- How big they can become depends on the bit depth of the pixel data.
pixelDataToIntList :: PpmPixelData -> [Int]
pixelDataToIntList :: PpmPixelData -> [Int]
pixelDataToIntList PpmPixelData
d = case PpmPixelData
d of
  PpmPixelDataRGB8 Vector PpmPixelRGB8
v  -> [[Int]] -> [Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ (Word8 -> Int) -> [Word8] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Word8
r, Word8
g, Word8
b] | PpmPixelRGB8 Word8
r Word8
g Word8
b  <- Vector PpmPixelRGB8 -> [PpmPixelRGB8]
forall a. Storable a => Vector a -> [a]
S.toList Vector PpmPixelRGB8
v ]
  PpmPixelDataRGB16 Vector PpmPixelRGB16
v -> [[Int]] -> [Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ (Word16 -> Int) -> [Word16] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Word16
r, Word16
g, Word16
b] | PpmPixelRGB16 Word16
r Word16
g Word16
b <- Vector PpmPixelRGB16 -> [PpmPixelRGB16]
forall a. Storable a => Vector a -> [a]
S.toList Vector PpmPixelRGB16
v ]
  PbmPixelData Vector PbmPixel
v      ->        [ if Bool
b then Int
1 else Int
0         | PbmPixel Bool
b          <- Vector PbmPixel -> [PbmPixel]
forall a. Storable a => Vector a -> [a]
S.toList Vector PbmPixel
v ]
  PgmPixelData8 Vector PgmPixel8
v     ->        [ Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x             | PgmPixel8 Word8
x         <- Vector PgmPixel8 -> [PgmPixel8]
forall a. Storable a => Vector a -> [a]
S.toList Vector PgmPixel8
v ]
  PgmPixelData16 Vector PgmPixel16
v    ->        [ Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
x             | PgmPixel16 Word16
x        <- Vector PgmPixel16 -> [PgmPixel16]
forall a. Storable a => Vector a -> [a]
S.toList Vector PgmPixel16
v ]


-- * Storable instance for pixels

storePpmPixel8 :: Store.Dictionary PpmPixelRGB8
storePpmPixel8 :: Dictionary PpmPixelRGB8
storePpmPixel8 =
  Access PpmPixelRGB8 PpmPixelRGB8 -> Dictionary PpmPixelRGB8
forall r. Access r r -> Dictionary r
Store.run (Access PpmPixelRGB8 PpmPixelRGB8 -> Dictionary PpmPixelRGB8)
-> Access PpmPixelRGB8 PpmPixelRGB8 -> Dictionary PpmPixelRGB8
forall a b. (a -> b) -> a -> b
$ (Word8 -> Word8 -> Word8 -> PpmPixelRGB8)
-> Access PpmPixelRGB8 Word8
-> Access PpmPixelRGB8 Word8
-> Access PpmPixelRGB8 Word8
-> Access PpmPixelRGB8 PpmPixelRGB8
forall (f :: * -> *) a b c d.
Applicative f =>
(a -> b -> c -> d) -> f a -> f b -> f c -> f d
liftA3 Word8 -> Word8 -> Word8 -> PpmPixelRGB8
PpmPixelRGB8
    ((PpmPixelRGB8 -> Word8) -> Access PpmPixelRGB8 Word8
forall a r. Storable a => (r -> a) -> Access r a
Store.element (\(PpmPixelRGB8 Word8
x Word8
_ Word8
_) -> Word8
x))
    ((PpmPixelRGB8 -> Word8) -> Access PpmPixelRGB8 Word8
forall a r. Storable a => (r -> a) -> Access r a
Store.element (\(PpmPixelRGB8 Word8
_ Word8
y Word8
_) -> Word8
y))
    ((PpmPixelRGB8 -> Word8) -> Access PpmPixelRGB8 Word8
forall a r. Storable a => (r -> a) -> Access r a
Store.element (\(PpmPixelRGB8 Word8
_ Word8
_ Word8
z) -> Word8
z))

storePpmPixel16 :: Store.Dictionary PpmPixelRGB16
storePpmPixel16 :: Dictionary PpmPixelRGB16
storePpmPixel16 =
  Access PpmPixelRGB16 PpmPixelRGB16 -> Dictionary PpmPixelRGB16
forall r. Access r r -> Dictionary r
Store.run (Access PpmPixelRGB16 PpmPixelRGB16 -> Dictionary PpmPixelRGB16)
-> Access PpmPixelRGB16 PpmPixelRGB16 -> Dictionary PpmPixelRGB16
forall a b. (a -> b) -> a -> b
$ (Word16 -> Word16 -> Word16 -> PpmPixelRGB16)
-> Access PpmPixelRGB16 Word16
-> Access PpmPixelRGB16 Word16
-> Access PpmPixelRGB16 Word16
-> Access PpmPixelRGB16 PpmPixelRGB16
forall (f :: * -> *) a b c d.
Applicative f =>
(a -> b -> c -> d) -> f a -> f b -> f c -> f d
liftA3 Word16 -> Word16 -> Word16 -> PpmPixelRGB16
PpmPixelRGB16
    ((PpmPixelRGB16 -> Word16) -> Access PpmPixelRGB16 Word16
forall a r. Storable a => (r -> a) -> Access r a
Store.element (\(PpmPixelRGB16 Word16
x Word16
_ Word16
_) -> Word16
x))
    ((PpmPixelRGB16 -> Word16) -> Access PpmPixelRGB16 Word16
forall a r. Storable a => (r -> a) -> Access r a
Store.element (\(PpmPixelRGB16 Word16
_ Word16
y Word16
_) -> Word16
y))
    ((PpmPixelRGB16 -> Word16) -> Access PpmPixelRGB16 Word16
forall a r. Storable a => (r -> a) -> Access r a
Store.element (\(PpmPixelRGB16 Word16
_ Word16
_ Word16
z) -> Word16
z))

storePbmPixel :: Store.Dictionary PbmPixel
storePbmPixel :: Dictionary PbmPixel
storePbmPixel =
  Access PbmPixel PbmPixel -> Dictionary PbmPixel
forall r. Access r r -> Dictionary r
Store.run (Access PbmPixel PbmPixel -> Dictionary PbmPixel)
-> Access PbmPixel PbmPixel -> Dictionary PbmPixel
forall a b. (a -> b) -> a -> b
$ (Bool -> PbmPixel)
-> Access PbmPixel Bool -> Access PbmPixel PbmPixel
forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA Bool -> PbmPixel
PbmPixel
    ((PbmPixel -> Bool) -> Access PbmPixel Bool
forall a r. Storable a => (r -> a) -> Access r a
Store.element (\(PbmPixel Bool
x) -> Bool
x))

storePgmPixel8 :: Store.Dictionary PgmPixel8
storePgmPixel8 :: Dictionary PgmPixel8
storePgmPixel8 =
  Access PgmPixel8 PgmPixel8 -> Dictionary PgmPixel8
forall r. Access r r -> Dictionary r
Store.run (Access PgmPixel8 PgmPixel8 -> Dictionary PgmPixel8)
-> Access PgmPixel8 PgmPixel8 -> Dictionary PgmPixel8
forall a b. (a -> b) -> a -> b
$ (Word8 -> PgmPixel8)
-> Access PgmPixel8 Word8 -> Access PgmPixel8 PgmPixel8
forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA Word8 -> PgmPixel8
PgmPixel8
    ((PgmPixel8 -> Word8) -> Access PgmPixel8 Word8
forall a r. Storable a => (r -> a) -> Access r a
Store.element (\(PgmPixel8 Word8
x) -> Word8
x))

storePgmPixel16 :: Store.Dictionary PgmPixel16
storePgmPixel16 :: Dictionary PgmPixel16
storePgmPixel16 =
  Access PgmPixel16 PgmPixel16 -> Dictionary PgmPixel16
forall r. Access r r -> Dictionary r
Store.run (Access PgmPixel16 PgmPixel16 -> Dictionary PgmPixel16)
-> Access PgmPixel16 PgmPixel16 -> Dictionary PgmPixel16
forall a b. (a -> b) -> a -> b
$ (Word16 -> PgmPixel16)
-> Access PgmPixel16 Word16 -> Access PgmPixel16 PgmPixel16
forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA Word16 -> PgmPixel16
PgmPixel16
    ((PgmPixel16 -> Word16) -> Access PgmPixel16 Word16
forall a r. Storable a => (r -> a) -> Access r a
Store.element (\(PgmPixel16 Word16
x) -> Word16
x))

instance Storable PpmPixelRGB8 where
  sizeOf :: PpmPixelRGB8 -> Int
sizeOf = Dictionary PpmPixelRGB8 -> PpmPixelRGB8 -> Int
forall r. Dictionary r -> r -> Int
Store.sizeOf Dictionary PpmPixelRGB8
storePpmPixel8
  alignment :: PpmPixelRGB8 -> Int
alignment = Dictionary PpmPixelRGB8 -> PpmPixelRGB8 -> Int
forall r. Dictionary r -> r -> Int
Store.alignment Dictionary PpmPixelRGB8
storePpmPixel8
  peek :: Ptr PpmPixelRGB8 -> IO PpmPixelRGB8
peek = Dictionary PpmPixelRGB8 -> Ptr PpmPixelRGB8 -> IO PpmPixelRGB8
forall r. Dictionary r -> Ptr r -> IO r
Store.peek Dictionary PpmPixelRGB8
storePpmPixel8
  poke :: Ptr PpmPixelRGB8 -> PpmPixelRGB8 -> IO ()
poke = Dictionary PpmPixelRGB8
-> Ptr PpmPixelRGB8 -> PpmPixelRGB8 -> IO ()
forall r. Dictionary r -> Ptr r -> r -> IO ()
Store.poke Dictionary PpmPixelRGB8
storePpmPixel8

instance Storable PpmPixelRGB16 where
  sizeOf :: PpmPixelRGB16 -> Int
sizeOf = Dictionary PpmPixelRGB16 -> PpmPixelRGB16 -> Int
forall r. Dictionary r -> r -> Int
Store.sizeOf Dictionary PpmPixelRGB16
storePpmPixel16
  alignment :: PpmPixelRGB16 -> Int
alignment = Dictionary PpmPixelRGB16 -> PpmPixelRGB16 -> Int
forall r. Dictionary r -> r -> Int
Store.alignment Dictionary PpmPixelRGB16
storePpmPixel16
  peek :: Ptr PpmPixelRGB16 -> IO PpmPixelRGB16
peek = Dictionary PpmPixelRGB16 -> Ptr PpmPixelRGB16 -> IO PpmPixelRGB16
forall r. Dictionary r -> Ptr r -> IO r
Store.peek Dictionary PpmPixelRGB16
storePpmPixel16
  poke :: Ptr PpmPixelRGB16 -> PpmPixelRGB16 -> IO ()
poke = Dictionary PpmPixelRGB16
-> Ptr PpmPixelRGB16 -> PpmPixelRGB16 -> IO ()
forall r. Dictionary r -> Ptr r -> r -> IO ()
Store.poke Dictionary PpmPixelRGB16
storePpmPixel16

instance Storable PbmPixel where
  sizeOf :: PbmPixel -> Int
sizeOf = Dictionary PbmPixel -> PbmPixel -> Int
forall r. Dictionary r -> r -> Int
Store.sizeOf Dictionary PbmPixel
storePbmPixel
  alignment :: PbmPixel -> Int
alignment = Dictionary PbmPixel -> PbmPixel -> Int
forall r. Dictionary r -> r -> Int
Store.alignment Dictionary PbmPixel
storePbmPixel
  peek :: Ptr PbmPixel -> IO PbmPixel
peek = Dictionary PbmPixel -> Ptr PbmPixel -> IO PbmPixel
forall r. Dictionary r -> Ptr r -> IO r
Store.peek Dictionary PbmPixel
storePbmPixel
  poke :: Ptr PbmPixel -> PbmPixel -> IO ()
poke = Dictionary PbmPixel -> Ptr PbmPixel -> PbmPixel -> IO ()
forall r. Dictionary r -> Ptr r -> r -> IO ()
Store.poke Dictionary PbmPixel
storePbmPixel

instance Storable PgmPixel8 where
  sizeOf :: PgmPixel8 -> Int
sizeOf = Dictionary PgmPixel8 -> PgmPixel8 -> Int
forall r. Dictionary r -> r -> Int
Store.sizeOf Dictionary PgmPixel8
storePgmPixel8
  alignment :: PgmPixel8 -> Int
alignment = Dictionary PgmPixel8 -> PgmPixel8 -> Int
forall r. Dictionary r -> r -> Int
Store.alignment Dictionary PgmPixel8
storePgmPixel8
  peek :: Ptr PgmPixel8 -> IO PgmPixel8
peek = Dictionary PgmPixel8 -> Ptr PgmPixel8 -> IO PgmPixel8
forall r. Dictionary r -> Ptr r -> IO r
Store.peek Dictionary PgmPixel8
storePgmPixel8
  poke :: Ptr PgmPixel8 -> PgmPixel8 -> IO ()
poke = Dictionary PgmPixel8 -> Ptr PgmPixel8 -> PgmPixel8 -> IO ()
forall r. Dictionary r -> Ptr r -> r -> IO ()
Store.poke Dictionary PgmPixel8
storePgmPixel8

instance Storable PgmPixel16 where
  sizeOf :: PgmPixel16 -> Int
sizeOf = Dictionary PgmPixel16 -> PgmPixel16 -> Int
forall r. Dictionary r -> r -> Int
Store.sizeOf Dictionary PgmPixel16
storePgmPixel16
  alignment :: PgmPixel16 -> Int
alignment = Dictionary PgmPixel16 -> PgmPixel16 -> Int
forall r. Dictionary r -> r -> Int
Store.alignment Dictionary PgmPixel16
storePgmPixel16
  peek :: Ptr PgmPixel16 -> IO PgmPixel16
peek = Dictionary PgmPixel16 -> Ptr PgmPixel16 -> IO PgmPixel16
forall r. Dictionary r -> Ptr r -> IO r
Store.peek Dictionary PgmPixel16
storePgmPixel16
  poke :: Ptr PgmPixel16 -> PgmPixel16 -> IO ()
poke = Dictionary PgmPixel16 -> Ptr PgmPixel16 -> PgmPixel16 -> IO ()
forall r. Dictionary r -> Ptr r -> r -> IO ()
Store.poke Dictionary PgmPixel16
storePgmPixel16


-- | Parses a netpbm magic number.
-- One of P1, P2, P3, P4, P5, P6.
magicNumberParser :: Parser PPMType
magicNumberParser :: Parser PPMType
magicNumberParser = do
  ByteString
magic <- [Parser ByteString ByteString] -> Parser ByteString ByteString
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice [Parser ByteString ByteString
"P1", Parser ByteString ByteString
"P2", Parser ByteString ByteString
"P3", Parser ByteString ByteString
"P4", Parser ByteString ByteString
"P5", Parser ByteString ByteString
"P6"]
  case ByteString
magic of
    ByteString
"P1" -> PPMType -> Parser PPMType
forall (m :: * -> *) a. Monad m => a -> m a
return PPMType
P1
    ByteString
"P2" -> PPMType -> Parser PPMType
forall (m :: * -> *) a. Monad m => a -> m a
return PPMType
P2
    ByteString
"P3" -> PPMType -> Parser PPMType
forall (m :: * -> *) a. Monad m => a -> m a
return PPMType
P3
    ByteString
"P4" -> PPMType -> Parser PPMType
forall (m :: * -> *) a. Monad m => a -> m a
return PPMType
P4
    ByteString
"P5" -> PPMType -> Parser PPMType
forall (m :: * -> *) a. Monad m => a -> m a
return PPMType
P5
    ByteString
"P6" -> PPMType -> Parser PPMType
forall (m :: * -> *) a. Monad m => a -> m a
return PPMType
P6
    ByteString
_    -> String -> Parser PPMType
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser PPMType) -> String -> Parser PPMType
forall a b. (a -> b) -> a -> b
$ String
"PPM: uknown PPM format " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
magic



-- Not writing this as @comments = skipMany comment@ because that would allow this parser
-- to consume no input, which makes it loop forever when stuck into something like `many`.
{-# INLINE comment #-}
comment :: Parser ByteString
comment :: Parser ByteString ByteString
comment = Parser ByteString ByteString
"#" Parser ByteString ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Word8 -> Bool) -> Parser ByteString ByteString
A.takeWhile Word8 -> Bool
forall a. (Eq a, Num a) => a -> Bool
isNotNewline Parser ByteString ByteString
-> Parser ByteString () -> Parser ByteString ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
endOfLine
  where
    isNotNewline :: a -> Bool
isNotNewline a
w = a
w a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
10 Bool -> Bool -> Bool
&& a
w a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
13


{-# INLINE sep #-}
sep :: Parser ()
-- At least one space, optionally with more space or comments around
sep :: Parser ByteString ()
sep = do Parser ByteString ByteString -> Parser ByteString ()
forall (f :: * -> *) a. Alternative f => f a -> f ()
skipMany Parser ByteString ByteString
comment
         Parser ByteString ()
singleWhitespace
         Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *) a. Alternative f => f a -> f ()
skipMany (Parser ByteString ()
singleWhitespace Parser ByteString ()
-> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString -> Parser ByteString ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser ByteString ByteString
comment)


-- | Decimal, possibly with comments interleaved,
-- but starting and ending with a digit.
-- See the notes about comments.
{-# INLINE decimalC #-}
decimalC :: Parser Int
decimalC :: Parser Int
decimalC = (Int -> Char -> Int) -> Int -> String -> Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Int -> Char -> Int
shiftDecimalChar Int
0 (String -> Int) -> Parser ByteString String -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser Char
digit Parser Char -> Parser ByteString () -> Parser ByteString String
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Parser ByteString ByteString -> Parser ByteString ()
forall (f :: * -> *) a. Alternative f => f a -> f ()
skipMany Parser ByteString ByteString
comment)
  where
    shiftDecimalChar :: Int -> Char -> Int
shiftDecimalChar Int
a Char
d = Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
48 :: Int)


headerParser :: Parser PPMHeader
headerParser :: Parser PPMHeader
headerParser = do
  PPMType
ppmType <- Parser PPMType
magicNumberParser
  Parser ByteString ()
sep
  Int
width <- Parser Int
decimalC
  Parser ByteString ()
sep
  Int
height <- Parser Int
decimalC
  Parser ByteString ByteString -> Parser ByteString ()
forall (f :: * -> *) a. Alternative f => f a -> f ()
skipMany Parser ByteString ByteString
comment -- Don't allow whitespace here since after the next whitespace there must not be any more comments
  PPMHeader -> Parser PPMHeader
forall (m :: * -> *) a. Monad m => a -> m a
return (PPMHeader -> Parser PPMHeader) -> PPMHeader -> Parser PPMHeader
forall a b. (a -> b) -> a -> b
$ PPMType -> Int -> Int -> PPMHeader
PPMHeader PPMType
ppmType Int
width Int
height


{-# INLINE word8max #-}
-- Parsing words not bigger than given maxval
word8max :: Word8 -> Parser Word8
word8max :: Word8 -> Parser Word8
word8max Word8
m = (Word8 -> Bool) -> Parser Word8
A.satisfy (Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
m) Parser Word8 -> String -> Parser Word8
forall i a. Parser i a -> String -> Parser i a
<?> String
"pixel data must be smaller than maxval"

{-# INLINE word16max #-}
word16max :: Word16 -> Parser Word16
word16max :: Word16 -> Parser Word16
word16max Word16
m = do Word16
w16 <- Parser Word16
anyWord16be
                 Bool -> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Word16
w16 Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word16
m) (Parser ByteString () -> Parser ByteString ())
-> Parser ByteString () -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$ String -> Parser ByteString ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"pixel data must be smaller than maxval"
                 Word16 -> Parser Word16
forall (m :: * -> *) a. Monad m => a -> m a
return Word16
w16


{-# INLINE isValidMaxval #-}
isValidMaxval :: Int -> Bool
isValidMaxval :: Int -> Bool
isValidMaxval Int
v = Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
65536


{-# INLINE singleWhitespace #-}
singleWhitespace :: Parser ()
singleWhitespace :: Parser ByteString ()
singleWhitespace = Parser Word8 -> Parser ByteString ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Word8 -> Parser ByteString ())
-> Parser Word8 -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$ (Word8 -> Bool) -> Parser Word8
A.satisfy Word8 -> Bool
isSpace_w8


-- | Parses a SINGLE PPM file.
--
-- Specification: http://netpbm.sourceforge.net/doc/ppm.html
--
-- There can be multiple images in one file, each starting with
-- a "Pn" magic number.
--
-- Comments starting with '#' can only be
-- "before the whitespace character that delimits the raster"
-- (see http://netpbm.sourceforge.net/doc/pbm.html).
-- Nevertheless, I interpret that as "comments cannot be
-- inside the magic number".
--
-- See also the notes for `imagesParser`.
ppmBodyParser :: PPMHeader -> Parser PPM
ppmBodyParser :: PPMHeader -> Parser PPM
ppmBodyParser header :: PPMHeader
header@PPMHeader { ppmWidth :: PPMHeader -> Int
ppmWidth = Int
width, ppmHeight :: PPMHeader -> Int
ppmHeight = Int
height } = do

  Parser ByteString ()
sep

  Int
maxColorVal <- Parser Int
decimalC
  Bool -> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> Bool
isValidMaxval Int
maxColorVal) (Parser ByteString () -> Parser ByteString ())
-> Parser ByteString () -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$
    String -> Parser ByteString ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ByteString ()) -> String -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$ String
"PPM: invalid color maxval " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
maxColorVal
  Parser ByteString ByteString -> Parser ByteString ()
forall (f :: * -> *) a. Alternative f => f a -> f ()
skipMany Parser ByteString ByteString
comment

  Parser ByteString ()
singleWhitespace -- obligatory SINGLE whitespace; starting from here, comments are not allowed any more

  PpmPixelData
raster <- case Int
maxColorVal of -- 1 or 2 bytes per pixel
    -- Parse pixel data into vector, making sure that words don't exceed maxColorVal
    Int
m | Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
256   -> let v :: Parser Word8
v = Word8 -> Parser Word8
word8max (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
m)
                      in Vector PpmPixelRGB8 -> PpmPixelData
PpmPixelDataRGB8  (Vector PpmPixelRGB8 -> PpmPixelData)
-> Parser ByteString (Vector PpmPixelRGB8)
-> Parser ByteString PpmPixelData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> Parser ByteString PpmPixelRGB8
-> Parser ByteString (Vector PpmPixelRGB8)
forall (m :: * -> *) a.
(Monad m, Storable a) =>
Int -> m a -> m (Vector a)
S.replicateM (Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
width) (Word8 -> Word8 -> Word8 -> PpmPixelRGB8
PpmPixelRGB8  (Word8 -> Word8 -> Word8 -> PpmPixelRGB8)
-> Parser Word8
-> Parser ByteString (Word8 -> Word8 -> PpmPixelRGB8)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Word8
v Parser ByteString (Word8 -> Word8 -> PpmPixelRGB8)
-> Parser Word8 -> Parser ByteString (Word8 -> PpmPixelRGB8)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Word8
v Parser ByteString (Word8 -> PpmPixelRGB8)
-> Parser Word8 -> Parser ByteString PpmPixelRGB8
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Word8
v)
    Int
m | Bool
otherwise -> let v :: Parser Word16
v = Word16 -> Parser Word16
word16max (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
m)
                      in Vector PpmPixelRGB16 -> PpmPixelData
PpmPixelDataRGB16 (Vector PpmPixelRGB16 -> PpmPixelData)
-> Parser ByteString (Vector PpmPixelRGB16)
-> Parser ByteString PpmPixelData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> Parser ByteString PpmPixelRGB16
-> Parser ByteString (Vector PpmPixelRGB16)
forall (m :: * -> *) a.
(Monad m, Storable a) =>
Int -> m a -> m (Vector a)
S.replicateM (Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
width) (Word16 -> Word16 -> Word16 -> PpmPixelRGB16
PpmPixelRGB16 (Word16 -> Word16 -> Word16 -> PpmPixelRGB16)
-> Parser Word16
-> Parser ByteString (Word16 -> Word16 -> PpmPixelRGB16)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Word16
v Parser ByteString (Word16 -> Word16 -> PpmPixelRGB16)
-> Parser Word16 -> Parser ByteString (Word16 -> PpmPixelRGB16)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Word16
v Parser ByteString (Word16 -> PpmPixelRGB16)
-> Parser Word16 -> Parser ByteString PpmPixelRGB16
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Word16
v)

  PPM -> Parser PPM
forall (m :: * -> *) a. Monad m => a -> m a
return (PPM -> Parser PPM) -> PPM -> Parser PPM
forall a b. (a -> b) -> a -> b
$ PPMHeader -> PpmPixelData -> PPM
PPM PPMHeader
header PpmPixelData
raster


pgmBodyParser :: PPMHeader -> Parser PPM
pgmBodyParser :: PPMHeader -> Parser PPM
pgmBodyParser header :: PPMHeader
header@PPMHeader { ppmWidth :: PPMHeader -> Int
ppmWidth = Int
width, ppmHeight :: PPMHeader -> Int
ppmHeight = Int
height } = do

  Parser ByteString ()
sep

  Int
maxGreyVal <- Parser Int
decimalC
  Bool -> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> Bool
isValidMaxval Int
maxGreyVal) (Parser ByteString () -> Parser ByteString ())
-> Parser ByteString () -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$
    String -> Parser ByteString ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ByteString ()) -> String -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$ String
"PGM: invalid grey maxval " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
maxGreyVal
  Parser ByteString ByteString -> Parser ByteString ()
forall (f :: * -> *) a. Alternative f => f a -> f ()
skipMany Parser ByteString ByteString
comment

  Parser ByteString ()
singleWhitespace -- obligatory SINGLE whitespace; starting from here, comments are not allowed any more

  PpmPixelData
raster <- case Int
maxGreyVal of -- 1 or 2 bytes per pixel
    -- Parse pixel data into vector, making sure that words don't exceed maxGreyVal
    Int
m | Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
256   -> let v :: Parser Word8
v = Word8 -> Parser Word8
word8max (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
m)
                      in Vector PgmPixel8 -> PpmPixelData
PgmPixelData8  (Vector PgmPixel8 -> PpmPixelData)
-> Parser ByteString (Vector PgmPixel8)
-> Parser ByteString PpmPixelData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> Parser ByteString PgmPixel8
-> Parser ByteString (Vector PgmPixel8)
forall (m :: * -> *) a.
(Monad m, Storable a) =>
Int -> m a -> m (Vector a)
S.replicateM (Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
width) (Word8 -> PgmPixel8
PgmPixel8  (Word8 -> PgmPixel8) -> Parser Word8 -> Parser ByteString PgmPixel8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Word8
v)
    Int
m | Bool
otherwise -> let v :: Parser Word16
v = Word16 -> Parser Word16
word16max (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
m)
                      in Vector PgmPixel16 -> PpmPixelData
PgmPixelData16 (Vector PgmPixel16 -> PpmPixelData)
-> Parser ByteString (Vector PgmPixel16)
-> Parser ByteString PpmPixelData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> Parser ByteString PgmPixel16
-> Parser ByteString (Vector PgmPixel16)
forall (m :: * -> *) a.
(Monad m, Storable a) =>
Int -> m a -> m (Vector a)
S.replicateM (Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
width) (Word16 -> PgmPixel16
PgmPixel16 (Word16 -> PgmPixel16)
-> Parser Word16 -> Parser ByteString PgmPixel16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Word16
v)

  PPM -> Parser PPM
forall (m :: * -> *) a. Monad m => a -> m a
return (PPM -> Parser PPM) -> PPM -> Parser PPM
forall a b. (a -> b) -> a -> b
$ PPMHeader -> PpmPixelData -> PPM
PPM PPMHeader
header PpmPixelData
raster


pbmBodyParser :: PPMHeader -> Parser PPM
pbmBodyParser :: PPMHeader -> Parser PPM
pbmBodyParser header :: PPMHeader
header@PPMHeader { ppmWidth :: PPMHeader -> Int
ppmWidth = Int
width, ppmHeight :: PPMHeader -> Int
ppmHeight = Int
height } = do

  Parser ByteString ()
singleWhitespace -- obligatory SINGLE whitespace; starting from here, comments are not allowed any more

  -- From: http://netpbm.sourceforge.net/doc/pbm.html
  --   "Each row is Width bits, packed 8 to a byte, with don't care bits to fill out the last byte in the row."
  let widthBytes :: Int
widthBytes = (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7) Int -> Int -> Int
// Int
8

  -- Parse pixel data first in into a Word8 vector, then translate to a Bool vector, leaving the don't-cares at the end out.
  Vector Word8
word8Vector <- Int -> Parser Word8 -> Parser ByteString (Vector Word8)
forall (m :: * -> *) a.
(Monad m, Storable a) =>
Int -> m a -> m (Vector a)
S.replicateM (Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
widthBytes) Parser Word8
anyWord8

  let bits :: Vector PbmPixel
bits = (forall s. ST s (MVector s PbmPixel)) -> Vector PbmPixel
forall a. Storable a => (forall s. ST s (MVector s a)) -> Vector a
S.create ((forall s. ST s (MVector s PbmPixel)) -> Vector PbmPixel)
-> (forall s. ST s (MVector s PbmPixel)) -> Vector PbmPixel
forall a b. (a -> b) -> a -> b
$ do
        MVector s PbmPixel
v <- Int -> PbmPixel -> ST s (MVector (PrimState (ST s)) PbmPixel)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> a -> m (MVector (PrimState m) a)
SM.replicate (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
height) (Bool -> PbmPixel
PbmPixel Bool
False)
        [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
heightInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
row ->
          [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
widthInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
col ->
            let i :: Int
i            = Int
row Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
col
                (Int
col8, Int
bitN) = Int
col Int -> Int -> (Int, Int)
/% Int
8
                i8 :: Int
i8           = Int
row Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
widthBytes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
col8
             -- We negate (see "not"), because:
             --   "1 is black, 0 is white."
             -- Also, `testBit` indexes from the right (LSB).
             in MVector (PrimState (ST s)) PbmPixel -> Int -> PbmPixel -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
SM.write MVector s PbmPixel
MVector (PrimState (ST s)) PbmPixel
v Int
i (Bool -> PbmPixel
PbmPixel (Bool -> PbmPixel) -> (Bool -> Bool) -> Bool -> PbmPixel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> PbmPixel) -> Bool -> PbmPixel
forall a b. (a -> b) -> a -> b
$ (Vector Word8
word8Vector Vector Word8 -> Int -> Word8
forall a. Storable a => Vector a -> Int -> a
! Int
i8) Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` (Int
7 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bitN))
        MVector s PbmPixel -> ST s (MVector s PbmPixel)
forall (m :: * -> *) a. Monad m => a -> m a
return MVector s PbmPixel
v

  PPM -> Parser PPM
forall (m :: * -> *) a. Monad m => a -> m a
return (PPM -> Parser PPM) -> PPM -> Parser PPM
forall a b. (a -> b) -> a -> b
$ PPMHeader -> PpmPixelData -> PPM
PPM PPMHeader
header (Vector PbmPixel -> PpmPixelData
PbmPixelData Vector PbmPixel
bits)
  where
    // :: Int -> Int -> Int
(//) = Int -> Int -> Int
forall a. Integral a => a -> a -> a
quot
    /% :: Int -> Int -> (Int, Int)
(/%) = Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
quotRem


-- | See http://netpbm.sourceforge.net/doc/pbm.html
--
-- We ignore the "No line should be longer than 70 characters" here due to "should".
pbmAsciiBodyParser :: PPMHeader -> Parser PPM
pbmAsciiBodyParser :: PPMHeader -> Parser PPM
pbmAsciiBodyParser header :: PPMHeader
header@PPMHeader { ppmWidth :: PPMHeader -> Int
ppmWidth = Int
width, ppmHeight :: PPMHeader -> Int
ppmHeight = Int
height } = do

  Parser ByteString ()
singleWhitespace -- obligatory SINGLE whitespace; starting from here, comments are not allowed any more

  -- Parse pixel data into Bool vector.
  let n :: Int
n = Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
width
  -- There must be whitespace *between* the values.
  -- There can be whitespace *before* the first value since:
  --   "White space in the raster section is ignored."
  -- Don't allow it *after* so that we can check if there is a whitespace between raster and optional junk.
  -- I use `generateM` here instead of fromList . (`sepBy` [whitespace]) because I believe it's faster.
  Vector PbmPixel
bits <- Int
-> Parser ByteString PbmPixel
-> Parser ByteString (Vector PbmPixel)
forall (m :: * -> *) a.
(Monad m, Storable a) =>
Int -> m a -> m (Vector a)
S.replicateM Int
n ((Word8 -> Bool) -> Parser ByteString ByteString
A.takeWhile Word8 -> Bool
isSpace_w8 Parser ByteString ByteString
-> Parser ByteString PbmPixel -> Parser ByteString PbmPixel
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString PbmPixel
asciiBit)

  -- From the spec (who the heck can even come up with this):
  --   "You can put any junk you want after the raster, if it starts with a white space character."
  -- Note that it says *can*, i.e. the junk can also be empty, so trailing whitespace is allowed.
  -- So let's eat all remaining input:
  () -> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option () ((Word8 -> Bool) -> Parser ByteString ByteString
A.takeWhile1 Word8 -> Bool
isSpace_w8 Parser ByteString ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ByteString
takeLazyByteString Parser ByteString ByteString
-> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> Parser ByteString ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

  -- Now we should be at the end of file.
  Parser ByteString ()
forall t. Chunk t => Parser t ()
endOfInput Parser ByteString () -> String -> Parser ByteString ()
forall i a. Parser i a -> String -> Parser i a
<?> String
"there is junk after the ASCII raster that is not separated by whitespace"

  PPM -> Parser PPM
forall (m :: * -> *) a. Monad m => a -> m a
return (PPM -> Parser PPM) -> PPM -> Parser PPM
forall a b. (a -> b) -> a -> b
$ PPMHeader -> PpmPixelData -> PPM
PPM PPMHeader
header (Vector PbmPixel -> PpmPixelData
PbmPixelData Vector PbmPixel
bits)
  where
    asciiBit :: Parser ByteString PbmPixel
asciiBit = Bool -> PbmPixel
PbmPixel (Bool -> PbmPixel)
-> Parser ByteString Bool -> Parser ByteString PbmPixel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser Word8
anyWord8 Parser Word8
-> (Word8 -> Parser ByteString Bool) -> Parser ByteString Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Parser ByteString Bool
forall a (m :: * -> *). (MonadFail m, Integral a) => a -> m Bool
toBool)
    -- We flip True/False because "1" means black == False.
    toBool :: a -> m Bool
toBool a
48 = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    toBool a
49 = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    toBool a
w  = String -> m Bool
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Bool) -> String -> m Bool
forall a b. (a -> b) -> a -> b
$ String
"ASCII bit must be '0' or '1', not " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show (Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
w)


pgmAsciiBodyParser :: PPMHeader -> Parser PPM
pgmAsciiBodyParser :: PPMHeader -> Parser PPM
pgmAsciiBodyParser header :: PPMHeader
header@PPMHeader { ppmWidth :: PPMHeader -> Int
ppmWidth = Int
width, ppmHeight :: PPMHeader -> Int
ppmHeight = Int
height } = do

  Parser ByteString ()
sep

  Int
maxGreyVal <- Parser Int
decimalC
  Bool -> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> Bool
isValidMaxval Int
maxGreyVal) (Parser ByteString () -> Parser ByteString ())
-> Parser ByteString () -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$
    String -> Parser ByteString ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ByteString ()) -> String -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$ String
"PGM: invalid grey maxval " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
maxGreyVal
  Parser ByteString ByteString -> Parser ByteString ()
forall (f :: * -> *) a. Alternative f => f a -> f ()
skipMany Parser ByteString ByteString
comment

  Parser ByteString ()
singleWhitespace -- obligatory SINGLE whitespace; starting from here, comments are not allowed any more

  let n :: Int
n = Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
width

  -- TODO size-check the int by first putting it in Word64 and limiting decimal length
  PpmPixelData
raster <- case Int
maxGreyVal of -- 1 or 2 bytes per pixel
    -- Parse pixel data into vector, making sure that words don't exceed maxGreyVal
    Int
m | Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
256 -> Vector PgmPixel8 -> PpmPixelData
PgmPixelData8  (Vector PgmPixel8 -> PpmPixelData)
-> Parser ByteString (Vector PgmPixel8)
-> Parser ByteString PpmPixelData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> Parser ByteString PgmPixel8
-> Parser ByteString (Vector PgmPixel8)
forall (m :: * -> *) a.
(Monad m, Storable a) =>
Int -> m a -> m (Vector a)
S.replicateM Int
n ((Word8 -> Bool) -> Parser ByteString ByteString
A.takeWhile Word8 -> Bool
isSpace_w8 Parser ByteString ByteString
-> Parser ByteString PgmPixel8 -> Parser ByteString PgmPixel8
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Word8 -> PgmPixel8
PgmPixel8  (Word8 -> PgmPixel8) -> Parser Word8 -> Parser ByteString PgmPixel8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Word8
forall a. Integral a => Parser a
decimal))
    Int
_           -> Vector PgmPixel16 -> PpmPixelData
PgmPixelData16 (Vector PgmPixel16 -> PpmPixelData)
-> Parser ByteString (Vector PgmPixel16)
-> Parser ByteString PpmPixelData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> Parser ByteString PgmPixel16
-> Parser ByteString (Vector PgmPixel16)
forall (m :: * -> *) a.
(Monad m, Storable a) =>
Int -> m a -> m (Vector a)
S.replicateM Int
n ((Word8 -> Bool) -> Parser ByteString ByteString
A.takeWhile Word8 -> Bool
isSpace_w8 Parser ByteString ByteString
-> Parser ByteString PgmPixel16 -> Parser ByteString PgmPixel16
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Word16 -> PgmPixel16
PgmPixel16 (Word16 -> PgmPixel16)
-> Parser Word16 -> Parser ByteString PgmPixel16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Word16
forall a. Integral a => Parser a
decimal))

  () -> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option () ((Word8 -> Bool) -> Parser ByteString ByteString
A.takeWhile1 Word8 -> Bool
isSpace_w8 Parser ByteString ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ByteString
takeLazyByteString Parser ByteString ByteString
-> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> Parser ByteString ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

  -- Now we should be at the end of file.
  Parser ByteString ()
forall t. Chunk t => Parser t ()
endOfInput Parser ByteString () -> String -> Parser ByteString ()
forall i a. Parser i a -> String -> Parser i a
<?> String
"there is junk after the ASCII raster that is not separated by whitespace"

  PPM -> Parser PPM
forall (m :: * -> *) a. Monad m => a -> m a
return (PPM -> Parser PPM) -> PPM -> Parser PPM
forall a b. (a -> b) -> a -> b
$ PPMHeader -> PpmPixelData -> PPM
PPM PPMHeader
header PpmPixelData
raster


ppmAsciiBodyParser :: PPMHeader -> Parser PPM
ppmAsciiBodyParser :: PPMHeader -> Parser PPM
ppmAsciiBodyParser header :: PPMHeader
header@PPMHeader { ppmWidth :: PPMHeader -> Int
ppmWidth = Int
width, ppmHeight :: PPMHeader -> Int
ppmHeight = Int
height } = do

  Parser ByteString ()
sep

  Int
maxColorVal <- Parser Int
decimalC
  Bool -> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> Bool
isValidMaxval Int
maxColorVal) (Parser ByteString () -> Parser ByteString ())
-> Parser ByteString () -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$
    String -> Parser ByteString ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ByteString ()) -> String -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$ String
"PGM: invalid color maxval " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
maxColorVal
  Parser ByteString ByteString -> Parser ByteString ()
forall (f :: * -> *) a. Alternative f => f a -> f ()
skipMany Parser ByteString ByteString
comment

  Parser ByteString ()
singleWhitespace -- obligatory SINGLE whitespace; starting from here, comments are not allowed any more

  let n :: Int
n = Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
width
      d8 :: Parser Word8
d8  = (Word8 -> Bool) -> Parser ByteString ByteString
A.takeWhile Word8 -> Bool
isSpace_w8 Parser ByteString ByteString -> Parser Word8 -> Parser Word8
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Word8
forall a. Integral a => Parser a
decimal :: Parser Word8
      d16 :: Parser Word16
d16 = (Word8 -> Bool) -> Parser ByteString ByteString
A.takeWhile Word8 -> Bool
isSpace_w8 Parser ByteString ByteString -> Parser Word16 -> Parser Word16
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Word16
forall a. Integral a => Parser a
decimal :: Parser Word16

  -- TODO size-check the int by first putting it in Word64 and limiting decimal length
  PpmPixelData
raster <- case Int
maxColorVal of -- 1 or 2 bytes per pixel
    -- Parse pixel data into vector, making sure that words don't exceed maxColorVal
    Int
m | Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
256 -> Vector PpmPixelRGB8 -> PpmPixelData
PpmPixelDataRGB8  (Vector PpmPixelRGB8 -> PpmPixelData)
-> Parser ByteString (Vector PpmPixelRGB8)
-> Parser ByteString PpmPixelData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> Parser ByteString PpmPixelRGB8
-> Parser ByteString (Vector PpmPixelRGB8)
forall (m :: * -> *) a.
(Monad m, Storable a) =>
Int -> m a -> m (Vector a)
S.replicateM Int
n (Word8 -> Word8 -> Word8 -> PpmPixelRGB8
PpmPixelRGB8  (Word8 -> Word8 -> Word8 -> PpmPixelRGB8)
-> Parser Word8
-> Parser ByteString (Word8 -> Word8 -> PpmPixelRGB8)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Word8
d8  Parser ByteString (Word8 -> Word8 -> PpmPixelRGB8)
-> Parser Word8 -> Parser ByteString (Word8 -> PpmPixelRGB8)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Word8
d8  Parser ByteString (Word8 -> PpmPixelRGB8)
-> Parser Word8 -> Parser ByteString PpmPixelRGB8
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Word8
d8 )
    Int
_           -> Vector PpmPixelRGB16 -> PpmPixelData
PpmPixelDataRGB16 (Vector PpmPixelRGB16 -> PpmPixelData)
-> Parser ByteString (Vector PpmPixelRGB16)
-> Parser ByteString PpmPixelData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> Parser ByteString PpmPixelRGB16
-> Parser ByteString (Vector PpmPixelRGB16)
forall (m :: * -> *) a.
(Monad m, Storable a) =>
Int -> m a -> m (Vector a)
S.replicateM Int
n (Word16 -> Word16 -> Word16 -> PpmPixelRGB16
PpmPixelRGB16 (Word16 -> Word16 -> Word16 -> PpmPixelRGB16)
-> Parser Word16
-> Parser ByteString (Word16 -> Word16 -> PpmPixelRGB16)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Word16
d16 Parser ByteString (Word16 -> Word16 -> PpmPixelRGB16)
-> Parser Word16 -> Parser ByteString (Word16 -> PpmPixelRGB16)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Word16
d16 Parser ByteString (Word16 -> PpmPixelRGB16)
-> Parser Word16 -> Parser ByteString PpmPixelRGB16
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Word16
d16)

  () -> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option () ((Word8 -> Bool) -> Parser ByteString ByteString
A.takeWhile1 Word8 -> Bool
isSpace_w8 Parser ByteString ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ByteString
takeLazyByteString Parser ByteString ByteString
-> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> Parser ByteString ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

  -- Now we should be at the end of file.
  Parser ByteString ()
forall t. Chunk t => Parser t ()
endOfInput Parser ByteString () -> String -> Parser ByteString ()
forall i a. Parser i a -> String -> Parser i a
<?> String
"there is junk after the ASCII raster that is not separated by whitespace"

  PPM -> Parser PPM
forall (m :: * -> *) a. Monad m => a -> m a
return (PPM -> Parser PPM) -> PPM -> Parser PPM
forall a b. (a -> b) -> a -> b
$ PPMHeader -> PpmPixelData -> PPM
PPM PPMHeader
header PpmPixelData
raster


imageParserOfType :: Maybe PPMType -> Parser PPM
imageParserOfType :: Maybe PPMType -> Parser PPM
imageParserOfType Maybe PPMType
mpN = do
  header :: PPMHeader
header@PPMHeader { PPMType
ppmType :: PPMType
ppmType :: PPMHeader -> PPMType
ppmType } <- Parser PPMHeader
headerParser

  case Maybe PPMType
mpN of
    Just PPMType
pN | PPMType
pN PPMType -> PPMType -> Bool
forall a. Eq a => a -> a -> Bool
/= PPMType
ppmType -> String -> Parser ByteString ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"an image in a multi-image file is not of the same type as the first image in the file"
    Maybe PPMType
_                       -> () -> Parser ByteString ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  case PPMType
ppmType of
    PPMType
P1 -> PPMHeader -> Parser PPM
pbmAsciiBodyParser PPMHeader
header
    PPMType
P2 -> PPMHeader -> Parser PPM
pgmAsciiBodyParser PPMHeader
header
    PPMType
P3 -> PPMHeader -> Parser PPM
ppmAsciiBodyParser PPMHeader
header
    PPMType
P4 -> PPMHeader -> Parser PPM
pbmBodyParser PPMHeader
header
    PPMType
P5 -> PPMHeader -> Parser PPM
pgmBodyParser PPMHeader
header
    PPMType
P6 -> PPMHeader -> Parser PPM
ppmBodyParser PPMHeader
header


imageParser :: Parser PPM
imageParser :: Parser PPM
imageParser = Maybe PPMType -> Parser PPM
imageParserOfType Maybe PPMType
forall a. Maybe a
Nothing


-- | Parses a full PPM file, containing one or more images.
--
-- From the spec:
--
-- >"A PPM file consists of a sequence of one or more PPM images.
-- > There are no data, delimiters, or padding before, after, or between images."
--
-- However, you can find PPM files that have trailing whitespace, especially a '\n',
-- so we allow this.
imagesParser :: Parser [PPM]
imagesParser :: Parser [PPM]
imagesParser = do
  -- Parse the first image.
  firstImage :: PPM
firstImage@PPM { ppmHeader :: PPM -> PPMHeader
ppmHeader = PPMHeader { PPMType
ppmType :: PPMType
ppmType :: PPMHeader -> PPMType
ppmType } } <- Parser PPM
imageParser Parser PPM -> Parser ByteString () -> Parser PPM
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
skipSpace

  -- Force the following images, if any, to be of the same type.
  [PPM]
otherImages <- Parser PPM -> Parser [PPM]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Maybe PPMType -> Parser PPM
imageParserOfType (PPMType -> Maybe PPMType
forall a. a -> Maybe a
Just PPMType
ppmType) Parser PPM -> Parser ByteString () -> Parser PPM
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
skipSpace)

  -- TODO Restructure so that this cannot happen. There is no point of returning [PPM] for ASCII images.
  Bool -> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PPMType
ppmType PPMType -> [PPMType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PPMType
P1, PPMType
P2, PPMType
P3] Bool -> Bool -> Bool
&& Bool -> Bool
not ([PPM] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PPM]
otherImages)) (Parser ByteString () -> Parser ByteString ())
-> Parser ByteString () -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$
    String -> Parser ByteString ()
forall a. HasCallStack => String -> a
error String
"haskell-netpbm bug: ASCII formats should never contain more than one image (they treat remaining data as junk)"

  [PPM] -> Parser [PPM]
forall (m :: * -> *) a. Monad m => a -> m a
return ([PPM] -> Parser [PPM]) -> [PPM] -> Parser [PPM]
forall a b. (a -> b) -> a -> b
$ PPM
firstImagePPM -> [PPM] -> [PPM]
forall a. a -> [a] -> [a]
:[PPM]
otherImages



-- | The result of a PPM parse.
--
-- See `parsePPM`.
type PpmParseResult = Either String ([PPM], Maybe ByteString)


-- | Parses a PPM file from the given 'ByteString'.
-- On failure, @Left error@ contains the error message.
-- On success, @Right (images, Maybe rest)@ contains the parsed images
-- and potentially an unparsable rest input.
parsePPM :: ByteString -> PpmParseResult
parsePPM :: ByteString -> PpmParseResult
parsePPM ByteString
bs = case Parser [PPM] -> ByteString -> Result [PPM]
forall a. Parser a -> ByteString -> Result a
parse Parser [PPM]
imagesParser ByteString
bs of
  -- 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 ByteString -> Result [PPM]
cont -> Result [PPM] -> PpmParseResult
forall a a.
(Eq a, IsString a) =>
IResult a a -> Either String (a, Maybe a)
resultToEither (ByteString -> Result [PPM]
cont ByteString
"")
  Result [PPM]
r            -> Result [PPM] -> PpmParseResult
forall a a.
(Eq a, IsString a) =>
IResult a a -> Either String (a, Maybe a)
resultToEither Result [PPM]
r
  where
    -- Assumes a Partial result has already been fed with "" (another Partial cannot happen)
    resultToEither :: IResult a a -> Either String (a, Maybe a)
resultToEither IResult a a
r = case IResult a a
r of
      Done a
""   a
images -> (a, Maybe a) -> Either String (a, Maybe a)
forall a b. b -> Either a b
Right (a
images, Maybe a
forall a. Maybe a
Nothing)
      Done a
rest a
images -> (a, Maybe a) -> Either String (a, Maybe a)
forall a b. b -> Either a b
Right (a
images, a -> Maybe a
forall a. a -> Maybe a
Just a
rest)
      Partial a -> IResult a a
_        -> String -> Either String (a, Maybe a)
forall a. HasCallStack => String -> a
error String
"parsePPM bug: Got a partial result after end of input"
      Fail a
_ [String]
cs String
e      -> String -> Either String (a, Maybe a)
forall a b. a -> Either a b
Left (String -> Either String (a, Maybe a))
-> String -> Either String (a, Maybe a)
forall a b. (a -> b) -> a -> b
$ String
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"; contexts: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
cs


-- * Unbox instance for pixels
--
-- Not used internally, but an Unbox instance might be convenient for users.

derivingUnbox "PpmPixelRGB8"
    [t| PpmPixelRGB8 -> (Word8, Word8, Word8) |]
    [| \ (PpmPixelRGB8 a b c) -> (a, b, c) |]
    [| \ (a, b, c) -> PpmPixelRGB8 a b c |]

derivingUnbox "PpmPixelRGB16"
    [t| PpmPixelRGB16 -> (Word16, Word16, Word16) |]
    [| \ (PpmPixelRGB16 a b c) -> (a, b, c) |]
    [| \ (a, b, c) -> PpmPixelRGB16 a b c |]

derivingUnbox "PbmPixel"
    [t| PbmPixel -> Bool |]
    [| \ (PbmPixel b) -> b |]
    [| \ b -> PbmPixel b |]

derivingUnbox "PgmPixel8"
    [t| PgmPixel8 -> Word8 |]
    [| \ (PgmPixel8 x) -> x |]
    [| \ x -> PgmPixel8 x |]

derivingUnbox "PgmPixel16"
    [t| PgmPixel16 -> Word16 |]
    [| \ (PgmPixel16 x) -> x |]
    [| \ x -> PgmPixel16 x |]