{-# LANGUAGE ConstraintKinds, ExistentialQuantification, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables, DeriveDataTypeable, TypeFamilies, StandaloneDeriving, Trustworthy #-}

-- | These strategies are for cycle detection and construction of fixed points. Cycle detection is used wherever there are
--   cycles in the reference graph implied by a Columbia file, or equivalently, if the file contains indefinitely
--   large data. It ensures that reading and writing operations terminate in the presence of such data. The reconstruction
--   of such data in a reading operation, implies that fixed points will be constructed. That way, while the reading operation
--   terminates, it does construct indefinitely large (non-terminating) data, i.e. it reconstructs the indefinitely large
--   data that was written.
--
--   The construction of cycles in the stream representation, is coordinated with the help of types that have non-trivial
--   'KeyComparable' instances. These types furnish a comparison function, that can be used to compare data structure nodes,
--   and thus detect cycles. These cycles are reflected as reference cycles in a Columbia file. Data at such types, where
--   found in a cycle can be called "loop-breakers." If the data have cycles without loop breakers, the writing process
--   will in fact not terminate, as there is no referentially transparent way (within Haskell) to detect the cycle.
module Data.Columbia.CycleDetection where

import Data.Map
import Data.Int
import Data.Word
import Data.IORef
import Data.Tree
import Data.Dynamic hiding (Proxy)
import Data.Generics.SYB.WithClass.Basics
import Data.Columbia.Internal.SeekableStream
import Data.Columbia.Internal.SeekableWriter
import Data.Columbia.Internal.IntegralTypes
import Data.Columbia.Types
import Data.Columbia.FRecord
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, ()))

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
	-- Here I'm going to assume that all data being compared have keys.
	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 Pointer 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) Pointer, 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)
				(\n->do
				writeIntegral n
				relSeekWriter(-4))
				$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

-----------------------------------

-- | A 'Pair' is a good data structures for associating a key and a value.
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

-- Some boilerplate instances
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(Array i e)
instance KeyComparable(U.UArray i e)
instance KeyComparable(Tree t)
instance KeyComparable(Map k v)
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 (Const x x2)
instance KeyComparable (Id x)