Last active
June 18, 2020 13:30
Star
You must be signed in to star a gist
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE RecursiveDo #-} | |
import Control.Lens ((^.), (+~), (-~), (.~)) | |
import GHC.Generics (Generic) | |
import Data.Generics.Labels () | |
import Control.Monad (forever) | |
import Control.Concurrent (forkIO, killThread, threadDelay) | |
import Data.Functor.Product (Product (..)) | |
import System.Random (randomIO) | |
import Data.IORef (newIORef, modifyIORef', readIORef, writeIORef) | |
newtype Action model event a | |
= Action (model -> (event -> IO ()) -> IO a) | |
data SubscriptionT model event f where | |
When :: (model -> Bool) -> f (IO ()) -> SubscriptionT model event f | |
Always :: f (IO ()) -> SubscriptionT model event f | |
Subscriptions :: [SubscriptionT model event f] -> SubscriptionT model event f | |
when_ :: (model -> Bool) -> (model -> (event -> IO ()) -> IO (IO ())) -> Subscription model event | |
when_ check action = When check (Action action) | |
always :: (model -> (event -> IO ()) -> IO (IO ())) -> Subscription model event | |
always action = Always (Action action) | |
type Subscription model event | |
= SubscriptionT model event (Action model event) | |
type SubscriptionRT model event | |
= SubscriptionT model event (Product (Action model event) Maybe) | |
startSubscription :: model -> (event -> IO ()) -> Subscription model event -> IO (SubscriptionRT model event) | |
startSubscription model dispatch = go where | |
go (Subscriptions subscriptions) = Subscriptions <$> traverse go subscriptions | |
go (Always (Action action)) = do | |
detach <- action model dispatch | |
pure $ Always (Pair (Action action) (Just detach)) | |
go (When check (Action action)) = do | |
detach <- if check model then Just <$> action model dispatch else pure Nothing | |
pure $ When check (Pair (Action action) detach) | |
updateSubscription :: model -> (event -> IO ()) -> SubscriptionRT model event -> IO (SubscriptionRT model event) | |
updateSubscription model dispatch = go where | |
go (Subscriptions subscriptions) = Subscriptions <$> traverse go subscriptions | |
go (Always (Pair (Action action) (Just detach))) = do | |
detach | |
detach <- action model dispatch | |
pure $ Always (Pair (Action action) (Just detach)) | |
go s@(When check (Pair (Action action) detach)) = case (check model, detach) of | |
(True, Just detach) -> pure s | |
(False, Nothing) -> pure s | |
(False, Just detach) -> do | |
detach | |
pure $ When check (Pair (Action action) Nothing) | |
(True, Nothing) -> do | |
detach <- action model dispatch | |
pure $ When check (Pair (Action action) (Just detach)) | |
stopSubscription :: SubscriptionRT model event -> IO (Subscription model event) | |
stopSubscription (Subscriptions subscriptions) = Subscriptions <$> traverse stopSubscription subscriptions | |
stopSubscription (Always (Pair action detach)) = sequence detach >> pure (Always action) | |
stopSubscription (When check (Pair action detach)) = sequence detach >> pure (When check action) | |
-- Example | |
data Model = Model | |
{ counter :: Int | |
, randomNumber :: Int | |
} deriving (Generic, Show) | |
data Event | |
= Increment | |
| Decrement | |
| SetRandom Int | |
update :: Event -> Model -> Model | |
update Increment = #counter +~ 1 | |
update Decrement = #counter -~ 1 | |
update (SetRandom x) = #randomNumber .~ x | |
subscription :: Subscription Model Event | |
subscription = Subscriptions | |
[ when_ (\state -> state ^. #counter < 5) \state dispatch -> do | |
putStrLn "start random thread" | |
threadId <- forkIO $ forever do | |
threadDelay $ 1000 * 1000 | |
dispatch . SetRandom . (`mod` 100) =<< randomIO | |
pure do | |
putStrLn "stop random thread" | |
killThread threadId | |
, always \state dispatch -> do | |
putStrLn $ "Logging: " <> show state | |
pure do pure () | |
] | |
main = do | |
let initialModel = Model 0 0 | |
modelRef <- newIORef initialModel | |
let dispatch subRef event = do | |
modifyIORef' modelRef (update event) | |
sub <- readIORef subRef | |
model <- readIORef modelRef | |
newSub <- updateSubscription model (dispatch subRef) sub | |
writeIORef subRef newSub | |
rec subRef <- newIORef =<< startSubscription initialModel (dispatch subRef) subscription | |
threadDelay $ 1000 * 400 | |
dispatch subRef Increment | |
threadDelay $ 1000 * 400 | |
dispatch subRef Increment | |
threadDelay $ 1000 * 400 | |
dispatch subRef Increment | |
threadDelay $ 1000 * 400 | |
dispatch subRef Increment | |
threadDelay $ 1000 * 400 | |
dispatch subRef Increment | |
threadDelay $ 1000 * 400 | |
dispatch subRef Increment | |
threadDelay $ 1000 * 400 | |
dispatch subRef Increment | |
threadDelay $ 1000 * 400 | |
dispatch subRef Decrement | |
threadDelay $ 1000 * 400 | |
dispatch subRef Decrement | |
threadDelay $ 1000 * 400 | |
dispatch subRef Decrement | |
threadDelay $ 1000 * 1000 * 3 | |
stopSubscription =<< readIORef subRef | |
print =<< readIORef modelRef | |
pure () |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
start random thread | |
Logging: Model {counter = 0, randomNumber = 0} | |
Logging: Model {counter = 1, randomNumber = 0} | |
Logging: Model {counter = 2, randomNumber = 0} | |
Logging: Model {counter = 2, randomNumber = 72} | |
Logging: Model {counter = 3, randomNumber = 72} | |
Logging: Model {counter = 4, randomNumber = 72} | |
Logging: Model {counter = 4, randomNumber = 88} | |
stop random thread | |
Logging: Model {counter = 5, randomNumber = 88} | |
Logging: Model {counter = 6, randomNumber = 88} | |
Logging: Model {counter = 7, randomNumber = 88} | |
Logging: Model {counter = 6, randomNumber = 88} | |
Logging: Model {counter = 5, randomNumber = 88} | |
start random thread | |
Logging: Model {counter = 4, randomNumber = 88} | |
Logging: Model {counter = 4, randomNumber = 50} | |
Logging: Model {counter = 4, randomNumber = 60} | |
stop random thread | |
Model {counter = 4, randomNumber = 60} |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
name: haskell-playground | |
version: 0.1.0.0 | |
github: "Github username here/haskell-playground" | |
license: BSD3 | |
author: "Author name here" | |
maintainer: "Author email here" | |
copyright: "2019 Author name here" | |
extra-source-files: | |
- README.md | |
- ChangeLog.md | |
# Metadata used when publishing your package | |
# synopsis: Short description of your package | |
# category: App category here | |
# To avoid duplicated efforts in documentation and dealing with the | |
# complications of embedding Haddock markup inside cabal files, it is | |
# common to point users to the README.md file. | |
description: Please see the README on GitHub at <https://github.com/Github username here/haskell-playground#readme> | |
default-extensions: | |
- BlockArguments | |
- RecordWildCards | |
- NamedFieldPuns | |
- DeriveGeneric | |
- DeriveFunctor | |
- OverloadedLabels | |
- LambdaCase | |
- TypeInType | |
- TypeOperators | |
- FlexibleInstances | |
- FlexibleContexts | |
- FunctionalDependencies | |
- TypeApplications | |
- ScopedTypeVariables | |
- TypeFamilies | |
- TupleSections | |
- GADTs | |
- RankNTypes | |
- ViewPatterns | |
- GeneralizedNewtypeDeriving | |
dependencies: | |
- base >= 4.7 && < 5 | |
- unordered-containers | |
- lens | |
- lens-aeson | |
- aeson | |
- text | |
- bytestring | |
- neat-interpolation | |
- vector | |
- managed | |
- transformers | |
- mtl | |
- containers | |
- generic-deriving | |
- profunctors | |
- generic-lens | |
- stm | |
- random | |
executables: | |
haskell-playground-exe: | |
main: Main.hs | |
source-dirs: app | |
ghc-options: | |
- -threaded | |
- -rtsopts | |
- -with-rtsopts=-N | |
dependencies: | |
- haskell-playground |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment