reflex-orphans (empty) → 0.1

raw patch · 5 files changed

+187/−0 lines, 5 filesdep +basedep +dependent-mapdep +mtlsetup-changed

Dependencies added: base, dependent-map, mtl, ref-tf, reflex, reflex-orphans, tasty, tasty-hunit, these

Files

LICENSE +30/−0
Setup.hs +2/−0
reflex-orphans.cabal +43/−0
src/Reflex/Orphans.hs +17/−0
test.hs +95/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2016, davean++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 davean 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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ reflex-orphans.cabal view

@@ -0,0 +1,43 @@+name:                reflex-orphans+version:             0.1+synopsis:            Useful missing instances for Reflex+license:             BSD3+license-file:        LICENSE+author:              davean+maintainer:          davean <davean@xkcd.com>+copyright:           Copyright (C) 2016 davean+stability:           provisional+category:            FRP+build-type:          Simple+cabal-version:       >=1.10+bug-reports:         oss@xkcd.com+description:+  This package provides additional instances missing from <https://hackage.haskell.org/package/reflex reflex>, specificly 'Functor' and 'Applicative' for 'Dynamic'. The inclusion of these instances facilitates easier, conventional Haskell style programming in reflex.++source-repository head+  type: git+  location: http://git.xkrd.net/davean/reflex-orphans.git++library+  hs-source-dirs:      src+  default-language:    Haskell2010+  exposed-modules:+          Reflex.Orphans+  build-depends:+        base >=4.8 && <5+      , reflex >= 0.4+      , these >= 0.4++test-suite test+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  main-is: test.hs+  build-depends:+        base >= 4.8 && < 5+      , tasty == 0.11.*+      , tasty-hunit == 0.9.*+      , reflex+      , reflex-orphans+      , dependent-map+      , ref-tf+      , mtl

+ src/Reflex/Orphans.hs view

@@ -0,0 +1,17 @@+{-# LANGUAGE LambdaCase #-}+module Reflex.Orphans () where++import Data.These+import Data.Align+import Reflex++instance Reflex t => Functor (Dynamic t) where+    fmap f d = unsafeDynamic (fmap f . current $ d) (fmap f . updated $ d)++instance Reflex t => Applicative (Dynamic t) where+    pure = constDyn+    f <*> x = unsafeDynamic+              ((current f) <*> (current x))+              (push (\case+                        These a b -> return . Just $ a b+                        _ -> return Nothing) $ align (updated f) (updated x))

+ test.hs view

@@ -0,0 +1,95 @@+{-# LANGUAGE FlexibleContexts #-}+import Test.Tasty+import Test.Tasty.HUnit+import Control.Monad+import Control.Monad.Trans++import Reflex+import Reflex.Host.Class+import Data.Functor.Identity+import Data.Dependent.Map (DSum((:=>)))+import Control.Monad.Ref++import Reflex.Orphans++main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests" [+    runSpiderEBD "Test mapDyn" $ \ e -> do+      b <- hold 1 e+      d <- mapDyn show =<< holdDyn 1 e+      return (fmap show e, fmap show b, d)+  , runSpiderEBD "Test fmap Dynamic" $ \ e -> do+      b <- hold 1 e+      d <- holdDyn 1 e+      return (fmap show e, fmap show b, fmap show d)+  , testApplicative+  ]++eventValue :: (Reflex t, MonadReadEvent t m) => EventHandle t a -> m (Maybe a)+eventValue eh = readEvent eh >>= sequence++sameBehavior :: (Reflex t, Eq a, MonadSample t m, MonadIO m, Show a) => Behavior t a -> Behavior t a -> m ()+sameBehavior ba bb = do+      va <- sample ba+      vb <- sample bb+      liftIO $ va @=? vb++testApplicative :: TestTree+testApplicative = testCase "Test Applicative" . runSpiderHost $ do+    (re, rmt) <- newEventWithTriggerRef+    (pb, pd) <- runHostFrame $ do+      b <- hold 1 re+      d <- holdDyn 1 re+      return (show <$> b, show <$> d)+    ehd <- subscribeEvent . updated $ pd+    pb `sameBehavior` (current pd)+    Just rt <- readRef rmt+    forM_ [1..10] $ \nv -> do+      checkStep =<< (fireEventsAndRead [rt :=> (Identity nv)] $ do+        (,,,) <$> pure (Just . show $ nv)+              <*> eventValue ehd+              <*> sample pb+              <*> (sample . current $ pd))+      pb `sameBehavior` (current pd)+    checkStep =<< (fireEventsAndRead [] $ do+        (,,,) <$> pure Nothing+              <*> eventValue ehd+              <*> sample pb+              <*> (sample . current $ pd))+    pb `sameBehavior` (current pd)+  where+    eventValue eh = readEvent eh >>= sequence+    checkStep (tv, ved, vba, vbb) = do+      liftIO $ tv @=? ved+      liftIO $ vba @=? vbb++runSpiderEBD :: (Eq a, Show a)+        => TestName+        -> (Event Spider Int -> HostFrame Spider (Event Spider a, Behavior Spider a, Dynamic Spider a))+        -> TestTree+runSpiderEBD nm frm = testCase nm . runSpiderHost $ do+    (re, rmt) <- newEventWithTriggerRef+    (pe, pb, pd) <- runHostFrame $ frm re+    ehe <- subscribeEvent pe+    ehd <- subscribeEvent . updated $ pd+    pb `sameBehavior` (current pd)+    Just rt <- readRef rmt+    forM_ [1..10] $ \nv ->+        checkStep =<< (fireEventsAndRead [rt :=> (Identity nv)] $ do+          (,,,) <$> eventValue ehe+                <*> eventValue ehd+                <*> sample pb+                <*> (sample . current $ pd))+    pb `sameBehavior` (current pd)+    checkStep =<< (fireEventsAndRead [] $ do+          (,,,) <$> eventValue ehe+                <*> eventValue ehd+                <*> sample pb+                <*> (sample . current $ pd))+    pb `sameBehavior` (current pd)+  where+    checkStep (vea, veb, vba, vbb) = do+      liftIO $ vea @=? veb+      liftIO $ vba @=? vbb