box 0.9.1 → 0.9.2.0
raw patch · 12 files changed
+187/−175 lines, 12 filesdep ~bytestringdep ~semigroupoidsPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: bytestring, semigroupoids
API changes (from Hackage documentation)
- Box.Codensity: instance GHC.Base.Semigroup a => GHC.Base.Semigroup (Control.Monad.Codensity.Codensity m a)
+ Box.Box: CommitterClosed :: Closure
+ Box.Box: EmitterClosed :: Closure
+ Box.Box: data Closure
+ Box.Box: glue' :: Monad m => Committer m a -> Emitter m a -> m Closure
+ Box.Box: instance GHC.Classes.Eq Box.Box.Closure
+ Box.Box: instance GHC.Classes.Ord Box.Box.Closure
+ Box.Box: instance GHC.Show.Show Box.Box.Closure
+ Box.Codensity: instance forall k a (m :: k -> *). GHC.Base.Semigroup a => GHC.Base.Semigroup (Control.Monad.Codensity.Codensity m a)
+ Box.Emitter: filterE :: Monad m => (a -> m (Maybe b)) -> Emitter m a -> Emitter m b
Files
- ChangeLog.md +0/−4
- box.cabal +74/−15
- src/Box.hs +5/−15
- src/Box/Box.hs +31/−13
- src/Box/Codensity.hs +4/−9
- src/Box/Committer.hs +6/−16
- src/Box/Connectors.hs +5/−14
- src/Box/Emitter.hs +34/−24
- src/Box/Functor.hs +2/−6
- src/Box/IO.hs +20/−37
- src/Box/Queue.hs +0/−10
- src/Box/Time.hs +6/−12
− ChangeLog.md
@@ -1,4 +0,0 @@-0.7.0-===--* Removed numhask dependencies
box.cabal view
@@ -1,8 +1,8 @@ cabal-version: 2.4 name: box-version: 0.9.1-synopsis: boxes-description: A profunctor effect+version: 0.9.2.0+synopsis: A profunctor effect system.+description: This might be a profunctor effect system, but unlike all the others. See the project readme.org for usage and discussion: https://github.com/tonyday567/box#readme.org category: project homepage: https://github.com/tonyday567/box#readme bug-reports: https://github.com/tonyday567/box/issues@@ -13,14 +13,80 @@ license-file: LICENSE build-type: Simple tested-with:- GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.2.5 || ==9.4.4-extra-source-files: ChangeLog.md+ GHC ==8.10.7 || ==9.2.8 || ==9.4.5 || ==9.6.2+extra-source-files: source-repository head type: git location: https://github.com/tonyday567/box +common ghc2021-stanza+ if impl(ghc >=9.2)+ default-language:+ GHC2021+ if impl(ghc <9.2)+ default-language:+ Haskell2010+ default-extensions:+ BangPatterns+ BinaryLiterals+ ConstrainedClassMethods+ ConstraintKinds+ DeriveDataTypeable+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveLift+ DeriveTraversable+ DoAndIfThenElse+ EmptyCase+ EmptyDataDecls+ EmptyDataDeriving+ ExistentialQuantification+ ExplicitForAll+ FlexibleContexts+ FlexibleInstances+ ForeignFunctionInterface+ GADTSyntax+ GeneralisedNewtypeDeriving+ HexFloatLiterals+ ImplicitPrelude+ InstanceSigs+ KindSignatures+ MonomorphismRestriction+ MultiParamTypeClasses+ NamedFieldPuns+ NamedWildCards+ NumericUnderscores+ PatternGuards+ PolyKinds+ PostfixOperators+ RankNTypes+ RelaxedPolyRec+ ScopedTypeVariables+ StandaloneDeriving+ StarIsType+ TraditionalRecordSyntax+ TupleSections+ TypeApplications+ TypeOperators+ TypeSynonymInstances+ if impl(ghc <9.2) && impl(ghc >=8.10)+ default-extensions:+ ImportQualifiedPost+ StandaloneKindSignatures++common ghc-options-stanza+ ghc-options:+ -Wall+ -Wcompat+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wredundant-constraints+ library+ import: ghc2021-stanza+ import: ghc-options-stanza exposed-modules: Box Box.Box@@ -34,16 +100,10 @@ Box.Time hs-source-dirs: src- default-extensions:- ghc-options:- -Wall -Wcompat -Wincomplete-record-updates- -Wincomplete-uni-patterns -Wredundant-constraints- -funbox-strict-fields- build-depends: , async ^>= 2.2- , base >=4.7 && <5- , bytestring ^>=0.11+ , base >=4.7 && <5+ , bytestring >=0.11 && <0.13 , containers ^>=0.6 , contravariant ^>=1.5 , dlist ^>=1.0@@ -51,9 +111,8 @@ , kan-extensions ^>=5.2 , mtl >=2.2.2 && <2.4 , profunctors ^>=5.6- , semigroupoids ^>=5.3+ , semigroupoids >=5.3 && <6.1 , stm ^>= 2.5.1 , text >=1.2 && < 2.1 , time >=1.9 && <1.13 - default-language: Haskell2010
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,6 +12,8 @@ bmap, foistb, glue,+ Closure (..),+ glue', glueN, glueES, glueS,@@ -35,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),@@ -44,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@@ -92,6 +92,24 @@ -- 3 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. --
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.@@ -33,7 +28,7 @@ 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@@ -53,7 +48,7 @@ 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]
src/Box/Connectors.hs view
@@ -1,12 +1,3 @@-{-# 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,@@ -36,9 +27,11 @@ import Box.Functor import Box.Queue 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@@ -48,7 +41,7 @@ -- >>> import Data.Bool -- >>> import Control.Monad --- | Queue a list Unbounded.+-- | Queue a list 'Unbounded'. -- -- >>> pushList <$|> qList [1,2,3] -- [1,2,3]@@ -91,11 +84,9 @@ a <- emit e forM_ a f --- FIXME: This doctest sometimes fails with the last value not being printed. Hypothesis: the pipe collapses before the console print effect happens.- -- | Create a finite Committer Unbounded Queue. ----- > glue <$> sink 2 print <*|> qList [1..3]+-- >>> glue <$> sink 2 print <*|> qList [1..3] -- 1 -- 2 sink :: Int -> (a -> IO ()) -> CoCommitter IO a
src/Box/Emitter.hs view
@@ -1,21 +1,14 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -Wall #-}-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-}+{-# LANGUAGE ExplicitNamespaces #-} --- | `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,@@ -27,11 +20,12 @@ 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 @@ -42,9 +36,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@@ -120,10 +112,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@@ -134,12 +125,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) =>@@ -155,7 +165,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@@ -178,7 +188,7 @@ -- | 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) =@@ -196,7 +206,7 @@ -- | 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,12 +1,4 @@-{-# 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@@ -48,7 +40,7 @@ import Data.Function import Data.Functor.Contravariant import Data.IORef-import qualified Data.Sequence as Seq+import Data.Sequence qualified as Seq import Data.String import Data.Text as Text hiding (null) import Data.Text.IO as Text@@ -94,11 +86,9 @@ fromStdinN :: Int -> CoEmitter IO Text fromStdinN n = source n Text.getLine --- FIXME: This doctest sometimes fails with the last value not being printed. Hypothesis: the pipe collapses before the console print effect happens.- -- | Finite console committer ----- > glue <$> contramap (pack . show) <$> (toStdoutN 2) <*|> qList [1..3]+-- >>> glue <$> contramap (pack . show) <$> (toStdoutN 2) <*|> qList [1..3] -- 1 -- 2 toStdoutN :: Int -> CoCommitter IO Text@@ -106,12 +96,12 @@ -- | Read from console, throwing away read errors ----- λ> glueN 2 showStdout (readStdin :: Emitter IO Int)--- 1--- 1--- hippo--- 2--- 2+-- > λ> 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 @@ -125,11 +115,6 @@ showStdout = contramap (Text.pack . show) toStdout -- | Emits lines of Text from a handle.--- handleEText = handleE Text.hGetLine---- handleEBS = handleE Char8.hGetLine---- | Emits lines of Text from a handle. handleE :: (IsString a, Eq a) => (Handle -> IO a) -> Handle -> Emitter IO a handleE action h = Emitter $ do l :: (Either IOException a) <- try (action h)@@ -143,13 +128,7 @@ action h a pure True --- | Commit lines of Text to a handle.--- handleCBS = handleC Char8.hPutStrLn---- | Emits lines of Text from a handle.--- handleCText = handleC Text.hPutStrLn---- | Emit lines of Text from a file.+-- | Emit from a file. fileE :: FilePath -> BufferMode -> IOMode -> (Handle -> Emitter IO a) -> CoEmitter IO a fileE fp b m action = Codensity $ \eio -> withFile@@ -160,13 +139,15 @@ eio (action h) ) +-- | Emit lines of Text from a file. fileEText :: FilePath -> BufferMode -> CoEmitter IO Text fileEText fp b = fileE fp b ReadMode (handleE Text.hGetLine) +-- | 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 to a file.+-- | Commit to a file. fileC :: FilePath -> IOMode -> BufferMode -> (Handle -> Committer IO a) -> CoCommitter IO a fileC fp m b action = Codensity $ \cio -> withFile@@ -177,9 +158,11 @@ 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) @@ -251,12 +234,12 @@ -- | quit a process based on a Bool emitter -- -- > quit <$> speedEffect (pure 2) <$> (resetGap 5) <*|> pure io--- 0--- 1--- 2--- 3--- 4--- Left True+-- > 0+-- > 1+-- > 2+-- > 3+-- > 4+-- > Left True quit :: Emitter IO Bool -> IO a -> IO (Either Bool a) quit flag io = race (checkE flag) io
src/Box/Queue.hs view
@@ -1,13 +1,3 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# 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 (..),
src/Box/Time.hs view
@@ -1,12 +1,3 @@-{-# 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,@@ -78,12 +69,13 @@ Emitter IO (LocalTime, a) stampE = witherE (fmap Just . stampNow) +-- | Usually represents seconds. type Gap = Double -- | 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)]+-- > [(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@@ -110,7 +102,7 @@ -- | 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)]+-- > [(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@@ -127,6 +119,7 @@ (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) ->@@ -175,6 +168,7 @@ (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@@ -191,6 +185,6 @@ -- | 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)]+-- > [(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)