module Control.Imperative.Zoom
( zoomR
, Traversal'
)
where
import Control.Applicative (Applicative, Const (..))
import Control.Imperative.Internal
import Control.Monad
import Data.Functor.Identity (Identity (..))
import Data.Maybe (fromMaybe)
import Data.Monoid (First (..))
type Traversal' s a = Applicative f => (a -> f a) -> s -> f s
unsafePreview :: Traversal' s a -> s -> a
unsafePreview l s = fromMaybe (error "empty value") $ getFirst $ getConst $ l (Const . First . Just) s
set' :: Traversal' s a -> a -> s -> s
set' l x = runIdentity . l (const (Identity x))
zoomR :: Monad m => Traversal' s a -> Ref m s -> Ref m a
zoomR l r = Ref
{ get = liftM (unsafePreview l) $ get r
, set = \x -> get r >>= \s -> let t = set' l x s in t `seq` set r t
}