packages feed

columbia 0.1.0.0 → 0.1.0.1

raw patch · 6 files changed

+145/−13 lines, 6 filesdep +data-endiandep ~base

Dependencies added: data-endian

Dependency ranges changed: base

Files

columbia.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                columbia
-version:             0.1.0.0
+version:             0.1.0.1
 synopsis:            Enhanced serialization for media that support seeking.
 description:         Libraries such as binary and cereal support sequential reading and writing but do not rely on any further operations. Many media support seeking in files as well. This library implements a file format that supports random access to data entities by seeking.
 	.
@@ -19,9 +19,9 @@ 
 library
   exposed-modules:     Data.Columbia, Data.Columbia.CompoundData, Data.Columbia.SeekableStream, Data.Columbia.SeekableWriter, Data.Columbia.Utils, Data.Columbia.Gc, Data.Columbia.Integral, Data.Columbia.CycleDetection, Data.Columbia.FRecord, Data.Columbia.WithAddress, Data.Columbia.Orphans, Data.Columbia.DualLock
-  other-modules:       Data.Columbia.Headers, Data.Columbia.Coercion, Data.Columbia.RWInstances, Data.Columbia.Mapper
+  other-modules:       Data.Columbia.Headers, Data.Columbia.Coercion, Data.Columbia.RWInstances, Data.Columbia.Mapper, Data.Columbia.MyEndianness
   -- other-extensions:    
-  build-depends:       base >=4.6 && <4.9, filelock ==0.1.0.1, contravariant ==1.4, bytestring >=0.10 && <0.11, monad-loops ==0.4.3, mtl ==2.2.1, directory ==1.2.2.0, syb-with-class ==0.6.1.7, array >=0.5.1 && <0.5.2, invariant ==0.4.2, containers ==0.5.8.1, pointless-haskell ==0.0.9, mmorph ==1.0.9, parallel ==3.2.1.1, QuickCheck ==2.10, transformers ==0.4.2.0, mmap ==0.5.9
+  build-depends:       base >=4.6 && <=5, filelock ==0.1.0.1, contravariant ==1.4, bytestring >=0.10 && <0.11, monad-loops ==0.4.3, mtl ==2.2.1, directory ==1.2.2.0, syb-with-class ==0.6.1.7, array >=0.5.1 && <0.5.2, invariant ==0.4.2, containers ==0.5.8.1, pointless-haskell ==0.0.9, mmorph ==1.0.9, parallel ==3.2.1.1, QuickCheck ==2.10, transformers ==0.4.2.0, mmap ==0.5.9, data-endian ==0.1
   if os(mingw32)
     cpp-options: -DWIN32
   hs-source-dirs:      src
src/Data/Columbia/Integral.hs view
@@ -11,6 +11,12 @@ import Data.Columbia.SeekableStream
 import Data.Columbia.SeekableWriter
 
+{-readIntegral :: (Monad m, Integral i) => ReaderT(SeekableStream m Word8) m i
+readIntegral = liftM fromIntegral consumeIntegralToken
+
+writeIntegral :: (Monad m, Integral i) => i -> ReaderT(SeekableWriter m Word8) m ()
+writeIntegral = putIntegralToken.fromIntegral-}
+
 readIntegral :: (Monad m, Bits i, Integral i) => ReaderT(SeekableStream m Word8) m i
 readIntegral = liftM4(\x1 x2 x3 x4 -> shiftL(fromIntegral x1) 24 .|.
 	shiftL(fromIntegral x2) 16 .|.
@@ -27,6 +33,7 @@ 	putToken$!fromIntegral$shiftR x 16
 	putToken$!fromIntegral$shiftR x 8
 	putToken$!fromIntegral x
+
 
 readIntegral16 :: (Monad m, Bits i, Integral i) => ReaderT(SeekableStream m Word8) m i
 readIntegral16 = liftM2(\x1 x2 -> shiftL(fromIntegral x1) 8 .|.
src/Data/Columbia/Mapper.hs view
@@ -89,12 +89,15 @@ 			bracket
 				(openBinaryFile path ReadWriteMode)
 				hClose
-				(`hSetFileSize` (toInteger aligned+65536))
+				(`hSetFileSize` (toInteger aligned+toInteger amount))
 		(mp',p) <- liftM (\p -> (insert aligned p mp, plusPtr p (fromIntegral r))) $
-			c_system_io_mmap_mmap handle' 3{-ReadWriteEx-} (fromIntegral aligned) 65536
+			c_system_io_mmap_mmap handle' 3{-ReadWriteEx-} (fromIntegral aligned) amount
 		-- putStrLn$"mmap complete"
 		return$!(mp',p)
 	where
+	-- Groups of four bytes that straddle a word
+	-- will have to trigger the mapping of two contiguous pages.
+	amount = if r >= 65533 then 2*65536 else 65536
 	(d, r) = ptr `divMod` 65536
 	aligned = 65536 * d
+ src/Data/Columbia/MyEndianness.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE Trustworthy, ScopedTypeVariables #-}
+
+-- | Read and write data in little-endian format.
+module Data.Columbia.MyEndianness (bigEndian, swapEndian') where
+
+import System.IO.Unsafe
+import Foreign.Marshal.Alloc
+import qualified Foreign.Storable as S
+import Data.Endian
+import Control.Exception
+import Foreign.Ptr
+import Data.Bits
+import Data.Word
+import Data.Int
+
+----------------------------------------------
+-- Endianness
+
+-- | Determine whether running on a big-endian system.
+bigEndian :: IO Bool
+bigEndian = do
+	p <- malloc
+	finally
+		(do
+		S.poke p (bit 24 :: Word32)
+		n :: Word8 <- S.peek (castPtr p)
+		return (n == 1))
+		(free p)
+
+{-# NOINLINE _bigEndian #-}
+_bigEndian :: Bool
+_bigEndian = unsafePerformIO bigEndian
+
+instance (EndianSensitive t, EndianSensitive u, EndianSensitive v, EndianSensitive w) => EndianSensitive (t, u, v, w) where
+	swapEndian (a, b, c, d) = (swapEndian a, swapEndian b, swapEndian c, swapEndian d)
+
+instance EndianSensitive Int8 where
+	swapEndian = id
+
+instance EndianSensitive Word8 where
+	swapEndian = id
+
+byteSwapped x = unsafePerformIO $ do
+	p <- malloc
+	finally
+		(do
+		S.poke p x
+		b1 :: Word8 <- S.peekByteOff p 0
+		b2 :: Word8 <- S.peekByteOff p 1
+		b3 :: Word8 <- S.peekByteOff p 2
+		b4 :: Word8 <- S.peekByteOff p 3
+		S.pokeByteOff p 3 b1
+		S.pokeByteOff p 2 b2
+		S.pokeByteOff p 1 b3
+		S.pokeByteOff p 0 b4
+		S.peek p)
+		(free p)
+
+instance EndianSensitive Float where
+	swapEndian = byteSwapped
+
+instance EndianSensitive Char where
+	swapEndian = byteSwapped
+
+instance (EndianSensitive t, EndianSensitive u) => EndianSensitive (t, u) where
+	swapEndian (x, y) = (swapEndian x, swapEndian y)
+
+instance (EndianSensitive t, EndianSensitive u) => EndianSensitive (Either t u) where
+	swapEndian = either (Left . swapEndian) (Right . swapEndian)
+
+instance EndianSensitive () where
+	swapEndian () = ()
+
+swapEndian' :: (EndianSensitive e) => e->e
+swapEndian' = if _bigEndian then swapEndian else id
src/Data/Columbia/SeekableStream.hs view
@@ -4,13 +4,14 @@ -- ** Stream forming functions
 makeIoStream, makeIoStreamChar, unshimmedIOStream, makeByteStringStream, makeGenericStream,
 -- ** Stream management functions
-_getPosition, _seek, _consumeToken, _seekAtEnd, _isLockLive, getPosition, seek, consumeToken, seekAtEnd, isLockLive, relSeek, peekStream, streamToList) where
+_getPosition, _seek, _consumeToken, _consumeIntegralToken, _seekAtEnd, _isLockLive, getPosition, seek, consumeToken, consumeIntegralToken, seekAtEnd, isLockLive, relSeek, peekStream, streamToList) where
 
 import Foreign.Marshal.Utils
 import Foreign.Storable
 import Data.Word
 import Data.Maybe
 import Data.Char
+import Data.Bits
 import Data.IORef
 import System.IO
 import System.IO.Error
@@ -25,16 +26,18 @@ import System.IO.Unsafe
 import Unsafe.Coerce
 import Data.Columbia.Mapper
+import Data.Columbia.MyEndianness
 
 data SeekableStream m c = SeekableStream
-	{ __consumeToken :: !(m(Maybe c)), __seek :: !(Word32 -> m()), __getPosition :: !(m Word32), __seekAtEnd :: !(m()), __isLockLive :: !(m Bool) } deriving Functor
+	{ __consumeToken :: !(m(Maybe c)), __consumeIntegralToken :: !(m(Maybe Word32)), __seek :: !(Word32 -> m()), __getPosition :: !(m Word32), __seekAtEnd :: !(m()), __isLockLive :: !(m Bool) } deriving Functor
 
-seekableStream :: m(Maybe c) -> (Word32 -> m()) -> m Word32 -> m() -> m Bool -> SeekableStream m c
+seekableStream :: m(Maybe c) -> m(Maybe Word32) -> (Word32 -> m()) -> m Word32 -> m() -> m Bool -> SeekableStream m c
 seekableStream = SeekableStream
 
 hoistStream :: (forall t. m t -> m2 t) -> SeekableStream m c -> SeekableStream m2 c
-hoistStream f s = SeekableStream(f(_consumeToken s)) (\n -> f(_seek s n)) (f(_getPosition s)) (f(_seekAtEnd s)) (f(_isLockLive s))
+hoistStream f s = SeekableStream(f(_consumeToken s)) (f(_consumeIntegralToken s)) (\n -> f(_seek s n)) (f(_getPosition s)) (f(_seekAtEnd s)) (f(_isLockLive s))
 
+{-# INLINE getWord8 #-}
 getWord8 :: Handle -> IO Word8
 getWord8 h = with 0$ \p -> do
 	n <- hGetBuf h p 1
@@ -52,6 +55,12 @@ 			return mzero
 		else
 			mapBlock table n>>=peek>>= \x->(writeIORef ref$!(succ n,sz))>>(return$!return x))
+	{-
+	TODO: not complete yet: (readIORef ref>>= \(n,sz)->if n+3>=sz then
+			return mzero
+		else
+			mapBlock table n>>=peek>>= \x->(writeIORef ref$!(n+4,sz))>>(return$!return$!swapEndian' x))-}
+	(return$error"makeIoStream: unimplemented")
 	(\n->modifyIORef' ref(\(_,sz)->(n,sz)))
 	(liftM fst$readIORef ref)
 	(modifyIORef' ref(\(_,sz)->(sz,sz)))
@@ -59,9 +68,15 @@ makeIoStreamChar :: IORef(Pointer,Pointer) -> Table -> FileLock -> SeekableStream IO Char
 makeIoStreamChar ref t = fmap(chr.fromIntegral).makeIoStream ref t
 
+bytesToIntegral x1 x2 x3 x4 = return$!shiftL(fromIntegral x1) 24 .|.
+	shiftL(fromIntegral x2) 16 .|.
+	shiftL(fromIntegral x3) 8 .|.
+	fromIntegral x4
+
 unshimmedIOStream :: Handle -> FileLock -> SeekableStream IO Word8
 unshimmedIOStream handle lock = SeekableStream
 	(liftM(return$!) (getWord8 handle))
+	(liftM4 bytesToIntegral(getWord8 handle) (getWord8 handle) (getWord8 handle) (getWord8 handle))
 	(hSeek handle AbsoluteSeek. toInteger)
 	(liftM fromInteger(hTell handle))
 	(hSeek handle SeekFromEnd 0)
@@ -77,6 +92,7 @@ 		else do
 			put$!succ n
 			return$!return$!B.index b n')
+	(return$error"makeByteStringStream: unimplemented")
 	put
 	get
 	(put$!fromIntegral$B.length b)
@@ -93,6 +109,7 @@ 			put$!(succ m, x:ls, xs)
 			return$!return x
 		[] -> return mzero)
+	(return$error"makeGenericStream: unimplemented")
 	(\n -> do
 	(m, ls, ls2) <- get
 	let n' = fromIntegral n-fromIntegral m
@@ -106,28 +123,40 @@ 	(return True)
 
 _consumeToken = __consumeToken
+_consumeIntegralToken = __consumeIntegralToken
 _seek = __seek
 _getPosition = __getPosition
 _seekAtEnd = __seekAtEnd
 _isLockLive = __isLockLive
 
+{-# INLINE getPosition #-}
 getPosition :: (Monad m) => ReaderT(SeekableStream m c) m Word32
 getPosition = ask>>=lift._getPosition
 
+{-# INLINE seek #-}
 seek :: (Monad m) => Word32 -> ReaderT(SeekableStream m c) m ()
 seek n = ask>>=lift.(`_seek` n)
 
+{-# INLINE consumeToken #-}
 consumeToken :: (Monad m) => ReaderT(SeekableStream m c) m c
 consumeToken = do
 	s <- ask
 	liftM(maybe(error"consumeToken: end of stream") id)$lift$_consumeToken s
 
+{-# INLINE consumeIntegralToken #-}
+consumeIntegralToken :: (Monad m) => ReaderT(SeekableStream m c) m Word32
+consumeIntegralToken = do
+	s <- ask
+	liftM(maybe(error"consumeIntegralToken: end of stream") id)$lift$_consumeIntegralToken s
+
+{-# INLINE seekAtEnd #-}
 seekAtEnd :: (Monad m) => ReaderT(SeekableStream m c) m ()
 seekAtEnd = ask>>=lift._seekAtEnd
 
 isLockLive :: (Monad m) => ReaderT(SeekableStream m c) m Bool
 isLockLive = ask>>=lift._isLockLive 
 
+{-# INLINE relSeek #-}
 relSeek n = do
 	m <- getPosition
 	seek$!m+n
src/Data/Columbia/SeekableWriter.hs view
@@ -8,6 +8,7 @@ import Data.List
 import Data.Word
 import Data.Char
+import Data.Bits
 import Data.IORef
 import System.IO
 import System.FileLock
@@ -17,16 +18,17 @@ import Control.Arrow
 import Control.Parallel.Strategies
 import Data.Columbia.SeekableStream
+import Data.Columbia.MyEndianness
 import Data.Columbia.Mapper
 
 data SeekableWriter m c = SeekableWriter
-	{ _putToken :: !(c -> m()), stream :: !(SeekableStream m c) }
+	{ _putToken :: !(c -> m()), _putIntegralToken :: !(Word32 -> m()), stream :: !(SeekableStream m c) }
 
 instance (Functor m) => Invariant(SeekableWriter m) where
-	invmap f g sw = SeekableWriter(_putToken sw.g) (fmap f(stream sw))
+	invmap f g sw = SeekableWriter(_putToken sw.g) (_putIntegralToken sw) (fmap f(stream sw))
 
 hoistWriter :: (forall t. m t -> m2 t) -> SeekableWriter m c -> SeekableWriter m2 c
-hoistWriter f sw = SeekableWriter(\x -> f(_putToken sw x)) (hoistStream f(stream sw))
+hoistWriter f sw = SeekableWriter(\x -> f(_putToken sw x)) (\x->f(_putIntegralToken sw x)) (hoistStream f(stream sw))
 
 putWord8 :: Handle -> Word8 -> IO()
 putWord8 h x = with x(\p -> hPutBuf h p 1)
@@ -34,24 +36,40 @@ makeIoWriter :: IORef(Pointer,Pointer) -> Table -> FileLock -> SeekableWriter IO Word8
 makeIoWriter ref table lock = SeekableWriter
 	(\x->readIORef ref>>= \(n,sz)->mapBlock table n>>=(`poke` x)>>(writeIORef ref$!(succ n,max(succ n) sz)))
+	{-
+	TODO: not complete yet
+	(\x->readIORef ref>>= \(n,sz)->mapBlock table n>>=(`poke` swapEndian' x)>>(writeIORef ref$!(n+4,max(n+4) sz)))-}
+	(\_->fail"makeIoWriter: unimplemented")
 	(makeIoStream ref table lock)
 
 makeIoWriterChar :: IORef(Pointer,Pointer) -> Table -> FileLock -> SeekableWriter IO Char
 makeIoWriterChar ref t = invmap(chr.fromIntegral) (fromIntegral.ord).makeIoWriter ref t
 
 unshimmedIOWriter :: Handle -> FileLock -> SeekableWriter IO Word8
-unshimmedIOWriter handle lock = SeekableWriter(putWord8 handle) (unshimmedIOStream handle lock)
+unshimmedIOWriter handle lock = SeekableWriter(putWord8 handle)
+	(\n->putWord8 handle(fromIntegral$shiftR n 24)>>
+		putWord8 handle(fromIntegral$shiftR n 16)>>
+		putWord8 handle(fromIntegral$shiftR n 8)>>
+		putWord8 handle(fromIntegral n))
+	(unshimmedIOStream handle lock)
 
 makeGenericWriter :: SeekableWriter(State(Word32, [t], [t])) t
 makeGenericWriter = SeekableWriter
 	(\x -> modify(\(n, ls, ls2) -> using(succ n, x:ls, drop 1 ls2) (evalTuple3 rseq rseq rseq)))
+	(\_->fail"makeGenericWriter: unimplemented")
 	makeGenericStream
 
 putToken :: (Monad m) => c -> ReaderT(SeekableWriter m c) m ()
 putToken c = ask>>=lift.(`_putToken` c)
 
+putIntegralToken :: (Monad m) => Word32 -> ReaderT(SeekableWriter m c) m ()
+putIntegralToken n = ask>>=lift.(`_putIntegralToken` n)
+
 consumeTokenW :: (Monad m) => ReaderT(SeekableWriter m c) m (Maybe c)
 consumeTokenW = ask>>=lift._consumeToken.stream
+
+consumeIntegralTokenW :: (Monad m) => ReaderT(SeekableWriter m c) m (Maybe Word32)
+consumeIntegralTokenW = ask>>=lift._consumeIntegralToken.stream
 
 getWriterPosition :: (Monad m) => ReaderT(SeekableWriter m c) m Word32
 getWriterPosition = ask>>=lift._getPosition.stream