glazier 0.11.0.1 → 1.0.0.0

raw patch · 7 files changed

+770/−264 lines, 7 filesdep +alternatorsdep +data-diversedep +data-diverse-lensdep −mmorphdep −semigroupoidsdep ~lensdep ~mtldep ~transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: alternators, data-diverse, data-diverse-lens, dlist, glazier, stm, tagged, unliftio, unliftio-core

Dependencies removed: mmorph, semigroupoids

Dependency ranges changed: lens, mtl, transformers

API changes (from Hackage documentation)

Files

• glazier.cabal +37/−14
• src/Glazier.hs +0/−28
• src/Glazier/Command.hs +352/−0
• src/Glazier/Command/Exec.hs +92/−0
• src/Glazier/Gadget.hs +0/−114
• src/Glazier/Window.hs +0/−108
• test/Spec.hs +289/−0

@@ -1,30 +1,53 @@ name:                glazier-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.+version:             1.0.0.0+synopsis:            Extensible effects using ContT, State and variants.+description:         Interpreting commmands with extensible effects using Cont/Concur monad, State, and variants. 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, GUI+category:            GUI build-type:          Simple cabal-version:       >=1.10-tested-with:         GHC == 8.0.1+tested-with:         GHC == 8.4.1  library   hs-source-dirs:      src-  exposed-modules:     Glazier-                       Glazier.Gadget-                       Glazier.Window+  exposed-modules:     Glazier.Command+                       Glazier.Command.Exec   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+                     , alternators >= 1.0+                     , data-diverse >= 4.6+                     , data-diverse-lens >= 4.3+                     , dlist >= 0.8+                     , lens >= 4+                     , mtl >= 2+                     , transformers >= 0.4+                     , unliftio >= 0.2+                     , unliftio-core >= 0.1+  ghc-options:        -Wall -Wredundant-constraints+  default-language:    Haskell2010++test-suite glazier-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       base >= 4.7 && < 5+                     , alternators >= 1.0+                     , glazier+                     , data-diverse >= 4.6+                     , data-diverse-lens >= 4.3+                     , lens >= 4.14+                     , mtl >= 2.2+                     , dlist >= 0.8+                     , transformers >= 0.3+                     , unliftio >= 0.2+                     , unliftio-core >= 0.1+                     , stm >= 2.4+                     , tagged >= 0.8+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall   default-language:    Haskell2010  source-repository head

@@ -1,28 +0,0 @@--- 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.Window-    , module Glazier.Gadget-    ) where--import Glazier.Window-import Glazier.Gadget

@@ -0,0 +1,352 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}++module Glazier.Command+    ( MonadCodify(..)+    , codifies'+    , codify+    , codify'+    , MonadCommand+    , command+    , command'+    , command_+    , commands+    , instruct+    , instructs+    , exec+    , exec'+    , exec_+    , eval+    , eval'+    , sequentially+    , dispatch+    , dispatch_+    , concurringly+    , concurringly_+    , AsConcur+    , Concur(..)+    , NewEmptyMVar -- Hiding constructor+    , unNewEmptyMVar+    ) where++import Control.Applicative+import Control.Concurrent+import Control.Lens+import Control.Monad.Cont+import Control.Monad.Delegate+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Trans.Cont+import Control.Monad.Trans.Except+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.State.Lazy as Lazy+import Control.Monad.Trans.State.Strict as Strict+import Data.Diverse.Lens+import qualified Data.DList as DL+import GHC.Generics++#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,10,0)+import Data.Semigroup+#endif++----------------------------------------------+-- Command utilties+----------------------------------------------++-- | Converts a handler that result in monad transformer stack with a 'State' of list of commands+-- to a handler that result in a list of commands, using the current monad context,+-- by running the State of comands with mempty like Writer.+class Monad m => MonadCodify cmd m | m -> cmd where+    codifies :: (a -> m ()) -> m (a -> [cmd])++-- | Variation of 'codifies' to transform the monad stack instead of a handler.+codifies' :: (MonadCodify cmd m) => m () -> m [cmd]+codifies' m = do+    f <- codifies (const m)+    pure (f ())++-- | Variation of 'codifies' to output a handler that result in a single command+codify :: (AsFacet [cmd] cmd, MonadCodify cmd m) => (a -> m ()) -> m (a -> cmd)+codify f = (commands .) <$> codifies f++-- | Variation of 'codify' to transform the monad stack instead of a handler.+codify' :: (AsFacet [cmd] cmd, MonadCodify cmd m) => m () -> m cmd+codify' m = do+    f <- codify (const m)+    pure (f ())++-- | Instance that does real work by running the State of commands with mempty.+instance MonadCodify cmd (Strict.State (DL.DList cmd)) where+    codifies f = pure $ \a -> DL.toList . (`Strict.execState` mempty) $ f a++-- | Instance that does real work by running the 'State' of commands with mempty.+instance MonadCodify cmd (Lazy.State (DL.DList cmd)) where+    codifies f = pure $ \a -> DL.toList . (`Lazy.execState` mempty) $ f a++-- | Passthrough instance+instance MonadCodify cmd m => MonadCodify cmd (IdentityT m) where+    codifies f = lift . codifies $ runIdentityT . f++-- | Passthrough instance+instance MonadCodify cmd m => MonadCodify cmd (ContT () m) where+    codifies f = lift . codifies $ evalContT . f++-- | Passthrough instance, using the Reader context+instance MonadCodify cmd m => MonadCodify cmd (ReaderT r m) where+    codifies f = do+        r <- ask+        lift . codifies $ (`runReaderT` r) . f++-- | Passthrough instance, ignoring that the handler result might be Nothing.+instance MonadCodify cmd m => MonadCodify cmd (MaybeT m) where+    codifies f = lift . codifies $ void . runMaybeT . f++-- | Passthrough instance which requires the inner monad to be a 'MonadDelegate'.+-- This means that the @Left e@ case can be handled by the provided delegate.+instance (MonadDelegate () m, MonadCodify cmd m) => MonadCodify cmd (ExceptT e m) where+    codifies f = ExceptT $ delegate $ \kec -> do+        let g a = do+                e <- runExceptT $ f a+                case e of+                    Left e' -> kec (Left e')+                    Right _ -> pure ()+        g' <- codifies g+        kec (Right g')++type MonadCommand cmd m =+    ( MonadState (DL.DList cmd) m+    , MonadDelegate () m+    , MonadCodify cmd m+    , AsFacet [cmd] cmd+    )++-- | convert a request type to a command type.+-- This is used for commands that doesn't have a continuation.+-- Ie. commands that doesn't "returns" a value from running an effect.+-- Use 'command'' for commands that require a continuation ("returns" a value).+command :: (AsFacet c cmd) => c -> cmd+command = review facet++-- | A variation of 'command' for commands with a type variable @cmd@,+-- which is usually commands that are containers of command,+-- or commands that require a continuation+-- Eg. commands that "returns" a value from running an effect.+command' :: (AsFacet (c cmd) cmd) => c cmd -> cmd+command' = review facet++-- | This helps allow executors of commands of a results only need to execute the type @c cmd@,+-- ie, when the command result in the next @cmd@.+-- This function is useful to fmap a command with a result of unit+--  to to a command with a result @cmd@ type.+command_ :: (AsFacet [cmd] cmd) => () -> cmd+command_ = command' . const []++-- | Convert a list of commands to a command. This implementation avoids nesting+-- for lists of a single command.+commands :: (AsFacet [cmd] cmd) => [cmd] -> cmd+commands [x] = x+commands xs = command' xs++-- | Add a command to the list of commands for this MonadState.+-- I basically want a Writer monad, but I'm using a State monad+-- because but I also want to use it inside a ContT which only has an instance of MonadState.+instruct :: (MonadState (DL.DList cmd) m) => cmd -> m ()+instruct c = id %= (`DL.snoc` c)++-- | Adds a list of commands to the list of commands for this MonadState.+instructs :: (MonadState (DL.DList cmd) m) => [cmd] -> m ()+instructs cs = id %= (<> DL.fromList cs)++-- | @'exec' = 'instruct' . 'command'@+exec :: (MonadState (DL.DList cmd) m, AsFacet c cmd) => c -> m ()+exec = instruct . command++-- | @'exec'' = 'instruct' . 'command''@+exec' :: (MonadState (DL.DList cmd) m, AsFacet (c cmd) cmd) => c cmd -> m ()+exec' = instruct . command'++-- | @'exec'' = 'instruct' . 'command''@+exec_ :: (Functor c, MonadState (DL.DList cmd) m, AsFacet [cmd] cmd, AsFacet (c cmd) cmd)+    => c () -> m ()+exec_ = instruct . command' . fmap command_++-- | This converts a monadic function that requires a handler for @a@ into+-- a monad that fires the @a@ so that the do notation can be used to compose the handler.+-- 'eval_' is used inside an 'evalContT' block or 'concurringly'.+-- If it is inside a 'evalContT' then the command is evaluated sequentially.+-- If it is inside a 'concurringly', then the command is evaluated concurrently+-- with other commands.+--+-- @+-- If tne input function purely returns a command, you can use:+-- eval_ . (exec' .) :: ((a -> cmd) -> c cmd) -> m a+--+-- If tne input function monnadic returns a command, you can use:+-- eval_ . ((>>= exec') .) :: ((a -> cmd) -> m (c cmd)) -> m a+-- @+eval_ ::+    ( MonadDelegate () m+    , MonadCodify cmd m+    , AsFacet [cmd] cmd+    )+    => ((a -> cmd) -> m ()) -> m a+eval_ m = delegate $ \k -> do+    f <- codify k+    m f++eval' ::+    ( MonadCommand cmd m+    , AsFacet [cmd] cmd+    , AsFacet (c cmd) cmd+    )+    => ((a -> cmd) -> c cmd) -> m a+eval' k = eval_ $ exec' . k++eval ::+    ( MonadCommand cmd m+    , AsFacet [cmd] cmd+    , AsFacet c cmd+    )+    => ((a -> cmd) -> c) -> m a+eval k = eval_ $ exec . k++-- | Adds a 'MonadCont' constraint. It is redundant but rules out+-- using 'Concur' at the bottom of the transformer stack.+-- 'sequentially' is used for operations that MUST run sequentially, not concurrently.+-- Eg. when the overhead of using 'Concur' 'MVar' is not worth it, or+-- when data dependencies are not explicitly specified by monadic binds,+-- Eg. A command to update mutable variable must exact before+-- a command that reads from the mutable variable.+-- In this case, the reference to the variable doesn't change, so the+-- data dependency is not explicit.+sequentially :: MonadCont m => m a -> m a+sequentially = id++-- | Retrieves the result of a functor command.+dispatch ::+    ( AsFacet (c cmd) cmd+    , MonadCommand cmd m+    , Functor c+    ) => c a -> m a+dispatch c = delegate $ \fire -> do+    fire' <- codify fire+    exec' $ fire' <$> c++-- | Retrieves the result of a functor command.+-- A simpler variation of 'dispatch' that only requires a @MonadState (DL.DList cmd) m@+dispatch_ ::+    ( AsFacet (c cmd) cmd+    , AsFacet [cmd] cmd+    , MonadState (DL.DList cmd) m+    , Functor c+    ) => c () -> m ()+dispatch_ = exec' . fmap command_++----------------------------------------------+-- Batch independant commands+----------------------------------------------++type AsConcur cmd = (AsFacet [cmd] cmd, AsFacet (Concur cmd cmd) cmd)++-- | This monad is intended to be used with @ApplicativeDo@ to allow do notation+-- for composing commands that can be run concurrently.+-- The 'Applicative' instance can merge multiple commands into the internal state of @DList c@.+-- The 'Monad' instance creates a 'ConcurCmd' command before continuing the bind.+newtype Concur cmd a = Concur+    -- The base IO doesn't block (only does newEmptyMVar), but may return an IO that blocks.+    -- The return is @Either (IO a) a@ where 'Left' is used for blocking IO+    -- and 'Right' is used for nonblocking pure values.+    -- This distinction prevents nested layers of MVar for pure monadic binds.+    -- See the instance of 'Monad' for 'Concur'.+    -- Once a blocking IO is returned, then all subsequent binds require another nested MVar.+    -- So it is more efficient to groups of pure binds first before binding with blocking code.+    { runConcur :: Strict.StateT (DL.DList cmd) NewEmptyMVar (Either (IO a) a)+    } deriving (Generic)++instance Show (Concur cmd a) where+    showsPrec _ _ = showString "Concur"++-- | NB. Don't export NewEmptyMVar constructor to guarantee+-- that that it only contains non-blocking 'newEmptyMVar' IO.+newtype NewEmptyMVar a = NewEmptyMVar (IO a)+    deriving (Functor, Applicative, Monad)++unNewEmptyMVar :: NewEmptyMVar a -> IO a+unNewEmptyMVar (NewEmptyMVar m) = m++-- This is a monad morphism that can be used to 'Control.Monad.Morph.hoist' transformer stacks on @Concur cmd a@+concurringly ::+    ( MonadCommand cmd m+    , AsConcur cmd+    -- , MonadCont m+    ) => Concur cmd a -> m a+concurringly = dispatch++-- | This is a monad morphism that can be used to 'Control.Monad.Morph.hoist' transformer stacks on @Concur cmd ()@+-- A simpler variation of 'concurringly' that only requires a @MonadState (DL.DList cmd) m@+concurringly_ :: (MonadState (DL.DList cmd) m, AsConcur cmd) => Concur cmd () -> m ()+concurringly_ = dispatch_++instance (AsConcur cmd) => MonadState (DL.DList cmd) (Concur cmd) where+    state m = Concur $ Right <$> Strict.state m++instance Functor (Concur cmd) where+    fmap f (Concur m) = Concur $ (either (Left . fmap f) (Right . f)) <$> m++-- | Applicative instand allows building up list of commands without blocking+instance Applicative (Concur cmd) where+    pure = Concur . pure . pure+    (Concur f) <*> (Concur a) = Concur $ liftA2 go f a+      where+        go :: Either (IO (a -> b)) (a -> b)+             -> Either (IO a) a+             -> Either (IO b) b+        go g b = case (g, b) of+            (Left g', Left b') -> Left (g' <*> b')+            (Left g', Right b') -> Left (($b') <$> g')+            (Right g', Left b') -> Left (g' <$> b')+            (Right g', Right b') -> Right (g' b')++-- Monad instance can't build commands without blocking.+instance (AsConcur cmd) => Monad (Concur cmd) where+    (Concur m) >>= k = Concur $ do+        m' <- m -- get the blocking io action while updating the state+        case m' of+            -- pure value, no blocking required, avoid using MVar.+            Right a -> runConcur $ k a+            -- blocking io, must use MVar+            Left ma -> do+                v <- lift $ NewEmptyMVar newEmptyMVar+                exec' $ flip fmap (Concur @cmd $ pure (Left ma))+                    (\a -> command' $ flip fmap (k a)+                        (\b -> command' $ command_ <$> (Concur @cmd $ pure $ Left $ putMVar v b)))+                pure $ Left $ takeMVar v++instance AsConcur cmd => MonadCodify cmd (Concur cmd) where+    codifies f = pure $ pure . command' . fmap command_ . f++-- | This instance makes usages of 'sequel' concurrent when used+-- insdie a 'concurringly' or 'concurringly_' block.+-- Converts a command that requires a handler to a Concur monad+-- so that the do notation can be used to compose the handler for that command.+-- The Concur monad allows scheduling the command in concurrently with other commands.+instance AsConcur cmd => MonadDelegate () (Concur cmd) where+    delegate f = Concur $ do+        v <- lift $ NewEmptyMVar newEmptyMVar+        b <- runConcur $ f (\a -> Concur $ lift $ pure $ Left $ putMVar v a)+        pure $ Left (either id pure b *> takeMVar v)

@@ -0,0 +1,92 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Glazier.Command.Exec where++import Data.Kind+import Control.Applicative+import Control.Lens+import Control.Monad.IO.Unlift+import Control.Monad.State.Strict+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Maybe.Extras+import Data.Diverse.Lens+import qualified Data.DList as DL+import Data.Foldable+import Data.Proxy+import Glazier.Command+import qualified UnliftIO.Concurrent as U++-- | type function to get the list of effects in a @c@, parameterized over @cmd@+type family CmdTypes c cmd :: [Type]++-- | A command type that removes the @IO cmd@ from the @CmdTypes@ of the input @cmd@+newtype NoIOCmd cmd = NoIOCmd { unNoIOCmd :: Which (CmdTypes (NoIOCmd cmd) (NoIOCmd cmd)) }++-- | Removes the @IO cmd@ from the @CmdTypes@ of the input @c@+type instance CmdTypes (NoIOCmd c) cmd = Remove (IO cmd) (CmdTypes c cmd)++-- UndecidableInstances!+instance (AsFacet a (Which (CmdTypes (NoIOCmd cmd) (NoIOCmd cmd)))) => AsFacet a (NoIOCmd cmd) where+    facet = iso unNoIOCmd NoIOCmd . facet++-- | Create an executor for a variant in the command type.+-- returns a 'Proxy' to keep track of the the types handled by the executor.+maybeExec :: (Applicative m, AsFacet a c) => (a -> m b) -> c -> MaybeT m (Proxy '[a], b)+maybeExec k c = MaybeT . sequenceA $ (fmap (\b -> (Proxy, b)) . k) <$> preview facet c++-- | Tie an executor with itself to get the final interpreter+fixExec :: Functor m => ((cmd -> m ()) -> cmd -> MaybeT m (Proxy cmds, ())) -> cmd -> m (Proxy cmds, ())+fixExec fexec = let go = (`evalMaybeT` (Proxy, ())) . fexec (fmap snd . go) in go++-- | Use this function to verify at compile time that the given executor will fullfill+-- all the variant types in a command type.+-- redundant-constraints: used to constrain xs and ys+verifyExec ::+    ( AppendUnique '[] ys ~ ys+    , AppendUnique xs ys ~ xs+    , AppendUnique ys xs ~ ys+    , Functor m+    )+    => (cmd -> Which xs) -> (cmd -> m (Proxy ys, b)) -> (cmd -> m b)+verifyExec _ g = fmap snd .  g++-- 'verifyExec' and 'fixExec' an executor.+verifyFixExec ::+    ( AppendUnique '[] ys ~ ys+    , AppendUnique xs ys ~ xs+    , AppendUnique ys xs ~ ys+    , Functor m+    , Functor m+    ) => (cmd -> Which xs) -> ((cmd -> m ()) -> cmd -> MaybeT m (Proxy ys, ())) -> cmd -> m ()+verifyFixExec unCmd maybeExecuteCmd = verifyExec unCmd (fixExec maybeExecuteCmd)++-- | Combines executors, keeping track of the combined list of types handled.+-- redundant-constraints: used to constrain a''+orMaybeExec :: (Monad m, a'' ~ Append a a') => MaybeT m (Proxy a, b) -> MaybeT m (Proxy a', b) -> MaybeT m (Proxy a'', b)+orMaybeExec m n = (\b -> (Proxy, b)) <$> ((snd <$> m) <|> (snd <$> n))+infixl 3 `orMaybeExec` -- like <|>++execConcur ::+    MonadUnliftIO m+    => (cmd -> m ())+    -> Concur cmd a+    -> m a+execConcur executor (Concur m) = do+        ea <- execConcur_ executor+        -- Now run the possibly blocking io+        liftIO $ either id pure ea+  where+    execConcur_ executor' = do+        -- get the list of commands to run+        (ma, cs) <- liftIO $ unNewEmptyMVar $ runStateT m mempty+        -- run the batched commands in separate threads+        traverse_ (void . U.forkIO . executor') (DL.toList cs)+        pure ma

@@ -1,114 +0,0 @@-{-# 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 #-}

@@ -1,108 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}--module Glazier.Window 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 Data.Semigroup------------------------------------------------------------------------------------- | The Elm view function is basically @view :: model -> html@--- 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 WindowT s m v = WindowT-    { runWindowT :: ReaderT s m v-    } deriving ( MonadReader s-               , Monad-               , Applicative-               , Functor-               , Fail.MonadFail-               , Alternative-               , MonadPlus-               , MonadFix-               , MonadIO-               )--makeWrapped ''WindowT--type Window s = WindowT s Identity--_WindowT :: Iso (WindowT s m v) (WindowT s' m' v') (s -> m v) (s' -> m' v')-_WindowT = _Wrapping WindowT . iso runReaderT ReaderT-{-# INLINABLE _WindowT #-}---- | Non polymorphic version of _Window-_WindowT' :: Iso' (WindowT s 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 (WindowT s m v) where-    mempty = WindowT $ pure mempty-    {-# INLINABLE mempty #-}--    (WindowT f) `mappend` (WindowT g) = WindowT $ mappend <$> f <*> g-    {-# INLINABLE mappend #-}---- | 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 #-}

@@ -0,0 +1,289 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+-- Example of interpreting using polymorphic variant+-- with the help of ContT and State+module Main where++import Control.Concurrent.STM+import Control.Lens+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Control.Monad.Reader+import Control.Monad.State.Strict+import Control.Monad.Trans.Cont+import Control.Monad.Trans.Maybe+import Data.Diverse.Lens+import qualified Data.DList as DL+import Data.Foldable+import Data.Proxy+import Data.Tagged+import Glazier.Command+import Glazier.Command.Exec++#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,10,0)+import Data.Semigroup+#endif++-- | NB. Data.Diverse imports @Which (xs :: [Type])@+-- which is a polymorphic variant++-- | NB. Data.Diverse.Lens imports the following+--+-- @+-- class AsFacet a s where+--     facet :: Prism' s a+-- @+--+-- The polymorphic variant 'Which' has+-- AsFacet instances for all the types in the variant typelist.++----------------------------------------------+-- Commands+----------------------------------------------++-- | Define data type to encapsulate the parameters required for effects.+-- If an an effect "returns" a value (eg GetLine),+-- then the last arg is a continuation that returns the next command "command".+-- Eg (String -> cmd)+-- I don't need to derive Functor, but I do it to show+-- that the data type has the same shape as for Free Monads.+data IOEffect next+    -- PutStrLn is effect with an () return value.+    = PutStrLn String+    -- GetLine is an effect with a String return value.+    -- Requires continuation that does something with the return.+    | GetLine (String -> next)+    deriving Functor++instance Show (IOEffect c) where+    showsPrec d (PutStrLn s) = showParen (d >= 11) $ showString "PutStrLn " . shows s+    showsPrec _ (GetLine _) = showString "GetLine"++-- | Another DSL for other effects+data HelloWorldEffect+    = HelloWorld+    | ByeWorld++instance Show HelloWorldEffect where+    showsPrec _ HelloWorld = showString "HelloWorld"+    showsPrec _ ByeWorld = showString "ByeWorld"++-- | Define the sum of all variants+type AppEffects cmd = '[[cmd], Concur cmd cmd, IOEffect cmd, HelloWorldEffect]+-- | Add a newtype wrapper to allow recursive definition+newtype AppCmd = AppCmd { unAppCmd :: Which (AppEffects AppCmd)}+    deriving Show++-- | Define AsFacet instances for all types in the variant+-- UndecidableInstances!+instance (AsFacet a (Which (AppEffects AppCmd))) => AsFacet a AppCmd where+    facet = iso unAppCmd AppCmd . facet++----------------------------------------------+-- IO interpreter+----------------------------------------------++execIOEffect :: MonadIO m => (cmd -> m ()) -> IOEffect cmd -> m ()+execIOEffect _ (PutStrLn str) = liftIO $ putStrLn str+execIOEffect executor (GetLine k) = liftIO getLine >>= executor . k++execHelloWorldEffect :: MonadIO m => HelloWorldEffect -> m ()+execHelloWorldEffect HelloWorld = liftIO $ putStrLn "Hello, world!"+execHelloWorldEffect ByeWorld = liftIO $ putStrLn "Bye, world!"++-- | Combine interpreters+execEffects' ::+    ( AsFacet (IOEffect cmd) cmd+    , AsFacet HelloWorldEffect cmd+    , AsConcur cmd+    , MonadUnliftIO m+    )+    => (cmd -> m ()) -> cmd -> MaybeT m (Proxy '[[cmd], Concur cmd cmd, IOEffect cmd, HelloWorldEffect], ())+execEffects' executor c =+    maybeExec (traverse_ @[] executor) c+    `orMaybeExec` maybeExec ((>>= executor). execConcur executor) c+    `orMaybeExec` maybeExec (execIOEffect executor) c+    `orMaybeExec` maybeExec execHelloWorldEffect c++execEffects :: MonadUnliftIO m => AppCmd -> m ()+execEffects = verifyExec unAppCmd (fixExec execEffects')++----------------------------------------------+-- Test interpreter+----------------------------------------------++data Output+data Input++-- Some interpreters need to be an instance of MonadUniftIO,+-- which limits the transformer stack to ReaderT.+testIOEffect ::+    ( MonadReader r m+    , Has (Tagged Output (TVar [String])) r+    , Has (Tagged Input (TVar [String])) r+    , MonadIO m+    )+    => (cmd -> m ()) -> IOEffect cmd -> m ()+testIOEffect _ (PutStrLn str) = do+    xs <- view (hasTag @Output)+    liftIO $ atomically $ modifyTVar' xs (\xs' -> ("PutStrLn " <> show str) : xs')++testIOEffect executor (GetLine k) = do+    xs <- view (hasTag @Output)+    ys <- view (hasTag @Input)+    y <- liftIO $ atomically $ do+        ys' <- readTVar ys+        let (y, ys'') = case ys' of+                        (h : t) -> (h, t)+                        _ -> ("Unexpected GetLine!", [])+        writeTVar ys ys''+        modifyTVar' xs (\xs' -> show y <> " <- GetLine" : xs')+        pure y+    executor $ k y++testHelloWorldEffect ::+    ( MonadReader r m+    , Has (Tagged Output (TVar [String])) r+    , MonadIO m+    )+    => HelloWorldEffect -> m ()+testHelloWorldEffect HelloWorld = do+    xs <- view (hasTag @Output)+    liftIO $ atomically $ modifyTVar' xs (\xs' -> "Hello World" : xs')+testHelloWorldEffect ByeWorld = do+    xs <- view (hasTag @Output)+    liftIO $ atomically $ modifyTVar' xs (\xs' -> "Bye, World" : xs')++-- | Combine test interpreters+testEffects' ::+    ( MonadReader r m+    , Has (Tagged Output (TVar [String])) r+    , Has (Tagged Input (TVar [String])) r+    , MonadUnliftIO m+    , AsFacet (IOEffect cmd) cmd+    , AsFacet HelloWorldEffect cmd+    , AsConcur cmd+    )+    => (cmd -> m ()) -> cmd -> MaybeT m (Proxy '[[cmd], Concur cmd cmd, IOEffect cmd, HelloWorldEffect], ())+testEffects' executor c =+    maybeExec (traverse_ @[] executor) c+    `orMaybeExec` maybeExec ((>>= executor) . execConcur executor) c+    `orMaybeExec` maybeExec (testIOEffect executor) c+    `orMaybeExec` maybeExec testHelloWorldEffect c++-- | Tie testEffects_ with itself to get the final interpreter+testEffects ::+    ( MonadReader r m+    , Has (Tagged Output (TVar [String])) r+    , Has (Tagged Input (TVar [String])) r+    , MonadUnliftIO m+    ) => AppCmd -> m ()+testEffects = verifyExec unAppCmd (fixExec testEffects')++----------------------------------------------+-- programs+----------------------------------------------++ioProgram :: (AsFacet (IOEffect cmd) cmd, AsFacet [cmd] cmd) => State (DL.DList cmd) ()+ioProgram = do+    exec' $ PutStrLn "Write two things"+    evalContT $ do+        -- Use the continuation monad to compose the function to pass into GetLine+        a1 <- sequentially . eval' $ GetLine+        a2 <- sequentially . eval' $ GetLine+        -- Do something monadic/different based on the return value.+        case a1 of+            "secret" -> exec' $ PutStrLn "Easter egg!"+            _ -> do+                exec' $ PutStrLn "Write something else"+                -- more GetLine input+                b <- sequentially . eval' $ GetLine+                exec' $ PutStrLn $ "You wrote: (" <> a1 <> ", " <> a2 <> ") then " <> b++-- | using only concur+ioProgramWithOnlyConcur ::+    ( AsFacet (IOEffect cmd) cmd+    , AsConcur cmd+    -- , MonadCommand cmd m+    ) => State (DL.DList cmd) ()+ioProgramWithOnlyConcur = do+    exec' $ PutStrLn "Write two things"+    concurringly_ $ do+        -- Use the Concur monad to batch two GetLines concurrently+        a1 <- eval' $ GetLine+        a2 <- eval' $ GetLine+        -- Do something monadic/different based on the return value.+        case a1 of+            "secret" -> exec' $ PutStrLn "Easter egg!"+            _ -> do+                exec' $ PutStrLn "Write something else"+                -- more GetLine input+                b <- eval' $ GetLine+                exec' $ PutStrLn $ "You wrote: (" <> a1 <> ", " <> a2 <> ") then " <> b++-- | using concur & cont together+ioProgramWithConcur ::+    ( AsFacet (IOEffect cmd) cmd+    , AsConcur cmd) => State (DL.DList cmd) ()+ioProgramWithConcur = do+    exec' $ PutStrLn "Write two things"+    evalContT $ do+        (a1, a2) <- concurringly $ do+                -- Use the Concur monad to batch two GetLines concurrently+                -- required ApplicativeDo+                a1 <- eval' $ GetLine+                a2 <- eval' $ GetLine+                pure (a1, a2)+        -- Do something monadic/different based on the return value.+        case a1 of+            "secret" -> exec' $ PutStrLn "Easter egg!"+            _ -> do+                exec' $ PutStrLn "Write something else"+                -- more GetLine input+                b <- sequentially . eval' $ GetLine+                exec' $ PutStrLn $ "You wrote: (" <> a1 <> ", " <> a2 <> ") then " <> b++-- | Program using both effects+program ::+    ( AsFacet HelloWorldEffect cmd+    , AsFacet (IOEffect cmd) cmd+    , AsFacet [cmd] cmd) => State (DL.DList cmd) ()+program = do+    exec $ HelloWorld+    ioProgram+    exec $ ByeWorld++main :: IO ()+main = do+    -- Reduce the program to the list of commands.+    let cs :: [AppCmd]+        cs =  DL.toList $ (`execState` mempty) ioProgramWithConcur+        -- cs =  DL.toList $ (`execState` mempty) ioProgramWithOnlyConcur++    -- Shoud randomly have different results depending on which+    -- concurrent GetLine is executed first.++    -- interpret the program commands with preconfigured inputs+    is <- newTVarIO ["secret", "y", "z"]+    os <- newTVarIO ([] :: [String])+    (`runReaderT` (Tagged @Input is, Tagged @Output os)) $ testEffects $ command' @[] cs+    is' <- readTVarIO is+    os' <- readTVarIO os+    putStrLn $ "Unconsumed input: " <> show is'+    putStrLn $ "Effects executed: " <> show (reverse os')++    -- interpret the program commands interactively+    -- execEffects $ command' @[] cs