box 0.6.3 → 0.7.0

raw patch · 16 files changed

+185/−566 lines, 16 filesdep −boxdep −comonaddep −dejafudep ~attoparsecdep ~concurrencydep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies removed: box, comonad, dejafu, doctest, generic-lens, numhask, numhask-space, optparse-generic, random, transformers-base, websockets

Dependency ranges changed: attoparsec, concurrency, containers, contravariant, exceptions, lens, mmorph, mtl, profunctors, text, time, transformers

API changes (from Hackage documentation)

Files

ChangeLog.md +4/−0
app/concurrency-tests.hs +0/−96
app/websocket-tests.hs +0/−213
box.cabal +37/−126
readme.md +0/−54
src/Box.hs +36/−21
src/Box/Box.hs +16/−6
src/Box/Committer.hs +4/−1
src/Box/Connectors.hs +18/−2
src/Box/Cont.hs +3/−2
src/Box/Emitter.hs +7/−2
src/Box/IO.hs +24/−10
src/Box/Queue.hs +3/−2
src/Box/Time.hs +33/−3
stack.yaml +0/−13
test/test.hs +0/−15

+ ChangeLog.md view

@@ -0,0 +1,4 @@+0.7.0+===++* Removed numhask dependencies

− app/concurrency-tests.hs

@@ -1,96 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RebindableSyntax #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -Wall #-}-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-}---- | dejavu testing-module Main where--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--tERef :: (MonadConc m) => Emitter m a -> m [a]-tERef e = do-  (c, res) <- cRef-  glue c e-  res--tToListE :: (MonadConc m) => Int -> m [Int]-tToListE n =-  toListE <$.> fromListE [1 .. n]--tFromListE :: (MonadConc m) => Int -> m [Int]-tFromListE n = do-  (c, res) <- cRef-  let e = fromListE [0 .. (n - 1)]-  fuse (pure . pure) <$.> (Box c <$> e)-  res--tToList_ :: (MonadConc m) => Int -> m [Int]-tToList_ n =-  toList_ <$.> fromListE [1 .. n]---- failing-tFromList_ :: (MonadConc m) => Int -> m [Int]-tFromList_ n = do-  (c, res) <- cRef-  fromList_ [1 .. n] c-  res--tFromList_' :: (MonadConc m) => Int -> m [Int]-tFromList_' n = toList <$> execStateT (fromList_ [1 .. n] stateC) Seq.empty--tPureState :: Int -> [Int]-tPureState n =-  toList $-    runIdentity $-      fmap fst $-        flip execStateT (Seq.empty, Seq.fromList [1 .. n]) $-          glue (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..]))-tForkEmit :: (MonadConc m) => Emitter m b -> m ([b], [b])-tForkEmit e = do-  (c1, r1) <- cRef-  (c2, r2) <- cRef-  let e' = forkEmit e c1-  glue c2 e'-  (,) <$> r1 <*> r2---- | test when the deterministic takes too long (which is almost always)-t ::-  (MonadIO n, Eq b, Show b, MonadDejaFu n) =>-  ConcT n b ->-  n Bool-t = dejafuWay (randomly (mkStdGen 42) 1000) defaultMemType "" alwaysSame--main :: IO ()-main = do-  let n = 4-  sequence_ $-    autocheck-      <$> [ tToListE n,-            tFromListE n,-            tToList_ n,-            tFromList_' n,-            pure (tPureState n),-            tPureBoxF (fuse (pure . pure)) n,-            tPureBoxF (\(Box c e) -> glue c e) n,-            uncurry (<>) <$> (tForkEmit <$.> fromListE [1 .. n])-          ]

− app/websocket-tests.hs

@@ -1,213 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# OPTIONS_GHC -Wall #-}-{-# OPTIONS_GHC -Wno-unused-do-bind #-}--{---Models a websocket connection---}--module Main where--import Box-import qualified Control.Concurrent.Classy.Async as C-import Control.Lens hiding (Unwrapped, Wrapped)-import Control.Monad.Catch-import Control.Monad.Conc.Class as C-import Data.Generics.Labels ()-import qualified Network.WebSockets as WS-import NumHask.Prelude hiding (STM, bracket)-import Options.Generic--data ConfigSocket = ConfigSocket-  { host :: !Text,-    port :: !Int,-    path :: !Text-  }-  deriving (Show, Eq, Generic)--defaultConfigSocket :: ConfigSocket-defaultConfigSocket = ConfigSocket "127.0.0.1" 9160 "/"--client :: (MonadIO m) => ConfigSocket -> WS.ClientApp () -> m ()-client c app = liftIO $ WS.runClient (unpack $ c ^. #host) (c ^. #port) (unpack $ c ^. #path) app--server :: (MonadIO m) => ConfigSocket -> WS.ServerApp -> m ()-server c app = liftIO $ WS.runServer (unpack $ c ^. #host) (c ^. #port) app--con :: (MonadMask m, MonadIO m) => WS.PendingConnection -> Cont m WS.Connection-con p = Cont $ \action ->-  bracket-    (liftIO $ WS.acceptRequest p)-    (\conn -> liftIO $ WS.sendClose conn ("Bye from con!" :: Text))-    action--clientApp ::-  (MonadIO m, MonadConc m) =>-  Box m (Either Text Text) Text ->-  WS.Connection ->-  m ()-clientApp (Box c e) conn =-  void $-    C.race-      (receiver c conn)-      (sender (Box mempty e) conn)--serverApp ::-  WS.PendingConnection ->-  IO ()-serverApp p =-  with-    (con p)-    ( responder-        (\x -> bool (Right $ "echo:" <> x) (Left "quit") (x == "q"))-        mempty-    )--serverIO :: IO ()-serverIO = server defaultConfigSocket serverApp--clientIO :: IO ()-clientIO =-  (client defaultConfigSocket . clientApp)-    (Box (contramap show toStdout) fromStdin)--data SocketType = Client | Responder | TestRun deriving (Eq, Read, Show, Generic)--instance ParseField SocketType--instance ParseRecord SocketType--instance ParseFields SocketType--newtype Opts w = Opts-  { apptype :: w ::: SocketType <?> "type of websocket app"-  }-  deriving (Generic)--instance ParseRecord (Opts Wrapped)--main :: IO ()-main = do-  o :: Opts Unwrapped <- unwrapRecord "example websocket apps"-  r :: Text <- case apptype o of-    Client -> show <$> clientIO-    Responder -> show <$> q serverIO-    TestRun -> show <$> testRun-  putStrLn r---- | default websocket receiver--- Lefts are info/debug-receiver ::-  (MonadIO m) =>-  Committer m (Either Text Text) ->-  WS.Connection ->-  m Bool-receiver c conn = go-  where-    go = do-      msg <- liftIO $ WS.receive conn-      case msg of-        WS.ControlMessage (WS.Close w b) ->-          commit-            c-            ( Left-                ( "receiver: received: close: " <> show w <> " " <> show b-                )-            )-        WS.ControlMessage _ -> go-        WS.DataMessage _ _ _ msg' -> do-          commit c $ Left $ "receiver: received: " <> (WS.fromDataMessage msg' :: Text)-          _ <- commit c (Right (WS.fromDataMessage msg'))-          go---- | default websocket sender-sender ::-  (MonadIO m, WS.WebSocketsData a, Show a) =>-  Box m Text a ->-  WS.Connection ->-  m ()-sender (Box c e) conn = forever $ do-  msg <- emit e-  case msg of-    Nothing -> pure ()-    Just msg' -> do-      commit c $ "sender: sending: " <> (show msg' :: Text)-      liftIO $ WS.sendTextData conn msg'---- | a receiver that responds based on received Text.--- lefts are quit signals. Rights are response text.-responder ::-  (MonadIO m) =>-  (Text -> Either Text Text) ->-  Committer m Text ->-  WS.Connection ->-  m ()-responder f c conn = go-  where-    go = do-      msg <- liftIO $ WS.receive conn-      case msg of-        WS.ControlMessage (WS.Close _ _) -> do-          commit c "responder: normal close"-          liftIO $ WS.sendClose conn ("received close signal: responder closed." :: Text)-        WS.ControlMessage _ -> go-        WS.DataMessage _ _ _ msg' -> do-          case f $ WS.fromDataMessage msg' of-            Left _ -> do-              commit c "responder: sender initiated close"-              liftIO $ WS.sendClose conn ("received close signal: responder closed." :: Text)-            Right r -> do-              commit c ("responder: sending" <> r)-              liftIO $ WS.sendTextData conn r-              go--q :: IO a -> IO (Either () a)-q = race (cancelQ fromStdin)--cancelQ :: Emitter IO Text -> IO ()-cancelQ e = do-  e' <- emit e-  case e' of-    Just "q" -> pure ()-    _other -> do-      putStrLn ("nothing happens" :: Text)-      cancelQ e---- | test of clientApp via a cRef committer and a canned list of Text-tClient :: [Text] -> IO [Either Text Text]-tClient xs = do-  (c, r) <- cRef-  client-    defaultConfigSocket-    ( \conn ->-        (`clientApp` conn)-          <$.> ( Box c <$> fromListE (xs <> ["q"])-               )-    )-  r--tClientIO :: [Text] -> IO ()-tClientIO xs =-  (client defaultConfigSocket . clientApp)-    <$.> (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.--- > testRun--- [Left "receiver: received: echo:1",Right "echo:1",Left "receiver: received: echo:2",Right "echo:2",Left "receiver: received: echo:3",Right "echo:3",Left "receiver: received: close: 1000 \"received close signal: responder closed.\""]-testRun :: IO [Either Text Text]-testRun = do-  a <- async (server defaultConfigSocket serverApp)-  r <- tClient (show <$> [1 .. 3 :: Int])-  cancel a-  pure r

box.cabal view

@@ -1,23 +1,22 @@-cabal-version:  2.4-name:           box-version:        0.6.3-synopsis:       boxes-description:    concurrent, effectful boxes-category:       project-homepage:       https://github.com/tonyday567/box#readme-bug-reports:    https://github.com/tonyday567/box/issues-author:         Tony Day-maintainer:     tonyday567@gmail.com-copyright:      Tony Day (c) 2017-license:        BSD-3-Clause-license-file:   LICENSE-build-type:     Simple-extra-source-files:-  stack.yaml-  readme.md+cabal-version:      2.4+name:               box+version:            0.7.0+synopsis:           boxes+description:        concurrent, effectful boxes+category:           project+homepage:           https://github.com/tonyday567/box#readme+bug-reports:        https://github.com/tonyday567/box/issues+author:             Tony Day+maintainer:         tonyday567@gmail.com+copyright:          Tony Day (c) 2017+license:            BSD-3-Clause+license-file:       LICENSE+build-type:         Simple+tested-with:        GHC ==8.8.4 || ==8.10.4 || ==9.0.1 || ==9.2.0.20210821+extra-source-files: ChangeLog.md  source-repository head-  type: git+  type:     git   location: https://github.com/tonyday567/box  library@@ -31,116 +30,28 @@     Box.IO     Box.Queue     Box.Time-  hs-source-dirs:-    src-  default-extensions:-  ghc-options:-    -Wall-    -Wcompat-    -Wincomplete-record-updates-    -Wincomplete-uni-patterns-    -Wredundant-constraints-    -funbox-strict-fields-    -fwrite-ide-info-    -hiedir=.hie-  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,-    mmorph >= 1.1,-    numhask >= 0.7 && < 0.8,-    numhask-space >= 0.7 && < 0.8,-    profunctors >= 5.5,-    text >= 1.2,-    time >= 1.9,-    transformers >= 0.5,-    transformers-base >= 0.4,-  default-language: Haskell2010 -executable concurrency-tests-  main-is: concurrency-tests.hs-  hs-source-dirs:-    app-  build-depends:-    base >=4.7 && <5,-    box,-    concurrency >= 1.11,-    containers >= 0.6 && < 0.7,-    dejafu >= 2.3,-    generic-lens >= 2.0,-    lens >= 4.19,-    numhask >= 0.7 && < 0.8,-    random >= 1.1,-    text >= 1.2,-    transformers >= 0.5-  default-language: Haskell2010-  default-extensions:-  ghc-options:-    -Wall-    -Wcompat-    -Wincomplete-record-updates-    -Wincomplete-uni-patterns-    -Wredundant-constraints-    -funbox-strict-fields-    -fforce-recomp-    -threaded-    -rtsopts-    -with-rtsopts=-N-    -fwrite-ide-info-    -hiedir=.hie-executable websocket-tests-  main-is: websocket-tests.hs-  hs-source-dirs:-    app-  ghc-options: -funbox-strict-fields -fforce-recomp -threaded -rtsopts -with-rtsopts=-N-  build-depends:-    base >=4.7 && <5,-    box,-    concurrency >= 1.11,-    dejafu >= 2.3,-    exceptions >= 0.10,-    generic-lens >= 2.0,-    lens >= 4.19,-    mtl >= 2.2,-    numhask >= 0.7 && < 0.8,-    optparse-generic >= 1.3.0 && < 1.4,-    text >= 1.2,-    transformers >= 0.5,-    websockets >= 0.12-  default-language: Haskell2010+  hs-source-dirs:     src   default-extensions:   ghc-options:-    -Wall-    -Wcompat-    -Wincomplete-record-updates-    -Wincomplete-uni-patterns-    -Wredundant-constraints-    -funbox-strict-fields-    -fwrite-ide-info-    -hiedir=.hie+    -Wall -Wcompat -Wincomplete-record-updates+    -Wincomplete-uni-patterns -Wredundant-constraints+    -funbox-strict-fields -fwrite-ide-info -hiedir=.hie+    -Wunused-packages -test-suite test-  type: exitcode-stdio-1.0-  main-is: test.hs-  hs-source-dirs:-    test   build-depends:-    base >=4.7 && <5,-    box,-    doctest >= 0.16,-    numhask >= 0.7 && < 0.8,-  default-language: Haskell2010-  default-extensions:-  ghc-options:-    -Wall-    -Wcompat-    -Wincomplete-record-updates-    -Wincomplete-uni-patterns-    -Wredundant-constraints-    -fwrite-ide-info-    -hiedir=.hie+    , attoparsec     ^>=0.14+    , base           >=4.7   && <5+    , concurrency    ^>=1.11+    , containers     ^>=0.6+    , contravariant  ^>=1.5+    , exceptions     ^>=0.10+    , lens           ^>=5.0+    , mmorph         ^>=1.2+    , mtl            ^>=2.2.2+    , profunctors    ^>=5.6+    , text           ^>=1.2+    , time           ^>=1.9+    , transformers   ^>=0.5++  default-language:   Haskell2010

− readme.md

@@ -1,54 +0,0 @@-[box](https://tonyday567.github.io/box/index.html) [![Build Status](https://travis-ci.org/tonyday567/box.svg)](https://travis-ci.org/tonyday567/box)-===--> The box is dark and full of terrors.--Take two ubiquitous concepts. There are things that emit stuff. They instantiate a particular thing on demand, somehow and somewhere beyond our concern and viewbox.  We ask an Emitter for an `a` and an `a` is there, or not (best to assume a `Maybe a`). The library calls this an Emitter:--```-newtype Emitter m a = Emitter { emit :: m (Maybe a)}-```-It emits over a type constructor, m, and this is often monadic in nature, and often IO.--Then there is the opposite.  There are things that commit stuff. We offer a Committer a particular thing and they take it away beyond our concerns. It is committed to the void. We offer an `a` and it is reported back whether the committment was succesful.The library calls this a Committer:--```-newtype Committer m a = Committer { commit :: a -> m Bool}-```--These two types are duals, across a wide spectrum of what that means. If you do something with a committer, like write to a socket, you can often immediately write an emitter the dual of this, like read from a socket.--When you have both things, something that emits and something that commits, over the same carrier, you have a Box:--```-data Box m c e = Box-  { committer :: Committer m c-  , emitter :: Emitter m e-  }-```--A Box tends to flip polarity, like a Möbius strip. and sometimes like a Dali.--You can see a committer as a wire into the box, and an emitter as a wire out of the box. You can then think of the box as opaque, and make the tasks on the outside of the box that much easier, removing concern about what is going on inside the box. But then coding tends to get you inside the box, and point-of-view shifts. From inside the box, stuff,, a's,, are coming from what we had thought of as the committer. It is emitting from our new viewbox, and vice versa. You are the black box, and your box matters. --Note how you can get confused with these metaphors.  The wire going into the box is a committer from a point of view outside the metaphorical box but looks like an emitter from the inside. The wire going out is a committer from the inside and an emitter from the outside.--The key to understanding this library is to resist having to choose a single frame of reference and, instead, focus on the types.--A `Box m c e` unifies the functorial wrapper `m` of the emitter and committer, which is what really makes it a functional box. Boxes can often be hooked together at this level for useful efficiencies.--A Box is also a [profunctor](https://bartoszmilewski.com/2019/03/27/promonads-arrows-and-einstein-notation-for-profunctors/) and, to quote Bartos, a profunctor can be used to glue together two categories.--Like other paradigms, boxes can be not fun places to get stuck in.  Much of the library are not, in fact, emitters and committers but emitter, committer and box continuations. If you gave me something that takes a box and does something, then I'll give you a something is a natural piece of logic within the library context, and so large parts of the functionality are [continuation-parsing style](https://ro-che.info/articles/2019-06-07-why-use-contt).--Finally, the interface between boxes is a natural place to create concurrency, and Box.Queue provides queues that are guaranteed to not race or block.--> “Do not define me by my gender or my socio-economic status, Noah Willis. Do not tell me who I am and do not tell me who society thinks I am and then put me in that box and expect me to stay there. Because, I swear to God, I will climb the hell out of that box and I will take that box you've just put me in and I will use that box to smash your face in until you're nothing more than a freckly, bloodied pulp. You got that, sweet cheeks?” ~ Megan Jacobson, Yellow---recipe------```-stack exec --test concurrency-tests --file-watch-```

src/Box.hs view

@@ -14,7 +14,7 @@ -- -- “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+  ( -- $usage     -- $continuations     -- $boxes     -- $commit@@ -44,26 +44,41 @@ -- $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.Applicative -- >>> import Control.Monad.Conc.Class as C -- >>> import Control.Lens -- >>> import qualified Data.Sequence as Seq+-- >>> import Data.Text (pack, Text)+-- >>> import Data.Functor.Contravariant+-- >>> import Data.Foldable+-- >>> import Data.Bool+-- >>> import Control.Monad.Morph+-- >>> import Control.Monad.State.Lazy +-- $usage+-- >>> :set -XOverloadedStrings+-- >>> :set -XGADTs+-- >>> :set -XFlexibleContexts+-- >>> import Data.Functor.Contravariant+-- >>> import Box+-- >>> import Control.Monad.Conc.Class as C+-- >>> import Control.Lens+-- >>> import qualified Data.Sequence as Seq+-- >>> import Data.Text (pack, Text)+ -- $continuations -- -- Continuations are very common in the API with 'Cont' as an inhouse type. ----- >>> :t fromListE [1..3::Int]+-- > :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]+-- >>> let box' = Box <$> pure toStdout <*> fromListE (pack <$> ["a", "b"]) -- >>> :t box' -- box' :: Cont IO (Box IO Text Text) @@ -82,7 +97,7 @@ -- -- 1. glue: direct fusion of committer and emitter ----- >>> runCont $ glue <$> pure toStdout <*> fromListE (show <$> [1..3])+-- >>> runCont $ glue <$> pure toStdout <*> fromListE ((pack . show) <$> [1..3]) -- 1 -- 2 -- 3@@ -95,24 +110,24 @@ -- -- - the '(<$.>)' operator is short hand for runCont $ xyz 'Control.Applicative.(<$>)' zy. ----- > glue <$> pure toStdout <*.> fromListE (show <$> [1..3])--- > glue toStdout <$.> fromListE (show <$> [1..3])+-- > glue <$> pure toStdout <*.> fromListE ((pack . show) <$> [1..3])+-- > glue toStdout <$.> fromListE ((pack . 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])+-- > glue toStdout <$.> fmap (fmap (pack . 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]+-- > glue (contramap (pack . show) toStdout) <$.> fromListE [1..3] -- -- Using the box version of glue: ----- > glueb <$.> (Box <$> pure toStdout <*> (fmap show <$> fromListE [1..3]))+-- > glueb <$.> (Box <$> pure toStdout <*> (fmap (pack . 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])+-- >>> let box' = Box <$> pure toStdout <*> fromListE ((pack . show) <$> [1..3]) -- >>> fuse (\a -> bool (pure $ Just $ "echo: " <> a) (pure Nothing) (a==("2"::Text))) <$.> box' -- echo: 1 -- echo: 3@@ -125,7 +140,7 @@ -- -- 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)+-- >>> 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 (pack . show) toStdout) -- >>> glueb <$.> (Box <$> pure c <*> fromListE [1..3]) -- 1 -- stole a 2!@@ -135,7 +150,7 @@ -- -- >>> 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+-- >>> (glueb <$.> (Box <$> pure (cFast <> cSlow) <*> fromListE ((pack . show) <$> [1..3]))) <* sleep 1 -- fast: 1 -- slow: 1 -- fast: 2@@ -145,7 +160,7 @@ -- -- To approximate what is intuitively expected, use 'concurrentC'. ----- >>> runCont $ (fromList_ (show <$> [1..3]) <$> (concurrentC cFast cSlow)) <> pure (sleep 1)+-- >>> runCont $ (fromList_ ((pack . show) <$> [1..3]) <$> (concurrentC cFast cSlow)) <> pure (sleep 1) -- fast: 1 -- fast: 2 -- fast: 3@@ -160,7 +175,7 @@ -- >>> ("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_)+-- >>> with (fromListE [1]) (\e' -> (emit e' & fmap show) >>= putStrLn & replicate 3 & sequence_) -- Just 1 -- Nothing -- Nothing@@ -176,7 +191,7 @@ -- Use concurrentE to get some nondeterministic balance. -- -- > let es = (join $ concurrentE <$> (fromListE [1..3]) <*> (fromListE [7..9]))--- > glue (contramap show toStdout) <$.> es+-- > glue (contramap (pack . show) toStdout) <$.> es -- 1 -- 2 -- 7@@ -205,7 +220,7 @@ -- -- 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..]+-- >>> glue <$> contramap show <$> (sink 5 putStrLn) <*.> fromListE [1..] -- 1 -- 2 -- 3@@ -214,7 +229,7 @@ -- -- Two infinite ends will tend to run infinitely. ----- > glue <$> pure (contramap show toStdout) <*.> fromListE [1..]+-- > glue <$> pure (contramap (pack . show) toStdout) <*.> fromListE [1..] -- -- 1 -- 2@@ -224,7 +239,7 @@ -- -- Use glueN to create a finite computation. ----- >>> glueN 4 <$> pure (contramap show toStdout) <*.> fromListE [1..]+-- >>> glueN 4 <$> pure (contramap (pack . show) toStdout) <*.> fromListE [1..] -- 1 -- 2 -- 3

src/Box/Box.hs view

@@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TypeFamilies #-}@@ -24,12 +23,23 @@   ) where -import Box.Committer-import Box.Emitter-import Data.Functor.Contravariant+import Box.Committer (Committer (commit), mapC)+import Box.Emitter (Emitter (emit), mapE)+import Control.Applicative+  ( Alternative (empty, (<|>)),+    Applicative (liftA2),+  )+import Control.Monad (when)+import Control.Monad.Morph (MFunctor (hoist))+import Data.Functor (($>))+import Data.Functor.Contravariant (Contravariant (contramap)) import Data.Functor.Contravariant.Divisible-import Data.Profunctor-import NumHask.Prelude+  ( Decidable (choose, lose),+    Divisible (conquer, divide),+  )+import Data.Profunctor (Profunctor (dimap))+import Data.Void (Void, absurd)+import Prelude  -- | 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.

src/Box/Committer.hs view

@@ -20,10 +20,13 @@   ) where +import Control.Monad.Morph+import Control.Monad.State.Lazy import Data.Functor.Contravariant import Data.Functor.Contravariant.Divisible import qualified Data.Sequence as Seq-import NumHask.Prelude+import Data.Void+import Prelude  -- | a Committer a "commits" values of type a. A Sink and a Consumer are some other metaphors for this. --

src/Box/Connectors.hs view

@@ -35,9 +35,25 @@ import Control.Concurrent.Classy.Async as C import Control.Lens import Control.Monad.Conc.Class (MonadConc)+import Control.Monad.Morph+import Control.Monad.State.Lazy+import Data.Foldable import qualified Data.Sequence as Seq-import NumHask.Prelude hiding (STM, atomically)+import Prelude +-- $setup+-- >>> :set -XOverloadedStrings+-- >>> :set -XGADTs+-- >>> :set -XFlexibleContexts+-- >>> import Data.Functor.Contravariant+-- >>> import Box+-- >>> import Control.Applicative+-- >>> import Control.Monad.Conc.Class as C+-- >>> import Control.Lens+-- >>> import qualified Data.Sequence as Seq+-- >>> import Data.Text (pack, Text)+-- >>> import Data.Functor.Contravariant+ -- | Turn a list into an 'Emitter' continuation via a 'Queue' fromListE :: (MonadConc m) => [a] -> Cont m (Emitter m a) fromListE xs = Cont $ queueE (eListC (Emitter . pure . Just <$> xs))@@ -66,7 +82,7 @@  -- | Glues a committer and emitter, taking n emits ----- >>> glueN 4 <$> pure (contramap show toStdout) <*.> fromListE [1..]+-- >>> glueN 4 <$> pure (contramap (pack . show) toStdout) <*.> fromListE [1..] -- 1 -- 2 -- 3

src/Box/Cont.hs view

@@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RebindableSyntax #-} {-# OPTIONS_GHC -Wall #-}  -- | A continuation type.@@ -16,7 +15,9 @@   ) where -import NumHask.Prelude hiding (STM, atomically)+import Control.Applicative+import Control.Monad.IO.Class+import Prelude  -- | A continuation similar to ` Control.Monad.ContT` but where the result type is swallowed by an existential newtype Cont m a = Cont

src/Box/Emitter.hs view

@@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}@@ -29,9 +28,15 @@   ) where +import Control.Applicative+import Control.Monad.Morph+import Control.Monad.State.Lazy import qualified Data.Attoparsec.Text as A+import Data.Bool+import Data.Foldable import qualified Data.Sequence as Seq-import NumHask.Prelude+import Data.Text (Text, pack, unpack)+import 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. --

src/Box/IO.hs view

@@ -3,7 +3,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall #-}@@ -32,14 +31,29 @@ import Box.Cont import Box.Emitter import qualified Control.Concurrent.Classy.IORef as C+import Control.Exception import Control.Lens hiding ((.>), (:>), (<|), (|>)) import qualified Control.Monad.Conc.Class as C+import Data.Bool+import Data.Foldable import qualified Data.Sequence as Seq-import Data.Text.IO (hGetLine)-import NumHask.Prelude hiding (STM)+import Data.Text as Text+import Data.Text.IO as Text+import System.IO as IO+import Prelude  -- $setup -- >>> :set -XOverloadedStrings+-- >>> :set -XGADTs+-- >>> :set -XFlexibleContexts+-- >>> import Data.Functor.Contravariant+-- >>> import Box+-- >>> import Control.Applicative+-- >>> import Control.Monad.Conc.Class as C+-- >>> import Control.Lens+-- >>> import qualified Data.Sequence as Seq+-- >>> import Data.Text (pack, Text)+-- >>> import Data.Functor.Contravariant  -- * console @@ -48,7 +62,7 @@ -- >>> :t emit fromStdin -- emit fromStdin :: IO (Maybe Text) fromStdin :: Emitter IO Text-fromStdin = Emitter $ Just <$> NumHask.Prelude.getLine+fromStdin = Emitter $ Just <$> Text.getLine  -- | commit to stdout --@@ -56,15 +70,15 @@ -- I'm committed! -- True toStdout :: Committer IO Text-toStdout = Committer $ \a -> putStrLn a >> pure True+toStdout = Committer $ \a -> Text.putStrLn a >> pure True  -- | finite console emitter fromStdinN :: Int -> Cont IO (Emitter IO Text)-fromStdinN n = source n NumHask.Prelude.getLine+fromStdinN n = source n Text.getLine  -- | finite console committer toStdoutN :: Int -> Cont IO (Committer IO Text)-toStdoutN n = sink n putStrLn+toStdoutN n = sink n Text.putStrLn  -- | read from console, throwing away read errors readStdin :: Read a => Emitter IO a@@ -72,14 +86,14 @@  -- | show to stdout showStdout :: Show a => Committer IO a-showStdout = contramap show toStdout+showStdout = contramap (Text.pack . show) toStdout  -- * handle operations  -- | Emits lines of Text from a handle. handleE :: Handle -> Emitter IO Text handleE h = Emitter $ do-  l :: (Either IOException Text) <- try (hGetLine h)+  l :: (Either IOException Text) <- try (Text.hGetLine h)   pure $ case l of     Left _ -> Nothing     Right a -> bool (Just a) Nothing (a == "")@@ -87,7 +101,7 @@ -- | Commit lines of Text to a handle. handleC :: Handle -> Committer IO Text handleC h = Committer $ \a -> do-  hPutStrLn h a+  Text.hPutStrLn h a   pure True  -- | Emits lines of Text from a file.

src/Box/Queue.hs view

@@ -3,7 +3,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TypeFamilies #-}@@ -34,11 +33,13 @@ import Box.Committer import Box.Cont import Box.Emitter+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 NumHask.Prelude hiding (STM, atomically)+import Control.Monad.Morph+import Prelude  -- | 'Queue' specifies how messages are queued data Queue a

src/Box/Time.hs view

@@ -23,14 +23,44 @@ import Box.Cont import Box.Emitter import Control.Monad.Conc.Class as C+import Control.Monad.IO.Class+import Data.Fixed (Fixed (MkFixed)) import Data.Time-import NumHask.Prelude hiding (STM, atomically)-import NumHask.Space.Time+import Prelude +-- $setup+-- >>> :set -XOverloadedStrings+-- >>> :set -XGADTs+-- >>> :set -XFlexibleContexts+-- >>> import Data.Functor.Contravariant+-- >>> import Box+-- >>> import Control.Applicative+-- >>> import Control.Monad.Conc.Class as C+-- >>> import Control.Lens+-- >>> import qualified Data.Sequence as Seq+-- >>> import Data.Text (pack, Text)+-- >>> import Data.Functor.Contravariant+ -- | sleep for x seconds sleep :: (MonadConc m) => Double -> m () sleep x = C.threadDelay (floor $ x * 1e6) +-- | convenience conversion to Double+fromNominalDiffTime :: NominalDiffTime -> Double+fromNominalDiffTime t = fromInteger i * 1e-12+  where+    (MkFixed i) = nominalDiffTimeToSeconds t++-- | convenience conversion from Double+toNominalDiffTime :: Double -> NominalDiffTime+toNominalDiffTime x =+  let d0 = ModifiedJulianDay 0+      days = floor (x / fromNominalDiffTime nominalDay)+      secs = x - fromIntegral days * fromNominalDiffTime nominalDay+      t0 = UTCTime d0 (picosecondsToDiffTime 0)+      t1 = UTCTime (addDays days d0) (picosecondsToDiffTime $ floor (secs / 1.0e-12))+   in diffUTCTime t1 t0+ -- | sleep until a certain time (in the future) sleepUntil :: UTCTime -> IO () sleepUntil u = do@@ -69,7 +99,7 @@     )  -- | 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])+-- > let e1 = fromListE (zipWith (\x a -> Stamped (addUTCTime x t) a) [0..5] [0..5]) playback :: Double -> Emitter IO (LocalTime, a) -> IO (Emitter IO (LocalTime, a)) playback speed e = do   r <- emit e

− stack.yaml

@@ -1,13 +0,0 @@-resolver: nightly-2020-11-19--packages:-  - .--extra-deps:-  - numhask-0.7.1.0-  - protolude-0.3.0-  - random-1.2.0-  - splitmix-0.1.0.3-  - numhask-space-0.7.1.0--allow-newer: true

− test/test.hs

@@ -1,15 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# OPTIONS_GHC -Wall #-}--module Main where--import NumHask.Prelude-import Test.DocTest--main :: IO ()-main = doctest-  [ "src/Box.hs",-    -- "src/Box/Committer.hs",-    "src/Box/IO.hs"-    -- "app/websocket-tests.hs"-  ]