module Data.LensRef.Pure
( Register
, runRegister
, runTests
) where
import Data.Monoid
import Control.Applicative
import Control.Monad.State
import Control.Monad.Reader
import Control.Arrow (second)
import qualified Data.Sequence as Seq
import Control.Lens hiding ((|>))
import Data.Foldable (toList)
import Unsafe.Coerce
import Data.LensRef
import Data.LensRef.Common
import Data.LensRef.TestEnv
import Data.LensRef.Test
newtype instance RefWriterOf (ReaderT s m) a
= RefWriterOfReaderT { runRefWriterOfReaderT :: StateT s m a }
deriving (Monad, Applicative, Functor, MonadReader s, MonadState s)
newtype Lens_ a b = Lens_ {unLens_ :: ALens' a b}
runLens_ :: Reader a (Lens_ a b) -> Lens' a b
runLens_ r f a = cloneLens (unLens_ $ runReader r a) f a
type LSt = Seq.Seq CC
data CC = forall a . CC (LSt -> a -> a) a
initLSt :: LSt
initLSt = empty
instance MonadRefReader (Reader LSt) where
type BaseRef (Reader LSt) = Lens_ LSt
liftRefReader = id
instance Monad m => MonadRefReader (RefWriterOf (ReaderT LSt m)) where
type BaseRef (RefWriterOf (ReaderT LSt m)) = Lens_ LSt
liftRefReader = RefWriterOfReaderT . gets . runReader
instance MonadRefWriter (RefWriterOf (Reader LSt)) where
liftRefWriter = id
instance RefClass (Lens_ LSt) where
type RefReaderSimple (Lens_ LSt) = Reader LSt
readRefSimple = view . runLens_
writeRefSimple r a = runLens_ r .= a
lensMap l r = return $ Lens_ $ runLens_ r . l
unitRef = return $ Lens_ united
instance Monad m => MonadRefReader (StateT LSt m) where
type BaseRef (StateT LSt m) = Lens_ LSt
liftRefReader = gets . runReader
instance Monad m => MonadRefCreator (StateT LSt m) where
extRef r r2 a0 = state extend
where
rk = set (runLens_ r) . (^. r2)
kr = set r2 . (^. runLens_ r)
extend x0 = (return $ Lens_ $ lens get set, x0 Seq.|> CC kr (kr x0 a0))
where
limit = second toList . Seq.splitAt (Seq.length x0)
get = unsafeData . head . snd . limit
set x a = foldl (\x -> (Seq.|>) x . ap_ x) (rk a zs Seq.|> CC kr a) ys where
(zs, _ : ys) = limit x
ap_ :: LSt -> CC -> CC
ap_ x (CC f a) = CC f (f x a)
unsafeData :: CC -> a
unsafeData (CC _ a) = unsafeCoerce a
instance Monad m => MonadMemo (StateT LSt m) where
memoRead = memoRead_
instance Monad m => MonadRefWriter (StateT LSt m) where
liftRefWriter = state . runState . runRefWriterOfReaderT
type Register_ m
= ReaderT (Ref m (MonadMonoid m, RegionStatusChange -> MonadMonoid m)) m
type RegRef m
= Ref m (MonadMonoid m, RegionStatusChange -> MonadMonoid m)
newtype Register n a
= Register { unRegister :: ReaderT (SLSt n () -> n (), RegRef (SLSt n)) (SLSt n) a }
deriving (Monad, Applicative, Functor)
type SLSt = StateT LSt
instance MonadTrans Register where
lift = Register . lift . lift
instance MonadFix m => MonadFix (Register m) where
mfix f = Register $ mfix $ unRegister . f
instance Monad m => MonadRefReader (Register m) where
type BaseRef (Register m) = Lens_ LSt
liftRefReader = Register . lift . liftRefReader
instance Monad n => MonadRefCreator (Register n) where
extRef r l = Register . lift . extRef r l
newRef = Register . lift . newRef
instance Monad m => MonadMemo (Register m) where
memoRead = memoRead_
instance Monad n => MonadRefWriter (Register n) where
liftRefWriter = Register . lift . liftRefWriter
instance Monad n => MonadRegister (Register n) where
type EffectM (Register n) = n
liftEffectM = lift
type Modifier (Register n) = Register n
liftToModifier = id
onChange r f = onChangeAcc r undefined undefined $ \b _ _ -> liftM const $ f b
registerCallback f = Register $ do
st <- ask
return $ fmap (fst st . evalRegister st) f
onRegionStatusChange g = Register $ do
st <- ask
magnify _2 $ tell' (mempty, MonadMonoid . evalRegister st . g)
evalRegister' ff (Register m) = ReaderT $ \s -> runReaderT m (ff, s)
evalRegister ff (Register m) = runReaderT m ff
runRegister :: Monad m => (forall a . m (m a, a -> m ())) -> Register m a -> m (a, m ())
runRegister newChan m = do
(read, write) <- newChan
runRegister_ read write m
runRegister_ :: Monad m => m (SLSt m ()) -> (SLSt m () -> m ()) -> Register m a -> m (a, m ())
runRegister_ read write (Register m) = do
((a, tick), s) <- flip runStateT initLSt $ do
r <- newRef mempty
a <- runReaderT m (write, r)
(w, _) <- readRef r
return (a, runMonadMonoid w)
let eval s = flip evalStateT s $ forever $ do
join $ lift read
tick
return $ (,) a $ eval s
onChangeAcc r b0 c0 f = Register $ do
ff <- asks fst
magnify _2 $ toSend r b0 c0 $ \b b' c' -> liftM (\x -> evalRegister' ff . x) $ evalRegister' ff $ f b b' c'
toSend
:: (Eq b, MonadRefCreator m, MonadRefWriter m)
=> RefReader m b
-> b -> (b -> c)
-> (b -> b -> c -> Register_ m (c -> Register_ m c))
-> Register_ m (RefReader m c)
toSend rb b0 c0 fb = do
let doit st = readRef st >>= runMonadMonoid . fst
reg st msg = readRef st >>= runMonadMonoid . ($ msg) . snd
memoref <- lift $ do
b <- liftRefReader rb
(c, st1) <- runRefWriterT $ fb b b0 $ c0 b0
(val, st2) <- runRefWriterT $ c $ c0 b0
doit st1
doit st2
newRef ((b, (c, val, st1, st2)), [])
let act = MonadMonoid $ do
b <- liftRefReader rb
(last@(b', cc@(_, oldval, st1, st2)), memo) <- readRef memoref
(_, _, st1, st2) <- if b' == b
then
return cc
else do
reg st1 Block
reg st2 Kill
(c, oldval', st1, _) <- case lookup b memo of
Nothing -> do
(c, st1) <- runRefWriterT $ fb b b' oldval
return (c, c0 b, st1, undefined)
Just cc'@(_, _, st1, _) -> do
reg st1 Unblock
return cc'
(val, st2) <- runRefWriterT $ c oldval'
let cc = (c, val, st1, st2)
writeRef memoref ((b, cc), filter ((/= b) . fst) (last:memo))
return cc
doit st1
doit st2
tell' (act, mempty)
return $ readRef $ (_1 . _2 . _2) `lensMap` memoref
instance MonadRegisterRun (Register (Prog TP)) where
type AsocT (Register (Prog TP)) = TP
runReg r w m = runRegister_ (liftM unTP r) (w . TP) m
newtype TP = TP { unTP :: SLSt (Prog TP) () }
runTests = do
mkTests runTestSimple
tests runTest
runTest :: (Eq a, Show a) => String -> Register (Prog TP) a -> Prog' (a, Prog' ()) -> IO ()
runTest name m p = do
runTest_ name (TP . lift) runReg m p
runTestSimple :: Register (Prog TP) () -> IO ()
runTestSimple m = runTest "" m $ return ((), return ())