box 0.8.0 → 0.8.1
raw patch · 11 files changed
+83/−88 lines, 11 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Box.Codensity: (<$|>) :: (a -> m r) -> Codensity m a -> m r
+ Box.Codensity: (<$|>) :: forall a m r. (a -> m r) -> Codensity m a -> m r
- Box.Codensity: process :: (a -> m r) -> Codensity m a -> m r
+ Box.Codensity: process :: forall a m r. (a -> m r) -> Codensity m a -> m r
Files
- box.cabal +14/−14
- src/Box.hs +2/−2
- src/Box/Box.hs +9/−12
- src/Box/Codensity.hs +3/−4
- src/Box/Committer.hs +2/−3
- src/Box/Connectors.hs +8/−7
- src/Box/Emitter.hs +24/−25
- src/Box/Functor.hs +8/−7
- src/Box/IO.hs +2/−3
- src/Box/Queue.hs +10/−10
- src/Box/Time.hs +1/−1
box.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: box-version: 0.8.0+version: 0.8.1 synopsis: boxes description: A profunctor effect category: project@@ -41,18 +41,18 @@ -Wunused-packages build-depends:- , base >=4.7 && <5- , concurrency ^>=1.11- , containers ^>=0.6- , contravariant ^>=1.5- , exceptions ^>=0.10- , mtl ^>=2.2.2- , profunctors ^>=5.6- , text ^>=1.2- , time ^>=1.9- , transformers ^>=0.5- , kan-extensions ^>=5.2- , semigroupoids ^>=5.3- , dlist ^>=1.0+ , 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
src/Box.hs view
@@ -26,14 +26,14 @@ where import Box.Box+import Box.Codensity import Box.Committer import Box.Connectors-import Box.Codensity import Box.Emitter+import Box.Functor import Box.IO import Box.Queue import Box.Time-import Box.Functor -- $setup -- >>> :set -XOverloadedStrings
src/Box/Box.hs view
@@ -25,26 +25,26 @@ ) where +import Box.Codensity import Box.Committer import Box.Emitter+import Box.Functor import Control.Applicative ( Alternative (empty, (<|>)), Applicative (liftA2), )+import Control.Monad.State.Lazy+import Data.Bool import Data.Functor.Contravariant (Contravariant (contramap)) import Data.Functor.Contravariant.Divisible ( Decidable (choose, lose), Divisible (conquer, divide), ) import Data.Profunctor (Profunctor (dimap))-import Data.Void (Void, absurd)-import Prelude hiding ((.), id)-import Box.Codensity-import Control.Monad.State.Lazy-import qualified Data.Sequence as Seq-import Data.Bool import Data.Semigroupoid-import Box.Functor+import qualified Data.Sequence as Seq+import Data.Void (Void, absurd)+import Prelude hiding (id, (.)) -- $setup -- >>> :set -XOverloadedStrings@@ -58,7 +58,6 @@ -- 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@@ -103,7 +102,6 @@ -- >>> 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) @@ -114,7 +112,6 @@ -- 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 (witherE f e) @@ -167,7 +164,7 @@ 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) }+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)+ o (CoBoxM b) (CoBoxM b') = CoBoxM (dotco b' b)
src/Box/Codensity.hs view
@@ -48,8 +48,8 @@ -- 1 -- 2 -- 3-process :: (a -> m r) -> Codensity m a -> m r-process = flip runCodensity+process :: forall a m r. (a -> m r) -> Codensity m a -> m r+process f k = runCodensity k f infixr 3 <$|> @@ -59,9 +59,8 @@ -- 1 -- 2 -- 3-(<$|>) :: (a -> m r) -> Codensity m a -> m r+(<$|>) :: forall a m r. (a -> m r) -> Codensity m a -> m r (<$|>) = process- infixr 3 <*|>
src/Box/Committer.hs view
@@ -18,14 +18,14 @@ ) 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 Data.Void import Prelude-import Box.Codensity (Codensity)-import Box.Functor -- $setup -- >>> :set -XOverloadedStrings@@ -40,7 +40,6 @@ -- >>> commit toStdout "I'm committed!" -- I'm committed! -- True--- newtype Committer m a = Committer { commit :: a -> m Bool }
src/Box/Connectors.hs view
@@ -24,9 +24,10 @@ where import Box.Box-import Box.Committer import Box.Codensity+import Box.Committer import Box.Emitter+import Box.Functor import Box.Queue import Control.Concurrent.Classy.Async as C import Control.Monad.Conc.Class (MonadConc)@@ -34,7 +35,6 @@ import Data.Foldable import qualified Data.Sequence as Seq import Prelude-import Box.Functor -- $setup -- >>> :set -XOverloadedStrings@@ -47,7 +47,6 @@ -- -- >>> 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)) @@ -112,7 +111,6 @@ -- -- >>> l1 -- [1,2,3]--- forkEmit :: (Monad m) => Emitter m a -> Committer m a -> Emitter m a forkEmit e c = Emitter $ do@@ -141,9 +139,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+concurrentE ::+ MonadConc f =>+ Queue a ->+ Emitter f a ->+ Emitter f a ->+ CoEmitter f a concurrentE q e e' = Codensity $ \eaction -> snd . fst <$> C.concurrently (queue q (`glue` e) eaction) (queue q (`glue` e') eaction)
src/Box/Emitter.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -7,7 +8,6 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-}-{-# LANGUAGE AllowAmbiguousTypes #-} -- | `emit` module Box.Emitter@@ -20,18 +20,18 @@ takeE, takeUntilE, pop,-)+ ) where +import Box.Functor import Control.Applicative+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.Text (Text, pack, unpack) import Prelude-import Control.Monad.Codensity-import Box.Functor-import qualified Data.Sequence as Seq-import qualified Data.DList as D -- $setup -- >>> :set -XOverloadedStrings@@ -69,13 +69,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@@ -88,7 +88,7 @@ Nothing -> emit i Just a -> pure (Just a) - -- | Zero or more.+ -- Zero or more. many e = Emitter $ Just <$> toListM e instance (Alternative m, Monad m) => MonadPlus (Emitter m) where@@ -104,7 +104,6 @@ mappend = (<>) - -- | This fold completes on the first Nothing emitted, which may not be what you want. instance FoldableM Emitter where foldrM acc begin e =@@ -159,20 +158,20 @@ unlistE :: (Monad m) => Emitter m [a] -> Emitter (StateT [a] m) a unlistE es = Emitter unlists where- -- unlists :: (Monad m) => StateT [a] m (Maybe a)- unlists = do- rs <- get- 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)+ -- unlists :: (Monad m) => StateT [a] m (Maybe a)+ unlists = do+ rs <- get+ 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) -- | Take n emits. --@@ -181,7 +180,7 @@ -- [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)+ Emitter $ get >>= \n' -> bool (pure Nothing) (put (n' + 1) >> lift e) (n' < n) -- | Take from an emitter until a predicate. --
src/Box/Functor.hs view
@@ -1,17 +1,18 @@-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE AllowAmbiguousTypes #-}--- |+{-# LANGUAGE RankNTypes #-} +--+ module Box.Functor- (- FFunctor (..),+ ( FFunctor (..), FoldableM (..),- ) where+ )+where -import Prelude import Data.Kind+import Prelude -- | An endofunctor in the category of endofunctors. --
src/Box/IO.hs view
@@ -26,21 +26,21 @@ ) where +import Box.Codensity import Box.Committer import Box.Connectors-import Box.Codensity import Box.Emitter import qualified Control.Concurrent.Classy.IORef as C import Control.Exception import qualified Control.Monad.Conc.Class as C import Data.Bool import Data.Foldable+import Data.Functor.Contravariant import qualified Data.Sequence as Seq import Data.Text as Text import Data.Text.IO as Text import System.IO as IO import Prelude-import Data.Functor.Contravariant -- $setup -- >>> :set -XOverloadedStrings@@ -140,7 +140,6 @@ -- >>> glue c1 <$|> qList [1..3] -- >>> l1 -- [1,2,3]--- refCommitter :: (C.MonadConc m) => m (Committer m a, m [a]) refCommitter = do ref <- C.newIORef Seq.empty
src/Box/Queue.hs view
@@ -22,16 +22,16 @@ where import Box.Box-import Box.Committer import Box.Codensity+import Box.Committer 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.Monad.Catch as C import Control.Monad.Conc.Class as C import Prelude-import Box.Functor -- $setup -- >>> :set -XOverloadedStrings@@ -47,29 +47,29 @@ | Newest Int | New --- | create a queue, returning the ends+-- | create a queue, supplying the ends and a sealing function. ends :: MonadSTM stm => 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@@ -173,7 +173,7 @@ (Queue a -> m (Box m a a, m ())) -> (Committer m a -> m l) -> (Emitter m a -> m r) ->- m (l,r)+ m (l, r) withQ q spawner cio eio = C.bracket (spawner q)
src/Box/Time.hs view
@@ -20,12 +20,12 @@ import Box.Codensity import Box.Emitter+import Control.Applicative import Control.Monad.Conc.Class as C import Control.Monad.IO.Class import Data.Fixed (Fixed (MkFixed)) import Data.Time import Prelude-import Control.Applicative -- $setup -- >>> :set -XOverloadedStrings