lensref (empty) → 0.1
raw patch · 10 files changed
+1982/−0 lines, 10 filesdep +basedep +containersdep +lenssetup-changed
Dependencies added: base, containers, lens, monad-control, mtl, operational, transformers
Files
- LICENSE +31/−0
- Setup.hs +2/−0
- lensref.cabal +84/−0
- src/Data/LensRef.hs +381/−0
- src/Data/LensRef/Common.hs +115/−0
- src/Data/LensRef/Default.hs +15/−0
- src/Data/LensRef/Fast.hs +311/−0
- src/Data/LensRef/Pure.hs +274/−0
- src/Data/LensRef/Test.hs +501/−0
- src/Data/LensRef/TestEnv.hs +268/−0
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright Péter Diviánszky 2013-2014++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Péter Diviánszky nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ lensref.cabal view
@@ -0,0 +1,84 @@+name: lensref+version: 0.1+category: Control, Data+synopsis: References which can be joined and on which lenses can be applied+description:+ The lensref package provides and interface an two implementation+ for references which can be joined and on which lenses can be applied.+ .+ * The pure implementation is slow and has memory leaks but probably easier to follow.+ This is the reference implementation, so if the the other implementation+ differs this has the right behaviour.+ * The fast implementation is intended for real usage.+ .+ Status:+ .+ * The interface is getting stable. You can expect more functionality and minor changes on current functionality.+ * There are test cases for the first half of the interface.+ Both implementations fulfil the test cases.+ * The pure implementation is ready.+ * The fast implementation is much faster than the pure implementation,+ but it is far from being as fast as possible.+ Probably it also leaks memory.+ .+ To see what is possible to do with lens references, look at the test cases in "Data.LensRef.Test"+ .+ For more information visit the following links:+ .+ * <http://www.haskell.org/haskellwiki/LGtk haskell.org wiki page>+ * <http://lgtk.wordpress.com/ Wordpress blog>+ * <https://github.com/divipp/lensref GitHub repository>+ * <http://hackage.haskell.org/package/lensref Haddock documentation (this page)>+stability: experimental+license: BSD3+license-file: LICENSE+author: Péter Diviánszky+homepage: http://www.haskell.org/haskellwiki/LGtk+bug-reports: https://github.com/divipp/lensref/issues+maintainer: divipp@gmail.com+cabal-version: >= 1.8+build-type: Simple++source-repository head+ type: git+ location: https://github.com/divipp/lensref.git++Flag Pure+ Description: Use the pure but slow implementation+ Default: False+++library++ hs-source-dirs:+ src+ build-depends:+ base < 5+ , transformers >= 0.3 && < 0.5+ , mtl >= 2 && < 2.3+ , monad-control == 0.3.*+ , operational == 0.2.*+ , lens == 4.1.*+ , containers == 0.5.*++ exposed-modules:+ Data.LensRef+ Data.LensRef.Common+ Data.LensRef.TestEnv+ Data.LensRef.Test+ Data.LensRef.Pure+ Data.LensRef.Fast+ Data.LensRef.Default+ if flag(Pure)+ cpp-options:+ -D__PURE__++ ghc-options: + -threaded+ -Wall + -fno-warn-incomplete-patterns + -fno-warn-name-shadowing + -fno-warn-missing-signatures + -fno-warn-orphans+ -fno-warn-type-defaults+
+ src/Data/LensRef.hs view
@@ -0,0 +1,381 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_HADDOCK prune #-}+module Data.LensRef+ (+ -- * Core++ -- ** References+ RefClass (..)+ , RefSimple+ , RefWriterOf+ , RefWriterSimple++ , MonadRefReader (..)+ , MonadRefWriter (..)++ -- ** Reference creation+ , MonadRefCreator (..)+ , Ref+ , RefReader+ , RefWriter++ -- ** Dynamic networks+ , MonadRegister (..)+ , RegionStatusChange (..)++ -- ** Other+ , MonadMemo (..)++ -- * Derived constructs+ , modRef+ , postponeModification+-- , undoTr++ , EqRefClass (..)+ , EqRefSimple, EqRef+ , hasEffect+ , toEqRef+ , fromEqRef+ , newEqRef+{-+ , CorrRef+ , corrRef+ , fromCorrRef+ , correction+-}+ ) where+++import Control.Monad+import Control.Monad.Identity+import Control.Lens (Lens', set, united)++--------------------------------+++{- |+Type class for references which can be joined and on which lenses can be applied.++The join operation is 'join' from "Control.Monad":+If @(r :: RefReaderSimple r (RefSimple r a))@ then @(join r :: RefSimple r a)@.+This is possible because reference operations work with @(RefReaderSimple r (r a))@ instead+of just @(r a)@. For more compact type signatures, @(RefReaderSimple r (r a))@ is called @(RefSimple r a)@.+-}+class (MonadRefWriter (RefWriterSimple r), MonadRefReader (RefReaderSimple r), RefReader (RefReaderSimple r) ~ RefReaderSimple r) => RefClass r where++ {- | unit reference+ -}+ unitRef :: RefSimple r ()++ {- | Apply a lens on a reference.+ -}+ lensMap :: Lens' a b -> RefSimple r a -> RefSimple r b++ {- | Associated reference reader monad.++ @(RefReaderSimple m)@ is ismoroprhic to @('Reader' x)@ for some @x@.+ Laws which ensures this isomorphism (@(r :: RefReaderSimple m a)@ is arbitrary):++ prop> r >> return () = return ()+ prop> liftM2 (,) r r = liftM (\a -> (a, a)) r++ See also <http://stackoverflow.com/questions/16123588/what-is-this-special-functor-structure-called>+ -}+ type RefReaderSimple r :: * -> *++ {- | Reference read.+ -}+ readRefSimple :: RefSimple r a -> RefReaderSimple r a++ {- | Reference write.+ -}+ writeRefSimple :: RefSimple r a -> a -> RefWriterSimple r ()++data family RefWriterOf (m :: * -> *) a :: *++{- |+There are two associated types of a reference, 'RefReaderSimple' and 'RefWriterSimple' which determines each-other.+This is implemented by putting only 'RefReaderSimple' into the 'RefClass' class and+adding a @RefWriterOf@ data family outside of 'RefClass'.++@RefWriterOf@ is hidden from the documentation because you never need it explicitly.+-}+type RefWriterSimple m = RefWriterOf (RefReaderSimple m)++-- | Reference wrapped into a RefReaderSimple monad. See the documentation of 'RefClass'.+type RefSimple r a = RefReaderSimple r (r a)++infixr 8 `lensMap`++-- | TODO+class Monad m => MonadRefReader m where++ -- | Base reference associated to the reference reader monad+ type BaseRef m :: * -> *++ liftRefReader :: RefReader m a -> m a++ {- | @readRef@ === @liftRefReader . readRefSimple@+ -}+ readRef :: (RefClass r, RefReader m ~ RefReaderSimple r) => RefSimple r a -> m a+ readRef = liftRefReader . readRefSimple+++-- | TODO+type RefReader m = RefReaderSimple (BaseRef m)++-- | TODO+type RefWriter m = RefWriterSimple (BaseRef m)++-- | TODO+type Ref m a = RefSimple (BaseRef m) a++++-- | TODO+class MonadRefReader m => MonadRefWriter m where++ liftRefWriter :: RefWriter m a -> m a++ {- | @writeRef r@ === @liftRefWriter . writeRefSimple r@+ -}+ writeRef :: (RefClass r, RefReaderSimple r ~ RefReader m) => RefSimple r a -> a -> m ()+ writeRef r = liftRefWriter . writeRefSimple r+++++{- | Monad for reference creation. Reference creation is not a method+of the 'RefClass' type class to make possible to+create the same type of references in multiple monads.++For basic usage examples, look into the source of @Data.LensRef.Test@.+-}+class (Monad m, RefClass (BaseRef m), MonadRefReader m, MonadMemo m) => MonadRefCreator m where++ {- | Reference creation by extending the state of an existing reference.++ Suppose that @r@ is a reference and @k@ is a lens.++ Law 1: @extRef@ applies @k@ on @r@ backwards, i.e. + the result of @(extRef r k a0)@ should behaves exactly as @(lensMap k r)@.++ prop> (liftM (k .) $ extRef r k a0) = return r++ Law 2: @extRef@ does not change the value of @r@:++ prop> (extRef r k a0 >> readRef r) = readRef r++ Law 3: Proper initialization of newly defined reference with @a0@:++ prop> (extRef r k a0 >>= readRef) = (readRef r >>= set k a0)+ -}+ extRef :: Ref m b -> Lens' a b -> a -> m (Ref m a)++ {- | @newRef@ extends the state @s@ in an independent way.++ @newRef@ === @extRef unitRef united@+ -}+ newRef :: a -> m (Ref m a)+ newRef = extRef unitRef united+++-- | TODO+class Monad m => MonadMemo m where+ {- | Lazy monadic evaluation.+ In case of @y <- memoRead x@, invoking @y@ will invoke @x@ at most once.++ Laws:++ * @(memoRead x >> return ())@ === @return ()@++ * @(memoRead x >>= id)@ === @x@++ * @(memoRead x >>= \y -> liftM2 (,) y y)@ === @liftM (\a -> (a, a)) y@++ * @(memoRead x >>= \y -> liftM3 (,) y y y)@ === @liftM (\a -> (a, a, a)) y@++ * ...+ -}+ memoRead :: m a -> m (m a)+{-+ memoWrite :: Eq b => (b -> m a) -> m (b -> m a)++ future :: (RefReader m a -> m a) -> m a+-}++-- | Monad for dynamic actions+class (MonadRefCreator m, MonadRefWriter (Modifier m), MonadRefCreator (Modifier m), BaseRef (Modifier m) ~ BaseRef m, Monad (EffectM m),+ {- MonadRegister (Modifier m), -}EffectM (Modifier m) ~ EffectM m, Modifier (Modifier m) ~ Modifier m)+ => MonadRegister m where+{-+ onChangeAcc+ :: Eq b+ => RefReader m b+ -> b -> (b -> c)+ -> (b -> b -> c -> m (c -> m c))+ -> m (RefReader m c)+-}+ onChange :: Eq a => RefReader m a -> (a -> m (m b)) -> m (RefReader m b)+-- onChange r f = onChangeAcc r undefined undefined $ \b _ _ -> liftM const $ f b++ onChangeSimple :: Eq a => RefReader m a -> (a -> m b) -> m (RefReader m b)+ onChangeSimple r f = onChange r $ return . f++ onRegionStatusChange :: (RegionStatusChange -> m ()) -> m ()+++ type EffectM m :: * -> *++ liftEffectM :: EffectM m a -> m a++ type Modifier m :: * -> *++ liftToModifier :: m a -> Modifier m a++ registerCallback :: Functor f => f (Modifier m ()) -> m (f (EffectM m ()))++-- unliftEffectM :: Functor f => f (m ()) -> m (f (EffectM m ()))+-- registerCallback_ :: Functor f => f (Modifier m ()) -> m (f (m ()))+-- registerCallback = registerCallback_ >=> unliftEffectM+++-- | TODO+data RegionStatusChange = Kill | Block | Unblock deriving (Eq, Ord, Show)++++++-------------- derived constructs++-- | TODO+postponeModification :: MonadRegister m => Modifier m () -> m ()+postponeModification = liftEffectM . runIdentity <=< registerCallback . Identity+++-- | @modRef r f@ === @readRef r >>= writeRef r . f@+modRef :: (MonadRefWriter m, RefClass r, RefReaderSimple r ~ RefReader m) => RefSimple r a -> (a -> a) -> m ()+r `modRef` f = readRef r >>= writeRef r . f++++++{- | Reference with inherent equivalence.++-}+class RefClass r => EqRefClass r where+ valueIsChanging :: RefSimple r a -> RefReaderSimple r (a -> Bool)++{- | @hasEffect r f@ returns @False@ iff @(modRef m f)@ === @(return ())@.++@hasEffect@ is correct only if @toEqRef@ is applied on a pure reference (a reference which is a pure lens on the hidden state).++@hasEffect@ makes defining auto-sensitive buttons easier, for example.+-}+hasEffect+ :: EqRefClass r+ => RefSimple r a+ -> (a -> a)+ -> RefReaderSimple r Bool+hasEffect r f = do+ a <- readRef r+ ch <- valueIsChanging r+ return $ ch $ f a+++-- | TODO+data EqRefCore r a = EqRefCore (r a) (a -> Bool{-changed-})++{- | RefClasss with inherent equivalence.++@EqRefSimple r a@ === @RefReaderSimple r (exist b . Eq b => (Lens' b a, r b))@++As a reference, @(m :: EqRefSimple r a)@ behaves as++@join $ liftM (uncurry lensMap) m@+-}+type EqRefSimple r a = RefReaderSimple r (EqRefCore r a)++-- | TODO+type EqRef m a = EqRefSimple (BaseRef m) a++{- | @EqRefSimple@ construction.+-}+toEqRef :: (RefClass r, Eq a) => RefSimple r a -> EqRefSimple r a+toEqRef r = do+ a <- readRef r+ r_ <- r+ return $ EqRefCore r_ (/= a)++-- | TODO+newEqRef :: (MonadRefCreator m, Eq a) => a -> m (EqRef m a) +newEqRef = liftM toEqRef . newRef++{- | An @EqRefSimple@ is a normal reference if we forget about the equality.++@fromEqRef m@ === @join $ liftM (uncurry lensMap) m@+-}+fromEqRef :: RefClass r => EqRefSimple r a -> RefSimple r a+fromEqRef m = m >>= \(EqRefCore r _) -> return r++instance RefClass r => EqRefClass (EqRefCore r) where+ valueIsChanging m = do+ EqRefCore _r k <- m+ return k++instance RefClass r => RefClass (EqRefCore r) where++ type (RefReaderSimple (EqRefCore r)) = RefReaderSimple r++ readRefSimple = readRef . fromEqRef++ writeRefSimple = writeRefSimple . fromEqRef++ lensMap l m = do+ a <- readRef m+ EqRefCore r k <- m+ lr <- lensMap l $ return r+ return $ EqRefCore lr $ \b -> k $ set l b a++ unitRef = toEqRef unitRef++{-+data CorrBaseRef r a = CorrBaseRef (r a) (a -> Maybe a{-corrected-})++type CorrRef r a = RefReaderSimple r (CorrBaseRef r a)++instance RefClass r => RefClass (CorrBaseRef r) where++ type (RefReaderSimple (CorrBaseRef r)) = RefReaderSimple r++ readRef = readRef . fromCorrRef++ writeRefSimple = writeRefSimple . fromCorrRef++ lensMap l m = do+ a <- readRef m+ CorrBaseRef r k <- m+ lr <- lensMap l $ return r+ return $ CorrBaseRef lr $ \b -> fmap (^. l) $ k $ set l b a++ unitRef = corrRef (const Nothing) unitRef++fromCorrRef :: RefClass r => CorrRef r a -> RefSimple r a+fromCorrRef m = m >>= \(CorrBaseRef r _) -> return r++corrRef :: RefClass r => (a -> Maybe a) -> RefSimple r a -> CorrRef r a+corrRef f r = do+ r_ <- r+ return $ CorrBaseRef r_ f++correction :: RefClass r => CorrRef r a -> RefReaderSimple r (a -> Maybe a)+correction r = do+ CorrBaseRef _ f <- r+ return f+-}++
+ src/Data/LensRef/Common.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_HADDOCK hide #-}+module Data.LensRef.Common where++import Data.Monoid+import Control.Concurrent+import Control.Monad.State+import Control.Monad.Writer+import Control.Monad.Reader++import Data.LensRef++----------------++-- Ref-based WriterT+type RefWriterT w m = ReaderT (Ref m w) m++runRefWriterT :: (MonadRefCreator m, Monoid w) => RefWriterT w m a -> m (a, Ref m w)+runRefWriterT m = do+ r <- newRef mempty+ a <- runReaderT m r+ return (a, r)++tell' :: (Monoid w, MonadRefCreator m, MonadRefWriter m) => w -> RefWriterT w m ()+tell' w = ReaderT $ \m -> modRef m (`mappend` w)++-------------++newtype MonadMonoid a = MonadMonoid { runMonadMonoid :: a () }++instance Monad m => Monoid (MonadMonoid m) where+ mempty = MonadMonoid $ return ()+ MonadMonoid a `mappend` MonadMonoid b = MonadMonoid $ a >> b+++------------------------++newtype Morph m n = Morph { runMorph :: forall a . m a -> n a }++type SRef m a = Morph (StateT a m) m++class Monad m => NewRef m where+ newRef' :: a -> m (SRef m a)+{-+instance Monad m => NewRef (StateT LSt m) where+ newRef' x = do+ v <- newRef x+ return $ Morph $ \m -> do+ x <- readRef v+ (y, x) <- runStateT m x+ writeRef v x+ return y+-}+instance NewRef IO where+ newRef' x = do+ vx <- liftIO $ newMVar x+ return $ Morph $ \m -> modifyMVar vx $ liftM swap . runStateT m+ where+ swap (a, b) = (b, a)++instance NewRef m => NewRef (StateT s m) where+ newRef' x = lift $ flip liftM (newRef' x) $ \r ->+ Morph $ \m -> StateT $ \s -> runMorph r $ flip mapStateT m $ \k -> flip liftM (runStateT k s) $ \((x, w), s) -> ((x, s), w)++instance (Monoid w, NewRef m) => NewRef (WriterT w m) where+ newRef' x = lift $ flip liftM (newRef' x) $ \r ->+ Morph $ \m -> WriterT $ runMorph r $ flip mapStateT m $ \k -> flip liftM (runWriterT k) $ \((x, s), w) -> ((x, w), s)++instance NewRef m => NewRef (ReaderT r m) where+ newRef' x = lift $ flip liftM (newRef' x) $ \r ->+ Morph $ \m -> ReaderT $ \st -> runMorph r $ flip mapStateT m $ flip runReaderT st++---------------------------++{-+ memoWrite = memoWrite_++ future = future_++future_ :: (MonadRefCreator m, MonadRefWriter m) => (RefReader m a -> m a) -> m a+future_ f = do+ s <- newRef $ error "can't see the future"+ a <- f $ readRef s+ writeRef s a+ return a+-}+memoRead_ :: (MonadRefWriter m, MonadRefCreator m) => m a -> m (m a) +memoRead_ g = do+ s <- newRef Nothing+ return $ readRef s >>= \x -> case x of+ Just a -> return a+ _ -> g >>= \a -> do+ writeRef s $ Just a+ return a++{-+memoWrite_ g = do+ s <- newRef Nothing+ return $ \b -> readRef s >>= \x -> case x of+ Just (b', a) | b' == b -> return a+ _ -> g b >>= \a -> do+ writeRef s $ Just (b, a)+ return a+-}++
+ src/Data/LensRef/Default.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+-- | Default implementation. Points to either to the pure or the fast implementation depending on the cabal flag @PURE@.+module Data.LensRef.Default+ ( Register+ , runRegister+ ) where++#ifdef __PURE__+import Data.LensRef.Pure+#else+import Data.LensRef.Fast+#endif++
+ src/Data/LensRef/Fast.hs view
@@ -0,0 +1,311 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+--{-# OPTIONS_HADDOCK hide #-}+{- |+Fast implementation for the @MonadRefCreator@ interface.++TODO+- elim mem leak: registered events don't allow to release unused refs+- optimiziation: do not remember values+- optimiziation: equality check+-}+module Data.LensRef.Fast+ ( Register+ , runRegister+ , runTests+ ) where++import Data.Monoid+import Control.Applicative hiding (empty)+import Control.Monad.State+import Control.Monad.Reader+import Control.Lens++import Data.LensRef+import Data.LensRef.Common+import Data.LensRef.TestEnv+import Data.LensRef.Test++----------------------++newtype Wrap m a+ = Wrap {unWrap :: m a}+ deriving (Monad, Functor, Applicative, MonadFix)++instance NewRef m => NewRef (Wrap m) where+ newRef' x = Wrap $ liftM (\(Morph f) -> Morph $ \g -> Wrap $ f $ mapStateT unWrap g) $ newRef' x++instance MonadTrans Wrap where+ lift = Wrap++newtype instance RefWriterOf (Wrap m) a+ = RefWriterOfIO { runRefWriterOfIO :: Wrap m a }+ deriving (Monad, Applicative, Functor)++----------------------++data Lens__ (m :: * -> *) a = Lens_ + { readPart :: m a+ , writePart :: a -> m ()+ , register :: m () -> m ()+ }++type Lens_ m = Lens__ (Wrap m)++joinLens :: Monad m => Wrap m (Lens_ m a) -> Lens_ m a+joinLens m = Lens_+ { readPart = m >>= readPart+ , writePart = \a -> m >>= \r -> writePart r a+ , register = \e -> m >>= \r -> register r e+ }++instance NewRef m => RefClass (Lens_ m) where+ type RefReaderSimple (Lens_ m) = Wrap m++ readRefSimple = readPart . joinLens+ writeRefSimple m = RefWriterOfIO . writePart (joinLens m)+ lensMap l m = do+ Lens_ r w t <- m+ return Lens_+ { readPart = r >>= \a -> return $ a ^. l+ , writePart = \b -> r >>= \a -> w $ set l b a+ , register = t+ }+ unitRef = return Lens_+ { readPart = return ()+ , writePart = const $ return ()+ , register = \_ -> return ()+ }++instance NewRef m => MonadRefReader (Wrap m) where++ type BaseRef (Wrap m) = Lens_ m++ liftRefReader = id++instance NewRef m => MonadRefReader (RefWriterOf (Wrap m)) where++ type BaseRef (RefWriterOf (Wrap m)) = Lens_ m++ liftRefReader = RefWriterOfIO++instance NewRef m => MonadRefWriter (RefWriterOf (Wrap m)) where+ liftRefWriter = id -- RefWriterOfIO . runRefWriterOfIO++{-+wrap :: NewRef m => IO a -> Wrap m a+wrap m = Wrap $ liftBaseWith $ const m+-}+instance NewRef m => MonadRefCreator (Wrap m) where++ extRef r r2 a0 = do+ Lens_ rb wb tb <- r+ b0 <- rb+ va <- newRef' $ set r2 b0 a0+ reg <- newRef' $ return ()+ status <- newRef' True -- True: normal; False:+ tb $ do+ s <- runMorph status get+ when s $ do+ b <- rb+ runMorph va $ modify (set r2 b)+ join $ runMorph reg get+ return $+ return Lens_+ { readPart = runMorph va get+ , writePart = \a -> do+ runMorph va $ put a+ runMorph status $ put False+ wb $ a ^. r2+ runMorph status $ put True+ join $ runMorph reg get+ , register = \m -> runMorph reg $ modify (>> m)+ }++ newRef a0 = do+ va <- newRef' a0+ reg <- newRef' $ return ()+ return $ return Lens_+ { readPart = runMorph va get+ , writePart = \a -> do+ runMorph va $ put a+ join $ runMorph reg get+ , register = \m -> runMorph reg $ modify (>> m)+ }++instance NewRef m => MonadMemo (Wrap m) where+ memoRead = memoRead_+{-+ memoWrite = memoWrite_++ future = future_+-}+++instance NewRef m => MonadRefWriter (Wrap m) where+ liftRefWriter = runRefWriterOfIO+++---------------------------------++type Register_ m = ReaderT (Ref m (MonadMonoid m, RegionStatusChange -> MonadMonoid m)) m++newtype Reg n a = Reg { unReg :: ReaderT (SLSt n () -> n ()) (Register_ (SLSt n)) a } deriving (Monad, Applicative, Functor)++type SLSt (m :: * -> *) = m++type Register m = Reg (Wrap m)+{-+mapReg :: (forall a . m a -> n a) -> Reg m a -> Reg n a+mapReg ff (Reg m) = Reg $ ReaderT $ \f -> ReaderT $ \r -> StateT $ \s -> + ff $ flip runStateT s $ flip runReaderT (iso undefined undefined `lensMap` r) $ runReaderT m $ undefined f++instance MonadTrans Reg where+ lift = Reg . lift . lift . lift+-}++instance MonadFix m => MonadFix (Register m) where+ mfix f = Reg $ mfix $ unReg . f++instance NewRef m => MonadRefReader (Register m) where++ type BaseRef (Register m) = Lens_ m++ liftRefReader = Reg . lift . lift . liftRefReader++instance NewRef m => MonadRefCreator (Register m) where+ extRef r l = Reg . lift . lift . extRef r l+ newRef = Reg . lift . lift . newRef++instance NewRef m => MonadMemo (Register m) where+ memoRead = memoRead_+{-+ memoWrite = memoWrite_+ future = future_+-}+instance NewRef m => MonadRefWriter (Register m) where+ liftRefWriter = Reg . lift . lift . liftRefWriter++instance NewRef m => MonadRegister (Register m) where++ type EffectM (Register m) = m++ type Modifier (Register m) = Register m++ liftEffectM = Reg . lift . lift . lift++ liftToModifier = id++ onChange r f = onChangeAcc r undefined undefined $ \b _ _ -> liftM const $ f b++ onChangeSimple r f = Reg $ ReaderT $ \ff ->+ toSend False r undefined undefined $ \b _ _ -> return $ \_ -> evalRegister ff $ f b++ registerCallback f = Reg $ ReaderT $ \ff -> do+ writerstate <- ask+ return $ fmap (unWrap . ff . flip runReaderT writerstate . evalRegister ff) f++ onRegionStatusChange g = Reg $ ReaderT $ \ff -> do+ writerstate <- ask+ tell' (mempty, MonadMonoid . flip runReaderT writerstate . evalRegister ff . g)+++evalRegister ff (Reg m) = runReaderT m ff++runRegister :: NewRef m => (forall a . m (m a, a -> m ())) -> Register m a -> m (a, m ())+runRegister newChan (Reg m) = unWrap $ do+ (read, write) <- Wrap newChan+ (a, tick) <- do+ (a, r) <- runRefWriterT $ runReaderT m $ Wrap . write+ (w, _) <- readRef r+ return (a, runMonadMonoid w)+ return $ (,) a $ unWrap $ forever $ do+ join $ Wrap read+ tick++runRegister_ :: NewRef m => (m (Wrap m ())) -> (Wrap m () -> m ()) -> Register m a -> m (a, m ())+runRegister_ read write (Reg m) = unWrap $ do+ (a, tick) <- do+ (a, r) <- runRefWriterT $ runReaderT m $ Wrap . write+ (w, _) <- readRef r+ return (a, runMonadMonoid w)+ return $ (,) a $ unWrap $ forever $ do+ join $ Wrap read+ tick+++onChangeAcc r b0 c0 f = Reg $ ReaderT $ \ff ->+ toSend True r b0 c0 $ \b b' c' -> liftM (\x -> evalRegister ff . x) $ evalRegister ff $ f b b' c'++toSend+ :: (Eq b, MonadRefCreator m, MonadRefWriter m)+ => Bool+ -> RefReader m b+ -> b -> (b -> c)+ -> (b -> b -> c -> {-Either (Register m c)-} Register_ m (c -> Register_ m c))+ -> Register_ m (RefReader m c)+toSend memoize 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)), []) -- memo table++ 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), if memoize then filter ((/= b) . fst) (last:memo) else [])+ 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 :: Wrap (Prog TP) () }++runTests = do+ mkTests runTestSimple+ tests runTest+++runTest :: (Eq a, Show a) => String -> Register (Prog TP) a -> Prog' (a, Prog' ()) -> IO ()+runTest name = runTest_ name (TP . lift) runReg++runTestSimple :: Register (Prog TP) () -> IO ()+runTestSimple m = runTest "" m $ return ((), return ())+
+ src/Data/LensRef/Pure.hs view
@@ -0,0 +1,274 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- {-# OPTIONS_HADDOCK hide #-}+{- |+Register reference implementation for the @MonadRefCreator@ interface.++The implementation uses @unsafeCoerce@ internally, but its effect cannot escape.+-}+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 MonadMemo (RefWriterOf (Reader LSt)) 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+{-+mapReg :: (forall a . m a -> n a) -> Register m a -> Register n a+mapReg ff (Register m) = Register $ ReaderT $ \f -> ReaderT $ \r -> StateT $ \s -> + ff $ flip runStateT s $ flip runReaderT (iso undefined undefined `lensMap` r) $ runReaderT m $ undefined f+-}+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 n) = 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_+{-+ memoWrite = memoWrite_+ future = future_+-}+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 -> {-Either (Register m 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)), []) -- memo table++ 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 ())+++
+ src/Data/LensRef/Test.hs view
@@ -0,0 +1,501 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+-- | Tests for the @MonadRefCreator@ interface.+module Data.LensRef.Test+ ( -- * Tests for the interface+ mkTests+ , tests+ ) where++import Data.Maybe+import Control.Monad.State+import Control.Arrow ((***))+import Control.Lens++import Data.LensRef+import Data.LensRef.TestEnv++-----------------------------------------------------------------++{- | +@mkTests@ generates a list of error messages which should be emtpy.++Look inside the sources for the tests.+-}+mkTests :: (MonadRegisterRun m, MonadRefWriter m, EffectM m ~ Prog (AsocT m), Monad n)+ => (m () -> n ())+ -> n ()++mkTests runTest = do+ newRefTest+ writeRefsTest+ extRefTest+ joinTest+ joinTest2+ chainTest0+ forkTest+ forkTest2+ chainTest+ chainTest'+ undoTest+ undoTest2+ undoTest3++-- writeRefTest+ where++ newRefTest = runTest $ do+ r <- newRef (3 :: Int)+ r ==> 3+++ writeRefsTest = runTest $ do+ r1 <- newRef (3 :: Int)+ r2 <- newRef (13 :: Int)+ r1 ==> 3+ r2 ==> 13+ writeRef r1 4+ r1 ==> 4+ r2 ==> 13+ writeRef r2 0+ r1 ==> 4+ r2 ==> 0++ extRefTest = runTest $ do+ r <- newRef $ Just (3 :: Int)+ q <- extRef r maybeLens (False, 0)+ let q1 = _1 `lensMap` q+ q2 = _2 `lensMap` q+ r ==> Just 3+ q ==> (True, 3)+ writeRef r Nothing+ r ==> Nothing+ q ==> (False, 3)+ q1 ==> False+ writeRef q1 True+ r ==> Just 3+ writeRef q2 1+ r ==> Just 1++ joinTest = runTest $ do+ r2 <- newRef (5 :: Int)+ r1 <- newRef 3+ rr <- newRef r1+ r1 ==> 3+ let r = join $ readRef rr+ r ==> 3+ writeRef r1 4+ r ==> 4+ writeRef rr r2+ r ==> 5+ writeRef r1 4+ r ==> 5+ writeRef r2 14+ r ==> 14++ joinTest2 = runTest $ do+ r1 <- newRef (3 :: Int)+ rr <- newRef r1+ r2 <- newRef 5+ writeRef rr r2+ join (readRef rr) ==> 5++ chainTest0 = runTest $ do+ r <- newRef (1 :: Int)+ q <- extRef r id 0+ s <- extRef q id 0+ r ==> 1+ q ==> 1+ s ==> 1+ writeRef r 2+ r ==> 2+ q ==> 2+ s ==> 2+ writeRef q 3+ r ==> 3+ q ==> 3+ s ==> 3+ writeRef s 4+ r ==> 4+ q ==> 4+ s ==> 4++ forkTest = runTest $ do+ r <- newRef (1 :: Int)+ q <- extRef r id 0+ s <- extRef r id 0+ r ==> 1+ q ==> 1+ s ==> 1+ writeRef r 2+ r ==> 2+ q ==> 2+ s ==> 2+ writeRef q 3+ r ==> 3+ q ==> 3+ s ==> 3+ writeRef s 4+ r ==> 4+ q ==> 4+ s ==> 4++ forkTest2 = runTest $ do+ r <- newRef $ Just (1 :: Int)+ q <- extRef r maybeLens (False, 0)+ s <- extRef r maybeLens (False, 0)+ r ==> Just 1+ q ==> (True, 1)+ s ==> (True, 1)+ writeRef r $ Just 2+ r ==> Just 2+ q ==> (True, 2)+ s ==> (True, 2)+ writeRef r Nothing+ r ==> Nothing+ q ==> (False, 2)+ s ==> (False, 2)+ writeRef (_1 `lensMap` q) True+ r ==> Just 2+ q ==> (True, 2)+ s ==> (True, 2)+ writeRef (_2 `lensMap` q) 3+ r ==> Just 3+ q ==> (True, 3)+ s ==> (True, 3)+ writeRef (_1 `lensMap` q) False+ r ==> Nothing+ q ==> (False, 3)+ s ==> (False, 3)+ writeRef (_2 `lensMap` q) 4+ r ==> Nothing+ q ==> (False, 4)+ s ==> (False, 3)+ writeRef (_1 `lensMap` q) True+ r ==> Just 4+ q ==> (True, 4)+ s ==> (True, 4)+ writeRef q (False, 5)+ r ==> Nothing+ q ==> (False, 5)+ s ==> (False, 4)+ writeRef (_1 `lensMap` s) True+ r ==> Just 4+ q ==> (True, 4)+ s ==> (True, 4)++ chainTest = runTest $ do+ r <- newRef $ Just Nothing+ q <- extRef r maybeLens (False, Nothing)+ s <- extRef (_2 `lensMap` q) maybeLens (False, 3 :: Int)+ writeRef (_1 `lensMap` s) False+ r ==> Just Nothing+ q ==> (True, Nothing)+ s ==> (False, 3)+ writeRef (_1 `lensMap` q) False+ r ==> Nothing+ q ==> (False, Nothing)+ s ==> (False, 3)++ chainTest' = runTest $ do+ r <- newRef $ Just $ Just (3 :: Int)+ q <- extRef r maybeLens (False, Nothing)+ s <- extRef (_2 `lensMap` q) maybeLens (False, 0 :: Int)+ r ==> Just (Just 3)+ q ==> (True, Just 3)+ s ==> (True, 3)+ writeRef (_1 `lensMap` s) False+ r ==> Just Nothing+ q ==> (True, Nothing)+ s ==> (False, 3)+ writeRef (_1 `lensMap` q) False+ r ==> Nothing+ q ==> (False, Nothing)+ s ==> (False, 3)+ writeRef (_1 `lensMap` s) True+ r ==> Nothing+ q ==> (False, Just 3)+ s ==> (True, 3)+ writeRef (_1 `lensMap` q) True+ r ==> Just (Just 3)+ q ==> (True, Just 3)+ s ==> (True, 3)++ undoTest = runTest $ do+ r <- newRef (3 :: Int)+ q <- extRef r (lens head $ flip (:)) []+ writeRef r 4+ q ==> [4, 3]++ undoTest2 = runTest $ do+ r <- newRef (3 :: Int)+ q <- extRef r (lens head $ flip (:)) []+ q ==> [3]++ undoTest3 = runTest $ do+ r <- newRef (3 :: Int)+ (undo, redo) <- liftM (liftRefReader *** liftRefReader) $ undoTr (==) r+ r ==> 3+ redo === False+ undo === False+ writeRef r 4+ r ==> 4+ redo === False+ undo === True+ writeRef r 5+ r ==> 5+ redo === False+ undo === True+ push undo+ r ==> 4+ redo === True+ undo === True+ push undo+ r ==> 3+ redo === True+ undo === False+ push redo+ r ==> 4+ redo === True+ undo === True+ writeRef r 6+ r ==> 6+ redo === False+ undo === True+ where+ push m = m >>= \x -> maybe (return ()) liftRefWriter x+ m === t = m >>= \x -> isJust x ==? t++--------------------------++maybeLens :: Lens' (Bool, a) (Maybe a)+maybeLens = lens (\(b,a) -> if b then Just a else Nothing)+ (\(_,a) x -> maybe (False, a) (\a' -> (True, a')) x)++-- | Undo-redo state transformation.+undoTr+ :: MonadRegister m =>+ (a -> a -> Bool) -- ^ equality on state+ -> Ref m a -- ^ reference of state+ -> m ( RefReader m (Maybe (RefWriter m ()))+ , RefReader m (Maybe (RefWriter m ()))+ ) -- ^ undo and redo actions+undoTr eq r = do+ ku <- extRef r (undoLens eq) ([], [])+ let try f = liftM (liftM (writeRefSimple ku) . f) $ readRef ku+ return (try undo, try redo)+ where+ undo (x: xs@(_:_), ys) = Just (xs, x: ys)+ undo _ = Nothing++ redo (xs, y: ys) = Just (y: xs, ys)+ redo _ = Nothing++undoLens :: (a -> a -> Bool) -> Lens' ([a],[a]) a+undoLens eq = lens get set where+ get = head . fst+ set (x' : xs, ys) x | eq x x' = (x: xs, ys)+ set (xs, _) x = (x : xs, [])+++----------------------------------------------------------------------------++tests :: (MonadRegisterRun m, EffectM m ~ Prog (AsocT m), Monad n, MonadRegister (Modifier m))+ => (forall a . (Eq a, Show a) => String -> m a -> Prog' (a, Prog' ()) -> n ())+ -> n ()+tests runTest = do++ runTest "trivial" (return ()) $ do+ return ((), return ())++ runTest "message" (message "Hello") $ do+ message' "Hello"+ return ((), return ())++ runTest "listener" (listen 1 $ \s -> message $ "Hello " ++ s) $ do+ message' "listener #0"+ return $ (,) () $ do+ send 1 "d"+ message' "Hello d"+ send 1 "f"+ message' "Hello f"+ -- send 2 "f"++ runTest "listeners" (do+ listen 1 $ \s -> message $ "Hello " ++ s+ listen 2 $ \s -> message $ "Hi " ++ s+ listen 3 $ \s -> do+ message $ "H_ " ++ s+ listen 4 $ \s' ->+ message $ "H " ++ s'+ ) $ do+ message' "listener #0"+ message' "listener #1"+ message' "listener #2"+ return $ (,) () $ do+ send 1 "d"+ message' "Hello d"+ send 1 "f"+ message' "Hello f"+ send 2 "f"+ message' "Hi f"+ send 3 "f"+ message' "H_ f"+ message' "listener #3"+ send 4 "f"+ message' "H f"++ runTest "postponed0" (postponeModification $ message "hello") $ do+ return $ (,) () $ do+ message' "hello"++ runTest "postponed" (do+ r <- newRef "x"+ _ <- onChangeSimple (readRef r) message+ postponeModification $ writeRef r "x"+ postponeModification $ writeRef r "y"+ return ()+ ) $ do+ message' "x"+ return $ (,) () $ do+ message' "y"++ runTest "onChangeSimple" (do+ r <- newRef "x"+ listen 1 $ writeRef r+ _ <- onChangeSimple (readRef r) message+ return ()+ ) $ do+ message' "listener #0"+ message' "x"+ return $ (,) () $ do+ send 1 "x"+ send 1 "y"+ message' "y"++ runTest "onChangeSimple + listener" (do+ r1 <- newRef "x"+ r2 <- newRef "y"+ listen 1 $ writeRef r1+ listen 2 $ writeRef r2+ _ <- onChangeSimple (liftM2 (++) (readRef r1) (readRef r2)) message+ return ()+ ) $ do+ message' "listener #0"+ message' "listener #1"+ message' "xy"+ return $ (,) () $ do+ send 1 "x"+ send 2 "y"+ send 1 "y"+ message' "yy"+ send 2 "y"+ send 2 "x"+ message' "yx"++ runTest "onChangeSimple + join" (do+ r1 <- newRef "x"+ r2 <- newRef "y"+ rr <- newRef r1+ listen 1 $ writeRef r1+ listen 2 $ writeRef r2+ listen 3 $ \i -> case i of+ True -> writeRef rr r1+ False -> writeRef rr r2+ _ <- onChangeSimple (readRef $ join $ readRef rr) message+ return ()+ ) $ do+ message' "listener #0"+ message' "listener #1"+ message' "listener #2"+ message' "x"+ return $ (,) () $ do+ send 1 "x"+ send 2 "y"+ send 1 "y"+ message' "y"+ send 2 "y"+ send 2 "x"+ send 3 False+ message' "x"+ send 1 "a"+ send 2 "b"+ message' "b"+++ runTest "" (do+ r <- newRef (0 :: Int)+ _ <- onChange (readRef r) $ \i -> case i of+ 0 -> return $ do+ listen 1 $ \s -> do+ when (s == "f") $ do+ writeRef r 1+ rv <- readRef r+ message $ show rv+ message $ "Hello " ++ s++ 1 -> do+ listen 2 $ \s -> do+ when (s == "g") $ writeRef r 0+ message $ "Hi " ++ s+ return $ return ()++ return ()+ ) $ do++ message' "listener #0"+ return $ (,) () $ do+ send 1 "d"+ message' "Hello d"+ send 1 "f"+ message' "1"+ message' "Hello f"+ message' "Kill #0"+ message' "listener #1"+ send 1 "f"+ error' "message is not received: 1 \"f\""+ send 2 "f"+ message' "Hi f"+ send 2 "g"+ message' "Hi g"+ message' "listener #2"+ send 2 "g"+ error' "message is not received: 2 \"g\""+ send 3 "f"+ error' "message is not received: 3 \"f\""+ send 1 "f"+ message' "1"+ message' "Hello f"+ message' "Kill #2"+ send 2 "f"+ message' "Hi f"+{-+ runTest "" (do+ r <- newRef $ Just (3 :: Int)+ q <- extRef r maybeLens (False, 0)+ let q1 = _1 `lensMap` q+ q2 = _2 `lensMap` q+ _ <- onChange (readRef r) $ \r -> return $ message $ show r+ _ <- onChange (readRef q) $ \r -> return $ message $ show r+ postponeModification $ writeRef r Nothing+ postponeModification $ writeRef q1 True+ postponeModification $ writeRef q2 1+ ) $ do+ message' "Just 3"+ message' "(True,3)"+ return $ (,) () $ do+ message' "Nothing"+ message' "(False,3)"+ message' "Just 3"+ message' "(True,3)"+ message' "Just 1"+ message' "(True,1)"+ return ()+-}++
+ src/Data/LensRef/TestEnv.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+module Data.LensRef.TestEnv where++import Control.Monad.State+import Control.Monad.Writer hiding (listen, Any)+import Control.Monad.Operational+import qualified Data.Sequence as Seq+import Control.Lens hiding ((|>), view)++import Unsafe.Coerce++import Data.LensRef+import Data.LensRef.Common++----------------------+++class MonadRegister tm => MonadRegisterRun tm where++ type AsocT tm :: *++ runReg :: (m ~ EffectM tm)+ => m (AsocT tm)+ -> (AsocT tm -> m ())+ -> tm a+ -> m (a, m ())++++--------------------------++newtype Id = Id Int deriving Eq++instance Show Id where show (Id i) = "#" ++ show i++newtype Port a = Port { unPort :: Int } deriving (Eq, Num)++instance Show (Port a) where show (Port i) = show i++data Inst t a where+ Message :: String -> Inst t ()+ Listen :: Show b => Port b -> (b -> Prog t ()) -> Inst t Id+ SetStatus :: Id -> RegionStatusChange -> Inst t ()++ ReadI :: Inst t t+ WriteI :: t -> Inst t ()+ NewRef :: a -> Inst t (Morph (StateT a (Prog t)) (Prog t))++type Prog t = ProgramT (Inst t) (State (Seq.Seq Any))+++---------------------------------------------------++instance NewRef (Prog t) where+ newRef' = singleton . NewRef++message :: (MonadRegister m, EffectM m ~ Prog t) => String -> m ()+message = liftEffectM . singleton . Message++listen :: (MonadRegister m, EffectM m ~ Prog t, Show a) => Port a -> (a -> Modifier m ()) -> m ()+listen i m = do+ f <- registerCallback m+ id <- liftEffectM . singleton $ Listen i f+ message $ "listener " ++ show id+ onRegionStatusChange $ \s -> do+ liftEffectM . singleton $ SetStatus id s+ when (s == Kill) $ message $ show s ++ " " ++ show id+++data Inst' a where+ Message' :: String -> Inst' ()+ Error' :: String -> Inst' ()+ Send :: forall a . Show a => Port a -> a -> Inst' ()++type Prog' = Program Inst'++message' = singleton . Message'+error' = singleton . Error'+send i s = singleton $ Send i s++--getProg' :: MonadError String m => Prog' b -> m b+getProg' :: Prog' b+ -> StateT s Er b+getProg' p = case runIdentity . viewT $ p of+ Return x -> return x+ Send i s :>>= p -> do+ fail' $ "end expected instead of send " ++ show i ++ " " ++ show s+ getProg' $ p ()+ Message' s :>>= p -> do+ fail' $ "end expected instead of message' " ++ s+ getProg' $ p ()+ Error' s :>>= p -> do+ fail' $ "end expected instead of unfail " ++ s+ getProg' $ p ()+ ++type Er = Writer [Either (Either String String) String] --ErrorT String (Writer [String])++tell_ s = tell [Right s]+fail' s = tell [Left $ Right s]+unfail s = tell [Left $ Left s]+handEr name = showRes name . runWriter -- . runErrorT+showRes name ((),l) = case f [] l of+ [] -> []+ xs -> ("test " ++ name ++ " failed.") : xs ++ [""]+ where+ f acc (Right x: xs) = f (x:acc) xs+ f acc (Left (Right s): Left (Left s'): xs) | s == s' = f (("unfail " ++ s'): acc) xs+ f acc (Left e: _) = reverse $ either id id e: acc+ f _ [] = []++data Any = forall x . Any x++data Listener m = forall a . Show a => Listener+ { _listenerId :: Id+ , _listenerPort :: Port a+ , _listenerStatus :: RegionStatusChange+ , _listenerCallback :: a -> Prog m ()+ }+makeLenses ''Listener++data ST m = ST+ { _postponed :: [m]+ , _listeners :: [Listener m]+ , _idcounter :: Int+ , _vars :: Seq.Seq Any+ }+makeLenses ''ST+++coeval_ :: forall a b m+ . (Prog m () -> m)+ -> Prog m a+ -> Prog' b+ -> StateT (ST m) Er (Maybe a, Prog' b)+coeval_ lift_ q p = do+ op <- zoom vars $ mapStateT lift $ viewT q+ coeval__ lift_ op p++coeval__ :: forall a b m+ . (Prog m () -> m)+ -> ProgramViewT (Inst m) (State (Seq.Seq Any)) a+ -> Prog' b+ -> StateT (ST m) Er (Maybe a, Prog' b)+coeval__ lift_ op p = do+ nopostponed <- use $ postponed . to null+ case (op, view p) of++ (_, Error' s :>>= k) -> do+ unfail s+ coeval__ lift_ op $ k ()++ (Message s :>>= k, Return x) -> do+ fail' $ "the following message expected: " ++ s ++ " instead of return"+ coeval_ lift_ (k ()) (return x)++ (Message s :>>= k, Message' s' :>>= k')+ | s == s' -> do+ tell_ ("message: " ++ s)+ coeval_ lift_ (k ()) (k' ())+ | otherwise -> do+ fail' $ "the following message expected: " ++ s ++ " instead of " ++ s'+ coeval__ lift_ op $ k' ()++ (Message s :>>= _, Send _i s' :>>= k') -> do+ fail' $ "the following message expected: " ++ s ++ " instead of send " ++ show s'+ coeval__ lift_ op (k' ())++ (SetStatus i status :>>= k, _) -> do+ listeners %= case status of+ Kill -> filter ((/=i) . (^. listenerId))+ Block -> map f where+ f (Listener i' c Unblock x) | i' == i = Listener i c Block x+ f x = x+ Unblock -> map f where+ f (Listener i' c Block x) | i' == i = Listener i c Unblock x+ f x = x+ coeval_ lift_ (k ()) p++ (Listen i lr :>>= k, _) -> do+ co <- use idcounter+ listeners %= (Listener (Id co) i Unblock lr :)+ idcounter %= (+1)+ coeval_ lift_ (k $ Id co) p++ (ReadI :>>= k, _) | not nopostponed -> do+ x <- use $ postponed . to head+ postponed %= tail+ coeval_ lift_ (k x) p++ (WriteI x :>>= k, _) -> do+ postponed %= (++[x])+ coeval_ lift_ (k ()) p++ (NewRef a :>>= k, _) -> do+ n <- use $ vars . to Seq.length++ let ff :: forall aa bb . aa -> StateT aa (Prog m) bb -> Prog m bb+ ff _ (StateT f) = do+ v <- gets (`Seq.index` n)+ modify $ Seq.update n $ error "recursive reference modification"+ case v of+ Any w -> do+ (x, w') <- f $ unsafeCoerce w+ modify $ Seq.update n $ Any w'+ return x+ vars %= (Seq.|> Any a)+ coeval_ lift_ (k $ Morph $ ff a) p++ (_, Send i@(Port pi) s :>>= k) -> do+ tell_ $ "send " ++ show i ++ " " ++ show s+ if not nopostponed+ then do+ fail' $ "early send of " ++ show s+ else do+ li' <- use $ listeners . to (\li -> [lift_ $ lr $ unsafeCoerce s | Listener _ (Port pi') Unblock lr <- li, pi == pi'])+ if (null li')+ then do+ fail' $ "message is not received: " ++ show i ++ " " ++ show s+ else do+ postponed %= (++ li')+ coeval__ lift_ op (k ())++ (ReadI :>>= _, _) | nopostponed -> return (Nothing, p)++ (Return x, _) -> return (Just x, p)++++runTest_ :: (Eq a, Show a, m ~ Prog n)+ => String+ -> (Prog n () -> n)+ -> (m n -> (n -> m ()) -> tm a -> m (a, m ()))+ -> tm a+ -> Prog' (a, Prog' ())+ -> IO ()+runTest_ name lift runRegister_ r p0 = putStr $ unlines $ handEr name $ flip evalStateT (ST [] [] 0 Seq.empty) $ do+ (Just (a1,c),pe) <- coeval_ lift (runRegister_ (singleton ReadI) (singleton . WriteI) r) p0+ (a2,p) <- getProg' pe+ when (a1 /= a2) $ fail' $ "results differ: " ++ show a1 ++ " vs " ++ show a2+ (_, pr) <- coeval_ lift c p+ getProg' pr++------------------------------------------------++-- | Check an equality.+(==?) :: (Eq a, Show a, MonadRegisterRun m, EffectM m ~ Prog (AsocT m)) => a -> a -> m ()+rv ==? v = when (rv /= v) $ message $ "runTest failed: " ++ show rv ++ " /= " ++ show v++-- | Check the current value of a given reference.+(==>) :: (Eq a, Show a, MonadRegisterRun m, EffectM m ~ Prog (AsocT m)) => Ref m a -> a -> m ()+r ==> v = readRef r >>= (==? v)++infix 0 ==>, ==?++++