{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, DeriveDataTypeable, ScopedTypeVariables, Trustworthy #-}

module Data.Columbia.WithAddress (WithAddress, copoint, point, addressOf, dataOf, withAddresses, writeBackAddresses) where

import Data.Word
import Data.Function
import Data.Generics.SYB.WithClass.Basics
import Data.Generics.SYB.WithClass.Instances
import Generics.Pointless.Functors hiding (Functor)
import Control.Monad
import Control.Monad.Reader
import Data.Columbia.Types
import Data.Columbia.Internal.SeekableStream
import Data.Columbia.Internal.IntegralTypes
import Data.Columbia.FRecord

{-# INLINE copoint #-}
copoint(WithAddress _ x) = x

{-# INLINE point #-}
point = WithAddress 0 -- Null address indicates that no address is known.

{-# INLINE addressOf #-}
addressOf :: WithAddress t -> Word32
addressOf(WithAddress n _) = n

{-# INLINE dataOf #-}
dataOf :: WithAddress t -> t
dataOf = copoint

instance (Sat(ctx Word32), Sat(ctx(WithAddress t)), Data ctx t) => Data ctx(WithAddress t) where
	gfoldl _ o k (WithAddress n x) = k WithAddress `o` n `o` x
	gunfold _ f k _ = f(f(k WithAddress))
	dataTypeOf proxy _ =
		let ty = DataType "Data.Columbia.WithAddresses.WithAddress" (AlgRep[
			Constr(AlgConstr 1) "WithAddress" [] Prefix ty]) in
			ty
	toConstr proxy x = case dataTypeOf proxy x of
		DataType _(AlgRep ls) -> head ls
	dataCast1 _ f = gcast1 f

instance (Typeable t) => RW(WithAddress t)

-- Addresses (file offsets) can serve as keys for purposes of cycle detection.
instance KeyComparable(WithAddress t) where
	isKeyed (WithAddress 0 _) = False
	isKeyed _ = True
	keyCompare = compare `on` addressOf

-- | The strategy reads term structure from a file and associates file addresses with it.
--   Bear in mind that the addresses become no good at the moment your reader lock is
--   relinquished, due to GC'ing.
withAddresses :: forall ctx m d. (Data ctx d, Monad m) => PolyTraversal ctx m d
withAddresses proxy m = case dataCast1 proxy(do
	addr <- readIntegral
	relSeek(-4)
	liftM(WithAddress addr) m) of
	Just m2 -> m2
	Nothing -> m

newtype Fl m t = Fl { unFl :: t -> ReaderT(SeekableWriter m Word8) m () }

-- | A strategy to intelligently reconstruct shared structure on disk. It intercepts any subterm with
--   type 'WithAddress' and that associates an address to the data, and writes that address
--   in lieu of writing all of the data, thereby achieving structural sharing. Note that the term
--   structure of 'WithAddress' constructor is skipped and does not get written.
writeBackAddresses ::  forall ctx m d. (Data ctx d, Monad m) => PolyTraversalW ctx m d
writeBackAddresses proxy f d = case dataCast1 proxy(Fl$ \d2 -> if addressOf d2==0 then f$dataOf d2 else writeIntegral$addressOf d2) of
	Just fl -> unFl fl d
	Nothing -> f d