    -- ------------------------------------------------------------

    {- |
       Module     : Text.XML.HXT.Arrow.Binary
       Copyright  : Copyright (C) 2008 Uwe Schmidt
       License    : MIT

       Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
       Stability  : experimental
       Portability: portable

       De-/Serialisation arrows for XmlTrees and other arbitrary values with a Binary instance
    -}

    -- ------------------------------------------------------------

    module Text.XML.HXT.Arrow.Binary
        ( readBinaryValue
        , writeBinaryValue
        )
    where

    import           Control.Arrow                             ()
    import           Control.Arrow.ArrowExc
    import           Control.Arrow.ArrowIO
    import           Control.Arrow.ArrowList

    import           Data.Binary
    import qualified Data.ByteString.Lazy                      as B

    import           System.IO                                 (IOMode (..), hClose,
                                                                openBinaryFile)

    import           Text.XML.HXT.Arrow.XmlState.ErrorHandling
    import           Text.XML.HXT.Arrow.XmlState.TypeDefs

    -- ------------------------------------------------------------

    readBinaryValue         :: (Binary a) => String -> IOStateArrow s b a
    readBinaryValue :: forall a s b. Binary a => String -> IOStateArrow s b a
    readBinaryValue String
    file
                            = ((Bool -> DeCompressionFct -> IOSLA (XIOState s) b a)
    -> (Bool, DeCompressionFct) -> IOSLA (XIOState s) b a
    forall a b c. (a -> b -> c) -> (a, b) -> c
    uncurry ((Bool -> DeCompressionFct -> IOSLA (XIOState s) b a)
     -> (Bool, DeCompressionFct) -> IOSLA (XIOState s) b a)
    -> (Bool -> DeCompressionFct -> IOSLA (XIOState s) b a)
    -> (Bool, DeCompressionFct)
    -> IOSLA (XIOState s) b a
    forall a b. (a -> b) -> a -> b
    $ String -> Bool -> DeCompressionFct -> IOSLA (XIOState s) b a
    forall a s b.
    Binary a =>
    String -> Bool -> DeCompressionFct -> IOStateArrow s b a
    decodeBinaryValue String
    file)
                              ((Bool, DeCompressionFct) -> IOSLA (XIOState s) b a)
    -> IOSLA (XIOState s) b (Bool, DeCompressionFct)
    -> IOSLA (XIOState s) b a
    forall c b d.
    (c -> IOSLA (XIOState s) b d)
    -> IOSLA (XIOState s) b c -> IOSLA (XIOState s) b d
    forall (a :: * -> * -> *) c b d.
    ArrowList a =>
    (c -> a b d) -> a b c -> a b d
    $< Selector XIOSysState (Bool, DeCompressionFct)
    -> IOSLA (XIOState s) b (Bool, DeCompressionFct)
    forall c s b. Selector XIOSysState c -> IOStateArrow s b c
    getSysVar ( Selector XIOSysState Bool
    theStrictDeserialize
                                             Selector XIOSysState Bool
    -> Selector XIOSysState DeCompressionFct
    -> Selector XIOSysState (Bool, DeCompressionFct)
    forall s a b. Selector s a -> Selector s b -> Selector s (a, b)
    .&&&.
                                             Selector XIOSysState DeCompressionFct
    theBinaryDeCompression
                                           )

    -- | Read a serialied value from a file, optionally decompress it and decode the value
    -- In case of an error, the error message is issued and the arrow fails

    decodeBinaryValue         :: (Binary a) => String -> Bool -> DeCompressionFct -> IOStateArrow s b a
    decodeBinaryValue :: forall a s b.
    Binary a =>
    String -> Bool -> DeCompressionFct -> IOStateArrow s b a
    decodeBinaryValue String
    file Bool
    strict DeCompressionFct
    decompress
                              = IO a -> IOSLA (XIOState s) b a
    forall c b. IO c -> IOSLA (XIOState s) b c
    forall (a :: * -> * -> *) c b. ArrowIO a => IO c -> a b c
    arrIO0 IO a
    dec
                                IOSLA (XIOState s) b a
    -> IOSLA (XIOState s) SomeException a -> IOSLA (XIOState s) b a
    forall b c.
    IOSLA (XIOState s) b c
    -> IOSLA (XIOState s) SomeException c -> IOSLA (XIOState s) b c
    forall (a :: * -> * -> *) b c.
    ArrowExc a =>
    a b c -> a SomeException c -> a b c
    `catchA`
                                String -> IOSLA (XIOState s) SomeException a
    forall s b. String -> IOStateArrow s SomeException b
    issueExc String
    "readBinaryValue"
        where
        dec :: IO a
    dec                 = ( if Bool
    strict
                                then IO ByteString
    readItAll
                                else String -> IO ByteString
    B.readFile String
    file
                              ) IO ByteString -> (ByteString -> IO a) -> IO a
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= a -> IO a
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (a -> IO a) -> (ByteString -> a) -> ByteString -> IO a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ByteString -> a
    forall a. Binary a => ByteString -> a
    decode (ByteString -> a) -> DeCompressionFct -> ByteString -> a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . DeCompressionFct
    decompress
        readItAll :: IO ByteString
    readItAll           = do
                              Handle
    h <- String -> IOMode -> IO Handle
    openBinaryFile String
    file IOMode
    ReadMode
                              ByteString
    c <- Handle -> IO ByteString
    B.hGetContents Handle
    h
                              ByteString -> Int64
    B.length ByteString
    c Int64 -> IO ByteString -> IO ByteString
    forall a b. a -> b -> b
    `seq`
                               do
                               Handle -> IO ()
    hClose Handle
    h
                               ByteString -> IO ByteString
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ByteString
    c     -- hack: force reading whole file and close it immediately

    -- | Serialize a value, optionally compress it, and write it to a file.
    -- In case of an error, the error message is issued and the arrow fails

    writeBinaryValue        :: (Binary a) => String -> IOStateArrow s a ()
    writeBinaryValue :: forall a s. Binary a => String -> IOStateArrow s a ()
    writeBinaryValue String
    file   = (DeCompressionFct -> String -> IOSLA (XIOState s) a ())
    -> String -> DeCompressionFct -> IOSLA (XIOState s) a ()
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip DeCompressionFct -> String -> IOSLA (XIOState s) a ()
    forall a s.
    Binary a =>
    DeCompressionFct -> String -> IOStateArrow s a ()
    encodeBinaryValue String
    file (DeCompressionFct -> IOSLA (XIOState s) a ())
    -> IOSLA (XIOState s) a DeCompressionFct -> IOSLA (XIOState s) a ()
    forall c b d.
    (c -> IOSLA (XIOState s) b d)
    -> IOSLA (XIOState s) b c -> IOSLA (XIOState s) b d
    forall (a :: * -> * -> *) c b d.
    ArrowList a =>
    (c -> a b d) -> a b c -> a b d
    $< Selector XIOSysState DeCompressionFct
    -> IOSLA (XIOState s) a DeCompressionFct
    forall c s b. Selector XIOSysState c -> IOStateArrow s b c
    getSysVar Selector XIOSysState DeCompressionFct
    theBinaryCompression

    encodeBinaryValue        :: (Binary a) => CompressionFct -> String -> IOStateArrow s a ()
    encodeBinaryValue :: forall a s.
    Binary a =>
    DeCompressionFct -> String -> IOStateArrow s a ()
    encodeBinaryValue DeCompressionFct
    compress String
    file
                             = (a -> IO ()) -> IOSLA (XIOState s) a ()
    forall b c. (b -> IO c) -> IOSLA (XIOState s) b c
    forall (a :: * -> * -> *) b c. ArrowIO a => (b -> IO c) -> a b c
    arrIO a -> IO ()
    enc
                               IOSLA (XIOState s) a ()
    -> IOSLA (XIOState s) SomeException () -> IOSLA (XIOState s) a ()
    forall b c.
    IOSLA (XIOState s) b c
    -> IOSLA (XIOState s) SomeException c -> IOSLA (XIOState s) b c
    forall (a :: * -> * -> *) b c.
    ArrowExc a =>
    a b c -> a SomeException c -> a b c
    `catchA`
                               String -> IOSLA (XIOState s) SomeException ()
    forall s b. String -> IOStateArrow s SomeException b
    issueExc String
    "writeBinaryXmlTree"
        where
        enc :: a -> IO ()
    enc                  = String -> ByteString -> IO ()
    B.writeFile String
    file (ByteString -> IO ()) -> (a -> ByteString) -> a -> IO ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . DeCompressionFct
    compress DeCompressionFct -> (a -> ByteString) -> a -> ByteString
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> ByteString
    forall a. Binary a => a -> ByteString
    encode

    -- ------------------------------------------------------------