box 0.8.1 → 0.9.4.0
raw patch · 14 files changed
Files
- ChangeLog.md +11/−2
- LICENSE +1/−1
- box.cabal +52/−41
- readme.md +300/−0
- src/Box.hs +5/−15
- src/Box/Box.hs +53/−16
- src/Box/Codensity.hs +6/−11
- src/Box/Committer.hs +7/−18
- src/Box/Connectors.hs +76/−43
- src/Box/Emitter.hs +44/−24
- src/Box/Functor.hs +2/−6
- src/Box/IO.hs +157/−45
- src/Box/Queue.hs +69/−78
- src/Box/Time.hs +136/−55
ChangeLog.md view
@@ -1,4 +1,13 @@-0.7.0+0.9.4 === -* Removed numhask dependencies+- 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.
box.cabal view
@@ -1,25 +1,60 @@-cabal-version: 2.4-name: box-version: 0.8.1-synopsis: boxes-description: A profunctor effect-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-tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.2.1-extra-source-files: ChangeLog.md+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+ 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@@ -32,27 +67,3 @@ 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- -Wunused-packages-- build-depends:- , base >=4.7 && <5- , concurrency ^>=1.11- , containers ^>=0.6- , contravariant ^>=1.5- , dlist ^>=1.0- , exceptions ^>=0.10- , kan-extensions ^>=5.2- , mtl ^>=2.2.2- , profunctors ^>=5.6- , semigroupoids ^>=5.3- , text ^>=1.2- , time ^>=1.9- , transformers ^>=0.5-- default-language: Haskell2010
+ readme.md view
@@ -0,0 +1,300 @@+[](https://hackage.haskell.org/package/box) [](https://github.com/tonyday567/box/actions/workflows/haskell-ci.yml)++A profunctor effect system.++> 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+++# Usage++ :set -XOverloadedStrings+ import Box+ import Prelude+ import Data.Function+ import Data.Bool++Standard IO echoing:++ echoC = Committer (\s -> putStrLn ("echo: " <> s) >> pure True)+ echoE = Emitter (getLine & fmap (\x -> bool (Just x) Nothing (x =="quit")))+ glue echoC echoE++ hello+ echo: hello+ echo+ echo: echo+ quit++Committing to a list:++ > toListM echoE+ hello+ echo+ quit+ ["hello","echo"]++Emitting from a list:++ > glue echoC <$|> witherE (\x -> bool (pure (Just x)) (pure Nothing) (x=="quit")) <$> (qList ["hello", "echo", "quit"])+ echo: hello+ echo: echo+++# Library Design+++### Resource Coinduction++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.++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:++ :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,23 +1,13 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RebindableSyntax #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StrictData #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -Wall #-}---- | A profunctor effect+-- | 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 ( -- $usage- module Box.Box, module Box.Committer,- module Box.Connectors,- module Box.Codensity, module Box.Emitter,+ module Box.Box,+ module Box.Codensity,+ module Box.Connectors, module Box.Functor, module Box.IO, module Box.Queue,
src/Box/Box.hs view
@@ -1,14 +1,10 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StrictData #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -Wall #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-}---- | A box is something that 'commit's and 'emit's+-- | 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,@@ -16,7 +12,11 @@ bmap, foistb, glue,+ Closure (..),+ glue', glueN,+ glueES,+ glueS, fuse, Divap (..), DecAlt (..),@@ -33,8 +33,10 @@ ( 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 ( Decidable (choose, lose),@@ -42,9 +44,9 @@ ) import Data.Profunctor (Profunctor (dimap)) import Data.Semigroupoid-import qualified Data.Sequence as Seq+import Data.Sequence qualified as Seq import Data.Void (Void, absurd)-import Prelude hiding (id, (.))+import Prelude hiding (id, liftA2, (.)) -- $setup -- >>> :set -XOverloadedStrings@@ -52,6 +54,7 @@ -- >>> 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'. --@@ -90,6 +93,40 @@ glue :: (Monad m) => Committer m a -> Emitter m a -> m () glue c e = fix $ \rec -> emit e >>= maybe (pure False) (commit c) >>= bool (pure ()) rec +-- | 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.+--+-- >>> 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)++-- | 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++-- | Connect a Stateful emitter to a (similarly-stateful) committer of the same type, supplying initial state.+--+-- >>> 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..]@@ -102,7 +139,7 @@ -- >>> 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 :: (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.@@ -127,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 @@ -156,7 +193,7 @@ 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 :: (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'
src/Box/Codensity.hs view
@@ -1,8 +1,3 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -Wno-orphans #-} -- | Extra Codensity operators.@@ -28,12 +23,12 @@ instance (Semigroup a) => Semigroup (Codensity m a) where (<>) = liftA2 (<>) -instance (Functor m, Semigroup a, Monoid a) => Monoid (Codensity m a) where+instance (Functor m, Monoid a) => Monoid (Codensity m a) where mempty = pure mempty mappend = (<>) --- | close a continuation+-- | close the Codensity continuation. -- -- >>> close $ glue showStdout <$> qList [1..3] -- 1@@ -42,7 +37,7 @@ close :: Codensity m (m r) -> m r close x = runCodensity x id --- | fmap then close over a Codensity+-- | fmap then close a continuation. -- -- >>> process (glue showStdout) (qList [1..3]) -- 1@@ -51,9 +46,9 @@ process :: forall a m r. (a -> m r) -> Codensity m a -> m r process f k = runCodensity k f -infixr 3 <$|>+infixr 0 <$|> --- | fmap then close over a Codensity+-- | fmap then close a continuation. -- -- >>> glue showStdout <$|> qList [1..3] -- 1@@ -64,7 +59,7 @@ infixr 3 <*|> --- | apply to a continuation and close.+-- | apply and then close a continuation. -- -- >>> glue <$> (pure showStdout) <*|> qList [1..3] -- 1
src/Box/Committer.hs view
@@ -1,14 +1,6 @@-{-# 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 (..), CoCommitter,@@ -23,7 +15,7 @@ import Control.Monad.State.Lazy import Data.Functor.Contravariant import Data.Functor.Contravariant.Divisible-import qualified Data.Sequence as Seq+import Data.Sequence qualified as Seq import Data.Void import Prelude @@ -33,9 +25,7 @@ -- >>> import Box -- >>> import Data.Bool --- | A Committer 'commit's values of type a and signals success or otherwise. A Sink and 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 '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. -- -- >>> commit toStdout "I'm committed!" -- I'm committed!@@ -93,7 +83,7 @@ Nothing -> pure True Just fb' -> commit c fb' --- | Convert a committer to be a list committer. Think mconcat.+-- | Convert a committer to be a list committer. -- -- >>> glue showStdout <$|> qList [[1..3]] -- [1,2,3]@@ -103,8 +93,7 @@ -- 2 -- 3 listC :: (Monad m) => Committer m a -> Committer m [a]-listC c = Committer $ \as ->- or <$> sequence (commit c <$> as)+listC c = Committer $ fmap or . mapM (commit c) -- | Push to a state sequence. --
src/Box/Connectors.hs view
@@ -1,25 +1,22 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RebindableSyntax #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -Wall #-}- -- | Various ways to connect things up. module Box.Connectors ( qList,+ qListWith, popList, pushList, pushListN, sink,+ sinkWith, source,+ sourceWith, forkEmit, bufferCommitter, bufferEmitter, concurrentE, concurrentC,+ takeQ,+ evalEmitter,+ evalEmitterWith, ) where @@ -29,11 +26,12 @@ import Box.Emitter import Box.Functor import Box.Queue-import Control.Concurrent.Classy.Async as C-import Control.Monad.Conc.Class (MonadConc)+import Control.Concurrent.Async+import Control.Monad import Control.Monad.State.Lazy import Data.Foldable-import qualified Data.Sequence as Seq+import Data.Functor+import Data.Sequence qualified as Seq import Prelude -- $setup@@ -43,21 +41,28 @@ -- >>> import Data.Bool -- >>> import Control.Monad --- | Queue a list.+-- | Queue a list 'Unbounded'. -- -- >>> pushList <$|> qList [1,2,3] -- [1,2,3]-qList :: (MonadConc m) => [a] -> CoEmitter m a-qList xs = emitQ Unbounded (\c -> fmap and (traverse (commit c) xs))+qList :: [a] -> CoEmitter IO a+qList xs = qListWith Unbounded xs +-- | Queue a list with an explicit 'Queue'.+--+-- >>> 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))+ -- | Directly supply a list to a committer action, via pop. -- -- >>> popList [1..3] showStdout -- 1 -- 2 -- 3-popList :: Monad m => [a] -> Committer m a -> m ()-popList xs c = flip evalStateT (Seq.fromList xs) $ glue (foist lift c) pop+popList :: (Monad m) => [a] -> Committer m a -> m ()+popList xs c = glueES (Seq.fromList xs) c pop -- | Push an Emitter into a list, via push. --@@ -77,32 +82,42 @@ 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 --- | Create a finite Committer.+-- | Create a finite Committer Unbounded Queue. ----- >>> glue <$> sink 2 print <*|> qList [1..3]--- 1--- 2-sink :: (MonadConc m) => Int -> (a -> m ()) -> CoCommitter m a-sink n f = commitQ Unbounded $ replicateM_ n . sink1 f+-- > glue <$> sink 2 print <*|> qList [1..3]+-- > 1+-- > 2+sink :: Int -> (a -> IO ()) -> CoCommitter IO a+sink n f = sinkWith Unbounded n f +-- | 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' --- | Create a finite Emitter.+-- | Create a finite (Co)Emitter Unbounded Queue. -- -- >>> glue toStdout <$|> source 2 (pure "hi") -- hi -- hi-source :: (MonadConc m) => Int -> m a -> CoEmitter m a-source n f = emitQ Unbounded $ replicateM_ n . source1 f+source :: Int -> IO a -> CoEmitter IO a+source n f = sourceWith Unbounded n f +-- | 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])@@ -119,11 +134,11 @@ pure a -- | Buffer a committer.-bufferCommitter :: (MonadConc m) => Committer m a -> CoCommitter m a+bufferCommitter :: Committer IO a -> CoCommitter IO a bufferCommitter c = Codensity $ \caction -> queueL Unbounded caction (glue c) -- | Buffer an emitter.-bufferEmitter :: (MonadConc m) => Emitter m a -> CoEmitter m a+bufferEmitter :: Emitter IO a -> CoEmitter IO a bufferEmitter e = Codensity $ \eaction -> queueR Unbounded (`glue` e) eaction -- | Concurrently run two emitters.@@ -140,13 +155,12 @@ -- > (c,l) <- refCommitter :: IO (Committer IO Int, IO [Int]) -- > close $ glue c <$> (join $ concurrentE Single <$> qList [1..30] <*> qList [40..60]) concurrentE ::- MonadConc f => Queue a ->- Emitter f a ->- Emitter f a ->- CoEmitter f a+ Emitter IO a ->+ Emitter IO a ->+ CoEmitter IO a concurrentE q e e' =- Codensity $ \eaction -> snd . fst <$> C.concurrently (queue q (`glue` e) eaction) (queue q (`glue` e') eaction)+ Codensity $ \eaction -> snd . fst <$> concurrently (queue q (`glue` e) eaction) (queue q (`glue` e') eaction) -- | Concurrently run two committers. --@@ -161,26 +175,45 @@ -- slow: 1 -- slow: 2 -- slow: 3-concurrentC :: (MonadConc m) => Queue a -> Committer m a -> Committer m a -> CoCommitter m a+concurrentC :: Queue a -> Committer IO a -> Committer IO a -> CoCommitter IO a concurrentC q c c' = mergeC <$> eitherC q c c' eitherC ::- (MonadConc m) => Queue a ->- Committer m a ->- Committer m a ->- Codensity m (Either (Committer m a) (Committer m 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+ <$> 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++-- | 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/Emitter.hs view
@@ -1,35 +1,29 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# 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 (..), type CoEmitter, toListM, witherE,+ filterE, readE, unlistE, takeE, takeUntilE,+ dropE, pop, ) where import Box.Functor import Control.Applicative+import Control.Monad import Control.Monad.Codensity import Control.Monad.State.Lazy import Data.Bool-import qualified Data.DList as D-import qualified Data.Sequence as Seq+import Data.DList qualified as D+import Data.Sequence qualified as Seq import Data.Text (Text, pack, unpack) import Prelude @@ -40,9 +34,7 @@ -- >>> import Data.Bool -- >>> import Data.Text (Text) --- | an `Emitter` `emit`s values of type Maybe a. Source & Producer are also appropriate metaphors.------ An Emitter reaches into itself for the value to emit, where itself is an opaque thing from the pov of usage.+-- | 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. -- -- >>> e = Emitter (pure (Just "I'm emitted")) -- >>> emit e@@ -118,10 +110,9 @@ -- | A monadic [Witherable](https://hackage.haskell.org/package/witherable) ----- >>> close $ toListM <$> witherE (\x -> bool (print x >> pure Nothing) (pure (Just x)) (even x)) <$> (qList [1..3])+-- >>> toListM <$|> witherE (\x -> bool (print x >> pure Nothing) (pure (Just x)) (even x)) <$> (qList [1..3]) -- 1--- 3--- [2]+-- [] witherE :: (Monad m) => (a -> m (Maybe b)) -> Emitter m a -> Emitter m b witherE f e = Emitter go where@@ -132,12 +123,31 @@ Just a' -> do fa <- f a' case fa of+ Nothing -> pure Nothing+ Just fa' -> pure (Just fa')++-- | 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 text on error ----- >>> process (toListM . readE) (qList ["1","2","3","four"]) :: IO [Either Text Int]+-- >>> (toListM . readE) <$|> (qList ["1","2","3","four"]) :: IO [Either Text Int] -- [Right 1,Right 2,Right 3,Left "four"] readE :: (Functor m, Read a) =>@@ -153,7 +163,7 @@ -- | Convert a list emitter to a (Stateful) element emitter. -- -- >>> import Control.Monad.State.Lazy--- >>> close $ flip runStateT [] . toListM . unlistE <$> (qList [[0..3],[5..7]])+-- >>> 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 = Emitter unlists@@ -176,15 +186,25 @@ -- | Take n emits. -- -- >>> import Control.Monad.State.Lazy--- >>> close $ flip evalStateT 0 <$> toListM . takeE 4 <$> qList [0..]+-- >>> 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 (Emitter e) = Emitter $ get >>= \n' -> bool (pure Nothing) (put (n' + 1) >> lift e) (n' < n) +-- | 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. ----- >>> process (toListM . takeUntilE (==3)) (qList [0..])+-- >>> (toListM . takeUntilE (==3)) <$|> (qList [0..]) -- [0,1,2] takeUntilE :: (Monad m) => (a -> Bool) -> Emitter m a -> Emitter m a takeUntilE p e = Emitter $ do
src/Box/Functor.hs view
@@ -1,10 +1,6 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-+-- | 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 (..),
src/Box/IO.hs view
@@ -1,43 +1,53 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -Wall #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-} -- | IO effects module Box.IO ( fromStdin, toStdout,+ stdBox, fromStdinN, toStdoutN, readStdin, showStdout,- handleE,- handleC, refCommitter, refEmitter,+ handleE,+ handleC, 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.Emitter-import qualified Control.Concurrent.Classy.IORef as C+import Control.Concurrent.Async import Control.Exception-import qualified Control.Monad.Conc.Class as C+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 qualified Data.Sequence as Seq-import Data.Text as Text+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@@ -70,6 +80,10 @@ toStdout :: Committer IO Text toStdout = Committer $ \a -> Text.putStrLn a >> pure True +-- | 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 emitter -- -- @@@ -91,12 +105,13 @@ -- | Read from console, throwing away read errors ----- λ> glueN 2 showStdout (readStdin :: Emitter IO Int)--- 1--- 1--- hippo--- 2-readStdin :: Read a => Emitter IO a+-- > λ> 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 -- | Show to stdout@@ -105,48 +120,82 @@ -- 1 -- 2 -- 3-showStdout :: Show a => Committer IO a+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 (Text.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- Text.hPutStrLn h a+handleC :: (Handle -> a -> IO ()) -> Handle -> Committer IO a+handleC action h = Committer $ \a -> do+ action h a pure True +-- | 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)+ )+ -- | Emit lines of Text from a file.-fileE :: FilePath -> CoEmitter IO Text-fileE fp = Codensity $ \eio -> withFile fp ReadMode (eio . handleE)+fileEText :: FilePath -> BufferMode -> CoEmitter IO Text+fileEText fp b = fileE fp b ReadMode (handleE Text.hGetLine) --- | Commit lines of Text to a file.-fileWriteC :: FilePath -> CoCommitter IO Text-fileWriteC fp = Codensity $ \cio -> withFile fp WriteMode (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 lines of Text, appending to a file.-fileAppendC :: FilePath -> CoCommitter IO Text-fileAppendC fp = Codensity $ \cio -> withFile fp AppendMode (cio . handleC)+-- | 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 :: (C.MonadConc m) => m (Committer m a, m [a])+refCommitter :: IO (Committer IO a, IO [a]) refCommitter = do- ref <- C.newIORef Seq.empty+ 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@@ -154,14 +203,77 @@ -- >>> e <- refEmitter [1..3] -- >>> toListM e -- [1,2,3]-refEmitter :: (C.MonadConc m) => [a] -> m (Emitter m a)+refEmitter :: [a] -> IO (Emitter IO a) refEmitter xs = do- ref <- C.newIORef xs+ 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,14 +1,3 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StrictData #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -Wall #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-}- -- | STM Queues, based originally on [pipes-concurrency](https://hackage.haskell.org/package/pipes-concurrency) module Box.Queue ( Queue (..),@@ -18,6 +7,11 @@ fromAction, emitQ, commitQ,+ fromActionWith,+ toBoxM,+ toBoxSTM,+ concurrentlyLeft,+ concurrentlyRight, ) where @@ -27,10 +21,9 @@ import Box.Emitter import Box.Functor import Control.Applicative-import Control.Concurrent.Classy.Async as C-import Control.Concurrent.Classy.STM as C+import Control.Concurrent.Async+import Control.Concurrent.STM import Control.Monad.Catch as C-import Control.Monad.Conc.Class as C import Prelude -- $setup@@ -48,7 +41,7 @@ | New -- | create a queue, supplying the ends and a sealing function.-ends :: MonadSTM stm => Queue a -> stm (a -> stm (), stm a)+ends :: Queue a -> STM (a -> STM (), STM a) ends qu = case qu of Bounded n -> do@@ -72,7 +65,7 @@ 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@@ -82,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) toBoxSTM ::- (MonadSTM stm) => Queue a ->- stm (Box stm a a, stm ())+ 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@@ -109,102 +101,91 @@ -- | 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 $ toBoxSTM q pure (liftB b, atomically s) -- | 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 the Committer action to complete. withQL ::- (MonadConc m) => Queue a ->- (Queue a -> m (Box m a a, m ())) ->- (Committer m a -> m l) ->- (Emitter m a -> m r) ->- m l+ (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 =- C.bracket+ 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 the Emitter action to complete. withQR ::- (MonadConc m) => Queue a ->- (Queue a -> m (Box m a a, m ())) ->- (Committer m a -> m l) ->- (Emitter m a -> m r) ->- m r+ (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 =- C.bracket+ 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) ) -- | connect a committer and emitter action via spawning a queue, and wait for both to complete. withQ ::- (MonadConc m) => Queue a ->- (Queue a -> m (Box m a a, m ())) ->- (Committer m a -> m l) ->- (Emitter m a -> m r) ->- m (l, r)+ (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 =- C.bracket+ bracket (spawner q) snd ( \(box, seal) -> concurrently- (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 result from the Committer action.------ >>> queueL New (\c -> glue c <$|> qList [1..3]) toListM queueL ::- (MonadConc m) => Queue a ->- (Committer m a -> m l) ->- (Emitter m a -> m r) ->- m l+ (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 New (\c -> glue c <$|> qList [1..3]) toListM--- [3] queueR ::- (MonadConc m) => Queue a ->- (Committer m a -> m l) ->- (Emitter m a -> m r) ->- m r+ (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.@@ -212,32 +193,42 @@ -- >>> queue Unbounded (\c -> glue c <$|> qList [1..3]) toListM -- ((),[1,2,3]) queue ::- (MonadConc m) => Queue a ->- (Committer m a -> m l) ->- (Emitter m a -> m r) ->- m (l, r)+ (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 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) -> CoBox m b a+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 :: (MonadConc m) => Queue a -> (Committer m a -> m r) -> CoEmitter m a+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 :: (MonadConc m) => Queue a -> (Emitter m a -> m r) -> CoCommitter m a+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,28 +1,28 @@-{-# 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. module Box.Time ( sleep,- Stamped (..), stampNow, stampE,- emitIn,+ Gap,+ gaps,+ fromGaps,+ fromGapsNow,+ gapEffect,+ skip, replay,+ gapSkipEffect,+ speedEffect,+ speedSkipEffect, ) where -import Box.Codensity+import Box.Connectors import Box.Emitter import Control.Applicative-import Control.Monad.Conc.Class as C-import Control.Monad.IO.Class+import Control.Concurrent+import Control.Monad.State.Lazy+import Data.Bifunctor+import Data.Bool import Data.Fixed (Fixed (MkFixed)) import Data.Time import Prelude@@ -33,8 +33,8 @@ -- >>> import Prelude -- | Sleep for x seconds.-sleep :: (MonadConc m) => Double -> m ()-sleep x = C.threadDelay (floor $ x * 1e6)+sleep :: Double -> IO ()+sleep x = threadDelay (floor $ x * 1e6) -- | convenience conversion to Double fromNominalDiffTime :: NominalDiffTime -> Double@@ -52,58 +52,139 @@ t1 = UTCTime (addDays days d0) (picosecondsToDiffTime $ floor (secs / 1.0e-12)) in diffUTCTime t1 t0 --- | A value with a UTCTime annotation.-data Stamped a = Stamped- { stamp :: !UTCTime,- value :: !a- }- deriving (Eq, Show, Read)- -- | 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) -- | Add the current time stamp. -- -- @--- > process (toListM . stampE) (qList [1..3])--- [(2022-02-09 01:18:00.293883,1),(2022-02-09 01:18:00.293899,2),(2022-02-09 01:18:00.293903,3)]+-- > 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)+ Emitter IO a ->+ Emitter IO (LocalTime, a) stampE = witherE (fmap Just . stampNow) --- | Wait s seconds before emitting-emitIn ::- Emitter IO (Double, a) ->- Emitter IO a-emitIn =- witherE- ( \(s, a) -> do- sleep s- pure $ Just a- )+-- | Usually represents seconds.+type Gap = Double --- | Convert emitter stamps to adjusted speed delays-delay :: (Monad m, Alternative m) => Double -> Emitter m (LocalTime, b) -> m (Emitter m (Double, b))-delay 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 (t0, _) -> do- let delta u = fromNominalDiffTime $ diffLocalTime u t0 * toNominalDiffTime speed- pure (witherE (\(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' +-- | 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. ----- @--- > glueN 4 showStdout <$|> replay 1 (Emitter $ sleep 0.1 >> Just <$> stampNow ())--- @-replay :: Double -> Emitter IO (LocalTime, a) -> CoEmitter IO a-replay speed e = Codensity $ \eaction -> do- e' <- delay speed e- eaction (emitIn e')+-- > 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)