module Glazier.Strict
( Gadget(..)
, HasGadget(..)
, _Gadget
, _Gadget'
, hoistGadget
, Widget(..)
, _Widget
, _Widget'
, _WrappingWidget
, _WrappingWidget'
, hoistWidget
, statically
, dynamically
, module Glazier
) where
import Control.Applicative
import Control.Arrow
import qualified Control.Category as C
import Control.Lens
import qualified Control.Monad.Fail as Fail
import Control.Monad.Fix (MonadFix)
import Control.Monad.Morph
import Control.Monad.Reader
import Control.Monad.State.Strict
import Data.Functor.Apply
import Data.Maybe
import Data.Profunctor
import Data.Semigroup
import Glazier
newtype Gadget s m a c = Gadget
{ runGadget :: ReaderT a (StateT s m) c
} deriving ( MonadState s
, MonadReader a
, Monad
, Applicative
, Functor
, Fail.MonadFail
, Alternative
, MonadPlus
, MonadFix
, MonadIO
)
class HasGadget s a | s -> a where
gadget :: Lens' s a
instance HasGadget (Gadget s m a c) (Gadget s m a c) where
gadget = id
makeWrapped ''Gadget
hoistGadget :: (Monad m) => (forall b. m b -> n b) -> Gadget s m a c -> Gadget s n a c
hoistGadget g = _Wrapping Gadget %~ hoist (hoist g)
_Gadget :: Iso (Gadget s m a c) (Gadget s' m' a' c') (a -> s -> m (c, s)) (a' -> s' -> m' (c', s'))
_Gadget = _Wrapping Gadget . iso runReaderT ReaderT . iso (runStateT .) (StateT .)
_Gadget' :: Iso' (Gadget s m a c) (a -> s -> m (c, s))
_Gadget' = _Gadget
instance (Monad m, Semigroup c) => Semigroup (Gadget s m a c) where
(Gadget f) <> (Gadget g) = Gadget $ (<>) <$> f <*> g
instance (Monad m, Monoid c) => Monoid (Gadget s m a c) where
mempty = Gadget $ pure mempty
(Gadget f) `mappend` (Gadget g) = Gadget $ mappend <$> f <*> g
instance Monad m => Profunctor (Gadget s m) where
dimap f g (Gadget (ReaderT m)) = Gadget $ ReaderT $ \a -> StateT $ \s -> undefined
(first g) <$> runStateT (m (f a)) s
instance Monad m => Strong (Gadget s m) where
first' (Gadget (ReaderT bc)) = Gadget $ ReaderT $ \(b, d) -> StateT $ \s ->
(\(c, s') -> ((c, d), s')) <$> runStateT (bc b) s
instance Monad m => C.Category (Gadget s m) where
id = Gadget $ ReaderT $ \a -> StateT $ \s -> pure (a, s)
Gadget (ReaderT bc) . Gadget (ReaderT ab) = Gadget $ ReaderT $ \a -> StateT $ \s -> do
(b, s') <- runStateT (ab a) s
runStateT (bc b) s'
instance Monad m => Arrow (Gadget s m) where
arr f = dimap f id C.id
first = first'
instance Monad m => Choice (Gadget s m) where
left' (Gadget (ReaderT bc)) = Gadget $ ReaderT $ \db -> StateT $ \s -> case db of
Left b -> do
(c, s') <- runStateT (bc b) s
pure (Left c, s')
Right d -> pure (Right d, s)
instance Monad m => ArrowChoice (Gadget s m) where
left = left'
instance Monad m => ArrowApply (Gadget s m) where
app = Gadget $ ReaderT $ \(Gadget (ReaderT bc), b) -> StateT $ \s -> runStateT (bc b) s
instance MonadPlus m => ArrowZero (Gadget s m) where
zeroArrow = Gadget mzero
instance MonadPlus m => ArrowPlus (Gadget s m) where
Gadget a <+> Gadget b = Gadget (a `mplus` b)
type instance Zoomed (Gadget s m a) = Zoomed (StateT s m)
instance Monad m => Zoom (Gadget s m a) (Gadget t m a) s t where
zoom l = Gadget . zoom l . runGadget
type instance Magnified (Gadget s m a) = Magnified (ReaderT a (StateT s m))
instance Monad m => Magnify (Gadget s m a) (Gadget s m b) a b where
magnify l = Gadget . magnify l . runGadget
type instance Implanted (Gadget s m a c) = Zoomed (Gadget s m a) c
instance Monad m => Implant (Gadget s m a c) (Gadget t m a c) s t where
implant = zoom
type instance Dispatched (Gadget s m a c) = Magnified (Gadget s m a) c
instance Monad m => Dispatch (Gadget s m a c) (Gadget s m b c) a b where
dispatch = magnify
data Widget s v m a c = Widget
{ widgetWindow :: Window m s v
, widgetGadget :: Gadget s m a c
}
makeFields ''Widget
_Widget :: Iso (Widget s v m a c) (Widget s' v' m' a' c')
(s -> m v, a -> s -> m (c, s)) (s' -> m' v', a' -> s' -> m' (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 s v m a c) (Widget s' v' m' a' c')
(Window m s v, Gadget s m a c) (Window m' s' v', Gadget s' m' a' c')
_WrappingWidget = iso (\(Widget w g) -> (w, g))
(\(w, g) -> Widget w g)
_WrappingWidget' :: Iso' (Widget s v m a c) (Window m s v, Gadget s m a c)
_WrappingWidget' = _WrappingWidget
_Widget' :: Iso' (Widget s v m a c) (s -> m v, a -> s -> m (c, s))
_Widget' = _Widget
hoistWidget :: (Monad m) => (forall x. m x -> n x) -> Widget s v m a c -> Widget s v n a c
hoistWidget f = _WrappingWidget %~ \(w, g) -> (hoistWindow f w, hoistGadget f g)
instance (Monad m, Semigroup c, Semigroup v) => Semigroup (Widget s v m a c) where
w1 <> w2 = Widget
(widgetWindow w1 <> widgetWindow w2)
(widgetGadget w1 <> widgetGadget w2)
instance (Monad m, Monoid c, Monoid v) => Monoid (Widget s v m a c) where
mempty = Widget mempty mempty
mappend w1 w2 = Widget
(widgetWindow w1 `mappend` widgetWindow w2)
(widgetGadget w1 `mappend` widgetGadget w2)
instance Functor m => Functor (Widget s v m a) where
fmap f (Widget w g) = Widget
w
(f <$> g)
instance (Semigroup v, Monad m, Monoid v) => Applicative (Widget s v m a) where
pure c = Widget mempty (pure c)
(Widget w1 fg) <*> (Widget w2 g) = Widget (w1 <> w2) (fg <*> g)
instance Monad m => Profunctor (Widget s v m) where
dimap f g (Widget w m) = Widget w (dimap f g m)
instance Monad m => Strong (Widget s v m) where
first' (Widget w g) = Widget w (first' g)
instance (Monad m, Monoid v) => C.Category (Widget s v m) where
id = Widget mempty C.id
Widget wbc gbc . Widget wab gab = Widget
(wab `mappend` wbc)
(gbc C.. gab)
instance (Monad m, Monoid v) => Arrow (Widget s v m) where
arr f = dimap f id C.id
first = first'
instance (Monad m) => Choice (Widget s v m) where
left' (Widget w bc) = Widget w (left' bc)
instance (Monad m, Monoid v) => ArrowChoice (Widget s v m) where
left = left'
statically :: (Monad m, Monoid c) => Window m s v -> Widget s v m a c
statically w = Widget w mempty
dynamically :: (Monad m, Monoid v) => Gadget s m a c -> Widget s v m a c
dynamically = Widget mempty
type instance Dispatched (Widget s v m a c) = Dispatched (Gadget s m a c)
instance Monad m => Dispatch (Widget s v m a c) (Widget s v m b c) a b where
dispatch p w = Widget
(widgetWindow w)
(dispatch p $ widgetGadget w)
type instance Implanted (Widget s v m a c) =
PairMaybeFunctor (Implanted (Gadget s m a c))
(Implanted (Window m s v))
instance Monad m => Implant (Widget s v m a c) (Widget t v m a c) s t where
implant l w = Widget
(implant (sndLensLike l) $ widgetWindow w)
(implant (fstLensLike l) $ widgetGadget 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