box 0.6.2 → 0.6.3

raw patch · 13 files changed

+317/−332 lines, 13 filesdep +containersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: containers

API changes (from Hackage documentation)

Files

• app/concurrency-tests.hs +11/−13
• app/websocket-tests.hs +14/−18
• box.cabal +11/−13
• src/Box.hs +186/−197
• src/Box/Box.hs +24/−27
• src/Box/Committer.hs +11/−9
• src/Box/Connectors.hs +9/−5
• src/Box/Cont.hs +7/−8
• src/Box/Emitter.hs +22/−22
• src/Box/IO.hs +6/−5
• src/Box/Queue.hs +2/−0
• src/Box/Time.hs +12/−13
• stack.yaml +2/−2

@@ -1,14 +1,11 @@ {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}@@ -20,6 +17,7 @@ import Box import Control.Lens import Control.Monad.Conc.Class as C+import qualified Data.Sequence as Seq import NumHask.Prelude hiding (STM) import Test.DejaFu hiding (get) import Test.DejaFu.Types@@ -30,9 +28,6 @@   glue c e   res -tEState :: (Monad m) => Emitter m a -> m [a]-tEState e = flip execStateT [] $ glue stateC (hoist lift e)- tToListE :: (MonadConc m) => Int -> m [Int] tToListE n =   toListE <$.> fromListE [1 .. n]@@ -41,7 +36,7 @@ tFromListE n = do   (c, res) <- cRef   let e = fromListE [0 .. (n - 1)]-  fuse (pure . pure) <$.> (Box <$> pure c <*> e)+  fuse (pure . pure) <$.> (Box c <$> e)   res  tToList_ :: (MonadConc m) => Int -> m [Int]@@ -56,14 +51,17 @@   res  tFromList_' :: (MonadConc m) => Int -> m [Int]-tFromList_' n = reverse <$> (flip execStateT [] $ fromList_ [1 .. n] stateC)+tFromList_' n = toList <$> execStateT (fromList_ [1 .. n] stateC) Seq.empty  tPureState :: Int -> [Int] tPureState n =-  runIdentity $ fmap (reverse . fst) $ flip execStateT ([], [1 .. n]) $ glue (hoist (zoom _1) stateC) (hoist (zoom _2) stateE)+  toList $+    runIdentity $+      fmap fst $+        flip execStateT (Seq.empty, Seq.fromList [1 .. n]) $+          glue (hoist (zoom _1) stateC) (hoist (zoom _2) stateE) -tPureBoxF f n =-  fmap (reverse . fst) $ flip execStateT ([], [1 .. n]) $ f (Box (hoist (zoom _1) stateC) (hoist (zoom _2) stateE))+tPureBoxF f n = fromToList_ [1 .. n] f  -- tForkEmit <$.> (fromListE [1..4]) -- tForkEmit <$.> (toEmitter (S.take 4 $ S.each [1..]))@@ -80,7 +78,7 @@   (MonadIO n, Eq b, Show b, MonadDejaFu n) =>   ConcT n b ->   n Bool-t c = dejafuWay (randomly (mkStdGen 42) 1000) defaultMemType "" alwaysSame c+t = dejafuWay (randomly (mkStdGen 42) 1000) defaultMemType "" alwaysSame  main :: IO () main = do@@ -94,5 +92,5 @@             pure (tPureState n),             tPureBoxF (fuse (pure . pure)) n,             tPureBoxF (\(Box c e) -> glue c e) n,-            (\(a, b) -> a <> b) <$> (tForkEmit <$.> (fromListE [1 .. n]))+            uncurry (<>) <$> (tForkEmit <$.> fromListE [1 .. n])           ]

@@ -28,12 +28,11 @@ import NumHask.Prelude hiding (STM, bracket) import Options.Generic -data ConfigSocket-  = ConfigSocket-      { host :: Text,-        port :: Int,-        path :: Text-      }+data ConfigSocket = ConfigSocket+  { host :: !Text,+    port :: !Int,+    path :: !Text+  }   deriving (Show, Eq, Generic)  defaultConfigSocket :: ConfigSocket@@ -90,10 +89,9 @@  instance ParseFields SocketType -data Opts w-  = Opts-      { apptype :: w ::: SocketType <?> "type of websocket app"-      }+newtype Opts w = Opts+  { apptype :: w ::: SocketType <?> "type of websocket app"+  }   deriving (Generic)  instance ParseRecord (Opts Wrapped)@@ -164,7 +162,7 @@           liftIO $ WS.sendClose conn ("received close signal: responder closed." :: Text)         WS.ControlMessage _ -> go         WS.DataMessage _ _ _ msg' -> do-          case (f $ WS.fromDataMessage msg') of+          case f $ WS.fromDataMessage msg' of             Left _ -> do               commit c "responder: sender initiated close"               liftIO $ WS.sendClose conn ("received close signal: responder closed." :: Text)@@ -174,14 +172,14 @@               go  q :: IO a -> IO (Either () a)-q f = race (cancelQ fromStdin) f+q = race (cancelQ fromStdin)  cancelQ :: Emitter IO Text -> IO () cancelQ e = do   e' <- emit e   case e' of     Just "q" -> pure ()-    _ -> do+    _other -> do       putStrLn ("nothing happens" :: Text)       cancelQ e @@ -192,10 +190,8 @@   client     defaultConfigSocket     ( \conn ->-        (\b -> clientApp b conn)-          <$.> ( Box-                   <$> pure c-                   <*> fromListE (xs <> ["q"])+        (`clientApp` conn)+          <$.> ( Box c <$> fromListE (xs <> ["q"])                )     )   r@@ -203,7 +199,7 @@ tClientIO :: [Text] -> IO () tClientIO xs =   (client defaultConfigSocket . clientApp)-    <$.> (Box (contramap show toStdout) <$> (fromListE (xs <> ["q"])))+    <$.> (Box (contramap show toStdout) <$> fromListE (xs <> ["q"]))  -- | main test run of client-server functionality -- the code starts a server in a thread, starts the client in the main thread, and cancels the server on completion.

@@ -1,6 +1,6 @@ cabal-version:  2.4 name:           box-version:        0.6.2+version:        0.6.3 synopsis:       boxes description:    concurrent, effectful boxes category:       project@@ -34,10 +34,6 @@   hs-source-dirs:     src   default-extensions:-    NegativeLiterals-    NoImplicitPrelude-    OverloadedStrings-    UnicodeSyntax   ghc-options:     -Wall     -Wcompat@@ -45,11 +41,14 @@     -Wincomplete-uni-patterns     -Wredundant-constraints     -funbox-strict-fields+    -fwrite-ide-info+    -hiedir=.hie   build-depends:     attoparsec >= 0.13,     base >=4.7 && <5,     comonad >= 5.0,     concurrency >= 1.11,+    containers >= 0.6 && < 0.7,     contravariant >= 1.5,     exceptions >= 0.10,     lens >= 4.19,@@ -71,6 +70,7 @@     base >=4.7 && <5,     box,     concurrency >= 1.11,+    containers >= 0.6 && < 0.7,     dejafu >= 2.3,     generic-lens >= 2.0,     lens >= 4.19,@@ -80,10 +80,6 @@     transformers >= 0.5   default-language: Haskell2010   default-extensions:-    NegativeLiterals-    NoImplicitPrelude-    OverloadedStrings-    UnicodeSyntax   ghc-options:     -Wall     -Wcompat@@ -95,6 +91,8 @@     -threaded     -rtsopts     -with-rtsopts=-N+    -fwrite-ide-info+    -hiedir=.hie executable websocket-tests   main-is: websocket-tests.hs   hs-source-dirs:@@ -116,10 +114,6 @@     websockets >= 0.12   default-language: Haskell2010   default-extensions:-    NegativeLiterals-    NoImplicitPrelude-    OverloadedStrings-    UnicodeSyntax   ghc-options:     -Wall     -Wcompat@@ -127,6 +121,8 @@     -Wincomplete-uni-patterns     -Wredundant-constraints     -funbox-strict-fields+    -fwrite-ide-info+    -hiedir=.hie  test-suite test   type: exitcode-stdio-1.0@@ -146,3 +142,5 @@     -Wincomplete-record-updates     -Wincomplete-uni-patterns     -Wredundant-constraints+    -fwrite-ide-info+    -hiedir=.hie

@@ -1,15 +1,18 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StrictData #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall #-}  -- | Effectful, profunctor boxes designed for concurrency. -- -- This library follows the ideas and code from [pipes-concurrency](https://hackage.haskell.org/package/pipes-concurrency) and [mvc](https://hackage.haskell.org/package/mvc) but with some polymorphic tweaks and definitively more pretentious names.+--+-- “Boxes are surprisingly bulky. Discard or recycle the box your cell phone comes in as soon as you unpack it. You don’t need the manual or the CD that comes with it either. You’ll figure out the applications you need through using it.” — Marie Kondo module Box   ( -- $setup     -- $continuations@@ -38,205 +41,191 @@ import Box.Queue import Box.Time -{- $setup->>> :set -XOverloadedStrings->>> :set -XGADTs->>> :set -XNoImplicitPrelude->>> :set -XFlexibleContexts->>> import NumHask.Prelude->>> import qualified Prelude as P->>> import Data.Functor.Contravariant->>> import Box->>> import Control.Monad.Conc.Class as C->>> import Control.Lens--}---{- $continuations--Continuations are very common in the API with 'Cont' as an inhouse type.-->>> :t fromListE [1..3::Int]-fromListE [1..3::Int] :: MonadConc m => Cont m (Emitter m Int)--The applicative is usually the easiest way to think about and combine continuations with their unadorned counterparts.-->>> let box' = Box <$> pure toStdout <*> fromListE ["a", "b" :: Text]->>> :t box'-box' :: Cont IO (Box IO Text Text)---}--{- $boxes--The two basic ways of connecting up a box are related as follows:--> glue c e == glueb (Box c e)-> glueb == fuse (pure . pure)-->>> fromToList_ [1..3] glueb-[1,2,3]-->>> fromToList_ [1..3] (fuse (pure . pure))-[1,2,3]--1. glue: direct fusion of committer and emitter-->>> runCont $ glue <$> pure toStdout <*> fromListE (show <$> [1..3])-1-2-3--Variations to the above code include:--Use of continuation applicative operators:--- the '(<*.>)' operator is short hand for runCont $ xyz '(<*>)' zy.--- the '(<$.>)' operator is short hand for runCont $ xyz '(<$>)' zy.--> glue <$> pure toStdout <*.> fromListE (show <$> [1..3])-> glue toStdout <$.> fromListE (show <$> [1..3])--Changing the type in the Emitter (The double fmap is cutting through the Cont and Emitter layers):--> glue toStdout <$.> fmap (fmap show) (fromListE [1..3])--Changing the type in the committer (which is Contrvariant so needs to be a contramap):--> glue (contramap show toStdout) <$.> fromListE [1..3]--Using the box version of glue:--> glueb <$.> (Box <$> pure toStdout <*> (fmap show <$> fromListE [1..3]))--2. fusion of a box, with an (a -> m (Maybe b)) function to allow for mapping, filtering and simple effects.-->>> let box' = Box <$> pure toStdout <*> fromListE (show <$> [1..3])->>> fuse (\a -> bool (pure $ Just $ "echo: " <> a) (pure Nothing) (a==("2"::Text))) <$.> box'-echo: 1-echo: 3---}--{- $commit-->>> commit toStdout "I'm committed!"-I'm committed!-True--Use mapC to modify a Committer and introduce effects.-->>> let c = mapC (\a -> if a==2 then (sleep 0.1 >> putStrLn "stole a 2!" >> sleep 0.1 >> pure (Nothing)) else (pure (Just a))) (contramap (show :: Int -> Text) toStdout)->>> glueb <$.> (Box <$> pure c <*> fromListE [1..3])-1-stole a 2!-3--The monoid instance of Committer sends each commit to both mappended committers. Because effects are also mappended together, the committed result is not always what is expected.-->>> let cFast = mapC (\b -> pure (Just b)) . contramap ("fast: " <>) $ toStdout->>> let cSlow = mapC (\b -> sleep 0.1 >> pure (Just b)) . contramap ("slow: " <>) $ toStdout->>> (glueb <$.> (Box <$> pure (cFast <> cSlow) <*> fromListE (show <$> [1..3]))) <* sleep 1-fast: 1-slow: 1-fast: 2-slow: 2-fast: 3-slow: 3--To approximate what is intuitively expected, use 'concurrentC'.-->>> runCont $ (fromList_ (show <$> [1..3]) <$> (concurrentC cFast cSlow)) <> pure (sleep 1)-fast: 1-fast: 2-fast: 3-slow: 1-slow: 2-slow: 3--This is all non-deterministic, hence the necessity for messy delays and heuristic avoidance of console races.---}--{- $emit-->>> ("I'm emitted!" :: Text) & Just & pure & Emitter & emit >>= print-Just "I'm emitted!"-->>> with (fromListE [1]) (\e' -> (emit e' & fmap show :: IO Text) >>= putStrLn & replicate 3 & sequence_)-Just 1-Nothing-Nothing-->>> toListE <$.> (fromListE [1..3])-[1,2,3]--The monoid instance is left-biased.-->>> toListE <$.> (fromListE [1..3] <> fromListE [7..9])-[1,2,3,7,8,9]--Use concurrentE to get some nondeterministic balance.--> let es = (join $ concurrentE <$> (fromListE [1..3]) <*> (fromListE [7..9]))-> glue (contramap show toStdout) <$.> es-1-2-7-3-8-9---}--{- $state--State committers and emitters are related as follows:-->>> runIdentity $ fmap (reverse . fst) $ flip execStateT ([],[1..4]) $ glue (hoist (zoom _1) stateC) (hoist (zoom _2) stateE)-[1,2,3,4]--For some reason, related to a lack of an MFunctor instance for Cont, but exactly not yet categorically pinned to a wall, the following compiles but is wrong.-->>> flip runStateT [] $ runCont $ glue <$> pure stateC <*> fromListE [1..4]-((),[])---}--{- $finite--Most committers and emitters will run forever until:--- the glued or fused other-side returns.-- the Transducer, stream or monadic action returns.--Finite ends (collective noun for emitters and committers) can be created with 'sink' and 'source' eg-->>> glue <$> contramap (show :: Int -> Text) <$> (sink 5 putStrLn) <*.> fromListE [1..]-1-2-3-4-5--Two infinite ends will tend to run infinitely.+-- $setup+-- >>> :set -XOverloadedStrings+-- >>> :set -XGADTs+-- >>> :set -XNoImplicitPrelude+-- >>> :set -XFlexibleContexts+-- >>> import NumHask.Prelude+-- >>> import qualified Prelude as P+-- >>> import Data.Functor.Contravariant+-- >>> import Box+-- >>> import Control.Monad.Conc.Class as C+-- >>> import Control.Lens+-- >>> import qualified Data.Sequence as Seq -> glue <$> pure (contramap show toStdout) <*.> fromListE [1..]+-- $continuations+--+-- Continuations are very common in the API with 'Cont' as an inhouse type.+--+-- >>> :t fromListE [1..3::Int]+-- fromListE [1..3::Int] :: MonadConc m => Cont m (Emitter m Int)+--+-- The applicative is usually the easiest way to think about and combine continuations with their unadorned counterparts.+--+-- >>> let box' = Box <$> pure toStdout <*> fromListE ["a", "b" :: Text]+-- >>> :t box'+-- box' :: Cont IO (Box IO Text Text) -1-2-...-💁-∞+-- $boxes+--+-- The two basic ways of connecting up a box are related as follows:+--+-- > glue c e == glueb (Box c e)+-- > glueb == fuse (pure . pure)+--+-- >>> fromToList_ [1..3] glueb+-- [1,2,3]+--+-- >>> fromToList_ [1..3] (fuse (pure . pure))+-- [1,2,3]+--+-- 1. glue: direct fusion of committer and emitter+--+-- >>> runCont $ glue <$> pure toStdout <*> fromListE (show <$> [1..3])+-- 1+-- 2+-- 3+--+-- Variations to the above code include:+--+-- Use of continuation applicative operators:+--+-- - the '(<*.>)' operator is short hand for runCont $ xyz 'Control.Applicative.(<*>)' zy.+--+-- - the '(<$.>)' operator is short hand for runCont $ xyz 'Control.Applicative.(<$>)' zy.+--+-- > glue <$> pure toStdout <*.> fromListE (show <$> [1..3])+-- > glue toStdout <$.> fromListE (show <$> [1..3])+--+-- Changing the type in the Emitter (The double fmap is cutting through the Cont and Emitter layers):+--+-- > glue toStdout <$.> fmap (fmap show) (fromListE [1..3])+--+-- Changing the type in the committer (which is Contrvariant so needs to be a contramap):+--+-- > glue (contramap show toStdout) <$.> fromListE [1..3]+--+-- Using the box version of glue:+--+-- > glueb <$.> (Box <$> pure toStdout <*> (fmap show <$> fromListE [1..3]))+--+-- 2. fusion of a box, with an (a -> m (Maybe b)) function to allow for mapping, filtering and simple effects.+--+-- >>> let box' = Box <$> pure toStdout <*> fromListE (show <$> [1..3])+-- >>> fuse (\a -> bool (pure $ Just $ "echo: " <> a) (pure Nothing) (a==("2"::Text))) <$.> box'+-- echo: 1+-- echo: 3 -Use glueN to create a finite computation.+-- $commit+--+-- >>> commit toStdout "I'm committed!"+-- I'm committed!+-- True+--+-- Use mapC to modify a Committer and introduce effects.+--+-- >>> let c = mapC (\a -> if a==2 then (sleep 0.1 >> putStrLn "stole a 2!" >> sleep 0.1 >> pure (Nothing)) else (pure (Just a))) (contramap (show :: Int -> Text) toStdout)+-- >>> glueb <$.> (Box <$> pure c <*> fromListE [1..3])+-- 1+-- stole a 2!+-- 3+--+-- The monoid instance of Committer sends each commit to both mappended committers. Because effects are also mappended together, the committed result is not always what is expected.+--+-- >>> let cFast = mapC (\b -> pure (Just b)) . contramap ("fast: " <>) $ toStdout+-- >>> let cSlow = mapC (\b -> sleep 0.1 >> pure (Just b)) . contramap ("slow: " <>) $ toStdout+-- >>> (glueb <$.> (Box <$> pure (cFast <> cSlow) <*> fromListE (show <$> [1..3]))) <* sleep 1+-- fast: 1+-- slow: 1+-- fast: 2+-- slow: 2+-- fast: 3+-- slow: 3+--+-- To approximate what is intuitively expected, use 'concurrentC'.+--+-- >>> runCont $ (fromList_ (show <$> [1..3]) <$> (concurrentC cFast cSlow)) <> pure (sleep 1)+-- fast: 1+-- fast: 2+-- fast: 3+-- slow: 1+-- slow: 2+-- slow: 3+--+-- This is all non-deterministic, hence the necessity for messy delays and heuristic avoidance of console races. ->>> glueN 4 <$> pure (contramap show toStdout) <*.> fromListE [1..]-1-2-3-4+-- $emit+--+-- >>> ("I'm emitted!" :: Text) & Just & pure & Emitter & emit >>= print+-- Just "I'm emitted!"+--+-- >>> with (fromListE [1]) (\e' -> (emit e' & fmap show :: IO Text) >>= putStrLn & replicate 3 & sequence_)+-- Just 1+-- Nothing+-- Nothing+--+-- >>> toListE <$.> (fromListE [1..3])+-- [1,2,3]+--+-- The monoid instance is left-biased.+--+-- >>> toListE <$.> (fromListE [1..3] <> fromListE [7..9])+-- [1,2,3,7,8,9]+--+-- Use concurrentE to get some nondeterministic balance.+--+-- > let es = (join $ concurrentE <$> (fromListE [1..3]) <*> (fromListE [7..9]))+-- > glue (contramap show toStdout) <$.> es+-- 1+-- 2+-- 7+-- 3+-- 8+-- 9 --}+-- $state+--+-- State committers and emitters are related as follows:+--+-- >>> toList . fst $ runIdentity $ flip execStateT (Seq.empty,Seq.fromList [1..4]) $ glue (hoist (zoom _1) stateC) (hoist (zoom _2) stateE)+-- [1,2,3,4]+--+-- For some reason, related to a lack of an MFunctor instance for Cont, but exactly not yet categorically pinned to a wall, the following compiles but is wrong.+--+-- >>> flip runStateT (Seq.empty) $ runCont $ glue <$> pure stateC <*> fromListE [1..4]+-- ((),fromList []) +-- $finite+--+-- Most committers and emitters will run forever until:+--+-- - the glued or fused other-side returns.+-- - the Transducer, stream or monadic action returns.+--+-- Finite ends (collective noun for emitters and committers) can be created with 'sink' and 'source' eg+--+-- >>> glue <$> contramap (show :: Int -> Text) <$> (sink 5 putStrLn) <*.> fromListE [1..]+-- 1+-- 2+-- 3+-- 4+-- 5+--+-- Two infinite ends will tend to run infinitely.+--+-- > glue <$> pure (contramap show toStdout) <*.> fromListE [1..]+--+-- 1+-- 2+-- ...+-- 💁+-- ∞+--+-- Use glueN to create a finite computation.+--+-- >>> glueN 4 <$> pure (contramap show toStdout) <*.> fromListE [1..]+-- 1+-- 2+-- 3+-- 4

@@ -2,7 +2,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StrictData #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-}@@ -17,27 +19,26 @@     glueb,     fuse,     dotb,-    Divap(..),-    DecAlt(..),+    Divap (..),+    DecAlt (..),   ) where  import Box.Committer import Box.Emitter import Data.Functor.Contravariant+import Data.Functor.Contravariant.Divisible import Data.Profunctor import NumHask.Prelude-import Data.Functor.Contravariant.Divisible  -- | A Box is a product of a Committer m and an Emitter. Think of a box with an incoming wire and an outgoing wire. Now notice that the abstraction is reversable: are you looking at two wires from "inside a box"; a blind erlang grunt communicating with the outside world via the two thin wires, or are you looking from "outside the box"; interacting with a black box object. Either way, it's a box. -- And either way, the committer is contravariant and the emitter covariant so it forms a profunctor. -- -- a Box can also be seen as having an input tape and output tape, thus available for turing and finite-state machine metaphorics.-data Box m c e-  = Box-      { committer :: Committer m c,-        emitter :: Emitter m e-      }+data Box m c e = Box+  { committer :: Committer m c,+    emitter :: Emitter m e+  }  -- | Wrong signature for the MFunctor class hoistb :: Monad m => (forall a. m a -> n a) -> Box m c e -> Box n c e@@ -65,7 +66,7 @@  -- | composition of monadic boxes dotb :: (Monad m) => Box m a b -> Box m b c -> m (Box m a c)-dotb (Box c e) (Box c' e') = glue c' e *> pure (Box c e')+dotb (Box c e) (Box c' e') = glue c' e $> Box c e'  -- | Connect an emitter directly to a committer of the same type. --@@ -90,9 +91,7 @@         Nothing -> go         Just a' -> do           b <- commit c a'-          case b of-            True -> go-            False -> pure ()+          if b then go else pure ()  -- | Short-circuit a homophonuos box. glueb :: (Monad m) => Box m a a -> m ()@@ -100,29 +99,27 @@  -- | fuse a box ----- > fuse (pure . pure) == glueb +-- > fuse (pure . pure) == glueb fuse :: (Monad m) => (a -> m (Maybe b)) -> Box m b a -> m () fuse f (Box c e) = glue c (mapE f e) --- combines 'divide'/'conquer' and 'liftA2'/'pure'+-- | combines 'divide'/'conquer' and 'liftA2'/'pure' class Divap p where-    divap :: (a -> (b, c)) -> ((d, e) -> f) -> p b d -> p c e -> p a f-    conpur :: a -> p b a--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+  divap :: (a -> (b, c)) -> ((d, e) -> f) -> p b d -> p c e -> p a f+  conpur :: a -> p b a  instance (Applicative m) => Divap (Box m) where-  divap split' merge (Box lc le) (Box rc re) = Box (divide split' lc rc) (liftA2 (curry merge) le re)+  divap split' merge (Box lc le) (Box rc re) =+    Box (divide split' lc rc) (liftA2 (curry merge) le re)    conpur a = Box conquer (pure a) +-- | combines 'Decidable' and 'Alternative'+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+ instance (Monad m, Alternative m) => DecAlt (Box m) where-  choice split merge (Box lc le) (Box rc re) =-    Box (choose split lc rc) (fmap merge $ (fmap Left le) <|> (fmap Right re))+  choice split' merge (Box lc le) (Box rc re) =+    Box (choose split' lc rc) (fmap merge $ fmap Left le <|> fmap Right re)   loss = Box (lose absurd) empty----

@@ -2,10 +2,10 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wall #-}  -- | `commit`@@ -22,15 +22,15 @@  import Data.Functor.Contravariant import Data.Functor.Contravariant.Divisible+import qualified Data.Sequence as Seq import NumHask.Prelude  -- | a Committer a "commits" values of type a. 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.-newtype Committer m a-  = Committer-      { commit :: a -> m Bool-      }+newtype Committer m a = Committer+  { commit :: a -> m Bool+  }  instance MFunctor Committer where   hoist nat (Committer c) = Committer $ nat . c@@ -98,13 +98,15 @@   f c   pure r --- | commit to a StateT list-stateC :: (Monad m) => Committer (StateT [a] m) a+-- | commit to a StateT 'Seq'.+--+-- Seq is used because only a finite number of commits are expected and because snoc'ing is cool.+stateC :: (Monad m) => Committer (StateT (Seq.Seq a) m) a stateC = Committer $ \a -> do-  modify (a :)+  modify (Seq.:|> a)   pure True  -- | list committer listC :: (Monad m) => Committer m a -> Committer m [a] listC c = Committer $ \as ->-  any id <$> (sequence $ commit c <$> as)+  or <$> sequence (commit c <$> as)

@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall #-}@@ -34,6 +35,7 @@ import Control.Concurrent.Classy.Async as C import Control.Lens import Control.Monad.Conc.Class (MonadConc)+import qualified Data.Sequence as Seq import NumHask.Prelude hiding (STM, atomically)  -- | Turn a list into an 'Emitter' continuation via a 'Queue'@@ -52,7 +54,7 @@ -- -- FIXME: fromList_ combined with cRef is failing dejavu concurrency testing... fromList_ :: Monad m => [a] -> Committer m a -> m ()-fromList_ xs c = flip evalStateT xs $ glue (hoist lift c) stateE+fromList_ xs c = flip evalStateT (Seq.fromList xs) $ glue (hoist lift c) stateE  -- | toList_ directly receives from an emitter --@@ -60,7 +62,7 @@ -- -- > toList_ == toListE toList_ :: (Monad m) => Emitter m a -> m [a]-toList_ e = reverse <$> flip execStateT [] (glue stateC (hoist lift e))+toList_ e = toList <$> flip execStateT Seq.empty (glue stateC (hoist lift e))  -- | Glues a committer and emitter, taking n emits --@@ -76,10 +78,12 @@ -- -- 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 ([b], [a]) m) b a -> StateT ([b], [a]) m r) -> m [b]+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 ([], xs) $ f (Box (hoist (zoom _1) stateC) (hoist (zoom _2) stateE))-  pure (reverse res)+  (res, _) <-+    flip execStateT (Seq.empty, Seq.fromList xs) $+      f (Box (hoist (zoom _1) stateC) (hoist (zoom _2) stateE))+  pure $ toList res  -- | hook a committer action to a queue, creating an emitter continuation emitQ :: (MonadConc m) => (Committer m a -> m r) -> Cont m (Emitter m a)

@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RebindableSyntax #-} {-# OPTIONS_GHC -Wall #-}  -- | A continuation type.@@ -18,10 +19,9 @@ import NumHask.Prelude hiding (STM, atomically)  -- | A continuation similar to ` Control.Monad.ContT` but where the result type is swallowed by an existential-newtype Cont m a-  = Cont-      { with :: forall r. (a -> m r) -> m r-      }+newtype Cont m a = Cont+  { with :: forall r. (a -> m r) -> m r+  }  instance Functor (Cont m) where   fmap f mx = Cont (\return_ -> mx `with` \x -> return_ (f x))@@ -57,10 +57,9 @@ runCont x = with x id  -- | sometimes you have no choice but to void it up-newtype Cont_ m a-  = Cont_-      { with_ :: (a -> m ()) -> m ()-      }+newtype Cont_ m a = Cont_+  { with_ :: (a -> m ()) -> m ()+  }  instance Functor (Cont_ m) where   fmap f mx = Cont_ (\return_ -> mx `with_` \x -> return_ (f x))

@@ -1,8 +1,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}@@ -30,15 +30,15 @@ where  import qualified Data.Attoparsec.Text as A+import qualified Data.Sequence as Seq import NumHask.Prelude  -- | an `Emitter` "emits" values of type a. A Source & a Producer (of a's) are the two other alternative but overloaded metaphors out there. -- -- An Emitter "reaches into itself" for the value to emit, where itself is an opaque thing from the pov of usage.  An Emitter is named for its main action: it emits.-newtype Emitter m a-  = Emitter-      { emit :: m (Maybe a)-      }+newtype Emitter m a = Emitter+  { emit :: m (Maybe a)+  }  instance MFunctor Emitter where   hoist nat (Emitter e) = Emitter (nat e)@@ -104,7 +104,7 @@  -- | no error-reporting parsing parseE_ :: (Monad m) => A.Parser a -> Emitter m Text -> Emitter m a-parseE_ parser = mapE (pure . (either (const Nothing) Just)) . parseE parser+parseE_ parser = mapE (pure . either (const Nothing) Just) . parseE parser  -- | read parse emitter, returning the original string on error readE ::@@ -116,14 +116,14 @@     parsed str =       case reads str of         [(a, "")] -> Right a-        _ -> Left (pack str)+        _err -> Left (pack str)  -- | no error-reporting reading readE_ ::   (Monad m, Read a) =>   Emitter m Text ->   Emitter m a-readE_ = mapE (pure . (either (const Nothing) Just)) . readE+readE_ = mapE (pure . either (const Nothing) Just) . readE  -- | adds a pre-emit monadic action to the emitter premapE ::@@ -160,25 +160,25 @@  -- | turn an emitter into a list toListE :: (Monad m) => Emitter m a -> m [a]-toListE e = go [] e+toListE e = go Seq.empty e   where     go xs e' = do       x <- emit e'       case x of-        Nothing -> pure (reverse xs)-        Just x' -> go (x' : xs) e'+        Nothing -> pure (toList xs)+        Just x' -> go (xs Seq.:|> x') e' --- | emit from a StateT list+-- | emit from a StateT Seq ----- This compiles but is an infinite "a" emitter:+-- FIXME: This compiles but is an infinite "a" emitter: ----- let e1 = hoist (flip evalStateT ["a", "b"::Text]) stateE :: Emitter IO Text-stateE :: (Monad m) => Emitter (StateT [a] m) a+-- let e1 = hoist (flip evalStateT (Seq.fromList ["a", "b"::Text])) stateE :: Emitter IO Text+stateE :: (Monad m) => Emitter (StateT (Seq.Seq a) m) a stateE = Emitter $ do   xs' <- get   case xs' of-    [] -> pure Nothing-    (x : xs'') -> do+    Seq.Empty -> pure Nothing+    (x Seq.:<| xs'') -> do       put xs''       pure $ Just x @@ -194,6 +194,7 @@           put xs'           pure (Just x) +-- | Stop an 'Emitter' after n 'emit's takeE :: (Monad m) => Int -> Emitter m a -> Emitter (StateT Int m) a takeE n e = Emitter $ do   x <- emit (hoist lift e)@@ -202,10 +203,10 @@     Just x' -> do       n' <- get       bool (pure Nothing) (emit' n') (n' < n)-        where-          emit' n' = do-            put (n'+1)-            pure $ Just x'+      where+        emit' n' = do+          put (n' + 1)+          pure $ Just x'  -- | Take from an emitter until predicate takeUntilE :: (Monad m) => (a -> Bool) -> Emitter m a -> Emitter m a@@ -226,4 +227,3 @@         Nothing -> pure Nothing         Just x' ->           bool go (pure (Just x')) (p x')-

@@ -3,9 +3,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} @@ -34,6 +34,7 @@ import qualified Control.Concurrent.Classy.IORef as C import Control.Lens hiding ((.>), (:>), (<|), (|>)) import qualified Control.Monad.Conc.Class as C+import qualified Data.Sequence as Seq import Data.Text.IO (hGetLine) import NumHask.Prelude hiding (STM) @@ -101,14 +102,14 @@ fileAppendC :: FilePath -> Cont IO (Committer IO Text) fileAppendC fp = Cont $ \cio -> withFile fp AppendMode (cio . handleC) --- | commit to a list IORef+-- | commit to an IORef cRef :: (C.MonadConc m) => m (Committer m a, m [a]) cRef = do-  ref <- C.newIORef []+  ref <- C.newIORef Seq.empty   let c = Committer $ \a -> do-        C.modifyIORef ref (a :)+        C.modifyIORef ref (Seq.:|> a)         pure True-  let res = reverse <$> C.readIORef ref+  let res = toList <$> C.readIORef ref   pure (c, res)  -- | emit from a list IORef

@@ -3,7 +3,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StrictData #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-}

@@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-orphans #-}@@ -37,37 +38,35 @@   sleep (fromNominalDiffTime $ diffUTCTime u t0)  -- | A value with a UTCTime annotation.-data Stamped a-  = Stamped-      { stamp :: UTCTime,-        value :: a-      }+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 = do   t <- liftIO getCurrentTime-  pure $ (utcToLocalTime utc t, a)+  pure (utcToLocalTime utc t, a)  -- | adding a time stamp stampE ::   (MonadConc m, MonadIO m) =>   Emitter m a ->-  Emitter m ((LocalTime, a))-stampE e = mapE (\x -> Just <$> stampNow x) e+  Emitter m (LocalTime, a)+stampE = mapE (fmap Just . stampNow)  -- | wait until Stamped time before emitting emitOn ::   Emitter IO (LocalTime, a) ->   Emitter IO a-emitOn e =+emitOn =   mapE-    ( \((l, a)) -> do+    ( \(l, a) -> do         sleepUntil (localTimeToUTC utc l)         pure $ Just a     )-    e  -- | reset the emitter stamps to by in sync with the current time and adjust the speed -- >>> let e1 = fromListE (zipWith (\x a -> Stamped (addUTCTime (fromDouble x) t) a) [0..5] [0..5])@@ -79,8 +78,8 @@     Just (l0, _) -> do       t0 <- getCurrentTime       let ua = diffLocalTime (utcToLocalTime utc t0) l0-      let delta u = addLocalTime ua $ addLocalTime (toNominalDiffTime ((fromNominalDiffTime $ diffLocalTime u l0) * speed)) l0-      pure (mapE (\((l, a)) -> pure (Just ((delta l), a))) e)+      let delta u = addLocalTime ua $ addLocalTime (toNominalDiffTime (fromNominalDiffTime (diffLocalTime u l0) * speed)) l0+      pure (mapE (\(l, a) -> pure (Just (delta l, a))) e)  -- | simulate a delay from a (Stamped a) Emitter relative to the first timestamp simulate :: Double -> Emitter IO (LocalTime, a) -> Cont IO (Emitter IO a)

@@ -4,10 +4,10 @@   - .  extra-deps:-  - numhask-0.7.0.0+  - numhask-0.7.1.0   - protolude-0.3.0   - random-1.2.0   - splitmix-0.1.0.3-  - numhask-space-0.7.0.0+  - numhask-space-0.7.1.0  allow-newer: true