WithAddress.hs

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

module Data.Columbia.WithAddress where

import Data.Word
import Data.Function
import Data.Generics.SYB.WithClass.Basics
import Generics.Pointless.Functors hiding (Functor)
import Control.Monad
import Control.Monad.Reader
import Data.Columbia.CompoundData
import Data.Columbia.CycleDetection
import Data.Columbia.FRecord

-- | Data type for a piece of data that may or may not have an explicit address associated with it.
--   This is nice because I can play with these in pure code to manipulate data, while still
--   remembering all of the explicit term structure.
data WithAddress t = WithAddress Word32 t
	| Address Word32 -- The address only.
	| Data t
	deriving (Read, Show, Typeable, Functor)

addressOf :: WithAddress t -> Word32
addressOf(WithAddress n _) = n
addressOf(Address n) = n
addressOf(Data _) = maxBound -- This has to be non-zero because reasons.

dataOf :: WithAddress t -> t
dataOf (WithAddress _ x) = x
dataOf (Address _) = error"dataOf: Address"
dataOf (Data x) = x

-- | A null address object.
nullAddress = Address$!0

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
	gfoldl _ o k (Address n) = k Address `o` n
	gfoldl _ o k (Data x) = k Data `o` x
	gunfold _ f k constr = case constrIndex constr of
		1 -> f(f(k WithAddress))
		2 -> f(k Address)
		3 -> f(k Data)
		_ -> error"gunfold for WithAddress: invalid constructor"
	dataTypeOf proxy _ =
		let ty = DataType "Data.Columbia.WithAddresses.WithAddress" (AlgRep[
			Constr(AlgConstr 1) "WithAddress" [] Prefix ty,
			Constr(AlgConstr 2) "Address" [] Prefix ty,
			Constr(AlgConstr 3) "Data" [] Prefix ty]) in
			ty
	toConstr proxy x@(WithAddress _ _) = case dataTypeOf proxy x of
		DataType _(AlgRep[c,_,_]) -> c
	toConstr proxy x@(Address _) = case dataTypeOf proxy x of
		DataType _(AlgRep[_,c,_]) -> c
	toConstr proxy x@(Data _) = case dataTypeOf proxy x of
		DataType _(AlgRep[_,_,c]) -> c
	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 (Data _) = 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 (unless you do something heroic with your own locking pattern).
withAddresses :: forall ctx m d. (Data ctx d, Monad m) => Proxy ctx -> PolyTraversal ctx m d
withAddresses proxy m = case dataCast1 proxy(do
	n <- getPosition
	if n == 0 then
			return$!Address$!0
		else
			liftM(WithAddress n) m) of
	Just m2 -> m2
	Nothing -> m

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

-- | 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. The term structure of 'WithAddress' constructor itself
--   never ends up in the file.
writeBackAddresses ::  forall ctx m d. (Data ctx d, Monad m) => Proxy ctx -> PolyTraversalW ctx m d
writeBackAddresses proxy f d = case dataCast1 proxy(Fl$ \d2 -> case d2 of
		WithAddress n _ -> return n
		Address n -> return n
		Data x -> f x) of
	Just fl -> unFl fl d
	Nothing -> f d