packages feed

reflex-dynamic-containers (empty) → 0.1.0.0

raw patch · 17 files changed

+1579/−0 lines, 17 filesdep +HUnitdep +basedep +binarysetup-changed

Dependencies added: HUnit, base, binary, containers, deepseq, dependent-map, dependent-sum, hashable, hspec, hspec-contrib, ilist, reflex, reflex-dynamic-containers, reflex-test-host, relude, these

Files

+ ChangeLog.md view
@@ -0,0 +1,4 @@+# Changelog for reflex-dynamic-containers++## 0.1.0.0+- first release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2020++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * 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.++    * Neither the name of Author name here nor the names of other+      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+OWNER 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.
+ README.md view
@@ -0,0 +1,16 @@+# reflex-dynamic-containers++Dynamic containers for reflex.++For usage examples, please see [todo-undo-mvc](https://github.com/pdlla/reflex-todo-undo-mvc-model).++Containers in this library have multiple update events. If any of these fire simultaneously, they will put out an stdout warning via `traceEvent` and all but one of the events are ignored by `leftmost`. This will almost certainly result in undesirable behavior.++PRs are very welcome.++These containers were written for use in [potato-flow](https://github.com/pdlla/potato-flow) (very WIP).++# TODOs+- switch to cabal only for better compatibility with rest of reflex ecosystem+- better documentation and examples+- more testing
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ reflex-dynamic-containers.cabal view
@@ -0,0 +1,90 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 19134950744a096fb8a5bf256e21f5a117e91866a3bb2748edd93da6d3bf9283++name:           reflex-dynamic-containers+version:        0.1.0.0+synopsis:       various dynamic containers for Reflex+description:    Please see the README on GitHub at <https://github.com/pdlla/reflex-dynamic-containers#readme>+category:       FRP, Reflex+homepage:       https://github.com/pdlla/reflex-dynamic-containers#readme+bug-reports:    https://github.com/pdlla/reflex-dynamic-containers/issues+author:         pdlla+maintainer:     chippermonky@gmail.com+copyright:      2020 Peter Lu+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/pdlla/reflex-dynamic-containers++library+  exposed-modules:+      Reflex.Data.ActionStack+      Reflex.Data.List+      Reflex.Data.Sequence+      Reflex.Data.Stack+  other-modules:+      Data.Wedge+      Reflex.Potato.Helpers+      Paths_reflex_dynamic_containers+  hs-source-dirs:+      src+  default-extensions: ApplicativeDo BangPatterns DataKinds ConstraintKinds DeriveFoldable DeriveFunctor DeriveTraversable DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies EmptyCase ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings PatternSynonyms RankNTypes ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators NoImplicitPrelude+  ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints+  build-depends:+      base >=4.7 && <5+    , binary+    , containers+    , deepseq+    , dependent-map+    , dependent-sum+    , hashable+    , ilist+    , reflex+    , reflex-test-host+    , relude+    , these+  default-language: Haskell2010++test-suite reflex-dynamic-containers-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Reflex.Data.ActionStackSpec+      Reflex.Data.ListSpec+      Reflex.Data.SequenceSpec+      Reflex.Data.StackSpec+      Reflex.Potato.Helpers+      Paths_reflex_dynamic_containers+  hs-source-dirs:+      test+  default-extensions: ApplicativeDo BangPatterns DataKinds ConstraintKinds DeriveFoldable DeriveFunctor DeriveTraversable DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies EmptyCase ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings PatternSynonyms RankNTypes ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators NoImplicitPrelude+  ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      HUnit+    , base >=4.7 && <5+    , binary+    , containers+    , deepseq+    , dependent-map+    , dependent-sum+    , hashable+    , hspec+    , hspec-contrib+    , ilist+    , reflex+    , reflex-dynamic-containers+    , reflex-test-host+    , relude+    , these+  default-language: Haskell2010
+ src/Data/Wedge.hs view
@@ -0,0 +1,454 @@+-- |+-- copied from smash-0.1.1.0 to resolve a dependency issue+-- reflex-platform doesn't seem to understand extra-deps from stack.yaml+-- TODO fix the dependency issue so you can remove this+++-- Module       : Data.Wedge+-- Copyright    : (c) 2020 Emily Pillmore+-- License      : BSD-3-Clause+--+-- Maintainer   : Emily Pillmore <emilypi@cohomolo.gy>+-- Stability    : Experimental+-- Portability  : CPP, RankNTypes, TypeApplications+--+-- This module contains the definition for the 'Wedge' datatype. In+-- practice, this type is isomorphic to 'Maybe (Either a b)' - the type with+-- two possibly non-exclusive values and an empty case.++{-# LANGUAGE CPP                #-}+{-# LANGUAGE DeriveAnyClass     #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE LambdaCase         #-}+{-# LANGUAGE RankNTypes         #-}+{-# LANGUAGE TupleSections      #-}+{-# LANGUAGE TypeApplications   #-}++module Data.Wedge+( -- * Datatypes+  -- $general+  Wedge(..)+  -- * Combinators+, quotWedge+, wedgeLeft+, wedgeRight+, fromWedge+, toWedge+, isHere+, isThere+, isNowhere+  -- ** Eliminators+, wedge+  -- ** Filtering+, heres+, theres+, filterHeres+, filterTheres+, filterNowheres+  -- ** Folding+, foldHeres+, foldTheres+, gatherWedges+  -- ** Partitioning+, partitionWedges+, mapWedges+  -- ** Distributivity+, distributeWedge+, codistributeWedge+  -- ** Associativity+, reassocLR+, reassocRL+  -- ** Symmetry+, swapWedge+) where++import           Prelude++import           Control.Applicative (Alternative (..))+import           Control.DeepSeq     (NFData (..))++import           Data.Bifoldable+import           Data.Bifunctor+import           Data.Binary         (Binary (..))+import           Data.Bitraversable+import           Data.Data+import           Data.Hashable+#if __GLASGOW_HASKELL__ < 804+import           Data.Semigroup      (Semigroup (..))+#endif++import           GHC.Generics++{- $general++Categorically, the 'Wedge' datatype represents the coproduct (like, 'Either')+in the category Hask* of pointed Hask types, called a <https://ncatlab.org/nlab/show/wedge+sum wedge sum>.+The category Hask* consists of Hask types affixed with+a dedicated base point along with an object. In Hask, this is+equivalent to `1 + a`, also known as 'Maybe a'. Because we can conflate+basepoints of different types (there is only one @Nothing@ type), the wedge sum is+can be viewed as the type `1 + a + b`, or `Maybe (Either a b)` in Hask.+Pictorially, one can visualize this as:+++@+'Wedge':+                a+                |+Nowhere +-------++                |+                b+@+++The fact that we can think about 'Wedge' as a coproduct gives us+some reasoning power about how a 'Wedge' will interact with the+product in Hask*, called 'Can'. Namely, we know that a product of a type and a+coproduct, `a * (b + c)`, is equivalent to `(a + b) * (a + c)`. Additioally,+we may derive other facts about its associativity, distributivity, commutativity, and+any more. As an exercise, think of soemthing `Either` can do. Now do it with 'Wedge'!++-}++-- | The 'Wedge' data type represents values with two exclusive+-- possibilities, and an empty case. This is a coproduct of pointed+-- types - i.e. of 'Maybe' values. The result is a type, 'Wedge a b',+-- which is isomorphic to 'Maybe (Either a b)'.+--+data Wedge a b = Nowhere | Here a | There b+  deriving+    ( Eq, Ord, Read, Show+    , Generic, Generic1+    , Typeable, Data+    )++-- -------------------------------------------------------------------- --+-- Eliminators++-- | Case elimination for the 'Wedge' datatype.+--+wedge+    :: c+    -> (a -> c)+    -> (b -> c)+    -> Wedge a b+    -> c+wedge c _ _ Nowhere   = c+wedge _ f _ (Here a)  = f a+wedge _ _ g (There b) = g b++-- -------------------------------------------------------------------- --+-- Combinators++-- | Given two possible pointed types, produce a 'Wedge' by+-- considering the left case, the right case, and mapping their+-- 'Nothing' cases to 'Nowhere'. This is a pushout of pointed+-- types `A <- * -> B`.+--+quotWedge :: Either (Maybe a) (Maybe b) -> Wedge a b+quotWedge (Left a)  = maybe Nowhere Here a+quotWedge (Right b) = maybe Nowhere There b++-- | Convert a 'Wedge a b' into a 'Maybe (Either a b)' value.+--+fromWedge :: Wedge a b -> Maybe (Either a b)+fromWedge Nowhere   = Nothing+fromWedge (Here a)  = Just (Left a)+fromWedge (There b) = Just (Right b)++-- | Convert a 'Maybe (Either a b)' value into a 'Wedge'+--+toWedge :: Maybe (Either a b) -> Wedge a b+toWedge Nothing  = Nowhere+toWedge (Just e) = either Here There e++-- | Inject a 'Maybe' value into the 'Here' case of a 'Wedge',+-- or 'Nowhere' if the empty case is given. This is analogous to the+-- 'Left' constructor for 'Either'.+--+wedgeLeft :: Maybe a -> Wedge a b+wedgeLeft Nothing  = Nowhere+wedgeLeft (Just a) = Here a++-- | Inject a 'Maybe' value into the 'There' case of a 'Wedge',+-- or 'Nowhere' if the empty case is given. This is analogous to the+-- 'Right' constructor for 'Either'.+--+wedgeRight :: Maybe b -> Wedge a b+wedgeRight Nothing  = Nowhere+wedgeRight (Just b) = There b++-- | Detect if a 'Wedge' is a 'Here' case.+--+isHere :: Wedge a b -> Bool+isHere = \case+  Here _ -> True+  _ -> False++-- | Detect if a 'Wedge' is a 'There' case.+--+isThere :: Wedge a b -> Bool+isThere = \case+  There _ -> True+  _ -> False++-- | Detect if a 'Wedge' is a 'Nowhere' empty case.+--+isNowhere :: Wedge a b -> Bool+isNowhere = \case+  Nowhere -> True+  _ -> False++-- -------------------------------------------------------------------- --+-- Filtering+++-- | Given a 'Foldable' of 'Wedge's, collect the 'Here' cases, if any.+--+heres :: Foldable f => f (Wedge a b) -> [a]+heres = foldr go mempty+  where+    go (Here a) acc = a:acc+    go _ acc        = acc++-- | Given a 'Foldable' of 'Wedge's, collect the 'There' cases, if any.+--+theres :: Foldable f => f (Wedge a b) -> [b]+theres = foldr go mempty+  where+    go (There b) acc = b:acc+    go _ acc         = acc++-- | Filter the 'Here' cases of a 'Foldable' of 'Wedge's.+--+filterHeres :: Foldable f => f (Wedge a b) -> [Wedge a b]+filterHeres = foldr go mempty+  where+    go (Here _) acc = acc+    go ab acc       = ab:acc++-- | Filter the 'There' cases of a 'Foldable' of 'Wedge's.+--+filterTheres :: Foldable f => f (Wedge a b) -> [Wedge a b]+filterTheres = foldr go mempty+  where+    go (There _) acc = acc+    go ab acc        = ab:acc++-- | Filter the 'Nowhere' cases of a 'Foldable' of 'Wedge's.+--+filterNowheres :: Foldable f => f (Wedge a b) -> [Wedge a b]+filterNowheres = foldr go mempty+  where+    go Nowhere acc = acc+    go ab acc      = ab:acc++-- -------------------------------------------------------------------- --+-- Filtering++-- | Fold over the 'Here' cases of a 'Foldable' of 'Wedge's by some+-- accumulating function.+--+foldHeres :: Foldable f => (a -> m -> m) -> m -> f (Wedge a b) -> m+foldHeres k = foldr go+  where+    go (Here a) acc = k a acc+    go _ acc        = acc++-- | Fold over the 'There' cases of a 'Foldable' of 'Wedge's by some+-- accumulating function.+--+foldTheres :: Foldable f => (b -> m -> m) -> m -> f (Wedge a b) -> m+foldTheres k = foldr go+  where+    go (There b) acc = k b acc+    go _ acc         = acc+++-- | Given a 'Wedge' of lists, produce a list of wedges by mapping+-- the list of 'as' to 'Here' values, or the list of 'bs' to 'There'+-- values.+--+gatherWedges :: Wedge [a] [b] -> [Wedge a b]+gatherWedges Nowhere    = []+gatherWedges (Here as)  = fmap Here as+gatherWedges (There bs) = fmap There bs++-- -------------------------------------------------------------------- --+-- Partitioning++-- | Given a 'Foldable' of 'Wedge's, partition it into a tuple of alternatives+-- their parts.+--+partitionWedges+    :: forall f t a b+    . ( Foldable t+      , Alternative f+      )+    => t (Wedge a b) -> (f a, f b)+partitionWedges = foldr go (empty, empty)+  where+    go Nowhere acc        = acc+    go (Here a) (as, bs)  = (pure a <|> as, bs)+    go (There b) (as, bs) = (as, pure b <|> bs)++-- | Partition a structure by mapping its contents into 'Wedge's,+-- and folding over '(<|>)'.+--+mapWedges+    :: forall f t a b c+    . ( Alternative f+      , Traversable t+      )+    => (a -> Wedge b c)+    -> t a+    -> (f b, f c)+mapWedges f = partitionWedges . fmap f++-- -------------------------------------------------------------------- --+-- Associativity++-- | Re-associate a 'Wedge' of 'Wedge's from left to right.+--+reassocLR :: Wedge (Wedge a b) c -> Wedge a (Wedge b c)+reassocLR = \case+    Nowhere -> Nowhere+    Here w -> case w of+      Nowhere -> There Nowhere+      Here a  -> Here a+      There b -> There (Here b)+    There c -> There (There c)++-- | Re-associate a 'Wedge' of 'Wedge's from left to right.+--+reassocRL :: Wedge a (Wedge b c) -> Wedge (Wedge a b) c+reassocRL = \case+  Nowhere -> Nowhere+  Here a -> Here (Here a)+  There w -> case w of+    Nowhere -> Here Nowhere+    Here b  -> Here (There b)+    There c -> There c++-- -------------------------------------------------------------------- --+-- Distributivity++-- | Distribute a 'Wedge' over a product.+--+distributeWedge :: Wedge (a,b) c -> (Wedge a c, Wedge b c)+distributeWedge = \case+  Nowhere -> (Nowhere, Nowhere)+  Here (a,b) -> (Here a, Here b)+  There c -> (There c, There c)++-- | Codistribute 'Wedge's over a coproduct+--+codistributeWedge :: Either (Wedge a c) (Wedge b c) -> Wedge (Either a b) c+codistributeWedge = \case+  Left w -> case w of+    Nowhere -> Nowhere+    Here a  -> Here (Left a)+    There c -> There c+  Right w -> case w of+    Nowhere -> Nowhere+    Here b  -> Here (Right b)+    There c -> There c++-- -------------------------------------------------------------------- --+-- Symmetry++-- | Swap the positions of the @a@'s and the @b@'s in a 'Wedge'.+--+swapWedge :: Wedge a b -> Wedge b a+swapWedge = \case+  Nowhere -> Nowhere+  Here a -> There a+  There b -> Here b++-- -------------------------------------------------------------------- --+-- Std instances++instance (Hashable a, Hashable b) => Hashable (Wedge a b)++instance Functor (Wedge a) where+  fmap f = \case+    Nowhere -> Nowhere+    Here a -> Here a+    There b -> There (f b)++instance Foldable (Wedge a) where+  foldMap f (There b) = f b+  foldMap _ _         = mempty++instance Traversable (Wedge a) where+  traverse f = \case+    Nowhere -> pure Nowhere+    Here a -> pure (Here a)+    There b -> There <$> f b++instance Semigroup a => Applicative (Wedge a) where+  pure = There++  _ <*> Nowhere = Nowhere+  Nowhere <*> _ = Nowhere+  Here a <*> _ = Here a+  There _ <*> Here b = Here b+  There f <*> There a = There (f a)++instance Semigroup a => Monad (Wedge a) where+  return = pure+  (>>) = (*>)++  Nowhere >>= _ = Nowhere+  Here a >>= _ = Here a+  There b >>= k = k b++instance (Semigroup a, Semigroup b) => Semigroup (Wedge a b) where+  Nowhere <> b = b+  a <> Nowhere = a+  Here a <> Here b = Here (a <> b)+  Here _ <> There b = There b+  There a <> Here _ = There a+  There a <> There b = There (a <> b)++instance (Semigroup a, Semigroup b) => Monoid (Wedge a b) where+  mempty = Nowhere+  mappend = (<>)++instance (NFData a, NFData b) => NFData (Wedge a b) where+    rnf Nowhere   = ()+    rnf (Here a)  = rnf a+    rnf (There b) = rnf b++instance (Binary a, Binary b) => Binary (Wedge a b) where+  put Nowhere   = put @Int 0+  put (Here a)  = put @Int 1 >> put a+  put (There b) = put @Int 2 >> put b++  get = get @Int >>= \case+    0 -> pure Nowhere+    1 -> Here <$> get+    2 -> There <$> get+    _ -> fail "Invalid Wedge index"++-- -------------------------------------------------------------------- --+-- Bifunctors++instance Bifunctor Wedge where+  bimap f g = \case+    Nowhere -> Nowhere+    Here a -> Here (f a)+    There b -> There (g b)++instance Bifoldable Wedge where+  bifoldMap f g = \case+    Nowhere -> mempty+    Here a -> f a+    There b -> g b++instance Bitraversable Wedge where+  bitraverse f g = \case+    Nowhere -> pure Nowhere+    Here a -> Here <$> f a+    There b -> There <$> g b
+ src/Reflex/Data/ActionStack.hs view
@@ -0,0 +1,118 @@+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2020 Peter Lu+-- License     :  see the file LICENSE+--+-- Maintainer  :  pdlla <chippermonky@gmail.com>+-- Stability   :  experimental+--+-- A dynamic structure intended for modelling action stacks for undo/redo.+-- Internally, it is represented as two stacks: "done" and "undone".+-- Redo/undo moves the top element from one stack to another.+-- New do events add elements to the "done" stack and clears the "undone" stack.+----------------------------------------------------------------------------+{-# LANGUAGE RecordWildCards #-}++module Reflex.Data.ActionStack+  ( ActionStack(..)+  , actionStack_makeDoSelector+  , actionStack_makeUndoSelector+  , ActionStackConfig(..)+  , holdActionStack+  )+where++import           Relude++import           Reflex+import           Reflex.Potato.Helpers++import           Control.Monad.Fix++import qualified Data.Dependent.Sum    as DS+import qualified Data.GADT.Compare+import           Data.Wedge++data ActionStack t a = ActionStack {+  _actionStack_do     :: Event t a -- ^ fires when element is added to do stack+  , _actionStack_undo :: Event t a -- ^ fires when element is added to undo stack++  -- TODO this is misleading as only the undone stack gets cleared, not the done stack+  -- TODO change it so it's only when undone gets cleared or remove this event all together+  --, _actionStack_clear       :: Event t () -- ^ fires when action stack is cleared either due to a new do action or clear event++  -- probably don't want to expose these?+  --, _actionStack_doneStack   :: Dynamic t [a] -- ^ stack of actions we've done+  --, _actionStack_undoneStack :: Dynamic t [a] -- ^ stack of actions we've undone+}++-- | helper method for ActionStacks that use DSum to represent actions+actionStack_makeDoSelector+  :: (Data.GADT.Compare.GCompare k, Reflex t)+  => ActionStack t (DS.DSum k Identity)+  -> (k a -> Event t a)+actionStack_makeDoSelector as = select (fanDSum $ _actionStack_do as)++-- | helper method for ActionStacks that use DSum to represent actions+actionStack_makeUndoSelector+  :: (Data.GADT.Compare.GCompare k, Reflex t)+  => ActionStack t (DS.DSum k Identity)+  -> (k a -> Event t a)+actionStack_makeUndoSelector as = select (fanDSum $ _actionStack_undo as)++data ActionStackConfig t a = ActionStackConfig {+  _actionStackConfig_do      :: Event t a -- ^ event to add an element to the stack+  , _actionStackConfig_undo  :: Event t () -- ^ event to undo top action of do stack+  , _actionStackConfig_redo  :: Event t () -- ^ event to redo top action of undo stack+  , _actionStackConfig_clear :: Event t () -- ^ clears both do/undo stack without firing any do/undo events+}++-- helper type for holdActionStack+data ASCmd a = ASCDo a | ASCUndo | ASCRedo | ASCClear+++holdActionStack+  :: forall t m a+   . (Reflex t, MonadHold t m, MonadFix m)+  => ActionStackConfig t a+  -> m (ActionStack t a)+holdActionStack (ActionStackConfig {..}) = do+  let+    changeEvent :: Event t (ASCmd a)+    changeEvent = leftmostwarn+      "ActionStack"+      [ fmap ASCDo            _actionStackConfig_do+      , fmap (const ASCUndo)  _actionStackConfig_undo+      , fmap (const ASCRedo)  _actionStackConfig_redo+      , fmap (const ASCClear) _actionStackConfig_clear+      ]++    -- Wedge values:+    -- 'Here' is element that was just added to do stack+    -- 'There' is element that was just added to undo stack+    -- 'Nowhere' is everything else+    foldfn+      :: (ASCmd a) -> (Wedge a a, [a], [a]) -> PushM t (Wedge a a, [a], [a])+    foldfn (ASCDo x) (_, xs    , _     ) = return (Here x, x : xs, []) -- clear undo stack on each new do+    foldfn ASCUndo   (_, []    , ys    ) = return (Nowhere, [], ys)+    foldfn ASCUndo   (_, x : xs, ys    ) = return (There x, xs, x : ys)+    foldfn ASCRedo   (_, xs    , []    ) = return (Nowhere, xs, [])+    foldfn ASCRedo   (_, xs    , y : ys) = return (Here y, y : xs, ys)+    foldfn ASCClear  (_, _     , _     ) = return (Nowhere, [], [])++  asdyn :: Dynamic t (Wedge a a, [a], [a]) <- foldDynM foldfn+                                                       (Nowhere, [], [])+                                                       changeEvent++  let changedEv :: Event t (Wedge a a)+      changedEv = fmap (\(x, _, _) -> x) (updated asdyn)++  return $ ActionStack { _actionStack_do   = fmapMaybe getHere changedEv+                       , _actionStack_undo = fmapMaybe getThere changedEv+    -- see comments in ActionStack definition above+    --, _actionStack_clear = leftmost [void _actionStackConfig_do, _actionStackConfig_clear]++    -- just delete these+    --, _actionStack_doneStack = fmap (\(_,x,_)->x) asdyn+    --, _actionStack_undoneStack = fmap (\(_,_,x)->x) asdyn+                       }
+ src/Reflex/Data/List.hs view
@@ -0,0 +1,161 @@+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2020 Peter Lu+-- License     :  see the file LICENSE+--+-- Maintainer  :  pdlla <chippermonky@gmail.com>+-- Stability   :  experimental+--+-- A dynamic list which are a set of input and output events that wrap an+-- internal 'Dynamic [a]'. Just like haskell lists, DynamicList is probably not+-- what you want. Perhaps you are looking for 'Reflex.Data.Sequence' or+-- 'Reflex.Data.Stack'?+----------------------------------------------------------------------------+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecursiveDo     #-}++module Reflex.Data.List+  ( DynamicList(..)+  , DynamicListConfig(..)+  , defaultDynamicListConfig+  , holdDynamicList+  )+where++import           Relude++import           Reflex+import           Reflex.Potato.Helpers++import           Control.Monad.Fix++import           Data.List.Index++data DynamicList t a = DynamicList {+  -- TODO rename to added/removed+  _dynamicList_added      :: Event t (Int, a)+  , _dynamicList_removed  :: Event t a+  , _dynamicList_contents :: Dynamic t [a]+}++data DynamicListConfig t a = DynamicListConfig {+  -- | event to add an element at a given index+  _dynamicListConfig_add       :: Event t (Int, a)+  -- | event to remove an element at given index+  , _dynamicListConfig_remove  :: Event t Int+  -- | event to add an element to front of list+  , _dynamicListConfig_push    :: Event t a+  -- | event to remove an element from front of list+  , _dynamicListConfig_pop     :: Event t ()+  -- | event to add an element to back of list+  , _dynamicListConfig_enqueue :: Event t a+  -- | event to remove an element from back of list+  , _dynamicListConfig_dequeue :: Event t ()+}++-- this is available since relude 0.6.0.0 as !!?+-- but nix/cabal can't seem to download 0.6.0.0 so I just do this instead+infix 9 !!!?+(!!!?) :: [a] -> Int -> Maybe a+(!!!?) xs i | i < 0     = Nothing+            | otherwise = go i xs+ where+  go :: Int -> [a] -> Maybe a+  go 0 (x : _ ) = Just x+  go j (_ : ys) = go (j - 1) ys+  go _ []       = Nothing+{-# INLINE (!!!?) #-}+++-- TODO switch to Data.Default+defaultDynamicListConfig :: (Reflex t) => DynamicListConfig t a+defaultDynamicListConfig = DynamicListConfig+  { _dynamicListConfig_add     = never+  , _dynamicListConfig_remove  = never+  , _dynamicListConfig_push    = never+  , _dynamicListConfig_pop     = never+  , _dynamicListConfig_enqueue = never+  , _dynamicListConfig_dequeue = never+  }+++data LState a = LSInserted (Int, a) | LSRemoved a | LSNothing+data DLCmd t a = DLCAdd (Int, a) | DLCRemove Int++-- | create a dynamic list+holdDynamicList+  :: forall t m a+   . (Reflex t, MonadHold t m, MonadFix m)+  => [a] -- ^ initial value+  -> DynamicListConfig t a+  -> m (DynamicList t a)+holdDynamicList initial (DynamicListConfig {..}) = mdo+  let _dynamicListConfig_add'  = _dynamicListConfig_add+      _dynamicListConfig_push' = fmap (\x -> (0, x)) _dynamicListConfig_push+      _dynamicListConfig_pop'  = fmap (const 0) _dynamicListConfig_pop+      _dynamicListConfig_enqueue' =+        attach (fmap length (current dlc)) _dynamicListConfig_enqueue+      _dynamicListConfig_dequeue' =+        tag (fmap ((+ (-1)) . length) (current dlc)) _dynamicListConfig_dequeue++      dlAdd =+        leftmost+          $     DLCAdd+          <<$>> [ _dynamicListConfig_add'+                , _dynamicListConfig_push'+                , _dynamicListConfig_enqueue'+                ]+      dlRemove =+        leftmost+          $     DLCRemove+          <<$>> [ _dynamicListConfig_remove+                , _dynamicListConfig_pop'+                , _dynamicListConfig_dequeue'+                ]++      -- TODO change to leftmost+      -- ensure these events never fire simultaneously as the indexing may be off+      changeEvent :: Event t (DLCmd t a)+      changeEvent = leftmostwarn "List" [dlRemove, dlAdd]++      foldfn :: DLCmd t a -> (LState a, [a]) -> Maybe (LState a, [a])+      foldfn op (_, xs) =+        let+          -- this code is a little convoluted because there use to be a "move" command that I since removed+            add' (index, x) xs' = do+              guard $ index >= 0 && index <= length xs'+              return $ insertAt index x xs'+            add :: (Int, a) -> Maybe (LState a, [a])+            add (index, x) = do+              xs' <- add' (index, x) xs+              return $ (LSInserted (index, x), xs')+            remove' index = do+              x <- xs !!!? index+              return $ (x, deleteAt index xs)+            remove :: Int -> Maybe (LState a, [a])+            remove index = do+              (x, xs') <- remove' index+              return $ (LSRemoved x, xs')+        in  case op of+              DLCAdd    x -> add x+              DLCRemove x -> remove x++  dynInt :: Dynamic t (LState a, [a]) <- foldDynMaybe foldfn+                                                      (LSNothing, initial)+                                                      changeEvent++  let evInt = fmap fst (updated dynInt)++      evAddSelect c = case c of+        LSInserted x -> Just x+        _            -> Nothing+      evRemoveSelect c = case c of+        LSRemoved x -> Just x+        _           -> Nothing++      dlc = fmap snd dynInt++  return $ DynamicList { _dynamicList_added    = fmapMaybe evAddSelect evInt+                       , _dynamicList_removed  = fmapMaybe evRemoveSelect evInt+                       , _dynamicList_contents = dlc+                       }
+ src/Reflex/Data/Sequence.hs view
@@ -0,0 +1,116 @@+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2020 Peter Lu+-- License     :  see the file LICENSE+--+-- Maintainer  :  pdlla <chippermonky@gmail.com>+-- Stability   :  experimental+--+-- A dynamic seq which are a set of input and output events that wrap an+-- internal 'Dynamic (Seq a)'.+----------------------------------------------------------------------------+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecursiveDo     #-}++module Reflex.Data.Sequence+  ( DynamicSeq(..)+  , DynamicSeqConfig(..)+  , defaultDynamicSeqConfig+  , dynamicSeq_attachEndPos+  , holdDynamicSeq+  )+where++import           Relude                hiding (empty, splitAt)++import           Reflex+import           Reflex.Potato.Helpers++import           Control.Monad.Fix++import           Data.Sequence         as Seq+import           Data.Wedge+++data DynamicSeq t a = DynamicSeq {+  -- | index and sub sequence that was just added+  _dynamicSeq_inserted   :: Event t (Int, Seq a)+  -- | original index of removed sub sequence and removed subsequence+  , _dynamicSeq_removed  :: Event t (Int, Seq a)+  -- TODO+  -- though you can probably do this by adding + removing with runWithReplace+  --, _dynamicSeq_moved     :: Event t (Int, a)+  -- | internal state of contents+  , _dynamicSeq_contents :: Dynamic t (Seq a)+}++-- | The interface only supports adding and removing several consecutive+-- elements. Use with 'singleton x' to add single elements.+data DynamicSeqConfig t a = DynamicSeqConfig {+  -- | index and sub sequence to add+  _dynamicSeqConfig_insert   :: Event t (Int, Seq a)+  -- | index and number of elements to remove+  , _dynamicSeqConfig_remove :: Event t (Int, Int)+  -- | same as removing all elts+  , _dynamicSeqConfig_clear  :: Event t ()++  -- TODO+  --, _dynamicSeqConfig_move    :: Event t (Int,Int)+}++defaultDynamicSeqConfig :: (Reflex t) => DynamicSeqConfig t a+defaultDynamicSeqConfig = DynamicSeqConfig { _dynamicSeqConfig_insert = never+                                           , _dynamicSeqConfig_remove = never+                                           , _dynamicSeqConfig_clear  = never+                                           }+++-- | use for inserting at end of seq+dynamicSeq_attachEndPos+  :: (Reflex t) => DynamicSeq t a -> Event t b -> Event t (Int, b)+dynamicSeq_attachEndPos DynamicSeq {..} =+  attach (Seq.length <$> current _dynamicSeq_contents)+++type DSState a = (Wedge (Int, Seq a) (Int, Seq a), Seq a)+data DSCmd t a = DSCAdd (Int, Seq a) | DSCRemove (Int, Int) | DSCClear++-- | create a dynamic list+holdDynamicSeq+  :: forall t m a+   . (Reflex t, MonadHold t m, MonadFix m)+  => Seq a+  -> DynamicSeqConfig t a+  -> m (DynamicSeq t a)+holdDynamicSeq initial DynamicSeqConfig {..} = mdo+  let changeEvent :: Event t (DSCmd t a)+      changeEvent = leftmostwarn+        "WARNING: multiple Seq events firing at once"+        [ fmap DSCAdd           _dynamicSeqConfig_insert+        , fmap DSCRemove        _dynamicSeqConfig_remove+        , fmap (const DSCClear) _dynamicSeqConfig_clear+        ]++      -- Wedge values:+      -- Here is elements that was just added fromSeq+      -- There is elements that was just removed from Seq+      -- Nowhere is everything else+      foldfn :: (DSCmd t a) -> DSState a -> PushM t (DSState a)+      foldfn (DSCAdd (i, ys)) (_, xs) = return (Here (i, ys), newSeq)       where+        (l, r) = splitAt i xs+        newSeq = l >< ys >< r+      foldfn (DSCRemove (i, n)) (_, xs) = return (There (i, removed), newSeq)       where+        (keepl  , rs   ) = splitAt i xs+        (removed, keepr) = splitAt n rs+        newSeq           = keepl >< keepr+      foldfn DSCClear (_, xs) = return (There (0, xs), empty)++  asdyn :: Dynamic t (DSState a) <- foldDynM foldfn+                                             (Nowhere, initial)+                                             changeEvent++  return $ DynamicSeq+    { _dynamicSeq_inserted = fmapMaybe (getHere . fst) $ updated asdyn+    , _dynamicSeq_removed  = fmapMaybe (getThere . fst) $ updated asdyn+    , _dynamicSeq_contents = snd <$> asdyn+    }
+ src/Reflex/Data/Stack.hs view
@@ -0,0 +1,93 @@+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2020 Peter Lu+-- License     :  see the file LICENSE+--+-- Maintainer  :  pdlla <chippermonky@gmail.com>+-- Stability   :  experimental+--+-- This is the same as 'Reflex.Dynamic.List' but with a+-- limited interface.+----------------------------------------------------------------------------++{-# LANGUAGE RecordWildCards #-}++module Reflex.Data.Stack+  ( DynamicStack(..)+  , DynamicStackConfig(..)+  , defaultDynamicStackConfig+  , holdDynamicStack+  )+where++import           Relude++import           Reflex+import           Reflex.Potato.Helpers++import           Control.Monad.Fix++import           Data.Wedge+++data DynamicStack t a = DynamicStack {+  _dynamicStack_pushed     :: Event t a+  , _dynamicStack_popped   :: Event t a+  , _dynamicStack_contents :: Dynamic t [a]+}++data DynamicStackConfig t a = DynamicStackConfig {+  _dynamicStackConfig_push    :: Event t a+  , _dynamicStackConfig_pop   :: Event t () -- ^ event to pop an elt from the stack+  , _dynamicStackConfig_clear :: Event t () -- ^ event to clear the stack, this does NOT trigger any pop events!!+}++-- I can't seem to instantiate from this without getting a could not deduce Reflex t0 error+-- it can't seem to match the t inside and the t outside? I don't understand+defaultDynamicStackConfig :: (Reflex t) => DynamicStackConfig t a+defaultDynamicStackConfig = DynamicStackConfig+  { _dynamicStackConfig_push  = never+  , _dynamicStackConfig_pop   = never+  , _dynamicStackConfig_clear = never+  }++-- helper type for holdDynamicStack+data DSCmd t a = DSCPush a | DSCPop | DSCClear++-- | create a dynamic list+holdDynamicStack+  :: forall t m a+   . (Reflex t, MonadHold t m, MonadFix m)+  => [a]+  -> DynamicStackConfig t a+  -> m (DynamicStack t a)+holdDynamicStack initial (DynamicStackConfig {..}) = do+  let changeEvent :: Event t (DSCmd t a)+      changeEvent = leftmostwarn+        "Stack"+        [ fmap DSCPush          _dynamicStackConfig_push+        , fmap (const DSCPop)   _dynamicStackConfig_pop+        , fmap (const DSCClear) _dynamicStackConfig_clear+        ]++      -- Wedge values:+      -- Here is element that was just pushed+      -- There is element that was just popped+      -- Nowhere is initial state or just popped an empty stack or after a clear+      foldfn :: (DSCmd t a) -> (Wedge a a, [a]) -> PushM t (Wedge a a, [a])+      foldfn (DSCPush x) (_, xs      ) = return (Here x, x : xs)+      foldfn DSCPop      (_, []      ) = return (Nowhere, [])+      foldfn DSCPop      (_, (x : xs)) = return (There x, xs)+      foldfn DSCClear    (_, _       ) = return (Nowhere, [])++  sdyn :: Dynamic t (Wedge a a, [a]) <- foldDynM foldfn+                                                 (Nowhere, initial)+                                                 changeEvent++  let changedEv :: Event t (Wedge a a)+      changedEv = fmap fst (updated sdyn)++  return $ DynamicStack { _dynamicStack_pushed   = fmapMaybe getHere changedEv+                        , _dynamicStack_popped   = fmapMaybe getThere changedEv+                        , _dynamicStack_contents = fmap snd sdyn+                        }
+ src/Reflex/Potato/Helpers.hs view
@@ -0,0 +1,80 @@+-- |+-- random helper methods, nothing to see here+-- the only reason this is exposed is so I can use this in tests+-- if you find any of these useful and want more please see the same file in https://github.com/pdlla/potato-flow+{-# LANGUAGE RecursiveDo #-}++module Reflex.Potato.Helpers+  ( leftmostwarn+  , fanDSum+  , foldDynMergeWith+  , getLeft+  , getRight+  , getHere+  , getThere+  )+where++import           Relude++import           Reflex++import           Control.Monad.Fix++import qualified Data.Dependent.Map as DM+import qualified Data.Dependent.Sum as DS+import           Data.Wedge++++-- | same as leftmost but outputs a warning if more than one event fires at once+leftmostwarn :: (Reflex t) => String -> [Event t a] -> Event t a+leftmostwarn label evs = r where+  combine = mergeList evs+  nowarn =+    fmapMaybe (\x -> if length x == 1 then Just (head x) else Nothing) combine+  warn =+    traceEventWith+        (const ("WARNING: multiple " <> label <> " events triggered"))+      $ fmapMaybe (\x -> if length x > 1 then Just (head x) else Nothing)+                  combine+  r = leftmost [nowarn, warn]+++fanDSum+  :: forall t k+   . (Reflex t, DM.GCompare k)+  => Event t (DS.DSum k Identity)+  -> EventSelector t k+fanDSum ds = fan $ DM.fromAscList . (: []) <$> ds+++foldDynMergeWith+  :: (Reflex t, MonadHold t m, MonadFix m)+  => b -- ^ initial value of dynamic+  -> [Event t (b -> b)]  -- ^ list of events producing a reducing method+  -> m (Dynamic t b)  -- ^ final output after all folding methods applied+foldDynMergeWith acc = foldDyn ($) acc . mergeWith (.)+++++getLeft :: Either a b -> Maybe a+getLeft (Left x) = Just x+getLeft _        = Nothing++getRight :: Either a b -> Maybe b+getRight (Right x) = Just x+getRight _         = Nothing+++-- my additions+getHere :: Wedge a b -> Maybe a+getHere c = case c of+  Here x -> Just x+  _      -> Nothing++getThere :: Wedge a b -> Maybe b+getThere c = case c of+  There x -> Just x+  _       -> Nothing
+ test/Reflex/Data/ActionStackSpec.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE RecursiveDo #-}++module Reflex.Data.ActionStackSpec+  ( spec+  )+where++import           Relude++import           Test.Hspec+import           Test.Hspec.Contrib.HUnit       ( fromHUnitTest )+import           Test.HUnit++import qualified Data.List                     as L+                                                ( last )++import           Reflex+import           Reflex.Data.ActionStack+import           Reflex.Potato.Helpers+import           Reflex.Test.Host++data TestCmd a = TCDo a | TCUndo | TCRedo | TCClear deriving (Eq, Show)++simple_state_network+  :: forall t a s m+   . (t ~ SpiderTimeline Global, m ~ SpiderHost Global)+  => (a -> s -> s) -- ^ do/redo method to transform state+  -> (a -> s -> s) -- ^ undo method to transform state+  -> s -- ^ initial state+  -> (Event t (TestCmd a) -> PerformEventT t m (Event t s)) -- ^ test app producing final state+simple_state_network fdo fundo initial ev = do+  let doEv = flip fmapMaybe ev $ \case+        TCDo a -> Just a+        _      -> Nothing+      undoEv = flip fmapMaybe ev $ \case+        TCUndo -> Just ()+        _      -> Nothing+      redoEv = flip fmapMaybe ev $ \case+        TCRedo -> Just ()+        _      -> Nothing+      clearEv = flip fmapMaybe ev $ \case+        TCClear -> Just ()+        _       -> Nothing++      mas = ActionStackConfig { _actionStackConfig_do    = doEv+                              , _actionStackConfig_undo  = undoEv+                              , _actionStackConfig_redo  = redoEv+                              , _actionStackConfig_clear = clearEv+                              }+  as :: ActionStack t a <- holdActionStack mas+  adder :: Dynamic t s  <- foldDynMergeWith+    initial+    [fmap fdo (_actionStack_do as), fmap fundo (_actionStack_undo as)]+  return $ updated adder++adder_test :: Test+adder_test = TestLabel "adder app" $ TestCase $ do+  let bs  = [TCDo 1, TCDo 2, TCDo 3, TCUndo, TCUndo, TCRedo, TCDo 100]+      run = runAppSimple (simple_state_network (+) (flip (-)) (0 :: Int)) bs+  v <- liftIO run+  L.last v @?= [Just 103]++spec :: Spec+spec = do+  describe "ActionStack" $ do+    fromHUnitTest adder_test
+ test/Reflex/Data/ListSpec.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE RecursiveDo #-}++module Reflex.Data.ListSpec+  ( spec+  )+where++import           Relude++import           Test.Hspec+import           Test.Hspec.Contrib.HUnit       ( fromHUnitTest )+import           Test.HUnit++import qualified Data.List                     as L+                                                ( last+                                                , tail+                                                )++import           Reflex+import           Reflex.Data.List+import           Reflex.Test.Host++pushAdd_network+  :: forall t m+   . (t ~ SpiderTimeline Global, m ~ SpiderHost Global)+  => (Event t Int -> PerformEventT t m (Event t [Int]))+pushAdd_network ev = mdo+  let+    -- element in the list is a dynamic int that adds to itself each new element added to the list+    -- this includes the element itself!+      pushAddEvent :: Int -> PushM t (Int, Dynamic t Int)+      pushAddEvent n = do+        -- this causes an RTE, maybe a bug?+        --addedEvExcludeSelf <- tailE addedEv+        addedEvExcludeSelf <- return addedEv+        let foldfn :: (Int, Dynamic t Int) -> Int -> PushM t (Maybe Int)+            foldfn (_, justAdded) old = do+              addme <- sample . current $ justAdded+              return $ Just (old + addme)+        dyn <- foldDynMaybeM foldfn n addedEvExcludeSelf+        return (0, dyn)+      mdl = defaultDynamicListConfig+        { _dynamicListConfig_add    = pushAlways pushAddEvent ev+        , _dynamicListConfig_remove = never+        }+      addedEv = _dynamicList_added dl+  dl <- holdDynamicList [] mdl+  return . updated . join . fmap sequence $ _dynamicList_contents dl+++-- use list as a queue of fixed size+pushAdd_test :: Test+pushAdd_test = TestLabel "pushAdd" $ TestCase $ do+  let bs  = [1, 1, 1, 1, 1] :: [Int]+      run = runAppSimple pushAdd_network bs+  v <- liftIO run+  --print v+  let expected = [2, 3, 4, 5, 6]+  L.last v @?= [Just expected]+++push_enqueue_pop_dequeue_network+  :: forall t m+   . (t ~ SpiderTimeline Global, m ~ SpiderHost Global)+  => (Event t Int -> PerformEventT t m (Event t [Int]))+push_enqueue_pop_dequeue_network ev = do+  let+    mdl = defaultDynamicListConfig+      { _dynamicListConfig_push    = fmapMaybe+        (\x -> if x `mod` 4 == 0 then Just x else Nothing)+        ev+      , _dynamicListConfig_enqueue = fmapMaybe+        (\x -> if x `mod` 4 == 1 then Just x else Nothing)+        ev+      , _dynamicListConfig_pop     = fmapMaybe+        (\x -> if x `mod` 4 == 2 then Just () else Nothing)+        ev+      , _dynamicListConfig_dequeue = fmapMaybe+        (\x -> if x `mod` 4 == 3 then Just () else Nothing)+        ev+      }+  dl <- holdDynamicList [] mdl+  return $ updated (_dynamicList_contents dl)++-- basic test case, add to list on each event tick+push_enqueue_pop_dequeue_test :: Test+push_enqueue_pop_dequeue_test =+  TestLabel "push/enqueue/pop/dequeue" $ TestCase $ do+    let bs  = [0, 1, 0, 1, 0, 1, 0, 1, 2, 3, 3] :: [Int]+        run = runAppSimple push_enqueue_pop_dequeue_network bs+    v <- liftIO run+    let expected = Just [0, 0, 0, 1, 1]+    L.last v @?= [expected]+++add_network+  :: forall t m+   . (t ~ SpiderTimeline Global, m ~ SpiderHost Global)+  => (Event t Int -> PerformEventT t m (Event t [Int]))+add_network ev = do+  let mdl = defaultDynamicListConfig+        { _dynamicListConfig_add = (fmap (\x -> (0, x)) ev)+        }+  dl <- holdDynamicList [] mdl+  return $ updated (_dynamicList_contents dl)++-- basic test case, add to list on each event tick+add_test :: Test+add_test = TestLabel "add" $ TestCase $ do+  let bs  = [1 .. 10] :: [Int]+      run = runAppSimple add_network bs+  v <- liftIO run+  let expected = fmap Just . L.tail . scanl (\acc x -> x : acc) [] $ bs+  join v @?= expected++spec :: Spec+spec = do+  describe "List" $ do+    fromHUnitTest add_test+    fromHUnitTest push_enqueue_pop_dequeue_test+    fromHUnitTest pushAdd_test
+ test/Reflex/Data/SequenceSpec.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE RecursiveDo #-}++module Reflex.Data.SequenceSpec+  ( spec+  )+where++import           Relude                  hiding ( empty+                                                , fromList+                                                )++import           Test.Hspec+import           Test.Hspec.Contrib.HUnit       ( fromHUnitTest )+import           Test.HUnit++import qualified Data.List                     as L+                                                ( last )+import           Data.Sequence++import           Reflex+import           Reflex.Data.Sequence++import           Reflex.Test.Host++data SeqCmd a = SCInsert (Int, [a]) | SCRemove (Int, Int) | SCClear deriving (Eq, Show)++seq_network+  :: forall t m a+   . (t ~ SpiderTimeline Global, m ~ SpiderHost Global)+  => (Event t (SeqCmd a) -> PerformEventT t m (Event t (Seq a)))+seq_network ev = do+  let insertEv = flip fmapMaybe ev $ \case+        SCInsert (i, a) -> Just (i, fromList a)+        _               -> Nothing+      removeEv = flip fmapMaybe ev $ \case+        SCRemove x -> Just x+        _          -> Nothing+      clearEv = flip fmapMaybe ev $ \case+        SCClear -> Just ()+        _       -> Nothing+      dseqc = DynamicSeqConfig { _dynamicSeqConfig_insert = insertEv+                               , _dynamicSeqConfig_remove = removeEv+                               , _dynamicSeqConfig_clear  = clearEv+                               }+  dseq <- holdDynamicSeq empty dseqc+  return $ updated $ _dynamicSeq_contents dseq++basic_test :: Test+basic_test = TestLabel "basic" $ TestCase $ do+  let bs =+        [ SCInsert (0, [1 .. 10])+        , SCClear+        , SCInsert (0, [1 .. 10])+        , SCRemove (5, 5)+        , SCInsert (3, [100])+        ] :: [SeqCmd Int]+      run :: IO [[Maybe (Seq Int)]]+      run = runAppSimple seq_network bs+  v <- liftIO run+  L.last v @?= [Just (fromList [1, 2, 3, 100, 4, 5])]+++spec :: Spec+spec = do+  describe "Sequence" $ do+    fromHUnitTest basic_test
+ test/Reflex/Data/StackSpec.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE RecursiveDo #-}++module Reflex.Data.StackSpec+  ( spec+  )+where++import           Relude++import           Test.Hspec+import           Test.Hspec.Contrib.HUnit       ( fromHUnitTest )+import           Test.HUnit++import qualified Data.List                     as L+                                                ( last )++import           Reflex+import           Reflex.Data.Stack+import           Reflex.Potato.Helpers+import           Reflex.Test.Host++data TestCmd a = TCPush a | TCPop | TCClear deriving (Eq, Show)++simple_state_network+  :: forall t a s m+   . (t ~ SpiderTimeline Global, m ~ SpiderHost Global)+  => (a -> s -> s) -- ^ do/redo method to transform state+  -> (a -> s -> s) -- ^ undo method to transform state+  -> s -- ^ initial state+  -> (Event t (TestCmd a) -> PerformEventT t m (Event t s)) -- ^ test app producing final state+simple_state_network fdo fundo initial ev = do+  let pushEv = flip fmapMaybe ev $ \case+        TCPush n -> Just n+        _        -> Nothing+      popEv = flip fmapMaybe ev $ \case+        TCPop -> Just ()+        _     -> Nothing+      clearEv = flip fmapMaybe ev $ \case+        TCClear -> Just ()+        _       -> Nothing++      mds = DynamicStackConfig { _dynamicStackConfig_push  = pushEv+                               , _dynamicStackConfig_pop   = popEv+                               , _dynamicStackConfig_clear = clearEv+                               }+  ds :: DynamicStack t a <- holdDynamicStack [] mds+  adder :: Dynamic t s   <- foldDynMergeWith+    initial+    [fmap fdo (_dynamicStack_pushed ds), fmap fundo (_dynamicStack_popped ds)]+  return $ updated adder++adder_test :: Test+adder_test = TestLabel "adder app" $ TestCase $ do+  let bs =+        fmap TCPush [1 .. 4]+          <> fmap (const TCPop) [(), (), (), (), (), (), ()]+          <> fmap TCPush        [100]+      run = runAppSimple (simple_state_network (+) (flip (-)) (0 :: Int)) bs+  v <- liftIO run+  L.last v @?= [Just 100]+++clear_test_network+  :: forall t m+   . (t ~ SpiderTimeline Global, m ~ SpiderHost Global)+  => (Event t (TestCmd Int) -> PerformEventT t m (Event t [Int]))+clear_test_network ev = do+  let pushEv = flip fmapMaybe ev $ \case+        TCPush n -> Just n+        _        -> Nothing+      popEv   = fmapMaybe (\x -> if x == TCPop then Just () else Nothing) ev+      clearEv = fmapMaybe (\x -> if x == TCClear then Just () else Nothing) ev++      mds     = DynamicStackConfig { _dynamicStackConfig_push  = pushEv+                                   , _dynamicStackConfig_pop   = popEv+                                   , _dynamicStackConfig_clear = clearEv+                                   }+  ds :: DynamicStack t Int <- holdDynamicStack+    []+    (mds :: DynamicStackConfig t Int)+  return $ updated (_dynamicStack_contents ds)++clear_test :: Test+clear_test = TestLabel "clear" $ TestCase $ do+  let bs =+        fmap TCPush [1 .. 13]+          <> fmap (const TCPop) [(), (), ()]+          <> [TCClear]+          <> fmap TCPush [100]+      run = runAppSimple clear_test_network bs+  v <- liftIO run+  L.last v @?= [Just [100]]+++basic_test_network+  :: forall t m+   . (t ~ SpiderTimeline Global, m ~ SpiderHost Global)+  => (Event t (Either Int ()) -> PerformEventT t m (Event t [Int]))+basic_test_network ev = do+  let pushEv = fmapMaybe getLeft ev+      popEv  = fmapMaybe getRight ev++      mds    = DynamicStackConfig { _dynamicStackConfig_push  = pushEv+                                  , _dynamicStackConfig_pop   = popEv+                                  , _dynamicStackConfig_clear = never+                                  }+  ds :: DynamicStack t Int <- holdDynamicStack+    []+    (mds :: DynamicStackConfig t Int)+  return $ updated (_dynamicStack_contents ds)++basic_test :: Test+basic_test = TestLabel "basic" $ TestCase $ do+  let bs  = fmap Left [1 .. 13] <> fmap Right [(), (), ()] :: [Either Int ()]+      run = runAppSimple basic_test_network bs+  v <- liftIO run+  L.last v @?= [Just (drop (length (rights bs)) . reverse $ lefts bs)]++spec :: Spec+spec = do+  describe "Stack" $ do+    fromHUnitTest basic_test+    fromHUnitTest clear_test+    fromHUnitTest adder_test
+ test/Reflex/Potato/Helpers.hs view
@@ -0,0 +1,36 @@+-- |+-- subset of the same file in src/ directory. So I don't have to expose it.+{-# LANGUAGE RecursiveDo #-}++module Reflex.Potato.Helpers+  ( foldDynMergeWith+  , getLeft+  , getRight+  )+where++import           Relude++import           Reflex++import           Control.Monad.Fix++import qualified Data.Dependent.Map as DM+import qualified Data.Dependent.Sum as DS+++foldDynMergeWith+  :: (Reflex t, MonadHold t m, MonadFix m)+  => b -- ^ initial value of dynamic+  -> [Event t (b -> b)]  -- ^ list of events producing a reducing method+  -> m (Dynamic t b)  -- ^ final output after all folding methods applied+foldDynMergeWith acc = foldDyn ($) acc . mergeWith (.)+++getLeft :: Either a b -> Maybe a+getLeft (Left x) = Just x+getLeft _        = Nothing++getRight :: Either a b -> Maybe b+getRight (Right x) = Just x+getRight _         = Nothing
+ test/Spec.hs view
@@ -0,0 +1,2 @@+-- hspec auto-discovery stuff+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}