glazier 0.9.0.0 → 0.10.0.0

raw patch · 4 files changed

+84/−97 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• glazier.cabal +1/−1
• src/Glazier/Example.hs +14/−15
• src/Glazier/Widget.hs +39/−39
• src/Glazier/Window.hs +30/−42

@@ -1,5 +1,5 @@ name:                glazier-version:             0.9.0.0+version:             0.10.0.0 synopsis:            Composable widgets framework description:         Please see README.md homepage:            https://github.com/louispan/glazier#readme

@@ -13,6 +13,7 @@ import Control.Category import Control.Lens import Control.Monad.Reader+import Data.Foldable import Data.List import Data.Semigroup import Glazier@@ -62,15 +63,15 @@ -- Widget s v m a c optionalExample ::   ( Monoid c-  , Monoid r+  , Monoid v   , Semigroup c-  , Semigroup r+  , Semigroup v   , AsSet a s   , AsReset a   , AsAction a (Maybe s -> Maybe s)   , Monad m   )-  => Prism' a a' -> Widget v m r a' s m c -> Widget v m r a (Maybe s) m c+  => Prism' a a' -> Widget m v a' s m c -> Widget m v a (Maybe s) m c optionalExample p w =      (      implant _Just -- original update will only work if model is Just@@ -95,22 +96,22 @@ -- modify the state of the head. -- The view will be mempty if Nil. listExample ::-  ( Monoid r+  ( Monoid v   , Monoid c-  , Semigroup r+  , Semigroup v   , Semigroup c   , AsTail a   , AsConsAction a s   , AsAction a ([s] -> [s])   , Monad m   )-  => Prism' b a -> Widget v m r a s m c -> Widget v m [r] b [s] m c+  => Prism' b a -> Widget m v a s m c -> Widget m v b [s] m c listExample p (Widget (WindowT d) g) =      -- Create a list rendering function by      -- sequencing the View from the original widget.      statically (WindowT . ReaderT $ \ss -> do-                        let ms = runReaderT d <$> ss -- [(StateT s m) a]-                        sequenceA ms)+                        ss' <- traverse (runReaderT d) ss+                        pure (fold ss'))   <> dynamically     (  implant (ix 0) g -- original update will only work on the head of list     <> dispatch _Tail       (review _GadgetT $ \_ s -> pure (mempty, tail s))@@ -127,26 +128,24 @@ -- * A tuple of (key, original action) -- The original action is now a tuple with an additional key, which will act on the widget if the key exists in the map. indexedExample ::-  ( Monoid r+  ( Monoid v   , Monoid c-  , Monoid (t r)   , Field2 b b a a   , Field1 b b (Index (t s)) (Index (t s))   , Ixed (t s)-  , Semigroup r+  , Semigroup v   , Semigroup c-  , Semigroup (t r)   , AsAction b (t s -> t s)   , IxValue (t s) ~ s   , Monad m   , Traversable t   )-  => Widget v m r a s m c -> Widget v m (t r) b (t s) m c+  => Widget m v a s m c -> Widget m v b (t s) m c indexedExample (Widget (WindowT d) g) =      -- Create a rendering function by folding the original view function      statically (WindowT . ReaderT $ \ss -> do-                        let ms = runReaderT d <$> ss -- [(StateT s m) a]-                        sequenceA ms)+                        ss' <- traverse (runReaderT d) ss+                        pure (fold ss'))   <>     dynamically     (

@@ -34,104 +34,104 @@ import Glazier.Window  -- | A widget is basically a tuple with Gadget and Window, but with handy instances for implant and dispatch.-data Widget v m r a s n c = Widget-  { window :: WindowT s v m r+data Widget m v a s n c = Widget+  { window :: WindowT s m v   , gadget :: GadgetT a s n c   }  -- | polymorphic lens to the window of a widget-_window :: Lens (Widget v m r a s n c) (Widget v' m' r' a s n c) (WindowT s v m r) (WindowT s v' m' r')+_window :: Lens (Widget m v a s n c) (Widget m' v' a s n c) (WindowT s m v) (WindowT s m' v') _window = lens window (\(Widget _ g) w -> Widget w g) {-# INLINABLE _window #-}  -- | polymorphic lens to the gadget of a widget-_gadget :: Lens (Widget v m r a s n c) (Widget v m r a' s n' c') (GadgetT a s n c) (GadgetT a' s n' c')+_gadget :: Lens (Widget m v a s n c) (Widget m v a' s n' c') (GadgetT a s n c) (GadgetT a' s n' c') _gadget = lens gadget (\(Widget w _) g -> Widget w g) {-# INLINABLE _gadget #-}  -- | non polymorphic lens to the window of a widget-_window' :: Lens' (Widget v m r a s n c) (WindowT s v m r)+_window' :: Lens' (Widget m v a s n c) (WindowT s m v) _window' = _window {-# INLINABLE _window' #-}  -- | non polymorphic lens to the gadget of a widget-_gadget' :: Lens' (Widget v m r a s n c) (GadgetT a s n c)+_gadget' :: Lens' (Widget m v a s n c) (GadgetT a s n c) _gadget' = _gadget {-# INLINABLE _gadget' #-} -_Widget :: Iso (Widget v m r a s n c) (Widget v' m' r' a' s' n' c')-           (s -> v -> m (r, v), a -> s -> n (c, s)) (s' -> v' -> m' (r', v'), a' -> s' -> n' (c', s'))+_Widget :: Iso (Widget m v a s n c) (Widget m' v' a' s' n' c')+           (s -> m v, a -> s -> n (c, s)) (s' -> m' v', a' -> s' -> n' (c', s')) _Widget = iso (\(Widget w g) -> (view _WindowT w, view _GadgetT g))                (\(w, g) -> Widget (review _WindowT w) (review _GadgetT g)) {-# INLINABLE _Widget #-}  -- | Non polymorphic version of _Widget-_Widget' :: Iso' (Widget v m r a s n c) (s -> v -> m (r, v), a -> s -> n (c, s))+_Widget' :: Iso' (Widget m v a s n c) (s -> m v, a -> s -> n (c, s)) _Widget' = _Widget {-# INLINABLE _Widget' #-} -_WrappingWidget :: Iso (Widget v m r a s n c) (Widget v' m' r' a' s' n' c')-           (WindowT s v m r, GadgetT a s n c) (WindowT s' v' m' r', GadgetT a' s' n' c')+_WrappingWidget :: Iso (Widget m v a s n c) (Widget m' v' a' s' n' c')+           (WindowT s m v, GadgetT a s n c) (WindowT s' m' v', GadgetT a' s' n' c') _WrappingWidget = iso (\(Widget w g) -> (w, g))                (\(w, g) -> Widget w g) {-# INLINABLE _WrappingWidget #-}  -- | Non polymorphic version of _WrappingWidget-_WrappingWidget' :: Iso' (Widget v m r a s n c) (WindowT s v m r, GadgetT a s n c)+_WrappingWidget' :: Iso' (Widget m v a s n c) (WindowT s m v, GadgetT a s n c) _WrappingWidget' = _WrappingWidget {-# INLINABLE _WrappingWidget' #-} -mkWidget :: (WindowT s v m r, GadgetT a s n c) -> Widget v m r a s n c+mkWidget :: (WindowT s m v, GadgetT a s n c) -> Widget m v a s n c mkWidget = review _WrappingWidget {-# INLINABLE mkWidget #-} -mkWidget' :: (s -> v -> m (r, v), a -> s -> n (c, s)) -> Widget v m r a s n c+mkWidget' :: (s -> m v, a -> s -> n (c, s)) -> Widget m v a s n c mkWidget' = review _Widget {-# INLINABLE mkWidget' #-} -runWidget :: Widget v m r a s n c -> (WindowT s v m r, GadgetT a s n c)+runWidget :: Widget m v a s n c -> (WindowT s m v, GadgetT a s n c) runWidget = view _WrappingWidget {-# INLINABLE runWidget #-} -runWidget' :: Widget v m r a s n c -> (s -> v -> m (r, v), a -> s -> n (c, s))+runWidget' :: Widget m v a s n c -> (s -> m v, a -> s -> n (c, s)) runWidget' = view _Widget {-# INLINABLE runWidget' #-}  belowWidget ::-  ((s -> v -> m (r, v), a -> s -> n (c, s))-   -> (s' -> v' -> m' (r', v'), a' -> s' -> n' (c', s')))-  -> Widget v m r a s n c -> Widget v' m' r' a' s' n' c'+  ((s -> m v, a -> s -> n (c, s))+   -> (s' -> m' v', a' -> s' -> n' (c', s')))+  -> Widget m v a s n c -> Widget m' v' a' s' n' c' belowWidget f = _Widget %~ f {-# INLINABLE belowWidget #-}  underWidget ::-  ((WindowT s v m r, GadgetT a s n c)-   -> (WindowT s' v' m' r', GadgetT a' s' n' c'))-  -> Widget v m r a s n c -> Widget v' m' r' a' s' n' c'+  ((WindowT s m v, GadgetT a s n c)+   -> (WindowT s' m' v', GadgetT a' s' n' c'))+  -> Widget m v a s n c -> Widget m' v' a' s' n' c' underWidget f = _WrappingWidget %~ f {-# INLINABLE underWidget #-}  overWidget ::-  (Widget v m r a s n c -> Widget v' m' r' a' s' n' c')-  -> (WindowT s v m r, GadgetT a s n c)-  -> (WindowT s' v' m' r', GadgetT a' s' n' c')+  (Widget m v a s n c -> Widget m' v' a' s' n' c')+  -> (WindowT s m v, GadgetT a s n c)+  -> (WindowT s' m' v', GadgetT a' s' n' c') overWidget f = from _WrappingWidget %~ f {-# INLINABLE overWidget #-}  aboveWidget ::-  (Widget v m r a s n c -> Widget v' m' r' a' s' n' c')-  -> (s -> v -> m (r, v), a -> s -> n (c, s))-  -> (s' -> v' -> m' (r', v'), a' -> s' -> n' (c', s'))+  (Widget m v a s n c -> Widget m' v' a' s' n' c')+  -> (s -> m v, a -> s -> n (c, s))+  -> (s' -> m' v', a' -> s' -> n' (c', s')) aboveWidget f = from _Widget %~ f {-# INLINABLE aboveWidget #-} -instance (Monad m, Monad n, Semigroup r, Semigroup c) => Semigroup (Widget v m r a s n c) where+instance (Applicative m, Monad n, Semigroup v, Semigroup c) => Semigroup (Widget m v a s n c) where     w1 <> w2 = Widget       (window w1 <> window w2)       (gadget w1 <> gadget w2)     {-# INLINABLE (<>) #-} -instance (Monad m, Monad n, Monoid r, Monoid c) => Monoid (Widget v m r a s n c) where+instance (Applicative m, Monad n, Monoid v, Monoid c) => Monoid (Widget m v a s n c) where     mempty = Widget mempty mempty     {-# INLINABLE mempty #-} @@ -145,7 +145,7 @@ -- (Widget w g) = Widget w (id <$> g) =  Widget w g -- 2: fmap (f . g) = fmap f . fmap g -- (Widget w gad) = Widget w ((f . g) <$> gad) = Widget w ((fmap f . fmap g) gad)-instance Functor n => Functor (Widget v m r a s n) where+instance Functor n => Functor (Widget m v a s n) where     fmap f (Widget w g) = Widget         w         (f <$> g)@@ -167,32 +167,32 @@ --     = Widget (uw <> mempty) (ug <*> pure y) --     = Widget (mempty <> uw) (pure ($ y) <*> ug) --     = Widget mempty (pure $y) <*> Widget uw ug-instance (Monad m, Monad n, Monoid r) => Applicative (Widget v m r a s n) where+instance (Applicative m, Monad n, Monoid v) => Applicative (Widget m v a s n) where     pure c = Widget mempty (pure c)     {-# INLINABLE pure #-}      (Widget w1 fg) <*> (Widget w2 g) = Widget (w1 `mappend` w2) (fg <*> g)     {-# INLINABLE (<*>) #-} -statically :: (Monad n, Monoid c) => WindowT s v m r -> Widget v m r a s n c+statically :: (Monad n, Monoid c) => WindowT s m v -> Widget m v a s n c statically w = Widget w mempty {-# INLINABLE statically #-} -dynamically :: (Monad m, Monoid r) => GadgetT a s n c -> Widget v m r a s n c+dynamically :: (Applicative m, Monoid v) => GadgetT a s n c -> Widget m v a s n c dynamically = Widget mempty {-# INLINABLE dynamically #-} -type instance Dispatched (Widget v m r a s n c) = Dispatched (GadgetT a s n c)-instance Monad n => Dispatch (Widget v m r a s n c) (Widget v m r b s n c) a b where+type instance Dispatched (Widget m v a s n c) = Dispatched (GadgetT a s n c)+instance Monad n => Dispatch (Widget m v a s n c) (Widget m v b s n c) a b where     dispatch p w = Widget         (window w)         (dispatch p $ gadget w)     {-# INLINABLE dispatch #-} -type instance Implanted (Widget v m r a s n c) =-     PairMaybeFunctor (Implanted (WindowT s v m r))+type instance Implanted (Widget m v a s n c) =+     PairMaybeFunctor (Implanted (WindowT s m v))        (Implanted (GadgetT a s n c))-instance (Monad m, Monad n) => Implant (Widget v m r a s n c) (Widget v m r a t n c) s t where+instance (Monad m, Monad n) => Implant (Widget m v a s n c) (Widget m v a t n c) s t where     implant l w = Widget         (implant (fstLensLike l) $ window w)         (implant (sndLensLike l) $ gadget w)

@@ -43,23 +43,17 @@ import Control.Monad.Fix (MonadFix) import Control.Monad.Morph import Control.Monad.Reader-import Control.Monad.State.Strict import Data.Semigroup import Glazier.Class  -------------------------------------------------------------------------------  -- | The Elm view function is basically @view :: model -> html@--- This is be ehanced with monadic effects with ReaderT.--- The render output can be wrapped in a WriterT to make it more composable.--- We use a CPS-style WriterT (ie a StateT) to avoid space leaks.+-- This can be enhanced with monadic effects with ReaderT. -- This is named Window instead of View to avoid confusion with view from Control.Lens--- NB. This is the same formulation as 'Glaizer.GadgetT'.--- The only difference is 'WindowT' only has 'Glazier.Implant' instance.-newtype WindowT s v m r = WindowT-    { runWindowT :: ReaderT s (StateT v m) r-    } deriving ( MonadState v-               , MonadReader s+newtype WindowT s m v = WindowT+    { runWindowT :: ReaderT s m v+    } deriving ( MonadReader s                , Monad                , Applicative                , Functor@@ -72,81 +66,75 @@  makeWrapped ''WindowT -type Window s v = WindowT s v Identity+type Window s = WindowT s Identity -_WindowT :: Iso (WindowT s v m r) (WindowT s' v' m' r') (s -> v -> m (r, v)) (s' -> v' -> m' (r', v'))-_WindowT = _Wrapping WindowT . iso runReaderT ReaderT . iso (runStateT .) (StateT .)+_WindowT :: Iso (WindowT s m v) (WindowT s' m' v') (s -> m v) (s' -> m' v')+_WindowT = _Wrapping WindowT . iso runReaderT ReaderT {-# INLINABLE _WindowT #-}  -- | Non polymorphic version of _Window-_WindowT' :: Iso' (WindowT s v m r) (s -> v -> m (r, v))+_WindowT' :: Iso' (WindowT s m v) (s -> m v) _WindowT' = _WindowT {-# INLINABLE _WindowT' #-} -mkWindowT' :: (s -> v -> m (r, v)) -> WindowT s v m r+mkWindowT' :: (s -> m v) -> WindowT s m v mkWindowT' = review _WindowT {-# INLINABLE mkWindowT' #-} -runWindowT' :: WindowT s v m r -> (s -> v -> m (r, v))+runWindowT' :: WindowT s m v -> (s -> m v) runWindowT' = view _WindowT {-# INLINABLE runWindowT' #-}  belowWindowT ::-  ((s -> v -> m (r, v)) -> s' -> v' -> m' (r', v'))-  -> WindowT s v m r -> WindowT s' v' m' r'+  ((s -> m v) -> (s' -> m' v'))+  -> WindowT s m v -> WindowT s' m' v' belowWindowT f = _WindowT %~ f {-# INLINABLE belowWindowT #-}  underWindowT-    :: (ReaderT s (StateT v m) r -> ReaderT s' (StateT v' m') r')-    -> WindowT s v m r-    -> WindowT s' v' m' r'+    :: (ReaderT s m v -> ReaderT s' m' v')+    -> WindowT s m v+    -> WindowT s' m' v' underWindowT f = _Wrapping WindowT %~ f {-# INLINABLE underWindowT #-}  overWindowT-    :: (WindowT s v m r -> WindowT s' v' m' r')-    -> ReaderT s (StateT v m) r-    -> ReaderT s' (StateT v' m') r'+    :: (WindowT s m v -> WindowT s' m' v')+    -> ReaderT s m v+    -> ReaderT s' m' v' overWindowT f = _Unwrapping WindowT %~ f {-# INLINABLE overWindowT #-}  aboveWindowT ::-  (WindowT s v m r -> WindowT s' v' m' r')-  -> (s -> v -> m (r, v)) -> s' -> v' -> m' (r', v')+  (WindowT s m v -> WindowT s' m' v')+  -> (s -> m v) -> (s' -> m' v') aboveWindowT f = from _WindowT %~ f {-# INLINABLE aboveWindowT #-} -instance MonadTrans (WindowT s v) where-    lift = WindowT . lift . lift+instance MonadTrans (WindowT s) where+    lift = WindowT . lift -instance MFunctor (WindowT s v) where-    hoist f (WindowT m) = WindowT (hoist (hoist f) m)+instance MFunctor (WindowT s) where+    hoist f (WindowT m) = WindowT (hoist f m) -instance (Monad m, Semigroup r) => Semigroup (WindowT s v m r) where+instance (Applicative m, Semigroup v) => Semigroup (WindowT s m v) where     (WindowT f) <> (WindowT g) = WindowT $ (<>) <$> f <*> g     {-# INLINABLE (<>) #-} -instance (Monad m, Monoid r) => Monoid (WindowT s v m r) where+instance (Applicative m, Monoid v) => Monoid (WindowT s m v) where     mempty = WindowT $ pure mempty     {-# INLINABLE mempty #-}      (WindowT f) `mappend` (WindowT g) = WindowT $ mappend <$> f <*> g     {-# INLINABLE mappend #-} --- | zoom can be used to modify the state inside an Gadget-type instance Zoomed (WindowT s v m) = Zoomed (ReaderT s (StateT v m))-instance Monad m => Zoom (WindowT s v m) (WindowT s u m) v u where-    zoom l = WindowT . zoom l . runWindowT-    {-# INLINABLE zoom #-}- -- | magnify can be used to modify the action inside an Gadget-type instance Magnified (WindowT s v m) = Magnified (ReaderT s (StateT v m))-instance Monad m => Magnify (WindowT s v m) (WindowT t v m) s t where+type instance Magnified (WindowT s m) = Magnified (ReaderT s m)+instance Monad m => Magnify (WindowT s m) (WindowT t m) s t where     magnify l = WindowT . magnify l . runWindowT     {-# INLINABLE magnify #-} -type instance Implanted (WindowT s v m r) = Magnified (WindowT s v m) r-instance Monad m => Implant (WindowT s v m r) (WindowT t v m r) s t where+type instance Implanted (WindowT s m v) = Magnified (WindowT s m) v+instance Monad m => Implant (WindowT s m v) (WindowT t m v) s t where     implant = magnify     {-# INLINABLE implant #-}