packages feed

glazier (empty) → 0.5.0.0

raw patch · 7 files changed

+956/−0 lines, 7 filesdep +basedep +lensdep +mmorphsetup-changed

Dependencies added: base, lens, mmorph, mtl, profunctors, semigroupoids, transformers

Files

+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2016, Louis Pan++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+   contributors may be used to endorse or promote products derived from+   this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.+IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,+INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ glazier.cabal view
@@ -0,0 +1,34 @@+name:                glazier+version:             0.5.0.0+synopsis:            Composable widgets framework+description:         Please see README.md+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+build-type:          Simple+cabal-version:       >=1.10+tested-with:         GHC == 8.0.1++library+  hs-source-dirs:      src+  exposed-modules:      Glazier+                      , Glazier.Example+                      , Glazier.Lazy+                      , Glazier.Strict+  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+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/louispan/glazier
+ src/Glazier.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Functional version of (Elm Brief/View & startApp architecture) enabling composable widgets, and a FRP-like framework.+--+-- This framework makes it easier to modularize the Elm architecture idea of View/Brief:+-- based on the deprecated Elm Architecture version of Jan 2016+-- https://github.com/evancz/elm-architecture-tutorial/tree/de5682a5a8e4459aed4637533adb25e462f8a2ae+--+-- The Elm View/Brief 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 implementations Brief and View 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(..)+    , _WindowT+    , _WindowT'+    , hoistWindow+    , Implanted+    , Implant(..)+    , Dispatched+    , Dispatch(..)+    ) 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++-------------------------------------------------------------------------------++-- | 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 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+               , Monad+               , Applicative+               , Functor+               , Fail.MonadFail+               , Alternative+               , MonadPlus+               , MonadFix+               , MonadIO+               , MonadZip+               )++makeWrapped ''Window++-- | lens 4.15.1 doesn't have a general enough ReaderT iso+_WrappingReaderT :: Iso (ReaderT r m a) (ReaderT r' m' a') (r -> m a) (r' -> m' a')+_WrappingReaderT = iso runReaderT ReaderT++-- | 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++-- | This in conjuction with Wrapped instance 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 = _WindowT %~ f+--+-- aboveWindow :: (Window m s v -> Window m' s' v') -> (s -> m v) -> (s' -> m' v')+-- aboveWindow f = from _WindowT %~ f+_WindowT :: Iso (Window m s v) (Window m' s' v') (s -> m v) (s' -> m' v')+_WindowT = _Wrapping Window . iso runReaderT ReaderT -- lens 4.15.1 doesn't have a general enough ReaderT iso++-- | Non polymorphic version of _WindowT+_WindowT' :: Iso' (Window m s v) (s -> m v)+_WindowT' = _WindowT++instance (Applicative m, Semigroup v) => Semigroup (Window m s v) where+    (Window f) <> (Window g) = Window $ ReaderT $ \a ->+        (<>) <$> runReaderT f a <*> runReaderT g a++instance (Applicative m, Monoid v) => Monoid (Window m s v) where+    mempty = Window $ ReaderT $ const $ pure mempty+    (Window f) `mappend` (Window g) = Window $ ReaderT $ \a ->+        mappend <$> runReaderT f a <*> runReaderT g a++instance Monad m => Profunctor (Window m) where+    dimap f g = _WindowT %~ (runKleisli . dimap f g . Kleisli)++instance Monad m => Strong (Window m) where+    first' = _WindowT %~ (runKleisli . first' . Kleisli)++instance Monad m => C.Category (Window m) where+    id = Window . ReaderT $ runKleisli C.id+    Window (ReaderT k) . Window (ReaderT l) = Window . ReaderT . runKleisli $ Kleisli k C.. Kleisli l++instance Monad m => Arrow (Window m) where+    arr f = Window $ ReaderT $ runKleisli $ arr f+    first = _WindowT %~ (runKleisli . first . Kleisli)++instance Monad m => Choice (Window m) where+    left' = _WindowT %~ (runKleisli . left' . Kleisli)++instance Monad m => ArrowChoice (Window m) where+    left = _WindowT %~ (runKleisli . left . Kleisli)++instance Monad m => ArrowApply (Window m) where+    app = Window . ReaderT $ \(Window (ReaderT bc), b) -> bc b++instance MonadPlus m => ArrowZero (Window m) where+    zeroArrow = Window mzero++instance MonadPlus m => ArrowPlus (Window m) where+    Window a <+> Window b = Window (a `mplus` b)++-------------------------------------------------------------------------------++-- | 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 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 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
+ src/Glazier/Example.hs view
@@ -0,0 +1,166 @@+{-# 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 Glazier.Strict+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 _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.+-- 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 _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,+-- 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 _GadgetT $ \(Action f) s -> pure (mempty, f s))+    )
+ src/Glazier/Lazy.hs view
@@ -0,0 +1,274 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Glazier.Lazy+    ( Gadget(..)+    , _GadgetT+    , _GadgetT'+    , hoistGadget+    , Widget(..)+    , hoistWidget+    , HasWindow(..)+    , HasGadget(..)+    , statically+    , dynamically+    ) 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.Functor.Apply+import Data.Maybe+import Data.Profunctor+import Data.Semigroup+import Glazier++-- | 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)++-- | This in conjuction with Wrapped instance 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 = _GadgetT %~ 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 _GadgetT %~ f+_GadgetT :: Iso (Gadget s m a c) (Gadget s' m' a' c') (a -> s -> m (c, s)) (a' -> s' -> m' (c', s'))+_GadgetT = _Wrapping Gadget . iso runReaderT ReaderT . iso (runStateT .) (StateT .)++-- | Non polymorphic version of _GadgetT+_GadgetT' :: Iso' (Gadget s m a c) (a -> s -> m (c, s))+_GadgetT' = _GadgetT++instance (Monad m, Semigroup c) => Semigroup (Gadget s m a c) where+    (Gadget f) <> (Gadget g) = Gadget $ (<>) <$> f <*> g++instance (Monad m, Monoid c) => Monoid (Gadget s m a c) where+    mempty = Gadget $ pure mempty+    (Gadget f) `mappend` (Gadget g) = Gadget $ mappend <$> f <*> g++instance Monad m => Profunctor (Gadget s m) where+    dimap f g (Gadget (ReaderT m)) = Gadget $ ReaderT $ \a -> StateT $ \s -> undefined+        (first g) <$> runStateT (m (f a)) s++instance Monad m => Strong (Gadget s m) where+    first' (Gadget (ReaderT bc)) = Gadget $ ReaderT $ \(b, d) -> StateT $ \s ->+        (\(c, s') -> ((c, d), s')) <$> runStateT (bc b) s++instance Monad m => C.Category (Gadget s m) where+    id = Gadget $ ReaderT $ \a -> StateT $ \s -> pure (a, s)+    Gadget (ReaderT bc) . Gadget (ReaderT ab) = Gadget $ ReaderT $ \a -> StateT $ \s -> do+        ~(b, s') <- runStateT (ab a) s+        runStateT (bc b) s'++instance Monad m => Arrow (Gadget s m) where+    arr f = dimap f id C.id+    first = first'++instance Monad m => Choice (Gadget s m) where+    left' (Gadget (ReaderT bc)) = Gadget $ ReaderT $ \db -> StateT $ \s -> case db of+        Left b -> do+            ~(c, s') <- runStateT (bc b) s+            pure (Left c, s')+        Right d -> pure (Right d, s)++instance Monad m => ArrowChoice (Gadget s m) where+    left = left'++instance Monad m => ArrowApply (Gadget s m) where+    app = Gadget $ ReaderT $ \(Gadget (ReaderT bc), b) -> StateT $ \s -> runStateT (bc b) s++instance MonadPlus m => ArrowZero (Gadget s m) where+    zeroArrow = Gadget mzero++instance MonadPlus m => ArrowPlus (Gadget s m) where+    Gadget a <+> Gadget b = Gadget (a `mplus` b)++-- | 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+  {-# INLINE 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+  {-# INLINE 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++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++-----------------------------------------------------------------------------++-- | 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++-- | 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)++instance (Monad m, Semigroup c, Semigroup v) => Semigroup (Widget s v m a c) where+    w1 <> w2 = Widget+      (widgetWindow w1 <> widgetWindow w2)+      (widgetGadget w1 <> widgetGadget w2)++instance (Monad m, Monoid c, Monoid v) => Monoid (Widget s v m a c) where+    mempty = Widget mempty mempty+    mappend w1 w2 = Widget+        (widgetWindow w1 `mappend` widgetWindow w2)+        (widgetGadget w1 `mappend` widgetGadget w2)++-- | 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)++-- | 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)+    (Widget w1 fg) <*> (Widget w2 g) = Widget (w1 <> w2) (fg <*> g)++instance Monad m => Profunctor (Widget s v m) where+    dimap f g (Widget w m) = Widget w (dimap f g m)++instance Monad m => Strong (Widget s v m) where+    first' (Widget w g) = Widget w (first' g)++instance (Monad m, Monoid v) => C.Category (Widget s v m) where+    id = Widget mempty C.id+    Widget wbc gbc . Widget wab gab = Widget+        (wab `mappend` wbc)+        (gbc C.. gab)++-- | 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+    first = first'++instance (Monad m) => Choice (Widget s v m) where+    left' (Widget w bc) = Widget w (left' bc)++instance (Monad m, Monoid v) => ArrowChoice (Widget s v m) where+    left = left'++statically :: (Monad m, Monoid c) => Window m s v -> Widget s v m a c+statically w = Widget w mempty++dynamically :: (Monad m, Monoid v) => Gadget s m a c -> Widget s v m a c+dynamically = Widget mempty++type instance Dispatched (Widget s v m a c) = Dispatched (Gadget s m a c)+instance Monad m => Dispatch (Widget s v m a c) (Widget s v m b c) a b where+  dispatch p w = Widget+    (widgetWindow w)+    (dispatch p $ widgetGadget w)++type instance Implanted (Widget s v m a c) =+     PairMaybeFunctor (Implanted (Gadget s m a c))+       (Implanted (Window m s v))+instance Monad m => Implant (Widget s v m a c) (Widget t v m a c) s t where+  implant l w = Widget+    (implant (sndLensLike l) $ widgetWindow w)+    (implant (fstLensLike l) $ widgetGadget w)++-- | 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)++instance (Apply f, Apply g) => Apply (PairMaybeFunctor f g) where+  (PairMaybeFunctor (a, b)) <.> (PairMaybeFunctor (c, d)) = PairMaybeFunctor (liftA2 (Data.Functor.Apply.<.>) a c, liftA2 (Data.Functor.Apply.<.>) b d)++instance (Applicative f, Applicative g) => Applicative (PairMaybeFunctor f g) where+  pure a = PairMaybeFunctor (Just $ pure a, Just $ pure a)+  (PairMaybeFunctor (a, b)) <*> (PairMaybeFunctor (c, d)) = PairMaybeFunctor (liftA2 (<*>) a c, liftA2 (<*>) b d)++instance (Contravariant f, Contravariant g) => Contravariant (PairMaybeFunctor f g) where+  contramap f (PairMaybeFunctor (a, b)) = PairMaybeFunctor (contramap f <$> a, contramap f <$> b)++fstLensLike :: LensLike (PairMaybeFunctor f g) s t a b -> LensLike f s t a b+-- 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++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
+ src/Glazier/Strict.hs view
@@ -0,0 +1,276 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Glazier.Strict+    ( Gadget(..)+    , _GadgetT+    , _GadgetT'+    , hoistGadget+    , Widget(..)+    , hoistWidget+    , HasWindow(..)+    , HasGadget(..)+    , statically+    , dynamically+    ) where++import Control.Applicative+import Control.Arrow+import qualified Control.Category as C+import Control.Lens+import qualified Control.Monad.Fail as Fail+import Control.Monad.Fix (MonadFix)+import Control.Monad.Morph+import Control.Monad.Reader+import Control.Monad.State.Strict+import Data.Functor.Apply+import Data.Maybe+import Data.Profunctor+import Data.Semigroup+import Glazier++-- | 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)++-- | This in conjuction with Wrapped instance 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 = _GadgetT %~ 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 _GadgetT %~ f+_GadgetT :: Iso (Gadget s m a c) (Gadget s' m' a' c') (a -> s -> m (c, s)) (a' -> s' -> m' (c', s'))+_GadgetT = _Wrapping Gadget . iso runReaderT ReaderT . iso (runStateT .) (StateT .)++-- | Non polymorphic version of _GadgetT+_GadgetT' :: Iso' (Gadget s m a c) (a -> s -> m (c, s))+_GadgetT' = _GadgetT++instance (Monad m, Semigroup c) => Semigroup (Gadget s m a c) where+    (Gadget f) <> (Gadget g) = Gadget $ (<>) <$> f <*> g++instance (Monad m, Monoid c) => Monoid (Gadget s m a c) where+    mempty = Gadget $ pure mempty+    (Gadget f) `mappend` (Gadget g) = Gadget $ mappend <$> f <*> g++instance Monad m => Profunctor (Gadget s m) where+    dimap f g (Gadget (ReaderT m)) = Gadget $ ReaderT $ \a -> StateT $ \s -> undefined+        (first g) <$> runStateT (m (f a)) s++instance Monad m => Strong (Gadget s m) where+    first' (Gadget (ReaderT bc)) = Gadget $ ReaderT $ \(b, d) -> StateT $ \s ->+        (\(c, s') -> ((c, d), s')) <$> runStateT (bc b) s++instance Monad m => C.Category (Gadget s m) where+    id = Gadget $ ReaderT $ \a -> StateT $ \s -> pure (a, s)+    Gadget (ReaderT bc) . Gadget (ReaderT ab) = Gadget $ ReaderT $ \a -> StateT $ \s -> do+        (b, s') <- runStateT (ab a) s+        runStateT (bc b) s'++instance Monad m => Arrow (Gadget s m) where+    arr f = dimap f id C.id+    first = first'++instance Monad m => Choice (Gadget s m) where+    left' (Gadget (ReaderT bc)) = Gadget $ ReaderT $ \db -> StateT $ \s -> case db of+        Left b -> do+            (c, s') <- runStateT (bc b) s+            pure (Left c, s')+        Right d -> pure (Right d, s)++instance Monad m => ArrowChoice (Gadget s m) where+    left = left'++instance Monad m => ArrowApply (Gadget s m) where+    app = Gadget $ ReaderT $ \(Gadget (ReaderT bc), b) -> StateT $ \s -> runStateT (bc b) s++instance MonadPlus m => ArrowZero (Gadget s m) where+    zeroArrow = Gadget mzero++instance MonadPlus m => ArrowPlus (Gadget s m) where+    Gadget a <+> Gadget b = Gadget (a `mplus` b)++-- | 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+  {-# INLINE 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+  {-# INLINE 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++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++-----------------------------------------------------------------------------++-- | 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++-- | 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)++instance (Monad m, Semigroup c, Semigroup v) => Semigroup (Widget s v m a c) where+    w1 <> w2 = Widget+      (widgetWindow w1 <> widgetWindow w2)+      (widgetGadget w1 <> widgetGadget w2)++instance (Monad m, Monoid c, Monoid v) => Monoid (Widget s v m a c) where+    mempty = Widget mempty mempty+    mappend w1 w2 = Widget+        (widgetWindow w1 `mappend` widgetWindow w2)+        (widgetGadget w1 `mappend` widgetGadget w2)++-- | 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)++-- | 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)+    (Widget w1 fg) <*> (Widget w2 g) = Widget (w1 <> w2) (fg <*> g)++instance Monad m => Profunctor (Widget s v m) where+    dimap f g (Widget w m) = Widget w (dimap f g m)++instance Monad m => Strong (Widget s v m) where+    first' (Widget w g) = Widget w (first' g)++instance (Monad m, Monoid v) => C.Category (Widget s v m) where+    id = Widget mempty C.id+    Widget wbc gbc . Widget wab gab = Widget+        (wab `mappend` wbc)+        (gbc C.. gab)++-- | 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+    first = first'++instance (Monad m) => Choice (Widget s v m) where+    left' (Widget w bc) = Widget w (left' bc)++instance (Monad m, Monoid v) => ArrowChoice (Widget s v m) where+    left = left'++statically :: (Monad m, Monoid c) => Window m s v -> Widget s v m a c+statically w = Widget w mempty++dynamically :: (Monad m, Monoid v) => Gadget s m a c -> Widget s v m a c+dynamically = Widget mempty++type instance Dispatched (Widget s v m a c) = Dispatched (Gadget s m a c)+instance Monad m => Dispatch (Widget s v m a c) (Widget s v m b c) a b where+  dispatch p w = Widget+    (widgetWindow w)+    (dispatch p $ widgetGadget w)++type instance Implanted (Widget s v m a c) =+     PairMaybeFunctor (Implanted (Gadget s m a c))+       (Implanted (Window m s v))+instance Monad m => Implant (Widget s v m a c) (Widget t v m a c) s t where+  implant l w = Widget+    (implant (sndLensLike l) $ widgetWindow w)+    (implant (fstLensLike l) $ widgetGadget w)++-- -------------------------------------------------------------------------------++-- | 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)++instance (Apply f, Apply g) => Apply (PairMaybeFunctor f g) where+  (PairMaybeFunctor (a, b)) <.> (PairMaybeFunctor (c, d)) = PairMaybeFunctor (liftA2 (Data.Functor.Apply.<.>) a c, liftA2 (Data.Functor.Apply.<.>) b d)++instance (Applicative f, Applicative g) => Applicative (PairMaybeFunctor f g) where+  pure a = PairMaybeFunctor (Just $ pure a, Just $ pure a)+  (PairMaybeFunctor (a, b)) <*> (PairMaybeFunctor (c, d)) = PairMaybeFunctor (liftA2 (<*>) a c, liftA2 (<*>) b d)++instance (Contravariant f, Contravariant g) => Contravariant (PairMaybeFunctor f g) where+  contramap f (PairMaybeFunctor (a, b)) = PairMaybeFunctor (contramap f <$> a, contramap f <$> b)++fstLensLike :: LensLike (PairMaybeFunctor f g) s t a b -> LensLike f s t a b+-- 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++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