Hello community, here is the log from the commit of package ghc-glazier for openSUSE:Factory checked in at 2017-08-31 20:51:13 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-glazier (Old) and /work/SRC/openSUSE:Factory/.ghc-glazier.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-glazier" Thu Aug 31 20:51:13 2017 rev:2 rq:513256 version:0.11.0.1 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-glazier/ghc-glazier.changes 2017-04-14 13:35:22.899228755 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-glazier.new/ghc-glazier.changes 2017-08-31 20:51:15.303314673 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:57 UTC 2017 - psimons@suse.com + +- Update to version 0.11.0.1. + +------------------------------------------------------------------- Old: ---- glazier-0.7.0.0.tar.gz New: ---- glazier-0.11.0.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-glazier.spec ++++++ --- /var/tmp/diff_new_pack.byzkDO/_old 2017-08-31 20:51:17.539000846 +0200 +++ /var/tmp/diff_new_pack.byzkDO/_new 2017-08-31 20:51:17.539000846 +0200 @@ -18,9 +18,9 @@ %global pkg_name glazier Name: ghc-%{pkg_name} -Version: 0.7.0.0 +Version: 0.11.0.1 Release: 0 -Summary: Composable widgets framework +Summary: Composable widgets framework with enhanced with transformers and lens License: BSD-3-Clause Group: Development/Languages/Other Url: https://hackage.haskell.org/package/%{pkg_name} @@ -29,7 +29,6 @@ BuildRequires: ghc-lens-devel BuildRequires: ghc-mmorph-devel BuildRequires: ghc-mtl-devel -BuildRequires: ghc-profunctors-devel BuildRequires: ghc-rpm-macros BuildRequires: ghc-semigroupoids-devel BuildRequires: ghc-transformers-devel ++++++ glazier-0.7.0.0.tar.gz -> glazier-0.11.0.1.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/glazier-0.7.0.0/glazier.cabal new/glazier-0.11.0.1/glazier.cabal --- old/glazier-0.7.0.0/glazier.cabal 2017-02-02 11:07:44.000000000 +0100 +++ new/glazier-0.11.0.1/glazier.cabal 2017-03-13 23:10:19.000000000 +0100 @@ -1,36 +1,30 @@ name: glazier -version: 0.7.0.0 -synopsis: Composable widgets framework -description: Please see README.md +version: 0.11.0.1 +synopsis: Composable widgets framework with enhanced with transformers and lens. +description: Elm-like Action/Model/View/Update framework powered by typeclasses, monad transformers, and lens. homepage: https://github.com/louispan/glazier#readme license: BSD3 license-file: LICENSE author: Louis Pan maintainer: louis@pan.me copyright: 2016 Louis Pan -category: FRP +category: FRP, GUI build-type: Simple cabal-version: >=1.10 tested-with: GHC == 8.0.1 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.Gadget + 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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/glazier-0.7.0.0/src/Glazier/Class.hs new/glazier-0.11.0.1/src/Glazier/Class.hs --- old/glazier-0.7.0.0/src/Glazier/Class.hs 2017-02-02 11:02:17.000000000 +0100 +++ new/glazier-0.11.0.1/src/Glazier/Class.hs 1970-01-01 01:00:00.000000000 +0100 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/glazier-0.7.0.0/src/Glazier/Example.hs new/glazier-0.11.0.1/src/Glazier/Example.hs --- old/glazier-0.7.0.0/src/Glazier/Example.hs 2017-02-02 11:07:21.000000000 +0100 +++ new/glazier-0.11.0.1/src/Glazier/Example.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,165 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} - --- | This contains examples of general widget transformation functions. -module Glazier.Example where - -import Control.Category -import Control.Lens -import Control.Monad.Reader -import Data.Foldable -import Data.List -import Data.Semigroup -import Glazier -import Prelude hiding (id, (.)) - -newtype Action a = Action { getAction :: a } -class AsAction s a | s -> a where - _Action :: Prism' s (Action a) -instance AsAction (Action a) a where - _Action = id - -newtype ConsAction a = ConsAction { getConsAction :: a } -class AsConsAction s a | s -> a where - _ConsAction :: Prism' s (ConsAction a) -instance AsConsAction (ConsAction a) a where - _ConsAction = id - -data Reset = Reset -class AsReset s where - _Reset :: Prism' s Reset -instance AsReset Reset where - _Reset = id - -data Tail = Tail -class AsTail s where - _Tail :: Prism' s Tail -instance AsTail Tail where - _Tail = id - -newtype Set a = Set { getSet :: a } -class AsSet s a | s -> a where - _Set :: Prism' s (Set a) -instance AsSet (Set a) a where - _Set = id - --- | Transforms a widget into an optional widget. --- This wraps the original model inside a Maybe. --- The new action is now a sum type that contains the additional actions: --- * A Reset action --- * A Set action --- * A mapping action --- * The original action --- The original action is wrapped using the given prism and will only --- modify the state if the preview of the prism is not Nothing. --- The view will be mempty if the model is Nothing. --- Widget was a w s m c v --- Widget s v m a c -optionalExample :: - ( Monoid v - , Monoid c - , Semigroup v - , Semigroup c - , AsSet a s - , AsReset a - , AsAction a (Maybe s -> Maybe s) - , Monad m - ) - => Prism' a a' -> Widget s v m a' c -> Widget (Maybe s) v m a 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 _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)) - ) - --- | Transforms a widget into an list widget. --- Given a separator rendering widget, and a widget, --- this wraps the original model inside a list. --- The new action is now a sum type that contains the additional actions: --- * A Tail action --- * A Cons action --- * A mapping action --- * The original action --- The original action is wrapped using the given prism and will only --- modify the state of the head. --- The view will be mempty if Nil. -listExample :: - ( Monoid v - , Monoid c - , Semigroup v - , Semigroup c - , AsTail a - , AsConsAction a s - , AsAction a ([s] -> [s]) - , Monad m - ) - => Prism' b a -> Widget s v m a c -> Widget [s] v m b c -listExample p (Widget (Window d) u) = - -- 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')) - <> 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)) - ) - & 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, --- allows a dictionary of k to Widget. --- The new action is now a sum type that contains the additional actions: --- * A mapping action --- * 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 c - , Field2 b b a a - , Field1 b b (Index (t s)) (Index (t s)) - , Ixed (t s) - , Semigroup v - , Semigroup c - , AsAction b (t s -> t s) - , IxValue (t s) ~ s - , Monad m - , Traversable t - ) - => Widget s v m a c -> Widget (t s) v m b c -indexedExample (Widget (Window 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')) - <> - 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 _Gadget $ \(Action f) s -> pure (mempty, f s)) - ) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/glazier-0.7.0.0/src/Glazier/Gadget/Lazy.hs new/glazier-0.11.0.1/src/Glazier/Gadget/Lazy.hs --- old/glazier-0.7.0.0/src/Glazier/Gadget/Lazy.hs 2017-02-02 11:05:42.000000000 +0100 +++ new/glazier-0.11.0.1/src/Glazier/Gadget/Lazy.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,173 +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 - ) - -class HasGadget s a | s -> a where - gadget :: Lens' s a - -instance HasGadget (Gadget s m a c) (Gadget s m a c) where - gadget = id - -makeWrapped ''Gadget - --- | 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 #-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/glazier-0.7.0.0/src/Glazier/Gadget/Strict.hs new/glazier-0.11.0.1/src/Glazier/Gadget/Strict.hs --- old/glazier-0.7.0.0/src/Glazier/Gadget/Strict.hs 2017-02-02 11:05:50.000000000 +0100 +++ new/glazier-0.11.0.1/src/Glazier/Gadget/Strict.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,173 +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 - ) - -class HasGadget s a | s -> a where - gadget :: Lens' s a - -instance HasGadget (Gadget s m a c) (Gadget s m a c) where - gadget = id - -makeWrapped ''Gadget - --- | 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 #-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/glazier-0.7.0.0/src/Glazier/Gadget.hs new/glazier-0.11.0.1/src/Glazier/Gadget.hs --- old/glazier-0.7.0.0/src/Glazier/Gadget.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/glazier-0.11.0.1/src/Glazier/Gadget.hs 2017-02-21 23:12:38.000000000 +0100 @@ -0,0 +1,114 @@ +{-# 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 + +-- | 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 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 #-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/glazier-0.7.0.0/src/Glazier/Widget/Lazy.hs new/glazier-0.11.0.1/src/Glazier/Widget/Lazy.hs --- old/glazier-0.7.0.0/src/Glazier/Widget/Lazy.hs 2017-02-02 11:07:12.000000000 +0100 +++ new/glazier-0.11.0.1/src/Glazier/Widget/Lazy.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,245 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -module Glazier.Widget.Lazy - ( Widget(..) - , _Widget - , _Widget' - , _WrappingWidget - , _WrappingWidget' - , hoistWidget - , 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. -data Widget s v m a c = Widget - { widgetWindow :: Window m s v - , widgetGadget :: Gadget s m a c - } - -makeFields ''Widget - --- | 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 s v m a c) (Widget s' v' m' a' c') - (s -> m v, a -> s -> m (c, s)) (s' -> m' v', a' -> s' -> m' (c', s')) -_Widget = iso (\(Widget w g) -> (view _Window w, view _Gadget g)) - (\(w, g) -> Widget (review _Window w) (review _Gadget g)) -{-# 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 s v m a c) (Widget s' v' m' a' c') - (Window m s v, Gadget s m a c) (Window m' s' v', Gadget s' m' a' c') -_WrappingWidget = iso (\(Widget w g) -> (w, g)) - (\(w, g) -> Widget w g) -{-# INLINABLE _WrappingWidget #-} - --- | Non polymorphic version of _WrappingWidget -_WrappingWidget' :: Iso' (Widget s v m a c) (Window m s v, Gadget s m a c) -_WrappingWidget' = _WrappingWidget -{-# INLINABLE _WrappingWidget' #-} - --- | Non polymorphic version of _Widget -_Widget' :: Iso' (Widget s v m a c) (s -> m v, a -> s -> m (c, s)) -_Widget' = _Widget -{-# INLINABLE _Widget' #-} - --- | NB lift can be simulated: --- liftWidget :: (MonadTrans t, Monad m) => Widget s v m a c -> Widget s v (t m) a c --- liftWidget = hoistWidget lift -hoistWidget :: (Monad m) => (forall x. m x -> n x) -> Widget s v m a c -> Widget s v n a c --- hoistWidget f (Widget w g) = Widget (hoistWindow f w) (hoistGadget f g) -hoistWidget f = _WrappingWidget %~ \(w, g) -> (hoistWindow f w, hoistGadget f g) -{-# INLINABLE hoistWidget #-} - -instance (Monad m, Semigroup c, Semigroup v) => Semigroup (Widget s v m a c) where - w1 <> w2 = Widget - (widgetWindow w1 <> widgetWindow w2) - (widgetGadget w1 <> widgetGadget w2) - {-# INLINABLE (<>) #-} - -instance (Monad m, Monoid c, Monoid v) => Monoid (Widget s v m a c) where - mempty = Widget mempty mempty - {-# INLINABLE mempty #-} - - mappend w1 w2 = Widget - (widgetWindow w1 `mappend` widgetWindow w2) - (widgetGadget w1 `mappend` widgetGadget 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 m => Functor (Widget s v m 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 (Semigroup v, Monad m, Monoid v) => Applicative (Widget s v m a) where - pure c = Widget mempty (pure c) - {-# INLINABLE pure #-} - - (Widget w1 fg) <*> (Widget w2 g) = Widget (w1 <> w2) (fg <*> g) - {-# INLINABLE (<*>) #-} - -instance Monad m => Profunctor (Widget s v m) where - dimap f g (Widget w m) = Widget w (dimap f g m) - {-# INLINABLE dimap #-} - -instance Monad m => Strong (Widget s v m) where - first' (Widget w g) = Widget w (first' g) - {-# INLINABLE first' #-} - -instance (Monad m, Monoid v) => C.Category (Widget s v m) 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 (Monad m, Monoid v) => Arrow (Widget s v m) where - arr f = dimap f id C.id - {-# INLINABLE arr #-} - - first = first' - {-# INLINABLE first #-} - -instance (Monad m) => Choice (Widget s v m) where - left' (Widget w bc) = Widget w (left' bc) - {-# INLINABLE left' #-} - -instance (Monad m, Monoid v) => ArrowChoice (Widget s v m) where - left = left' - {-# INLINABLE left #-} - -statically :: (Monad m, Monoid c) => Window m s v -> Widget s v m a c -statically w = Widget w mempty -{-# INLINABLE statically #-} - -dynamically :: (Monad m, Monoid v) => Gadget s m a c -> Widget s v m a c -dynamically = Widget mempty -{-# INLINABLE dynamically #-} - -type instance Dispatched (Widget s v m a c) = Dispatched (Gadget s m a c) -instance Monad m => Dispatch (Widget s v m a c) (Widget s v m b c) a b where - dispatch p w = Widget - (widgetWindow w) - (dispatch p $ widgetGadget w) - {-# INLINABLE dispatch #-} - -type instance Implanted (Widget s v m a c) = - PairMaybeFunctor (Implanted (Gadget s m a c)) - (Implanted (Window m s v)) -instance Monad m => Implant (Widget s v m a c) (Widget t v m a c) s t where - implant l w = Widget - (implant (sndLensLike l) $ widgetWindow w) - (implant (fstLensLike l) $ widgetGadget w) - {-# 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 #-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/glazier-0.7.0.0/src/Glazier/Widget/Strict.hs new/glazier-0.11.0.1/src/Glazier/Widget/Strict.hs --- old/glazier-0.7.0.0/src/Glazier/Widget/Strict.hs 2017-02-02 11:06:46.000000000 +0100 +++ new/glazier-0.11.0.1/src/Glazier/Widget/Strict.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,245 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -module Glazier.Widget.Strict - ( Widget(..) - , _Widget - , _Widget' - , _WrappingWidget - , _WrappingWidget' - , hoistWidget - , 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. -data Widget s v m a c = Widget - { widgetWindow :: Window m s v - , widgetGadget :: Gadget s m a c - } - -makeFields ''Widget - --- | 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 s v m a c) (Widget s' v' m' a' c') - (s -> m v, a -> s -> m (c, s)) (s' -> m' v', a' -> s' -> m' (c', s')) -_Widget = iso (\(Widget w g) -> (view _Window w, view _Gadget g)) - (\(w, g) -> Widget (review _Window w) (review _Gadget g)) -{-# 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 s v m a c) (Widget s' v' m' a' c') - (Window m s v, Gadget s m a c) (Window m' s' v', Gadget s' m' a' c') -_WrappingWidget = iso (\(Widget w g) -> (w, g)) - (\(w, g) -> Widget w g) -{-# INLINABLE _WrappingWidget #-} - --- | Non polymorphic version of _WrappingWidget -_WrappingWidget' :: Iso' (Widget s v m a c) (Window m s v, Gadget s m a c) -_WrappingWidget' = _WrappingWidget -{-# INLINABLE _WrappingWidget' #-} - --- | Non polymorphic version of _Widget -_Widget' :: Iso' (Widget s v m a c) (s -> m v, a -> s -> m (c, s)) -_Widget' = _Widget -{-# INLINABLE _Widget' #-} - --- | NB lift can be simulated: --- liftWidget :: (MonadTrans t, Monad m) => Widget s v m a c -> Widget s v (t m) a c --- liftWidget = hoistWidget lift -hoistWidget :: (Monad m) => (forall x. m x -> n x) -> Widget s v m a c -> Widget s v n a c --- hoistWidget f (Widget w g) = Widget (hoistWindow f w) (hoistGadget f g) -hoistWidget f = _WrappingWidget %~ \(w, g) -> (hoistWindow f w, hoistGadget f g) -{-# INLINABLE hoistWidget #-} - -instance (Monad m, Semigroup c, Semigroup v) => Semigroup (Widget s v m a c) where - w1 <> w2 = Widget - (widgetWindow w1 <> widgetWindow w2) - (widgetGadget w1 <> widgetGadget w2) - {-# INLINABLE (<>) #-} - -instance (Monad m, Monoid c, Monoid v) => Monoid (Widget s v m a c) where - mempty = Widget mempty mempty - {-# INLINABLE mempty #-} - - mappend w1 w2 = Widget - (widgetWindow w1 `mappend` widgetWindow w2) - (widgetGadget w1 `mappend` widgetGadget 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 m => Functor (Widget s v m 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 (Semigroup v, Monad m, Monoid v) => Applicative (Widget s v m a) where - pure c = Widget mempty (pure c) - {-# INLINABLE pure #-} - - (Widget w1 fg) <*> (Widget w2 g) = Widget (w1 <> w2) (fg <*> g) - {-# INLINABLE (<*>) #-} - -instance Monad m => Profunctor (Widget s v m) where - dimap f g (Widget w m) = Widget w (dimap f g m) - {-# INLINABLE dimap #-} - -instance Monad m => Strong (Widget s v m) where - first' (Widget w g) = Widget w (first' g) - {-# INLINABLE first' #-} - -instance (Monad m, Monoid v) => C.Category (Widget s v m) 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 (Monad m, Monoid v) => Arrow (Widget s v m) where - arr f = dimap f id C.id - {-# INLINABLE arr #-} - - first = first' - {-# INLINABLE first #-} - -instance (Monad m) => Choice (Widget s v m) where - left' (Widget w bc) = Widget w (left' bc) - {-# INLINABLE left' #-} - -instance (Monad m, Monoid v) => ArrowChoice (Widget s v m) where - left = left' - {-# INLINABLE left #-} - -statically :: (Monad m, Monoid c) => Window m s v -> Widget s v m a c -statically w = Widget w mempty -{-# INLINABLE statically #-} - -dynamically :: (Monad m, Monoid v) => Gadget s m a c -> Widget s v m a c -dynamically = Widget mempty -{-# INLINABLE dynamically #-} - -type instance Dispatched (Widget s v m a c) = Dispatched (Gadget s m a c) -instance Monad m => Dispatch (Widget s v m a c) (Widget s v m b c) a b where - dispatch p w = Widget - (widgetWindow w) - (dispatch p $ widgetGadget w) - {-# INLINABLE dispatch #-} - -type instance Implanted (Widget s v m a c) = - PairMaybeFunctor (Implanted (Gadget s m a c)) - (Implanted (Window m s v)) -instance Monad m => Implant (Widget s v m a c) (Widget t v m a c) s t where - implant l w = Widget - (implant (sndLensLike l) $ widgetWindow w) - (implant (fstLensLike l) $ widgetGadget w) - {-# 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 #-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/glazier-0.7.0.0/src/Glazier/Window.hs new/glazier-0.11.0.1/src/Glazier/Window.hs --- old/glazier-0.7.0.0/src/Glazier/Window.hs 2017-02-02 10:58:11.000000000 +0100 +++ new/glazier-0.11.0.1/src/Glazier/Window.hs 2017-03-18 14:37:37.000000000 +0100 @@ -9,60 +9,23 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} --- | Functional version of (Elm View/Update & startApp architecture) enabling composable widgets, and a FRP-like framework. --- --- This framework makes it easier to modularize the Elm architecture idea of View/Update: --- based on the deprecated Elm Architecture version of Jan 2016 --- https://github.com/evancz/elm-architecture-tutorial/tree/de5682a5a8e4459aed4... --- --- The Elm View/Update is basically as follows: --- --- @ --- data Model = Blah.... --- data Action = DoThis | DoThat deriving Show --- --- -- | update is fired from an event processing loop --- update :: Action -> Model -> Model --- --- -- | The widget from 'view' knows how to send Action to a mailbox --- view :: Signal Address -> Model -> Html --- @ --- --- 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 -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 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. +-- This can be enhanced with monadic effects with ReaderT. -- 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 +newtype WindowT s m v = WindowT + { runWindowT :: ReaderT s m v } deriving ( MonadReader s , Monad , Applicative @@ -72,113 +35,74 @@ , MonadPlus , MonadFix , MonadIO - , MonadZip ) -class HasWindow s a | s -> a where - window :: Lens' s a -instance HasWindow (Window m s v) (Window m s v) where - window = id +makeWrapped ''WindowT -makeWrapped ''Window +type Window s = WindowT s Identity --- | 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 #-} - --- | 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 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 -_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 +_WindowT' :: Iso' (WindowT s m v) (s -> m v) +_WindowT' = _WindowT +{-# INLINABLE _WindowT' #-} + +mkWindowT' :: (s -> m v) -> WindowT s m v +mkWindowT' = review _WindowT +{-# INLINABLE mkWindowT' #-} + +runWindowT' :: WindowT s m v -> (s -> m v) +runWindowT' = view _WindowT +{-# INLINABLE runWindowT' #-} + +belowWindowT :: + ((s -> m v) -> (s' -> m' v')) + -> WindowT s m v -> WindowT s' m' v' +belowWindowT f = _WindowT %~ f +{-# INLINABLE belowWindowT #-} + +underWindowT + :: (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 m v -> WindowT s' m' v') + -> ReaderT s m v + -> ReaderT s' m' v' +overWindowT f = _Unwrapping WindowT %~ f +{-# INLINABLE overWindowT #-} + +aboveWindowT :: + (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) where + lift = WindowT . lift + +instance MFunctor (WindowT s) where + hoist f (WindowT m) = WindowT (hoist f m) + +instance (Applicative m, Semigroup v) => Semigroup (WindowT s m v) where + (WindowT f) <> (WindowT g) = WindowT $ (<>) <$> f <*> g {-# INLINABLE (<>) #-} -instance (Applicative m, Monoid v) => Monoid (Window m s v) where - mempty = Window $ ReaderT $ const $ pure mempty +instance (Applicative m, Monoid v) => Monoid (WindowT s m v) where + mempty = WindowT $ pure mempty {-# INLINABLE mempty #-} - (Window f) `mappend` (Window g) = Window $ ReaderT $ \a -> - mappend <$> runReaderT f a <*> runReaderT g a + (WindowT f) `mappend` (WindowT g) = WindowT $ mappend <$> f <*> g {-# INLINABLE mappend #-} -instance Monad m => Profunctor (Window m) where - dimap f g = _Window %~ (runKleisli . dimap f g . Kleisli) - {-# INLINABLE dimap #-} - -instance Monad m => Strong (Window m) where - first' = _Window %~ (runKleisli . first' . Kleisli) - {-# INLINABLE first' #-} - -instance Monad m => C.Category (Window m) where - id = Window . ReaderT $ runKleisli C.id - {-# INLINABLE id #-} - - Window (ReaderT k) . Window (ReaderT l) = Window . ReaderT . runKleisli $ Kleisli k C.. Kleisli l - {-# INLINABLE (.) #-} - -instance Monad m => Arrow (Window m) where - arr f = Window $ ReaderT $ runKleisli $ arr f - {-# INLINABLE arr #-} - - first = _Window %~ (runKleisli . first . Kleisli) - {-# INLINABLE first #-} - -instance Monad m => Choice (Window m) where - left' = _Window %~ (runKleisli . left' . Kleisli) - {-# INLINABLE left' #-} - -instance Monad m => ArrowChoice (Window m) where - left = _Window %~ (runKleisli . left . Kleisli) - {-# INLINABLE left #-} - -instance Monad m => ArrowApply (Window m) where - app = Window . ReaderT $ \(Window (ReaderT bc), b) -> bc b - {-# INLINABLE app #-} - -instance MonadPlus m => ArrowZero (Window m) where - zeroArrow = Window mzero - {-# INLINABLE zeroArrow #-} - -instance MonadPlus m => ArrowPlus (Window m) where - Window a <+> Window b = Window (a `mplus` b) - {-# INLINABLE (<+>) #-} - -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 - {-# INLINABLE implant #-} +-- | magnify can be used to modify the action inside an Gadget +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 #-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/glazier-0.7.0.0/src/Glazier.hs new/glazier-0.11.0.1/src/Glazier.hs --- old/glazier-0.7.0.0/src/Glazier.hs 2017-02-02 11:03:30.000000000 +0100 +++ new/glazier-0.11.0.1/src/Glazier.hs 2017-03-18 14:46:57.000000000 +0100 @@ -1,11 +1,28 @@ +-- Functional version of Elm Action/Model/View/Update architecture, but additionally powered by Haskell typeclasses, monad transformers, and lens. +-- #Features +-- ## Composable widgets +-- Larger widgets can be made out of smaller widgets without changing any existing code, or "lifting of" states. +-- ## Easily embed widget +-- Use of lens and prisms to embed a smaller widget Action &Model within larger widget Action & Model. +-- ## Typeclasses and Monad Transformers +-- Using Haskell typeclasses and monad transformer enables a disciplined and lawful way of composing widgets and effects together. +-- ## Orthogonal wiring +-- Unlike other GUI frameworks, the signal framework (how the widgets interact with other stateful effects) are not fixed by this library. I recommend using the pipe ecosystem, but you could probably use conduit or manually run the StateT transformer yourself. +-- ## Combine multiple concurrent stateful effects +-- I recommend using the pipe ecosystem the signal framework because [pipes-fluid](https://github.com/louispan/pipes-fluid) allows combining multiple concurrent stateful effects whilst maintaining a single source of truth. This is possible because the stateful effects are running over [STM](http://chimera.labs.oreilly.com/books/1230000000929/ch10.html) which will ensure a consistent ordering of stateful effects. Haskell is +-- ## Isolation of IO +-- The stateful effects are pure and do not involve IO. All IO effects are isolated to an interpreter of the command output of the gadget. This has the benefit of allowing better testing of the intention of gadgets; increasing confidence of the behaviour of the gadget, reducing the surface area of IO misbehaviour. +-- # Examples +-- ## TodoMVC +-- This is a fully featured TodoMVC in in Haskell and ReactJS using the [glazier-react](https://github.com/louispan/glazier-react) library. +-- For a live demo, see https://louispan.github.io/glazier-react-examples/ +-- For more details, see the [todo example README.md](https://github.com/louispan/glazier-react-examples/tree/master/examples/todo) +-- # Slides +-- See [slides](https://github.com/louispan/glazier-react-intro) module Glazier - ( module Glazier.Class - , module Glazier.Window - , module Glazier.Gadget.Strict - , module Glazier.Widget.Strict + ( module Glazier.Window + , module Glazier.Gadget ) where -import Glazier.Class import Glazier.Window -import Glazier.Gadget.Strict -import Glazier.Widget.Strict +import Glazier.Gadget