{- |
ToDo:

Lazy read and write.

Problem on writing:
If the length of data is computed lazily,
then you must seek back to the file position
where the size is stored.
That is for writing of lazily generated data
we need a seekable file device.
-}
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 -- skip padding byte
      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