SeekableWriter.hs

{-# LANGUAGE Rank2Types, Trustworthy #-}

module Data.Columbia.Internal.SeekableWriter where

import Foreign.Marshal.Utils
import Foreign.Storable
import Data.Functor.Invariant
import Data.List
import Data.Word
import Data.Char
import Data.Bits
import Data.IORef
import Data.Generics.SYB.WithClass.Basics
import System.IO
import System.FileLock
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Morph
import Control.Monad
import Control.Arrow
import Control.Parallel.Strategies
import Control.Exception
import Data.Columbia.Types
import Data.Columbia.Internal.SeekableStream
-- import Data.Columbia.MyEndianness
import Data.Columbia.Internal.Mapper

instance (Functor m) => Invariant(SeekableWriter m) where
	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)) (\x->f(_putIntegralToken sw x)) (hoistStream f(stream sw))

{-# INLINE putWord8 #-}
putWord8 :: Handle -> Word8 -> IO()
putWord8 h x = with x(\p -> hPutBuf h p 1)

makeIoWriter :: IORef(Pointer,Pointer) -> Table -> FileLock -> Bool -> SeekableWriter IO Word8
makeIoWriter ref table lock eagerUnmapping = SeekableWriter
	(\x->readIORef ref>>= \(n,sz)->mapBlock table n eagerUnmapping>>=(`poke` x)>>(writeIORef ref$!(succ n,max(succ n) sz)))
	{- TODO: not complete yet
	(\x->readIORef ref>>= \(n,sz)->mapBlock table n eagerUnmapping>>=(`poke` swapEndian' x)>>(writeIORef ref$!(n+4,max(n+4) sz)))-}
	(\_->fail"makeIoWriter: unimplemented")
	(makeIoStream ref table lock eagerUnmapping)

{-# INLINE makeIoWriter' #-}
makeIoWriter' :: FilePath -> FileLock -> Bool -> IO(SeekableWriter IO Word8,IO(),IORef(Pointer,Pointer))
makeIoWriter' path l eagerUnmapping = do
	table <- newTable path
	sz <- fileSizeShim table
	ref <- newIORef$!(0,sz)

	-- Delegate used for closing file.
	let conclude = do
		(_,sz) <- readIORef ref
		unmapAll table
		bracket
			(openBinaryFile path ReadWriteMode)
			hClose
			(`hSetFileSize` toInteger sz)

	return$!(makeIoWriter ref table l eagerUnmapping,
		conclude,	
		ref)

makeIoWriterChar :: IORef(Pointer,Pointer) -> Table -> FileLock -> Bool -> SeekableWriter IO Char
makeIoWriterChar ref t l = invmap(chr.fromIntegral) (fromIntegral.ord).makeIoWriter ref t l

unshimmedIOWriter :: Handle -> FileLock -> SeekableWriter IO Word8
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

{-# INLINE putToken #-}
putToken :: (Monad m) => c -> ReaderT(SeekableWriter m c) m ()
putToken c = ask>>=lift.(`_putToken` c)

{-# INLINE putIntegralToken #-}
putIntegralToken :: (Monad m) => Word32 -> ReaderT(SeekableWriter m c) m ()
putIntegralToken n = ask>>=lift.(`_putIntegralToken` n)

{-# INLINE consumeTokenW #-}
consumeTokenW :: (Monad m) => ReaderT(SeekableWriter m c) m (Maybe c)
consumeTokenW = ask>>=lift._consumeToken.stream

{-# INLINE consumeIntegralTokenW #-}
consumeIntegralTokenW :: (Monad m) => ReaderT(SeekableWriter m c) m (Maybe Word32)
consumeIntegralTokenW = ask>>=lift._consumeIntegralToken.stream

{-# INLINE getWriterPosition #-}
getWriterPosition :: (Monad m) => ReaderT(SeekableWriter m c) m Word32
getWriterPosition = ask>>=lift._getPosition.stream

{-# INLINE seekWriter #-}
seekWriter :: (Monad m) => Pointer -> ReaderT(SeekableWriter m c) m ()
seekWriter n = ask>>=lift.(`_seek` n).stream

{-# INLINE seekWriterAtEnd #-}
seekWriterAtEnd :: (Monad m) => ReaderT(SeekableWriter m c) m ()
seekWriterAtEnd = ask>>=lift._seekAtEnd.stream

{-# INLINE relSeekWriter #-}
relSeekWriter :: (Monad m) => Word32 -> ReaderT(SeekableWriter m c) m ()
relSeekWriter n = ask>>=lift.runReaderT(relSeek n).stream

{-# INLINE local' #-}
local' f x = ask>>=lift.runReaderT x.f

{-# INLINE hoistReaderM #-}
hoistReaderM :: (Monad m, Monad n)
	=> (forall t. m t->n t)
	-> (forall t. n t->m t)
	-> ReaderT(SeekableWriter m c) m u
	-> ReaderT(SeekableWriter n c) n u
hoistReaderM f f2 = hoist f.local'(hoistWriter f2)

hoistPolyTraversalW :: (Monad m, Monad n)
	=> (forall t. m t->n t)
	-> (forall t. n t->m t)
	-> PolyTraversalW ctx m u
	-> PolyTraversalW ctx n u
hoistPolyTraversalW f f2 traversal proxy g = hoistReaderM f f2.traversal proxy(\x->hoistReaderM f2 f.g$x)