├── .gitignore ├── .travis.yml ├── ChangeLog.md ├── LICENCE ├── README.md ├── Setup.hs ├── default.nix ├── example ├── Counter.hs ├── Main.hs └── Multithread.hs ├── nix ├── nixpkgs.json ├── nixpkgs.nix └── update.bash ├── reflex-basic-host.cabal ├── reflex-basic-host.nix ├── shell.nix └── src └── Reflex └── Host └── Basic.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-newstyle 3 | cabal.project.local 4 | result 5 | .dir-locals.el 6 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This Travis job script has been generated by a script via 2 | # 3 | # haskell-ci 'reflex-basic-host.cabal' 4 | # 5 | # For more information, see https://github.com/haskell-CI/haskell-ci 6 | # 7 | # version: 0.3.20190814 8 | # 9 | language: c 10 | dist: xenial 11 | sudo: required 12 | git: 13 | # whether to recursively clone submodules 14 | submodules: false 15 | cache: 16 | directories: 17 | - $HOME/.cabal/packages 18 | - $HOME/.cabal/store 19 | before_cache: 20 | - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log 21 | # remove files that are regenerated by 'cabal update' 22 | - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* 23 | - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json 24 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache 25 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar 26 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx 27 | - rm -rfv $CABALHOME/packages/head.hackage 28 | matrix: 29 | include: 30 | - compiler: ghc-8.6.5 31 | addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-2.4"]}} 32 | - compiler: ghc-8.4.4 33 | addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-2.4"]}} 34 | - compiler: ghc-8.2.2 35 | addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-2.4"]}} 36 | - compiler: ghc-8.0.2 37 | addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-2.4"]}} 38 | before_install: 39 | - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') 40 | - WITHCOMPILER="-w $HC" 41 | - HCPKG="$HC-pkg" 42 | - unset CC 43 | - CABAL=/opt/ghc/bin/cabal 44 | - CABALHOME=$HOME/.cabal 45 | - export PATH="$CABALHOME/bin:$PATH" 46 | - TOP=$(pwd) 47 | - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')" 48 | - echo $HCNUMVER 49 | - CABAL="$CABAL -vnormal+nowrap+markoutput" 50 | - set -o pipefail 51 | - | 52 | echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk 53 | echo 'BEGIN { state = "output"; }' >> .colorful.awk 54 | echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk 55 | echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk 56 | echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk 57 | echo ' if (state == "cabal") {' >> .colorful.awk 58 | echo ' print blue($0)' >> .colorful.awk 59 | echo ' } else {' >> .colorful.awk 60 | echo ' print $0' >> .colorful.awk 61 | echo ' }' >> .colorful.awk 62 | echo '}' >> .colorful.awk 63 | - cat .colorful.awk 64 | - | 65 | color_cabal_output () { 66 | awk -f $TOP/.colorful.awk 67 | } 68 | - echo text | color_cabal_output 69 | install: 70 | - ${CABAL} --version 71 | - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" 72 | - TEST=--enable-tests 73 | - BENCH=--enable-benchmarks 74 | - HEADHACKAGE=false 75 | - rm -f $CABALHOME/config 76 | - | 77 | echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config 78 | echo "remote-build-reporting: anonymous" >> $CABALHOME/config 79 | echo "write-ghc-environment-files: always" >> $CABALHOME/config 80 | echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config 81 | echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config 82 | echo "world-file: $CABALHOME/world" >> $CABALHOME/config 83 | echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config 84 | echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config 85 | echo "installdir: $CABALHOME/bin" >> $CABALHOME/config 86 | echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config 87 | echo "store-dir: $CABALHOME/store" >> $CABALHOME/config 88 | echo "install-dirs user" >> $CABALHOME/config 89 | echo " prefix: $CABALHOME" >> $CABALHOME/config 90 | echo "repository hackage.haskell.org" >> $CABALHOME/config 91 | echo " url: http://hackage.haskell.org/" >> $CABALHOME/config 92 | - cat $CABALHOME/config 93 | - rm -fv cabal.project cabal.project.local cabal.project.freeze 94 | - travis_retry ${CABAL} v2-update -v 95 | # Generate cabal.project 96 | - rm -rf cabal.project cabal.project.local cabal.project.freeze 97 | - touch cabal.project 98 | - | 99 | echo "packages: ." >> cabal.project 100 | - | 101 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(reflex-basic-host)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 102 | - cat cabal.project || true 103 | - cat cabal.project.local || true 104 | - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi 105 | - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output 106 | - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" 107 | - rm cabal.project.freeze 108 | - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all | color_cabal_output 109 | - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all | color_cabal_output 110 | script: 111 | - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) 112 | # Packaging... 113 | - ${CABAL} v2-sdist all | color_cabal_output 114 | # Unpacking... 115 | - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ 116 | - cd ${DISTDIR} || false 117 | - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \; 118 | - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \; 119 | - PKGDIR_reflex_basic_host="$(find . -maxdepth 1 -type d -regex '.*/reflex-basic-host-[0-9.]*')" 120 | # Generate cabal.project 121 | - rm -rf cabal.project cabal.project.local cabal.project.freeze 122 | - touch cabal.project 123 | - | 124 | echo "packages: ${PKGDIR_reflex_basic_host}" >> cabal.project 125 | - | 126 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(reflex-basic-host)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 127 | - cat cabal.project || true 128 | - cat cabal.project.local || true 129 | # Building... 130 | # this builds all libraries and executables (without tests/benchmarks) 131 | - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output 132 | # Building with tests and benchmarks... 133 | # build & run tests, build benchmarks 134 | - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output 135 | # cabal check... 136 | - (cd ${PKGDIR_reflex_basic_host} && ${CABAL} -vnormal check) 137 | # haddock... 138 | - ${CABAL} v2-haddock $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output 139 | # Building without installed constraints for packages in global-db... 140 | - rm -f cabal.project.local 141 | - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output 142 | 143 | # REGENDATA ["reflex-basic-host.cabal"] 144 | # EOF 145 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # ChangeLog 2 | 3 | ## 0.2.0.1 - 2019-10-29 4 | 5 | * Documentation fixups. 6 | * Removed redundant dependencies from cabal file. 7 | 8 | ## 0.2 - 2019-10-28 9 | 10 | * Added `Reflex.Host.Basic.repeatUntilQuit_`, with the same behaviour 11 | as 0.1's `Reflex.Host.Basic.repeatUntilQuit`. 12 | * `Reflex.Host.Basic.repeatUntilQuit` now returns an `Event` that 13 | fires each time the action executes. If you don't need this, 14 | consider `Reflex.Host.Basic.repeatUntilQuit_`. 15 | * `Reflex.Host.Basic.basicHostWithQuit`: Expect a guest that returns 16 | only `Event t ()`, as trying to return an actual result gives 17 | hard-to-diagnose type errors at the use site and most people 18 | returned `()` anyway. 19 | * `Reflex.Host.Basic.basicHostForever`: Return `()` instead of `a` for 20 | the same reason. 21 | * Do not fork a new thread when starting the host. 22 | * All hosts now run in separate reflex timelines. 23 | * Add example of a program with two independent hosts. 24 | 25 | ## 0.1 - 2019-03-19 26 | 27 | * Initial release 28 | -------------------------------------------------------------------------------- /LICENCE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019, Commonwealth Scientific and Industrial Research Organisation 2 | (CSIRO) ABN 41 687 119 230. 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above 13 | copyright notice, this list of conditions and the following 14 | disclaimer in the documentation and/or other materials provided 15 | with the distribution. 16 | 17 | * Neither the name of Data61 nor the names of other 18 | contributors may be used to endorse or promote products derived 19 | from this software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 27 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 28 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 29 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 30 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 31 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # THIS LIBRARY IS DEPRECATED 2 | 3 | Since `reflex-0.7.1.0`, there is a 4 | [`Reflex.Host.Headless`](https://hackage.haskell.org/package/reflex-0.7.1.0/docs/Reflex-Host-Headless.html) 5 | module in mainline Reflex, which allows you to do the same things as 6 | `reflex-basic-host`. 7 | 8 | # reflex-basic-host 9 | 10 | [![Build Status](https://travis-ci.org/qfpl/reflex-basic-host.svg?branch=master)](https://travis-ci.org/qfpl/reflex-basic-host) 11 | 12 | A basic `reflex` host for backend work. 13 | 14 | ## Getting Started 15 | 16 | The main entry point is `Reflex.Host.Basic.basicHostWithQuit`. The 17 | `BasicGuest` type that it expects has instances for most of the 18 | important Reflex typeclasses. To create your own `Event`s, use 19 | functions from by `Reflex.TriggerEvent`. To peform side-effects, use 20 | functions from `Reflex.PerformEvent` - `Performable (BasicGuest t m)` 21 | has a `MonadIO` instance. 22 | 23 | ## Examples 24 | 25 | For some usage examples, see [the example 26 | directory](https://github.com/qfpl/reflex-basic-host/tree/master/example) 27 | 28 | ## Contribution 29 | 30 | Feel free to file an issue or pull request on Github, or contact us at: 31 | 32 | * IRC - #qfpl on Freenode 33 | * Email - 34 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import ./nix/nixpkgs.nix 2 | , compiler ? "default" 3 | , doBenchmark ? false 4 | }: 5 | 6 | let 7 | inherit (nixpkgs) pkgs; 8 | 9 | baseHaskellPackages = if compiler == "default" 10 | then pkgs.haskellPackages 11 | else pkgs.haskell.packages.${compiler}; 12 | 13 | haskellPackages = baseHaskellPackages.override { 14 | overrides = self: super: with pkgs.haskell.lib; { 15 | witherable = super.callHackage "witherable" "0.3.1" {}; 16 | 17 | patch = unmarkBroken super.patch; 18 | reflex = unmarkBroken super.reflex; 19 | }; 20 | }; 21 | 22 | variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id; 23 | in 24 | variant (haskellPackages.callPackage ./reflex-basic-host.nix {}) 25 | -------------------------------------------------------------------------------- /example/Counter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE RecursiveDo #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | module Main where 6 | 7 | import Control.Concurrent (threadDelay) 8 | import Control.Monad.Fix (MonadFix) 9 | import Control.Monad.IO.Class (liftIO) 10 | import Data.Functor (void) 11 | import Reflex 12 | import Reflex.Host.Basic 13 | 14 | myNetwork 15 | :: (Reflex t, MonadHold t m, MonadFix m) 16 | => Event t () 17 | -> m (Dynamic t Int) 18 | myNetwork = count 19 | 20 | myGuest :: BasicGuestConstraints t m => BasicGuest t m (Event t ()) 21 | myGuest = mdo 22 | eTick <- repeatUntilQuit (void $ threadDelay 1000000) eQuit 23 | let 24 | eCountUpdated = updated dCount 25 | eQuit = () <$ ffilter (==5) eCountUpdated 26 | dCount <- myNetwork eTick 27 | 28 | performEvent_ $ liftIO . print <$> eCountUpdated 29 | pure eQuit 30 | 31 | main :: IO () 32 | main = basicHostWithQuit myGuest 33 | -------------------------------------------------------------------------------- /example/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecursiveDo #-} 2 | 3 | module Main (main) where 4 | 5 | import Control.Monad.IO.Class (liftIO) 6 | import Data.Functor (($>), void) 7 | import Reflex 8 | import Reflex.Host.Basic (basicHostWithQuit) 9 | 10 | main :: IO () 11 | main = basicHostWithQuit $ mdo 12 | ePostBuild <- getPostBuild 13 | eLine <- performEventAsync $ leftmost [void eMessage, ePostBuild] $> \fn -> 14 | liftIO $ fn =<< getLine 15 | 16 | let 17 | eMessage = ffilter (/= "quit") eLine 18 | eQuit = void . ffilter (== "quit") $ eLine 19 | 20 | performEvent_ $ liftIO . putStrLn <$> eMessage 21 | 22 | pure eQuit 23 | -------------------------------------------------------------------------------- /example/Multithread.hs: -------------------------------------------------------------------------------- 1 | {-# language FlexibleContexts, TypeFamilies #-} 2 | module Main where 3 | 4 | {- | 5 | 6 | * Multithreaded Multi-Host Example 7 | 8 | This example boots two reflex networks which we will call "Left" and 9 | "Right". As they start, they each write an event trigger into an 10 | 'MVar' and read an event trigger from another 'MVar', so that they can 11 | fire events into each other's network. 12 | 13 | Left and Right both log to stdout any lines received from each 14 | other. Left also reads lines from stdin, and lines are passed around 15 | as follows: Left passes incoming lines to Right, which immediately 16 | sends received lines back to Left. 17 | 18 | If "quit" is read from stdin, this triggers a shutdown of both FRP 19 | networks. 20 | 21 | -} 22 | 23 | import Control.Concurrent (forkIO) 24 | import Control.Concurrent.MVar (MVar, newEmptyMVar, readMVar, putMVar, takeMVar) 25 | import Control.Lens ((<&>)) 26 | import Control.Monad (forever) 27 | import Control.Monad.IO.Class (liftIO) 28 | import Data.Functor (($>), void) 29 | import Data.Semigroup ((<>)) 30 | import Data.Witherable (filter) 31 | import Prelude hiding (filter) 32 | import Reflex 33 | import Reflex.Host.Basic 34 | 35 | left 36 | :: BasicGuestConstraints t m 37 | => MVar (String -> IO ()) 38 | -> MVar (String -> IO ()) 39 | -> BasicGuest t m (Event t ()) 40 | left mTriggerLeft mTriggerRight = do 41 | -- Construct the event "lines from Right", and put its trigger in an MVar. 42 | (eFromRight, triggerLeft) <- newTriggerEvent 43 | liftIO $ putMVar mTriggerLeft triggerLeft 44 | 45 | -- Kick off a loop to read from stdin. Ignore exceptions for brevity. 46 | ePostBuild <- getPostBuild 47 | eLines <- performEventAsync $ ePostBuild $> \fire -> 48 | void . liftIO . forkIO . forever $ getLine >>= fire 49 | 50 | -- Get the event trigger for the "lines from Left" event inside the 51 | -- Right network, and fire it on each line. 52 | triggerRight <- liftIO $ readMVar mTriggerRight 53 | performEvent_ $ liftIO . triggerRight <$> eLines 54 | 55 | -- Log events received from Right. 56 | performEvent_ $ eFromRight <&> \msg -> 57 | liftIO . putStrLn $ "From Right: " <> msg 58 | 59 | -- Quit if we get a "quit" from Right. 60 | pure . void $ filter (== "quit") eFromRight 61 | 62 | right 63 | :: BasicGuestConstraints t m 64 | => MVar (String -> IO ()) 65 | -> MVar (String -> IO ()) 66 | -> BasicGuest t m (Event t ()) 67 | right mTriggerLeft mTriggerRight = do 68 | -- Construct the event "lines from Left", and put its trigger in an MVar. 69 | (eFromLeft, triggerRight) <- newTriggerEvent 70 | liftIO $ putMVar mTriggerRight triggerRight 71 | 72 | -- Get the event trigger for the "lines from Right" event inside the 73 | -- Left network, and fire it on each line. 74 | triggerLeft <- liftIO $ readMVar mTriggerLeft 75 | performEvent_ $ liftIO . triggerLeft <$> eFromLeft 76 | 77 | -- Log events received from Left. 78 | performEvent_ $ eFromLeft <&> \msg -> 79 | liftIO . putStrLn $ "From Left: " <> msg 80 | 81 | -- Quit if we get a "quit" from Left. 82 | pure . void $ filter (== "quit") eFromLeft 83 | 84 | main :: IO () 85 | main = do 86 | -- Removing these type annotations causes type errors like "a0 is 87 | -- untouchable". 88 | mTriggerLeft <- newEmptyMVar :: IO (MVar (String -> IO ())) 89 | mTriggerRight <- newEmptyMVar :: IO (MVar (String -> IO ())) 90 | 91 | mLeftDone <- newEmptyMVar 92 | mRightDone <- newEmptyMVar 93 | 94 | -- Not exception-safe, for brevity's sake. 95 | void . forkIO $ do 96 | basicHostWithQuit (left mTriggerLeft mTriggerRight) 97 | putMVar mLeftDone () 98 | 99 | void . forkIO $ do 100 | basicHostWithQuit (right mTriggerLeft mTriggerRight) 101 | putMVar mRightDone () 102 | 103 | -- Wait for both threads 104 | takeMVar mLeftDone 105 | takeMVar mRightDone 106 | -------------------------------------------------------------------------------- /nix/nixpkgs.json: -------------------------------------------------------------------------------- 1 | { 2 | "url": "https://github.com/NixOS/nixpkgs", 3 | "rev": "40d7ce78281319631feceac6e0579a6d01b76b33", 4 | "date": "2020-03-04T11:55:41+01:00", 5 | "sha256": "0nmz0i9wfiylfh4dynyqcfpzjqqjxmc62ls1ayl1gd1256ihgzfr", 6 | "fetchSubmodules": false 7 | } 8 | -------------------------------------------------------------------------------- /nix/nixpkgs.nix: -------------------------------------------------------------------------------- 1 | let 2 | nixpkgsJson = builtins.fromJSON (builtins.readFile ./nixpkgs.json); 3 | nixpkgsFunc = import (builtins.fetchTarball (with nixpkgsJson; { 4 | url = "${url}/archive/${rev}.tar.gz"; 5 | inherit sha256; 6 | })); 7 | in 8 | nixpkgsFunc {} 9 | -------------------------------------------------------------------------------- /nix/update.bash: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env nix-shell 2 | #!nix-shell -i bash -p nix-prefetch-git 3 | 4 | nix-prefetch-git https://github.com/NixOS/nixpkgs > nixpkgs.json 5 | -------------------------------------------------------------------------------- /reflex-basic-host.cabal: -------------------------------------------------------------------------------- 1 | name: reflex-basic-host 2 | version: 0.2.0.1 3 | license: BSD3 4 | license-file: LICENCE 5 | author: Dave Laing 6 | maintainer: dave.laing.80@gmail.com, jack.kelly@data61.csiro.au 7 | homepage: https://github.com/qfpl/reflex-basic-host/ 8 | bug-reports: https://github.com/qfpl/reflex-basic-host/issues 9 | copyright: Copyright (c) 2019, Commonwealth Scientific and Industrial Research Organisation (CSIRO) ABN 41 687 119 230. 10 | build-type: Simple 11 | extra-source-files: ChangeLog.md 12 | cabal-version: >=1.10 13 | category: FRP 14 | synopsis: A basic Reflex host for backend work 15 | description: 16 | <> 17 | . 18 | reflex-basic-host provides a basic Reflex host for backend work. It 19 | provides instances for most of the important Reflex typeclasses. 20 | . 21 | @Reflex.Host.Basic.basicHostWithQuit@ is the main entry point for 22 | running FRP code. Use the @TriggerEvent@ instance to construct 23 | @Event@s and control when they fire, and use the @PerformEvent@ 24 | instance to take actions in response to @Event@ firings. 25 | . 26 | From @reflex >= 0.7.1.0@, there is an equivalent 27 | @Reflex.Host.Headless@ module, so this package is now deprecated. 28 | 29 | tested-with: GHC == 8.0.2 30 | , GHC == 8.2.2 31 | , GHC == 8.4.4 32 | , GHC == 8.6.5 33 | 34 | source-repository head 35 | type: git 36 | location: git@github.com:qfpl/reflex-basic-host.git 37 | 38 | library 39 | exposed-modules: Reflex.Host.Basic 40 | build-depends: base >=4.9 && <4.14 41 | , dependent-sum >= 0.4 && < 0.7 42 | , lens >= 3.6 && < 4.19 43 | , mtl >= 2.2 && < 2.3 44 | , primitive >= 0.6 && < 0.8 45 | , ref-tf >= 0.4 && < 0.5 46 | , reflex >= 0.6 && < 0.7 47 | , stm >= 2.4 && < 2.6 48 | hs-source-dirs: src 49 | ghc-options: -Wall 50 | default-language: Haskell2010 51 | 52 | executable example 53 | main-is: Main.hs 54 | build-depends: base >=4.9 && <4.14 55 | , reflex >= 0.6 && < 0.7 56 | , reflex-basic-host 57 | hs-source-dirs: example 58 | ghc-options: -Wall 59 | default-language: Haskell2010 60 | 61 | executable counter 62 | main-is: Counter.hs 63 | build-depends: base >=4.9 && <4.14 64 | , reflex >= 0.6 && < 0.7 65 | , reflex-basic-host 66 | hs-source-dirs: example 67 | ghc-options: -Wall 68 | default-language: Haskell2010 69 | 70 | executable multithread 71 | main-is: Multithread.hs 72 | build-depends: base >=4.9 && <4.14 73 | , lens >= 3.6 && < 4.19 74 | , reflex >= 0.6 && < 0.7 75 | , reflex-basic-host 76 | , witherable >= 0.2 && < 0.4 77 | hs-source-dirs: example 78 | ghc-options: -Wall 79 | default-language: Haskell2010 80 | -------------------------------------------------------------------------------- /reflex-basic-host.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, dependent-sum, lens, mtl, primitive, ref-tf 2 | , reflex, stdenv, stm, witherable 3 | }: 4 | mkDerivation { 5 | pname = "reflex-basic-host"; 6 | version = "0.2"; 7 | src = ./.; 8 | isLibrary = true; 9 | isExecutable = true; 10 | libraryHaskellDepends = [ 11 | base dependent-sum lens mtl primitive ref-tf reflex stm 12 | ]; 13 | executableHaskellDepends = [ base lens reflex witherable ]; 14 | homepage = "https://github.com/qfpl/reflex-basic-host/"; 15 | description = "A basic Reflex host for backend work"; 16 | license = stdenv.lib.licenses.bsd3; 17 | } 18 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import ./nix/nixpkgs.nix 2 | , compiler ? "default" 3 | , doBenchmark ? false 4 | }: 5 | let 6 | inherit (nixpkgs) pkgs; 7 | env = (import ./. { inherit nixpkgs compiler doBenchmark; }).env; 8 | in 9 | env.overrideAttrs (oldAttrs: { 10 | buildInputs = with pkgs.haskellPackages; oldAttrs.buildInputs ++ [ 11 | cabal-install cabal2nix ghcid 12 | ]; 13 | }) 14 | -------------------------------------------------------------------------------- /src/Reflex/Host/Basic.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Reflex.Host.Basic 3 | Copyright : (c) 2019 Commonwealth Scientific and Industrial Research Organisation (CSIRO) 4 | License : BSD-3 5 | Maintainer : dave.laing.80@gmail.com, jack.kelly@data61.csiro.au 6 | 7 | 'BasicGuest' provides instances that most Reflex programs need: 8 | 9 | * 'MonadIO' 10 | * 'MonadFix' 11 | * 'MonadSample' 12 | * 'MonadHold' 13 | * 'NotReady' 14 | * 'PostBuild' 15 | * 'PerformEvent' — @'Performable' ('BasicGuest' t m)@ has 'MonadIO' 16 | * 'TriggerEvent' 17 | * 'Adjustable' 18 | 19 | For some usage examples, see 20 | . 21 | 22 | -} 23 | 24 | {-# LANGUAGE ConstraintKinds #-} 25 | {-# LANGUAGE FlexibleContexts #-} 26 | {-# LANGUAGE FlexibleInstances #-} 27 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 28 | {-# LANGUAGE MultiParamTypeClasses #-} 29 | {-# LANGUAGE RankNTypes #-} 30 | {-# LANGUAGE TypeFamilies #-} 31 | {-# LANGUAGE UndecidableInstances #-} 32 | 33 | module Reflex.Host.Basic 34 | ( 35 | -- * Running the host 36 | basicHostWithQuit 37 | , basicHostForever 38 | 39 | -- * Types 40 | , BasicGuest 41 | , BasicGuestConstraints 42 | 43 | -- * Utilities 44 | , repeatUntilQuit 45 | , repeatUntilQuit_ 46 | ) where 47 | 48 | import Control.Concurrent (forkIO) 49 | import Control.Concurrent.Chan (newChan, readChan) 50 | import Control.Concurrent.STM.TVar (newTVarIO, writeTVar, readTVarIO) 51 | import Control.Lens ((<&>)) 52 | import Control.Monad (void, when, unless) 53 | import Control.Monad.Fix (MonadFix) 54 | import Control.Monad.Primitive (PrimMonad) 55 | import Control.Monad.Ref (MonadRef(..)) 56 | import Control.Monad.STM (atomically) 57 | import Control.Monad.Trans (MonadIO(..), MonadTrans(..)) 58 | import Data.Dependent.Sum (DSum(..), (==>)) 59 | import Data.Foldable (for_, traverse_) 60 | import Data.Functor.Identity (Identity) 61 | import Data.Maybe (catMaybes, isJust) 62 | import Data.Traversable (for) 63 | import Reflex 64 | import Reflex.Host.Class 65 | 66 | -- | Constraints provided by a 'BasicGuest', when run by 67 | -- 'basicHostWithQuit' or 'basicHostForever'. 68 | type BasicGuestConstraints t (m :: * -> *) = 69 | ( MonadReflexHost t m 70 | , MonadHold t m 71 | , MonadSample t m 72 | , Ref m ~ Ref IO 73 | , MonadRef (HostFrame t) 74 | , Ref (HostFrame t) ~ Ref IO 75 | , MonadIO (HostFrame t) 76 | , PrimMonad (HostFrame t) 77 | , MonadIO m 78 | , MonadFix m 79 | ) 80 | 81 | -- | The basic guest type. Try not to code against it directly; 82 | -- instead ask for the features you need MTL-style: 83 | -- 84 | -- @ 85 | -- myFunction :: (Reflex t, MonadHold m) => ... 86 | -- @ 87 | newtype BasicGuest t (m :: * -> *) a = 88 | BasicGuest { 89 | unBasicGuest :: PostBuildT t (TriggerEventT t (PerformEventT t m)) a 90 | } deriving (Functor, Applicative, Monad, MonadFix) 91 | 92 | instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (BasicGuest t m) where 93 | {-# INLINEABLE liftIO #-} 94 | liftIO = BasicGuest . liftIO 95 | 96 | instance ReflexHost t => MonadSample t (BasicGuest t m) where 97 | {-# INLINABLE sample #-} 98 | sample = BasicGuest . lift . sample 99 | 100 | instance (ReflexHost t, MonadHold t m) => MonadHold t (BasicGuest t m) where 101 | {-# INLINABLE hold #-} 102 | hold v0 = BasicGuest . lift . hold v0 103 | 104 | {-# INLINABLE holdDyn #-} 105 | holdDyn v0 = BasicGuest . lift . holdDyn v0 106 | 107 | {-# INLINABLE holdIncremental #-} 108 | holdIncremental v0 = BasicGuest . lift . holdIncremental v0 109 | 110 | {-# INLINABLE buildDynamic #-} 111 | buildDynamic a0 = BasicGuest . lift . buildDynamic a0 112 | 113 | {-# INLINABLE headE #-} 114 | headE = BasicGuest . lift . headE 115 | 116 | instance ReflexHost t => PostBuild t (BasicGuest t m) where 117 | {-# INLINABLE getPostBuild #-} 118 | getPostBuild = BasicGuest getPostBuild 119 | 120 | instance 121 | ( ReflexHost t 122 | , MonadRef (HostFrame t) 123 | , Ref (HostFrame t) ~ Ref IO 124 | ) => TriggerEvent t (BasicGuest t m) where 125 | 126 | {-# INLINABLE newTriggerEvent #-} 127 | newTriggerEvent = BasicGuest $ lift newTriggerEvent 128 | 129 | {-# INLINABLE newTriggerEventWithOnComplete #-} 130 | newTriggerEventWithOnComplete = 131 | BasicGuest $ lift newTriggerEventWithOnComplete 132 | 133 | {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-} 134 | newEventWithLazyTriggerWithOnComplete = 135 | BasicGuest . lift . newEventWithLazyTriggerWithOnComplete 136 | 137 | instance 138 | ( ReflexHost t 139 | , Ref m ~ Ref IO 140 | , MonadRef (HostFrame t) 141 | , Ref (HostFrame t) ~ Ref IO 142 | , MonadIO (HostFrame t) 143 | , PrimMonad (HostFrame t) 144 | , MonadIO m 145 | ) => PerformEvent t (BasicGuest t m) where 146 | 147 | type Performable (BasicGuest t m) = HostFrame t 148 | 149 | {-# INLINABLE performEvent_ #-} 150 | performEvent_ = BasicGuest . lift . lift . performEvent_ 151 | 152 | {-# INLINABLE performEvent #-} 153 | performEvent = BasicGuest . lift . lift . performEvent 154 | 155 | instance 156 | ( ReflexHost t 157 | , Ref m ~ Ref IO 158 | , MonadHold t m 159 | , PrimMonad (HostFrame t) 160 | ) => Adjustable t (BasicGuest t m) where 161 | 162 | {-# INLINABLE runWithReplace #-} 163 | runWithReplace a0 a' = BasicGuest $ 164 | runWithReplace (unBasicGuest a0) (fmap unBasicGuest a') 165 | 166 | {-# INLINABLE traverseIntMapWithKeyWithAdjust #-} 167 | traverseIntMapWithKeyWithAdjust f dm0 dm' = BasicGuest $ 168 | traverseIntMapWithKeyWithAdjust (\k v -> unBasicGuest (f k v)) dm0 dm' 169 | 170 | {-# INLINABLE traverseDMapWithKeyWithAdjust #-} 171 | traverseDMapWithKeyWithAdjust f dm0 dm' = BasicGuest $ 172 | traverseDMapWithKeyWithAdjust (\k v -> unBasicGuest (f k v)) dm0 dm' 173 | 174 | {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-} 175 | traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = BasicGuest $ 176 | traverseDMapWithKeyWithAdjustWithMove (\k v -> unBasicGuest (f k v)) dm0 dm' 177 | 178 | instance ReflexHost t => NotReady t (BasicGuest t m) where 179 | {-# INLINABLE notReadyUntil #-} 180 | notReadyUntil _ = pure () 181 | 182 | {-# INLINABLE notReady #-} 183 | notReady = pure () 184 | 185 | -- | Run a 'BasicGuest' without a quit 'Event'. 186 | -- 187 | -- @ 188 | -- basicHostForever guest = 'basicHostWithQuit' $ never <$ guest 189 | -- @ 190 | basicHostForever 191 | :: (forall t m. BasicGuestConstraints t m => BasicGuest t m ()) 192 | -> IO () 193 | basicHostForever guest = basicHostWithQuit $ never <$ guest 194 | 195 | -- | Run a 'BasicGuest', and return when the 'Event' returned by the 196 | -- 'BasicGuest' fires. 197 | -- 198 | -- Each host runs on a separate spider timeline, so you can launch 199 | -- multiple hosts via 'Control.Concurrent.forkIO' or 200 | -- 'Control.Concurrent.forkOS' and they will not mutex each other. 201 | -- 202 | -- NOTE: If you want to capture values from a build before the network 203 | -- starts firing (e.g., to hand off event triggers to another thread), 204 | -- populate an 'Control.Concurrent.MVar' (if threading) or 205 | -- 'Data.IORef.IORef' as you build the network. If you receive errors 206 | -- about untouchable type variables while doing this, add type 207 | -- annotations to constrain the 'Control.Concurrent.MVar' or 208 | -- 'Data.IORef.IORef' contents before passing them to the function 209 | -- that returns your 'BasicGuest'. See the @Multithread.hs@ example 210 | -- for a demonstration of this pattern, and where to put the type 211 | -- annotations. 212 | basicHostWithQuit 213 | :: (forall t m. BasicGuestConstraints t m => BasicGuest t m (Event t ())) 214 | -> IO () 215 | basicHostWithQuit guest = 216 | withSpiderTimeline $ runSpiderHostForTimeline $ do 217 | -- Unpack the guest, get the quit event, the result of building the 218 | -- network, and a function to kick off each frame. 219 | (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef 220 | triggerEventChan <- liftIO newChan 221 | rHasQuit <- newRef False -- When to shut down 222 | (eQuit, FireCommand fire) <- hostPerformEventT 223 | . flip runTriggerEventT triggerEventChan 224 | . flip runPostBuildT postBuild 225 | $ unBasicGuest guest 226 | 227 | hQuit <- subscribeEvent eQuit 228 | let 229 | runFrameAndCheckQuit firings = do 230 | lmQuit <- fire firings $ readEvent hQuit >>= sequenceA 231 | when (any isJust lmQuit) $ writeRef rHasQuit True 232 | 233 | -- If anyone is listening to PostBuild, fire it 234 | readRef postBuildTriggerRef 235 | >>= traverse_ (\t -> runFrameAndCheckQuit [t ==> ()]) 236 | 237 | let 238 | loop = do 239 | hasQuit <- readRef rHasQuit 240 | unless hasQuit $ do 241 | eventsAndTriggers <- liftIO $ readChan triggerEventChan 242 | 243 | let 244 | prepareFiring 245 | :: (MonadRef m, Ref m ~ Ref IO) 246 | => DSum (EventTriggerRef t) TriggerInvocation 247 | -> m (Maybe (DSum (EventTrigger t) Identity)) 248 | prepareFiring (EventTriggerRef er :=> TriggerInvocation x _) 249 | = readRef er <&> fmap (==> x) 250 | 251 | catMaybes <$> for eventsAndTriggers prepareFiring 252 | >>= runFrameAndCheckQuit 253 | 254 | -- Fire callbacks for each event we triggered this frame 255 | liftIO . for_ eventsAndTriggers $ 256 | \(_ :=> TriggerInvocation _ cb) -> cb 257 | loop 258 | loop 259 | 260 | -- | Augment a 'BasicGuest' with an action that is repeatedly run 261 | -- until the provided 'Event' fires. Each time the action completes, 262 | -- the returned 'Event' will fire. 263 | -- 264 | -- Example - providing a \'tick\' 'Event' to a network 265 | -- 266 | -- @ 267 | -- myNetwork 268 | -- :: (Reflex t, MonadHold t m, MonadFix m) 269 | -- => Event t () 270 | -- -> m (Dynamic t Int) 271 | -- myNetwork = count 272 | -- 273 | -- myGuest :: BasicGuestConstraints t m => BasicGuest t m (Event t ()) 274 | -- myGuest = mdo 275 | -- eTick <- repeatUntilQuit (void $ threadDelay 1000000) eQuit 276 | -- let 277 | -- eCountUpdated = updated dCount 278 | -- eQuit = () <$ ffilter (==5) eCountUpdated 279 | -- dCount <- myNetwork eTick 280 | -- 281 | -- performEvent_ $ liftIO . print \<$\> eCountUpdated 282 | -- pure eQuit 283 | -- 284 | -- main :: IO () 285 | -- main = basicHostWithQuit myGuest 286 | -- @ 287 | repeatUntilQuit 288 | :: BasicGuestConstraints t m 289 | => IO a -- ^ Action to repeatedly run 290 | -> Event t () -- ^ 'Event' to stop the action 291 | -> BasicGuest t m (Event t a) 292 | repeatUntilQuit act eQuit = do 293 | ePostBuild <- getPostBuild 294 | tHasQuit <- liftIO $ newTVarIO False 295 | 296 | let 297 | go fire = loop where 298 | loop = do 299 | hasQuit <- readTVarIO tHasQuit 300 | unless hasQuit $ (act >>= fire) *> loop 301 | 302 | performEvent_ $ liftIO (atomically $ writeTVar tHasQuit True) <$ eQuit 303 | performEventAsync $ liftIO . void . forkIO . go <$ ePostBuild 304 | 305 | -- | Like 'repeatUntilQuit', but it doesn't do anything with the 306 | -- result of the action. May be a little more efficient if you don't 307 | -- need it. 308 | repeatUntilQuit_ 309 | :: BasicGuestConstraints t m 310 | => IO a -- ^ Action to repeatedly run 311 | -> Event t () -- ^ 'Event' to stop the action 312 | -> BasicGuest t m () 313 | repeatUntilQuit_ act eQuit = do 314 | ePostBuild <- getPostBuild 315 | tHasQuit <- liftIO $ newTVarIO False 316 | 317 | let 318 | loop = do 319 | hasQuit <- readTVarIO tHasQuit 320 | unless hasQuit $ act *> loop 321 | 322 | performEvent_ $ liftIO (atomically $ writeTVar tHasQuit True) <$ eQuit 323 | performEvent_ $ liftIO (void $ forkIO loop) <$ ePostBuild 324 | --------------------------------------------------------------------------------