├── benchmark └── Main.hs ├── Setup.hs ├── .gitignore ├── library └── Ramus │ ├── Channel.hs │ ├── Internal.hs │ ├── DOM.hs │ ├── Time.hs │ └── Signal.hs ├── LICENSE ├── package.yaml ├── README.md ├── test-suite ├── SignalTester.hs └── Main.hs └── stack.yaml /benchmark/Main.hs: -------------------------------------------------------------------------------- 1 | -- You can benchmark your code quickly and effectively with Criterion. See its 2 | -- website for help: . 3 | import Criterion.Main 4 | 5 | main :: IO () 6 | main = defaultMain [bench "const" (whnf const ())] 7 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | -- This script is used to build and install your package. Typically you don't 2 | -- need to change it. The Cabal documentation has more information about this 3 | -- file: . 4 | import qualified Distribution.Simple 5 | 6 | main :: IO () 7 | main = Distribution.Simple.defaultMain 8 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /bower_components/ 2 | /output/ 3 | /.psci 4 | /.browserify-cache.json 5 | /.psci_modules/ 6 | *.tix 7 | 8 | # Created by https://www.gitignore.io/api/haskell 9 | 10 | ### Haskell ### 11 | dist 12 | dist-* 13 | cabal-dev 14 | *.o 15 | *.hi 16 | *.chi 17 | *.chs.h 18 | *.dyn_o 19 | *.dyn_hi 20 | .hpc 21 | .hsenv 22 | .cabal-sandbox/ 23 | cabal.sandbox.config 24 | *.prof 25 | *.aux 26 | *.hp 27 | *.eventlog 28 | .stack-work/ 29 | cabal.project.local 30 | *.cabal 31 | .HTF/ 32 | 33 | # End of https://www.gitignore.io/api/haskell -------------------------------------------------------------------------------- /library/Ramus/Channel.hs: -------------------------------------------------------------------------------- 1 | module Ramus.Channel where 2 | 3 | import Ramus.Signal 4 | import Ramus.Internal 5 | 6 | newtype Channel a = Channel (Signal a) 7 | 8 | -- |Creates a channel, which allows you to feed arbitrary values into a signal. 9 | channel :: a -> IO (Channel a) 10 | channel = return . Channel . make 11 | 12 | -- |Sends a value to a given channel. 13 | send :: Channel a -> a -> IO () 14 | send (Channel c) = set c 15 | 16 | -- |Takes a channel and returns a signal of the values sent to it. 17 | subscribe :: Channel a -> Signal a 18 | subscribe (Channel c) = c 19 | -------------------------------------------------------------------------------- /library/Ramus/Internal.hs: -------------------------------------------------------------------------------- 1 | module Ramus.Internal where 2 | 3 | import Data.IORef 4 | import System.IO.Unsafe 5 | import Control.Monad 6 | import Data.Monoid 7 | 8 | data Signal a = Signal 9 | { get :: a 10 | , set :: a -> IO () 11 | , subscribe :: (a -> IO ()) -> IO () 12 | } 13 | 14 | unsafeRef :: a -> IORef a 15 | unsafeRef = unsafePerformIO . newIORef 16 | 17 | unsafeRead :: IORef a -> a 18 | unsafeRead = unsafePerformIO . readIORef 19 | 20 | make :: a -> Signal a 21 | make initial = unsafePerformIO $ do 22 | subs <- newIORef [] :: IO (IORef [a -> IO()]) 23 | val <- newIORef initial 24 | let _get = unsafeRead val 25 | let _set newval = do 26 | writeIORef val newval 27 | forM_ (unsafeRead subs) $ \sub -> 28 | sub newval 29 | let _subscribe sub = do 30 | currentSubs <- readIORef subs 31 | _val <- readIORef val 32 | writeIORef subs $ currentSubs <> [sub] 33 | sub _val 34 | return Signal 35 | { get = _get 36 | , set = _set 37 | , subscribe = _subscribe 38 | } 39 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | ===================== 3 | 4 | Copyright © `` `` 5 | 6 | Permission is hereby granted, free of charge, to any person 7 | obtaining a copy of this software and associated documentation 8 | files (the “Software”), to deal in the Software without 9 | restriction, including without limitation the rights to use, 10 | copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the 12 | Software is furnished to do so, subject to the following 13 | conditions: 14 | 15 | The above copyright notice and this permission notice shall be 16 | included in all copies or substantial portions of the Software. 17 | 18 | THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, 19 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 20 | OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 21 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 22 | HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 23 | WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 24 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 25 | OTHER DEALINGS IN THE SOFTWARE. 26 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | # This YAML file describes your package. Stack will automatically generate a 2 | # Cabal file when you run `stack build`. See the hpack website for help with 3 | # this file: . 4 | benchmarks: 5 | ramus-benchmarks: 6 | dependencies: 7 | - base == 4.* 8 | - ramus 9 | - criterion 10 | ghc-options: 11 | - -rtsopts 12 | - -threaded 13 | - -with-rtsopts=-N 14 | main: Main.hs 15 | source-dirs: benchmark 16 | category: Other 17 | description: Ramus is a direct port of purescript-signal into Haskell, offering the Elm signal system for Haskell. 18 | extra-source-files: 19 | - LICENSE 20 | - package.yaml 21 | - README.md 22 | - stack.yaml 23 | ghc-options: -Wall 24 | github: NickSeagull/ramus 25 | library: 26 | dependencies: 27 | - base == 4.* 28 | - async 29 | source-dirs: library 30 | license: MIT 31 | maintainer: Nikita Tchayka 32 | name: ramus 33 | synopsis: Elm signal system for Haskell 34 | tests: 35 | ramus-test-suite: 36 | dependencies: 37 | - base == 4.* 38 | - ramus 39 | - hspec 40 | - QuickCheck 41 | - quickcheck-io 42 | - async 43 | ghc-options: 44 | - -rtsopts 45 | - -threaded 46 | - -with-rtsopts=-N 47 | main: Main.hs 48 | source-dirs: test-suite 49 | version: '0.1.2' 50 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Ramus 2 | 3 | Ramus is a lightweight FRP-like library heavily inspired by the Elm Signal implementation, 4 | in fact, it's a direct port of the [purescript-signal](https://github.com/bodil/purescript-signal) library, 5 | in Haskell. 6 | Where possible and sensible, it tries to maintain API equivalence with Elm. 7 | 8 | See [the Elm documentation](http://elm-lang.org:1234/guide/reactivity#signals) for details on usage and principles. 9 | 10 | ## Haskell Usage Patterns 11 | 12 | Haskell depends on `IO` to manage side effects, where Elm's runtime generally manages them for you. 13 | `ramus` provides the `Signal.runSignal` function for running effectful signals. 14 | 15 | ```haskell 16 | module Main where 17 | 18 | import Signal 19 | 20 | hello :: Signal String 21 | hello = constant "Hello Joe!" 22 | 23 | helloEffect :: Signal (IO ()) 24 | helloEffect = hello ~> print 25 | 26 | main :: IO () 27 | main = runSignal helloEffect 28 | ``` 29 | 30 | This simple example takes a constant signal which contains the string `"Hello Joe!"` 31 | and maps it over the `print` function, which has the type `(Show a) => a -> IO()`, thus taking the `String` 32 | content of the signal and turning it into an effect which logs the provided string to the user's console. 33 | 34 | This gives us a `Signal (IO ())`. We use `runSignal` to take the signal of effects and run each effect 35 | in turn—in our case, just the one effect which prints `"Hello Joe!"` to the console. 36 | 37 | ## API Documentation 38 | 39 | * [Module documentation on Hackage](https://hackage.haskell.org/package/ramus) 40 | 41 | ## Usage Examples 42 | 43 | * TODO 44 | -------------------------------------------------------------------------------- /test-suite/SignalTester.hs: -------------------------------------------------------------------------------- 1 | module SignalTester 2 | ( shouldYield 3 | , tick 4 | , expect 5 | ) 6 | where 7 | 8 | import Ramus.Signal 9 | import Ramus.Internal 10 | import Data.IORef 11 | import Control.Monad (unless) 12 | import System.IO.Unsafe 13 | import Control.Concurrent 14 | import Control.Concurrent.Async (race_) 15 | 16 | shouldYield :: (Eq a, Show a) 17 | => Signal a 18 | -> [a] 19 | -> IO () 20 | shouldYield sig vals = do 21 | remaining <- newIORef vals 22 | let getNext val = do 23 | nextValues <- readIORef remaining 24 | case nextValues of 25 | (x : xs) -> 26 | if x /= val 27 | then error $ "Expected " ++ show x ++ " but got " ++ show val 28 | else case xs of 29 | [] -> return () 30 | _ -> writeIORef remaining xs 31 | [] -> error "Unexpected emptiness" 32 | runSignal $ sig ~> getNext 33 | 34 | tick :: Show a 35 | => Int 36 | -> Int 37 | -> [a] 38 | -> Signal a 39 | tick initial interval values = unsafePerformIO $ do 40 | vals <- newIORef values 41 | valsShift <- shift vals 42 | let out = constant valsShift 43 | let pop = do 44 | shifted <- shift vals 45 | out `set` valsShift 46 | v <- readIORef vals 47 | unless (null v) (setTimeout interval pop) 48 | unless (null values) (setTimeout initial pop) 49 | return out 50 | 51 | shift :: Show a => IORef [a] -> IO a 52 | shift ref = do 53 | (x:xs) <- readIORef ref 54 | writeIORef ref xs 55 | return x 56 | 57 | 58 | setTimeout :: Int -> IO () -> IO () 59 | setTimeout ms action = do 60 | threadDelay (ms * 1000) 61 | action 62 | 63 | expect :: (Eq a, Show a) => Int -> Signal a -> [a] -> IO () 64 | expect ms sig vals = 65 | race_ 66 | (error "Operation timed out") 67 | (sig `shouldYield` vals) 68 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | # 19 | 20 | resolver: lts-7.19 21 | compiler: ghcjs-0.2.1.9007019_ghc-8.0.1 22 | compiler-check: match-exact 23 | 24 | setup-info: 25 | ghcjs: 26 | source: 27 | ghcjs-0.2.1.9007019_ghc-8.0.1: 28 | url: http://ghcjs.tolysz.org/ghc-8.0-2017-02-05-lts-7.19-9007019.tar.gz 29 | sha1: d2cfc25f9cda32a25a87d9af68891b2186ee52f9 30 | 31 | 32 | # User packages to be built. 33 | # Various formats can be used as shown in the example below. 34 | # 35 | # packages: 36 | # - some-directory 37 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 38 | # - location: 39 | # git: https://github.com/commercialhaskell/stack.git 40 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 41 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 42 | # extra-dep: true 43 | # subdirs: 44 | # - auto-update 45 | # - wai 46 | # 47 | # A package marked 'extra-dep: true' will only be built if demanded by a 48 | # non-dependency (i.e. a user package), and its test suites and benchmarks 49 | # will not be run. This is useful for tweaking upstream packages. 50 | packages: 51 | - '.' 52 | # Dependency packages to be pulled from upstream that are not in the resolver 53 | # (e.g., acme-missiles-0.3) 54 | extra-deps: [] 55 | 56 | # Override default flag values for local packages and extra-deps 57 | flags: {} 58 | 59 | # Extra package databases containing global packages 60 | extra-package-dbs: [] 61 | 62 | # Control whether we use the GHC we find on the path 63 | # system-ghc: true 64 | # 65 | # Require a specific version of stack, using version ranges 66 | # require-stack-version: -any # Default 67 | # require-stack-version: ">=1.3" 68 | # 69 | # Override the architecture used by stack, especially useful on Windows 70 | # arch: i386 71 | # arch: x86_64 72 | # 73 | # Extra directories used by stack for building 74 | # extra-include-dirs: [/path/to/dir] 75 | # extra-lib-dirs: [/path/to/dir] 76 | # 77 | # Allow a newer minor version of GHC than the snapshot specifies 78 | # compiler-check: newer-minor 79 | -------------------------------------------------------------------------------- /library/Ramus/DOM.hs: -------------------------------------------------------------------------------- 1 | module Ramus.DOM () where 2 | 3 | import Ramus.Signal 4 | import Ramus.Time 5 | 6 | import GHCJS.Foreign.Callback 7 | 8 | data CoordinatePair = CoordinatePair { x :: Int, y :: Int } 9 | data DimensionPair = DimensionPair { w :: Int, h :: Int } 10 | 11 | foreign import javascript unsafe "window.addEventListener('keydown', function(e){\ 12 | if(e.keyCode === $1) $2(true);\ 13 | });\ 14 | window.addEventListener('keyup', function(e){\ 15 | if(e.keyCode === $1) $2(false);\ 16 | });" 17 | js_keyPressed :: Int -> Callback (Bool -> IO ()) -> IO () 18 | 19 | foreign import javascript unsafe "window.addEventListener('mousedown', function(e){\ 20 | if(e.keyCode === $1) $2(true);\ 21 | });\ 22 | window.addEventListener('mouseup', function(e){\ 23 | if(e.keyCode === $1) $2(false);\ 24 | });" 25 | js_mouseButton :: Int -> Callback (Bool -> IO ()) -> IO () 26 | 27 | 28 | -- |Creates a signal which will be `true` when the key matching the given key 29 | -- |code is pressed, and `false` when it's released. 30 | keyPressed :: Int -> IO (Signal Bool) 31 | keyPressed keyCode = do 32 | let out = constant False 33 | cb <- asyncCallback1 (set out) 34 | js_keyPressed keyCode cb 35 | return out 36 | 37 | -- |Creates a signal which will be `true` when the given mouse button is 38 | -- |pressed, and `false` when it's released. 39 | mouseButton :: Int -> IO (Signal Bool) 40 | mouseButton button = do 41 | let out = constant False 42 | cb <- asyncCallback1 (set out) 43 | js_mouseButton button cb 44 | return out 45 | 46 | data Touch = Touch 47 | { id :: String 48 | , screenX :: Int 49 | , screenY :: Int 50 | 51 | , clientX :: Int 52 | , clientY :: Int 53 | 54 | , pageX :: Int 55 | , pageY :: Int 56 | 57 | , radiusX :: Int 58 | , radiusY :: Int 59 | 60 | , rotationAngle :: Float 61 | , force :: Float 62 | } 63 | 64 | -- |A signal containing the current state of the touch device, as described by 65 | -- |the `Touch` record type. 66 | touch :: IO (Signal [Touch]) 67 | touch = undefined 68 | 69 | -- |A signal which will be `true` when at least one finger is touching the 70 | -- |touch device, and `false` otherwise. 71 | tap :: IO (Signal Bool) 72 | tap = undefined 73 | 74 | -- |A signal containing the current mouse position. 75 | mousePos :: IO (Signal CoordinatePair) 76 | mousePos = undefined 77 | 78 | -- |A signal which yields the current time, as determined by `now`, on every 79 | -- |animation frame (see [https://developer.mozilla.org/en-US/docs/Web/API/window/requestAnimationFrame]). 80 | animationFrame :: IO (Signal Time) 81 | animationFrame = undefined 82 | 83 | -- |A signal which contains the document window's current width and height. 84 | windowDimensions :: IO (Signal DimensionPair) 85 | windowDimensions = undefined constant 86 | -------------------------------------------------------------------------------- /library/Ramus/Time.hs: -------------------------------------------------------------------------------- 1 | module Ramus.Time where 2 | 3 | import Prelude hiding (filter) 4 | import Ramus.Signal 5 | import Ramus.Internal 6 | import Control.Concurrent 7 | import Control.Concurrent.Async 8 | import Control.Monad (forever) 9 | import Data.IORef 10 | import System.IO.Unsafe 11 | 12 | type Time = Float 13 | 14 | millisecond :: Time 15 | millisecond = 1.0 16 | 17 | second :: Time 18 | second = 1000.0 19 | 20 | foreign import javascript unsafe "$r = Date.now();" 21 | js_now :: IO Int 22 | 23 | -- |Creates a signal which yields the current time (according to `now`) every 24 | -- |given number of milliseconds. 25 | every :: Time -> Signal Time 26 | every ms = unsafePerformIO $ do 27 | rn <- now 28 | let out = constant rn 29 | _ <- async $ forever $ do 30 | threadDelay (round $ ms * 1000) 31 | rn' <- now 32 | out `set` rn' 33 | return out 34 | 35 | -- |Returns the number of milliseconds since an arbitrary, but constant, time 36 | -- |in the past. 37 | now :: IO Time 38 | now = do 39 | rn <- js_now 40 | return $ fromIntegral rn / 1000000 41 | 42 | -- |Takes a signal and delays its yielded values by a given number of 43 | -- |milliseconds. 44 | delay :: Time -> Signal a -> Signal a 45 | delay t sig = unsafePerformIO $ do 46 | let out = make $ get sig 47 | first <- newIORef True 48 | sig `subscribe` \val -> do 49 | first' <- readIORef first 50 | if first' 51 | then writeIORef first False 52 | else do 53 | threadDelay (round $ t * 1000) 54 | out `set` val 55 | return out 56 | 57 | -- |Takes a signal and a time value, and creates a signal which yields `True` 58 | -- |when the input signal yields, then goes back to `False` after the given 59 | -- |number of milliseconds have elapsed, unless the input signal yields again 60 | -- |in the interim. 61 | since :: Time -> Signal a -> Signal Bool 62 | since t sig = unsafePerformIO $ do 63 | let out = make False 64 | firstRef <- newIORef True 65 | timerRef <- newIORef Nothing 66 | let tick = do 67 | out `set` False 68 | writeIORef timerRef Nothing 69 | sig `subscribe` \val -> do 70 | first <- readIORef firstRef 71 | if first 72 | then writeIORef firstRef False 73 | else do 74 | timer <- readIORef timerRef 75 | case timer of 76 | Nothing -> do 77 | out `set` True 78 | tim <- forkIO $ do 79 | threadDelay (round $ t * 1000) 80 | tick 81 | writeIORef timerRef $ Just tim 82 | 83 | Just tim -> do 84 | killThread tim 85 | tim' <- forkIO $ do 86 | threadDelay (round $ t * 1000) 87 | tick 88 | writeIORef timerRef $ Just tim' 89 | return out 90 | 91 | 92 | -- |Takes a signal and a time value, and creates a signal which waits to yield 93 | -- |the next result until the specified amount of time has elapsed. It then 94 | -- |yields only the newest value from that period. New events during the debounce 95 | -- |period reset the delay. 96 | debounce :: Time -> Signal a -> Signal a 97 | debounce t s = 98 | let leading = whenChangeTo False $ since t s 99 | in sampleOn leading s 100 | where 101 | whenEqual value = filter (value ==) value 102 | whenChangeTo value input = whenEqual value $ dropRepeats input 103 | -------------------------------------------------------------------------------- /library/Ramus/Signal.hs: -------------------------------------------------------------------------------- 1 | module Ramus.Signal 2 | ( Signal () 3 | , constant 4 | , merge 5 | , mergeMany 6 | , foldp 7 | , sampleOn 8 | , dropRepeats 9 | , runSignal 10 | -- , unwrap 11 | , filter 12 | , filterMap 13 | , flatten 14 | , flattenArray 15 | , (~>) 16 | , (<~) 17 | , (~~) 18 | , map2 19 | , map3 20 | , map4 21 | , map5 22 | ) where 23 | 24 | import Prelude hiding (filter) 25 | 26 | import Ramus.Internal 27 | import Control.Applicative () 28 | import Control.Monad (unless, when) 29 | import Data.Functor () 30 | import Data.Semigroup 31 | import Data.Foldable 32 | import Data.Maybe 33 | import Data.IORef 34 | import System.IO.Unsafe 35 | import Unsafe.Coerce 36 | 37 | 38 | -- |Creates a signal with a constant value. 39 | constant :: a -> Signal a 40 | constant = make 41 | 42 | -- |Merge two signals, returning a new signal which will yield a value 43 | -- |whenever either of the input signals yield. Its initial value will be 44 | -- |that of the first signal. 45 | merge :: Signal a -> Signal a -> Signal a 46 | merge sig1 sig2 = unsafePerformIO $ do 47 | let out = constant $ get sig1 48 | sig2 `subscribe` set out 49 | sig1 `subscribe` set out 50 | return out 51 | 52 | -- |Merge all signals inside a `Foldable`, returning a `Maybe` which will 53 | -- |either contain the resulting signal, or `Nothing` if the `Foldable` 54 | -- |was empty. 55 | mergeMany :: (Functor f, Foldable f) => f (Signal a) -> Maybe (Signal a) 56 | mergeMany sigs = foldl mergeMaybe Nothing (Just <$> sigs) 57 | where mergeMaybe a Nothing = a 58 | mergeMaybe Nothing a = a 59 | mergeMaybe (Just a) (Just b) = Just (merge a b) 60 | 61 | -- |Creates a past dependent signal. The function argument takes the value of 62 | -- |the input signal, and the previous value of the output signal, to produce 63 | -- |the new value of the output signal. 64 | foldp :: (a -> b -> b) -> b -> Signal a -> Signal b 65 | foldp fun seed sig = unsafePerformIO $ do 66 | acc <- newIORef seed 67 | let out = make seed 68 | sig `subscribe` \val -> do 69 | acc' <- readIORef acc 70 | writeIORef acc $ fun val acc' 71 | acc'' <- readIORef acc 72 | out `set` acc'' 73 | return out 74 | 75 | -- |Creates a signal which yields the current value of the second signal every 76 | -- |time the first signal yields. 77 | sampleOn :: Signal a -> Signal b -> Signal b 78 | sampleOn sig1 sig2 = unsafePerformIO $ do 79 | let val = get sig1 80 | let out = make val 81 | sig1 `subscribe` \val -> do 82 | let v' = get sig2 83 | out `set` (unsafeCoerce v' :: b) -- If something goes wrong, it's probably here 84 | return $ unsafeCoerce out -- or here 85 | 86 | -- |Create a signal which only yields values which aren't equal to the previous 87 | -- |value of the input signal. 88 | dropRepeats :: (Eq a) => Signal a -> Signal a 89 | dropRepeats sig = unsafePerformIO $ do 90 | let val = get sig 91 | let out = make val 92 | sig `subscribe` \newval -> 93 | unless (val == newval) (out `set` val) 94 | return out 95 | 96 | -- |Given a signal of effects with no return value, run each effect as it 97 | -- |comes in. 98 | runSignal :: Signal (IO ()) -> IO () 99 | runSignal sig = 100 | sig `subscribe` id 101 | 102 | 103 | -- |Takes a signal of effects of `a`, and produces an effect which returns a 104 | -- |signal which will take each effect produced by the input signal, run it, 105 | -- |and yield its returned value. 106 | unwrap :: Signal (IO a) -> IO (Signal a) 107 | unwrap sig = do 108 | let val = unsafePerformIO $ get sig 109 | let out = make val 110 | sig `subscribe` \v -> out `set` unsafePerformIO v 111 | return out 112 | 113 | -- |Takes a signal and filters out yielded values for which the provided 114 | -- |predicate function returns `false`. 115 | filter :: (a -> Bool) -> a -> Signal a -> Signal a 116 | filter fn seed sig = unsafePerformIO $ do 117 | let out = make (if fn (get sig) then get sig else seed) 118 | sig `subscribe` \val -> 119 | when (fn val) (out `set` val) 120 | return out 121 | 122 | -- |Map a signal over a function which returns a `Maybe`, yielding only the 123 | -- values inside `Just`s, dropping the `Nothing`s. 124 | filterMap :: (a -> Maybe b) -> b -> Signal a -> Signal b 125 | filterMap f def sig = fromMaybe def <$> filter isJust (Just def) (f <$> sig) 126 | 127 | -- |Turns a signal of arrays of items into a signal of each item inside 128 | -- each array, in order. 129 | -- 130 | -- Like `flatten`, but faster. 131 | flattenArray :: Show a => Signal [a] -> a -> Signal a 132 | flattenArray sig seed = unsafePerformIO $ do 133 | firstRef <- newIORef (Just $ get sig) 134 | seedRef <- newIORef seed 135 | first <- readIORef firstRef 136 | case first of 137 | Just x -> writeIORef seedRef (head x) 138 | Nothing -> writeIORef firstRef Nothing 139 | seed <- readIORef seedRef 140 | let out = make seed 141 | let sset = set out 142 | let feed = mapM_ sset 143 | sig `subscribe` \val -> do 144 | first <- readIORef firstRef 145 | case first of 146 | Nothing -> feed val 147 | Just x -> do 148 | feed [head x] 149 | writeIORef firstRef Nothing 150 | return out 151 | 152 | -- |Turns a signal of collections of items into a signal of each item inside 153 | -- each collection, in order. 154 | flatten :: (Functor f, Foldable f, Show a) => Signal (f a) -> a -> Signal a 155 | flatten sig = flattenArray (sig ~> fold . fmap (: []) ) 156 | --} 157 | 158 | infixl 4 ~> 159 | -- | Flipped map operator 160 | (~>) :: Signal a -> (a -> b) -> Signal b 161 | (~>) = flip fmap 162 | 163 | infixl 4 <~ 164 | -- | map operator 165 | (<~) :: (a -> b) -> Signal a -> Signal b 166 | (<~) = fmap 167 | 168 | infixl 4 ~~ 169 | -- | Signal application. 170 | -- | Note that it is a double tilde, differing from 171 | -- | purescript-signal, as a single tilde is used 172 | -- | in Haskell for lazy evaluation. 173 | (~~) :: Signal (a -> b) -> Signal a -> Signal b 174 | (~~) = (<*>) 175 | 176 | instance Functor Signal where 177 | fmap fun sig = unsafePerformIO $ do 178 | let out = make $ fun $ get sig 179 | sig `subscribe` \val -> out `set` fun val 180 | return out 181 | 182 | instance Applicative Signal where 183 | pure = constant 184 | fun <*> sig = unsafePerformIO $ do 185 | let f = get fun 186 | let out = make $ f (get sig) 187 | let produce = const $ out `set` f (get sig) 188 | fun `subscribe` produce 189 | sig `subscribe` produce 190 | return out 191 | 192 | instance Semigroup (Signal a) where 193 | (<>) = merge 194 | 195 | map2 :: (a -> b -> c) -> Signal a -> Signal b -> Signal c 196 | map2 f a b = f <~ a ~~ b 197 | 198 | map3 :: (a -> b -> c -> d) -> Signal a -> Signal b -> Signal c -> Signal d 199 | map3 f a b c = f <~ a ~~ b ~~ c 200 | 201 | map4 :: (a -> b -> c -> d -> e) -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e 202 | map4 f a b c d = f <~ a ~~ b ~~ c ~~ d 203 | 204 | map5 :: (a -> b -> c -> d -> e -> f) -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e -> Signal f 205 | map5 f a b c d e = f <~ a ~~ b ~~ c ~~ d ~~ e 206 | -------------------------------------------------------------------------------- /test-suite/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | 3 | import Prelude hiding (filter) 4 | 5 | import Test.Hspec 6 | import Test.QuickCheck 7 | import Test.QuickCheck.Function 8 | import Test.QuickCheck.IO () 9 | import Data.Semigroup 10 | import Data.Maybe 11 | import Ramus.Signal 12 | import Ramus.Channel as Channel 13 | import Ramus.Time 14 | import Ramus.Internal 15 | import SignalTester 16 | import Control.Concurrent.Async 17 | import Control.Concurrent (threadDelay) 18 | 19 | type A = Int 20 | type B = Int 21 | type C = Int 22 | type (~>) a b = Fun a b 23 | 24 | main :: IO () 25 | main = hspec $ parallel $ do 26 | 27 | describe "The Signal tester" $ 28 | it "can check if a Signal contains the values or not" $ 29 | constant "Foo" `shouldYield` ["Foo"] 30 | 31 | describe "A Signal" $ do 32 | 33 | it "can contain an IO action, and is able to run it after" $ 34 | runSignal $ constant (return ()) 35 | 36 | it "is a functor, it satisfies the identity law" $ 37 | property functorIdentity 38 | 39 | it "is a functor, it satisfies the composition law" $ 40 | property functorComposition 41 | 42 | it "is an applicative, it satisifies the identity law" $ 43 | property applicativeIdentity 44 | 45 | it "is an applicative, it satisifies the homomorphism law" $ 46 | property applicativeHomomorphism 47 | 48 | it "is an applicative, it satisifies the composition law" $ 49 | property applicativeComposition 50 | 51 | it "is an applicative, it satisifies the interchange law" $ 52 | property applicativeInterchange 53 | 54 | it "is able to merge with another signal, yielding in order" $ 55 | property semigroupMerge 56 | 57 | it "is able to merge with multiple signals, yielding in order" $ 58 | property semigroupMergeMany 59 | 60 | it "is able to map a function over each value that will be yielded" $ 61 | property mapFunctionsProperty 62 | 63 | it "is able to drop repeated values in a sequence" $ 64 | property dropRepeatsProperty 65 | 66 | it "can reduce values with foldp" $ 67 | foldp (+) 0 (tick 1 1 [1, 2, 3, 4, 5]) 68 | `shouldYield` [1, 3, 6, 10, 15] 69 | 70 | it "is able to filter out values with filter" $ 71 | filter (< 5) 0 (tick 1 1 [5, 3, 8, 4]) 72 | `shouldYield` [0, 3, 4] 73 | 74 | it "is able to filter Maybe values with filterMap" $ 75 | filterMap (\n -> if n < 5 then Just n else Nothing) 76 | 0 (tick 1 1 [5, 3, 8, 4]) 77 | `shouldYield` [0, 3, 4] 78 | 79 | {- Leaves the first value off always-} 80 | it "is able to flatten the values" $ 81 | flatten (tick 1 1 [[1, 2], [3, 4], [], [5, 6, 7]]) 0 82 | `shouldYield` [1, 2, 3, 4, 5, 6, 7] 83 | --} 84 | 85 | it "is able to sum values with foldp" $ 86 | foldp (+) 0 (tick 1 1 [1, 2, 3, 4, 5]) 87 | `shouldYield` [1, 3, 6, 10, 15] 88 | 89 | it "can be delayed, but yields the same results" $ 90 | delay 40.0 (tick 1 1 [1, 2, 3, 4, 5]) 91 | `shouldYield` [1, 2, 3, 4, 5] 92 | 93 | it "yields true only once for multiple yields with since" $ 94 | since 10.0 (tick 1 1 [1, 2, 3]) 95 | `shouldYield` [False, True, False] 96 | 97 | it "can use debounce, which yields only the most recent value in a series shorter than the interval" $ do 98 | chan <- channel 0 99 | let sig = debounce 10.0 $ Channel.subscribe chan 100 | send' = send chan 101 | _ <- async $ expect 50 sig [0,2,4] 102 | threadDelay (20 * 1000) 103 | send' 1 104 | threadDelay (5 * 1000) 105 | send' 2 106 | threadDelay (20 * 1000) 107 | send' 3 108 | threadDelay (5 * 1000) 109 | send' 4 110 | threadDelay (20 * 1000) 111 | 112 | 113 | 114 | describe "A Channel" $ 115 | 116 | it "'s subscriptions yield when we send to it" $ do 117 | chan <- Channel.channel 1 118 | runSignal $ tick 1 1 [2, 3, 4] ~> Channel.send chan 119 | Channel.subscribe chan `shouldYield` [2, 3, 4] 120 | 121 | 122 | functorIdentity :: A 123 | -> IO () 124 | functorIdentity x = 125 | (id <$> constant x) 126 | `shouldYield` [x] 127 | 128 | 129 | functorComposition :: A ~> B 130 | -> B ~> C 131 | -> A 132 | -> IO () 133 | functorComposition _F _G x = 134 | (f <$> g <$> constant x) 135 | `shouldYield` [f (g x)] 136 | where 137 | f = apply _F 138 | g = apply _G 139 | 140 | 141 | applicativeIdentity :: A 142 | -> IO () 143 | applicativeIdentity x = 144 | (pure id <*> pure x) 145 | `shouldYield` [x] 146 | 147 | 148 | applicativeHomomorphism :: A ~> B 149 | -> A 150 | -> IO () 151 | applicativeHomomorphism _F x = 152 | (pure f <*> pure x) 153 | `shouldYield` [f x] 154 | where f = apply _F 155 | 156 | 157 | applicativeComposition :: B ~> C 158 | -> A ~> B 159 | -> A 160 | -> IO () 161 | applicativeComposition _F _G x = 162 | (pure (.) <*> apf <*> apg <*> apx) 163 | `shouldYield` [(f . g) x] 164 | where 165 | f = apply _F 166 | g = apply _G 167 | apf = pure f 168 | apg = pure g 169 | apx = pure x 170 | 171 | 172 | applicativeInterchange :: A 173 | -> A ~> B 174 | -> IO () 175 | applicativeInterchange y _U = 176 | (pure ($ y) <*> apu) 177 | `shouldYield` [u y] 178 | where 179 | u = apply _U 180 | apu = pure u 181 | 182 | 183 | semigroupMerge :: A 184 | -> A 185 | -> IO () 186 | semigroupMerge x y = 187 | (constant x <> constant y) 188 | `shouldYield` [x] 189 | 190 | 191 | semigroupMergeMany :: A 192 | -> [A] 193 | -> IO () 194 | semigroupMergeMany x xs = 195 | fromMaybe (constant 1337) (mergeMany testSignals) 196 | `shouldYield` [x] 197 | where 198 | testSignals = constant <$> (x:xs) 199 | 200 | 201 | mapFunctionsProperty :: [A] 202 | -> A ~> B 203 | -> Property 204 | mapFunctionsProperty lst _F = 205 | length lst > 1 ==> 206 | (f <$> tick 1 1 lst ) `shouldYield` (f <$> lst) 207 | where 208 | f = apply _F 209 | 210 | 211 | dropRepeatsProperty :: [A] 212 | -> Property 213 | dropRepeatsProperty lst = 214 | length lst > 1 ==> 215 | dropRepeats (tick 1 1 duplicated) `shouldYield` lst 216 | where 217 | duplicated = concatMap (\ x -> [x, x]) lst 218 | --------------------------------------------------------------------------------