module Data.Columbia.CycleDetection where
import Data.Map
import Data.Set (Set)
import Data.Int
import Data.Word
import Data.IORef
import Data.Dynamic hiding (Proxy)
import Data.Generics.SYB.WithClass.Basics
import Data.Columbia.CompoundData
import Data.Columbia.FRecord
import Data.Columbia.Orphans
import Data.Columbia.Integral
import Data.Columbia.DynamicWithCtx
import Generics.Pointless.Functors
import Generics.Pointless.Combinators
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Fix
import Prelude hiding (lookup)
import Data.Array
import qualified Data.Array.Unboxed as U
class (Monad m) => StateM m where
type StateOf m :: *
mfy' :: (StateOf m -> (StateOf m, a)) -> m a
instance (Monad m) => StateM(StateT s m) where
type StateOf(StateT s m) = s
mfy' f = get>>= \s -> let(s', x) = f s in (put$!s')>>return x
instance StateM(ReaderT(IORef s) IO) where
type StateOf(ReaderT(IORef s) IO) = s
mfy' f = ask>>=lift.(`atomicModifyIORef'` f)
get' :: (StateM m) => m(StateOf m)
get' = mfy'(\s -> (s, s))
put' s = mfy'(\_ -> (s, ()))
class KeyComparable t where
isKeyed :: t->Bool
isKeyed _ = False
keyCompare :: t -> t->Ordering
keyCompare _ _ = error"KeyComparable.keyCompare: is not a keyed data type"
data KeyCtx t = (KeyComparable t) => KeyCtx
instance (KeyComparable t) => Sat(KeyCtx t) where dict = KeyCtx
instance Eq(DynamicWithCtx Eq) where
DynamicWithCtx x == DynamicWithCtx x2 = maybe False(==x2) (cast x)
instance KeyComparable(DynamicWithCtx KeyComparable) where
isKeyed(DynamicWithCtx x) = isKeyed x
keyCompare(DynamicWithCtx x) (DynamicWithCtx x2) = maybe(compare(typeOf x) (typeOf x2)) (`keyCompare` x2) (cast x)
instance Ord(DynamicWithCtx KeyComparable) where
compare = keyCompare
instance Eq(DynamicWithCtx KeyComparable) where
(==) d = (==EQ).keyCompare d
type CycleDetectionR m = StateT(Map Word32 Dynamic) m
type CycleDetectionW m = StateT(Map(DynamicWithCtx KeyComparable) Word32) m
type CycleDetectionRIO = ReaderT(IORef(Map Word32 Dynamic)) IO
type CycleDetectionWIO = ReaderT(IORef(Map(DynamicWithCtx KeyComparable) Word32)) IO
cycleDetect :: forall ctx m t. (MonadFix m, StateM m, StateOf m ~ Map Word32 Dynamic, HasField ctx RWCtx, Data ctx t)
=> PolyTraversal ctx m t
cycleDetect proxy m =
readIntegral>>= \n->
relSeek(4)>>
lift get'>>=
maybe
(mfix(\x -> do
lift$mfy'(\mp -> (insert n(toDyn x) mp, ()))
m))
(maybe
(fail$"cycleDetect: type mismatch")
return
.fromDynamic)
.lookup n
cycleDetectW :: forall ctx m t. (StateM m, StateOf m ~ Map(DynamicWithCtx KeyComparable) Word32, HasField ctx RWCtx, HasField ctx KeyCtx, Data ctx t)
=> PolyTraversalW ctx m t
cycleDetectW proxy f x =
case hasField(dict :: ctx t) :: KeyCtx t of
KeyCtx ->
let d = dynamicWithCtx x in
lift get'>>= \mp->
maybe
(do
n <- getWriterPosition
seekWriterAtEnd
addr <- getWriterPosition
seekWriter n
when(isKeyed d)$lift$put'$insert d addr mp
f x)
writeIntegral
$lookup d mp
runCycleDetectionR :: (Monad m)
=> ReaderT(SeekableStream(CycleDetectionR m) Word8) (CycleDetectionR m) t
-> ReaderT(SeekableStream m Word8) m t
runCycleDetectionR m = do
s <- ask
lift$evalStateT(runReaderT m(hoistStream lift s)) empty
runCycleDetectionW :: (Monad m)
=> ReaderT(SeekableWriter(CycleDetectionW m) Word8) (CycleDetectionW m) t
-> ReaderT(SeekableWriter m Word8) m t
runCycleDetectionW m = do
sw <- ask
lift$evalStateT(runReaderT m(hoistWriter lift sw)) empty
data Pair k v = Pair k v deriving (Read, Show, Typeable, Eq, Ord)
instance (Ord k) => KeyComparable(Pair k v) where
isKeyed _ = True
keyCompare(Pair k _) (Pair k2 _) = compare k k2
pairCtor = Constr(AlgConstr 1) "Pair" [] Prefix pairDataType
pairDataType = DataType "Data.Columbia.CycleDetection"(AlgRep[pairCtor])
instance (Sat(ctx(Pair k v)), Data ctx k, Data ctx v) => Data ctx(Pair k v) where
gfoldl _ o f (Pair k v) = f Pair `o` k `o` v
gunfold _ k f _ = k(k(f Pair))
dataTypeOf _ _ = pairDataType
toConstr _ _ = pairCtor
dataCast2 _ f = gcast2 f
instance (Typeable k, Typeable v) => RW(Pair k v)
type instance Rep(Pair k) v = Pair k v
instance ToRep(Pair k) where
rep = id
unrep _ _ = id
val _ = ann
fun _ = ann
instance KeyComparable(t1,t2)
instance KeyComparable(t1,t2,t3)
instance KeyComparable(t1,t2,t3,t4)
instance KeyComparable(t1,t2,t3,t4,t5)
instance KeyComparable(Either t t2)
instance KeyComparable(Maybe t)
instance KeyComparable[t]
instance KeyComparable(Map t u)
instance KeyComparable(Set t)
instance KeyComparable(Array i e)
instance KeyComparable(U.UArray i e)
instance KeyComparable Int
instance KeyComparable Word
instance KeyComparable Int8
instance KeyComparable Word8
instance KeyComparable Int16
instance KeyComparable Word16
instance KeyComparable Int32
instance KeyComparable Word32
instance KeyComparable Int64
instance KeyComparable Word64
instance KeyComparable Float
instance KeyComparable Char
instance KeyComparable Ordering
instance KeyComparable Bool
instance KeyComparable ()
instance KeyComparable ((:+:) f g x)
instance KeyComparable ((:*:) f g x)
instance KeyComparable ((:@:) f g x)
instance KeyComparable (Fix f)
instance KeyComparable (LazyFix f)
instance KeyComparable (Const x x2)
instance KeyComparable (Id x)