Skip to content

Instantly share code, notes, and snippets.

@kana-sama
Last active June 18, 2020 13:30
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
Save kana-sama/d7998257abbeaf7fdd7dafce18440ac7 to your computer and use it in GitHub Desktop.
{-# 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 ()
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}
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