{-# 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 an inductive data type instance is
--   implemented in 'readOneLayer'. A bare-bones reader function is then /let r = readOneLayer proxy r in r/.
--   A poly-traversal 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'.
--
--   Technically, the type of poly-traversals encompasses all co-recursive definitions at that type.
--   Well-founded recursion cannot be guaranteed owing to the cyclical nature of data structures.
--   If one needs recursion to be well-founded, one can use 'cycReadCompoundData' -- the well-foundedness
--   then follows from the finitude of the addresses.
module Data.Columbia.CompoundData (module Data.Columbia.SeekableStream, module Data.Columbia.SeekableWriter, module Data.Columbia.RWInstances,
-- ** 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.SeekableStream
import Data.Columbia.SeekableWriter
import Data.Columbia.Integral
import Data.Columbia.Headers
import Data.Columbia.RWInstances
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
	-> (forall t3. (Data ctx t3) => PolyTraversal ctx m t3)
	-> 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
	-> (forall t3. (Data ctx t3) => PolyTraversalW ctx m t3)
	-> 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

-- | A 'PolyTraversal' is a reader method over a data type, parameterized over a method to read components.
--   Think: the targets have /wide appeal/, making it /easy to find a buyer/.
type PolyTraversal ctx m d = Proxy ctx
	-> (forall a. (Data ctx a) => ReaderT(SeekableStream m Word8) m a)
	-> ReaderT(SeekableStream m Word8) m d

-- | 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
	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 ")")
	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

-- | 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

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

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

{-# INLINE seekByTrack #-}
seekByTrack track = mapM_ seekToField track

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

{-# INLINE updateByTrack #-}
updateByTrack :: (Monad m, Data ctx d, HasField ctx RWCtx) => [Int]-> PolyTraversalW ctx m d
updateByTrack = hoistPolyTraversalW(`evalStateT`1) lift._updateByTrack