{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, ScopedTypeVariables, TypeOperators, Rank2Types, ImpredicativeTypes, Trustworthy #-}

-- | Serialization of compound data types (with class!). Also read and write methods' type class contexts
--   are implemented with heterogeneous list constraints, making them sufficiently abstract. For every
--   context FooCtx that a program uses, one has a constraint /HasField ctx FooCtx/, that allows
--   one to find the context evidence in the concrete context.
--
--   The recursive function that is generally needed to traverse some data is implemented in 'readOneLayer'.
--   A poly-traversal (aka strategy) is a function that is inserted into this recursive call chain. For instance,
--   'cycReadCompoundData' is a poly-traversal implementing cycle detection for circular data dependencies,
--   but it leaves the programmer free to determine exactly how the layers are to be read. The types of
--   poly-traversals are found in 'PolyTraversal' and 'PolyTraversalW'.
--
--   The library uses a concept of strategy/poly-traversal to coordinate reading. Poly-traversals have as a
--   precondition that they must be seeked at a data entity at address 'n', an invariant that they must seek
--   to some other data entity before calling each of their parameter operations, and a postcondition that
--   they must leave the stream seeked at 'n'. The operations in Integral, Headers, SeekableStream, and
--   SeekableWriter do not obey these properties; they are low-level implementation functions.
--
--   The functions 'readOneLayer' and 'writeOneLayer' do appropriate checking that the data being read is
--   of the correct shape for the type at which they are called. See 'Headers' module for documentation
--   of the data format.
module Data.Columbia.CompoundData (module Data.Columbia.Types, module Data.Columbia.Internal.RWInstances, module Data.Columbia.Internal.Orphans, readHeader',
-- ** Strategy/traversal combinators
(#.), (##.), fixT, fixTW, typeCoerce, typeCoerceW,
-- ** Compound data read/write strategies
RW(..), RWCtx(..), PolyTraversal, readOneLayer, PolyTraversalW, writeOneLayer,
-- ** Seeking and updating
seekByTrack, seekToField, updateField, updateByTrack) where

import Data.Generics.SYB.WithClass.Basics
import Data.Word
import Data.Int
import Data.Maybe
import Data.Array
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
import Control.Monad.Identity
import Control.Monad.Trans
import Control.Monad.Morph
import Control.Monad
import Data.Columbia.Internal.SeekableStream
import Data.Columbia.Internal.SeekableWriter
import Data.Columbia.Internal.IntegralTypes
import Data.Columbia.Internal.Headers
import Data.Columbia.Internal.RWInstances
import Data.Columbia.Internal.Orphans
import Data.Columbia.Types
import Data.Columbia.FRecord
import Data.Columbia.DynamicWithCtx

infixl 9 #.
infixl 9 ##.

{-# INLINE (#.) #-}
(#.) :: (Data ctx t)
	=> PolyTraversal ctx m t
	-> (forall t2. (Data ctx t2) => PolyTraversal ctx m t2)
	-> PolyTraversal ctx m t
(traversal #. traversal2) proxy f = traversal proxy(traversal2 proxy f)

{-# INLINE (##.) #-}
(##.) :: (Data ctx t)
	=> PolyTraversalW ctx m t
	-> (forall t2. (Data ctx t2) => PolyTraversalW ctx m t2)
	-> PolyTraversalW ctx m t
(traversal ##. traversal2) proxy f = traversal proxy(traversal2 proxy f)

fixT :: (Data ctx t)
	=> Proxy ctx
	-> (forall t2. (Data ctx t2) => PolyTraversal ctx m t2)
	-> ReaderT(SeekableStream m Word8) m t
fixT proxy traversal = traversal proxy(fixT proxy traversal)

fixTW :: (Data ctx t)
	=> Proxy ctx
	-> (forall t2. (Data ctx t2) => PolyTraversalW ctx m t2)
	-> t
	-> ReaderT(SeekableWriter m Word8) m ()
fixTW proxy traversal = traversal proxy(fixTW proxy traversal)

-- | Try to cast from the first traversal; if that fails, use the second traversal.
typeCoerce :: (Typeable t, Data ctx t2)
	=> PolyTraversal ctx m t
	-> PolyTraversal ctx m t2
	-> PolyTraversal ctx m t2
typeCoerce traversal traversal2 proxy m = 
	maybe
	(traversal2 proxy m)
	id
	(gcast(traversal proxy m))

typeCoerceW :: (Typeable t, Data ctx t2)
	=> PolyTraversalW ctx m t
	-> PolyTraversalW ctx m t2
	-> PolyTraversalW ctx m t2
typeCoerceW traversal traversal2 proxy f x = 
	maybe
	(traversal2 proxy f x)
	(traversal proxy f)
	(cast x)

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

{-# INLINE recursor #-}
recursor :: forall ctx m a. (Monad m, HasField ctx RWCtx, Data ctx a)
	=> (forall a. (Data ctx a) => ReaderT(SeekableStream m Word8) m a)
	-> Proxy ctx -> StateT Word32(ReaderT(SeekableStream m Word8) m) a
recursor rec proxy = do
	x <- get
	put$!x+4
	lift$do
		seek x
		rec

-- | Function returns something 'PolyTraversal'. We can use this to examine the top layer
--   of a data structure, then seek to and read some of its components.
readOneLayer :: forall ctx m d. (Monad m, HasField ctx RWCtx, Data ctx d)
	=> PolyTraversal ctx m d
readOneLayer proxy0 m = do
	seekByPointer
	addr <- getPosition
	let specimen :: d = error"readOneLayer: specimen"
	let ty = dataTypeOf proxy0 specimen
	-- First examine the header on disk and compare to the header deriving from the data type.
	-- If they don't match, reading cannot continue.
	hdr@(_, ix, _) <- readHeader
	let hdr2 = headerFromConstr proxy0 specimen(indexConstr ty ix)
	when(hdr/=hdr2)$fail$"readCompoundData: header check failed "++
		"(header from file is "++showsPrec 11 hdr
		("; header from program is "++showsPrec 11 hdr2 ")")
	d <- if isHeaderAlgtype hdr || isHeaderArraytype hdr then do
			-- Construct a term skeleton; transforming this skeleton will load the data.
			specimen2 <- if isHeaderArraytype hdr then do
					l <- readIntegral
					return$!enhancedFromConstr proxy0 ty hdr l
				else
					return$!enhancedFromConstr proxy0 ty hdr 0
			addr <- getPosition
			-- Construct a 'PolyTraversal' that reads the sub-components.
			evalStateT
				(gmapM
				proxy0
				(\_ -> recursor m proxy0)
				specimen2)
				addr
		else
		-- Fall back on a primitive reader method if one is defined.
		case hasField(dict :: ctx d) of
			RWCtx -> readData
	seek addr
	return d

-- | This is a slightly more tail-recursive implementation of 'mapM_' for lists.
--   That helps deal with serialization of lists, a common case.
mapM_' :: (Monad m) => (t->m())->[t]->m()
mapM_' f (x:xs@(_:_)) = do { f x;mapM_' f xs }
mapM_' f [x] = f x
mapM_' _ [] = return()

{-# INLINE recursorW #-}
recursorW :: forall ctx m. (Monad m, HasField ctx RWCtx)
	=> (forall a. (Data ctx a) => a -> ReaderT(SeekableWriter m Word8) m ())
	-> DynamicWithCtx(Data ctx)
	-> StateT Word32(ReaderT(SeekableWriter m Word8) m) ()
recursorW rec (DynamicWithCtx d) = do
	n <- get
	put$!n+4
	lift$do
		seekWriter n
		rec d -- Tail recursive

{-# INLINE collectSubterms #-}
collectSubterms :: (Data ctx d) => Proxy ctx->d->[DynamicWithCtx(Data ctx)]
collectSubterms proxy = snd.runWriter.gmapM proxy(\d->do { tell.return.dynamicWithCtx$d; return$error"unused result" })

-- | Writes the top layer of a data structure, and sells each of the sub-targets in turn.
writeOneLayer :: forall ctx m d. (Monad m, HasField ctx RWCtx, Data ctx d) => PolyTraversalW ctx m d
writeOneLayer proxy0 f d = do
	let ty = dataTypeOf proxy0 d
	n <- getWriterPosition
	seekWriterAtEnd
	m <- getWriterPosition
	seekWriter n
	writeIntegral m
	seekWriterAtEnd
	if isAlgType ty || dataTypeName ty == "Data.Array.Array" then do
			writeHeader proxy0 d
			n <- getWriterPosition
			sequence_(replicate(nConstructorParameters proxy0 d) (writeIntegral(0::Word32)))
			let subterms = collectSubterms proxy0 d
			evalStateT(mapM_'(recursorW f) subterms)
				n
		else case hasField(dict :: ctx d) of
			RWCtx -> do
				writeHeader proxy0 d
				writeData d
	seekWriter n

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

-- | 'seekToField' is going to be used to seek at a field by its constructor index, or if it happens
--   to be an array, by its array index.
seekToField :: forall m. (Monad m) => Int -> ReaderT(SeekableStream m Word8) m ()
seekToField ix = do
	seekByPointer
	hdr <- readHeader
	(nf, _) <- nFieldsBytes hdr
	when(ix<1||ix>nf)$fail$"seekToField: index out of range (1,"++showsPrec 11 nf")"
	relSeek$fromIntegral$4*ix-4

-- | This is for traversing several fields in succession. It relies on the notion of track from the 'zipper'
--   package. These tracks are monomorphic; people who want to can define polymorphic tracks in the privacy
--   of their own homes.
{-# INLINE seekByTrack #-}
seekByTrack track = mapM_ seekToField track

-- | 'updateField' reads and reconstructs the whole constructor (or array) with the specified field
--   as the target of the writer-poly-traversal. It then writes the modified constructor back onto
--   the stream.
updateField :: (Monad m, Data ctx d, HasField ctx RWCtx) => Int -> PolyTraversalW ctx(StateT Int m) d
updateField n proxy f =
	writeOneLayer proxy
	$ \d->
	do
	m <- get
	put$!succ m
	if n==m then
		hoist(lift.(`evalStateT`1))$f d
		else
		fixTW proxy writeOneLayer d

_updateByTrack :: (Monad m, Data ctx d, HasField ctx RWCtx) => [Int] -> PolyTraversalW ctx(StateT Int m) d
_updateByTrack (i:is) proxy f = (updateField i ##. _updateByTrack is) proxy f
_updateByTrack [] _ f = f

-- | 'updateByTrack' is going to modify and reconstruct several constructors in succession.
{-# INLINE updateByTrack #-}
updateByTrack :: (Monad m, Data ctx d, HasField ctx RWCtx) => [Int]-> PolyTraversalW ctx m d
updateByTrack = hoistPolyTraversalW(`evalStateT`1) lift._updateByTrack