CompoundData.hs

{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, ScopedTypeVariables, TypeOperators, Rank2Types, AllowAmbiguousTypes, 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,
-- ** Compound data read/write strategies
RW(..), RWCtx(..), PolyTraversal, readOneLayer, PolyTraversalW, writeOneLayer, seekToField) 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
import Data.Columbia.SeekableStream
import Data.Columbia.SeekableWriter
import Data.Columbia.Integral
import Data.Columbia.Headers
import Data.Columbia.RWInstances
import Data.Columbia.FRecord

infixl 9 #.
infixl 9 ##.

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

(##.) :: (Data ctx t)
	=> PolyTraversalW ctx m t
	-> (forall t2. (Data ctx t2) => PolyTraversalW ctx m t2)
	-> PolyTraversalW ctx m t
(traversal ##. traversal2) f = traversal(traversal2 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(fixT proxy traversal)

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

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

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

readAddresses :: forall ctx m a. (Monad m, HasField ctx RWCtx, Sat(ctx a))
	=> Proxy ctx
	-> WriterT[Word32] (ReaderT(SeekableStream m Word8) m) a
readAddresses _ = case hasField(dict :: ctx a) of
	RWCtx -> do
		x <- lift readIntegral
		tell[x]
		return$error"readAddresses: unused"

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:xs) <- get
	put xs
	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 = (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)
	=> Proxy ctx
	-> PolyTraversal ctx m d
readOneLayer proxy0 m = do
	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
			(_ :: d, ls) <- runWriterT(gmapM
				proxy0
				(\_ -> readAddresses proxy0)
				specimen2)
			-- Construct a 'PolyTraversal' that reads the sub-components.
			evalStateT
				(gmapM
				proxy0
				(\_ -> recursor m proxy0)
				specimen2)
				ls
		else
		-- Fall back on a primitive reader method if one is defined.
		case hasField(dict :: ctx d) of
			RWCtx -> readData

recursorW :: forall ctx m a. (Monad m, HasField ctx RWCtx, Data(ctx) a)
	=> (a -> ReaderT(SeekableWriter m Word8) m Word32)
	-> Proxy ctx -> a -> StateT Word32(ReaderT(SeekableWriter m Word8) m) a
recursorW rec proxy d = do
	lift seekWriterAtEnd
	x <- lift$rec d
	n <- get
	put$!n+4
	lift$do
		seekWriter n
		writeIntegral x
	return$error"recursorW: unused"

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

-- | 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) => Proxy ctx -> PolyTraversalW ctx m d
writeOneLayer proxy0 f d = do
	let ty = dataTypeOf proxy0 d
	m <- getWriterPosition
	if isAlgType ty || dataTypeName ty == "Data.Array.Array" then do
			writeHeader proxy0 d
			n <- getWriterPosition
			sequence_(replicate(nConstructorParameters proxy0 d) (writeIntegral(0::Word32)))
			evalStateT(gmapM proxy0
				(recursorW f proxy0)
				d)
				n
			return m
		else case hasField(dict :: ctx d) of
			RWCtx -> do
				writeHeader proxy0 d
				writeData d
				return m

seekToField :: forall m. (Monad m) => Int -> ReaderT(SeekableStream m Word8) m ()
seekToField ix = do
	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
	seekByPointer