Zoom.hs

-------------------------------------------------------------
-- |
-- Module      : Control.Imperative.Zoom
-- Copyright   : (C) 2015, Yu Fukuzawa
-- License     : BSD3
-- Maintainer  : minpou.primer@email.com
-- Stability   : experimental
-- Portability : portable
--
-----------------------------------------------------------

{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE RankNTypes                #-}
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 (..))

-- | See <http://hackage.haskell.org/package/lens/docs/Control-Lens-Traversal.html>.
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
{-# INLINE unsafePreview #-}

set' :: Traversal' s a -> a -> s -> s
set' l x = runIdentity . l (const (Identity x))
{-# INLINE set' #-}

-- | Zoom in on stored value in the 'Ref'.
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
  }
{-# INLINE zoomR #-}