glazier 0.8.0.0 → 0.9.0.0

raw patch · 10 files changed

+480/−989 lines, 10 filesdep −profunctorsPVP ok

version bump matches the API change (PVP)

Dependencies removed: profunctors

API changes (from Hackage documentation)

Files

• glazier.cabal +14/−17
• src/Glazier.hs +4/−4
• src/Glazier/Example.hs +29/−29
• src/Glazier/Gadget.hs +127/−0
• src/Glazier/Gadget/Lazy.hs +0/−167
• src/Glazier/Gadget/Strict.hs +0/−167
• src/Glazier/Widget.hs +236/−0
• src/Glazier/Widget/Lazy.hs +0/−254
• src/Glazier/Widget/Strict.hs +0/−254
• src/Glazier/Window.hs +70/−97

@@ -1,5 +1,5 @@ name:                glazier-version:             0.8.0.0+version:             0.9.0.0 synopsis:            Composable widgets framework description:         Please see README.md homepage:            https://github.com/louispan/glazier#readme@@ -15,22 +15,19 @@  library   hs-source-dirs:      src-  exposed-modules:      Glazier-                        Glazier.Class-                        Glazier.Example-                        Glazier.Gadget.Lazy-                        Glazier.Gadget.Strict-                        Glazier.Widget.Lazy-                        Glazier.Widget.Strict-                        Glazier.Window-  build-depends:        base >= 4.7 && < 5-                      , lens >= 4 && < 5-                      , mmorph >= 1 && < 2-                      , mtl >= 2 && <3-                      , semigroupoids >= 5 && < 6-                      , transformers >= 0.4 && < 0.6-                      , profunctors >= 5 && < 6-  ghc-options:         -Wall+  exposed-modules:     Glazier+                       Glazier.Class+                       Glazier.Example+                       Glazier.Gadget+                       Glazier.Widget+                       Glazier.Window+  build-depends:       base >= 4.7 && < 5+                     , lens >= 4 && < 5+                     , mmorph >= 1 && < 2+                     , mtl >= 2 && <3+                     , semigroupoids >= 5 && < 6+                     , transformers >= 0.4 && < 0.6+  ghc-options:        -Wall   default-language:    Haskell2010  source-repository head

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

@@ -13,7 +13,6 @@ import Control.Category import Control.Lens import Control.Monad.Reader-import Data.Foldable import Data.List import Data.Semigroup import Glazier@@ -62,16 +61,16 @@ -- Widget was a w s m c v -- Widget s v m a c optionalExample ::-  ( Monoid v-  , Monoid c-  , Semigroup v+  ( Monoid c+  , Monoid r   , Semigroup c+  , Semigroup r   , AsSet a s   , AsReset a   , AsAction a (Maybe s -> Maybe s)   , Monad m   )-  => Prism' a a' -> Widget m s v m a' c -> Widget m (Maybe s) v m a c+  => Prism' a a' -> Widget v m r a' s m c -> Widget v m r a (Maybe s) m c optionalExample p w =      (      implant _Just -- original update will only work if model is Just@@ -79,9 +78,9 @@      ) w   <> statically mempty -- change mempty to specify a rendering function when Nothing   <> dynamically-    (  dispatch _Set    (review _Gadget $ \a _ -> pure (mempty,Just $ getSet a))-    <> dispatch _Action (review _Gadget $ \(Action f) s -> pure (mempty, f s))-    <> dispatch _Reset  (review _Gadget $ \_ _ -> pure (mempty, Nothing))+    (  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))     )  -- | Transforms a widget into an list widget.@@ -96,30 +95,29 @@ -- modify the state of the head. -- The view will be mempty if Nil. listExample ::-  ( Monoid v+  ( Monoid r   , Monoid c-  , Semigroup v+  , Semigroup r   , Semigroup c   , AsTail a   , AsConsAction a s   , AsAction a ([s] -> [s])   , Monad m   )-  => Prism' b a -> Widget m s v m a c -> Widget m [s] v m b c-listExample p (Widget (Window d) u) =+  => Prism' b a -> Widget v m r a s m c -> Widget v m [r] b [s] m c+listExample p (Widget (WindowT d) g) =      -- Create a list rendering function by-     -- interspercing the separator with the View from the original widget.-     statically (Window . ReaderT $ \ss -> do-                        ss' <- traverse (runReaderT d) ss-                        pure (fold $ intersperse separator ss'))+     -- sequencing the View from the original widget.+     statically (WindowT . ReaderT $ \ss -> do+                        let ms = runReaderT d <$> ss -- [(StateT s m) a]+                        sequenceA ms)   <> dynamically-    (  implant (ix 0) u -- original update will only work on the head of list-    <> dispatch _Tail       (review _Gadget $ \_ s -> pure (mempty, tail s))-    <> dispatch _ConsAction (review _Gadget $ \(ConsAction a) s -> pure (mempty, a : s))-    <> dispatch _Action     (review _Gadget $ \(Action f) s -> pure (mempty, f s))+    (  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- where separator = mempty -- change mempty to specify a rendering function  -- | Transforms a widget into an dictionary widget. -- Given a ordering function, a key function, and a separator rendering function,@@ -129,24 +127,26 @@ -- * 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 v+  ( Monoid r   , Monoid c+  , Monoid (t r)   , Field2 b b a a   , Field1 b b (Index (t s)) (Index (t s))   , Ixed (t s)-  , Semigroup v+  , Semigroup r   , Semigroup c+  , Semigroup (t r)   , AsAction b (t s -> t s)   , IxValue (t s) ~ s   , Monad m   , Traversable t   )-  => Widget m s v m a c -> Widget m (t s) v m b c-indexedExample (Widget (Window d) g) =+  => Widget v m r a s m c -> Widget v m (t r) b (t s) m c+indexedExample (Widget (WindowT d) g) =      -- Create a rendering function by folding the original view function-     statically (Window . ReaderT $ \ss -> do-                        ss' <- traverse (runReaderT d) ss-                        pure (fold ss'))+     statically (WindowT . ReaderT $ \ss -> do+                        let ms = runReaderT d <$> ss -- [(StateT s m) a]+                        sequenceA ms)   <>     dynamically     (@@ -161,5 +161,5 @@          zoom (ix k) (magnify _2 g)        )     <>-      dispatch _Action     (review _Gadget $ \(Action f) s -> pure (mempty, f s))+      dispatch _Action     (review _GadgetT $ \(Action f) s -> pure (mempty, f s))     )

@@ -0,0 +1,127 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Glazier.Gadget where++import Control.Applicative+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.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+               , MonadReader a+               , Monad+               , Applicative+               , Functor+               , Fail.MonadFail+               , Alternative+               , MonadPlus+               , MonadFix+               , MonadIO+               )++makeWrapped ''GadgetT++type Gadget a s = GadgetT a s Identity++_GadgetT :: Iso (GadgetT a s m c) (GadgetT a' s' m' c') (a -> s -> m (c, s)) (a' -> s' -> m' (c', s'))+_GadgetT = _Wrapping GadgetT . iso runReaderT ReaderT . iso (runStateT .) (StateT .)+{-# INLINABLE _GadgetT #-}++-- | Non polymorphic version of _Gadget+_GadgetT' :: Iso' (GadgetT a s m c) (a -> s -> m (c, s))+_GadgetT' = _GadgetT+{-# INLINABLE _GadgetT' #-}++mkGadgetT' :: (a -> s -> m (c, s)) -> GadgetT a s m c+mkGadgetT' = review _GadgetT+{-# INLINABLE mkGadgetT' #-}++runGadgetT' :: GadgetT a s m c -> (a -> s -> m (c, s))+runGadgetT' = view _GadgetT+{-# INLINABLE runGadgetT' #-}++belowGadgetT ::+  ((a -> s -> m (c, s)) -> a' -> s' -> m' (c', s'))+  -> GadgetT a s m c -> GadgetT a' s' m' c'+belowGadgetT f = _GadgetT %~ f+{-# INLINABLE belowGadgetT #-}++underGadgetT+    :: (ReaderT a (StateT s m) c -> ReaderT a' (StateT s' m') c')+    -> GadgetT a s m c+    -> GadgetT a' s' m' c'+underGadgetT f = _Wrapping GadgetT %~ f+{-# INLINABLE underGadgetT #-}++overGadgetT+    :: (GadgetT a s m c -> GadgetT a' s' m' c')+    -> ReaderT a (StateT s m) c+    -> ReaderT a' (StateT s' m') c'+overGadgetT f = _Unwrapping GadgetT %~ f+{-# INLINABLE overGadgetT #-}++aboveGadgetT ::+  (GadgetT a s m c -> GadgetT a' s' m' c')+  -> (a -> s -> m (c, s)) -> a' -> s' -> m' (c', s')+aboveGadgetT f = from _GadgetT %~ f+{-# INLINABLE aboveGadgetT #-}++instance MonadTrans (GadgetT a s) where+    lift = GadgetT . lift . lift++instance MFunctor (GadgetT a s) where+    hoist f (GadgetT m) = GadgetT (hoist (hoist f) m)++instance (Monad m, Semigroup c) => Semigroup (GadgetT a s m c) where+    (GadgetT f) <> (GadgetT g) = GadgetT $ (<>) <$> f <*> g+    {-# INLINABLE (<>) #-}++instance (Monad m, Monoid c) => Monoid (GadgetT a s m c) where+    mempty = GadgetT $ pure mempty+    {-# INLINABLE mempty #-}++    (GadgetT f) `mappend` (GadgetT g) = GadgetT $ mappend <$> f <*> g+    {-# INLINABLE mappend #-}++-- | zoom can be used to modify the state inside an Gadget+type instance Zoomed (GadgetT a s m) = Zoomed (ReaderT a (StateT s m))+instance Monad m => Zoom (GadgetT a s m) (GadgetT a t m) s t where+    zoom l = GadgetT . zoom l . runGadgetT+    {-# INLINABLE zoom #-}++-- | magnify can be used to modify the action inside an Gadget+type instance Magnified (GadgetT a s m) = Magnified (ReaderT a (StateT s m))+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,167 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}--module Glazier.Gadget.Lazy 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.Lazy-import Data.Profunctor-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-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-               )--makeWrapped ''Gadget---- | NB lift can be simulated:--- liftGadget :: (MonadTrans t, Monad m) => Gadget s m a c -> Gadget s (t m) a c--- liftGadget = _Wrapping Gadget %~ hoist (hoist lift)-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)-{-# INLINABLE hoistGadget #-}---- | This Iso gives the following functions:------ @--- underGadget :: (ReaderT a (StateT s m) c -> ReaderT a' (StateT s' m') c') -> Gadget s m a c -> Gadget s' m' a' c'--- underGadget f = _Wrapping Gadget %~ f------ overGadget :: (Gadget s m a c -> Gadget s' m' a' c') -> ReaderT a (StateT s m) c -> ReaderT a' (StateT s' m') c'--- overGadget f = _Unwrapping Gadget %~ f------ belowGadget :: (a -> s -> m (c, s)) (a' -> s' -> m' (c', s')) -> Gadget s m a c -> Gadget s' m' a' c'--- belowGadget f = _Gadget %~ f------ aboveGadget :: (Gadget s m a c -> Gadget s' m' a' c') -> (a -> s -> m (c, s)) (a' -> s' -> m' (c', s'))--- aboveGadget f = from _Gadget %~ f------ mkGadget' :: (a -> s -> m (c, s)) -> Gadget s m a c--- mkGadget' = review _Gadget------ runGadget' :: Gadget s m a c -> (a -> s -> m (c, s))--- runGadget' = view _Gadget--- @----_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 .)-{-# INLINABLE _Gadget #-}---- | Non polymorphic version of _Gadget-_Gadget' :: Iso' (Gadget s m a c) (a -> s -> m (c, s))-_Gadget' = _Gadget-{-# INLINABLE _Gadget' #-}--instance (Monad m, Semigroup c) => Semigroup (Gadget s m a c) where-    (Gadget f) <> (Gadget g) = Gadget $ (<>) <$> f <*> g-    {-# INLINABLE (<>) #-}--instance (Monad m, Monoid c) => Monoid (Gadget s m a c) where-    mempty = Gadget $ pure mempty-    {-# INLINABLE mempty #-}--    (Gadget f) `mappend` (Gadget g) = Gadget $ mappend <$> f <*> g-    {-# INLINABLE mappend #-}--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-    {-# INLINABLE dimap #-}--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-    {-# INLINABLE first' #-}--instance Monad m => C.Category (Gadget s m) where-    id = Gadget $ ReaderT $ \a -> StateT $ \s -> pure (a, s)-    {-# INLINABLE id #-}--    Gadget (ReaderT bc) . Gadget (ReaderT ab) = Gadget $ ReaderT $ \a -> StateT $ \s -> do-        -- This line is the main difference between Strict and Lazy versions-        ~(b, s') <- runStateT (ab a) s-        runStateT (bc b) s'-    {-# INLINABLE (.) #-}--instance Monad m => Arrow (Gadget s m) where-    arr f = dimap f id C.id-    {-# INLINABLE arr #-}--    first = first'-    {-# INLINABLE first #-}--instance Monad m => Choice (Gadget s m) where-    left' (Gadget (ReaderT bc)) = Gadget $ ReaderT $ \db -> StateT $ \s -> case db of-        Left b -> do-            -- This line is the main difference between Strict and Lazy versions-            ~(c, s') <- runStateT (bc b) s-            pure (Left c, s')-        Right d -> pure (Right d, s)-    {-# INLINABLE left' #-}--instance Monad m => ArrowChoice (Gadget s m) where-    left = left'-    {-# INLINABLE left #-}--instance Monad m => ArrowApply (Gadget s m) where-    app = Gadget $ ReaderT $ \(Gadget (ReaderT bc), b) -> StateT $ \s -> runStateT (bc b) s-    {-# INLINABLE app #-}--instance MonadPlus m => ArrowZero (Gadget s m) where-    zeroArrow = Gadget mzero-    {-# INLINABLE zeroArrow #-}--instance MonadPlus m => ArrowPlus (Gadget s m) where-    Gadget a <+> Gadget b = Gadget (a `mplus` b)-    {-# INLINABLE (<+>) #-}---- | zoom can be used to modify the state inside an Gadget-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-    {-# INLINABLE zoom #-}---- | magnify can be used to modify the action inside an Gadget-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-    {-# INLINABLE magnify #-}--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-    {-# INLINABLE implant #-}--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-    {-# INLINABLE dispatch #-}

@@ -1,167 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}--module Glazier.Gadget.Strict 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.Profunctor-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-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-               )--makeWrapped ''Gadget---- | NB lift can be simulated:--- liftGadget :: (MonadTrans t, Monad m) => Gadget s m a c -> Gadget s (t m) a c--- liftGadget = _Wrapping Gadget %~ hoist (hoist lift)-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)-{-# INLINABLE hoistGadget #-}---- | This Iso gives the following functions:------ @--- underGadget :: (ReaderT a (StateT s m) c -> ReaderT a' (StateT s' m') c') -> Gadget s m a c -> Gadget s' m' a' c'--- underGadget f = _Wrapping Gadget %~ f------ overGadget :: (Gadget s m a c -> Gadget s' m' a' c') -> ReaderT a (StateT s m) c -> ReaderT a' (StateT s' m') c'--- overGadget f = _Unwrapping Gadget %~ f------ belowGadget :: (a -> s -> m (c, s)) (a' -> s' -> m' (c', s')) -> Gadget s m a c -> Gadget s' m' a' c'--- belowGadget f = _Gadget %~ f------ aboveGadget :: (Gadget s m a c -> Gadget s' m' a' c') -> (a -> s -> m (c, s)) (a' -> s' -> m' (c', s'))--- aboveGadget f = from _Gadget %~ f------ mkGadget' :: (a -> s -> m (c, s)) -> Gadget s m a c--- mkGadget' = review _Gadget------ runGadget' :: Gadget s m a c -> (a -> s -> m (c, s))--- runGadget' = view _Gadget--- @----_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 .)-{-# INLINABLE _Gadget #-}---- | Non polymorphic version of _Gadget-_Gadget' :: Iso' (Gadget s m a c) (a -> s -> m (c, s))-_Gadget' = _Gadget-{-# INLINABLE _Gadget' #-}--instance (Monad m, Semigroup c) => Semigroup (Gadget s m a c) where-    (Gadget f) <> (Gadget g) = Gadget $ (<>) <$> f <*> g-    {-# INLINABLE (<>) #-}--instance (Monad m, Monoid c) => Monoid (Gadget s m a c) where-    mempty = Gadget $ pure mempty-    {-# INLINABLE mempty #-}--    (Gadget f) `mappend` (Gadget g) = Gadget $ mappend <$> f <*> g-    {-# INLINABLE mappend #-}--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-    {-# INLINABLE dimap #-}--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-    {-# INLINABLE first' #-}--instance Monad m => C.Category (Gadget s m) where-    id = Gadget $ ReaderT $ \a -> StateT $ \s -> pure (a, s)-    {-# INLINABLE id #-}--    Gadget (ReaderT bc) . Gadget (ReaderT ab) = Gadget $ ReaderT $ \a -> StateT $ \s -> do-        -- This line is the main difference between Strict and Lazy versions-        (b, s') <- runStateT (ab a) s-        runStateT (bc b) s'-    {-# INLINABLE (.) #-}--instance Monad m => Arrow (Gadget s m) where-    arr f = dimap f id C.id-    {-# INLINABLE arr #-}--    first = first'-    {-# INLINABLE first #-}--instance Monad m => Choice (Gadget s m) where-    left' (Gadget (ReaderT bc)) = Gadget $ ReaderT $ \db -> StateT $ \s -> case db of-        Left b -> do-            -- This line is the main difference between Strict and Lazy versions-            (c, s') <- runStateT (bc b) s-            pure (Left c, s')-        Right d -> pure (Right d, s)-    {-# INLINABLE left' #-}--instance Monad m => ArrowChoice (Gadget s m) where-    left = left'-    {-# INLINABLE left #-}--instance Monad m => ArrowApply (Gadget s m) where-    app = Gadget $ ReaderT $ \(Gadget (ReaderT bc), b) -> StateT $ \s -> runStateT (bc b) s-    {-# INLINABLE app #-}--instance MonadPlus m => ArrowZero (Gadget s m) where-    zeroArrow = Gadget mzero-    {-# INLINABLE zeroArrow #-}--instance MonadPlus m => ArrowPlus (Gadget s m) where-    Gadget a <+> Gadget b = Gadget (a `mplus` b)-    {-# INLINABLE (<+>) #-}---- | zoom can be used to modify the state inside an Gadget-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-    {-# INLINABLE zoom #-}---- | magnify can be used to modify the action inside an Gadget-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-    {-# INLINABLE magnify #-}--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-    {-# INLINABLE implant #-}--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-    {-# INLINABLE dispatch #-}

@@ -0,0 +1,236 @@+{-# 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 v m r a s n c = Widget+  { window :: WindowT s v m r+  , 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 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 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' = _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' = _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 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' = _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 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' = _WrappingWidget+{-# INLINABLE _WrappingWidget' #-}++mkWidget :: (WindowT s v m r, GadgetT a s n c) -> Widget v m r 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' = review _Widget+{-# INLINABLE mkWidget' #-}++runWidget :: Widget v m r a s n c -> (WindowT s v m r, 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' = 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'+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'+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')+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'))+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+    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+    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 v m r 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 (Monad m, Monad n, Monoid r) => Applicative (Widget v m r 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 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 = 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+    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))+       (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+    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 #-}

@@ -1,254 +0,0 @@-{-# LANGUAGE MonomorphismRestriction #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}--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---- | A widget is basically a tuple with Gadget and Window, but with handy instances for implant and dispatch.-data Widget m s v n a c = Widget-  { window :: Window m s v-  , gadget :: Gadget s n a c-  }---- | polymorphic lens to the window of a widget-_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)---- | polymorphic lens to the gadget of a widget-_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)---- | non polymorphic lens to the window of a widget-_window' :: Lens' (Widget m s v n a c) (Window m s v)-_window' = _window---- | non polymorphic lens to the gadget of a widget-_gadget' :: Lens' (Widget m s v n a c) (Gadget s n a c)-_gadget' = _gadget---- | This Iso gives the following functions:------ @--- belowWidget :: ((s -> m v, a -> s -> m (c, s)) -> (s' -> m' v', a' -> s' -> m' (c', s'))) -> Widget s v m a c -> Widget s' v' m' a' c'--- belowWidget f = _Widget %~ f------ aboveWidget :: (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'))--- aboveWidget f = from _Widget %~ f------ mkWidget' :: (s -> m v, a -> s -> m (c, s)) -> Widget s v m a c--- mkWidget' = review _Widget------ runWidget' :: Widget s v m a c -> (s -> m v, a -> s -> m (c, s))--- runWidget' = view _Widget--- @----_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))-{-# INLINABLE _Widget #-}---- | This Iso gives the following functions:------ @--- underWidget :: ((Window m s v, Gadget s m a c) -> (Window m' s' v', Gadget s' m' a' c')) -> Widget s v m a c -> Widget s' v' m' a' c'--- underWidget f = _WrappingWidget %~ f------ overWidget :: (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')--- overWidget f = from _WrappingWidget %~ f------ mkWidget :: (Window m s v, Gadget s m a c) -> Widget s v m a c--- mkWidget = review _WrappingWidget------ runWidget :: Widget s v m a c -> (Window m s v, Gadget s m a c)--- runWidget = view _WrappingWidget--- @----_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)-{-# INLINABLE _WrappingWidget #-}---- | Non polymorphic version of _WrappingWidget-_WrappingWidget' :: Iso' (Widget m s v n a c) (Window m s v, Gadget s n a c)-_WrappingWidget' = _WrappingWidget-{-# INLINABLE _WrappingWidget' #-}---- | Non polymorphic version of _Widget-_Widget' :: Iso' (Widget m s v n a c) (s -> m v, a -> s -> n (c, s))-_Widget' = _Widget-{-# INLINABLE _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)-    {-# INLINABLE (<>) #-}--instance (Applicative m, Monad n, Monoid c, Monoid v) => Monoid (Widget m s v n a 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 s v n a) 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, Semigroup v, Monoid v) => Applicative (Widget m s v n a) where-    pure c = Widget mempty (pure c)-    {-# INLINABLE pure #-}--    (Widget w1 fg) <*> (Widget w2 g) = Widget (w1 <> w2) (fg <*> g)-    {-# INLINABLE (<*>) #-}--instance (Applicative m, Monad n) => Profunctor (Widget m s v n) where-    dimap f g (Widget w m) = Widget w (dimap f g m)-    {-# INLINABLE dimap #-}--instance (Applicative m, Monad n) => Strong (Widget m s v n) where-    first' (Widget w g) = Widget w (first' g)-    {-# INLINABLE first' #-}--instance (Applicative m, Monad n, Monoid v) => C.Category (Widget m s v n) where-    id = Widget mempty C.id-    {-# INLINABLE id #-}--    Widget wbc gbc . Widget wab gab = Widget-        (wab `mappend` wbc)-        (gbc C.. gab)-    {-# INLINABLE (.) #-}---- | No monad instance for Widget is possible, however an arrow is possible.--- The Arrow instance monoidally appends the Window, and uses the inner Gadget Arrow instance.-instance (Applicative m, Monad n, Monoid v) => Arrow (Widget m s v n) where-    arr f = dimap f id C.id-    {-# INLINABLE arr #-}--    first = first'-    {-# INLINABLE first #-}--instance (Applicative m, Monad n) => Choice (Widget m s v n) where-    left' (Widget w bc) = Widget w (left' bc)-    {-# INLINABLE left' #-}--instance (Applicative m, Monad n, Monoid v) => ArrowChoice (Widget m s v n) where-    left = left'-    {-# INLINABLE left #-}--statically :: (Monad n, Monoid c) => Window m s v -> Widget m s v n a c-statically w = Widget w mempty-{-# INLINABLE statically #-}--dynamically :: (Applicative m, Monad n, Monoid v) => Gadget s n a c -> Widget m s v n a c-dynamically = Widget mempty-{-# INLINABLE dynamically #-}--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)-    {-# INLINABLE dispatch #-}--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)-    {-# 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 #-}

@@ -1,254 +0,0 @@-{-# LANGUAGE MonomorphismRestriction #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}--module Glazier.Widget.Strict-    ( 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.Strict-import Glazier.Window---- | A widget is basically a tuple with Gadget and Window, but with handy instances for implant and dispatch.-data Widget m s v n a c = Widget-  { window :: Window m s v-  , gadget :: Gadget s n a c-  }---- | polymorphic lens to the window of a widget-_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)---- | polymorphic lens to the gadget of a widget-_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)---- | non polymorphic lens to the window of a widget-_window' :: Lens' (Widget m s v n a c) (Window m s v)-_window' = _window---- | non polymorphic lens to the gadget of a widget-_gadget' :: Lens' (Widget m s v n a c) (Gadget s n a c)-_gadget' = _gadget---- | This Iso gives the following functions:------ @--- belowWidget :: ((s -> m v, a -> s -> m (c, s)) -> (s' -> m' v', a' -> s' -> m' (c', s'))) -> Widget s v m a c -> Widget s' v' m' a' c'--- belowWidget f = _Widget %~ f------ aboveWidget :: (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'))--- aboveWidget f = from _Widget %~ f------ mkWidget' :: (s -> m v, a -> s -> m (c, s)) -> Widget s v m a c--- mkWidget' = review _Widget------ runWidget' :: Widget s v m a c -> (s -> m v, a -> s -> m (c, s))--- runWidget' = view _Widget--- @----_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))-{-# INLINABLE _Widget #-}---- | This Iso gives the following functions:------ @--- underWidget :: ((Window m s v, Gadget s m a c) -> (Window m' s' v', Gadget s' m' a' c')) -> Widget s v m a c -> Widget s' v' m' a' c'--- underWidget f = _WrappingWidget %~ f------ overWidget :: (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')--- overWidget f = from _WrappingWidget %~ f------ mkWidget :: (Window m s v, Gadget s m a c) -> Widget s v m a c--- mkWidget = review _WrappingWidget------ runWidget :: Widget s v m a c -> (Window m s v, Gadget s m a c)--- runWidget = view _WrappingWidget--- @----_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)-{-# INLINABLE _WrappingWidget #-}---- | Non polymorphic version of _WrappingWidget-_WrappingWidget' :: Iso' (Widget m s v n a c) (Window m s v, Gadget s n a c)-_WrappingWidget' = _WrappingWidget-{-# INLINABLE _WrappingWidget' #-}---- | Non polymorphic version of _Widget-_Widget' :: Iso' (Widget m s v n a c) (s -> m v, a -> s -> n (c, s))-_Widget' = _Widget-{-# INLINABLE _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)-    {-# INLINABLE (<>) #-}--instance (Applicative m, Monad n, Monoid c, Monoid v) => Monoid (Widget m s v n a 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 s v n a) 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, Semigroup v, Monoid v) => Applicative (Widget m s v n a) where-    pure c = Widget mempty (pure c)-    {-# INLINABLE pure #-}--    (Widget w1 fg) <*> (Widget w2 g) = Widget (w1 <> w2) (fg <*> g)-    {-# INLINABLE (<*>) #-}--instance (Applicative m, Monad n) => Profunctor (Widget m s v n) where-    dimap f g (Widget w m) = Widget w (dimap f g m)-    {-# INLINABLE dimap #-}--instance (Applicative m, Monad n) => Strong (Widget m s v n) where-    first' (Widget w g) = Widget w (first' g)-    {-# INLINABLE first' #-}--instance (Applicative m, Monad n, Monoid v) => C.Category (Widget m s v n) where-    id = Widget mempty C.id-    {-# INLINABLE id #-}--    Widget wbc gbc . Widget wab gab = Widget-        (wab `mappend` wbc)-        (gbc C.. gab)-    {-# INLINABLE (.) #-}---- | No monad instance for Widget is possible, however an arrow is possible.--- The Arrow instance monoidally appends the Window, and uses the inner Gadget Arrow instance.-instance (Applicative m, Monad n, Monoid v) => Arrow (Widget m s v n) where-    arr f = dimap f id C.id-    {-# INLINABLE arr #-}--    first = first'-    {-# INLINABLE first #-}--instance (Applicative m, Monad n) => Choice (Widget m s v n) where-    left' (Widget w bc) = Widget w (left' bc)-    {-# INLINABLE left' #-}--instance (Applicative m, Monad n, Monoid v) => ArrowChoice (Widget m s v n) where-    left = left'-    {-# INLINABLE left #-}--statically :: (Monad n, Monoid c) => Window m s v -> Widget m s v n a c-statically w = Widget w mempty-{-# INLINABLE statically #-}--dynamically :: (Applicative m, Monad n, Monoid v) => Gadget s n a c -> Widget m s v n a c-dynamically = Widget mempty-{-# INLINABLE dynamically #-}--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)-    {-# INLINABLE dispatch #-}--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)-    {-# 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 #-}

@@ -38,32 +38,28 @@ module Glazier.Window where  import Control.Applicative-import Control.Arrow-import qualified Control.Category as C import Control.Lens-import qualified Control.Lens.Internal.Zoom as Z import qualified Control.Monad.Fail as Fail import Control.Monad.Fix (MonadFix) import Control.Monad.Morph import Control.Monad.Reader-import Control.Monad.Zip (MonadZip)-import Data.Profunctor+import Control.Monad.State.Strict import Data.Semigroup import Glazier.Class  -------------------------------------------------------------------------------  -- | The Elm view function is basically @view :: model -> html@--- NB. elm-html is actually @view :: Signal.Address action -> model -> html@--- where @Signal.Address action@ is the Pipes.Concurrent.Output that is sent--- actions (eg. when html button is clicked).--- This address argument is not required in the general case, and is only required for specific widgets on an as needed basis.--- Therefore, using the fundamental type of @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 is named Window instead of View to avoid confusion with view from Control.Lens-newtype Window m s v = Window-    { runWindow :: ReaderT s m v-    } deriving ( MonadReader s+-- 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                , Monad                , Applicative                , Functor@@ -72,108 +68,85 @@                , MonadPlus                , MonadFix                , MonadIO-               , MonadZip                ) -makeWrapped ''Window+makeWrapped ''WindowT --- | NB lift can be simulated:--- liftWindow :: (MonadTrans t, Monad m) => Window m s v -> Window (t m) s v--- liftWindow = hoistWindow lift-hoistWindow :: (Monad m) => (forall a. m a -> n a) -> Window m s v -> Window n s v-hoistWindow g = _Wrapping Window %~ hoist g-{-# INLINABLE hoistWindow #-}+type Window s v = WindowT s v Identity --- | This Iso gives the following functions:------ @--- liftWindow :: (MonadTrans t, Monad m) => Window m s v -> Window (t m) s v--- liftWindow = hoistWindow lift------ underWindow :: (ReaderT s m v -> ReaderT s' m' v') -> Window m s v -> Window m' s' v'--- underWindow f = _Wrapping Window %~ f------ overWindow :: (Window m s v -> Window m' s' v') -> ReaderT s m v -> ReaderT s' m' v'--- overWindow f = _Unwrapping Window %~ f------ belowWindow :: ((s -> m v) -> (s' -> m' v')) -> Window m s v -> Window m' s' v'--- belowWindow f = _Window %~ f------ aboveWindow :: (Window m s v -> Window m' s' v') -> (s -> m v) -> (s' -> m' v')--- aboveWindow f = from _Window %~ f------ mkWindow' :: (s -> m v) -> Window m s v--- mkWindow' = review _Window------ runWindow' :: Window m s v -> (s -> m v)--- runWindow' = view _Window--- @----_Window :: Iso (Window m s v) (Window m' s' v') (s -> m v) (s' -> m' v')-_Window = _Wrapping Window . iso runReaderT ReaderT -- lens 4.15.1 doesn't have a general enough ReaderT iso-{-# INLINABLE _Window #-}+_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 .)+{-# INLINABLE _WindowT #-}  -- | Non polymorphic version of _Window-_Window' :: Iso' (Window m s v) (s -> m v)-_Window' = _Window-{-# INLINABLE _Window' #-}--instance (Applicative m, Semigroup v) => Semigroup (Window m s v) where-    (Window f) <> (Window g) = Window $ ReaderT $ \a ->-        (<>) <$> runReaderT f a <*> runReaderT g a-    {-# INLINABLE (<>) #-}+_WindowT' :: Iso' (WindowT s v m r) (s -> v -> m (r, v))+_WindowT' = _WindowT+{-# INLINABLE _WindowT' #-} -instance (Applicative m, Monoid v) => Monoid (Window m s v) where-    mempty = Window $ ReaderT $ const $ pure mempty-    {-# INLINABLE mempty #-}+mkWindowT' :: (s -> v -> m (r, v)) -> WindowT s v m r+mkWindowT' = review _WindowT+{-# INLINABLE mkWindowT' #-} -    (Window f) `mappend` (Window g) = Window $ ReaderT $ \a ->-        mappend <$> runReaderT f a <*> runReaderT g a-    {-# INLINABLE mappend #-}+runWindowT' :: WindowT s v m r -> (s -> v -> m (r, v))+runWindowT' = view _WindowT+{-# INLINABLE runWindowT' #-} -instance Monad m => Profunctor (Window m) where-    dimap f g = _Window %~ (runKleisli . dimap f g . Kleisli)-    {-# INLINABLE dimap #-}+belowWindowT ::+  ((s -> v -> m (r, v)) -> s' -> v' -> m' (r', v'))+  -> WindowT s v m r -> WindowT s' v' m' r'+belowWindowT f = _WindowT %~ f+{-# INLINABLE belowWindowT #-} -instance Monad m => Strong (Window m) where-    first' = _Window %~ (runKleisli . first' . Kleisli)-    {-# INLINABLE first' #-}+underWindowT+    :: (ReaderT s (StateT v m) r -> ReaderT s' (StateT v' m') r')+    -> WindowT s v m r+    -> WindowT s' v' m' r'+underWindowT f = _Wrapping WindowT %~ f+{-# INLINABLE underWindowT #-} -instance Monad m => C.Category (Window m) where-    id = Window . ReaderT $ runKleisli C.id-    {-# INLINABLE id #-}+overWindowT+    :: (WindowT s v m r -> WindowT s' v' m' r')+    -> ReaderT s (StateT v m) r+    -> ReaderT s' (StateT v' m') r'+overWindowT f = _Unwrapping WindowT %~ f+{-# INLINABLE overWindowT #-} -    Window (ReaderT k) . Window (ReaderT l) = Window . ReaderT . runKleisli $ Kleisli k C.. Kleisli l-    {-# INLINABLE (.) #-}+aboveWindowT ::+  (WindowT s v m r -> WindowT s' v' m' r')+  -> (s -> v -> m (r, v)) -> s' -> v' -> m' (r', v')+aboveWindowT f = from _WindowT %~ f+{-# INLINABLE aboveWindowT #-} -instance Monad m => Arrow (Window m) where-    arr f = Window $ ReaderT $ runKleisli $ arr f-    {-# INLINABLE arr #-}+instance MonadTrans (WindowT s v) where+    lift = WindowT . lift . lift -    first = _Window %~ (runKleisli . first . Kleisli)-    {-# INLINABLE first #-}+instance MFunctor (WindowT s v) where+    hoist f (WindowT m) = WindowT (hoist (hoist f) m) -instance Monad m => Choice (Window m) where-    left' = _Window %~ (runKleisli . left' . Kleisli)-    {-# INLINABLE left' #-}+instance (Monad m, Semigroup r) => Semigroup (WindowT s v m r) where+    (WindowT f) <> (WindowT g) = WindowT $ (<>) <$> f <*> g+    {-# INLINABLE (<>) #-} -instance Monad m => ArrowChoice (Window m) where-    left = _Window %~ (runKleisli . left . Kleisli)-    {-# INLINABLE left #-}+instance (Monad m, Monoid r) => Monoid (WindowT s v m r) where+    mempty = WindowT $ pure mempty+    {-# INLINABLE mempty #-} -instance Monad m => ArrowApply (Window m) where-    app = Window . ReaderT $ \(Window (ReaderT bc), b) -> bc b-    {-# INLINABLE app #-}+    (WindowT f) `mappend` (WindowT g) = WindowT $ mappend <$> f <*> g+    {-# INLINABLE mappend #-} -instance MonadPlus m => ArrowZero (Window m) where-    zeroArrow = Window mzero-    {-# INLINABLE zeroArrow #-}+-- | 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 #-} -instance MonadPlus m => ArrowPlus (Window m) where-    Window a <+> Window b = Window (a `mplus` b)-    {-# INLINABLE (<+>) #-}+-- | 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+    magnify l = WindowT . magnify l . runWindowT+    {-# INLINABLE magnify #-} -type instance Implanted (Window m s v) = Z.Effect m v-instance Monad m => Implant (Window m s v) (Window m t v) s t where-    implant l (Window m) = Window $ magnify l m+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+    implant = magnify     {-# INLINABLE implant #-}