glazier 0.10.0.0 → 0.11.0.0

raw patch · 7 files changed

+40/−330 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• glazier.cabal +1/−3
• src/Glazier.hs +1/−5
• src/Glazier/Class.hs +0/−20
• src/Glazier/Example.hs +38/−43
• src/Glazier/Gadget.hs +0/−13
• src/Glazier/Widget.hs +0/−236
• src/Glazier/Window.hs +0/−10

@@ -1,5 +1,5 @@ name:                glazier-version:             0.10.0.0+version:             0.11.0.0 synopsis:            Composable widgets framework description:         Please see README.md homepage:            https://github.com/louispan/glazier#readme@@ -16,10 +16,8 @@ library   hs-source-dirs:      src   exposed-modules:     Glazier-                       Glazier.Class                        Glazier.Example                        Glazier.Gadget-                       Glazier.Widget                        Glazier.Window   build-depends:       base >= 4.7 && < 5                      , lens >= 4 && < 5

@@ -1,11 +1,7 @@ module Glazier-    ( module Glazier.Class-    , module Glazier.Window+    ( module Glazier.Window     , module Glazier.Gadget-    , module Glazier.Widget     ) where -import Glazier.Class import Glazier.Window import Glazier.Gadget-import Glazier.Widget

@@ -1,20 +0,0 @@-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}--module Glazier.Class where--import Control.Lens---- | Modify the state given a lens, prism or traversal.--- NB. This is 'Control.Lens.Zoom' for Notify.-type family Implanted m :: * -> *-class Implant m n s t | m -> s, n -> t, m t -> n, n s -> m where-    implant :: LensLike' (Implanted m) t s -> m -> n----------------------------------------------------------------------------------type family Dispatched m :: * -> *---- | Changes the action type given a lens, prism or traversal-class Dispatch m n b a | m -> b, n -> a, m a -> n, n b -> m where-    dispatch :: LensLike' (Dispatched m) a b -> m -> n

@@ -71,18 +71,15 @@   , AsAction a (Maybe s -> Maybe s)   , Monad m   )-  => 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-     >>> dispatch p -- make original action part of a smaller action, in preparation of adding other actions below-     ) w-  <> statically mempty -- change mempty to specify a rendering function when Nothing-  <> dynamically-    (  dispatch _Set    (review _GadgetT $ \a _ -> pure (mempty, Just $ getSet a))-    <> dispatch _Action (review _GadgetT $ \(Action f) s -> pure (mempty, f s))-    <> dispatch _Reset  (review _GadgetT $ \_ _ -> pure (mempty, Nothing))-    )+  => Prism' a a' -> (WindowT s m v, GadgetT a' s m c) -> (WindowT (Maybe s) m v, GadgetT a (Maybe s) m c)+optionalExample p (w, g) = (w', g')+  where+    w' = magnify _Just w+    g' =   magnify p (zoom _Just g) -- original action will only work if model is Just+        -- new action handlers+        <> magnify _Set    (review _GadgetT $ \a _ -> pure (mempty, Just $ getSet a))+        <> magnify _Action (review _GadgetT $ \(Action f) s -> pure (mempty, f s))+        <> magnify _Reset  (review _GadgetT $ \_ _ -> pure (mempty, Nothing))  -- | Transforms a widget into an list widget. -- Given a separator rendering widget, and a widget,@@ -105,20 +102,21 @@   , AsAction a ([s] -> [s])   , Monad m   )-  => Prism' b a -> Widget m v a s m c -> Widget m v b [s] m c-listExample p (Widget (WindowT d) g) =+  => Prism' b a -> (WindowT s m v, GadgetT a s m c) -> (WindowT [s] m v, GadgetT b [s] m c)+listExample p (WindowT d, g) = (w', g')+  where      -- Create a list rendering function by      -- sequencing the View from the original widget.-     statically (WindowT . ReaderT $ \ss -> do+    w' = WindowT . ReaderT $ \ss -> do                         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))-    <> dispatch _ConsAction (review _GadgetT $ \(ConsAction a) s -> pure (mempty, a : s))-    <> dispatch _Action     (review _GadgetT $ \(Action f) s -> pure (mempty, f s))-    )-  & dispatch p -- make original action part of a smaller action+                        pure (fold ss')+    g' = magnify p (+            zoom (ix 0) g -- original action will only work on the head of list+            -- new action handlers+            <> magnify _Tail       (review _GadgetT $ \_ s -> pure (mempty, tail s))+            <> magnify _ConsAction (review _GadgetT $ \(ConsAction a) s -> pure (mempty, a : s))+            <> magnify _Action     (review _GadgetT $ \(Action f) s -> pure (mempty, f s))+        )  -- | Transforms a widget into an dictionary widget. -- Given a ordering function, a key function, and a separator rendering function,@@ -140,25 +138,22 @@   , Monad m   , Traversable t   )-  => Widget m v a s m c -> Widget m v b (t s) m c-indexedExample (Widget (WindowT d) g) =+  => (WindowT s m v, GadgetT a s m c) -> (WindowT (t s) m v, GadgetT b (t s) m c)+indexedExample (WindowT d, g) = (w', g')+  where      -- Create a rendering function by folding the original view function-     statically (WindowT . ReaderT $ \ss -> do+    w' = WindowT . ReaderT $ \ss -> do                         ss' <- traverse (runReaderT d) ss-                        pure (fold ss'))-  <>-    dynamically-    (-       -- This effectively dispatches the Update-       -- ie the action type has changed-       -- so a @dispatch prism@ is not required-       (do-         x <- ask-         let k = x ^. _1-             -- a = x ^. _2-         -- run u but for a state implanted by ix k-         zoom (ix k) (magnify _2 g)-       )-    <>-      dispatch _Action     (review _GadgetT $ \(Action f) s -> pure (mempty, f s))-    )+                        pure (fold ss')++    -- This effectively dispatches the Update+    -- ie the action type has changed+    -- so a @dispatch prism@ is not required+    g' = (do+             x <- ask+             let k = x ^. _1+                 -- a = x ^. _2+             -- run u but for a state implanted by ix k+             zoom (ix k) (magnify _2 g)+         )+         <> magnify _Action     (review _GadgetT $ \(Action f) s -> pure (mempty, f s))

@@ -17,15 +17,12 @@ import Control.Monad.Reader import Control.Monad.State.Strict import Data.Semigroup-import Glazier.Class  -- | The Elm update function is @a -> s -> (s, c)@ -- This is isomorphic to @ReaderT a (State s) c@ -- ie, given an action "a", and a current state "s", return the new state "s" -- and any commands "c" that need to be interpreted externally (eg. download file). -- This is named Gadget instead of Update to avoid confusion with update from Data.Map--- NB. This is the same formulation as 'Glaizer.Window'.--- The only difference is that Gadget has both 'Implant' and 'Dispatch' instances. newtype GadgetT a s m c = GadgetT     { runGadgetT :: ReaderT a (StateT s m) c     } deriving ( MonadState s@@ -115,13 +112,3 @@ instance Monad m => Magnify (GadgetT a s m) (GadgetT b s m) a b where     magnify l = GadgetT . magnify l . runGadgetT     {-# INLINABLE magnify #-}--type instance Implanted (GadgetT a s m c) = Zoomed (GadgetT a s m) c-instance Monad m => Implant (GadgetT a s m c) (GadgetT a t m c) s t where-    implant = zoom-    {-# INLINABLE implant #-}--type instance Dispatched (GadgetT a s m c) = Magnified (GadgetT a s m) c-instance Monad m => Dispatch (GadgetT a s m c) (GadgetT b s m c) a b where-    dispatch = magnify-    {-# INLINABLE dispatch #-}

@@ -1,236 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}--module Glazier.Widget-    ( Widget(..)-    , _window-    , _gadget-    , _window'-    , _gadget'-    , _Widget-    , _Widget'-    , _WrappingWidget-    , _WrappingWidget'-    , belowWidget-    , underWidget-    , overWidget-    , aboveWidget-    , mkWidget-    , mkWidget'-    , runWidget-    , runWidget'-    , statically-    , dynamically-    ) where--import Control.Applicative-import Control.Lens-import Data.Functor.Apply-import Data.Maybe-import Data.Semigroup-import Glazier.Class-import Glazier.Gadget-import Glazier.Window---- | A widget is basically a tuple with Gadget and Window, but with handy instances for implant and dispatch.-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 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 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 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 m v a s n c) (GadgetT a s n c)-_gadget' = _gadget-{-# INLINABLE _gadget' #-}--_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 m v a s n c) (s -> m v, a -> s -> n (c, s))-_Widget' = _Widget-{-# INLINABLE _Widget' #-}--_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 m v a s n c) (WindowT s m v, GadgetT a s n c)-_WrappingWidget' = _WrappingWidget-{-# INLINABLE _WrappingWidget' #-}--mkWidget :: (WindowT s m v, GadgetT a s n c) -> Widget m v a s n c-mkWidget = review _WrappingWidget-{-# INLINABLE mkWidget #-}--mkWidget' :: (s -> m v, a -> s -> n (c, s)) -> Widget m v a s n c-mkWidget' = review _Widget-{-# INLINABLE mkWidget' #-}--runWidget :: Widget m v a s n c -> (WindowT s m v, GadgetT a s n c)-runWidget = view _WrappingWidget-{-# INLINABLE runWidget #-}--runWidget' :: Widget m v a s n c -> (s -> m v, a -> s -> n (c, s))-runWidget' = view _Widget-{-# INLINABLE runWidget' #-}--belowWidget ::-  ((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 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 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 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 (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 (Applicative m, Monad n, Monoid v, Monoid c) => Monoid (Widget m v a s n c) where-    mempty = Widget mempty mempty-    {-# INLINABLE mempty #-}--    mappend w1 w2 = Widget-        (window w1 `mappend` window w2)-        (gadget w1 `mappend` gadget w2)-    {-# INLINABLE mappend #-}---- | Widget Functor is lawful--- 1: fmap id  =  id--- (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 m v a s n) where-    fmap f (Widget w g) = Widget-        w-        (f <$> g)-    {-# INLINABLE fmap #-}---- | Widget Applicative is lawful--- Identity: pure id <*> v = v--- Widget mempty (pure id) <*> Widget vw vg---     = Widget (mempty <> vw) (pure id <*> vg)---     = Widget vw vg--- Composition: pure (.) <*> u <*> v <*> w = u <*> (v <*> w)--- Widget mempty (pure (.)) <*> Widget uw ug <*> Widget vw vg <*> Widget ww wg =---     = Widget (mempty <> uw <> vw <> ww) (pure (.) <*> ug <*> vg <*> wg---     = Widget (uw <> vw <> ww) (ug <*> (vg <*> wg))---     = Widget (uw <> (vw <> ww)) (ug <*> (vg <*> wg))---     = Widget uw ug <*> (Widget vw vg <*> Widget ww wg)--- Interchange: u <*> pure y = pure ($ y) <*> u--- Widget uw ug <*> Widget mempty (pure y)---     = Widget (uw <> mempty) (ug <*> pure y)---     = Widget (mempty <> uw) (pure ($ y) <*> ug)---     = Widget mempty (pure $y) <*> Widget uw ug-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 m v -> Widget m v a s n c-statically w = Widget w mempty-{-# INLINABLE statically #-}--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 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 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 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)-    {-# INLINABLE implant #-}---- ----------------------------------------------------------------------------------- | This can be used to hold two LensLike functors.--- The inner LensLike functor can be extracted from a @LensLike (PairMaybeFunctor f g) s t a b@--- using 'fstLensLike' or 'sndLensLike'.--- NB. The constructor must not be exported to keep 'fstLensLike' and 'sndLensLike' safe.-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)-    {-# INLINABLE fmap #-}--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)-    {-# INLINABLE (<.>) #-}--instance (Applicative f, Applicative g) => Applicative (PairMaybeFunctor f g) where-    pure a = PairMaybeFunctor (Just $ pure a, Just $ pure a)-    {-# INLINABLE pure #-}--    (PairMaybeFunctor (a, b)) <*> (PairMaybeFunctor (c, d)) = PairMaybeFunctor (liftA2 (<*>) a c, liftA2 (<*>) b d)-    {-# INLINABLE (<*>) #-}--instance (Contravariant f, Contravariant g) => Contravariant (PairMaybeFunctor f g) where-    contramap f (PairMaybeFunctor (a, b)) = PairMaybeFunctor (contramap f <$> a, contramap f <$> b)-    {-# INLINABLE contramap #-}--fstLensLike :: LensLike (PairMaybeFunctor f g) s t a b -> LensLike f s t a b--- fromJust is safe here as the constructor is hidden and we've definitely filled in the fst item of PairMaybeFunctor-fstLensLike l f b = fromJust . fst . getPairMaybeFunctor $ l (\a -> PairMaybeFunctor (Just $ f a, Nothing)) b-{-# INLINABLE fstLensLike #-}--sndLensLike :: LensLike (PairMaybeFunctor f g) s t a b -> LensLike g s t a b--- fromJust is safe here as the constructor is hidden and we've definitely filled in the snd item of PairMaybeFunctor-sndLensLike l f b = fromJust . snd . getPairMaybeFunctor $ l (\a -> PairMaybeFunctor (Nothing, Just $ f a)) b-{-# INLINABLE sndLensLike #-}

@@ -31,10 +31,6 @@ -- This module uses isomorphic Window and Gadget resulting in instances can be be composed together into larger Widgets. -- Original inspiration from https://arianvp.me/lenses-and-prisms-for-modular-clientside-apps/ ----- This framework provides three main combinators:--- * Semigroup and Monoid instances for concatenating widgets.--- * 'dispatch' is used to re-route the action type.--- * 'implant' is used to modify the model type. module Glazier.Window where  import Control.Applicative@@ -44,7 +40,6 @@ import Control.Monad.Morph import Control.Monad.Reader import Data.Semigroup-import Glazier.Class  ------------------------------------------------------------------------------- @@ -133,8 +128,3 @@ 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 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 #-}