module Data.IFF
(T(..), Chunk(..),
ChunkId, chunkIdFromString, chunkIdToString,
fromByteString, toByteString,
) where
import Control.Monad (guard, liftM, liftM2, liftM4, )
import Data.Maybe (fromMaybe)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as L
import Data.ByteString (ByteString)
import Data.Word (Word32)
import qualified Data.Binary.Get as Get
import qualified Data.Binary as Bin
import Data.Binary.Get (Get, getByteString, getWord32be, getWord8, runGetOrFail)
import Data.Binary.Put (Put, putByteString, putWord32be, runPut)
import Data.Binary (Binary)
import Prelude hiding (getChar)
data T = Cons
{T -> ChunkId
chunkId :: ChunkId
,T -> Chunk
chunk :: Chunk
}
data ChunkId = ChunkId Char Char Char Char
deriving ChunkId -> ChunkId -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChunkId -> ChunkId -> Bool
$c/= :: ChunkId -> ChunkId -> Bool
== :: ChunkId -> ChunkId -> Bool
$c== :: ChunkId -> ChunkId -> Bool
Eq
data Chunk =
Form {Chunk -> [T]
parts :: [T]
}
| List {Chunk -> [T]
props :: [T]
,parts :: [T]
}
| Cat {parts :: [T]
}
| Prop {parts :: [T]
}
| Chunk {Chunk -> ByteString
content :: ByteString
}
chunkIdFromString :: String -> ChunkId
chunkIdFromString :: String -> ChunkId
chunkIdFromString (Char
c0:Char
c1:Char
c2:Char
c3:[]) = Char -> Char -> Char -> Char -> ChunkId
ChunkId Char
c0 Char
c1 Char
c2 Char
c3
chunkIdFromString String
_ = forall a. HasCallStack => String -> a
error String
"chunkId must have four characters"
chunkIdToString :: ChunkId -> String
chunkIdToString :: ChunkId -> String
chunkIdToString (ChunkId Char
c0 Char
c1 Char
c2 Char
c3) = Char
c0forall a. a -> [a] -> [a]
:Char
c1forall a. a -> [a] -> [a]
:Char
c2forall a. a -> [a] -> [a]
:Char
c3forall a. a -> [a] -> [a]
:[]
formId, listId, catId, propId :: ChunkId
formId :: ChunkId
formId = String -> ChunkId
chunkIdFromString String
"FORM"
listId :: ChunkId
listId = String -> ChunkId
chunkIdFromString String
"LIST"
catId :: ChunkId
catId = String -> ChunkId
chunkIdFromString String
"CAT "
propId :: ChunkId
propId = String -> ChunkId
chunkIdFromString String
"PROP"
instance Show T where
show :: T -> String
show (Cons { chunkId :: T -> ChunkId
chunkId = ChunkId
name, chunk :: T -> Chunk
chunk = Chunk
chk }) =
String
"chunk "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show ChunkId
nameforall a. [a] -> [a] -> [a]
++String
" "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show Chunk
chk
instance Show ChunkId where
show :: ChunkId -> String
show ChunkId
cid = forall a. Show a => a -> String
show (ChunkId -> String
chunkIdToString ChunkId
cid)
instance Show Chunk where
show :: Chunk -> String
show (Form { parts :: Chunk -> [T]
parts = [T]
p }) =
String
"IFF.Form {parts="forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show [T]
pforall a. [a] -> [a] -> [a]
++String
"}"
show (List { props :: Chunk -> [T]
props = [T]
ps, parts :: Chunk -> [T]
parts = [T]
p }) =
String
"IFF.List {props"forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show [T]
psforall a. [a] -> [a] -> [a]
++String
",parts="forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show [T]
pforall a. [a] -> [a] -> [a]
++String
"}"
show (Cat { parts :: Chunk -> [T]
parts = [T]
p }) =
String
"IFF.Cat {parts="forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show [T]
pforall a. [a] -> [a] -> [a]
++String
"}"
show (Prop { parts :: Chunk -> [T]
parts = [T]
p }) =
String
"IFF.Prop {parts="forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show [T]
pforall a. [a] -> [a] -> [a]
++String
"}"
show (Chunk { content :: Chunk -> ByteString
content = ByteString
cont }) =
String
"IFF.Chunk { binary content, size "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show (ByteString -> Int
B.length ByteString
cont)forall a. [a] -> [a] -> [a]
++String
" }"
instance Binary T where
get :: Get T
get = Get T
parser
put :: T -> Put
put = T -> Put
putT
isProp :: T -> Bool
isProp :: T -> Bool
isProp (Cons ChunkId
_ (Prop [T]
_)) = Bool
True
isProp T
_ = Bool
False
getChar :: Get Char
getChar :: Get Char
getChar = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) Get Word8
getWord8
getChunkId :: Get ChunkId
getChunkId :: Get ChunkId
getChunkId = forall (m :: * -> *) a1 a2 a3 a4 r.
Monad m =>
(a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r
liftM4 Char -> Char -> Char -> Char -> ChunkId
ChunkId Get Char
getChar Get Char
getChar Get Char
getChar Get Char
getChar
fromByteString :: ByteString -> Maybe T
fromByteString :: ByteString -> Maybe T
fromByteString = forall a. Get a -> ByteString -> Maybe a
runParser Get T
parser
runParser :: Get a -> ByteString -> Maybe a
runParser :: forall a. Get a -> ByteString -> Maybe a
runParser Get a
parse ByteString
bs = forall a. Get a -> ByteString -> Maybe a
runParserLazy Get a
parse forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
L.fromChunks [ByteString
bs]
runParserLazy :: Get a -> L.ByteString -> Maybe a
runParserLazy :: forall a. Get a -> ByteString -> Maybe a
runParserLazy Get a
parse ByteString
bs =
case forall a.
Get a
-> ByteString
-> Either
(ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
runGetOrFail Get a
parse ByteString
bs of
Right (ByteString
rest, ByteOffset
_, a
x) -> forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ByteString -> Bool
L.null ByteString
rest) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. a -> Maybe a
Just a
x
Left (ByteString, ByteOffset, String)
_ -> forall a. Maybe a
Nothing
parseMany :: Get [T]
parseMany :: Get [T]
parseMany =
do Bool
mt <- Get Bool
Get.isEmpty
if Bool
mt
then forall (m :: * -> *) a. Monad m => a -> m a
return []
else forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (:) Get T
parser Get [T]
parseMany
parser :: Get T
parser :: Get T
parser =
do ChunkId
cid <- Get ChunkId
getChunkId
Int
size <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral Get Word32
getWord32be
ByteString
rawContent <- Int -> Get ByteString
getByteString Int
size
Int -> Get ()
Get.skip forall a b. (a -> b) -> a -> b
$ forall a. Integral a => a -> a -> a
mod (-Int
size) Int
2
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"parser: failed") forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
forall a. a -> Maybe a -> a
fromMaybe (forall a. a -> Maybe a
Just (ChunkId -> Chunk -> T
Cons ChunkId
cid
(Chunk {content :: ByteString
content = ByteString
rawContent}))) forall a b. (a -> b) -> a -> b
$
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ChunkId
cid forall a b. (a -> b) -> a -> b
$
(ChunkId
formId, ([T] -> Chunk) -> ByteString -> Maybe T
runParseStruct [T] -> Chunk
Form ByteString
rawContent) forall a. a -> [a] -> [a]
:
(ChunkId
listId, ([T] -> Chunk) -> ByteString -> Maybe T
runParseStruct (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [T] -> [T] -> Chunk
List forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> ([a], [a])
span T -> Bool
isProp) ByteString
rawContent) forall a. a -> [a] -> [a]
:
(ChunkId
catId, ([T] -> Chunk) -> ByteString -> Maybe T
runParseStruct [T] -> Chunk
Cat ByteString
rawContent) forall a. a -> [a] -> [a]
:
(ChunkId
propId, ([T] -> Chunk) -> ByteString -> Maybe T
runParseStruct [T] -> Chunk
Prop ByteString
rawContent) forall a. a -> [a] -> [a]
:
[]
runParseStruct :: ([T] -> Chunk) -> ByteString -> Maybe T
runParseStruct :: ([T] -> Chunk) -> ByteString -> Maybe T
runParseStruct [T] -> Chunk
cons ByteString
bs =
do (ChunkId
format, [T]
subChunks) <- forall a. Get a -> ByteString -> Maybe a
runParser Get (ChunkId, [T])
parseStruct ByteString
bs
forall (m :: * -> *) a. Monad m => a -> m a
return (ChunkId -> Chunk -> T
Cons ChunkId
format ([T] -> Chunk
cons [T]
subChunks))
parseStruct :: Get (ChunkId, [T])
parseStruct :: Get (ChunkId, [T])
parseStruct =
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) Get ChunkId
getChunkId Get [T]
parseMany
packLengthBE :: ByteString -> Put
packLengthBE :: ByteString -> Put
packLengthBE ByteString
dat =
Word32 -> Put
putWord32be (forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
dat) :: Word32)
s2b :: String -> ByteString
s2b :: String -> ByteString
s2b = String -> ByteString
B8.pack
toByteString :: T -> ByteString
toByteString :: T -> ByteString
toByteString = [ByteString] -> ByteString
B.concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
L.toChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPut forall b c a. (b -> c) -> (a -> b) -> a -> c
. T -> Put
putT
putT :: T -> Put
putT :: T -> Put
putT (Cons {chunkId :: T -> ChunkId
chunkId = ChunkId
name, chunk :: T -> Chunk
chunk = Chunk
chk}) =
let bid :: ByteString
bid = String -> ByteString
s2b (ChunkId -> String
chunkIdToString ChunkId
name)
in case Chunk
chk of
Form [T]
subChunks -> ChunkId -> ByteString -> [T] -> Put
makeStructureChunk ChunkId
formId ByteString
bid [T]
subChunks
List [T]
ps
[T]
subChunks -> ChunkId -> ByteString -> [T] -> Put
makeStructureChunk ChunkId
listId ByteString
bid ([T]
psforall a. [a] -> [a] -> [a]
++[T]
subChunks)
Cat [T]
subChunks -> ChunkId -> ByteString -> [T] -> Put
makeStructureChunk ChunkId
catId ByteString
bid [T]
subChunks
Prop [T]
subChunks -> ChunkId -> ByteString -> [T] -> Put
makeStructureChunk ChunkId
propId ByteString
bid [T]
subChunks
Chunk ByteString
chunkData -> do
ByteString -> Put
putByteString ByteString
bid
ByteString -> Put
packLengthBE ByteString
chunkData
ByteString -> Put
putByteString forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
padData ByteString
chunkData
makeStructureChunk :: ChunkId -> ByteString -> [T] -> Put
makeStructureChunk :: ChunkId -> ByteString -> [T] -> Put
makeStructureChunk ChunkId
name ByteString
formatName [T]
chunks =
let cont :: ByteString
cont = [ByteString] -> ByteString
B.concat (ByteString
formatName forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map T -> ByteString
toByteString [T]
chunks)
in do
ByteString -> Put
putByteString forall a b. (a -> b) -> a -> b
$ String -> ByteString
s2b forall a b. (a -> b) -> a -> b
$ ChunkId -> String
chunkIdToString ChunkId
name
ByteString -> Put
packLengthBE ByteString
cont
ByteString -> Put
putByteString ByteString
cont
padData :: ByteString -> ByteString
padData :: ByteString -> ByteString
padData ByteString
str =
if forall a. Integral a => a -> Bool
even (ByteString -> Int
B.length ByteString
str)
then ByteString
str
else ByteString -> Word8 -> ByteString
B.snoc ByteString
str Word8
0