diff --git a/app/app.hs b/app/app.hs new file mode 100644 index 0000000..3f85bd0 --- /dev/null +++ b/app/app.hs @@ -0,0 +1,16 @@ +-- | + +module Main where + +import Prelude +import Data.Bool +import Data.Foldable +import Box + +data Teletype m a where + ReadTTY :: Teletype m String + WriteTTY :: String -> Teletype m () + +echo :: (Monad m, Eq a, Monoid a) => Box m a a -> m () +echo = fuse (\x -> bool (pure (Just x)) (pure Nothing) (x == mempty)) + diff --git a/app/speed.hs b/app/speed.hs new file mode 100644 index 0000000..109a442 --- /dev/null +++ b/app/speed.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -Wno-unused-do-bind #-} + +import Control.Applicative +import Control.Monad +import Data.List (intercalate) +import qualified Data.Map.Strict as Map +import Data.Semigroup +import Options.Applicative +import Perf +import Prelude +import Box + +toListMTest :: Int -> IO [Int] +toListMTest n = toListM <$|> qListWith Unbounded [1..n] + +pushListTest :: Int -> IO [Int] +pushListTest n = pushList <$|> (qListWith Unbounded [1..n]) + +data TestType = TestToListM | TestQList | TestDefault deriving (Eq, Show) + +parseTestType :: Parser TestType +parseTestType = + flag' TestToListM (long "toListM" <> help "test toListM speed") + <|> flag' TestQList (long "qList" <> help "test qList speed") + <|> pure TestDefault + +data Options = Options + { optionN :: Int, + optionL :: Int, + optionStatDType :: StatDType, + optionTestType :: TestType, + optionMeasureType :: MeasureType, + optionGolden :: Golden, + optionReportConfig :: ReportConfig, + optionRawStats :: Bool + } + deriving (Eq, Show) + +options :: Parser Options +options = + Options + <$> option auto (value 1000 <> long "runs" <> short 'n' <> help "number of tests to perform") + <*> option auto (value 1000 <> long "length" <> short 'l' <> help "number of emits") + <*> parseStatD + <*> parseTestType + <*> parseMeasure + <*> parseGolden "golden" + <*> parseReportConfig defaultReportConfig + <*> switch (long "raw" <> short 'w' <> help "write raw statistics to file") + +opts :: ParserInfo Options +opts = + info + (options <**> helper) + (fullDesc <> progDesc "box benchmarking" <> header "speed performance") + +main :: IO () +main = do + o <- execParser opts + let !n = optionN o + let !l = optionL o + let t = optionTestType o + let mt = optionMeasureType o + let gold = goldenFromOptions [show mt, show n, show l] (optionGolden o) + let w = optionRawStats o + let raw = "other/" <> intercalate "-" [show mt, show t, show n] <> ".map" + let cfg = optionReportConfig o + + case t of + TestQList -> do + error "nyi" + TestToListM -> do + error "nyi" + TestDefault -> do + m <- fmap (fmap (measureFinalStat mt)) $ + execPerfT (fmap (fmap average) $ measureDs mt n) $ do + _ <- fam "sum fold" (pure $ sum [1..l]) + _ <- fam "toListM" (toListMTest l) + _ <- fam "pushList" (pushListTest l) + + pure () + when w (writeFile raw (show m)) + report cfg gold (measureLabels mt) (Map.mapKeys (: []) (fmap (: []) m)) diff --git a/box.cabal b/box.cabal index efd4611..c8b2c1b 100644 --- a/box.cabal +++ b/box.cabal @@ -115,3 +115,21 @@ library , stm ^>= 2.5.1 , text >=1.2 && < 2.1 , time >=1.9 && <1.13 + +executable box-speed + import: ghc2021-stanza + import: ghc-options-stanza + main-is: speed.hs + hs-source-dirs: + app + build-depends: + base >=4.7 && <5, + box, + perf ^>= 0.11, + containers, + optparse-applicative, + ghc-options: + -funbox-strict-fields + -rtsopts + -threaded + -O2 diff --git a/cabal.project b/cabal.project index 53af291..d46e085 100644 --- a/cabal.project +++ b/cabal.project @@ -1,3 +1,6 @@ packages: box.cabal + ../perf/perf.cabal +allow-newer: numhask-space:semigroupoids, + tdigest:semigroupoids diff --git a/other/MeasureTime-1000-1000.perf b/other/MeasureTime-1000-1000.perf new file mode 100644 index 0000000..bb81d25 --- /dev/null +++ b/other/MeasureTime-1000-1000.perf @@ -0,0 +1 @@ +fromList [(["pushList","time"],1700193.684),(["sum fold","time"],1851.174),(["toListM","time"],1137498.997)] \ No newline at end of file diff --git a/other/TestDefault-1000-1000-MeasureTime.perf b/other/TestDefault-1000-1000-MeasureTime.perf new file mode 100644 index 0000000..365cec6 --- /dev/null +++ b/other/TestDefault-1000-1000-MeasureTime.perf @@ -0,0 +1 @@ +fromList [(["pushList","time"],1639947.761),(["sum fold","time"],1818.752),(["toListM","time"],1123639.039)] \ No newline at end of file diff --git a/readme.org b/readme.org index 1207ddb..1884f22 100644 --- a/readme.org +++ b/readme.org @@ -15,389 +15,185 @@ What is all this stuff around me; this stream of experiences that I seem to be h :set -XOverloadedStrings import Box import Prelude -#+end_src - -* Debugging echo example - -#+begin_src haskell :results output -import Prelude -import Box import Data.Function import Data.Bool -stdC = Committer (\s -> putStrLn s >> pure True) -emitQuit = Emitter (getLine & fmap (\x -> bool (Just x) Nothing (x =="quit"))) -glue stdC emitQuit - -#+end_src - - -** basic narrative -Effects often come in pairs, in two ways, duals that use the same real-world effect system such as standard IO, and effects that bracket a computation. You read from a source (a file, a socket, the screen or an IORef), compute stuff, then write to a target (a file, a socket, the screen or an IORef). - -Starting with the dual of reading and writing lines to standard IO: - - #+begin_src haskell :results output :exports both -:t getLine -:t putStrLn #+end_src #+RESULTS: -: getLine :: IO String -: putStrLn :: String -> IO () +: > -The design of Haskell tends to encourage coinduction for the (effect) functionality either side of a computation. In practice, this means that it is useful to define effects according to their destructors: how do I run an effect until it is exhausted. +Standard IO echoing: #+begin_src haskell -newtype Emitter m a = Emitter - { emit :: m (Maybe a) - } +echoC = Committer (\s -> putStrLn ("echo: " <> s) >> pure True) +echoE = Emitter (getLine & fmap (\x -> bool (Just x) Nothing (x =="quit"))) +glue echoC echoE #+end_src -An emitter returns an 'a' on demand until it doesn't. +#+begin_src +hello +echo: hello +echo +echo: echo +quit +#+end_src + +Committing to a list: #+begin_src haskell -newtype Committer m a = Committer - { commit :: a -> m Bool - } +> toListM echoE +hello +echo +quit +["hello","echo"] #+end_src -You give a committer an 'a', and it tells you whether the consumption of the 'a' was successful or not. - -A Box is just a product of an emitter and committer, so the standard IO box would be: - -#+begin_src haskell -data Box m c e = Box - { committer :: Committer m c, - emitter :: Emitter m e - } -#+end_src - -#+begin_src haskell :results output -stdIO = Box (Committer (\s -> putStrLn s >> pure True)) (Emitter (Just <$> getLine)) -#+end_src +Emitting from a list: -#+RESULTS: #+begin_src haskell :results output -echo = (\string -> bool (pure (Just ("echo: " <> string))) (pure Nothing) (string=="quit")) +> glue echoC <$|> witherE (\x -> bool (pure (Just x)) (pure Nothing) (x=="quit")) <$> (qList ["hello", "echo", "quit"]) +echo: hello +echo: echo #+end_src -#+RESULTS: - - #+begin_src haskell :results output -:t echo - #+end_src - -#+RESULTS: -: echo -: :: (Applicative f, Semigroup a, Data.String.IsString a, Eq a) => -: a - -: f (Maybe a) - - #+begin_src haskell :results output -:t fuse echo stdIO - #+end_src - -#+RESULTS: -: fuse echo stdIO :: IO () - - - - - - -One possible motivation for Haskell laziness - - - -This library grew out of using pipes. I wanted to try out the streaming library but it didn't yet have a concurrency system, so I ripped out the ends management and queues of pipes-concurrency. After a while I realised I was using this functionality ~instead~ of streams. There was often no stream, just pure computes with management of queues and effects at either end. I've used streamly without looking under the hood and the API, at least, seems somewhat familial. +* Library Design -It's a bit of a hodge-podge, but there's a good idea or two in here somewhere I'm sure. +*** Resource Coinduction -- Box.Queue is well balanced and has never raced or blocked. I don't think it can. -- Boxes are as fast as the underlying computation, and you tend not to notice them once they're coded up. -- a Box is a profunctor. In the langauge of optics, it's an adapter, and library extension may expand this into other optics areas. -- Continuation-based coding is very hard (at least for me), but seems less hard with the library in hand. +Haskell has an affinity with [[https://www.reddit.com/r/haskell/comments/j3kbge/comment/g7foelq/?utm_source=share&utm_medium=web2x&context=3][coinductive functions]]; functions should expose destructors and allow for infinite data. -* Usage +The key text, [[https://www.cs.kent.ac.uk/people/staff/dat/miranda/whyfp90.pdf][Why Functional Programming Matters]], details how producers and consumers can be separated by exploiting laziness, so that both ends of a computation can coexist and harmonise without interfering with each others functioning. -#+begin_src haskell -:set prompt "> " -:set -XOverloadedStrings -import Box -import Prelude -#+end_src +Hence the focus in Haskell on the list. Utilising laziness, we can peel off (destruct) the next element to be consumed without disturbing the pipeline of computations that is still to occur, for the cost of a thunk. -#+RESULTS: +So how do this apply 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: -#+begin_src haskell :results output -glue toStdout <$|> qList ["a","b","c"] + #+begin_src haskell :results output :exports both +:t getLine +:t putStrLn #+end_src #+RESULTS: -: a -: b -: c - -* Committing - +: getLine :: IO String +: putStrLn :: String -> IO () -#+begin_src haskell -commit toStdout "I'm committed!" -#+end_src +These are the destructors that need to be transparently exposed if effects are to be good citizens in Haskell. -#+RESULTS: -: I'm committed! -: True +*** What is a Box? -Use witherC to modify a Committer and introduce effects. +A Box is simply the product of a consumer destructor and a producer destructor. #+begin_src haskell -let c = witherC (\a -> if a==2 then (sleep 0.1 >> putStrLn "stole a 2!" >> sleep 0.1 >> pure (Nothing)) else (pure (Just a))) (contramap (pack . show) toStdout) -glue c <$|> qList [1..3] +data Box m c e = Box + { committer :: Committer m c, + emitter :: Emitter m e + } #+end_src -#+RESULTS: -: 1 -: stole a 2! -: 3 +*** Committer -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. - -#+begin_src haskell :results output -let cFast = witherC (\b -> pure (Just b)) . contramap ("fast: " <>) $ toStdout -let cSlow = witherC (\b -> sleep 0.1 >> pure (Just b)) . contramap ("slow: " <>) $ toStdout -glue (cFast <> cSlow) <$|> qList ((pack . show) <$> [1..3]))) <* sleep 1 -#+end_src +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 above types. A better approach, for a consumer, is to signal whether consumption actually occurred. -#+RESULTS: -#+begin_example -fast: 1 -slow: 1 -fast: 2 -slow: 2 -fast: 3 -slow: 3 -#+end_example + #+begin_src haskell +newtype Committer m a = Committer + { commit :: a -> m Bool + } + #+end_src -To approximate what is intuitively expected, use 'concurrentC'. +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: #+begin_src haskell -close $ (popList ((pack . show) <$> [1..3]) <$> (concurrentC cFast cSlow)) <> pure (sleep 1) +stdC :: Committer IO String +stdC = Committer (\s -> putStrLn s >> pure True) #+end_src #+RESULTS: -: fast: 1 -: fast: 2 -: fast: 3 -: slow: 1 -: slow: 2 -: slow: 3 +: :19:1-4: warning: [GHC-63397] [-Wname-shadowing] +: This binding for ‘stdC’ shadows the existing binding +: defined at :16:1 -* Emitting +A Committer is a contravariant functor, so contramap can be used to modify this: #+begin_src haskell -import Data.Function ((&)) -("I'm emitted!") & Just & pure & Emitter & emit >>= print -#+end_src - -#+RESULTS: -: Just "I'm emitted!" - -If asked to, an Emitter will run forever, even if it runs out of stuff: it's just a wrapped effect. +import Data.Text as Text +import Data.Functor.Contravariant -#+begin_src haskell -runCodensity (qList [1]) (\e' -> (emit e' & fmap show) >>= putStrLn & replicate 3 & sequence_) +echoC :: Committer IO Text +echoC = contramap (Text.unpack . ("echo: "<>)) stdC #+end_src -#+RESULTS: -: Just 1 -: Nothing -: Nothing +*** Emitter -The monoid instance is left-biased. +The library denotes a producer by wrapping a production destructor and calling it an Emitter. #+begin_src haskell -process toListM (qList [1..3] <> qList [7..9]) +newtype Emitter m a = Emitter + { emit :: m (Maybe a) + } #+end_src -#+RESULTS: -| 1 | 2 | 3 | 7 | 8 | 9 | - -** ToDo concurrentE (is broken) - -Use concurrentE to get some nondeterministic balance. +An emitter returns an 'a' on demand until it doesn't. #+begin_src haskell :results output -import Control.Monad -let es' = join $ concurrentE <$> qList [1..3] <*> qList [7..9] -process toListM es' +stdE :: Emitter IO String +stdE = Emitter (Just <$> getLine) #+end_src #+RESULTS: -: -: > [1,2,3] -* Gluing -#+begin_quote -This is how we can use a profunctor to glue together two categories ~ Milewski -[[https://bartoszmilewski.com/2019/03/27/promonads-arrows-and-einstein-notation-for-profunctors/][Promonads, Arrows, and Einstein Notation for Profunctors]] -#+end_quote - -~glue~ glues together a Committer and Emitter. Once glued, it will be difficult to tear them apart again. It can probably be done but will be messy. - -Non-fix version of glue: +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. #+begin_src haskell :results output -:{ -import Control.Monad - -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 -:} +echoE :: Emitter IO Text +echoE = witherE (\x -> bool (pure (Just x)) (putStrLn "quitting" *> pure Nothing) (x == "quit")) (fmap Text.pack stdE) #+end_src #+RESULTS: -: ghci| ghci| ghci| ghci| ghci| ghci| ghci| ghci| ghci| ghci| - -#+begin_src haskell :results output -:{ -glue'' :: (Show a) => Committer IO a -> Emitter IO a -> IO () -glue'' c e = go - where - go = do - a <- emit e - putStrLn $ "emitted: " <> show a - c' <- maybe (pure False) (commit c) a - when c' (putStrLn "next go" >> go) -:} -#+end_src +: :52:1-5: warning: [GHC-63397] [-Wname-shadowing] +: This binding for ‘echoE’ shadows the existing binding +: defined at :49:1 -#+RESULTS: -: ghci| ghci| ghci| ghci| ghci| ghci| ghci| ghci| ghci| +*** Box duality +A Box represents a duality in two ways: -#+RESULTS: -#+begin_src haskell :results output -echo = (\string -> bool (pure (Just ("echo: " <> string))) (pure Nothing) (string=="quit")) -#+end_src +1. As the consumer and producer sides of a resource -#+RESULTS: -: :449:1: warning: [GHC-63397] [-Wname-shadowing] -: This binding for ‘echo’ shadows the existing binding -: defined at :375:1 +The complete interface to standard IO, for example, could be: #+begin_src haskell :results output -glue'' (committer stdIO) (witherE echo (emitter stdIO)) -#+end_src - - -** finiteness - -Most committers and emitters will run forever until the glued or fused other-side returns. - -Finite ends (collective noun for emitters and committers) can be created with 'sink' and 'source' eg - -#+begin_src haskell -glue <$> contramap show <$> (sink 5 putStrLn) <*|> qList [1..] -#+end_src - -#+RESULTS: -: 1 -: 2 -: 3 -: 4 -: 5 - -This would run forever, though it would do so momemnt to moment with a minimum of fuss. - -#+begin_src haskell --- glue <$> pure (contramap (pack . show) toStdout) <*|> qList [1..] -#+end_src - -Use glueN to create a finite version of this effect. - - -#+begin_src haskell -glueN 4 <$> pure (contramap (pack . show) toStdout) <*|> qList [1..] -#+end_src - -#+RESULTS: -: 1 -: 2 -: 3 -: 4 - -* Computation points - -There are three points at which change happens: - -** At the Emitter - -An Emitter is a Functor, so anything coming out of it can be fmapped. - -#+begin_src haskell -glue toStdout <$|> fmap (fmap (pack . show)) (qList [1..3]) -#+end_src - -#+RESULTS: -: 1 -: 2 -: 3 - -The first fmap is fmapping over the Codensity layer of qList, and the second fmap is fmapping into Emitter. - -*** witherE - -#+begin_src haskell -filterE p = witherE (\a -> bool (pure (Just a)) (pure Nothing) (p a)) +stdIO :: Box IO String String +stdIO = Box (Committer (\s -> putStrLn s >> pure True)) (Emitter (Just <$> getLine)) #+end_src -** At the Committer - -#+begin_src haskell -import Data.Functor.Contravariant -glue (contramap (pack . show) toStdout) <$|> qList [1..3] -#+end_src - -#+RESULTS: -: 1 -: 2 -: 3 -*** ToDo filterC +2. As two ends of a computation. -** At the intersection of an emitter and committer +#+begin_quote +This is how we can use a profunctor to glue together two categories ~ Milewski +[[https://bartoszmilewski.com/2019/03/27/promonads-arrows-and-einstein-notation-for-profunctors/][Promonads, Arrows, and Einstein Notation for Profunctors]] +#+end_quote -~fuse~ glues an Emitter and Committer contained in a Box by passing emissions to the committers using an intermediary function: +~glue~ is the primitive with which we connect a Committer and Emitter. #+begin_src haskell -:t fuse +> glue echoC echoE +hello +echo: hello +echo +echo: echo +quit +quitting #+end_src -#+RESULTS: -: fuse :: Monad m => (a -> m (Maybe b)) -> Box m b a -> m () +Effectively the same computation, for a box, is: -#+begin_src haskell :results output -import Data.Text (pack) -import Data.Bool -let box' = Box <$> pure toStdout <*> qList ((pack . show) <$> [1..3]) -fuse (\a -> bool (pure $ Just $ "echo: " <> a) (pure Nothing) (a=="2")) <$|> box' -#+end_src - -#+RESULTS: -: echo: 1 -: echo: 3 - - -A future direction of the library may be to add this in to a box. + #+begin_src haskell :results output +fuse (pure . pure) stdIO + #+end_src -* Continuation operators +*** Continuation As with many operators in the library, ~qList~ is actually a continuation: @@ -413,6 +209,14 @@ As with many operators in the library, ~qList~ is actually a continuation: type CoEmitter m a = Codensity m (Emitter m a) #+end_src +Effectively being a newtype wrapper around: + +#+begin_src haskell +forall x. (Emitter m a -> m x) -> m x +#+end_src + +A good background on call-back style programming in Haskell is in the [[https://hackage.haskell.org/package/managed-1.0.10/docs/Control-Monad-Managed.html][managed]] 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: #+begin_src haskell @@ -454,6 +258,10 @@ close $ glue toStdout <$> qList ["a", "b", "c"] : b : c +Given the ubiquity of this method, the library supplies two applicative style operators that combine application and closure. + +1. (<$|>) fmap and close over a Codensity: + #+begin_src haskell glue toStdout <$|> qList ["a", "b", "c"] #+end_src @@ -463,6 +271,8 @@ glue toStdout <$|> qList ["a", "b", "c"] : b : c +2. (<*|>) Apply and close over Codensity + #+begin_src haskell glue <$> pure toStdout <*|> qList ["a", "b", "c"] #+end_src @@ -474,136 +284,40 @@ glue <$> pure toStdout <*|> qList ["a", "b", "c"] * Explicit Continuation -At the tip of stream implementations are coroutines that embed continuation logic. A major drawback of eschewing coroutines is that continuations become explicit and difficult to hide. +Yield-style streaming libraries are [[https://rubenpieters.github.io/assets/papers/JFP20-pipes.pdf][coroutines]], 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: #+begin_src haskell :t takeE takeE :: Monad m => Int -> Emitter m a -> Emitter (StateT Int m) a #+end_src -A disappointing type. The state monad can not quite be hidden: - -#+begin_src haskell --- | Supply takeE with a continuation and escape the state layer. --- --- >>> takeEK 4 <$> qList [0..] <*|> pure toListM --- [0,1,2,3] --- -takeEK :: (Monad m) => Int -> Emitter m a -> (Emitter (StateT Int m) a -> StateT Int m r) -> m r -takeEK n e k = flip evalStateT 0 . k . takeE n $ e -#+end_src - -#+begin_src haskell -takeEK :: (Monad m) => Int -> Emitter m a -> (Emitter (StateT Int m) a -> StateT Int m r) -> m r -takeEK n e k = flip evalStateT 0 . k . takeE n $ e -#+end_src - - -#+begin_src haskell -:t (\s0 k e -> flip evalStateT s0 . k $ e) :: (Monad m) => s -> (Emitter m a -> StateT s m a) -> Emitter m a -> m a -#+end_src - -#+RESULTS: -: (\s0 k e -> flip evalStateT s0 . k $ e) :: (Monad m) => s -> (Emitter m a -> StateT s m a) -> Emitter m a -> m a -: :: Monad m => -: s -> (Emitter m a -> StateT s m a) -> Emitter m a -> m a - -(t f a -> s f a) -> t f a -> f a - -(t f ~> s f) -> t f ~> f - -#+begin_src haskell -:t (\s0 k -> \e -> flip evalStateT s0 . k $ e) -#+end_src - -#+RESULTS: -: (\s0 k -> \e -> flip evalStateT s0 . k $ e) -: :: Monad m => s -> (t -> StateT s m a) -> t -> m a - -#+begin_src haskell -:t Codensity -#+end_src - -#+RESULTS: -: Codensity :: (forall b. (a -> m b) -> m b) -> Codensity 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: #+begin_src haskell :results output -:t \c -> glue (foist lift c) -:t takeE -#+end_src - -#+RESULTS: -: \c -> glue (foist lift c) -: :: (Monad (t f), MonadTrans t, Monad f) => -: Committer f a -> Emitter (t f) a -> t f () -: takeE :: Monad m => Int -> Emitter m a -> Emitter (StateT Int m) a - - - - -* Debugging - -#+begin_src haskell -logE :: - (Show a) => - Emitter IO a -> - Emitter IO a -logE e = Emitter $ do - r <- emit e - print r - pure r - -logEAction :: - (Show a) => - (Emitter IO a -> IO r) -> - (Emitter IO a -> IO r) -logEAction eaction = \e -> eaction (logE e) - --- | create an unbounded queue, returning both results -queueIO :: - (Show a) => - (Committer IO a -> IO l) -> - (Emitter IO a -> IO r) -> - IO (l, r) -queueIO cm em = withQ Unbounded toBoxM cm (logEAction em) - -concurrentELog :: Show a => - Emitter IO a -> Emitter IO a -> Codensity IO (Emitter IO a) -concurrentELog e e' = - Codensity $ \eaction -> snd . fst <$> C.concurrently (queueIO (`glue` e) eaction) (queueIO (`glue` e') eaction) -#+end_src - -#+begin_src haskell --- | take a list, emit it through a box, and output the committed result. +-- | Connect a Stateful emitter to a (non-stateful) committer of the same type, supplying initial state. -- --- 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 (foist (zoom _1) push) (foist (zoom _2) pop)) - pure $ toList res +-- >>> 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 #+end_src * Future directions -This library is at the intersection of many different and current Haskell threads, which means that it could quickly be elided or obviated by future developments. +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. - -** Streamly +A Box is an adapter in the [[http://www.cs.ox.ac.uk/people/jeremy.gibbons/publications/poptics.pdf][language of optics]] and inner links between a spawned resources committers and emitters could be modelled by other optics. -An Emitter looks very similar to an IsStream in streamly +** Categorical Profunctor -The library may be subsumed by this one. +The deprecation of Box.Functor awaits the development of [[https://github.com/haskell/core-libraries-committee/issues/91#issuecomment-1325337471][categorical functors]]. 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 [[https://papers.ssrn.com/sol3/papers.cfm?abstract_id=4496714][Programming with Monoidal Profunctors and Semiarrows]]. -** Wider types +** Wider Types -If the types were widened, it would widen the potential use cases: +Alternatively, the types could be widened: #+begin_src haskell newtype Committer f a = Committer { commit :: a -> f () } @@ -634,9 +348,9 @@ type EmitterB m a = Emitter (MaybeT m) a type BoxB m b a = Box (MaybeT m) (MaybeT m) b a #+end_src -** Introduce a nucleus +** Introduce a [[https://golem.ph.utexas.edu/category/2013/08/the_nucleus_of_a_profunctor_so.html][nucleus]] -Wider types highlights a flaw in the original conception of the library. There are the ends of the computational pipeline, but there is also the gluing/fusion/middle bit. +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. #+begin_src haskell connect :: (f a -> b) -> Committer g b -> Emitter f a -> g () @@ -653,31 +367,6 @@ nucleate :: f (g ()) nucleate n c e = emit e & n & fmap (commit c) #+end_src -** Programming with Monoidal Profunctors and Semarrows -This paper may be relevant and contain abstraction that could be usefully backported: - [[https://papers.ssrn.com/sol3/papers.cfm?abstract_id=4496714][Programming with Monoidal Profunctors and Semiarrows by Alexandre Garcia de O...]] -* bugs - -This compiles but is broken: - -#+begin_src haskell :results output -flip runStateT Seq.empty $ close $ glue <$> pure push <*> qList [1..4] -#+end_src +This has the nice property that the closure is not hidden (as is usually the case for a Monad constraint) so that opportunities to allow fusion to occur along longer chains would become possible. -The pure lifts to the wrong spot I suspect. - -#+begin_src haskell :results output -flip runStateT Seq.empty $ close $ glue <$> push <*> (foist lift $ qList [1..4]) -#+end_src -* toListM - -Version of toListM that doesn't go through FoldableM - -#+begin_src haskell --- | Collect emitter emits into a list. -toListM :: Monad m => Emitter m a -> m [a] -toListM e = - D.toList <$> - fix (\ rec xs -> emit e >>= maybe (pure xs) (rec . D.snoc xs)) D.empty -#+end_src diff --git a/src/Box/Box.hs b/src/Box/Box.hs index a799ba3..6a8082b 100644 --- a/src/Box/Box.hs +++ b/src/Box/Box.hs @@ -6,6 +6,8 @@ module Box.Box bmap, foistb, glue, + Closure (..), + glue', glueN, glueES, glueS, @@ -84,6 +86,18 @@ bmap fc fe (Box c e) = Box (witherC fc c) (witherE fe e) 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 resulting in glue closing. +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' :: (Monad m) => Committer m a -> Emitter m a -> m Closure +glue' c e = + fix $ \rec -> + emit e >>= + maybe (pure EmitterClosed) + (\a -> commit c a >>= + 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]) diff --git a/src/Box/Emitter.hs b/src/Box/Emitter.hs index 524ebb3..52b453d 100644 --- a/src/Box/Emitter.hs +++ b/src/Box/Emitter.hs @@ -6,6 +6,7 @@ module Box.Emitter type CoEmitter, toListM, witherE, + filterE, readE, unlistE, takeE, @@ -113,10 +114,28 @@ toListM e = D.toList <$> foldrM (\a acc -> fmap (`D.snoc` a) acc) (pure D.empty) -- -- >>> close $ 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 + go = do + a <- emit e + case a of + Nothing -> pure Nothing + 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. +-- +-- >>> close $ 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 @@ -128,6 +147,7 @@ witherE f e = Emitter go 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]