diff --git a/box.cabal b/box.cabal --- a/box.cabal +++ b/box.cabal @@ -1,5 +1,6 @@ +cabal-version: 3.0 name: box -version: 0.3.0 +version: 0.4.0 synopsis: boxes description: concurrent, effectful boxes category: project @@ -8,10 +9,9 @@ author: Tony Day maintainer: tonyday567@gmail.com copyright: Tony Day (c) 2017 -license: BSD3 +license: BSD-3-Clause license-file: LICENSE build-type: Simple -cabal-version: 1.12 extra-source-files: stack.yaml readme.md @@ -37,8 +37,6 @@ Box.Time Box.Transducer Box.Updater - other-modules: - Paths_box hs-source-dirs: src ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -funbox-strict-fields @@ -53,6 +51,7 @@ , lens , pipes , profunctors + , protolude >= 0.3.0 && < 0.4 , streaming , text , time @@ -63,8 +62,6 @@ executable concurrency-tests main-is: concurrency-tests.hs - other-modules: - Paths_box hs-source-dirs: app ghc-options: -funbox-strict-fields -fforce-recomp -threaded -rtsopts -with-rtsopts=-N @@ -76,6 +73,7 @@ , generic-lens , lens , mtl + , protolude , random , streaming , text @@ -84,8 +82,6 @@ executable websocket-tests main-is: websocket-tests.hs - other-modules: - Paths_box hs-source-dirs: app ghc-options: -funbox-strict-fields -fforce-recomp -threaded -rtsopts -with-rtsopts=-N @@ -106,12 +102,9 @@ , websockets default-language: Haskell2010 - test-suite test type: exitcode-stdio-1.0 main-is: test.hs - other-modules: - Paths_box hs-source-dirs: test ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints diff --git a/readme.md b/readme.md --- a/readme.md +++ b/readme.md @@ -48,5 +48,5 @@ --- ``` -stack build --test --exec "$(stack path --local-install-root)/bin/box-test" --file-watch +stack build --test --exec "$(stack path --local-install-root)/bin/concurrency-tests" --file-watch ``` diff --git a/src/Box.hs b/src/Box.hs --- a/src/Box.hs +++ b/src/Box.hs @@ -59,6 +59,18 @@ -- >>> let box' = Box <$> committer' <*> emitter' -- >>> let transducer' = Transducer $ \s -> s & S.takeWhile (/="q") & S.map ("echo: " <>) +-- toEmit . S.each +-- + +-- | emitting +-- > toListE . fromListE :: [a] -> IO [a] +-- >>> toListE . fromListE $ [1..3::Int] +-- [1,2,3] +-- +-- > fuse (pure . Just) $ Box <$> (liftC <$> showStdout) <*> (fromListE [1..3::Int]) + + + -- $commit -- committing -- diff --git a/src/Box/Connectors.hs b/src/Box/Connectors.hs --- a/src/Box/Connectors.hs +++ b/src/Box/Connectors.hs @@ -24,6 +24,8 @@ splitCommit, splitCommitSTM, contCommit, + fromListE, + toListE, ) where @@ -179,3 +181,26 @@ Cont m (Emitter m a) feedbackE f e = emergeM ((,) <$> pure e <*> fuseEmitM (emap f e)) + +-- | turn a list into an emitter +fromListE :: [a] -> Cont IO (Emitter IO a) +fromListE xs = Cont $ queueEM' (eListC (Emitter . pure . Just <$> xs)) + +eListC :: (Monad m) => [Emitter m a] -> Committer m a -> m () +eListC [] _ = pure () +eListC (e:es) c = do + x <- emit e + case x of + Nothing -> pure () + Just x' -> commit c x' >> eListC es c + +-- | turn a list into an emitter +toListE :: (MonadConc m) => Cont m (Emitter m a) -> m [a] +toListE ce = with ce (go []) + where + go xs e = do + x <- emit e + case x of + Nothing -> pure (reverse xs) + Just x' -> go (x':xs) e + diff --git a/src/Box/Control.hs b/src/Box/Control.hs --- a/src/Box/Control.hs +++ b/src/Box/Control.hs @@ -175,7 +175,7 @@ dec r = do info "dec" cfg@(CBS _ n) <- readIORef r - writeIORef r (cfg {restartsLeft = n -1}) + writeIORef r (cfg {restartsLeft = n - 1}) start r s = do info "start" (CBS a _) <- readIORef r diff --git a/src/Box/IO.hs b/src/Box/IO.hs --- a/src/Box/IO.hs +++ b/src/Box/IO.hs @@ -1,6 +1,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -32,6 +34,9 @@ toListM, getCommissions, getEmissions, + fileEmitter, + fileCommitter, + appendCommitter, ) where @@ -48,15 +53,11 @@ import Control.Monad import qualified Control.Monad.Conc.Class as C import Control.Monad.Conc.Class (STM) -import Control.Monad.IO.Class -import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.IO as Text -import Streaming (Of (..), Stream) -import qualified Streaming.Internal as S import qualified Streaming.Prelude as S import System.IO hiding (getLine) -import Prelude hiding (getLine) +import Protolude hiding (getLine, STM) -- * console @@ -155,34 +156,30 @@ consolePlug n = boxPlug (eStdout n) (cStdin n) -- * file operations +-- | Emits lines of Text from a handle. +emitLines :: Handle -> Emitter IO Text +emitLines h = Emitter $ do + l :: (Either IOException Text) <- try (Text.hGetLine h) + pure $ case l of + Left _ -> Nothing + Right a -> bool (Just a) Nothing (a == "") --- | emit lines from a file -emitLines :: FilePath -> Cont IO (Emitter (STM IO) Text) -emitLines filePath = Cont (withFile filePath ReadMode) >>= (toEmit . fromHandle) - where - fromHandle :: Handle -> Stream (Of Text) IO () - fromHandle h = - forever $ do - a <- liftIO $ Text.hGetLine h - S.yield a +-- | Commit lines of Text to a handle. +commitLines :: Handle -> Committer IO Text +commitLines h = Committer $ \a -> do + Text.hPutStrLn h a + pure True --- | commit lines to a file -commitLines :: FilePath -> Cont IO (Committer (STM IO) Text) -commitLines filePath = - Cont (withFile filePath WriteMode) >>= (toCommit . toHandle) - where - toHandle h = loop - where - loop str = - case str of - S.Return r -> return r - S.Effect m -> m >>= loop - S.Step (s :> rest) -> do - liftIO (Text.hPutStrLn h s) - loop rest +fileEmitter :: FilePath -> Cont IO (Emitter IO Text) +fileEmitter fp = Cont $ \eio -> withFile fp ReadMode (eio . emitLines) --- * concurrent refs +fileCommitter :: FilePath -> Cont IO (Committer IO Text) +fileCommitter fp = Cont $ \cio -> withFile fp WriteMode (cio . commitLines) +appendCommitter :: FilePath -> Cont IO (Committer IO Text) +appendCommitter fp = Cont $ \cio -> withFile fp AppendMode (cio . commitLines) + +-- * concurrent refs -- | commit to a list CRef cCRef :: (C.MonadConc m) => m (C.IORef m [b], Cont m (Committer (C.STM m) b), m [b]) cCRef = do diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,7 @@ -resolver: lts-15.6 +resolver: lts-15.13 packages: - . -extra-deps: [] +extra-deps: + - protolude-0.3.0