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 WithAddress t = WithAddress Word32 t
| Address Word32
| Data t
deriving (Read, Show, Typeable, Functor)
addressOf :: WithAddress t -> Word32
addressOf(WithAddress n _) = n
addressOf(Address n) = n
addressOf(Data _) = maxBound
dataOf :: WithAddress t -> t
dataOf (WithAddress _ x) = x
dataOf (Address _) = error"dataOf: Address"
dataOf (Data x) = x
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)
instance KeyComparable(WithAddress t) where
isKeyed (Data _) = False
isKeyed _ = True
keyCompare = compare `on` addressOf
withAddresses :: forall ctx m d. (Data ctx d, Monad m) => 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 }
writeBackAddresses :: forall ctx m d. (Data ctx d, Monad m) => 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