module BinaryFiles
(Endianness(..),
HasEndianness(..),
Serializable,
serialize,
deserialize,
Serialization,
Deserialization,
ContextualSerialization,
ContextualDeserialization,
SomeSerializationFailure(..),
SerializationFailure(..),
LowLevelSerializationFailure(..),
OutOfRangeSerializationFailure(..),
InsufficientDataSerializationFailure(..),
MonadSerial,
seek,
tell,
isEOF,
SerialOrigin(..),
read,
write,
throw,
catch,
getContext,
withContext,
getTags,
withTag,
withWindow,
runSerializationToByteString,
runSerializationToFile,
runDeserializationFromByteString,
runDeserializationFromFile,
runSubDeserializationFromByteString,
toByteString,
toFile,
fromByteString,
fromFile,
serializeWord,
deserializeWord,
serializeNullTerminatedText,
deserializeNullTerminatedText,
serializeNullPaddedText,
deserializeNullPaddedText)
where
import Control.Exception (Exception, IOException)
import qualified Control.Exception as E
import Data.Bits
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.List
import Data.Typeable
import Numeric
import Prelude hiding (read, catch)
import qualified Prelude as P
import System.IO hiding (isEOF)
data Endianness = BigEndian | LittleEndian
deriving (Eq, Show)
class HasEndianness hasEndianness where
considerEndianness :: hasEndianness -> Endianness
instance HasEndianness Endianness where
considerEndianness = id
type Serialization a =
forall context
. ContextualSerialization context a
type Deserialization a =
forall context
. ContextualDeserialization context a
newtype ContextualSerialization context a =
ContextualSerialization {
contextualSerializationAction
:: forall backend
. (BackendSpecificMonadSerial BackendSpecificSerialization backend,
MonadSerial (BackendSpecificSerialization backend),
MonadSerialWriter (BackendSpecificSerialization backend))
=> BackendSpecificSerialization backend context a
}
newtype ContextualDeserialization context a =
ContextualDeserialization {
contextualDeserializationAction
:: forall backend
. (BackendSpecificMonadSerial BackendSpecificDeserialization backend,
MonadSerial (BackendSpecificDeserialization backend),
MonadSerialReader (BackendSpecificDeserialization backend))
=> BackendSpecificDeserialization backend context a
}
data SerialOrigin
= OffsetFromStart
| OffsetFromCurrent
| OffsetFromEnd
deriving (Eq, Ord, Show)
data Window
= IdentityWindow
| StackedWindow {
stackedWindowStart :: Int,
stackedWindowLength :: Int,
stackedWindowUnderlying :: Window
}
data Identity a =
Identity {
identityAction :: a
}
data BackendSpecificSerialization backend context a =
BackendSpecificSerialization {
serializationAction
:: Internals BackendSpecificSerialization backend
-> context
-> [(Int, String)]
-> Window
-> PrimitiveMonad backend
(Either (Int, [(Int, String)], SomeSerializationFailure)
(Internals BackendSpecificSerialization backend, a))
}
data BackendSpecificDeserialization backend context a =
BackendSpecificDeserialization {
deserializationAction
:: Internals BackendSpecificDeserialization backend
-> context
-> [(Int, String)]
-> Window
-> PrimitiveMonad backend
(Either (Int, [(Int, String)], SomeSerializationFailure)
(Internals BackendSpecificDeserialization backend, a))
}
data SomeSerializationFailure =
forall failure . SerializationFailure failure
=> SomeSerializationFailure failure
deriving (Typeable)
data LowLevelSerializationFailure =
LowLevelSerializationFailure IOException
deriving (Typeable)
data OutOfRangeSerializationFailure =
OutOfRangeSerializationFailure Int
deriving (Typeable)
data InsufficientDataSerializationFailure =
InsufficientDataSerializationFailure Int
deriving (Typeable)
class Serial backend where
data SerialDataSource backend
type PrimitiveMonad backend :: * -> *
backend
:: SerialDataSource backend
-> backend
class Serializable context a where
serialize :: a -> ContextualSerialization context ()
deserialize :: ContextualDeserialization context a
class (Show failure, Typeable failure) => SerializationFailure failure where
toSerializationFailure :: failure -> SomeSerializationFailure
fromSerializationFailure :: SomeSerializationFailure -> Maybe failure
toSerializationFailure failure =
SomeSerializationFailure failure
fromSerializationFailure someFailure = case someFailure of
SomeSerializationFailure failure -> cast failure
class (Serial backend,
Monad (PrimitiveMonad backend))
=> BackendSpecificMonadSerial m backend
where
data Internals m backend
getInternals
:: m backend context (Internals m backend)
putInternals
:: Internals m backend
-> m backend context ()
internalsDataSource
:: Internals m backend
-> SerialDataSource backend
class MonadSerial m where
getContext
:: forall context
. (Monad (m context))
=> m context context
withContext
:: forall context context' a
. (Monad (m context),
Monad (m context'))
=> context'
-> m context' a
-> m context a
getTags
:: forall context
. (Monad (m context))
=> m context [(Int, String)]
withTag
:: forall context a
. (Monad (m context))
=> String
-> m context a
-> m context a
getWindow
:: forall context
. (Monad (m context))
=> m context Window
withWindow
:: forall context a
. (Monad (m context))
=> SerialOrigin
-> Int
-> Int
-> m context a
-> m context a
throw
:: forall context failure a
. (Monad (m context),
SerializationFailure failure)
=> failure
-> m context a
catch
:: forall context failure a
. (Monad (m context),
SerializationFailure failure)
=> m context a
-> (Int -> [(Int, String)] -> failure -> m context a)
-> m context a
seek
:: SerialOrigin -> Int -> m context ()
tell
:: m context Int
primitiveTell
:: m context Int
isEOF
:: m context Bool
class MonadSerial m => MonadSerialReader m where
read :: Int -> m context ByteString
class MonadSerial m => MonadSerialWriter m where
write :: ByteString -> m context ()
class BackendSpecificMonadSerial m ByteString
=> MonadSerialByteString m
where
byteStringInternalsOffset
:: Internals m ByteString
-> Int
updateByteStringInternalsOffset
:: Int
-> Internals m ByteString
-> Internals m ByteString
class (MonadSerialWriter (m backend),
BackendSpecificMonadSerial m backend)
=> MonadSerialByteStringWriter m backend
where
byteStringWriterInternalsOutputs
:: Internals m backend
-> [(Int, ByteString)]
updateByteStringWriterInternalsOutputs
:: [(Int, ByteString)]
-> Internals m backend
-> Internals m backend
class BackendSpecificMonadSerial m backend
=> MonadSerialIO m backend
where
ioInternalsHandle
:: Internals m backend
-> Handle
catchIO
:: Exception e
=> IO a
-> (e -> m backend context a)
-> m backend context a
instance Serial ByteString where
data SerialDataSource ByteString =
ByteStringSerialDataSource {
byteStringSerialDataSourceByteString :: ByteString
}
type PrimitiveMonad ByteString = Identity
backend = byteStringSerialDataSourceByteString
instance Serial FilePath where
data SerialDataSource FilePath =
FilePathSerialDataSource {
filePathSerialDataSourceFilePath :: FilePath
}
type PrimitiveMonad FilePath = IO
backend = filePathSerialDataSourceFilePath
instance Monad Identity where
return a = Identity a
(Identity x) >>= f = f x
instance Monad (PrimitiveMonad backend)
=> Monad (BackendSpecificSerialization backend context) where
return a = BackendSpecificSerialization $ \internals _ _ _ ->
return $ Right (internals, a)
(BackendSpecificSerialization x) >>= f =
BackendSpecificSerialization $ \internals context tags window -> do
v <- x internals context tags window
case v of
Left failure -> return $ Left failure
Right (internals', y) ->
serializationAction (f y) internals' context tags window
instance Monad (PrimitiveMonad backend)
=> Monad (BackendSpecificDeserialization backend context) where
return a = BackendSpecificDeserialization $ \internals _ _ _ ->
return $ Right (internals, a)
(BackendSpecificDeserialization x) >>= f =
BackendSpecificDeserialization $ \internals context tags window -> do
v <- x internals context tags window
case v of
Left failure -> return $ Left failure
Right (internals', y) ->
deserializationAction (f y) internals' context tags window
instance forall context
. Monad (ContextualSerialization context) where
return a = ContextualSerialization $ return a
x >>= f =
ContextualSerialization $ do
v <- contextualSerializationAction x
contextualSerializationAction $ f v
instance forall context
. Monad (ContextualDeserialization context) where
return a = ContextualDeserialization $ return a
x >>= f =
ContextualDeserialization $ do
v <- contextualDeserializationAction x
contextualDeserializationAction $ f v
instance BackendSpecificMonadSerial BackendSpecificSerialization ByteString
where
data Internals BackendSpecificSerialization ByteString =
ByteStringSerializationInternals {
byteStringSerializationInternalsDataSource
:: SerialDataSource ByteString,
byteStringSerializationInternalsOffset
:: Int,
byteStringSerializationInternalsOutputs
:: [(Int, ByteString)]
}
getInternals =
BackendSpecificSerialization $ \internals _ _ _ ->
return $ Right (internals, internals)
putInternals internals =
BackendSpecificSerialization $ \_ _ _ _ ->
return $ Right (internals, ())
internalsDataSource = byteStringSerializationInternalsDataSource
instance BackendSpecificMonadSerial BackendSpecificSerialization FilePath
where
data Internals BackendSpecificSerialization FilePath =
FilePathSerializationInternals {
filePathSerializationInternalsDataSource
:: SerialDataSource FilePath,
filePathSerializationInternalsHandle
:: Handle
}
getInternals =
BackendSpecificSerialization $ \internals _ _ _ ->
return $ Right (internals, internals)
putInternals internals =
BackendSpecificSerialization $ \_ _ _ _ ->
return $ Right (internals, ())
internalsDataSource = filePathSerializationInternalsDataSource
instance BackendSpecificMonadSerial BackendSpecificDeserialization ByteString
where
data Internals BackendSpecificDeserialization ByteString =
ByteStringDeserializationInternals {
byteStringDeserializationInternalsDataSource
:: SerialDataSource ByteString,
byteStringDeserializationInternalsOffset
:: Int
}
getInternals =
BackendSpecificDeserialization $ \internals _ _ _ ->
return $ Right (internals, internals)
putInternals internals =
BackendSpecificDeserialization $ \_ _ _ _ ->
return $ Right (internals, ())
internalsDataSource = byteStringDeserializationInternalsDataSource
instance BackendSpecificMonadSerial BackendSpecificDeserialization FilePath
where
data Internals BackendSpecificDeserialization FilePath =
FilePathDeserializationInternals {
filePathDeserializationInternalsDataSource
:: SerialDataSource FilePath,
filePathDeserializationInternalsHandle
:: Handle
}
getInternals =
BackendSpecificDeserialization $ \internals _ _ _ ->
return $ Right (internals, internals)
putInternals internals =
BackendSpecificDeserialization $ \_ _ _ _ ->
return $ Right (internals, ())
internalsDataSource = filePathDeserializationInternalsDataSource
instance MonadSerial (BackendSpecificSerialization ByteString) where
getContext = getContextImplementation BackendSpecificSerialization
withContext context action =
withContextImplementation BackendSpecificSerialization
serializationAction
context action
getTags = getTagsImplementation BackendSpecificSerialization
withTag tag action =
withTagImplementation BackendSpecificSerialization serializationAction
tag action
getWindow = getWindowImplementation BackendSpecificSerialization
withWindow = withWindowImplementation BackendSpecificSerialization
serializationAction
throw failure = throwImplementation BackendSpecificSerialization failure
catch action handler =
catchImplementation BackendSpecificSerialization serializationAction
action handler
seek = seekImplementation byteStringSeek
tell = tellImplementation byteStringTell
primitiveTell = primitiveTellImplementation byteStringTell
isEOF = isEOFImplementation byteStringIsEOF
instance MonadSerial (BackendSpecificSerialization FilePath) where
getContext = getContextImplementation BackendSpecificSerialization
withContext context action =
withContextImplementation BackendSpecificSerialization
serializationAction
context action
getTags = getTagsImplementation BackendSpecificSerialization
withTag tag action =
withTagImplementation BackendSpecificSerialization serializationAction
tag action
getWindow = getWindowImplementation BackendSpecificSerialization
withWindow = withWindowImplementation BackendSpecificSerialization
serializationAction
throw failure = throwImplementation BackendSpecificSerialization failure
catch action handler =
catchImplementation BackendSpecificSerialization serializationAction
action handler
seek = seekImplementation handleSeek
tell = tellImplementation handleTell
primitiveTell = primitiveTellImplementation handleTell
isEOF = isEOFImplementation handleIsEOF
instance MonadSerial (BackendSpecificDeserialization ByteString)
where
getContext = getContextImplementation BackendSpecificDeserialization
withContext context action =
withContextImplementation BackendSpecificDeserialization
deserializationAction
context action
getTags = getTagsImplementation BackendSpecificDeserialization
withTag tag action =
withTagImplementation BackendSpecificDeserialization deserializationAction
tag action
getWindow = getWindowImplementation BackendSpecificDeserialization
withWindow = withWindowImplementation BackendSpecificDeserialization
deserializationAction
throw failure = throwImplementation BackendSpecificDeserialization failure
catch action handler =
catchImplementation BackendSpecificDeserialization deserializationAction
action handler
seek = seekImplementation byteStringSeek
tell = tellImplementation byteStringTell
primitiveTell = primitiveTellImplementation byteStringTell
isEOF = isEOFImplementation byteStringIsEOF
instance MonadSerial (BackendSpecificDeserialization FilePath) where
getContext = getContextImplementation BackendSpecificDeserialization
withContext context action =
withContextImplementation BackendSpecificDeserialization
deserializationAction
context action
getTags = getTagsImplementation BackendSpecificDeserialization
withTag tag action =
withTagImplementation BackendSpecificDeserialization deserializationAction
tag action
getWindow = getWindowImplementation BackendSpecificDeserialization
withWindow = withWindowImplementation BackendSpecificDeserialization
deserializationAction
throw failure = throwImplementation BackendSpecificDeserialization failure
catch action handler =
catchImplementation BackendSpecificDeserialization deserializationAction
action handler
seek = seekImplementation handleSeek
tell = tellImplementation handleTell
primitiveTell = primitiveTellImplementation handleTell
isEOF = isEOFImplementation handleIsEOF
instance MonadSerial ContextualSerialization where
getContext = ContextualSerialization $ getContext
withContext context action =
ContextualSerialization
$ withContext context $ contextualSerializationAction action
getTags = ContextualSerialization $ getTags
withTag tag action =
ContextualSerialization
$ withTag tag $ contextualSerializationAction action
getWindow = ContextualSerialization $ getWindow
withWindow origin offset length action =
ContextualSerialization
$ withWindow origin offset length
$ contextualSerializationAction action
throw failure = ContextualSerialization $ throw failure
catch action handler =
ContextualSerialization
$ catch (contextualSerializationAction action)
(\offset tags failure ->
contextualSerializationAction $ handler offset tags failure)
seek origin offset = ContextualSerialization $ seek origin offset
tell = ContextualSerialization tell
primitiveTell = ContextualSerialization primitiveTell
isEOF = ContextualSerialization isEOF
instance MonadSerial ContextualDeserialization where
getContext = ContextualDeserialization $ getContext
withContext context action =
ContextualDeserialization
$ withContext context $ contextualDeserializationAction action
getTags = ContextualDeserialization $ getTags
withTag tag action =
ContextualDeserialization
$ withTag tag $ contextualDeserializationAction action
getWindow = ContextualDeserialization $ getWindow
withWindow origin offset length action =
ContextualDeserialization
$ withWindow origin offset length
$ contextualDeserializationAction action
throw failure = ContextualDeserialization $ throw failure
catch action handler =
ContextualDeserialization
$ catch (contextualDeserializationAction action)
(\offset tags failure ->
contextualDeserializationAction $ handler offset tags failure)
seek origin offset = ContextualDeserialization $ seek origin offset
tell = ContextualDeserialization tell
primitiveTell = ContextualDeserialization primitiveTell
isEOF = ContextualDeserialization isEOF
instance MonadSerialWriter (BackendSpecificSerialization ByteString) where
write = writeImplementation byteStringWrite
instance MonadSerialWriter (BackendSpecificSerialization FilePath) where
write = writeImplementation handleWrite
instance MonadSerialWriter ContextualSerialization where
write byteString = ContextualSerialization $ write byteString
instance MonadSerialReader (BackendSpecificDeserialization ByteString) where
read = readImplementation byteStringRead
instance MonadSerialReader (BackendSpecificDeserialization FilePath) where
read = readImplementation handleRead
instance MonadSerialReader ContextualDeserialization where
read nBytes = ContextualDeserialization $ read nBytes
instance MonadSerialByteString BackendSpecificSerialization
where
byteStringInternalsOffset = byteStringSerializationInternalsOffset
updateByteStringInternalsOffset newOffset internals =
internals {
byteStringSerializationInternalsOffset = newOffset
}
instance MonadSerialByteString BackendSpecificDeserialization where
byteStringInternalsOffset = byteStringDeserializationInternalsOffset
updateByteStringInternalsOffset newOffset internals =
internals {
byteStringDeserializationInternalsOffset = newOffset
}
instance MonadSerialByteStringWriter
BackendSpecificSerialization ByteString
where
byteStringWriterInternalsOutputs = byteStringSerializationInternalsOutputs
updateByteStringWriterInternalsOutputs newOutputs internals =
internals {
byteStringSerializationInternalsOutputs = newOutputs
}
instance MonadSerialIO BackendSpecificSerialization
FilePath
where
ioInternalsHandle = filePathSerializationInternalsHandle
catchIO action handler =
BackendSpecificSerialization $ \internals context tags window -> do
E.catch (do
result <- action
return $ Right (internals, result))
(\exception ->
serializationAction (handler exception)
internals context tags window)
instance MonadSerialIO BackendSpecificDeserialization
FilePath
where
ioInternalsHandle = filePathDeserializationInternalsHandle
catchIO action handler =
BackendSpecificDeserialization $ \internals context tags window -> do
E.catch (do
result <- action
return $ Right (internals, result))
(\exception ->
deserializationAction (handler exception)
internals context tags window)
instance SerializationFailure SomeSerializationFailure where
toSerializationFailure = id
fromSerializationFailure = Just
instance SerializationFailure LowLevelSerializationFailure
instance SerializationFailure OutOfRangeSerializationFailure
instance SerializationFailure InsufficientDataSerializationFailure
instance Show SomeSerializationFailure where
show (SomeSerializationFailure e) = show e
instance Show LowLevelSerializationFailure where
show (LowLevelSerializationFailure e) =
"Low-level serialization failure: " ++ show e
instance Show OutOfRangeSerializationFailure where
show (OutOfRangeSerializationFailure offset) =
"Out-of-range at " ++ show offset
instance Show InsufficientDataSerializationFailure where
show (InsufficientDataSerializationFailure readLength) =
"Insufficient data for read of " ++ show readLength ++ " bytes"
throwImplementation
:: (Monad (m context),
Monad m',
MonadSerial m,
SerializationFailure failure)
=> ((internals
-> context
-> [(Int, String)]
-> Window
-> m' (Either (Int, [(Int, String)], SomeSerializationFailure)
(internals, a)))
-> m context a)
-> failure
-> m context a
throwImplementation constructor failure = do
offset <- primitiveTell
constructor $ \_ _ tags _ ->
return $ Left (offset, tags, toSerializationFailure failure)
catchImplementation
:: (Monad (m context),
Monad m',
MonadSerial m,
SerializationFailure failure)
=> ((internals
-> context
-> [(Int, String)]
-> Window
-> m' (Either (Int, [(Int, String)], SomeSerializationFailure)
(internals, a)))
-> m context a)
-> (m context a
-> internals
-> context
-> [(Int, String)]
-> Window
-> m' (Either (Int, [(Int, String)], SomeSerializationFailure)
(internals, a)))
-> m context a
-> (Int
-> [(Int, String)]
-> failure
-> m context a)
-> m context a
catchImplementation constructor accessor action handler = do
initialOffset <- tell
constructor $ \internals context tags window -> do
result <- accessor action internals context tags window
case result of
Left (failureOffset, failureTags, failure) ->
case fromSerializationFailure failure of
Nothing -> return result
Just specificFailure ->
accessor
(do
seek OffsetFromStart initialOffset
handler failureOffset failureTags specificFailure)
internals context tags window
Right _ -> return result
getContextImplementation
:: (Monad (m context),
Monad m')
=> ((internals
-> context
-> [(Int, String)]
-> Window
-> m' (Either (Int, [(Int, String)], SomeSerializationFailure)
(internals, context)))
-> m context context)
-> m context context
getContextImplementation constructor = do
constructor $ \internals context _ _ ->
return $ Right (internals, context)
withContextImplementation
:: (Monad (m context),
Monad m',
MonadSerial m)
=> ((internals
-> context
-> [(Int, String)]
-> Window
-> m' (Either (Int, [(Int, String)], SomeSerializationFailure)
(internals, a)))
-> m context a)
-> (m context' a
-> internals
-> context'
-> [(Int, String)]
-> Window
-> m' (Either (Int, [(Int, String)], SomeSerializationFailure)
(internals, a)))
-> context'
-> m context' a
-> m context a
withContextImplementation constructor accessor context x = do
constructor $ \internals _ tags window -> do
v <- accessor x internals context tags window
case v of
Left failure -> return $ Left failure
Right (internals', y) -> return $ Right (internals', y)
getTagsImplementation
:: (Monad (m context),
Monad m',
MonadSerial m)
=> ((internals
-> context
-> [(Int, String)]
-> Window
-> m' (Either (Int, [(Int, String)], SomeSerializationFailure)
(internals, [(Int, String)])))
-> m context [(Int, String)])
-> m context [(Int, String)]
getTagsImplementation constructor =
constructor $ \internals _ tags _ ->
return $ Right (internals, tags)
withTagImplementation
:: (Monad (m context),
Monad m',
MonadSerial m)
=> ((internals
-> context
-> [(Int, String)]
-> Window
-> m' (Either (Int, [(Int, String)], SomeSerializationFailure)
(internals, a)))
-> m context a)
-> (m context a
-> internals
-> context
-> [(Int, String)]
-> Window
-> m' (Either (Int, [(Int, String)], SomeSerializationFailure)
(internals, a)))
-> String
-> m context a
-> m context a
withTagImplementation constructor accessor tagText action = do
tagOffset <- primitiveTell
tags <- getTags
let tags' = (tagOffset, tagText) : tags
constructor $ \internals context _ window ->
accessor action internals context tags' window
getWindowImplementation
:: (Monad (m context),
Monad m',
MonadSerial m)
=> ((internals
-> context
-> [(Int, String)]
-> Window
-> m' (Either (Int, [(Int, String)], SomeSerializationFailure)
(internals, Window)))
-> m context Window)
-> m context Window
getWindowImplementation constructor = do
constructor $ \internals _ _ window -> return $ Right (internals, window)
withWindowImplementation
:: (Monad (m backend context),
Monad m',
MonadSerial (m backend),
BackendSpecificMonadSerial m backend)
=> ((Internals m backend
-> context
-> [(Int, String)]
-> Window
-> m' (Either (Int, [(Int, String)], SomeSerializationFailure)
(Internals m backend, a)))
-> m backend context a)
-> (m backend context a
-> Internals m backend
-> context
-> [(Int, String)]
-> Window
-> m' (Either (Int, [(Int, String)], SomeSerializationFailure)
(Internals m backend, a)))
-> SerialOrigin
-> Int
-> Int
-> m backend context a
-> m backend context a
withWindowImplementation constructor accessor origin offset length action = do
absoluteOffset <- case origin of
OffsetFromStart -> do
return offset
OffsetFromEnd -> do
oldOffset <- tell
seek OffsetFromEnd 0
totalLength <- tell
seek OffsetFromStart oldOffset
return $ offset + totalLength
OffsetFromCurrent -> do
currentOffset <- tell
return $ offset + currentOffset
constructor $ \internals context tags underlyingWindow -> do
let dataSource = internalsDataSource internals
window = StackedWindow {
stackedWindowStart = absoluteOffset,
stackedWindowLength = length,
stackedWindowUnderlying = underlyingWindow
}
x <- accessor action internals context tags window
case x of
Left failure -> return $ Left failure
Right (internals, a) -> do
return $ Right (internals, a)
byteStringSeek
:: (Monad (m ByteString context),
MonadSerial (m ByteString),
MonadSerialByteString m)
=> SerialOrigin
-> Int
-> m ByteString context ()
byteStringSeek origin desiredOffset = do
internals <- getInternals
let dataSource = internalsDataSource internals
byteString = backend dataSource
totalLength = BS.length byteString
currentOffset = byteStringInternalsOffset internals
absoluteDesiredOffset =
case origin of
OffsetFromStart -> desiredOffset
OffsetFromEnd -> desiredOffset + totalLength
OffsetFromCurrent -> desiredOffset + currentOffset
newInternals = updateByteStringInternalsOffset
absoluteDesiredOffset
internals
if (absoluteDesiredOffset < 0) || (absoluteDesiredOffset > totalLength)
then throw $ OutOfRangeSerializationFailure absoluteDesiredOffset
else putInternals newInternals
byteStringTell
:: (Monad (m ByteString context),
MonadSerialByteString m)
=> m ByteString context Int
byteStringTell = do
internals <- getInternals
return $ byteStringInternalsOffset internals
byteStringIsEOF
:: (Monad (m ByteString context),
MonadSerial (m ByteString),
MonadSerialByteString m)
=> m ByteString context Bool
byteStringIsEOF = do
offset <- tell
internals <- getInternals
let dataSource = internalsDataSource internals
byteString = backend dataSource
return $ offset == BS.length byteString
byteStringWrite
:: (MonadSerialByteString BackendSpecificSerialization,
MonadSerialByteStringWriter BackendSpecificSerialization ByteString)
=> ByteString
-> BackendSpecificSerialization ByteString context ()
byteStringWrite output = do
oldInternals <- getInternals
let preexistingOutputs = byteStringWriterInternalsOutputs oldInternals
oldOffset = byteStringInternalsOffset oldInternals
newOffset = oldOffset + BS.length output
newOutputs = (oldOffset, output) : preexistingOutputs
newInternals = updateByteStringWriterInternalsOutputs newOutputs
$ updateByteStringInternalsOffset newOffset oldInternals
putInternals newInternals
byteStringRead
:: (Monad (m ByteString context),
MonadSerialByteString m,
MonadSerialReader (m ByteString))
=> Int
-> m ByteString context ByteString
byteStringRead nBytes = do
internals <- getInternals
let dataSource = internalsDataSource internals
byteString = backend dataSource
totalLength = BS.length byteString
currentOffset = byteStringInternalsOffset internals
actualLengthRead = min nBytes (max 0 (totalLength currentOffset))
newOffset = currentOffset + actualLengthRead
newInternals = updateByteStringInternalsOffset
newOffset
internals
result = BS.take actualLengthRead $ BS.drop currentOffset byteString
putInternals newInternals
if actualLengthRead < nBytes
then throw $ InsufficientDataSerializationFailure
$ nBytes actualLengthRead
else return result
handleSeek
:: (Monad (m FilePath context),
MonadSerial (m FilePath),
MonadSerialIO m FilePath)
=> SerialOrigin
-> Int
-> m FilePath context ()
handleSeek origin desiredOffset = do
internals <- getInternals
let handle = ioInternalsHandle internals
lowLevelOrigin = case origin of
OffsetFromStart -> AbsoluteSeek
OffsetFromEnd -> SeekFromEnd
OffsetFromCurrent -> RelativeSeek
lowLevelOffset = fromIntegral desiredOffset
catchIO (hSeek handle lowLevelOrigin lowLevelOffset)
(\exception -> do
return (exception :: IOException)
absoluteDesiredOffset <-
case origin of
OffsetFromStart -> return desiredOffset
OffsetFromEnd -> do
seek OffsetFromEnd 0
end <- tell
return $ desiredOffset + end
OffsetFromCurrent -> do
current <- tell
return $ desiredOffset + current
throw $ OutOfRangeSerializationFailure absoluteDesiredOffset)
handleTell
:: (Monad (m FilePath context),
MonadSerial (m FilePath),
MonadSerialIO m FilePath)
=> m FilePath context Int
handleTell = do
internals <- getInternals
let handle = ioInternalsHandle internals
catchIO (do
result <- hTell handle
return $ fromIntegral result)
(\exception -> throw $ LowLevelSerializationFailure exception)
handleIsEOF
:: (Monad (m FilePath context),
MonadSerial (m FilePath),
MonadSerialIO m FilePath)
=> m FilePath context Bool
handleIsEOF = do
internals <- getInternals
let handle = ioInternalsHandle internals
catchIO (hIsEOF handle)
(\exception -> throw $ LowLevelSerializationFailure exception)
handleWrite
:: (Monad (m FilePath context),
MonadSerial (m FilePath),
MonadSerialIO m FilePath,
MonadSerialWriter (m FilePath))
=> ByteString
-> m FilePath context ()
handleWrite output = do
internals <- getInternals
let handle = ioInternalsHandle internals
catchIO (BS.hPut handle output)
(\exception -> throw $ LowLevelSerializationFailure exception)
handleRead
:: (Monad (m FilePath context),
MonadSerial (m FilePath),
MonadSerialIO m FilePath,
MonadSerialReader (m FilePath))
=> Int
-> m FilePath context ByteString
handleRead nBytes = do
internals <- getInternals
let handle = ioInternalsHandle internals
catchIO (BS.hGet handle nBytes)
(\exception -> throw $ LowLevelSerializationFailure exception)
seekImplementation
:: (Monad (m backend context),
MonadSerial (m backend),
BackendSpecificMonadSerial m backend)
=> (SerialOrigin
-> Int
-> m backend context a)
-> SerialOrigin
-> Int
-> m backend context a
seekImplementation backendSeek origin desiredOffset = do
recurseOnWindows
(\(origin, desiredOffset) -> backendSeek origin desiredOffset)
(\(origin, desiredOffset) windowStart windowLength recurse -> do
internals <- getInternals
let dataSource = internalsDataSource internals
window = backend dataSource
absoluteDesiredOffset <- case origin of
OffsetFromStart -> return desiredOffset
OffsetFromEnd -> do
return $ desiredOffset + windowLength
OffsetFromCurrent -> do
currentOffset <- tell
return $ desiredOffset + currentOffset
if (absoluteDesiredOffset < 0)
|| (absoluteDesiredOffset > windowLength)
then throw $ OutOfRangeSerializationFailure absoluteDesiredOffset
else do
let underlyingDesiredOffset =
absoluteDesiredOffset + windowStart
recurse (OffsetFromStart, underlyingDesiredOffset))
(origin, desiredOffset)
tellImplementation
:: (Monad (m backend context),
MonadSerial (m backend),
BackendSpecificMonadSerial m backend)
=> m backend context Int
-> m backend context Int
tellImplementation backendTell = do
recurseOnWindows
(\() -> backendTell)
(\() windowStart windowLength recurse -> do
underlyingOffset <- recurse ()
internals <- getInternals
let dataSource = internalsDataSource internals
maybeFailure =
if (underlyingOffset < windowStart)
|| (underlyingOffset windowStart > windowLength)
then Just $ OutOfRangeSerializationFailure offset
else Nothing
offset = underlyingOffset windowStart
case maybeFailure of
Just failure -> throw failure
Nothing -> return offset)
()
primitiveTellImplementation
:: (Monad (m backend context),
MonadSerial (m backend),
BackendSpecificMonadSerial m backend)
=> m backend context Int
-> m backend context Int
primitiveTellImplementation backendTell = do
recurseOnWindows
(\() -> backendTell)
(\() _ _ recurse -> recurse ())
()
isEOFImplementation
:: (Monad (m backend context),
MonadSerial (m backend),
BackendSpecificMonadSerial m backend)
=> m backend context Bool
-> m backend context Bool
isEOFImplementation backendIsEOF = do
recurseOnWindows
(\() -> backendIsEOF)
(\() _ windowLength _ -> do
offset <- tell
internals <- getInternals
return $ offset == windowLength)
()
writeImplementation
:: (Monad (m context),
MonadSerialWriter m)
=> (ByteString -> m context ())
-> ByteString
-> m context ()
writeImplementation backendWrite output = do
let outputLength = BS.length output
recurseOnWindows
(\_ -> backendWrite output)
(\maybeOffset windowStart windowLength recurse -> do
offset <- case maybeOffset of
Nothing -> tell
Just offset -> return offset
let outputStart = offset
outputEnd = outputStart + outputLength
if (outputStart >= 0) && (outputEnd < windowLength)
then recurse $ Just $ offset + windowStart
else throw $ OutOfRangeSerializationFailure $ if outputStart < 0
then outputStart
else outputEnd)
Nothing
readImplementation
:: (Monad (m context),
MonadSerialReader m)
=> (Int -> m context ByteString)
-> Int
-> m context ByteString
readImplementation backendRead nBytes = do
recurseOnWindows
(\_ -> backendRead nBytes)
(\maybeOffset windowStart windowLength recurse -> do
offset <- case maybeOffset of
Nothing -> tell
Just offset -> return offset
if offset + nBytes <= windowLength
then recurse $ Just $ offset + windowStart
else throw $ InsufficientDataSerializationFailure nBytes)
Nothing
recurseOnWindows
:: (Monad (m context),
MonadSerial m)
=> (b -> m context a)
-> (b -> Int -> Int -> (b -> m context a) -> m context a)
-> b
-> m context a
recurseOnWindows baseCase recursiveCase initialValue = do
let loop window value = do
case window of
IdentityWindow -> baseCase value
StackedWindow { } -> do
let windowStart = stackedWindowStart window
windowLength = stackedWindowLength window
underlyingWindow = stackedWindowUnderlying window
recursiveCase value windowStart windowLength
$ loop underlyingWindow
outermostWindow <- getWindow
loop outermostWindow initialValue
runSerializationToByteString
:: ContextualSerialization () a
-> Either (Int, [(Int, String)], SomeSerializationFailure) (a, ByteString)
runSerializationToByteString action = do
identityAction $ do
let dataSource =
ByteStringSerialDataSource {
byteStringSerialDataSourceByteString = BS.empty
}
internals =
ByteStringSerializationInternals {
byteStringSerializationInternalsDataSource = dataSource,
byteStringSerializationInternalsOffset = 0,
byteStringSerializationInternalsOutputs = []
}
context = ()
tags = []
window = IdentityWindow
result <- serializationAction
(do
value <- contextualSerializationAction action
internals <- getInternals
let outputs =
byteStringSerializationInternalsOutputs internals
finalLength =
foldl' (\lengthSoFar (offset, output) ->
max lengthSoFar (offset + BS.length output))
0
outputs
output =
foldl' (\outputSoFar (offset, output) ->
BS.concat [BS.take offset outputSoFar,
output,
BS.drop (offset + BS.length output)
outputSoFar])
(BS.replicate finalLength 0x00)
(reverse outputs)
return (value, output))
internals context tags window
case result of
Left failure -> return $ Left failure
Right (_, result) -> return $ Right result
runSerializationToFile
:: ContextualSerialization () a
-> FilePath
-> IO (Either (Int, [(Int, String)], SomeSerializationFailure) a)
runSerializationToFile action filePath = do
withBinaryFile filePath WriteMode $ \handle -> do
let dataSource =
FilePathSerialDataSource {
filePathSerialDataSourceFilePath = filePath
}
internals =
FilePathSerializationInternals {
filePathSerializationInternalsDataSource = dataSource,
filePathSerializationInternalsHandle = handle
}
context = ()
tags = []
window = IdentityWindow
result <- serializationAction
(contextualSerializationAction action)
internals context tags window
case result of
Left failure -> return $ Left failure
Right (_, result) -> return $ Right result
runDeserializationFromByteString
:: ContextualDeserialization () a
-> ByteString
-> Either (Int, [(Int, String)], SomeSerializationFailure) a
runDeserializationFromByteString action byteString =
identityAction $ do
let dataSource =
ByteStringSerialDataSource {
byteStringSerialDataSourceByteString = byteString
}
internals =
ByteStringDeserializationInternals {
byteStringDeserializationInternalsDataSource = dataSource,
byteStringDeserializationInternalsOffset = 0
}
context = ()
tags = []
window = IdentityWindow
result <- deserializationAction
(contextualDeserializationAction action)
internals context tags window
case result of
Left failure -> return $ Left failure
Right (_, result) -> return $ Right result
runDeserializationFromFile
:: ContextualDeserialization () a
-> FilePath
-> IO (Either (Int, [(Int, String)], SomeSerializationFailure) a)
runDeserializationFromFile action filePath = do
withBinaryFile filePath ReadMode $ \handle -> do
let dataSource =
FilePathSerialDataSource {
filePathSerialDataSourceFilePath = filePath
}
internals =
FilePathDeserializationInternals {
filePathDeserializationInternalsDataSource = dataSource,
filePathDeserializationInternalsHandle = handle
}
context = ()
tags = []
window = IdentityWindow
result <- deserializationAction
(contextualDeserializationAction action)
internals context tags window
case result of
Left failure -> return $ Left failure
Right (_, result) -> return $ Right result
runSubDeserializationFromByteString
:: ContextualDeserialization () a
-> ByteString
-> Deserialization a
runSubDeserializationFromByteString action byteString =
case runDeserializationFromByteString action byteString of
Left (_, _, failure) -> throw failure
Right result -> return result
toByteString
:: Serializable () a
=> a
-> (Either (Int, [(Int, String)], SomeSerializationFailure) ByteString)
toByteString value =
case runSerializationToByteString (serialize value) of
Left failure -> Left failure
Right (_, byteString) -> Right byteString
toFile
:: Serializable () a
=> a
-> FilePath
-> IO (Maybe (Int, [(Int, String)], SomeSerializationFailure))
toFile value filePath = do
result <- runSerializationToFile (serialize value) filePath
case result of
Left failure -> return (Just failure)
Right _ -> return Nothing
fromByteString
:: Serializable () a
=> ByteString
-> Either (Int, [(Int, String)], SomeSerializationFailure) a
fromByteString byteString =
runDeserializationFromByteString deserialize byteString
fromFile
:: Serializable () a
=> FilePath
-> IO (Either (Int, [(Int, String)], SomeSerializationFailure) a)
fromFile filePath =
runDeserializationFromFile deserialize filePath
serializeWord
:: (Bits word, Integral word, Num word, HasEndianness context)
=> word
-> ContextualSerialization context ()
serializeWord word = do
context <- getContext
let byteSize = div (bitSize word) 8
getByte byteIndex =
fromIntegral $ 0xFF .&. shiftR word (byteIndex * 8)
byteSequence = case considerEndianness context of
LittleEndian -> [0 .. byteSize 1]
BigEndian -> [byteSize 1, byteSize 2 .. 0]
write $ BS.pack $ map getByte byteSequence
deserializeWord
:: forall word context
. (Bits word, Integral word, Num word, HasEndianness context)
=> ContextualDeserialization context word
deserializeWord = do
context <- getContext
let byteSize = div (bitSize (0 :: word)) 8
combine byteString =
foldl' (.|.)
0
$ zipWith (\byteIndex byte ->
shiftL (fromIntegral byte)
(byteIndex * 8))
byteSequence
(BS.unpack byteString)
byteSequence = case considerEndianness context of
LittleEndian -> [0 .. byteSize 1]
BigEndian -> [byteSize 1, byteSize 2 .. 0]
byteString <- read byteSize
return $ combine byteString
serializeNullTerminatedText :: ByteString -> Serialization ()
serializeNullTerminatedText text = do
write text
write $ BS.pack [0x00]
deserializeNullTerminatedText :: Deserialization ByteString
deserializeNullTerminatedText = do
let loop octetsSoFar = do
octetByteString <- read 1
let octet = BS.head octetByteString
if octet == 0x00
then return $ BS.pack octetsSoFar
else loop $ octetsSoFar ++ [octet]
loop []
serializeNullPaddedText :: Int -> ByteString -> Serialization ()
serializeNullPaddedText paddedLength text = do
write text
write $ BS.pack $ take (paddedLength BS.length text) $ repeat 0x00
deserializeNullPaddedText :: Int -> Deserialization ByteString
deserializeNullPaddedText paddedLength = do
byteString <- read paddedLength
return
$ BS.reverse
$ BS.dropWhile (\octet -> octet == 0x00)
$ BS.reverse byteString