{-# LANGUAGE BangPatterns, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}

module Gamgine.Image.PNG.Internal.Parser where

import Text.Parsec.Prim
import Text.Parsec.Combinator

import Data.Word
import Data.Bits
import Numeric (showHex)

import qualified Gamgine.Image.PNG.Internal.LBS as LBS
import Gamgine.Image.PNG.Internal.LBS (LBS)
import qualified Data.ByteString.Lazy as LB

type Parser = Parsec LBS ()

word8 :: (Monad m) => Word8 -> ParsecT LBS u m Word8
word8 :: forall (m :: * -> *) u. Monad m => Word8 -> ParsecT LBS u m Word8
word8 = (Word8 -> Bool) -> ParsecT LBS u m Word8
forall (m :: * -> *) u.
Monad m =>
(Word8 -> Bool) -> ParsecT LBS u m Word8
satisfy ((Word8 -> Bool) -> ParsecT LBS u m Word8)
-> (Word8 -> Word8 -> Bool) -> Word8 -> ParsecT LBS u m Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
(==)

word16 :: (Monad m) => Word16 -> ParsecT LBS u m Word16
word16 :: forall (m :: * -> *) u. Monad m => Word16 -> ParsecT LBS u m Word16
word16 Word16
w = (Word8 -> ParsecT LBS u m Word8
forall (m :: * -> *) u. Monad m => Word8 -> ParsecT LBS u m Word8
word8 Word8
hi ParsecT LBS u m Word8
-> ParsecT LBS u m Word8 -> ParsecT LBS u m Word8
forall a b.
ParsecT LBS u m a -> ParsecT LBS u m b -> ParsecT LBS u m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> ParsecT LBS u m Word8
forall (m :: * -> *) u. Monad m => Word8 -> ParsecT LBS u m Word8
word8 Word8
lo ParsecT LBS u m Word8
-> ParsecT LBS u m Word16 -> ParsecT LBS u m Word16
forall a b.
ParsecT LBS u m a -> ParsecT LBS u m b -> ParsecT LBS u m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word16 -> ParsecT LBS u m Word16
forall a. a -> ParsecT LBS u m a
forall (m :: * -> *) a. Monad m => a -> m a
return Word16
w) ParsecT LBS u m Word16 -> String -> ParsecT LBS u m Word16
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"0x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word16 -> String -> String
forall a. Integral a => a -> String -> String
showHex Word16
w String
""
 where
   hi :: Word8
hi = Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
w Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftR` Int
8)
   lo :: Word8
lo = Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
w

word32 :: (Monad m) => Word32 -> ParsecT LBS u m Word32
word32 :: forall (m :: * -> *) u. Monad m => Word32 -> ParsecT LBS u m Word32
word32 Word32
w = (Word16 -> ParsecT LBS u m Word16
forall (m :: * -> *) u. Monad m => Word16 -> ParsecT LBS u m Word16
word16 Word16
hi ParsecT LBS u m Word16
-> ParsecT LBS u m Word16 -> ParsecT LBS u m Word16
forall a b.
ParsecT LBS u m a -> ParsecT LBS u m b -> ParsecT LBS u m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word16 -> ParsecT LBS u m Word16
forall (m :: * -> *) u. Monad m => Word16 -> ParsecT LBS u m Word16
word16 Word16
lo ParsecT LBS u m Word16
-> ParsecT LBS u m Word32 -> ParsecT LBS u m Word32
forall a b.
ParsecT LBS u m a -> ParsecT LBS u m b -> ParsecT LBS u m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word32 -> ParsecT LBS u m Word32
forall a. a -> ParsecT LBS u m a
forall (m :: * -> *) a. Monad m => a -> m a
return Word32
w) ParsecT LBS u m Word32 -> String -> ParsecT LBS u m Word32
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"0x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word32 -> String -> String
forall a. Integral a => a -> String -> String
showHex Word32
w String
""
 where
   hi :: Word16
hi = Word32 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
16)
   lo :: Word16
lo = Word32 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w

satisfy :: (Monad m) => (Word8 -> Bool) -> ParsecT LBS u m Word8
satisfy :: forall (m :: * -> *) u.
Monad m =>
(Word8 -> Bool) -> ParsecT LBS u m Word8
satisfy Word8 -> Bool
f = (Word8 -> String)
-> (SourcePos -> Word8 -> LBS -> SourcePos)
-> (Word8 -> Maybe Word8)
-> ParsecT LBS u m Word8
forall s (m :: * -> *) t a u.
Stream s m t =>
(t -> String)
-> (SourcePos -> t -> s -> SourcePos)
-> (t -> Maybe a)
-> ParsecT s u m a
tokenPrim (\Word8
c -> String
"0x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word8 -> String -> String
forall a. Integral a => a -> String -> String
showHex Word8
c String
"")
                      (\SourcePos
pos Word8
_ LBS
_ -> SourcePos
pos)
                      (\Word8
c -> if Word8 -> Bool
f Word8
c then Word8 -> Maybe Word8
forall a. a -> Maybe a
Just Word8
c else Maybe Word8
forall a. Maybe a
Nothing)

anyWord8 :: (Monad m) => ParsecT LBS u m Word8
anyWord8 :: forall (m :: * -> *) u. Monad m => ParsecT LBS u m Word8
anyWord8 = ParsecT LBS u m Word8
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m t
anyToken

anyWord16 :: (Monad m) => ParsecT LBS u m Word16
anyWord16 :: forall (m :: * -> *) u. Monad m => ParsecT LBS u m Word16
anyWord16 = do
  Word8
hi <- ParsecT LBS u m Word8
forall (m :: * -> *) u. Monad m => ParsecT LBS u m Word8
anyWord8
  Word8
lo <- ParsecT LBS u m Word8
forall (m :: * -> *) u. Monad m => ParsecT LBS u m Word8
anyWord8
  Word16 -> ParsecT LBS u m Word16
forall a. a -> ParsecT LBS u m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word16 -> ParsecT LBS u m Word16)
-> Word16 -> ParsecT LBS u m Word16
forall a b. (a -> b) -> a -> b
$ (Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
hi Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftL` Int
8) Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
lo

anyWord32 :: (Monad m) => ParsecT LBS u m Word32
anyWord32 :: forall (m :: * -> *) u. Monad m => ParsecT LBS u m Word32
anyWord32 = do
  Word16
hi <- ParsecT LBS u m Word16
forall (m :: * -> *) u. Monad m => ParsecT LBS u m Word16
anyWord16
  Word16
lo <- ParsecT LBS u m Word16
forall (m :: * -> *) u. Monad m => ParsecT LBS u m Word16
anyWord16
  Word32 -> ParsecT LBS u m Word32
forall a. a -> ParsecT LBS u m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32 -> ParsecT LBS u m Word32)
-> Word32 -> ParsecT LBS u m Word32
forall a b. (a -> b) -> a -> b
$ (Word16 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
hi Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
16) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word16 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
lo

string :: (Monad m) => LBS -> ParsecT LBS u m LBS
string :: forall (m :: * -> *) u. Monad m => LBS -> ParsecT LBS u m LBS
string LBS
s = (Word8 -> ParsecT LBS u m Word8) -> [Word8] -> ParsecT LBS u m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Word8 -> ParsecT LBS u m Word8
forall (m :: * -> *) u. Monad m => Word8 -> ParsecT LBS u m Word8
word8 (LBS -> [Word8]
LBS.unpack LBS
s) ParsecT LBS u m () -> ParsecT LBS u m LBS -> ParsecT LBS u m LBS
forall a b.
ParsecT LBS u m a -> ParsecT LBS u m b -> ParsecT LBS u m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LBS -> ParsecT LBS u m LBS
forall a. a -> ParsecT LBS u m a
forall (m :: * -> *) a. Monad m => a -> m a
return LBS
s

block :: (Monad m) => Int -> ParsecT LBS u m LBS
block :: forall (m :: * -> *) u. Monad m => Int -> ParsecT LBS u m LBS
block Int
size = do  -- count size anyWord8 >>= return . LB.pack
  LBS
i <- ParsecT LBS u m LBS
forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput
  let (LBS
s,LBS
r) = Int64 -> LBS -> (LBS, LBS)
LBS.splitAt (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size) LBS
i
  LBS -> ParsecT LBS u m ()
forall (m :: * -> *) s u. Monad m => s -> ParsecT s u m ()
setInput LBS
r
  LBS -> ParsecT LBS u m LBS
forall a. a -> ParsecT LBS u m a
forall (m :: * -> *) a. Monad m => a -> m a
return LBS
s

allowedValues :: (a -> Parser a) -> [(a,b)] -> Parser b
allowedValues :: forall a b. (a -> Parser a) -> [(a, b)] -> Parser b
allowedValues a -> Parser a
fn = [ParsecT LBS () Identity b] -> ParsecT LBS () Identity b
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice ([ParsecT LBS () Identity b] -> ParsecT LBS () Identity b)
-> ([(a, b)] -> [ParsecT LBS () Identity b])
-> [(a, b)]
-> ParsecT LBS () Identity b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b) -> ParsecT LBS () Identity b)
-> [(a, b)] -> [ParsecT LBS () Identity b]
forall a b. (a -> b) -> [a] -> [b]
map (\(a
val,b
res) -> a -> Parser a
fn a
val Parser a -> ParsecT LBS () Identity b -> ParsecT LBS () Identity b
forall a b.
ParsecT LBS () Identity a
-> ParsecT LBS () Identity b -> ParsecT LBS () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> ParsecT LBS () Identity b
forall a. a -> ParsecT LBS () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return b
res)

parseFromFile :: Parser a -> FilePath -> IO (Either String a)
parseFromFile :: forall a. Parser a -> String -> IO (Either String a)
parseFromFile Parser a
p String
fname
    = do LBS
input <- String -> IO LBS
LBS.readFile String
fname
         Either String a -> IO (Either String a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String a -> IO (Either String a))
-> Either String a -> IO (Either String a)
forall a b. (a -> b) -> a -> b
$ case Parser a -> () -> String -> LBS -> Either ParseError a
forall s t u a.
Stream s Identity t =>
Parsec s u a -> u -> String -> s -> Either ParseError a
runP Parser a
p () String
fname LBS
input of
                    Left ParseError
err  -> String -> Either String a
forall a b. a -> Either a b
Left (ParseError -> String
forall a. Show a => a -> String
show ParseError
err)
                    Right a
x   -> a -> Either String a
forall a b. b -> Either a b
Right a
x