box 0.6.3 → 0.9.4.0
raw patch · 19 files changed
Files
- ChangeLog.md +13/−0
- LICENSE +1/−1
- app/concurrency-tests.hs +0/−96
- app/websocket-tests.hs +0/−213
- box.cabal +52/−129
- readme.md +280/−34
- src/Box.hs +24/−205
- src/Box/Box.hs +146/−64
- src/Box/Codensity.hs +69/−0
- src/Box/Committer.hs +52/−57
- src/Box/Connectors.hs +158/−122
- src/Box/Cont.hs +0/−111
- src/Box/Emitter.hs +137/−136
- src/Box/Functor.hs +21/−0
- src/Box/IO.hs +220/−67
- src/Box/Queue.hs +133/−108
- src/Box/Time.hs +168/−66
- stack.yaml +0/−13
- test/test.hs +0/−15
+ ChangeLog.md view
@@ -0,0 +1,13 @@+0.9.4+===++- GHC 9.14.1 support+- simplified Cabal stanzas to best practice template+- relaxed dependency bounds via allow-newer for GHC 9.14 compatibility++0.9.3+===+* stdBox, toLineBox, fromLineBox added to Box.IO++* concurrentlyLeft & concurrentlyRight exposed in Box.Queue+
LICENSE view
@@ -1,4 +1,4 @@-Copyright Tony Day (c) 2018+Copyright (c) 2017, Tony Day All rights reserved.
− app/concurrency-tests.hs
@@ -1,96 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RebindableSyntax #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -Wall #-}-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-}---- | dejavu testing-module Main where--import Box-import Control.Lens-import Control.Monad.Conc.Class as C-import qualified Data.Sequence as Seq-import NumHask.Prelude hiding (STM)-import Test.DejaFu hiding (get)-import Test.DejaFu.Types--tERef :: (MonadConc m) => Emitter m a -> m [a]-tERef e = do- (c, res) <- cRef- glue c e- res--tToListE :: (MonadConc m) => Int -> m [Int]-tToListE n =- toListE <$.> fromListE [1 .. n]--tFromListE :: (MonadConc m) => Int -> m [Int]-tFromListE n = do- (c, res) <- cRef- let e = fromListE [0 .. (n - 1)]- fuse (pure . pure) <$.> (Box c <$> e)- res--tToList_ :: (MonadConc m) => Int -> m [Int]-tToList_ n =- toList_ <$.> fromListE [1 .. n]---- failing-tFromList_ :: (MonadConc m) => Int -> m [Int]-tFromList_ n = do- (c, res) <- cRef- fromList_ [1 .. n] c- res--tFromList_' :: (MonadConc m) => Int -> m [Int]-tFromList_' n = toList <$> execStateT (fromList_ [1 .. n] stateC) Seq.empty--tPureState :: Int -> [Int]-tPureState n =- toList $- runIdentity $- fmap fst $- flip execStateT (Seq.empty, Seq.fromList [1 .. n]) $- glue (hoist (zoom _1) stateC) (hoist (zoom _2) stateE)--tPureBoxF f n = fromToList_ [1 .. n] f---- tForkEmit <$.> (fromListE [1..4])--- tForkEmit <$.> (toEmitter (S.take 4 $ S.each [1..]))-tForkEmit :: (MonadConc m) => Emitter m b -> m ([b], [b])-tForkEmit e = do- (c1, r1) <- cRef- (c2, r2) <- cRef- let e' = forkEmit e c1- glue c2 e'- (,) <$> r1 <*> r2---- | test when the deterministic takes too long (which is almost always)-t ::- (MonadIO n, Eq b, Show b, MonadDejaFu n) =>- ConcT n b ->- n Bool-t = dejafuWay (randomly (mkStdGen 42) 1000) defaultMemType "" alwaysSame--main :: IO ()-main = do- let n = 4- sequence_ $- autocheck- <$> [ tToListE n,- tFromListE n,- tToList_ n,- tFromList_' n,- pure (tPureState n),- tPureBoxF (fuse (pure . pure)) n,- tPureBoxF (\(Box c e) -> glue c e) n,- uncurry (<>) <$> (tForkEmit <$.> fromListE [1 .. n])- ]
− app/websocket-tests.hs
@@ -1,213 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# OPTIONS_GHC -Wall #-}-{-# OPTIONS_GHC -Wno-unused-do-bind #-}--{---Models a websocket connection---}--module Main where--import Box-import qualified Control.Concurrent.Classy.Async as C-import Control.Lens hiding (Unwrapped, Wrapped)-import Control.Monad.Catch-import Control.Monad.Conc.Class as C-import Data.Generics.Labels ()-import qualified Network.WebSockets as WS-import NumHask.Prelude hiding (STM, bracket)-import Options.Generic--data ConfigSocket = ConfigSocket- { host :: !Text,- port :: !Int,- path :: !Text- }- deriving (Show, Eq, Generic)--defaultConfigSocket :: ConfigSocket-defaultConfigSocket = ConfigSocket "127.0.0.1" 9160 "/"--client :: (MonadIO m) => ConfigSocket -> WS.ClientApp () -> m ()-client c app = liftIO $ WS.runClient (unpack $ c ^. #host) (c ^. #port) (unpack $ c ^. #path) app--server :: (MonadIO m) => ConfigSocket -> WS.ServerApp -> m ()-server c app = liftIO $ WS.runServer (unpack $ c ^. #host) (c ^. #port) app--con :: (MonadMask m, MonadIO m) => WS.PendingConnection -> Cont m WS.Connection-con p = Cont $ \action ->- bracket- (liftIO $ WS.acceptRequest p)- (\conn -> liftIO $ WS.sendClose conn ("Bye from con!" :: Text))- action--clientApp ::- (MonadIO m, MonadConc m) =>- Box m (Either Text Text) Text ->- WS.Connection ->- m ()-clientApp (Box c e) conn =- void $- C.race- (receiver c conn)- (sender (Box mempty e) conn)--serverApp ::- WS.PendingConnection ->- IO ()-serverApp p =- with- (con p)- ( responder- (\x -> bool (Right $ "echo:" <> x) (Left "quit") (x == "q"))- mempty- )--serverIO :: IO ()-serverIO = server defaultConfigSocket serverApp--clientIO :: IO ()-clientIO =- (client defaultConfigSocket . clientApp)- (Box (contramap show toStdout) fromStdin)--data SocketType = Client | Responder | TestRun deriving (Eq, Read, Show, Generic)--instance ParseField SocketType--instance ParseRecord SocketType--instance ParseFields SocketType--newtype Opts w = Opts- { apptype :: w ::: SocketType <?> "type of websocket app"- }- deriving (Generic)--instance ParseRecord (Opts Wrapped)--main :: IO ()-main = do- o :: Opts Unwrapped <- unwrapRecord "example websocket apps"- r :: Text <- case apptype o of- Client -> show <$> clientIO- Responder -> show <$> q serverIO- TestRun -> show <$> testRun- putStrLn r---- | default websocket receiver--- Lefts are info/debug-receiver ::- (MonadIO m) =>- Committer m (Either Text Text) ->- WS.Connection ->- m Bool-receiver c conn = go- where- go = do- msg <- liftIO $ WS.receive conn- case msg of- WS.ControlMessage (WS.Close w b) ->- commit- c- ( Left- ( "receiver: received: close: " <> show w <> " " <> show b- )- )- WS.ControlMessage _ -> go- WS.DataMessage _ _ _ msg' -> do- commit c $ Left $ "receiver: received: " <> (WS.fromDataMessage msg' :: Text)- _ <- commit c (Right (WS.fromDataMessage msg'))- go---- | default websocket sender-sender ::- (MonadIO m, WS.WebSocketsData a, Show a) =>- Box m Text a ->- WS.Connection ->- m ()-sender (Box c e) conn = forever $ do- msg <- emit e- case msg of- Nothing -> pure ()- Just msg' -> do- commit c $ "sender: sending: " <> (show msg' :: Text)- liftIO $ WS.sendTextData conn msg'---- | a receiver that responds based on received Text.--- lefts are quit signals. Rights are response text.-responder ::- (MonadIO m) =>- (Text -> Either Text Text) ->- Committer m Text ->- WS.Connection ->- m ()-responder f c conn = go- where- go = do- msg <- liftIO $ WS.receive conn- case msg of- WS.ControlMessage (WS.Close _ _) -> do- commit c "responder: normal close"- liftIO $ WS.sendClose conn ("received close signal: responder closed." :: Text)- WS.ControlMessage _ -> go- WS.DataMessage _ _ _ msg' -> do- case f $ WS.fromDataMessage msg' of- Left _ -> do- commit c "responder: sender initiated close"- liftIO $ WS.sendClose conn ("received close signal: responder closed." :: Text)- Right r -> do- commit c ("responder: sending" <> r)- liftIO $ WS.sendTextData conn r- go--q :: IO a -> IO (Either () a)-q = race (cancelQ fromStdin)--cancelQ :: Emitter IO Text -> IO ()-cancelQ e = do- e' <- emit e- case e' of- Just "q" -> pure ()- _other -> do- putStrLn ("nothing happens" :: Text)- cancelQ e---- | test of clientApp via a cRef committer and a canned list of Text-tClient :: [Text] -> IO [Either Text Text]-tClient xs = do- (c, r) <- cRef- client- defaultConfigSocket- ( \conn ->- (`clientApp` conn)- <$.> ( Box c <$> fromListE (xs <> ["q"])- )- )- r--tClientIO :: [Text] -> IO ()-tClientIO xs =- (client defaultConfigSocket . clientApp)- <$.> (Box (contramap show toStdout) <$> fromListE (xs <> ["q"]))---- | main test run of client-server functionality--- the code starts a server in a thread, starts the client in the main thread, and cancels the server on completion.--- > testRun--- [Left "receiver: received: echo:1",Right "echo:1",Left "receiver: received: echo:2",Right "echo:2",Left "receiver: received: echo:3",Right "echo:3",Left "receiver: received: close: 1000 \"received close signal: responder closed.\""]-testRun :: IO [Either Text Text]-testRun = do- a <- async (server defaultConfigSocket serverApp)- r <- tClient (show <$> [1 .. 3 :: Int])- cancel a- pure r
box.cabal view
@@ -1,146 +1,69 @@-cabal-version: 2.4-name: box-version: 0.6.3-synopsis: boxes-description: concurrent, effectful boxes-category: project-homepage: https://github.com/tonyday567/box#readme-bug-reports: https://github.com/tonyday567/box/issues-author: Tony Day-maintainer: tonyday567@gmail.com-copyright: Tony Day (c) 2017-license: BSD-3-Clause-license-file: LICENSE-build-type: Simple-extra-source-files:- stack.yaml+cabal-version: 3.0+name: box+version: 0.9.4.0+license: BSD-3-Clause+license-file: LICENSE+copyright: Tony Day (c) 2017+category: control+author: Tony Day+maintainer: tonyday567@gmail.com+homepage: https://github.com/tonyday567/box#readme+bug-reports: https://github.com/tonyday567/box/issues+synopsis: A profunctor effect system?+description:+ This might be a profunctor effect system, but is unlike all the others, so it's hard to say for sure.++build-type: Simple+tested-with:+ ghc ==9.10.3+ ghc ==9.12.2+ ghc ==9.14.1++extra-doc-files:+ ChangeLog.md readme.md source-repository head type: git location: https://github.com/tonyday567/box +common ghc-options-stanza+ ghc-options:+ -Wall+ -Wcompat+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wredundant-constraints+ library+ import: ghc-options-stanza+ default-language: GHC2024+ hs-source-dirs: src+ build-depends:+ async >=2.2 && <2.3,+ base >=4.7 && <5,+ bytestring >=0.11.3 && <0.13,+ containers >=0.6 && <0.9,+ contravariant >=1.5 && <1.6,+ dlist >=1.0 && <1.1,+ exceptions >=0.10 && <0.11,+ kan-extensions >=5.2 && <5.3,+ mtl >=2.2.2 && <2.4,+ profunctors >=5.6.2 && <5.7,+ semigroupoids >=5.3 && <6.1,+ stm >=2.5.1 && <2.6,+ text >=1.2 && <2.2,+ time >=1.10 && <1.15,+ exposed-modules: Box Box.Box+ Box.Codensity Box.Committer Box.Connectors- Box.Cont Box.Emitter+ Box.Functor Box.IO Box.Queue Box.Time- hs-source-dirs:- src- default-extensions:- ghc-options:- -Wall- -Wcompat- -Wincomplete-record-updates- -Wincomplete-uni-patterns- -Wredundant-constraints- -funbox-strict-fields- -fwrite-ide-info- -hiedir=.hie- build-depends:- attoparsec >= 0.13,- base >=4.7 && <5,- comonad >= 5.0,- concurrency >= 1.11,- containers >= 0.6 && < 0.7,- contravariant >= 1.5,- exceptions >= 0.10,- lens >= 4.19,- mmorph >= 1.1,- numhask >= 0.7 && < 0.8,- numhask-space >= 0.7 && < 0.8,- profunctors >= 5.5,- text >= 1.2,- time >= 1.9,- transformers >= 0.5,- transformers-base >= 0.4,- default-language: Haskell2010 -executable concurrency-tests- main-is: concurrency-tests.hs- hs-source-dirs:- app- build-depends:- base >=4.7 && <5,- box,- concurrency >= 1.11,- containers >= 0.6 && < 0.7,- dejafu >= 2.3,- generic-lens >= 2.0,- lens >= 4.19,- numhask >= 0.7 && < 0.8,- random >= 1.1,- text >= 1.2,- transformers >= 0.5- default-language: Haskell2010- default-extensions:- ghc-options:- -Wall- -Wcompat- -Wincomplete-record-updates- -Wincomplete-uni-patterns- -Wredundant-constraints- -funbox-strict-fields- -fforce-recomp- -threaded- -rtsopts- -with-rtsopts=-N- -fwrite-ide-info- -hiedir=.hie-executable websocket-tests- main-is: websocket-tests.hs- hs-source-dirs:- app- ghc-options: -funbox-strict-fields -fforce-recomp -threaded -rtsopts -with-rtsopts=-N- build-depends:- base >=4.7 && <5,- box,- concurrency >= 1.11,- dejafu >= 2.3,- exceptions >= 0.10,- generic-lens >= 2.0,- lens >= 4.19,- mtl >= 2.2,- numhask >= 0.7 && < 0.8,- optparse-generic >= 1.3.0 && < 1.4,- text >= 1.2,- transformers >= 0.5,- websockets >= 0.12- default-language: Haskell2010- default-extensions:- ghc-options:- -Wall- -Wcompat- -Wincomplete-record-updates- -Wincomplete-uni-patterns- -Wredundant-constraints- -funbox-strict-fields- -fwrite-ide-info- -hiedir=.hie--test-suite test- type: exitcode-stdio-1.0- main-is: test.hs- hs-source-dirs:- test- build-depends:- base >=4.7 && <5,- box,- doctest >= 0.16,- numhask >= 0.7 && < 0.8,- default-language: Haskell2010- default-extensions:- ghc-options:- -Wall- -Wcompat- -Wincomplete-record-updates- -Wincomplete-uni-patterns- -Wredundant-constraints- -fwrite-ide-info- -hiedir=.hie
readme.md view
@@ -1,54 +1,300 @@-[box](https://tonyday567.github.io/box/index.html) [](https://travis-ci.org/tonyday567/box)-===+[](https://hackage.haskell.org/package/box) [](https://github.com/tonyday567/box/actions/workflows/haskell-ci.yml) -> The box is dark and full of terrors.+A profunctor effect system. -Take two ubiquitous concepts. There are things that emit stuff. They instantiate a particular thing on demand, somehow and somewhere beyond our concern and viewbox. We ask an Emitter for an `a` and an `a` is there, or not (best to assume a `Maybe a`). The library calls this an Emitter:+> What is all this stuff around me; this stream of experiences that I seem to be having all the time? Throughout history there have been people who say it is all illusion. ~ S Blackmore -```-newtype Emitter m a = Emitter { emit :: m (Maybe a)}-```-It emits over a type constructor, m, and this is often monadic in nature, and often IO. -Then there is the opposite. There are things that commit stuff. We offer a Committer a particular thing and they take it away beyond our concerns. It is committed to the void. We offer an `a` and it is reported back whether the committment was succesful.The library calls this a Committer:+# Usage -```-newtype Committer m a = Committer { commit :: a -> m Bool}-```+ :set -XOverloadedStrings+ import Box+ import Prelude+ import Data.Function+ import Data.Bool -These two types are duals, across a wide spectrum of what that means. If you do something with a committer, like write to a socket, you can often immediately write an emitter the dual of this, like read from a socket.+Standard IO echoing: -When you have both things, something that emits and something that commits, over the same carrier, you have a Box:+ echoC = Committer (\s -> putStrLn ("echo: " <> s) >> pure True)+ echoE = Emitter (getLine & fmap (\x -> bool (Just x) Nothing (x =="quit")))+ glue echoC echoE -```-data Box m c e = Box- { committer :: Committer m c- , emitter :: Emitter m e- }-```+ hello+ echo: hello+ echo+ echo: echo+ quit -A Box tends to flip polarity, like a Möbius strip. and sometimes like a Dali.+Committing to a list: -You can see a committer as a wire into the box, and an emitter as a wire out of the box. You can then think of the box as opaque, and make the tasks on the outside of the box that much easier, removing concern about what is going on inside the box. But then coding tends to get you inside the box, and point-of-view shifts. From inside the box, stuff,, a's,, are coming from what we had thought of as the committer. It is emitting from our new viewbox, and vice versa. You are the black box, and your box matters. + > toListM echoE+ hello+ echo+ quit+ ["hello","echo"] -Note how you can get confused with these metaphors. The wire going into the box is a committer from a point of view outside the metaphorical box but looks like an emitter from the inside. The wire going out is a committer from the inside and an emitter from the outside.+Emitting from a list: -The key to understanding this library is to resist having to choose a single frame of reference and, instead, focus on the types.+ > glue echoC <$|> witherE (\x -> bool (pure (Just x)) (pure Nothing) (x=="quit")) <$> (qList ["hello", "echo", "quit"])+ echo: hello+ echo: echo -A `Box m c e` unifies the functorial wrapper `m` of the emitter and committer, which is what really makes it a functional box. Boxes can often be hooked together at this level for useful efficiencies. -A Box is also a [profunctor](https://bartoszmilewski.com/2019/03/27/promonads-arrows-and-einstein-notation-for-profunctors/) and, to quote Bartos, a profunctor can be used to glue together two categories.+# Library Design -Like other paradigms, boxes can be not fun places to get stuck in. Much of the library are not, in fact, emitters and committers but emitter, committer and box continuations. If you gave me something that takes a box and does something, then I'll give you a something is a natural piece of logic within the library context, and so large parts of the functionality are [continuation-parsing style](https://ro-che.info/articles/2019-06-07-why-use-contt). -Finally, the interface between boxes is a natural place to create concurrency, and Box.Queue provides queues that are guaranteed to not race or block.+### Resource Coinduction -> “Do not define me by my gender or my socio-economic status, Noah Willis. Do not tell me who I am and do not tell me who society thinks I am and then put me in that box and expect me to stay there. Because, I swear to God, I will climb the hell out of that box and I will take that box you've just put me in and I will use that box to smash your face in until you're nothing more than a freckly, bloodied pulp. You got that, sweet cheeks?” ~ Megan Jacobson, Yellow+Haskell has an affinity with [coinductive functions](https://www.reddit.com/r/haskell/comments/j3kbge/comment/g7foelq/?utm_source=share&utm_medium=web2x&context=3); functions should expose destructors and allow for infinite data. +The key text, [Why Functional Programming Matters](https://www.cs.kent.ac.uk/people/staff/dat/miranda/whyfp90.pdf), details how producers and consumers can be separated by exploiting laziness, creating a speration of concern not available in other technologies. Utilising laziness, we can peel off (destruct) the next element of a list to be consumed without disturbing the pipeline of computations that is still to occur, for the cost of a thunk. -recipe----+So how do you apply this to resources and their effects? One answer is that you destruct a (potentially long-lived) resource simply by using it. For example, reading and writing lines to standard IO: -```-stack exec --test concurrency-tests --file-watch-```+ :t getLine+ :t putStrLn++ getLine :: IO String+ putStrLn :: String -> IO ()++These are the destructors that need to be transparently exposed if effects are to be good citizens in Haskell.+++### What is a Box?++A Box is simply the product of a consumer destructor and a producer destructor.++ data Box m c e = Box+ { committer :: Committer m c,+ emitter :: Emitter m e+ }+++### Committer++The library denotes a consumer by wrapping a consumption destructor and calling it a Committer. Like much of base, there is failure hidden in the getLine example type. A better approach, for a consumer, is to signal whether consumption actually occurred.++ newtype Committer m a = Committer+ { commit :: a -> m Bool+ }++You give a Committer an ’a’, and the destructor tells you whether the consumption of the ’a’ was successful or not. A standard output committer is then:++ stdC :: Committer IO String+ stdC = Committer (\s -> putStrLn s >> pure True)++ <interactive>:19:1-4: warning: [GHC-63397] [-Wname-shadowing]+ This binding for ‘stdC’ shadows the existing binding+ defined at <interactive>:16:1++A Committer is a contravariant functor, so contramap can be used to modify this:++ import Data.Text as Text+ import Data.Functor.Contravariant+ + echoC :: Committer IO Text+ echoC = contramap (Text.unpack . ("echo: "<>)) stdC+++### Emitter++The library denotes a producer by wrapping a production destructor and calling it an Emitter.++ newtype Emitter m a = Emitter+ { emit :: m (Maybe a)+ }++An emitter returns an ’a’ on demand or not.++ stdE :: Emitter IO String+ stdE = Emitter (Just <$> getLine)++As a functor instance, an Emitter can be modified with fmap. Several library functions, such as witherE and filterE can also be used to stop emits or add effects.++ echoE :: Emitter IO Text+ echoE =+ witherE (\x -> bool (pure (Just x)) (putStrLn "quitting" *> pure Nothing) (x == "quit"))+ (fmap Text.pack stdE)++ <interactive>:52:1-5: warning: [GHC-63397] [-Wname-shadowing]+ This binding for ‘echoE’ shadows the existing binding+ defined at <interactive>:49:1+++### Box duality++A Box represents a duality in two ways:++- As the consumer and producer sides of a resource. The complete interface to standard IO, for example, could be:++ stdIO :: Box IO String String+ stdIO = Box (Committer (\s -> putStrLn s >> pure True)) (Emitter (Just <$> getLine))++- As two ends of a computation.++> This is how we can use a profunctor to glue together two categories ~ Milewski+> [Promonads, Arrows, and Einstein Notation for Profunctors](https://bartoszmilewski.com/2019/03/27/promonads-arrows-and-einstein-notation-for-profunctors/)++`glue` is the primitive with which we connect a Committer and Emitter.++ > glue echoC echoE+ hello+ echo: hello+ echo+ echo: echo+ quit+ quitting++Effectively the same computation, for a Box, is:++ fuse (pure . pure) stdIO+++### Continuation++As with many operators in the library, `qList` is actually a continuation:++ :t qList++ qList+ :: Control.Monad.Conc.Class.MonadConc m => [a] -> CoEmitter m a++ type CoEmitter m a = Codensity m (Emitter m a)++Effectively being a newtype wrapper around:++ forall x. (Emitter m a -> m x) -> m x++A good background on call-back style programming in Haskell is in the [managed](https://hackage.haskell.org/package/managed-1.0.10/docs/Control-Monad-Managed.html) library, which is a specialised version of Codensity.++Codensity has an Applicative instance, and lends itself to applicative-style coding. To send a (queued) list to stdout, for example, you could say:++ :t glue <$> pure toStdout <*> qList ["a", "b", "c"]++ glue <$> pure toStdout <*> qList ["a", "b", "c"]+ :: Codensity IO (IO ())++and then escape the continuation with:++ runCodensity (glue <$> pure toStdout <*> (qList ["a", "b", "c"])) id++ a+ b+ c++This closes the continuation. The following code is equivalent:++ close $ glue <$> pure toStdout <*> qList ["a", "b", "c"]++ a+ b+ c++ close $ glue toStdout <$> qList ["a", "b", "c"]++ a+ b+ c++Given the ubiquity of this method, the library supplies two applicative style operators that combine application and closure.++- `(<$|>)` fmap and close over a Codensity:++ glue toStdout <$|> qList ["a", "b", "c"]++ a+ b+ c++- `(<*|>)` Apply and close over Codensity++ glue <$> pure toStdout <*|> qList ["a", "b", "c"]++ a+ b+ c+++# Explicit Continuation++Yield-style streaming libraries are [coroutines](https://rubenpieters.github.io/assets/papers/JFP20-pipes.pdf), sum types that embed and mix continuation logic in with other stuff like effect decontruction. `box` sticks to a corner case of a product type representing a consumer and producer. The major drawback of eschewing coroutines is that continuations become explicit and difficult to hide. One example; taking the first n elements of an Emitter:++ :t takeE+ takeE :: Monad m => Int -> Emitter m a -> Emitter (StateT Int m) a++A disappointing type. The state monad can not be hidden, the running count has to sit somewhere, and so different glueing functions are needed:++ -- | Connect a Stateful emitter to a (non-stateful) committer of the same type, supplying initial state.+ --+ -- >>> glueES 0 (showStdout) <$|> (takeE 2 <$> qList [1..3])+ -- 1+ -- 2+ glueES :: (Monad m) => s -> Committer m a -> Emitter (StateT s m) a -> m ()+ glueES s c e = flip evalStateT s $ glue (foist lift c) e+++# Future directions++The design and concepts contained within the box library is a hodge-podge, but an interesting mess, being at quite a busy confluence of recent developments.+++## Optics++A Box is an adapter in the [language of optics](http://www.cs.ox.ac.uk/people/jeremy.gibbons/publications/poptics.pdf) and the relationship between a resource’s committer and emitter could be modelled by other optics.+++## Categorical Profunctor++The deprecation of Box.Functor awaits the development of [categorical functors](https://github.com/haskell/core-libraries-committee/issues/91#issuecomment-1325337471). Similarly to Filterable the type of a Box could be something like `FunctorOf Op(Kleisli Maybe) (Kleisli Maybe) (->)`. Or it could be something like the SISO type in [Programming with Monoidal Profunctors and Semiarrows](https://papers.ssrn.com/sol3/papers.cfm?abstract_id=4496714).+++## Wider Types++Alternatively, the types could be widened:++ newtype Committer f a = Committer { commit :: a -> f () }+ + instance Contravariant (Committer f) where+ contramap f (Committer a) = Committer (a . f)+ + newtype Emitter f a = Emitter { emit :: f a }+ + instance (Functor f) => Functor (Emitter f) where+ fmap f (Emitter a) = Emitter (fmap f a)+ + data Box f g b a =+ Box { committer :: Committer g b, emitter :: Emitter f a }+ + instance (Functor f) => Functor (Box f g b) where+ fmap f (Box c e) = Box c (fmap f e)+ + instance (Functor f, Contravariant g) => Profunctor (Box f g) where+ dimap f g (Box c e) = Box (contramap f c) (fmap g e)++.. with the existing computations recovered with:++ type CommitterB m a = Committer (MaybeT m) a+ type EmitterB m a = Emitter (MaybeT m) a+ type BoxB m b a = Box (MaybeT m) (MaybeT m) b a+++## Introduce a [nucleus](https://golem.ph.utexas.edu/category/2013/08/the_nucleus_of_a_profunctor_so.html)++Alternative to both of these, the Monad constraint could be rethought. There are the ends of the computational pipeline, but there is also the gluing/fusion/middle bit.++ connect :: (f a -> b) -> Committer g b -> Emitter f a -> g ()+ connect w c e = emit e & w & commit c+ + glue :: Box f g (f a) a -> g ()+ glue (Box c e) = connect id c e+ + nucleate ::+ Functor f =>+ (f a -> f b) ->+ Committer g b ->+ Emitter f a ->+ f (g ())+ nucleate n c e = emit e & n & fmap (commit c)++This has the nice property that the closure is not hidden (as is usually the case for a Monad constraint) so that, for instance, fusion along longer chains becomes possible.+
src/Box.hs view
@@ -1,31 +1,14 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RebindableSyntax #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StrictData #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -Wall #-}---- | Effectful, profunctor boxes designed for concurrency.------ This library follows the ideas and code from [pipes-concurrency](https://hackage.haskell.org/package/pipes-concurrency) and [mvc](https://hackage.haskell.org/package/mvc) but with some polymorphic tweaks and definitively more pretentious names.+-- | A profunctor effect system ----- “Boxes are surprisingly bulky. Discard or recycle the box your cell phone comes in as soon as you unpack it. You don’t need the manual or the CD that comes with it either. You’ll figure out the applications you need through using it.” — Marie Kondo+-- “Boxes are surprisingly bulky. Discard or recycle the box your cell phone comes in as soon as you unpack it. You don’t need the manual or the CD that comes with it either. You’ll figure out the applications you need through using it.” ~ Marie Kondo module Box- ( -- $setup- -- $continuations- -- $boxes- -- $commit- -- $emit- -- $state- -- $finite- module Box.Box,+ ( -- $usage module Box.Committer,- module Box.Connectors,- module Box.Cont, module Box.Emitter,+ module Box.Box,+ module Box.Codensity,+ module Box.Connectors,+ module Box.Functor, module Box.IO, module Box.Queue, module Box.Time,@@ -33,199 +16,35 @@ where import Box.Box+import Box.Codensity import Box.Committer import Box.Connectors-import Box.Cont import Box.Emitter+import Box.Functor import Box.IO import Box.Queue import Box.Time -- $setup -- >>> :set -XOverloadedStrings--- >>> :set -XGADTs--- >>> :set -XNoImplicitPrelude--- >>> :set -XFlexibleContexts--- >>> import NumHask.Prelude--- >>> import qualified Prelude as P--- >>> import Data.Functor.Contravariant+-- >>> import Prelude -- >>> import Box--- >>> import Control.Monad.Conc.Class as C--- >>> import Control.Lens--- >>> import qualified Data.Sequence as Seq---- $continuations------ Continuations are very common in the API with 'Cont' as an inhouse type.------ >>> :t fromListE [1..3::Int]--- fromListE [1..3::Int] :: MonadConc m => Cont m (Emitter m Int)------ The applicative is usually the easiest way to think about and combine continuations with their unadorned counterparts.------ >>> let box' = Box <$> pure toStdout <*> fromListE ["a", "b" :: Text]--- >>> :t box'--- box' :: Cont IO (Box IO Text Text)---- $boxes------ The two basic ways of connecting up a box are related as follows:------ > glue c e == glueb (Box c e)--- > glueb == fuse (pure . pure)------ >>> fromToList_ [1..3] glueb--- [1,2,3]------ >>> fromToList_ [1..3] (fuse (pure . pure))+-- >>> pushList <$|> qList [1,2,3] -- [1,2,3] ----- 1. glue: direct fusion of committer and emitter------ >>> runCont $ glue <$> pure toStdout <*> fromListE (show <$> [1..3])--- 1--- 2--- 3------ Variations to the above code include:------ Use of continuation applicative operators:------ - the '(<*.>)' operator is short hand for runCont $ xyz 'Control.Applicative.(<*>)' zy.------ - the '(<$.>)' operator is short hand for runCont $ xyz 'Control.Applicative.(<$>)' zy.------ > glue <$> pure toStdout <*.> fromListE (show <$> [1..3])--- > glue toStdout <$.> fromListE (show <$> [1..3])------ Changing the type in the Emitter (The double fmap is cutting through the Cont and Emitter layers):------ > glue toStdout <$.> fmap (fmap show) (fromListE [1..3])------ Changing the type in the committer (which is Contrvariant so needs to be a contramap):------ > glue (contramap show toStdout) <$.> fromListE [1..3]------ Using the box version of glue:------ > glueb <$.> (Box <$> pure toStdout <*> (fmap show <$> fromListE [1..3]))------ 2. fusion of a box, with an (a -> m (Maybe b)) function to allow for mapping, filtering and simple effects.------ >>> let box' = Box <$> pure toStdout <*> fromListE (show <$> [1..3])--- >>> fuse (\a -> bool (pure $ Just $ "echo: " <> a) (pure Nothing) (a==("2"::Text))) <$.> box'--- echo: 1--- echo: 3---- $commit------ >>> commit toStdout "I'm committed!"--- I'm committed!--- True------ Use mapC to modify a Committer and introduce effects.------ >>> let c = mapC (\a -> if a==2 then (sleep 0.1 >> putStrLn "stole a 2!" >> sleep 0.1 >> pure (Nothing)) else (pure (Just a))) (contramap (show :: Int -> Text) toStdout)--- >>> glueb <$.> (Box <$> pure c <*> fromListE [1..3])--- 1--- stole a 2!--- 3------ The monoid instance of Committer sends each commit to both mappended committers. Because effects are also mappended together, the committed result is not always what is expected.------ >>> let cFast = mapC (\b -> pure (Just b)) . contramap ("fast: " <>) $ toStdout--- >>> let cSlow = mapC (\b -> sleep 0.1 >> pure (Just b)) . contramap ("slow: " <>) $ toStdout--- >>> (glueb <$.> (Box <$> pure (cFast <> cSlow) <*> fromListE (show <$> [1..3]))) <* sleep 1--- fast: 1--- slow: 1--- fast: 2--- slow: 2--- fast: 3--- slow: 3------ To approximate what is intuitively expected, use 'concurrentC'.------ >>> runCont $ (fromList_ (show <$> [1..3]) <$> (concurrentC cFast cSlow)) <> pure (sleep 1)--- fast: 1--- fast: 2--- fast: 3--- slow: 1--- slow: 2--- slow: 3------ This is all non-deterministic, hence the necessity for messy delays and heuristic avoidance of console races.+-- >>> glue toStdout <$|> qList ["a", "b", "c"]+-- a+-- b+-- c --- $emit------ >>> ("I'm emitted!" :: Text) & Just & pure & Emitter & emit >>= print--- Just "I'm emitted!"------ >>> with (fromListE [1]) (\e' -> (emit e' & fmap show :: IO Text) >>= putStrLn & replicate 3 & sequence_)--- Just 1--- Nothing--- Nothing------ >>> toListE <$.> (fromListE [1..3])+-- $usage+-- >>> :set -XOverloadedStrings+-- >>> import Box+-- >>> import Prelude+-- >>> pushList <$|> qList [1,2,3] -- [1,2,3] ----- The monoid instance is left-biased.------ >>> toListE <$.> (fromListE [1..3] <> fromListE [7..9])--- [1,2,3,7,8,9]------ Use concurrentE to get some nondeterministic balance.------ > let es = (join $ concurrentE <$> (fromListE [1..3]) <*> (fromListE [7..9]))--- > glue (contramap show toStdout) <$.> es--- 1--- 2--- 7--- 3--- 8--- 9---- $state------ State committers and emitters are related as follows:------ >>> toList . fst $ runIdentity $ flip execStateT (Seq.empty,Seq.fromList [1..4]) $ glue (hoist (zoom _1) stateC) (hoist (zoom _2) stateE)--- [1,2,3,4]------ For some reason, related to a lack of an MFunctor instance for Cont, but exactly not yet categorically pinned to a wall, the following compiles but is wrong.------ >>> flip runStateT (Seq.empty) $ runCont $ glue <$> pure stateC <*> fromListE [1..4]--- ((),fromList [])---- $finite------ Most committers and emitters will run forever until:------ - the glued or fused other-side returns.--- - the Transducer, stream or monadic action returns.------ Finite ends (collective noun for emitters and committers) can be created with 'sink' and 'source' eg------ >>> glue <$> contramap (show :: Int -> Text) <$> (sink 5 putStrLn) <*.> fromListE [1..]--- 1--- 2--- 3--- 4--- 5------ Two infinite ends will tend to run infinitely.------ > glue <$> pure (contramap show toStdout) <*.> fromListE [1..]------ 1--- 2--- ...--- 💁--- ∞------ Use glueN to create a finite computation.------ >>> glueN 4 <$> pure (contramap show toStdout) <*.> fromListE [1..]--- 1--- 2--- 3--- 4+-- >>> glue toStdout <$|> qList ["a", "b", "c"]+-- a+-- b+-- c
src/Box/Box.hs view
@@ -1,48 +1,74 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RebindableSyntax #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StrictData #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -Wall #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-}---- | A box is something that commits and emits+-- | A box is a product of a consumer and producer destructor.+--+-- Consumers and producers (committers and emitters) are paired in two ways:+--+-- - As two ends of a resource such as a file, or screen or queue; input to and output from.+--+-- - As the start and end of a computation pipeline. module Box.Box ( Box (..),+ CoBox,+ CoBoxM (..), bmap,- hoistb,+ foistb, glue,- glue_,- glueb,+ Closure (..),+ glue',+ glueN,+ glueES,+ glueS, fuse,- dotb, Divap (..), DecAlt (..),+ cobox,+ seqBox, ) where +import Box.Codensity import Box.Committer import Box.Emitter-import Data.Functor.Contravariant+import Box.Functor+import Control.Applicative+ ( Alternative (empty, (<|>)),+ Applicative (liftA2),+ )+import Control.Monad+import Control.Monad.State.Lazy+import Data.Bool+import Data.Function+import Data.Functor.Contravariant (Contravariant (contramap)) import Data.Functor.Contravariant.Divisible-import Data.Profunctor-import NumHask.Prelude+ ( Decidable (choose, lose),+ Divisible (conquer, divide),+ )+import Data.Profunctor (Profunctor (dimap))+import Data.Semigroupoid+import Data.Sequence qualified as Seq+import Data.Void (Void, absurd)+import Prelude hiding (id, liftA2, (.)) --- | A Box is a product of a Committer m and an Emitter. Think of a box with an incoming wire and an outgoing wire. Now notice that the abstraction is reversable: are you looking at two wires from "inside a box"; a blind erlang grunt communicating with the outside world via the two thin wires, or are you looking from "outside the box"; interacting with a black box object. Either way, it's a box.--- And either way, the committer is contravariant and the emitter covariant so it forms a profunctor.+-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Prelude+-- >>> import Box+-- >>> import Data.Text (pack)+-- >>> import Data.Bool+-- >>> import Control.Monad.State.Lazy++-- | A Box is a product of a 'Committer' and an 'Emitter'. ----- a Box can also be seen as having an input tape and output tape, thus available for turing and finite-state machine metaphorics.+-- Think of a box with an incoming arrow an outgoing arrow. And then make your pov ambiguous: are you looking at two wires from "inside a box"; or are you looking from "outside the box"; interacting with a black box object. Either way, it looks the same: it's a box.+--+-- And either way, one of the arrows, the 'Committer', is contravariant and the other, the 'Emitter' is covariant. The combination is a profunctor. data Box m c e = Box { committer :: Committer m c, emitter :: Emitter m e } --- | Wrong signature for the MFunctor class-hoistb :: Monad m => (forall a. m a -> n a) -> Box m c e -> Box n c e-hoistb nat (Box c e) = Box (hoist nat c) (hoist nat e)+-- | Wrong kind signature for the FFunctor class+foistb :: (forall a. m a -> n a) -> Box m c e -> Box n c e+foistb nat (Box c e) = Box (foist nat c) (foist nat e) instance (Functor m) => Profunctor (Box m) where dimap f g (Box c e) = Box (contramap f c) (fmap g e)@@ -54,56 +80,79 @@ mempty = Box mempty mempty mappend = (<>) --- | a profunctor dimapMaybe+-- | A profunctor dimapMaybe bmap :: (Monad m) => (a' -> m (Maybe a)) -> (b -> m (Maybe b')) -> Box m a b -> Box m a' b'-bmap fc fe (Box c e) = Box (mapC fc c) (mapE fe e)--{--instance Category (Box Identity) where- id = Box ??? ???- (.) (Box c e) (Box c' e') = runIdentity $ glue c e' >> pure (Box c' e)--}---- | composition of monadic boxes-dotb :: (Monad m) => Box m a b -> Box m b c -> m (Box m a c)-dotb (Box c e) (Box c' e') = glue c' e $> Box c e'+bmap fc fe (Box c e) = Box (witherC fc c) (witherE fe e) -- | Connect an emitter directly to a committer of the same type. ----- The monadic action returns when the committer finishes.+-- >>> glue showStdout <$|> qList [1..3]+-- 1+-- 2+-- 3 glue :: (Monad m) => Committer m a -> Emitter m a -> m ()-glue c e = go- where- go = do- a <- emit e- c' <- maybe (pure False) (commit c) a- when c' go+glue c e = fix $ \rec -> emit e >>= maybe (pure False) (commit c) >>= bool (pure ()) rec --- | Connect an emitter directly to a committer of the same type.+-- | Whether the committer or emitter closed the computation.+data Closure = CommitterClosed | EmitterClosed deriving (Eq, Show, Ord)++-- | Connect an emitter directly to a committer of the same type, returning whether the emitter or committer caused eventual closure. ----- The monadic action returns if the committer returns False.-glue_ :: (Monad m) => Committer m a -> Emitter m a -> m ()-glue_ c e = go- where- go = do- a <- emit e- case a of- Nothing -> go- Just a' -> do- b <- commit c a'- if b then go else pure ()+-- >>> glue' showStdout <$|> qList [1..3]+-- 1+-- 2+-- 3+-- EmitterClosed+glue' :: (Monad m) => Committer m a -> Emitter m a -> m Closure+glue' c e =+ fix $ \rec ->+ emit e+ >>= maybe+ (pure EmitterClosed)+ (commit c >=> bool (pure CommitterClosed) rec) --- | Short-circuit a homophonuos box.-glueb :: (Monad m) => Box m a a -> m ()-glueb (Box c e) = glue c e+-- | Connect a Stateful emitter to a (non-stateful) committer of the same type, supplying initial state.+--+-- >>> glueES 0 (showStdout) <$|> (takeE 2 <$> qList [1..3])+-- 1+-- 2+glueES :: (Monad m) => s -> Committer m a -> Emitter (StateT s m) a -> m ()+glueES s c e = flip evalStateT s $ glue (foist lift c) e --- | fuse a box+-- | Connect a Stateful emitter to a (similarly-stateful) committer of the same type, supplying initial state. ----- > fuse (pure . pure) == glueb+-- >>> glueS 0 (foist lift showStdout) <$|> (takeE 2 <$> qList [1..3])+-- 1+-- 2+glueS :: (Monad m) => s -> Committer (StateT s m) a -> Emitter (StateT s m) a -> m ()+glueS s c e = flip evalStateT s $ glue c e++-- | Glues a committer and emitter, and takes n emits+--+-- >>> glueN 3 <$> pure showStdout <*|> qList [1..]+-- 1+-- 2+-- 3+--+-- Note that glueN counts the number of events passing across the connection and doesn't take into account post-transmission activity in the Committer, eg+--+-- >>> glueN 4 (witherC (\x -> bool (pure Nothing) (pure (Just x)) (even x)) showStdout) <$|> qList [0..9]+-- 0+-- 2+glueN :: (Monad m) => Int -> Committer m a -> Emitter m a -> m ()+glueN n c e = flip evalStateT 0 $ glue (foist lift c) (takeE n e)++-- | Glue a Committer to an Emitter within a box.+--+-- > fuse (pure . pure) == \(Box c e) -> glue c e+--+-- A command-line echoer+--+-- > fuse (pure . Just . ("echo " <>)) (Box toStdout fromStdin) fuse :: (Monad m) => (a -> m (Maybe b)) -> Box m b a -> m ()-fuse f (Box c e) = glue c (mapE f e)+fuse f (Box c e) = glue c (witherE f e) --- | combines 'divide'/'conquer' and 'liftA2'/'pure'+-- | combines 'divide' 'conquer' and 'liftA2' 'pure' class Divap p where divap :: (a -> (b, c)) -> ((d, e) -> f) -> p b d -> p c e -> p a f conpur :: a -> p b a@@ -115,7 +164,7 @@ conpur a = Box conquer (pure a) -- | combines 'Decidable' and 'Alternative'-class Profunctor p => DecAlt p where+class (Profunctor p) => DecAlt p where choice :: (a -> Either b c) -> (Either d e -> f) -> p b d -> p c e -> p a f loss :: p Void b @@ -123,3 +172,36 @@ choice split' merge (Box lc le) (Box rc re) = Box (choose split' lc rc) (fmap merge $ fmap Left le <|> fmap Right re) loss = Box (lose absurd) empty++-- | A box continuation+type CoBox m a b = Codensity m (Box m a b)++-- | Construct a CoBox+--+--+-- > cobox = Box <$> c <*> e+--+-- >>> fuse (pure . Just . ("show: " <>) . pack . show) <$|> (cobox (pure toStdout) (qList [1..3]))+-- show: 1+-- show: 2+-- show: 3+cobox :: CoCommitter m a -> CoEmitter m b -> CoBox m a b+cobox c e = Box <$> c <*> e++-- | State monad queue.+seqBox :: (Monad m) => Box (StateT (Seq.Seq a) m) a a+seqBox = Box push pop++-- | cps composition of monadic boxes+dotco :: (Monad m) => Codensity m (Box m a b) -> Codensity m (Box m b c) -> Codensity m (Box m a c)+dotco b b' = lift $ do+ (Box c e) <- lowerCodensity b+ (Box c' e') <- lowerCodensity b'+ glue c' e+ pure (Box c e')++-- | Wrapper for the semigroupoid instance of a box continuation.+newtype CoBoxM m a b = CoBoxM {uncobox :: Codensity m (Box m a b)}++instance (Monad m) => Semigroupoid (CoBoxM m) where+ o (CoBoxM b) (CoBoxM b') = CoBoxM (dotco b' b)
+ src/Box/Codensity.hs view
@@ -0,0 +1,69 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Extra Codensity operators.+module Box.Codensity+ ( close,+ process,+ (<$|>),+ (<*|>),+ module Control.Monad.Codensity,+ )+where++import Control.Applicative+import Control.Monad.Codensity+import Prelude++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Prelude+-- >>> import Box+-- >>> import Data.Bool++instance (Semigroup a) => Semigroup (Codensity m a) where+ (<>) = liftA2 (<>)++instance (Functor m, Monoid a) => Monoid (Codensity m a) where+ mempty = pure mempty++ mappend = (<>)++-- | close the Codensity continuation.+--+-- >>> close $ glue showStdout <$> qList [1..3]+-- 1+-- 2+-- 3+close :: Codensity m (m r) -> m r+close x = runCodensity x id++-- | fmap then close a continuation.+--+-- >>> process (glue showStdout) (qList [1..3])+-- 1+-- 2+-- 3+process :: forall a m r. (a -> m r) -> Codensity m a -> m r+process f k = runCodensity k f++infixr 0 <$|>++-- | fmap then close a continuation.+--+-- >>> glue showStdout <$|> qList [1..3]+-- 1+-- 2+-- 3+(<$|>) :: forall a m r. (a -> m r) -> Codensity m a -> m r+(<$|>) = process++infixr 3 <*|>++-- | apply and then close a continuation.+--+-- >>> glue <$> (pure showStdout) <*|> qList [1..3]+-- 1+-- 2+-- 3+(<*|>) :: Codensity m (a -> m r) -> Codensity m a -> m r+(<*|>) f a = close (f <*> a)
src/Box/Committer.hs view
@@ -1,40 +1,45 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RebindableSyntax #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -Wall #-}---- | `commit`+-- | 'Committer' wraps a consumer destructor.+--+-- "Commitment is an act, not a word." ~ Jean-Paul Sartre module Box.Committer ( Committer (..),- drain,- mapC,- premapC,- postmapC,- stateC,+ CoCommitter,+ witherC, listC,+ push, ) where +import Box.Codensity (Codensity)+import Box.Functor+import Control.Monad.State.Lazy import Data.Functor.Contravariant import Data.Functor.Contravariant.Divisible-import qualified Data.Sequence as Seq-import NumHask.Prelude+import Data.Sequence qualified as Seq+import Data.Void+import Prelude --- | a Committer a "commits" values of type a. A Sink and a Consumer are some other metaphors for this.+-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Prelude+-- >>> import Box+-- >>> import Data.Bool++-- | A Committer 'commit's values of type a and signals success or otherwise. A sink or a consumer are some other metaphors for this. A Committer absorbs the value being committed; the value disappears into the opaque thing that is a Committer from the pov of usage. ----- A Committer absorbs the value being committed; the value disappears into the opaque thing that is a Committer from the pov of usage.+-- >>> commit toStdout "I'm committed!"+-- I'm committed!+-- True newtype Committer m a = Committer { commit :: a -> m Bool } -instance MFunctor Committer where- hoist nat (Committer c) = Committer $ nat . c+-- | 'Committer' continuation.+type CoCommitter m a = Codensity m (Committer m a) +instance FFunctor Committer where+ foist nat (Committer c) = Committer $ nat . c+ instance (Applicative m) => Semigroup (Committer m a) where (<>) i1 i2 = Committer (\a -> (||) <$> commit i1 a <*> commit i2 a) @@ -63,15 +68,14 @@ Left b -> commit i1 b Right c -> commit i2 c --- | Do nothing with values that are committed.+-- | A monadic [Witherable](https://hackage.haskell.org/package/witherable) ----- This is useful for keeping the commit end of a box or pipeline open.-drain :: (Applicative m) => Committer m a-drain = Committer (\_ -> pure True)---- | This is a contramapMaybe, if such a thing existed, as the contravariant version of a mapMaybe. See [witherable](https://hackage.haskell.org/package/witherable)-mapC :: (Monad m) => (b -> m (Maybe a)) -> Committer m a -> Committer m b-mapC f c = Committer go+-- >>> glue (witherC (\x -> pure $ bool Nothing (Just x) (even x)) showStdout) <$|> qList [0..5]+-- 0+-- 2+-- 4+witherC :: (Monad m) => (b -> m (Maybe a)) -> Committer m a -> Committer m b+witherC f c = Committer go where go b = do fb <- f b@@ -79,34 +83,25 @@ Nothing -> pure True Just fb' -> commit c fb' --- | adds a monadic action to the committer-premapC ::- (Applicative m) =>- (Committer m a -> m ()) ->- Committer m a ->- Committer m a-premapC f c = Committer $ \a -> f c *> commit c a---- | adds a post-commit monadic action to the committer-postmapC ::- (Monad m) =>- (Committer m a -> m ()) ->- Committer m a ->- Committer m a-postmapC f c = Committer $ \a -> do- r <- commit c a- f c- pure r+-- | Convert a committer to be a list committer.+--+-- >>> glue showStdout <$|> qList [[1..3]]+-- [1,2,3]+--+-- >>> glue (listC showStdout) <$|> qList [[1..3]]+-- 1+-- 2+-- 3+listC :: (Monad m) => Committer m a -> Committer m [a]+listC c = Committer $ fmap or . mapM (commit c) --- | commit to a StateT 'Seq'.+-- | Push to a state sequence. ----- Seq is used because only a finite number of commits are expected and because snoc'ing is cool.-stateC :: (Monad m) => Committer (StateT (Seq.Seq a) m) a-stateC = Committer $ \a -> do+-- >>> import Control.Monad.State.Lazy+-- >>> import qualified Data.Sequence as Seq+-- >>> flip execStateT Seq.empty . glue push . foist lift <$|> qList [1..3]+-- fromList [1,2,3]+push :: (Monad m) => Committer (StateT (Seq.Seq a) m) a+push = Committer $ \a -> do modify (Seq.:|> a) pure True---- | list committer-listC :: (Monad m) => Committer m a -> Committer m [a]-listC c = Committer $ \as ->- or <$> sequence (commit c <$> as)
src/Box/Connectors.hs view
@@ -1,121 +1,131 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RebindableSyntax #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -Wall #-}---- | various ways to connect things up+-- | Various ways to connect things up. module Box.Connectors- ( fromListE,- fromList_,- toList_,- fromToList_,- emitQ,- commitQ,+ ( qList,+ qListWith,+ popList,+ pushList,+ pushListN, sink,+ sinkWith, source,+ sourceWith, forkEmit,- feedback,- queueCommitter,- queueEmitter,+ bufferCommitter,+ bufferEmitter, concurrentE, concurrentC,- glueN,+ takeQ,+ evalEmitter,+ evalEmitterWith, ) where import Box.Box+import Box.Codensity import Box.Committer-import Box.Cont import Box.Emitter+import Box.Functor import Box.Queue-import Control.Concurrent.Classy.Async as C-import Control.Lens-import Control.Monad.Conc.Class (MonadConc)-import qualified Data.Sequence as Seq-import NumHask.Prelude hiding (STM, atomically)---- | Turn a list into an 'Emitter' continuation via a 'Queue'-fromListE :: (MonadConc m) => [a] -> Cont m (Emitter m a)-fromListE xs = Cont $ queueE (eListC (Emitter . pure . Just <$> xs))+import Control.Concurrent.Async+import Control.Monad+import Control.Monad.State.Lazy+import Data.Foldable+import Data.Functor+import Data.Sequence qualified as Seq+import Prelude -eListC :: (Monad m) => [Emitter m a] -> Committer m a -> m ()-eListC [] _ = pure ()-eListC (e : es) c = do- x <- emit e- case x of- Nothing -> pure ()- Just x' -> commit c x' *> eListC es c+-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Box+-- >>> import Prelude+-- >>> import Data.Bool+-- >>> import Control.Monad --- | fromList_ directly supplies to a committer action+-- | Queue a list 'Unbounded'. ----- FIXME: fromList_ combined with cRef is failing dejavu concurrency testing...-fromList_ :: Monad m => [a] -> Committer m a -> m ()-fromList_ xs c = flip evalStateT (Seq.fromList xs) $ glue (hoist lift c) stateE+-- >>> pushList <$|> qList [1,2,3]+-- [1,2,3]+qList :: [a] -> CoEmitter IO a+qList xs = qListWith Unbounded xs --- | toList_ directly receives from an emitter------ TODO: check isomorphism+-- | Queue a list with an explicit 'Queue'. ----- > toList_ == toListE-toList_ :: (Monad m) => Emitter m a -> m [a]-toList_ e = toList <$> flip execStateT Seq.empty (glue stateC (hoist lift e))+-- >>> pushList <$|> qListWith Single [1,2,3]+-- [1,2,3]+qListWith :: Queue a -> [a] -> CoEmitter IO a+qListWith q xs = emitQ q (\c -> fmap and (traverse (commit c) xs)) --- | Glues a committer and emitter, taking n emits+-- | Directly supply a list to a committer action, via pop. ----- >>> glueN 4 <$> pure (contramap show toStdout) <*.> fromListE [1..]+-- >>> popList [1..3] showStdout -- 1 -- 2 -- 3--- 4-glueN :: Monad m => Int -> Committer m a -> Emitter m a -> m ()-glueN n c e = flip evalStateT 0 $ glue (hoist lift c) (takeE n e)+popList :: (Monad m) => [a] -> Committer m a -> m ()+popList xs c = glueES (Seq.fromList xs) c pop --- | take a list, emit it through a box, and output the committed result.+-- | Push an Emitter into a list, via push. ----- The pure nature of this computation is highly useful for testing,--- especially where parts of the box under investigation has non-deterministic attributes.-fromToList_ :: (Monad m) => [a] -> (Box (StateT (Seq.Seq b, Seq.Seq a) m) b a -> StateT (Seq.Seq b, Seq.Seq a) m r) -> m [b]-fromToList_ xs f = do- (res, _) <-- flip execStateT (Seq.empty, Seq.fromList xs) $- f (Box (hoist (zoom _1) stateC) (hoist (zoom _2) stateE))- pure $ toList res---- | hook a committer action to a queue, creating an emitter continuation-emitQ :: (MonadConc m) => (Committer m a -> m r) -> Cont m (Emitter m a)-emitQ cio = Cont $ \eio -> queueE cio eio+-- >>> pushList <$|> qList [1..3]+-- [1,2,3]+pushList :: (Monad m) => Emitter m a -> m [a]+pushList e = toList <$> flip execStateT Seq.empty (glue push (foist lift e)) --- | hook a committer action to a queue, creating an emitter continuation-commitQ :: (MonadConc m) => (Emitter m a -> m r) -> Cont m (Committer m a)-commitQ eio = Cont $ \cio -> queueC cio eio+-- | Push an Emitter into a list, finitely.+--+-- >>> pushListN 2 <$|> qList [1..3]+-- [1,2]+pushListN :: (Monad m) => Int -> Emitter m a -> m [a]+pushListN n e = toList <$> flip execStateT Seq.empty (glueN n push (foist lift e)) --- | singleton sink+-- singleton sink sink1 :: (Monad m) => (a -> m ()) -> Emitter m a -> m () sink1 f e = do a <- emit e- case a of- Nothing -> pure ()- Just a' -> f a'+ forM_ a f --- | finite sink-sink :: (MonadConc m) => Int -> (a -> m ()) -> Cont m (Committer m a)-sink n f = commitQ $ replicateM_ n . sink1 f+-- | Create a finite Committer Unbounded Queue.+--+-- > glue <$> sink 2 print <*|> qList [1..3]+-- > 1+-- > 2+sink :: Int -> (a -> IO ()) -> CoCommitter IO a+sink n f = sinkWith Unbounded n f --- | singleton source+-- | Create a finite Committer Queue.+sinkWith :: Queue a -> Int -> (a -> IO ()) -> CoCommitter IO a+sinkWith q n f = commitQ q $ replicateM_ n . sink1 f++-- singleton source source1 :: (Monad m) => m a -> Committer m a -> m () source1 a c = do a' <- a void $ commit c a' --- | finite source-source :: (MonadConc m) => Int -> m a -> Cont m (Emitter m a)-source n f = emitQ $ replicateM_ n . source1 f+-- | Create a finite (Co)Emitter Unbounded Queue.+--+-- >>> glue toStdout <$|> source 2 (pure "hi")+-- hi+-- hi+source :: Int -> IO a -> CoEmitter IO a+source n f = sourceWith Unbounded n f --- | glues an emitter to a committer, then resupplies the emitter+-- | Create a finite (Co)Emitter Unbounded Queue.+--+-- >>> glue toStdout <$|> sourceWith Single 2 (pure "hi")+-- hi+-- hi+sourceWith :: Queue a -> Int -> IO a -> CoEmitter IO a+sourceWith q n f = emitQ q $ replicateM_ n . source1 f++-- | Glues an emitter to a committer, then resupplies the emitter.+--+-- >>> (c1,l1) <- refCommitter :: IO (Committer IO Int, IO [Int])+-- >>> close $ toListM <$> (forkEmit <$> (qList [1..3]) <*> pure c1)+-- [1,2,3]+--+-- >>> l1+-- [1,2,3] forkEmit :: (Monad m) => Emitter m a -> Committer m a -> Emitter m a forkEmit e c = Emitter $ do@@ -123,61 +133,87 @@ maybe (pure ()) (void <$> commit c) a pure a --- | fuse a committer to a buffer-queueCommitter :: (MonadConc m) => Committer m a -> Cont m (Committer m a)-queueCommitter c = Cont $ \caction -> queueC caction (glue c)+-- | Buffer a committer.+bufferCommitter :: Committer IO a -> CoCommitter IO a+bufferCommitter c = Codensity $ \caction -> queueL Unbounded caction (glue c) --- | fuse an emitter to a buffer-queueEmitter :: (MonadConc m) => Emitter m a -> Cont m (Emitter m a)-queueEmitter e = Cont $ \eaction -> queueE (`glue` e) eaction+-- | Buffer an emitter.+bufferEmitter :: Emitter IO a -> CoEmitter IO a+bufferEmitter e = Codensity $ \eaction -> queueR Unbounded (`glue` e) eaction --- | concurrently run two emitters+-- | Concurrently run two emitters. ----- This differs from mappend in that the monoidal (and alternative) instance of an Emitter is left-biased (The left emitter exhausts before the right one is begun). This is non-deterministically concurrent.+-- This differs to (<>), which is left-biased.+--+-- Note that functions such as toListM, which complete on the first Nothing emitted, will not work as expected.+--+-- >>> close $ (fmap toListM) (join $ concurrentE Single <$> qList [1..3] <*> qList [5..9])+-- [1,2,3]+--+-- In the code below, the ordering is non-deterministic.+--+-- > (c,l) <- refCommitter :: IO (Committer IO Int, IO [Int])+-- > close $ glue c <$> (join $ concurrentE Single <$> qList [1..30] <*> qList [40..60]) concurrentE ::- (MonadConc m) =>- Emitter m a ->- Emitter m a ->- Cont m (Emitter m a)-concurrentE e e' =- Cont $ \eaction ->- fst- <$> C.concurrently- (queueE (`glue` e) eaction)- (queueE (`glue` e') eaction)+ Queue a ->+ Emitter IO a ->+ Emitter IO a ->+ CoEmitter IO a+concurrentE q e e' =+ Codensity $ \eaction -> snd . fst <$> concurrently (queue q (`glue` e) eaction) (queue q (`glue` e') eaction) --- | run two committers concurrently-concurrentC :: (MonadConc m) => Committer m a -> Committer m a -> Cont m (Committer m a)-concurrentC c c' = mergeC <$> eitherC c c'+-- | Concurrently run two committers.+--+-- >>> import Data.Functor.Contravariant+-- >>> import Data.Text (pack)+-- >>> cFast = witherC (\b -> pure (Just b)) . contramap ("fast: " <>) $ toStdout+-- >>> cSlow = witherC (\b -> sleep 0.1 >> pure (Just b)) . contramap ("slow: " <>) $ toStdout+-- >>> close $ (popList ((pack . show) <$> [1..3]) <$> (concurrentC Unbounded cFast cSlow)) <> pure (sleep 1)+-- fast: 1+-- fast: 2+-- fast: 3+-- slow: 1+-- slow: 2+-- slow: 3+concurrentC :: Queue a -> Committer IO a -> Committer IO a -> CoCommitter IO a+concurrentC q c c' = mergeC <$> eitherC q c c' eitherC ::- (MonadConc m) =>- Committer m a ->- Committer m a ->- Cont m (Either (Committer m a) (Committer m a))-eitherC cl cr =- Cont $+ Queue a ->+ Committer IO a ->+ Committer IO a ->+ Codensity IO (Either (Committer IO a) (Committer IO a))+eitherC q cl cr =+ Codensity $ \kk -> fst- <$> C.concurrently- (queueC (kk . Left) (glue cl))- (queueC (kk . Right) (glue cr))+ <$> concurrently+ (queueL q (kk . Left) (glue cl))+ (queueL q (kk . Right) (glue cr)) -mergeC :: Either (Committer m a) (Committer m a) -> Committer m a+mergeC :: Either (Committer IO a) (Committer IO a) -> Committer IO a mergeC ec = Committer $ \a -> case ec of Left lc -> commit lc a Right rc -> commit rc a --- | a box modifier that feeds commits back to the emitter-feedback ::- (MonadConc m) =>- (a -> m (Maybe b)) ->- Cont m (Box m b a) ->- Cont m (Box m b a)-feedback f box =- Cont $ \bio ->- with box $ \(Box c e) -> do- glue c (mapE f e)- bio (Box c e)+-- | Take and queue n emits.+--+-- >>> import Control.Monad.State.Lazy+-- >>> toListM <$|> (takeQ Single 4 =<< qList [0..])+-- [0,1,2,3]+takeQ :: Queue a -> Int -> Emitter IO a -> CoEmitter IO a+takeQ q n e = emitQ q $ \c -> glueES 0 c (takeE n e)++-- | queue a stateful emitter, supplying initial state+--+-- >>> import Control.Monad.State.Lazy+-- >>> toListM <$|> (evalEmitter 0 <$> takeE 4 =<< qList [0..])+-- [0,1,2,3]+evalEmitter :: s -> Emitter (StateT s IO) a -> CoEmitter IO a+evalEmitter s e = evalEmitterWith Unbounded s e++-- | queue a stateful emitter, supplying initial state+evalEmitterWith :: Queue a -> s -> Emitter (StateT s IO) a -> CoEmitter IO a+evalEmitterWith q s e = emitQ q $ \c -> glueES s c e
− src/Box/Cont.hs
@@ -1,111 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RebindableSyntax #-}-{-# OPTIONS_GHC -Wall #-}---- | A continuation type.-module Box.Cont- ( Cont (..),- runCont,- (<$.>),- (<*.>),- Cont_ (..),- runCont_,- )-where--import NumHask.Prelude hiding (STM, atomically)---- | A continuation similar to ` Control.Monad.ContT` but where the result type is swallowed by an existential-newtype Cont m a = Cont- { with :: forall r. (a -> m r) -> m r- }--instance Functor (Cont m) where- fmap f mx = Cont (\return_ -> mx `with` \x -> return_ (f x))--instance Applicative (Cont m) where- pure r = Cont (\return_ -> return_ r)-- mf <*> mx = Cont (\return_ -> mf `with` \f -> mx `with` \x -> return_ (f x))--instance Monad (Cont m) where- return r = Cont (\return_ -> return_ r)-- ma >>= f = Cont (\return_ -> ma `with` \a -> f a `with` \b -> return_ b)--instance (MonadIO m) => MonadIO (Cont m) where- liftIO m =- Cont- ( \return_ -> do- a <- liftIO m- return_ a- )--instance (Semigroup a) => Semigroup (Cont m a) where- (<>) = liftA2 (<>)--instance (Functor m, Semigroup a, Monoid a) => Monoid (Cont m a) where- mempty = pure mempty-- mappend = (<>)---- | finally run a continuation-runCont :: Cont m (m r) -> m r-runCont x = with x id---- | sometimes you have no choice but to void it up-newtype Cont_ m a = Cont_- { with_ :: (a -> m ()) -> m ()- }--instance Functor (Cont_ m) where- fmap f mx = Cont_ (\return_ -> mx `with_` \x -> return_ (f x))--instance Applicative (Cont_ m) where- pure r = Cont_ (\return_ -> return_ r)-- mf <*> mx = Cont_ (\return_ -> mf `with_` \f -> mx `with_` \x -> return_ (f x))--instance Monad (Cont_ m) where- return r = Cont_ (\return_ -> return_ r)-- ma >>= f = Cont_ (\return_ -> ma `with_` \a -> f a `with_` \b -> return_ b)--instance (MonadIO m) => MonadIO (Cont_ m) where- liftIO m =- Cont_- ( \return_ -> do- a <- liftIO m- return_ a- )--instance (Semigroup a) => Semigroup (Cont_ m a) where- (<>) = liftA2 (<>)--instance (Functor m, Semigroup a, Monoid a) => Monoid (Cont_ m a) where- mempty = pure mempty-- mappend = (<>)---- | finally run a Cont_-runCont_ :: Cont_ m (m ()) -> m ()-runCont_ x = with_ x id--infixr 3 <$.>---- | fmap over a continuation and then run the result.------ The . position is towards the continuation-(<$.>) :: (a -> m r) -> Cont m a -> m r-(<$.>) f a = runCont (fmap f a)--infixr 3 <*.>---- | fmap over a continuation and then run the result.------ The . position is towards the continuation-(<*.>) :: Cont m (a -> m r) -> Cont m a -> m r-(<*.>) f a = runCont (f <*> a)
src/Box/Emitter.hs view
@@ -1,48 +1,57 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RebindableSyntax #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -Wall #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-}---- | `emit`+-- | 'Emitter' wraps a producer destructor.+--+-- "Every Thought emits a Dice Throw" ~ Stéphane Mallarmé module Box.Emitter ( Emitter (..),- mapE,+ type CoEmitter,+ toListM,+ witherE,+ filterE, readE,- readE_,- parseE,- parseE_,- premapE,- postmapE,- postmapM,- toListE, unlistE,- stateE, takeE, takeUntilE,- filterE,+ dropE,+ pop, ) where -import qualified Data.Attoparsec.Text as A-import qualified Data.Sequence as Seq-import NumHask.Prelude+import Box.Functor+import Control.Applicative+import Control.Monad+import Control.Monad.Codensity+import Control.Monad.State.Lazy+import Data.Bool+import Data.DList qualified as D+import Data.Sequence qualified as Seq+import Data.Text (Text, pack, unpack)+import Prelude --- | an `Emitter` "emits" values of type a. A Source & a Producer (of a's) are the two other alternative but overloaded metaphors out there.+-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Prelude+-- >>> import Box+-- >>> import Data.Bool+-- >>> import Data.Text (Text)++-- | An `Emitter` `emit`s values of type 'Maybe' a. Source and producer are similar metaphors. An Emitter reaches into itself for the value to emit, where itself is an opaque thing from the pov of usage. ----- An Emitter "reaches into itself" for the value to emit, where itself is an opaque thing from the pov of usage. An Emitter is named for its main action: it emits.+-- >>> e = Emitter (pure (Just "I'm emitted"))+-- >>> emit e+-- Just "I'm emitted"+--+-- >>> emit mempty+-- Nothing newtype Emitter m a = Emitter { emit :: m (Maybe a) } -instance MFunctor Emitter where- hoist nat (Emitter e) = Emitter (nat e)+-- | An 'Emitter' continuation.+type CoEmitter m a = Codensity m (Emitter m a) +instance FFunctor Emitter where+ foist nat (Emitter e) = Emitter (nat e)+ instance (Functor m) => Functor (Emitter m) where fmap f m = Emitter (fmap (fmap f) (emit m)) @@ -52,13 +61,13 @@ mf <*> mx = Emitter ((<*>) <$> emit mf <*> emit mx) instance (Monad m) => Monad (Emitter m) where- return r = Emitter (return (return r))+ return = pure m >>= f = Emitter $ do ma <- emit m case ma of- Nothing -> return Nothing+ Nothing -> pure Nothing Just a -> emit (f a) instance (Monad m, Alternative m) => Alternative (Emitter m) where@@ -71,6 +80,9 @@ Nothing -> emit i Just a -> pure (Just a) + -- Zero or more.+ many e = Emitter $ Just <$> toListM e+ instance (Alternative m, Monad m) => MonadPlus (Emitter m) where mzero = empty @@ -84,9 +96,25 @@ mappend = (<>) --- | like a monadic mapMaybe. (See [witherable](https://hackage.haskell.org/package/witherable))-mapE :: (Monad m) => (a -> m (Maybe b)) -> Emitter m a -> Emitter m b-mapE f e = Emitter go+-- | This fold completes on the first Nothing emitted, which may not be what you want.+instance FoldableM Emitter where+ foldrM acc begin e =+ maybe begin (\a' -> foldrM acc (acc a' begin) e) =<< emit e++-- | Collect emits into a list, and close on the first Nothing.+--+-- >>> toListM <$|> qList [1..3]+-- [1,2,3]+toListM :: (Monad m) => Emitter m a -> m [a]+toListM e = D.toList <$> foldrM (\a acc -> fmap (`D.snoc` a) acc) (pure D.empty) e++-- | A monadic [Witherable](https://hackage.haskell.org/package/witherable)+--+-- >>> toListM <$|> witherE (\x -> bool (print x >> pure Nothing) (pure (Just x)) (even x)) <$> (qList [1..3])+-- 1+-- []+witherE :: (Monad m) => (a -> m (Maybe b)) -> Emitter m a -> Emitter m b+witherE f e = Emitter go where go = do a <- emit e@@ -95,18 +123,32 @@ Just a' -> do fa <- f a' case fa of- Nothing -> go+ Nothing -> pure Nothing Just fa' -> pure (Just fa') --- | parse emitter which returns the original text on failure-parseE :: (Functor m) => A.Parser a -> Emitter m Text -> Emitter m (Either Text a)-parseE parser e = (\t -> either (const $ Left t) Right (A.parseOnly parser t)) <$> e---- | no error-reporting parsing-parseE_ :: (Monad m) => A.Parser a -> Emitter m Text -> Emitter m a-parseE_ parser = mapE (pure . either (const Nothing) Just) . parseE parser+-- | Like witherE but does not emit Nothing on filtering.+--+-- >>> toListM <$|> filterE (\x -> bool (print x >> pure Nothing) (pure (Just x)) (even x)) <$> (qList [1..3])+-- 1+-- 3+-- [2]+filterE :: (Monad m) => (a -> m (Maybe b)) -> Emitter m a -> Emitter m b+filterE f e = Emitter go+ where+ go = do+ a <- emit e+ case a of+ Nothing -> pure Nothing+ Just a' -> do+ fa <- f a'+ case fa of+ Nothing -> go+ Just fa' -> pure (Just fa') --- | read parse emitter, returning the original string on error+-- | Read parse 'Emitter', returning the original text on error+--+-- >>> (toListM . readE) <$|> (qList ["1","2","3","four"]) :: IO [Either Text Int]+-- [Right 1,Right 2,Right 3,Left "four"] readE :: (Functor m, Read a) => Emitter m Text ->@@ -118,97 +160,52 @@ [(a, "")] -> Right a _err -> Left (pack str) --- | no error-reporting reading-readE_ ::- (Monad m, Read a) =>- Emitter m Text ->- Emitter m a-readE_ = mapE (pure . either (const Nothing) Just) . readE---- | adds a pre-emit monadic action to the emitter-premapE ::- (Applicative m) =>- (Emitter m a -> m ()) ->- Emitter m a ->- Emitter m a-premapE f e = Emitter $ f e *> emit e---- | adds a post-emit monadic action to the emitter-postmapE ::- (Monad m) =>- (Emitter m a -> m ()) ->- Emitter m a ->- Emitter m a-postmapE f e = Emitter $ do- r <- emit e- f e- pure r---- | add a post-emit monadic action on the emitted value (if there was any)-postmapM ::- (Monad m) =>- (a -> m ()) ->- Emitter m a ->- Emitter m a-postmapM f e = Emitter $ do- r <- emit e- case r of- Nothing -> pure Nothing- Just r' -> do- f r'- pure (Just r')---- | turn an emitter into a list-toListE :: (Monad m) => Emitter m a -> m [a]-toListE e = go Seq.empty e- where- go xs e' = do- x <- emit e'- case x of- Nothing -> pure (toList xs)- Just x' -> go (xs Seq.:|> x') e'---- | emit from a StateT Seq------ FIXME: This compiles but is an infinite "a" emitter:+-- | Convert a list emitter to a (Stateful) element emitter. ----- let e1 = hoist (flip evalStateT (Seq.fromList ["a", "b"::Text])) stateE :: Emitter IO Text-stateE :: (Monad m) => Emitter (StateT (Seq.Seq a) m) a-stateE = Emitter $ do- xs' <- get- case xs' of- Seq.Empty -> pure Nothing- (x Seq.:<| xs'') -> do- put xs''- pure $ Just x---- | convert a list emitter to a Stateful element emitter+-- >>> import Control.Monad.State.Lazy+-- >>> flip runStateT [] . toListM . unlistE <$|> (qList [[0..3],[5..7]])+-- ([0,1,2,3,5,6,7],[]) unlistE :: (Monad m) => Emitter m [a] -> Emitter (StateT [a] m) a-unlistE es = mapE unlistS (hoist lift es)+unlistE es = Emitter unlists where- unlistS xs = do+ -- unlists :: (Monad m) => StateT [a] m (Maybe a)+ unlists = do rs <- get- case rs <> xs of- [] -> pure Nothing- (x : xs') -> do- put xs'+ case rs of+ [] -> do+ xs <- lift $ emit es+ case xs of+ Nothing -> pure Nothing+ Just xs' -> do+ put xs'+ unlists+ (x : rs') -> do+ put rs' pure (Just x) --- | Stop an 'Emitter' after n 'emit's+-- | Take n emits.+--+-- >>> import Control.Monad.State.Lazy+-- >>> flip evalStateT 0 <$|> toListM . takeE 4 <$> qList [0..]+-- [0,1,2,3] takeE :: (Monad m) => Int -> Emitter m a -> Emitter (StateT Int m) a-takeE n e = Emitter $ do- x <- emit (hoist lift e)- case x of- Nothing -> pure Nothing- Just x' -> do- n' <- get- bool (pure Nothing) (emit' n') (n' < n)- where- emit' n' = do- put (n' + 1)- pure $ Just x'+takeE n (Emitter e) =+ Emitter $ get >>= \n' -> bool (pure Nothing) (put (n' + 1) >> lift e) (n' < n) --- | Take from an emitter until predicate+-- | Drop n emits.+--+-- >>> import Control.Monad.State.Lazy+-- >>> toListM <$|> (dropE 2 =<< qList [0..3])+-- [2,3]+dropE :: (Monad m) => Int -> Emitter m a -> CoEmitter m a+dropE n e = Codensity $ \k -> do+ replicateM_ n (emit e)+ k e++-- | Take from an emitter until a predicate.+--+-- >>> (toListM . takeUntilE (==3)) <$|> (qList [0..])+-- [0,1,2] takeUntilE :: (Monad m) => (a -> Bool) -> Emitter m a -> Emitter m a takeUntilE p e = Emitter $ do x <- emit e@@ -217,13 +214,17 @@ Just x' -> bool (pure (Just x')) (pure Nothing) (p x') --- | Filter emissions according to a predicate.-filterE :: (Monad m) => (a -> Bool) -> Emitter m a -> Emitter m a-filterE p e = Emitter go- where- go = do- x <- emit e- case x of- Nothing -> pure Nothing- Just x' ->- bool go (pure (Just x')) (p x')+-- | Pop from a State sequence.+--+-- >>> import qualified Data.Sequence as Seq+-- >>> import Control.Monad.State.Lazy (evalStateT)+-- >>> flip evalStateT (Seq.fromList [1..3]) $ toListM pop+-- [1,2,3]+pop :: (Monad m) => Emitter (StateT (Seq.Seq a) m) a+pop = Emitter $ do+ xs <- get+ case xs of+ Seq.Empty -> pure Nothing+ (x Seq.:<| xs') -> do+ put xs'+ pure (Just x)
+ src/Box/Functor.hs view
@@ -0,0 +1,21 @@+-- | Some higher-kinded Functor types that make do until we get FunctorOf+--+-- eg https://eevie.ro/posts/2019-05-12-functor-of.html+module Box.Functor+ ( FFunctor (..),+ FoldableM (..),+ )+where++import Data.Kind+import Prelude++-- | An endofunctor in the category of endofunctors.+--+-- Like `Control.Monad.Morph.MFunctor` but without a `Monad` constraint.+class FFunctor (h :: (Type -> Type) -> Type -> Type) where+ foist :: (forall x. f x -> g x) -> h f a -> h g a++-- | Monadically Foldable+class FoldableM (t :: (Type -> Type) -> Type -> Type) where+ foldrM :: (Monad m) => (a -> m b -> m b) -> m b -> t m a -> m b
src/Box/IO.hs view
@@ -1,126 +1,279 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RebindableSyntax #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -Wall #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-} --- | IO actions+-- | IO effects module Box.IO ( fromStdin, toStdout,+ stdBox, fromStdinN, toStdoutN, readStdin, showStdout,+ refCommitter,+ refEmitter, handleE, handleC,- cRef,- eRef, fileE,- fileWriteC,- fileAppendC,+ fileC,+ fileEText,+ fileEBS,+ fileCText,+ fileCBS,+ toLineBox,+ fromLineBox,+ logConsoleC,+ logConsoleE,+ pauser,+ changer,+ quit,+ restart, ) where +import Box.Box+import Box.Codensity import Box.Committer import Box.Connectors-import Box.Cont import Box.Emitter-import qualified Control.Concurrent.Classy.IORef as C-import Control.Lens hiding ((.>), (:>), (<|), (|>))-import qualified Control.Monad.Conc.Class as C-import qualified Data.Sequence as Seq-import Data.Text.IO (hGetLine)-import NumHask.Prelude hiding (STM)+import Control.Concurrent.Async+import Control.Exception+import Control.Monad.State.Lazy+import Data.Bool+import Data.ByteString.Char8 as Char8+import Data.Foldable+import Data.Function+import Data.Functor.Contravariant+import Data.IORef+import Data.Sequence qualified as Seq+import Data.String+import Data.Text as Text hiding (null, show)+import Data.Text.Encoding+import Data.Text.IO as Text+import System.IO as IO+import Prelude -- $setup -- >>> :set -XOverloadedStrings+-- >>> import Prelude+-- >>> import Box+-- >>> import Data.Bool+-- >>> import Data.Text (Text, pack)+-- >>> import Data.Functor.Contravariant -- * console --- | emit Text from stdin inputs+-- | Emit text from stdin ----- >>> :t emit fromStdin--- emit fromStdin :: IO (Maybe Text)+-- @+-- λ> emit fromStdin+-- hello+-- Just "hello"+-- @ fromStdin :: Emitter IO Text-fromStdin = Emitter $ Just <$> NumHask.Prelude.getLine+fromStdin = Emitter $ Just <$> Text.getLine --- | commit to stdout+-- | Commit to stdout -- -- >>> commit toStdout ("I'm committed!" :: Text) -- I'm committed! -- True toStdout :: Committer IO Text-toStdout = Committer $ \a -> putStrLn a >> pure True+toStdout = Committer $ \a -> Text.putStrLn a >> pure True --- | finite console emitter-fromStdinN :: Int -> Cont IO (Emitter IO Text)-fromStdinN n = source n NumHask.Prelude.getLine+-- | A 'Box' to and from std, with an escape phrase.+stdBox :: Text -> Box IO Text Text+stdBox q = Box toStdout (takeUntilE (== q) fromStdin) --- | finite console committer-toStdoutN :: Int -> Cont IO (Committer IO Text)-toStdoutN n = sink n putStrLn+-- | Finite console emitter+--+-- @+-- λ> toListM /<$|/> fromStdinN 2+-- hello+-- hello again+-- ["hello","hello again"]+-- @+fromStdinN :: Int -> CoEmitter IO Text+fromStdinN n = source n Text.getLine --- | read from console, throwing away read errors-readStdin :: Read a => Emitter IO a-readStdin = mapE (pure . either (const Nothing) Just) . readE $ fromStdin+-- | Finite console committer+--+-- >>> glue <$> contramap (pack . show) <$> (toStdoutN 2) <*|> qList [1..3]+-- 1+-- 2+toStdoutN :: Int -> CoCommitter IO Text+toStdoutN n = sink n Text.putStrLn --- | show to stdout-showStdout :: Show a => Committer IO a-showStdout = contramap show toStdout+-- | Read from console, throwing away read errors+--+-- > λ> glueN 2 showStdout (readStdin :: Emitter IO Int)+-- > 1+-- > 1+-- > hippo+-- > 2+-- > 2+readStdin :: (Read a) => Emitter IO a+readStdin = witherE (pure . either (const Nothing) Just) . readE $ fromStdin --- * handle operations+-- | Show to stdout+--+-- >>> glue showStdout <$|> qList [1..3]+-- 1+-- 2+-- 3+showStdout :: (Show a) => Committer IO a+showStdout = contramap (Text.pack . show) toStdout -- | Emits lines of Text from a handle.-handleE :: Handle -> Emitter IO Text-handleE h = Emitter $ do- l :: (Either IOException Text) <- try (hGetLine h)+handleE :: (IsString a, Eq a) => (Handle -> IO a) -> Handle -> Emitter IO a+handleE action h = Emitter $ do+ l :: (Either IOException a) <- try (action h) pure $ case l of Left _ -> Nothing Right a -> bool (Just a) Nothing (a == "") -- | Commit lines of Text to a handle.-handleC :: Handle -> Committer IO Text-handleC h = Committer $ \a -> do- hPutStrLn h a+handleC :: (Handle -> a -> IO ()) -> Handle -> Committer IO a+handleC action h = Committer $ \a -> do+ action h a pure True --- | Emits lines of Text from a file.-fileE :: FilePath -> Cont IO (Emitter IO Text)-fileE fp = Cont $ \eio -> withFile fp ReadMode (eio . handleE)+-- | Emit from a file.+fileE :: FilePath -> BufferMode -> IOMode -> (Handle -> Emitter IO a) -> CoEmitter IO a+fileE fp b m action = Codensity $ \eio ->+ withFile+ fp+ m+ ( \h -> do+ hSetBuffering h b+ eio (action h)+ ) --- | Commits lines of Text to a file.-fileWriteC :: FilePath -> Cont IO (Committer IO Text)-fileWriteC fp = Cont $ \cio -> withFile fp WriteMode (cio . handleC)+-- | Emit lines of Text from a file.+fileEText :: FilePath -> BufferMode -> CoEmitter IO Text+fileEText fp b = fileE fp b ReadMode (handleE Text.hGetLine) --- | Commits lines of Text, appending to a file.-fileAppendC :: FilePath -> Cont IO (Committer IO Text)-fileAppendC fp = Cont $ \cio -> withFile fp AppendMode (cio . handleC)+-- | Emit lines of ByteString from a file.+fileEBS :: FilePath -> BufferMode -> CoEmitter IO ByteString+fileEBS fp b = fileE fp b ReadMode (handleE Char8.hGetLine) --- | commit to an IORef-cRef :: (C.MonadConc m) => m (Committer m a, m [a])-cRef = do- ref <- C.newIORef Seq.empty+-- | Commit to a file.+fileC :: FilePath -> IOMode -> BufferMode -> (Handle -> Committer IO a) -> CoCommitter IO a+fileC fp m b action = Codensity $ \cio ->+ withFile+ fp+ m+ ( \h -> do+ hSetBuffering h b+ cio (action h)+ )++-- | Commit Text to a file, as a line.+fileCText :: FilePath -> BufferMode -> IOMode -> CoCommitter IO Text+fileCText fp m b = fileC fp b m (handleC Text.hPutStrLn)++-- | Commit ByteString to a file, as a line.+fileCBS :: FilePath -> BufferMode -> IOMode -> CoCommitter IO ByteString+fileCBS fp m b = fileC fp b m (handleC Char8.hPutStrLn)++-- | Convert a 'Box' from ByteString to lines of Text.+toLineBox :: Text -> Box IO ByteString ByteString -> CoBox IO Text Text+toLineBox end (Box c e) = Box (contramap (encodeUtf8 . (<> end)) c) <$> evalEmitter [] (unlistE $ fmap (Text.lines . decodeUtf8) e)++-- | Convert a 'Box' from lines of Text to ByteStrings.+fromLineBox :: Text -> Box IO Text Text -> Box IO ByteString ByteString+fromLineBox end (Box c e) = Box (contramap (Text.lines . decodeUtf8) (listC c)) (fmap (encodeUtf8 . (<> end)) e)++-- | Commit to an IORef+--+-- >>> (c1,l1) <- refCommitter :: IO (Committer IO Int, IO [Int])+-- >>> glue c1 <$|> qList [1..3]+-- >>> l1+-- [1,2,3]+refCommitter :: IO (Committer IO a, IO [a])+refCommitter = do+ ref <- newIORef Seq.empty let c = Committer $ \a -> do- C.modifyIORef ref (Seq.:|> a)+ modifyIORef ref (Seq.:|> a) pure True- let res = toList <$> C.readIORef ref+ let res = toList <$> readIORef ref pure (c, res) --- | emit from a list IORef-eRef :: (C.MonadConc m) => [a] -> m (Emitter m a)-eRef xs = do- ref <- C.newIORef xs+-- | Emit from a list IORef+--+-- >>> e <- refEmitter [1..3]+-- >>> toListM e+-- [1,2,3]+refEmitter :: [a] -> IO (Emitter IO a)+refEmitter xs = do+ ref <- newIORef xs let e = Emitter $ do- as <- C.readIORef ref+ as <- readIORef ref case as of [] -> pure Nothing (x : xs') -> do- C.writeIORef ref xs'+ writeIORef ref xs' pure $ Just x pure e++-- | simple console logger for rough testing+logConsoleE :: (Show a) => String -> Emitter IO a -> Emitter IO a+logConsoleE label e = Emitter $ do+ a <- emit e+ Prelude.putStrLn (label <> show a)+ pure a++-- | simple console logger for rough testing+logConsoleC :: (Show a) => String -> Committer IO a -> Committer IO a+logConsoleC label c = Committer $ \a -> do+ Prelude.putStrLn (label <> show a)+ commit c a++-- | Pause an emitter based on a Bool emitter+pauser :: Emitter IO Bool -> Emitter IO a -> Emitter IO a+pauser b e = Emitter $ fix $ \rec -> do+ b' <- emit b+ case b' of+ Nothing -> pure Nothing+ Just False -> emit e+ Just True -> rec++-- | Create an emitter that indicates when another emitter has changed.+changer :: (Eq a) => a -> Emitter IO a -> CoEmitter IO Bool+changer a0 e = evalEmitter a0 $ Emitter $ do+ r <- lift $ emit e+ case r of+ Nothing -> pure Nothing+ Just r' -> do+ r'' <- get+ put r'+ pure (Just (r' == r''))++-- | quit a process based on a Bool emitter+--+-- > quit <$> speedEffect (pure 2) <$> (resetGap 5) <*|> pure io+-- > 0+-- > 1+-- > 2+-- > 3+-- > 4+-- > Left True+quit :: Emitter IO Bool -> IO a -> IO (Either Bool a)+quit flag io = race (checkE flag) io++checkE :: Emitter IO Bool -> IO Bool+checkE e = fix $ \rec -> do+ a <- emit e+ -- atomically $ check (a == Just False)+ case a of+ Nothing -> pure False+ Just True -> pure True+ Just False -> rec++-- | restart a process if flagged by a Bool emitter+restart :: Emitter IO Bool -> IO a -> IO (Either Bool a)+restart flag io = fix $ \rec -> do+ res <- quit flag io+ case res of+ Left True -> rec+ Left False -> pure (Left False)+ Right r -> pure (Right r)
src/Box/Queue.hs view
@@ -1,45 +1,36 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RebindableSyntax #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StrictData #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -Wall #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-}---- | queues--- Follows [pipes-concurrency](https://hackage.haskell.org/package/pipes-concurrency)+-- | STM Queues, based originally on [pipes-concurrency](https://hackage.haskell.org/package/pipes-concurrency) module Box.Queue ( Queue (..),- queueC,- queueE,- waitCancel,- ends,- withQE,- withQC,- toBox,+ queueL,+ queueR,+ queue,+ fromAction,+ emitQ,+ commitQ,+ fromActionWith, toBoxM,- liftB,+ toBoxSTM, concurrentlyLeft, concurrentlyRight,- fromAction,- fuseActions, ) where import Box.Box+import Box.Codensity import Box.Committer-import Box.Cont import Box.Emitter-import Control.Concurrent.Classy.Async as C-import Control.Concurrent.Classy.STM as C+import Box.Functor+import Control.Applicative+import Control.Concurrent.Async+import Control.Concurrent.STM import Control.Monad.Catch as C-import Control.Monad.Conc.Class as C-import NumHask.Prelude hiding (STM, atomically)+import Prelude +-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Box+-- >>> import Prelude+ -- | 'Queue' specifies how messages are queued data Queue a = Unbounded@@ -49,32 +40,32 @@ | Newest Int | New --- | create a queue, returning the ends-ends :: MonadSTM stm => Queue a -> stm (a -> stm (), stm a)+-- | create a queue, supplying the ends and a sealing function.+ends :: Queue a -> STM (a -> STM (), STM a) ends qu = case qu of Bounded n -> do q <- newTBQueue (fromIntegral n)- return (writeTBQueue q, readTBQueue q)+ pure (writeTBQueue q, readTBQueue q) Unbounded -> do q <- newTQueue- return (writeTQueue q, readTQueue q)+ pure (writeTQueue q, readTQueue q) Single -> do m <- newEmptyTMVar- return (putTMVar m, takeTMVar m)+ pure (putTMVar m, takeTMVar m) Latest a -> do t <- newTVar a- return (writeTVar t, readTVar t)+ pure (writeTVar t, readTVar t) New -> do m <- newEmptyTMVar- return (\x -> tryTakeTMVar m *> putTMVar m x, takeTMVar m)+ pure (\x -> tryTakeTMVar m *> putTMVar m x, takeTMVar m) Newest n -> do q <- newTBQueue (fromIntegral n) let write x = writeTBQueue q x <|> (tryReadTBQueue q *> write x)- return (write, readTBQueue q)+ pure (write, readTBQueue q) -- | write to a queue, checking the seal-writeCheck :: (MonadSTM stm) => TVar stm Bool -> (a -> stm ()) -> a -> stm Bool+writeCheck :: TVar Bool -> (a -> STM ()) -> a -> STM Bool writeCheck sealed i a = do b <- readTVar sealed if b@@ -84,23 +75,22 @@ pure True -- | read from a queue, and retry if not sealed-readCheck :: MonadSTM stm => TVar stm Bool -> stm a -> stm (Maybe a)+readCheck :: TVar Bool -> STM a -> STM (Maybe a) readCheck sealed o = (Just <$> o) <|> ( do b <- readTVar sealed- C.check b+ check b pure Nothing ) -- | turn a queue into a box (and a seal)-toBox ::- (MonadSTM stm) =>+toBoxSTM :: Queue a ->- stm (Box stm a a, stm ())-toBox q = do+ STM (Box STM a a, STM ())+toBoxSTM q = do (i, o) <- ends q- sealed <- newTVarN "sealed" False+ sealed <- newTVar False let seal = writeTVar sealed True pure ( Box@@ -111,99 +101,134 @@ -- | turn a queue into a box (and a seal), and lift from stm to the underlying monad. toBoxM ::- (MonadConc m) => Queue a ->- m (Box m a a, m ())+ IO (Box IO a a, IO ()) toBoxM q = do- (b, s) <- atomically $ toBox q+ (b, s) <- atomically $ toBoxSTM q pure (liftB b, atomically s) --- | wait for the first action, and then cancel the second-waitCancel :: (MonadConc m) => m b -> m a -> m b-waitCancel a b =- C.withAsync a $ \a' ->- C.withAsync b $ \b' -> do- a'' <- C.wait a'- C.cancel b'- pure a''- -- | run two actions concurrently, but wait and return on the left result.-concurrentlyLeft :: MonadConc m => m a -> m b -> m a+concurrentlyLeft :: IO a -> IO b -> IO a concurrentlyLeft left right =- C.withAsync left $ \a ->- C.withAsync right $ \_ ->- C.wait a+ withAsync left $ \a ->+ withAsync right $ \_ ->+ wait a -- | run two actions concurrently, but wait and return on the right result.-concurrentlyRight :: MonadConc m => m a -> m b -> m b+concurrentlyRight :: IO a -> IO b -> IO b concurrentlyRight left right =- C.withAsync left $ \_ ->- C.withAsync right $ \b ->- C.wait b+ withAsync left $ \_ ->+ withAsync right $ \b ->+ wait b --- | connect a committer and emitter action via spawning a queue, and wait for both to complete.-withQC ::- (MonadConc m) =>+-- | connect a committer and emitter action via spawning a queue, and wait for the Committer action to complete.+withQL :: Queue a ->- (Queue a -> m (Box m a a, m ())) ->- (Committer m a -> m l) ->- (Emitter m a -> m r) ->- m l-withQC q spawner cio eio =- C.bracket+ (Queue a -> IO (Box IO a a, IO ())) ->+ (Committer IO a -> IO l) ->+ (Emitter IO a -> IO r) ->+ IO l+withQL q spawner cio eio =+ bracket (spawner q) snd ( \(box, seal) -> concurrentlyLeft- (cio (committer box) `C.finally` seal)- (eio (emitter box) `C.finally` seal)+ (cio (committer box) `finally` seal)+ (eio (emitter box) `finally` seal) ) --- | connect a committer and emitter action via spawning a queue, and wait for both to complete.-withQE ::- (MonadConc m) =>+-- | connect a committer and emitter action via spawning a queue, and wait for the Emitter action to complete.+withQR :: Queue a ->- (Queue a -> m (Box m a a, m ())) ->- (Committer m a -> m l) ->- (Emitter m a -> m r) ->- m r-withQE q spawner cio eio =- C.bracket+ (Queue a -> IO (Box IO a a, IO ())) ->+ (Committer IO a -> IO l) ->+ (Emitter IO a -> IO r) ->+ IO r+withQR q spawner cio eio =+ bracket (spawner q) snd ( \(box, seal) -> concurrentlyRight- (cio (committer box) `C.finally` seal)- (eio (emitter box) `C.finally` seal)+ (cio (committer box) `finally` seal)+ (eio (emitter box) `finally` seal) ) --- | create an unbounded queue, returning the emitter result-queueC ::- (MonadConc m) =>- (Committer m a -> m l) ->- (Emitter m a -> m r) ->- m l-queueC cm em = withQC Unbounded toBoxM cm em+-- | connect a committer and emitter action via spawning a queue, and wait for both to complete.+withQ ::+ Queue a ->+ (Queue a -> IO (Box IO a a, IO ())) ->+ (Committer IO a -> IO l) ->+ (Emitter IO a -> IO r) ->+ IO (l, r)+withQ q spawner cio eio =+ bracket+ (spawner q)+ snd+ ( \(box, seal) ->+ concurrently+ (cio (committer box) `finally` seal)+ (eio (emitter box) `finally` seal)+ ) --- | create an unbounded queue, returning the emitter result-queueE ::- (MonadConc m) =>- (Committer m a -> m l) ->- (Emitter m a -> m r) ->- m r-queueE cm em = withQE Unbounded toBoxM cm em+-- | Create an unbounded queue, returning the result from the Committer action.+queueL ::+ Queue a ->+ (Committer IO a -> IO l) ->+ (Emitter IO a -> IO r) ->+ IO l+queueL q cm em = withQL q toBoxM cm em +-- | Create an unbounded queue, returning the result from the Emitter action.+queueR ::+ Queue a ->+ (Committer IO a -> IO l) ->+ (Emitter IO a -> IO r) ->+ IO r+queueR q cm em = withQR q toBoxM cm em++-- | Create an unbounded queue, returning both results.+--+-- >>> queue Unbounded (\c -> glue c <$|> qList [1..3]) toListM+-- ((),[1,2,3])+queue ::+ Queue a ->+ (Committer IO a -> IO l) ->+ (Emitter IO a -> IO r) ->+ IO (l, r)+queue q cm em = withQ q toBoxM cm em+ -- | lift a box from STM-liftB :: (MonadConc m) => Box (STM m) a b -> Box m a b-liftB (Box c e) = Box (hoist atomically c) (hoist atomically e)+liftB :: Box STM a b -> Box IO a b+liftB (Box c e) = Box (foist atomically c) (foist atomically e) --- | turn a box action into a box continuation-fromAction :: (MonadConc m) => (Box m a b -> m r) -> Cont m (Box m b a)-fromAction baction = Cont $ fuseActions baction+-- | Turn a box action into a box continuation+fromAction :: (Box IO a b -> IO r) -> CoBox IO b a+fromAction baction = Codensity $ fuseActions baction --- | connect up two box actions via two queues-fuseActions :: (MonadConc m) => (Box m a b -> m r) -> (Box m b a -> m r') -> m r'+-- | Turn a box action into a box continuation+fromActionWith :: Queue a -> Queue b -> (Box IO a b -> IO r) -> CoBox IO b a+fromActionWith qa qb baction = Codensity $ fuseActionsWith qa qb baction++-- | Connect up two box actions via two Unbounded queues+fuseActions :: (Box IO a b -> IO r) -> (Box IO b a -> IO r') -> IO r' fuseActions abm bam = do (Box ca ea, _) <- toBoxM Unbounded (Box cb eb, _) <- toBoxM Unbounded concurrentlyRight (abm (Box ca eb)) (bam (Box cb ea))++-- | Connect up two box actions via two queues+fuseActionsWith :: Queue a -> Queue b -> (Box IO a b -> IO r) -> (Box IO b a -> IO r') -> IO r'+fuseActionsWith qa qb abm bam = do+ (Box ca ea, _) <- toBoxM qa+ (Box cb eb, _) <- toBoxM qb+ concurrentlyRight (abm (Box ca eb)) (bam (Box cb ea))++-- | Hook a committer action to a queue, creating an emitter continuation.+emitQ :: Queue a -> (Committer IO a -> IO r) -> CoEmitter IO a+emitQ q cio = Codensity $ \eio -> queueR q cio eio++-- | Hook a committer action to a queue, creating an emitter continuation.+commitQ :: Queue a -> (Emitter IO a -> IO r) -> CoCommitter IO a+commitQ q eio = Codensity $ \cio -> queueL q cio eio
src/Box/Time.hs view
@@ -1,88 +1,190 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RebindableSyntax #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-}---- | timing effects+-- | Timing effects. module Box.Time ( sleep,- sleepUntil,- Stamped (..), stampNow, stampE,- emitOn,- playback,- simulate,+ Gap,+ gaps,+ fromGaps,+ fromGapsNow,+ gapEffect,+ skip,+ replay,+ gapSkipEffect,+ speedEffect,+ speedSkipEffect, ) where -import Box.Cont+import Box.Connectors import Box.Emitter-import Control.Monad.Conc.Class as C+import Control.Applicative+import Control.Concurrent+import Control.Monad.State.Lazy+import Data.Bifunctor+import Data.Bool+import Data.Fixed (Fixed (MkFixed)) import Data.Time-import NumHask.Prelude hiding (STM, atomically)-import NumHask.Space.Time+import Prelude --- | sleep for x seconds-sleep :: (MonadConc m) => Double -> m ()-sleep x = C.threadDelay (floor $ x * 1e6)+-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Box+-- >>> import Prelude --- | sleep until a certain time (in the future)-sleepUntil :: UTCTime -> IO ()-sleepUntil u = do- t0 <- getCurrentTime- sleep (fromNominalDiffTime $ diffUTCTime u t0)+-- | Sleep for x seconds.+sleep :: Double -> IO ()+sleep x = threadDelay (floor $ x * 1e6) --- | A value with a UTCTime annotation.-data Stamped a = Stamped- { stamp :: !UTCTime,- value :: !a- }- deriving (Eq, Show, Read)+-- | convenience conversion to Double+fromNominalDiffTime :: NominalDiffTime -> Double+fromNominalDiffTime t = fromInteger i * 1e-12+ where+ (MkFixed i) = nominalDiffTimeToSeconds t +-- | convenience conversion from Double+toNominalDiffTime :: Double -> NominalDiffTime+toNominalDiffTime x =+ let d0 = ModifiedJulianDay 0+ days = floor (x / fromNominalDiffTime nominalDay)+ secs = x - fromIntegral days * fromNominalDiffTime nominalDay+ t0 = UTCTime d0 (picosecondsToDiffTime 0)+ t1 = UTCTime (addDays days d0) (picosecondsToDiffTime $ floor (secs / 1.0e-12))+ in diffUTCTime t1 t0+ -- | Add the current time-stampNow :: (MonadConc m, MonadIO m) => a -> m (LocalTime, a)+stampNow :: a -> IO (LocalTime, a) stampNow a = do- t <- liftIO getCurrentTime+ t <- getCurrentTime pure (utcToLocalTime utc t, a) --- | adding a time stamp+-- | Add the current time stamp.+--+-- @+-- > toListM . stampE <$|> (qList [1..3])+-- [(2022-08-30 01:55:16.517127,1),(2022-08-30 01:55:16.517132,2),(2022-08-30 01:55:16.517135,3)]+-- @ stampE ::- (MonadConc m, MonadIO m) =>- Emitter m a ->- Emitter m (LocalTime, a)-stampE = mapE (fmap Just . stampNow)+ Emitter IO a ->+ Emitter IO (LocalTime, a)+stampE = witherE (fmap Just . stampNow) --- | wait until Stamped time before emitting-emitOn ::- Emitter IO (LocalTime, a) ->- Emitter IO a-emitOn =- mapE- ( \(l, a) -> do- sleepUntil (localTimeToUTC utc l)- pure $ Just a- )+-- | Usually represents seconds.+type Gap = Double --- | reset the emitter stamps to by in sync with the current time and adjust the speed--- >>> let e1 = fromListE (zipWith (\x a -> Stamped (addUTCTime (fromDouble x) t) a) [0..5] [0..5])-playback :: Double -> Emitter IO (LocalTime, a) -> IO (Emitter IO (LocalTime, a))-playback speed e = do- r <- emit e+-- | Convert stamped emitter to gap between emits in seconds+--+-- > toListM <$|> (gaps =<< (fromGapsNow =<< (qList (zip (0:repeat 1) [1..4]))))+-- > [(0.0,1),(1.0,2),(1.0,3),(1.0,4)]+gaps :: Emitter IO (LocalTime, a) -> CoEmitter IO (Gap, a)+gaps e = evalEmitter Nothing $ Emitter $ do+ r <- lift $ emit e case r of- Nothing -> pure mempty- Just (l0, _) -> do- t0 <- getCurrentTime- let ua = diffLocalTime (utcToLocalTime utc t0) l0- let delta u = addLocalTime ua $ addLocalTime (toNominalDiffTime (fromNominalDiffTime (diffLocalTime u l0) * speed)) l0- pure (mapE (\(l, a) -> pure (Just (delta l, a))) e)+ Nothing -> pure Nothing+ Just a' -> do+ t' <- get+ let delta u = maybe 0 (fromNominalDiffTime . diffLocalTime u) t'+ put (Just $ fst a')+ pure $ Just $ first delta a' --- | simulate a delay from a (Stamped a) Emitter relative to the first timestamp-simulate :: Double -> Emitter IO (LocalTime, a) -> Cont IO (Emitter IO a)-simulate speed e = Cont $ \eaction -> do- e' <- playback speed e- eaction (emitOn e')+-- | Convert gaps in seconds to stamps starting from an initial supplied 'LocalTime'+fromGaps :: LocalTime -> Emitter IO (Gap, a) -> CoEmitter IO (LocalTime, a)+fromGaps t0 e = evalEmitter t0 $ Emitter $ do+ r <- lift $ emit e+ case r of+ Nothing -> pure Nothing+ Just a' -> do+ t' <- get+ let t'' = addLocalTime (toNominalDiffTime (fst a')) t'+ put t''+ pure $ Just (t'', snd a')++-- | Convert gaps in seconds to stamps starting with current time+--+-- > toListM <$|> (fromGapsNow =<< (qList (zip (0:repeat 1) [1..4])))+-- > [(2022-08-30 22:57:33.835228,1),(2022-08-30 22:57:34.835228,2),(2022-08-30 22:57:35.835228,3),(2022-08-30 22:57:36.835228,4)]+fromGapsNow :: Emitter IO (Gap, a) -> CoEmitter IO (LocalTime, a)+fromGapsNow e = do+ t0 <- liftIO getCurrentTime+ fromGaps (utcToLocalTime utc t0) e++-- | Convert a (Gap,a) emitter to an a emitter, with delays between emits of the gap.+gapEffect ::+ Emitter IO (Gap, a) ->+ Emitter IO a+gapEffect as =+ Emitter $ do+ a <- emit as+ case a of+ (Just (s, a')) -> sleep s >> pure (Just a')+ _ -> pure Nothing++-- | Using the Gap emitter, adjust the Gap for a (Gap, a) emitter+speedEffect ::+ Emitter IO Gap ->+ Emitter IO (Gap, a) ->+ Emitter IO a+speedEffect speeds as =+ Emitter $ do+ s <- emit speeds+ a <- emit as+ case (s, a) of+ (Just s', Just (g, a')) -> sleep (g / s') >> pure (Just a')+ _ -> pure Nothing++-- | Only add a Gap effect if greater than the Int emitter+--+-- effect is similar to a fast-forward of the first n emits+gapSkipEffect ::+ Emitter IO Int ->+ Emitter IO Gap ->+ CoEmitter IO Gap+gapSkipEffect n e = evalEmitter 0 $ Emitter $ do+ n' <- lift $ emit n+ e' <- lift $ emit e+ count <- get+ modify (1 +)+ case (n', e') of+ (_, Nothing) -> pure Nothing+ (Nothing, _) -> pure Nothing+ (Just n'', Just e'') ->+ pure $ Just (bool e'' 0 (n'' >= count))++-- | Only add a Gap if greater than the Int emitter+--+-- effect is similar to a fast-forward of the first n emits+speedSkipEffect ::+ Emitter IO (Int, Gap) ->+ Emitter IO (Gap, a) ->+ CoEmitter IO a+speedSkipEffect p e = evalEmitter 0 $ Emitter $ do+ p' <- lift $ emit p+ e' <- lift $ emit e+ count <- get+ modify (1 +)+ case (p', e') of+ (_, Nothing) -> pure Nothing+ (Nothing, _) -> pure Nothing+ (Just (n, s), Just (g, a)) ->+ lift $ sleep (bool (g / s) 0 (n >= count)) >> pure (Just a)++-- | Ignore the first n gaps and immediately emit them.+skip :: Int -> Emitter IO (Gap, a) -> CoEmitter IO (Gap, a)+skip sk e = evalEmitter (sk + 1) $ Emitter $ do+ skip' <- get+ e' <- lift $ emit e+ case e' of+ Nothing -> pure Nothing+ Just (secs, a) -> do+ case skip' of+ 0 -> pure (Just (secs, a))+ _ -> do+ put (skip' - 1)+ pure (Just (0, a))++-- | Replay a stamped emitter, adjusting the speed of the replay.+--+-- > toListM . stampE <$|> (replay 0.1 1 =<< (fromGapsNow =<< (qList (zip (0:repeat 1) [1..4]))))+-- > [(2022-08-31 02:29:39.643831,1),(2022-08-31 02:29:39.643841,2),(2022-08-31 02:29:39.746998,3),(2022-08-31 02:29:39.849615,4)]+replay :: Double -> Int -> Emitter IO (LocalTime, a) -> CoEmitter IO a+replay speed sk e = gapEffect . fmap (first (speed *)) <$> (skip sk =<< gaps e)
− stack.yaml
@@ -1,13 +0,0 @@-resolver: nightly-2020-11-19--packages:- - .--extra-deps:- - numhask-0.7.1.0- - protolude-0.3.0- - random-1.2.0- - splitmix-0.1.0.3- - numhask-space-0.7.1.0--allow-newer: true
− test/test.hs
@@ -1,15 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# OPTIONS_GHC -Wall #-}--module Main where--import NumHask.Prelude-import Test.DocTest--main :: IO ()-main = doctest- [ "src/Box.hs",- -- "src/Box/Committer.hs",- "src/Box/IO.hs"- -- "app/websocket-tests.hs"- ]