packages feed

reflex-potatoes (empty) → 0.1.0.0

raw patch · 8 files changed

+898/−0 lines, 8 filesdep +HUnitdep +basedep +dependent-map

Dependencies added: HUnit, base, dependent-map, dependent-sum, hspec, hspec-contrib, ref-tf, reflex, reflex-potatoes, reflex-test-host, relude, semialign, some, text, these

Files

+ ChangeLog.md view
@@ -0,0 +1,4 @@+# Changelog for reflex-potatoes++## 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,3 @@+# reflex-potatoes++This library various reflex-frp helper functions
+ reflex-potatoes.cabal view
@@ -0,0 +1,143 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           reflex-potatoes+version:        0.1.0.0+description:    Please see the README on GitHub at <https://github.com/pdlla/reflex-potatoes#readme>+homepage:       https://github.com/pdlla/reflex-potatoes#readme+bug-reports:    https://github.com/pdlla/reflex-potatoes/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-potatoes++library+  exposed-modules:+      Reflex.Potato.Helpers+  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+    , dependent-map+    , dependent-sum+    , ref-tf+    , reflex >= 0.7 && <1+    , reflex-test-host >=0.1.2+    , relude+    , semialign+    , some+    , text+    , these+  default-language: Haskell2010++test-suite reflex-potatoes-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Reflex.Potato.HelpersSpec+      Reflex.Potato.TestingSpec+  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+    , dependent-map+    , dependent-sum+    , hspec+    , hspec-contrib+    , ref-tf+    , reflex >=0.7 && <1+    , reflex-potatoes+    , reflex-test-host >=0.1.2+    , relude+    , semialign+    , some+    , text+    , these+  default-language: Haskell2010
+ src/Reflex/Potato/Helpers.hs view
@@ -0,0 +1,430 @@+--TODO move some of this stuff into it's own lib when it's properly tested++{-# LANGUAGE RecursiveDo #-}+++++module Reflex.Potato.Helpers+  (+  -- other helpers+    dsum_to_dmap+++  -- reflex helpers+  , simultaneous+  , assertEvent+  , assertEventWith+  , fmapMaybeWarn+  , fmapMaybeWarnWith+  , traceEventSimple+  , leftmostWarn+  , leftmostAssert+  , leftmostWarnWithIndex+  , leftmostWarnWithEverything+  , alignWarn+  , alignAssert+  , foldDynMergeWith+  , foldDynMerge+  , fanDSum+  , pushAlwaysDyn++  , delayEvent+  , sequenceEvents+  , stepEvents+  , stepEventsAndCollectOutput+  , stepEventsAndSequenceCollectOutput++  , switchHoldPair+  , switchHoldTriple++  , waitForSecondAfterFirst+  )+where++import           Prelude            (error)+import           Relude             hiding (error)++import           Reflex++import           Control.Monad.Fix++import           Data.Align+import qualified Data.Dependent.Map as DM+import qualified Data.Dependent.Sum as DS+import qualified Data.GADT.Compare  as DM+import           Data.These++-- | fires only when both events fire+simultaneous :: (Reflex t) => Event t a -> Event t b -> Event t (a,b)+simultaneous eva evb = alignEventWithMaybe+  (\case+    These a b -> Just (a,b)+    _ -> Nothing)+  eva+  evb++dsum_to_dmap :: DM.GCompare k => DS.DSum k f -> DM.DMap k f+dsum_to_dmap ds = DM.fromList [ds]+++{- TODO can't get -fno-ignore-asserts to work+-- | assert that a predicate is true each time the event triggers+-- internall calls assert, which can be disabled via compiler options+-- enable explicitly with {-# OPTIONS_GHC -fno-ignore-asserts #-}+assertEvent :: (Reflex t, Show a)+  => String -- ^ assert message+  -> (a -> Bool) -- ^ predicate to check+  -> Event t a+  -> Event t a+assertEvent s p = fmap (\x -> byPred assert s p x x)++-- | assert that a predicate is true each time the event triggers+-- internall calls assert, which can be disabled via compiler options+-- enable explicitly with {-# OPTIONS_GHC -fno-ignore-asserts #-}+assertEventWith :: (Reflex t)+  => (a -> String) -- ^ assert message+  -> (a -> Bool) -- ^ predicate to check+  -> Event t a+  -> Event t a+assertEventWith sf p = fmap (\x -> byPred assert (sf x) id (p x) x)+-}++-- | assert that a predicate is true each time the event triggers+assertEvent :: (Reflex t, Show a)+  => String -- ^ assert message+  -> (a -> Bool) -- ^ predicate to check+  -> Event t a+  -> Event t a+assertEvent s p = fmap (\x -> if not (p x) then error $ s <> " " <> show x else x)++-- | assert that a predicate is true each time the event triggers+assertEventWith :: (Reflex t)+  => (a -> String) -- ^ assert message+  -> (a -> Bool) -- ^ predicate to check+  -> Event t a+  -> Event t a+assertEventWith sf p = fmap (\x -> if not (p x) then error $ sf x else x)++-- | same as fmapMaybe except outputs a warning if predicate fails+fmapMaybeWarn :: (Reflex t, Show a)+  => String -- ^ warning message+  -> (a -> Bool) -- ^ predicate to check+  -> Event t a+  -> Event t a+fmapMaybeWarn s p ev = r where+  ev' = fmap (\x -> (p x, x)) ev+  good = fmapMaybe (\(a,x) -> if a then Just x else Nothing) ev'+  bad =  fmapMaybe (\(a,x) -> if not a then Just x else Nothing) ev'+  r = leftmost [good, fmapMaybe (const Nothing) $ traceEvent s bad]++-- | same as fmapMaybe except outputs a warning if predicate fails+fmapMaybeWarnWith :: (Reflex t)+  => (a -> String) -- ^ warning message+  -> (a -> Bool) -- ^ predicate to check+  -> Event t a+  -> Event t a+fmapMaybeWarnWith sf p ev = r where+  ev' = fmap (\x -> (p x, x)) ev+  good = fmapMaybe (\(a,x) -> if a then Just x else Nothing) ev'+  bad =  fmapMaybe (\(a,x) -> if not a then Just x else Nothing) ev'+  r = leftmost [good, fmapMaybe (const Nothing) $ traceEventWith sf bad]++traceEventSimple :: (Reflex t) => String -> Event t a -> Event t a+traceEventSimple s = traceEventWith (const s)++-- | 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]++-- | same as leftmost but asserts if more than one event fires at once+leftmostAssert :: (Reflex t) => String -> [Event t a] -> Event t a+leftmostAssert label evs = r where+  combine = mergeList evs+  nowarn =+    fmapMaybe (\x -> if length x == 1 then Just (head x) else Nothing) combine+  warn =+    assertEventWith (const ("ASSERT: multiple " <> label <> " events triggered")) (const False)+      $ fmapMaybe (\x -> if length x > 1 then Just (head x) else Nothing)+                  combine+  r = leftmost [nowarn, warn]++-- | same as leftmostWarn but also adds an index for debugging+leftmostWarnWithIndex :: (Reflex t) => String -> [Event t a] -> Event t a+leftmostWarnWithIndex label evs = r where+  evsWithIndex = zipWith (\i -> fmap (i,)) [0..] evs+  combine = mergeList evsWithIndex+  nowarn =+    fmapMaybe (\x -> if length x == 1 then Just (head x) else Nothing) combine+  warn = fmapMaybe (\x -> if length x > 1 then Just (head x) else Nothing)+      $ traceEventWith (\xs -> "WARNING: multiple " <> label <> " events triggered: " <> show (fmap fst xs))+      $ fmapMaybe (\x -> if length x > 1 then Just x else Nothing)+      combine+  r = fmap snd $ leftmost [nowarn, warn]++-- | same as leftmostWarn but rpint everything+leftmostWarnWithEverything :: (Reflex t, Show a) => String -> [Event t a] -> Event t a+leftmostWarnWithEverything label evs = r where+  evsWithIndex = zipWith (\i -> fmap (i,)) [0..] evs+  combine = mergeList evsWithIndex+  nowarn =+    fmapMaybe (\x -> if length x == 1 then Just (head x) else Nothing) combine+  warn = fmapMaybe (\x -> if length x > 1 then Just (head x) else Nothing)+      $ traceEventWith (\xs -> "WARNING: multiple " <> label <> " events triggered: " <> show xs)+      $ fmapMaybe (\x -> if length x > 1 then Just x else Nothing)+      combine+  r = fmap snd $ leftmost [nowarn, warn]+++-- | same as align but only returns left event if both events fire+-- prints a warning if both events fire+alignWarn+  :: (Reflex t) => String -> Event t a -> Event t b -> Event t (Either a b)+alignWarn label ev1 ev2 =+  leftmostWarn label [Left <$> ev1, Right <$> ev2]+++-- | same as align but returns an either and asserts if both events fire at once+alignAssert :: (Reflex t) => String -> Event t a -> Event t b -> Event t (Either a b)+alignAssert label = alignEventWithMaybe alignfn where+  alignfn (This a) = Just $ Left a+  alignfn (That b) = Just $ Right b+  alignfn _        = error $ "both events fired when aligning " <> label++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 (.)++foldDynMerge+  :: (Reflex t, MonadHold t m, MonadFix m)+  => (a -> b -> b) -- ^ folding method+  -> b -- ^ initial value of dynamic+  -> [Event t a] -- ^ list of events+  -> m (Dynamic t b) -- ^ final output+foldDynMerge f acc evs = foldDynMergeWith acc (f <<$>> evs)++fanDSum+  :: forall t k+   . (Reflex t, DM.GCompare k)+  => Event t (DS.DSum k Identity)+  -> EventSelector t k+fanDSum ds = fan $ DM.fromAscList . (: []) <$> ds++-- TODO test+pushAlwaysDyn+  :: (Reflex t, MonadHold t m, MonadFix m)+  => (a -> PushM t b)+  -> Dynamic t a+  -> m (Dynamic t b)+pushAlwaysDyn f da = do+  da0 <- sample . current $ da+  buildDynamic (f da0) $ pushAlways f (updated da)+++selectNext :: [a] -> Maybe a+selectNext []      = Nothing+selectNext (x : _) = Just x+selectRest :: [a] -> Maybe [a]+selectRest []       = Nothing+selectRest (_ : []) = Nothing+selectRest (_ : xs) = Just xs++-- | delays an event by 1 tick+delayEvent+  :: forall t m a+   . (Adjustable t m)+  => Event t a+  -> m (Event t a)+delayEvent ev = do+  (_, evDelayed) <- runWithReplace (return ()) (fmap return ev)+  return evDelayed++-- | This takes two possibly simultaneous events to and sequences them to fire on different frames.+-- If both events fire at the same time, this functions returns an event with the second event's results that fires one frame after the first event fires.+sequenceEvents+  :: forall t m a b+   . (Adjustable t m, MonadFix m)+  => Event t a+  -> Event t b+  -> m (Event t b)+sequenceEvents ev1 ev2 = mdo+  let makeEv2Delayed :: m (Event t b)+      makeEv2Delayed = do+        let+          -- filters for when BOTH ev1 and ev2 triggered in the previous frame+            fmapfn = \case+              These _ v2 -> Just v2+              _           -> Nothing+            delayed = fmapMaybe fmapfn redo+        -- if ev1 does not trigger, delay does not trigger and this gives ev2+        -- if ev1 did trigger, and ev2 did not, this gives ev2+        -- if ev1 and ev2 both triggered, this gives previous value of evl2+        -- note that it's possible for ev1 or ev2 to trigger in the second frame for outside reasons+        -- if this is the case, you really should not use this function+        return $ leftmost [delayed, difference ev2 ev1]+  (ev2Delayed, redo) <- runWithReplace+    makeEv2Delayed+    (alignEventWithMaybe (Just . return) ev1 ev2)+  return ev2Delayed++-- | Creates an output event that fires once for each input in the list.+-- Each output event runs in a different consecutive frame.+-- If an output event triggers the input event, they get appended to the end of the list of events to be triggered+stepEvents+  :: forall t m a+   . (Adjustable t m, MonadFix m)+  => Event t [a]+  -> m (Event t a)+stepEvents evin = mdo+  let+    -- if input event fires in subsequent ticks, append to end+    -- obviously, be mindful of infinite loops+      evin' :: Event t [a]+      evin' = mergeWith (\rev' ev' -> rev' <> ev') [rev, evin]+      next  = fmapMaybe selectNext evin'+      rest  = fmapMaybe selectRest evin'++  -- TODO this implementation is better but I can't figure out how to properly wrap request and response types+  --rev <- requestingIdentity (Identity <$> rest)+  --requestingIdentity (Identity <$> next)++  (_, rev) <- runWithReplace (return ()) (return <$> rest)+  return next++-- | Same as stepEvents but collects results for each event firing.+stepEventsAndCollectOutput+  :: forall t m a b+   . (Adjustable t m, MonadHold t m, MonadFix m)+  => Event t [a] -- ^ event to repeat+  -> Event t b -- ^ event to collect results from, only collects if event fires+  -> m (Event t a, Event t [b]) -- ^ (repeated event, collected results once event is done repeating)+stepEventsAndCollectOutput evin collectEv = mdo+  let+    -- if input event fires in subsequent ticks, append to end+    -- obviously, be mindful of infinite loops+    evin' :: Event t [a]+    evin' = mergeWith (\rev' ev' -> rev' <> ev') [rev, evin]+    next  = fmapMaybe selectNext evin'+    rest  = fmapMaybe selectRest evin'+    -- nothing left, this means we fired the last event+    stop  = fmapMaybe+      (\x -> if isNothing (selectRest x) then Just () else Nothing)+      evin'+    collected = tagPromptlyDyn (reverse <$> collector) stop++    -- collect events in reverse order+    -- reset when given the signal+    foldfn :: These Bool b -> [b] -> [b]+    foldfn (This True    ) _  = []+    foldfn (That b       ) bs = b : bs+    foldfn (These True  b) _  = [b]+    foldfn (These False b) bs = b : bs+    foldfn _               bs = bs++  -- we use the trick 'tag (current resetState) evin''+  -- which causes it to use resetState from previous iterations.+  collector <- foldDyn+    foldfn+    []+    (alignEventWithMaybe Just (tag (current resetState) evin') collectEv)++  resetState <- foldDyn+    const+    True+    (leftmost [const True <$> stop, const False <$> evin'])++  (_, rev) <- runWithReplace (return ()) (return <$> rest)+  return (next, collected)++-- | Same as stepEventsAndCollectOutput but the collected event fires one frame+-- AFTER the last input event fires+stepEventsAndSequenceCollectOutput+  :: forall t m a b+   . (Adjustable t m, MonadHold t m, MonadFix m)+  => Event t [a] -- ^ event to step+  -> Event t b -- ^ event to collect results from, only collects if event fires+  -> m (Event t a, Event t [b]) -- ^ (repeated event, collected results once event is done repeating)+stepEventsAndSequenceCollectOutput evin collectEv = mdo+  let+    -- if input event fires in subsequent ticks, append to end+    -- obviously, be mindful of infinite loops+    evin' :: Event t [a]+    evin' = mergeWith (\rev' ev' -> rev' <> ev') [rev, evin]+    next  = fmapMaybe selectNext evin'+    rest  = fmapMaybe selectRest evin'+    -- nothing left, this means we fired the last event+    stop  = fmapMaybe+      (\x -> if isNothing (selectRest x) then Just () else Nothing)+      evin'+    collected = tag (current (reverse <$> collector)) stop++    -- collect events in reverse order+    -- reset when given the signal+    foldfn :: These Bool b -> [b] -> [b]+    foldfn (This True    ) _  = []+    foldfn (That b       ) bs = b : bs+    foldfn (These True  b) _  = [b]+    foldfn (These False b) bs = b : bs+    foldfn _               bs = bs++  -- we use the trick 'tag (current resetState) evin''+  -- which causes it to use resetState from previous iterations.+  collector <- foldDyn+    foldfn+    []+    (alignEventWithMaybe Just (updated resetState) collectEv)++  resetState <- foldDyn+    const+    True+    (leftmost [const True <$> stop, const False <$> evin'])++  (_, rev) <- runWithReplace (return ()) (return <$> rest)+  return (next, collected)++++switchHoldPair :: (Reflex t, MonadHold t m) => Event t a -> Event t b -> Event t (Event t a, Event t b) -> m (Event t a, Event t b)+switchHoldPair eva evb evin = fmap fanThese $ switchHold (align eva evb) $ fmap (uncurry align) evin++switchHoldTriple :: forall t m a b c. (Reflex t, MonadHold t m) => Event t a -> Event t b -> Event t c -> Event t (Event t a, Event t b, Event t c) -> m (Event t a, Event t b, Event t c)+switchHoldTriple eva evb evc evin = r where+  evinAligned :: Event t (Event t (These a (These b c)))+  evinAligned = fmap (\(eva', evb', evc') -> align eva' (align evb' evc')) evin+  evabc = align eva (align evb evc)+  switched :: m (Event t (These a (These b c)))+  switched = switchHold evabc evinAligned+  fanned1 :: m (Event t a, Event t (These b c))+  fanned1 = fmap fanThese switched+  fanned2 = fmap (\(a,bc) -> (a, fanThese bc)) fanned1+  r = fmap (\(a, (b,c)) -> (a,b,c)) fanned2+++-- | produces an event that will fire when the following sequence of conditions happens or happens simultaneously+-- evA fires+-- evB fires+-- +-- the state is reset after this event fires and the sequence must occur again for the event to fire again+waitForSecondAfterFirst :: (Reflex t, MonadFix m, MonadHold t m) => Event t a -> Event t b -> m (Event t (a, b))+waitForSecondAfterFirst eva evb = mdo+  -- reset state of a firing each time b fires after a fires or at the same time+  aDyn <- holdDyn Nothing $ leftmost [evabsimul $> Nothing, fmap Just eva, evb $> Nothing]+  let +    -- always fire if both events fire at the same time+    evabsimul = simultaneous eva evb +    -- only fire when b fires if a fired before+    evbaftera = fmapMaybe (\(ma,b) -> maybe Nothing (Just . (,b)) ma) (attach (current aDyn) evb)+  return $ leftmost [evabsimul, evbaftera]+
+ test/Reflex/Potato/HelpersSpec.hs view
@@ -0,0 +1,242 @@+{-# LANGUAGE RecursiveDo #-}++module Reflex.Potato.HelpersSpec+  ( spec+  )+where++import           Relude++import           Test.Hspec+import           Test.Hspec.Contrib.HUnit (fromHUnitTest)+import           Test.HUnit++import qualified Data.List                as L (last)+import Data.These++import           Reflex+import           Reflex.Potato.Helpers+import           Reflex.Test.Host+++++switchtest_network+  :: forall t m+   . (t ~ SpiderTimeline Global, m ~ SpiderHost Global)+  => (Event t Int -> TestGuestT t m (Event t Int))+switchtest_network ev = mdo+  let+    ev1 = fmapMaybe (\x -> if x == 1 then Just 1 else Nothing) ev+  outEvDyn <- foldDyn (\x _ -> if x == 1 then ev1 else (ev $> 0)) ev ev+  return $ switchPromptlyDyn outEvDyn++test_switchtest :: Test+test_switchtest = TestLabel "switchtest" $ TestCase $ do+  let+    bs = [0,1] :: [Int]+    run :: IO [[Maybe Int]]+    run = runAppSimple switchtest_network bs+  v <- liftIO run+  print v+++simultaneous_network+  :: forall t m+   . (t ~ SpiderTimeline Global, m ~ SpiderHost Global)+  => (Event t () -> TestGuestT t m (Event t ((),())))+simultaneous_network ev = mdo+  delayedEv <- delayEvent ev+  let+    -- this will fire on first tick+    ev1 = simultaneous ev ev+    -- this will never fire+    ev2 = simultaneous ev delayedEv+  return $ leftmost $ [ev1, ev2]++test_simultaneous :: Test+test_simultaneous = TestLabel "simultaneous" $ TestCase $ do+  let+    bs = [()] :: [()]+    run :: IO [[Maybe ((),())]]+    run = runAppSimple simultaneous_network bs+  v <- liftIO run+  v @?= [[Just ((),()), Nothing]]+++warning_network+  :: forall t m+   . (t ~ SpiderTimeline Global, m ~ SpiderHost Global)+  => (Event t ()) -> TestGuestT t m (Event t ())+warning_network ev = do++  let+    -- ensure leftmostWarn gives a warning+    ev1 = leftmostWarn "expected" [ev, ev]++    -- ensure fmapMaybeWarn/With gives a warning+    ev2 = fmapMaybeWarn "expected" (const False) ev+    ev2Failed = assertEvent "must not happen" (const False) ev2+    ev3 = fmapMaybeWarnWith (const "expected") (const False) ev+    ev3Failed = assertEvent "must not happen" (const False) ev2++    -- ensure fmapMaybeWarn/With does not give a warning+    ev4 = fmapMaybeWarn "expected" (const True) ev+    ev5 = fmapMaybeWarnWith (const "expected") (const True) ev++    -- ensure assertEvent/With gives no error+    ev6 = assertEventWith (const "must not happen") (const True) ev+    ev7 = assertEvent "must not happen" (const True) ev++    -- ensure assertEvent/With gives error (uncomment to test)+    --ev8 = assertEventWith (const "must crash") (const False) ev+    --ev9 = assertEvent "must crash" (const False) ev+    ev8 = never+    ev9 = never++  -- force all events by collecting them+  return $ leftmost [ev1, ev2, ev2Failed, ev3, ev3Failed, ev4, ev5, ev6, ev7, ev8, ev9]++test_warning :: Test+test_warning = TestLabel "delayEvent" $ TestCase $ do+  let+    bs = [()]+    run :: IO [[Maybe ()]]+    run = runAppSimple warning_network bs+  _ <- liftIO run+  return ()++delayEvent_network+  :: forall t m+   . (t ~ SpiderTimeline Global, m ~ SpiderHost Global)+  => (Event t Int -> TestGuestT t m (Event t Int))+delayEvent_network ev = mdo+  delayedEv <- delayEvent ev+  return $ leftmostWarn "delayEvent" [ev, delayedEv]++test_delayEvent :: Test+test_delayEvent = TestLabel "delayEvent" $ TestCase $ do+  let+    n = 100+    bs = [0..n] :: [Int]+    run :: IO [[Maybe Int]]+    run = runAppSimple delayEvent_network bs+  v <- liftIO run+  join v @?= [Just (x `div` 2) | x <- [0..(n*2+1)]]+++sequenceEvents_network+  :: forall t m+   . (t ~ SpiderTimeline Global, m ~ SpiderHost Global)+  => (Event t (Int, Int) -> TestGuestT t m (Event t Int))+sequenceEvents_network ev = mdo+  let fstEv = fmap fst ev+      sndEv = fmap snd ev+  delayedSndEv <- sequenceEvents fstEv sndEv+  return $ leftmostWarn "sequenceEvents" [fstEv, delayedSndEv]++test_sequenceEvents :: Test+test_sequenceEvents = TestLabel "sequenceEvents" $ TestCase $ do+  let bs = [(0, 1)] :: [(Int, Int)]+      run :: IO [[Maybe Int]]+      run = runAppSimple sequenceEvents_network bs+  v <- liftIO run+  join v @?= [Just 0, Just 1]++++stepEventsAndSequenceCollectOutput_network+  :: forall t m+   . (t ~ SpiderTimeline Global, m ~ SpiderHost Global)+  => (Event t [Int] -> TestGuestT t m (Event t [Int]))+stepEventsAndSequenceCollectOutput_network ev = mdo+  (repeated, collected) <- stepEventsAndCollectOutput ev repeated+  return collected++test_stepEventsAndSequenceCollectOutput :: Test+test_stepEventsAndSequenceCollectOutput =+  TestLabel "stepEventsAndSequenceCollectOutput" $ TestCase $ do+    let bs = [[0], [], [1 .. 5], [], [], [1, 2], [1 .. 10], []] :: [[Int]]+        run :: IO [[Maybe [Int]]]+        run = runAppSimple stepEventsAndSequenceCollectOutput_network bs+    v <- liftIO run+    fmap L.last v @?= fmap Just bs++++stepEventsAndCollectOutput_network+  :: forall t m+   . (t ~ SpiderTimeline Global, m ~ SpiderHost Global)+  => (Event t [Int] -> TestGuestT t m (Event t [Int]))+stepEventsAndCollectOutput_network ev = mdo+  (repeated, collected) <- stepEventsAndCollectOutput ev repeated+  return collected++test_stepEventsAndCollectOutput :: Test+test_stepEventsAndCollectOutput =+  TestLabel "stepEventsAndCollectOutput" $ TestCase $ do+    let bs = [[0], [], [1 .. 5], [], [], [1, 2], [1 .. 10], []] :: [[Int]]+        run :: IO [[Maybe [Int]]]+        run = runAppSimple stepEventsAndCollectOutput_network bs+    v <- liftIO run+    fmap L.last v @?= fmap Just bs++stepEvents_network+  :: forall t m+   . (t ~ SpiderTimeline Global, m ~ SpiderHost Global)+  => (Event t [Int] -> TestGuestT t m (Event t Int))+stepEvents_network = stepEvents++test_stepEvents :: Test+test_stepEvents = TestLabel "stepEvents" $ TestCase $ do+  let bs = [[1 .. 10], [0], [], [1 .. 5], [], [], [1, 2]] :: [[Int]]+      run :: IO [[Maybe Int]]+      run = runAppSimple stepEvents_network bs+  v <- liftIO run+  --print v+  return ()+  L.last v @?= [Just 1, Just 2]++++-- TODO move to Data.These.Extra somewhere+maybeThis :: These a b -> Maybe a+maybeThis (This a)    = Just a+maybeThis (These a _) = Just a+maybeThis _           = Nothing++maybeThat :: These a b -> Maybe b+maybeThat (That b)    = Just b+maybeThat (These _ b) = Just b+maybeThat _           = Nothing++waitForSecondAfterFirst_network +  :: forall t m+   . (t ~ SpiderTimeline Global, m ~ SpiderHost Global)+  => (Event t (These Int Int) -> TestGuestT t m (Event t (Int, Int)))+waitForSecondAfterFirst_network ev = +  waitForSecondAfterFirst (fmapMaybe maybeThis ev) (fmapMaybe maybeThat ev)++test_waitForSecondAfterFirst :: Test+test_waitForSecondAfterFirst = TestLabel "waitForSecondAfterFirst" $ TestCase $ do+  let bs = [This 1, This 2, That 3, That 4, This 5, These 6 7] :: [These Int Int]+      run :: IO [[Maybe (Int, Int)]]+      run = runAppSimple waitForSecondAfterFirst_network bs+  v <- liftIO run+  print v+  return ()+  v @?= [[Nothing], [Nothing], [Just (2,3)], [Nothing], [Nothing], [Just (6, 7)]]+++spec :: Spec+spec = do+  describe "Potato" $ do+    fromHUnitTest test_warning+    fromHUnitTest test_stepEvents+    fromHUnitTest test_stepEventsAndCollectOutput+    fromHUnitTest test_stepEventsAndSequenceCollectOutput+    fromHUnitTest test_sequenceEvents+    fromHUnitTest test_delayEvent+    fromHUnitTest test_simultaneous+    fromHUnitTest test_switchtest+    fromHUnitTest test_waitForSecondAfterFirst
+ test/Reflex/Potato/TestingSpec.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE RecursiveDo #-}++module Reflex.Potato.TestingSpec+  ( spec+  )+where++import           Relude++import           Test.Hspec+import           Test.Hspec.Contrib.HUnit (fromHUnitTest)+import           Test.HUnit++import           Reflex++import           Reflex.Test.Host++++switchtest_network+  :: forall t m+   . (t ~ SpiderTimeline Global, m ~ SpiderHost Global)+  => (Event t Int -> TestGuestT t m (Event t Int))+switchtest_network ev = mdo+  let+    ev1 = fmapMaybe (\x -> if x == 1 then Just 1 else Nothing) ev+  outEvDyn <- foldDyn (\x _ -> if x == 1 then ev1 else never) ev ev+  --return $ switchPromptlyDyn outEvDyn+  return $ switchDyn outEvDyn++test_switchtest :: Test+test_switchtest = TestLabel "switchtest" $ TestCase $ do+  let+    bs = [0,1] :: [Int]+    run :: IO [[Maybe Int]]+    run = runAppSimple switchtest_network bs+  v <- liftIO run+  print v+++spec :: Spec+spec = do+  describe "Reflex" $ do+    fromHUnitTest test_switchtest
+ test/Spec.hs view
@@ -0,0 +1,2 @@+-- hspec auto-discovery stuff+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}