module Glazier.Widget.Lazy
( Widget(..)
, _gadget
, _window
, _Widget
, _Widget'
, _WrappingWidget
, _WrappingWidget'
, statically
, dynamically
) where
import Control.Applicative
import Control.Arrow
import qualified Control.Category as C
import Control.Lens
import Data.Functor.Apply
import Data.Maybe
import Data.Profunctor
import Data.Semigroup
import Glazier.Class
import Glazier.Gadget.Lazy
import Glazier.Window
data Widget m s v n a c = Widget
{ window :: Window m s v
, gadget :: Gadget s n a c
}
_window :: Lens (Widget m s v n a c) (Widget m' s v' n a c) (Window m s v) (Window m' s v')
_window = lens window (\(Widget _ g) w -> Widget w g)
_gadget :: Lens (Widget m s v n a c) (Widget m s v n' a' c') (Gadget s n a c) (Gadget s n' a' c')
_gadget = lens gadget (\(Widget w _) g -> Widget w g)
_window' :: Lens' (Widget m s v n a c) (Window m s v)
_window' = _window
_gadget' :: Lens' (Widget m s v n a c) (Gadget s n a c)
_gadget' = _gadget
_Widget :: Iso (Widget m s v n a c) (Widget m' s' v' n' a' c')
(s -> m v, a -> s -> n (c, s)) (s' -> m' v', a' -> s' -> n' (c', s'))
_Widget = iso (\(Widget w g) -> (view _Window w, view _Gadget g))
(\(w, g) -> Widget (review _Window w) (review _Gadget g))
_WrappingWidget :: Iso (Widget m s v n a c) (Widget m' s' v' n' a' c')
(Window m s v, Gadget s n a c) (Window m' s' v', Gadget s' n' a' c')
_WrappingWidget = iso (\(Widget w g) -> (w, g))
(\(w, g) -> Widget w g)
_WrappingWidget' :: Iso' (Widget m s v n a c) (Window m s v, Gadget s n a c)
_WrappingWidget' = _WrappingWidget
_Widget' :: Iso' (Widget m s v n a c) (s -> m v, a -> s -> n (c, s))
_Widget' = _Widget
instance (Applicative m, Monad n, Semigroup c, Semigroup v) => Semigroup (Widget m s v n a c) where
w1 <> w2 = Widget
(window w1 <> window w2)
(gadget w1 <> gadget w2)
instance (Applicative m, Monad n, Monoid c, Monoid v) => Monoid (Widget m s v n a c) where
mempty = Widget mempty mempty
mappend w1 w2 = Widget
(window w1 `mappend` window w2)
(gadget w1 `mappend` gadget w2)
instance Functor n => Functor (Widget m s v n a) where
fmap f (Widget w g) = Widget
w
(f <$> g)
instance (Applicative m, Monad n, Semigroup v, Monoid v) => Applicative (Widget m s v n a) where
pure c = Widget mempty (pure c)
(Widget w1 fg) <*> (Widget w2 g) = Widget (w1 <> w2) (fg <*> g)
instance (Applicative m, Monad n) => Profunctor (Widget m s v n) where
dimap f g (Widget w m) = Widget w (dimap f g m)
instance (Applicative m, Monad n) => Strong (Widget m s v n) where
first' (Widget w g) = Widget w (first' g)
instance (Applicative m, Monad n, Monoid v) => C.Category (Widget m s v n) where
id = Widget mempty C.id
Widget wbc gbc . Widget wab gab = Widget
(wab `mappend` wbc)
(gbc C.. gab)
instance (Applicative m, Monad n, Monoid v) => Arrow (Widget m s v n) where
arr f = dimap f id C.id
first = first'
instance (Applicative m, Monad n) => Choice (Widget m s v n) where
left' (Widget w bc) = Widget w (left' bc)
instance (Applicative m, Monad n, Monoid v) => ArrowChoice (Widget m s v n) where
left = left'
statically :: (Monad n, Monoid c) => Window m s v -> Widget m s v n a c
statically w = Widget w mempty
dynamically :: (Applicative m, Monad n, Monoid v) => Gadget s n a c -> Widget m s v n a c
dynamically = Widget mempty
type instance Dispatched (Widget m s v n a c) = Dispatched (Gadget s n a c)
instance Monad n => Dispatch (Widget m s v n a c) (Widget m s v n b c) a b where
dispatch p w = Widget
(window w)
(dispatch p $ gadget w)
type instance Implanted (Widget m s v n a c) =
PairMaybeFunctor (Implanted (Window m s v))
(Implanted (Gadget s n a c))
instance (Monad m, Monad n) => Implant (Widget m s v n a c) (Widget m t v n a c) s t where
implant l w = Widget
(implant (fstLensLike l) $ window w)
(implant (sndLensLike l) $ gadget w)
newtype PairMaybeFunctor f g a = PairMaybeFunctor { getPairMaybeFunctor :: (Maybe (f a), Maybe (g a)) }
instance (Functor f, Functor g) => Functor (PairMaybeFunctor f g) where
fmap f (PairMaybeFunctor (a, b)) = PairMaybeFunctor (fmap f <$> a, fmap f <$> b)
instance (Apply f, Apply g) => Apply (PairMaybeFunctor f g) where
(PairMaybeFunctor (a, b)) <.> (PairMaybeFunctor (c, d)) = PairMaybeFunctor (liftA2 (Data.Functor.Apply.<.>) a c, liftA2 (Data.Functor.Apply.<.>) b d)
instance (Applicative f, Applicative g) => Applicative (PairMaybeFunctor f g) where
pure a = PairMaybeFunctor (Just $ pure a, Just $ pure a)
(PairMaybeFunctor (a, b)) <*> (PairMaybeFunctor (c, d)) = PairMaybeFunctor (liftA2 (<*>) a c, liftA2 (<*>) b d)
instance (Contravariant f, Contravariant g) => Contravariant (PairMaybeFunctor f g) where
contramap f (PairMaybeFunctor (a, b)) = PairMaybeFunctor (contramap f <$> a, contramap f <$> b)
fstLensLike :: LensLike (PairMaybeFunctor f g) s t a b -> LensLike f s t a b
fstLensLike l f b = fromJust . fst . getPairMaybeFunctor $ l (\a -> PairMaybeFunctor (Just $ f a, Nothing)) b
sndLensLike :: LensLike (PairMaybeFunctor f g) s t a b -> LensLike g s t a b
sndLensLike l f b = fromJust . snd . getPairMaybeFunctor $ l (\a -> PairMaybeFunctor (Nothing, Just $ f a)) b