{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, Trustworthy #-}

{-
Here I document the header layout. Every entity in a file has a header attached.
The header has enough information to traverse the graph structure of data.
It is laid out as follows:

* The first bit determines whether the entity is an algebraic type. If it is
zero, the next seven bits specify the index of the constructor represented,
minus one. The next bit is a parity check bit. The seven bits following
that specify how many parameters the constructor takes, and therefore the
number of four-byte addresses in the body of the entity.

* If the first bit is one, the second bit specifies whether the entity
is a primitive type (0) or an array (1). In this case the remaining six bits
in the first byte are reserved and must be zero, and the entity follows.

* The body of a primitive type is always four bytes long.

* The body of an array consists of a four-byte length entry, followed
by that many four-byte addresses.-}
module Data.Columbia.Headers where

import Data.Bits
import Data.Word
import Data.Int
import Data.Array
import Data.Maybe
import Data.Generics.SYB.WithClass.Basics
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans
import Control.Monad.Identity
import Control.Monad
import Control.Parallel.Strategies
import Data.Columbia.RWInstances
import Data.Columbia.Integral
import Data.Columbia.FRecord

evalTriple = evalTuple3 rseq rseq rseq

parity x1 fields = (popCount x1 + popCount fields) .&. 1

readHeader :: (Monad m) => ReaderT(SeekableStream m Word8) m (Word8, ConIndex, Int)
readHeader = do
	x1 <- consumeToken
	if testBit x1 7 then
			let x = (case x1 of
				160 -> 3
				192 -> 2
				128 -> 1
				_ -> error$"readHeader: header code "++show x1++" is invalid") in
			return$!using(x, 0, 0) evalTriple
		else do
		x2 <- consumeToken
		let fields = fromIntegral x2 .&. 127
		when(testBit x2 7 /= (parity x1 fields == 1))$
			fail"readHeader: parity check error"
		return$!using(0, fromIntegral x1, fields) evalTriple

{-# INLINE enhancedFromConstr #-}
enhancedFromConstr :: forall ctx a. (Data ctx a) => Proxy ctx -> DataType -> (Word8, ConIndex, Int) -> Int -> a
enhancedFromConstr proxy0 ty hdr@(_, ix, _) l = maybe
	(runIdentity$fromConstrM proxy0(return$error"enhancedFromConstr: constr is too strict")$indexConstr ty ix)
	runIdentity
	(dataCast1 proxy0(return$listArray(1,l)$repeat$error"enhancedFromConstr: uninitialized array"))

nConstructorParameters :: forall ctx d. (Data ctx d) => Proxy ctx -> d -> Int
nConstructorParameters proxy d =
	execState(gmapM
		proxy
		(\_ -> do { modify succ; return$error"nConstructorParameters: unused" })
		d)
		0

headerFromConstr :: forall ctx d. (Data ctx d) => Proxy ctx -> d -> Constr -> (Word8, ConIndex, Int)
headerFromConstr proxy d constr = hdr where
	ty = dataTypeOf proxy d
	specimen :: d = fromConstr proxy constr
	hdr = if dataTypeName ty == "Data.Array.Unboxed.UArray" then
			(3, 0, 0)
		else if dataTypeName ty == "Data.Array.Array" then
			(2, 0, 0)
		else if not(isAlgType ty) then
			(1, 0, 0)
		else
			(0, constrIndex constr, nConstructorParameters proxy specimen) where

writeHeader :: (Monad m, Data cxt d) => Proxy cxt -> d -> ReaderT(SeekableWriter m Word8) m ()
writeHeader proxy d = do
	let (n, conIndex, nFields) = headerFromConstr proxy d(toConstr proxy d)
	case n of
		3 -> putToken 160
		2 -> putToken 192
		1 -> putToken 128
		0 -> do
			when(conIndex>127)$fail"writeCompoundData: constructor index not in range 1-127"
			putToken(fromIntegral conIndex)
			when(nFields>127)$fail"writeCompoundData: number of fields not in range 0-127"
			putToken(fromIntegral$nFields .|. shiftL(parity conIndex nFields) 7)

nFieldsBytes hdr@(_, _, nFields) = if isHeaderPrimtype hdr then
		return(0, 5)
	else if isHeaderUArraytype hdr then do
		len <- readIntegral
		return(0, 5+len)
	else if isHeaderArraytype hdr then do
		len <- readIntegral
		return(len, 5+4*len)
	else
		return(nFields, 2+4*nFields)

isHeaderUArraytype :: (Word8, ConIndex, Int) -> Bool
isHeaderUArraytype (n, _, _) = n == 3

isHeaderArraytype :: (Word8, ConIndex, Int) -> Bool
isHeaderArraytype (n, _, _) = n == 2

isHeaderPrimtype :: (Word8, ConIndex, Int) -> Bool
isHeaderPrimtype (n, _, _) = n == 1

isHeaderAlgtype :: (Word8, ConIndex, Int) -> Bool
isHeaderAlgtype (n, _, _) = n == 0