{-# LANGUAGE Rank2Types #-}
-- | Apply lenses onto Reactive Values, produced RVs that focus
-- only on a part of the value.
--
-- Copyright   : (C) Keera Studios Ltd, 2013
-- License     : BSD3
-- Maintainer  : support@keera.co.uk
module Data.ReactiveLens where

import Control.Lens
import Data.ReactiveValue

-- | Apply a lens to a reactive value, produced another reactive value that
-- focuses on a part of the first.
reactiveFromLens :: (Monad m, Functor m)
                 => ReactiveFieldReadWrite m a
                 -> Lens' a b
                 -> ReactiveFieldReadWrite m b
reactiveFromLens :: ReactiveFieldReadWrite m a
-> Lens' a b -> ReactiveFieldReadWrite m b
reactiveFromLens rv :: ReactiveFieldReadWrite m a
rv@(ReactiveFieldReadWrite FieldSetter m a
_setter FieldGetter m a
getter FieldNotifier m a
notifier) Lens' a b
l =
    FieldSetter m b
-> FieldGetter m b
-> FieldNotifier m a
-> ReactiveFieldReadWrite m b
forall (m :: * -> *) a.
FieldSetter m a
-> FieldGetter m a
-> FieldNotifier m a
-> ReactiveFieldReadWrite m a
ReactiveFieldReadWrite FieldSetter m b
setter' FieldGetter m b
getter' FieldNotifier m a
notifier
  where setter' :: FieldSetter m b
setter' b
v = ReactiveFieldReadWrite m a -> (a -> a) -> m ()
forall (m :: * -> *) a b.
(Monad m, ReactiveValueReadWrite a b m) =>
a -> (b -> b) -> m ()
reactiveValueModify ReactiveFieldReadWrite m a
rv (ASetter a a b b -> b -> a -> a
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter a a b b
Lens' a b
l b
v)
        getter' :: FieldGetter m b
getter'   = (a -> b) -> FieldGetter m a -> FieldGetter m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Getting b a b -> a -> b
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting b a b
Lens' a b
l) FieldGetter m a
getter

-- I'd love to write this, but it's not possible because Haskell does not
-- allow partially applied type synonyms anywhere.
-- instance Monad m => GFunctor (ReactiveFieldReadWrite m) Lens' where
--   gmap = reactiveFromLens

-- | An infix version of 'reactiveFromLense'.
--
-- DUE to a strange problem with GHC-7.10, I cannot use the following
-- equivalente definition: 'flip' 'reactiveFromLens'.
(<$$$>) :: (Monad m, Functor m)
        => Lens' a b -> ReactiveFieldReadWrite m a -> ReactiveFieldReadWrite m b
<$$$> :: Lens' a b
-> ReactiveFieldReadWrite m a -> ReactiveFieldReadWrite m b
(<$$$>) Lens' a b
l rv :: ReactiveFieldReadWrite m a
rv@(ReactiveFieldReadWrite FieldSetter m a
_setter FieldGetter m a
getter FieldNotifier m a
notifier) =
    FieldSetter m b
-> FieldGetter m b
-> FieldNotifier m a
-> ReactiveFieldReadWrite m b
forall (m :: * -> *) a.
FieldSetter m a
-> FieldGetter m a
-> FieldNotifier m a
-> ReactiveFieldReadWrite m a
ReactiveFieldReadWrite FieldSetter m b
setter' FieldGetter m b
getter' FieldNotifier m a
notifier
  where setter' :: FieldSetter m b
setter' b
v = ReactiveFieldReadWrite m a -> (a -> a) -> m ()
forall (m :: * -> *) a b.
(Monad m, ReactiveValueReadWrite a b m) =>
a -> (b -> b) -> m ()
reactiveValueModify ReactiveFieldReadWrite m a
rv (ASetter a a b b -> b -> a -> a
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter a a b b
Lens' a b
l b
v)
        getter' :: FieldGetter m b
getter'   = (a -> b) -> FieldGetter m a -> FieldGetter m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Getting b a b -> a -> b
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting b a b
Lens' a b
l) FieldGetter m a
getter

-- I think this bit would need monadic lenses
-- reactiveLens :: Lens' a b -> Lens' (ReactiveFieldReadWrite m a) (ReactiveFieldReadWrite m b)
-- reactiveLens = undefined