{-# LANGUAGE Rank2Types, Trustworthy #-}

module Data.Columbia.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.SeekableStream
import Data.Columbia.MyEndianness
import Data.Columbia.Mapper

data SeekableWriter m c = SeekableWriter
	{ _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) (_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 -> 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)
	(\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) => Word32 -> 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)

type PolyTraversalW ctx m d = Proxy ctx
	-> (forall a. (Data ctx a) => a -> ReaderT(SeekableWriter m Word8) m ())
	-> d -> ReaderT(SeekableWriter m Word8) m ()

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)

concludeFileWrite ref table@(Table path _) = do
	(_,sz) <- readIORef ref
	unmapAll table
	bracket
		(openBinaryFile path ReadWriteMode)
		hClose
		(`hSetFileSize` toInteger sz)