fix: more Pipes.Collect utils, stack-safety

This commit is contained in:
bingus 2024-05-11 18:01:34 -05:00
parent f2f18c3c13
commit 634e52fe39
Signed by: orion
GPG Key ID: 6D4165AE4C928719
14 changed files with 354 additions and 136 deletions

View File

@ -1,6 +1,7 @@
{ {
"name": "purescript-csv-stream", "name": "purescript-node-stream-pipes",
"version": "v1.0.5", "version": "v1.0.5",
"type": "module",
"dependencies": { "dependencies": {
"csv-parse": "^5.5.5", "csv-parse": "^5.5.5",
"csv-stringify": "^6.4.6" "csv-stringify": "^6.4.6"

View File

@ -9,6 +9,8 @@ workspace:
- either: ">=6.1.0 <7.0.0" - either: ">=6.1.0 <7.0.0"
- exceptions: ">=6.0.0 <7.0.0" - exceptions: ">=6.0.0 <7.0.0"
- foldable-traversable: ">=6.0.0 <7.0.0" - foldable-traversable: ">=6.0.0 <7.0.0"
- foreign-object
- lists
- maybe: ">=6.0.0 <7.0.0" - maybe: ">=6.0.0 <7.0.0"
- mmorph: ">=7.0.0 <8.0.0" - mmorph: ">=7.0.0 <8.0.0"
- newtype: ">=5.0.0 <6.0.0" - newtype: ">=5.0.0 <6.0.0"
@ -18,6 +20,7 @@ workspace:
- node-path: ">=5.0.0 <6.0.0" - node-path: ">=5.0.0 <6.0.0"
- node-streams: ">=9.0.0 <10.0.0" - node-streams: ">=9.0.0 <10.0.0"
- node-zlib: ">=0.4.0 <0.5.0" - node-zlib: ">=0.4.0 <0.5.0"
- ordered-collections
- parallel: ">=6.0.0 <7.0.0" - parallel: ">=6.0.0 <7.0.0"
- pipes: ">=8.0.0 <9.0.0" - pipes: ">=8.0.0 <9.0.0"
- prelude: ">=6.0.1 <7.0.0" - prelude: ">=6.0.1 <7.0.0"
@ -25,6 +28,8 @@ workspace:
- strings: ">=6.0.1 <7.0.0" - strings: ">=6.0.1 <7.0.0"
- tailrec: ">=6.1.0 <7.0.0" - tailrec: ">=6.1.0 <7.0.0"
- transformers: ">=6.0.0 <7.0.0" - transformers: ">=6.0.0 <7.0.0"
- tuples
- unordered-collections
- unsafe-coerce: ">=6.0.0 <7.0.0" - unsafe-coerce: ">=6.0.0 <7.0.0"
test_dependencies: test_dependencies:
- console - console
@ -105,6 +110,7 @@ workspace:
- type-equality - type-equality
- typelevel-prelude - typelevel-prelude
- unfoldable - unfoldable
- unordered-collections
- unsafe-coerce - unsafe-coerce
- variant - variant
extra_packages: {} extra_packages: {}
@ -903,6 +909,21 @@ packages:
- partial - partial
- prelude - prelude
- tuples - tuples
unordered-collections:
type: registry
version: 3.1.0
integrity: sha256-H2eQR+ylI+cljz4XzWfEbdF7ee+pnw2IZCeq69AuJ+Q=
dependencies:
- arrays
- enums
- functions
- integers
- lists
- prelude
- record
- tuples
- typelevel-prelude
- unfoldable
unsafe-coerce: unsafe-coerce:
type: registry type: registry
version: 6.0.0 version: 6.0.0

View File

@ -10,6 +10,11 @@ package:
strict: true strict: true
pedanticPackages: true pedanticPackages: true
dependencies: dependencies:
- foreign-object
- lists
- ordered-collections
- tuples
- unordered-collections
- aff: ">=7.1.0 <8.0.0" - aff: ">=7.1.0 <8.0.0"
- arrays: ">=7.3.0 <8.0.0" - arrays: ">=7.3.0 <8.0.0"
- effect: ">=4.0.0 <5.0.0" - effect: ">=4.0.0 <5.0.0"

View File

@ -1,35 +1,39 @@
import Stream from "stream"; import Stream from "stream";
/** @type {(s: Stream.Readable | Stream.Transform) => () => boolean} */ /** @type {(s: Stream.Readable | Stream.Transform) => () => boolean} */
export const isReadableImpl = s => () => s.readable export const isReadableImpl = (s) => () => s.readable;
/** @type {(s: Stream.Writable | Stream.Readable) => () => boolean} */ /** @type {(s: Stream.Writable | Stream.Readable) => () => boolean} */
export const isClosedImpl = s => () => s.closed export const isClosedImpl = (s) => () => s.closed;
/** @type {(s: Stream.Writable | Stream.Transform) => () => boolean} */ /** @type {(s: Stream.Writable | Stream.Transform) => () => boolean} */
export const isWritableImpl = s => () => s.writable export const isWritableImpl = (s) => () => s.writable;
/** @type {(s: Stream.Readable | Stream.Transform) => () => boolean} */ /** @type {(s: Stream.Readable | Stream.Transform) => () => boolean} */
export const isReadableEndedImpl = s => () => s.readableEnded export const isReadableEndedImpl = (s) => () => s.readableEnded;
/** @type {(s: Stream.Writable | Stream.Transform) => () => boolean} */ /** @type {(s: Stream.Writable | Stream.Transform) => () => boolean} */
export const isWritableEndedImpl = s => () => s.writableEnded export const isWritableEndedImpl = (s) => () => s.writableEnded;
/** @type {(s: Stream.Writable | Stream.Transform) => () => void} */ /** @type {(s: Stream.Writable | Stream.Transform) => () => void} */
export const endImpl = (s) => () => s.end(); export const endImpl = (s) => () => s.end();
/** @type {<WriteResult>(o: {ok: WriteResult, wouldBlock: WriteResult, closed: WriteResult}) => (s: Stream.Writable | Stream.Transform) => (a: unknown) => () => WriteResult} */ /** @type {<WriteResult>(o: {ok: WriteResult, wouldBlock: WriteResult, closed: WriteResult}) => (s: Stream.Writable | Stream.Transform) => (a: unknown) => () => WriteResult} */
export const writeImpl = ({ok, wouldBlock, closed}) => (s) => (a) => () => { export const writeImpl =
if (s.closed || s.writableEnded) { ({ ok, wouldBlock, closed }) =>
return closed (s) =>
} (a) =>
() => {
if (s.closed || s.writableEnded) {
return closed;
}
if (s.write(a)) { if (s.write(a)) {
return ok return ok;
} else { } else {
return wouldBlock return wouldBlock;
} }
} };
/** @type {<ReadResult>(o: {just: (_a: unknown) => ReadResult, wouldBlock: ReadResult, closed: ReadResult}) => (s: Stream.Readable | Stream.Transform) => () => ReadResult} */ /** @type {<ReadResult>(o: {just: (_a: unknown) => ReadResult, wouldBlock: ReadResult, closed: ReadResult}) => (s: Stream.Readable | Stream.Transform) => () => ReadResult} */
export const readImpl = export const readImpl =

View File

@ -28,6 +28,7 @@ data ReadResult a
= ReadWouldBlock = ReadWouldBlock
| ReadClosed | ReadClosed
| ReadJust a | ReadJust a
derive instance Generic (ReadResult a) _ derive instance Generic (ReadResult a) _
derive instance Functor ReadResult derive instance Functor ReadResult
derive instance Eq a => Eq (ReadResult a) derive instance Eq a => Eq (ReadResult a)
@ -38,9 +39,11 @@ data WriteResult
= WriteWouldBlock = WriteWouldBlock
| WriteClosed | WriteClosed
| WriteOk | WriteOk
derive instance Generic WriteResult _ derive instance Generic WriteResult _
derive instance Eq WriteResult derive instance Eq WriteResult
instance Show WriteResult where show = genericShow instance Show WriteResult where
show = genericShow
type ReadResultFFI a = { closed :: ReadResult a, wouldBlock :: ReadResult a, just :: a -> ReadResult a } type ReadResultFFI a = { closed :: ReadResult a, wouldBlock :: ReadResult a, just :: a -> ReadResult a }
type WriteResultFFI = { closed :: WriteResult, wouldBlock :: WriteResult, ok :: WriteResult } type WriteResultFFI = { closed :: WriteResult, wouldBlock :: WriteResult, ok :: WriteResult }
@ -59,10 +62,10 @@ foreign import isWritableEndedImpl :: forall s. s -> Effect Boolean
foreign import isClosedImpl :: forall s. s -> Effect Boolean foreign import isClosedImpl :: forall s. s -> Effect Boolean
readResultFFI :: forall a. ReadResultFFI a readResultFFI :: forall a. ReadResultFFI a
readResultFFI = {closed: ReadClosed, wouldBlock: ReadWouldBlock, just: ReadJust} readResultFFI = { closed: ReadClosed, wouldBlock: ReadWouldBlock, just: ReadJust }
writeResultFFI :: WriteResultFFI writeResultFFI :: WriteResultFFI
writeResultFFI = {closed: WriteClosed, wouldBlock: WriteWouldBlock, ok: WriteOk} writeResultFFI = { closed: WriteClosed, wouldBlock: WriteWouldBlock, ok: WriteOk }
class Stream :: Type -> Constraint class Stream :: Type -> Constraint
class Stream s where class Stream s where
@ -117,11 +120,11 @@ else instance (Write s a) => Write s a where
write s a = write s a write s a = write s a
end s = end s end s = end s
withErrorST :: forall s. Stream s => s -> Effect {cancel :: Effect Unit, error :: STRef Global (Maybe Error)} withErrorST :: forall s. Stream s => s -> Effect { cancel :: Effect Unit, error :: STRef Global (Maybe Error) }
withErrorST s = do withErrorST s = do
error <- liftST $ STRef.new Nothing error <- liftST $ STRef.new Nothing
cancel <- flip (Event.once errorH) s \e -> void $ liftST $ STRef.write (Just e) error cancel <- flip (Event.once errorH) s \e -> void $ liftST $ STRef.write (Just e) error
pure {error, cancel} pure { error, cancel }
fromBufferReadable :: forall r. Stream.Readable r -> Readable Buffer fromBufferReadable :: forall r. Stream.Readable r -> Readable Buffer
fromBufferReadable = unsafeCoerce fromBufferReadable = unsafeCoerce
@ -147,7 +150,7 @@ awaitReadableOrClosed s = do
ended <- liftEffect $ isReadableEnded s ended <- liftEffect $ isReadableEnded s
readable <- liftEffect $ isReadable s readable <- liftEffect $ isReadable s
when (not ended && not closed && not readable) when (not ended && not closed && not readable)
$ liftEither =<< parOneOf [onceAff0 readableH s $> Right unit, onceAff0 closeH s $> Right unit, Left <$> onceAff1 errorH s] $ liftEither =<< parOneOf [ onceAff0 readableH s $> Right unit, onceAff0 closeH s $> Right unit, Left <$> onceAff1 errorH s ]
awaitWritableOrClosed :: forall s a. Write s a => s -> Aff Unit awaitWritableOrClosed :: forall s a. Write s a => s -> Aff Unit
awaitWritableOrClosed s = do awaitWritableOrClosed s = do
@ -155,7 +158,7 @@ awaitWritableOrClosed s = do
ended <- liftEffect $ isWritableEnded s ended <- liftEffect $ isWritableEnded s
writable <- liftEffect $ isWritable s writable <- liftEffect $ isWritable s
when (not ended && not closed && not writable) when (not ended && not closed && not writable)
$ liftEither =<< parOneOf [onceAff0 drainH s $> Right unit, onceAff0 closeH s $> Right unit, Left <$> onceAff1 errorH s] $ liftEither =<< parOneOf [ onceAff0 drainH s $> Right unit, onceAff0 closeH s $> Right unit, Left <$> onceAff1 errorH s ]
onceAff0 :: forall e. EventHandle0 e -> e -> Aff Unit onceAff0 :: forall e. EventHandle0 e -> e -> Aff Unit
onceAff0 h emitter = makeAff \res -> do onceAff0 h emitter = makeAff \res -> do

View File

@ -2,17 +2,81 @@ module Pipes.Collect where
import Prelude import Prelude
import Control.Monad.Rec.Class (class MonadRec) import Control.Monad.Maybe.Trans (MaybeT(..), runMaybeT)
import Control.Monad.Rec.Class (class MonadRec, Step(..), tailRecM)
import Control.Monad.ST.Class (liftST) import Control.Monad.ST.Class (liftST)
import Control.Monad.Trans.Class (lift)
import Data.Array.ST as Array.ST import Data.Array.ST as Array.ST
import Data.Either (hush)
import Data.HashMap (HashMap)
import Data.HashMap as HashMap
import Data.Hashable (class Hashable)
import Data.List (List)
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Tuple.Nested (type (/\), (/\))
import Effect.Class (class MonadEffect, liftEffect) import Effect.Class (class MonadEffect, liftEffect)
import Pipes (for) as Pipes import Foreign.Object (Object)
import Foreign.Object.ST as Object.ST
import Foreign.Object.ST.Unsafe as Object.ST.Unsafe
import Pipes (next) as Pipes
import Pipes.Core (Producer) import Pipes.Core (Producer)
import Pipes.Core (runEffect) as Pipes
-- | Traverse a pipe, collecting into a mutable array with constant stack usage -- | Fold every value produced
collectArray :: forall a m. MonadRec m => MonadEffect m => Producer a m Unit -> m (Array a) -- |
collectArray p = do -- | Uses `MonadRec`, supporting producers of arbitrary length.
fold :: forall a b m. MonadRec m => (b -> a -> b) -> b -> Producer a m Unit -> m b
fold f b p =
let
insertNext b' p' = runMaybeT do
a /\ p'' <- MaybeT $ hush <$> Pipes.next p'
pure $ Loop $ f b' a /\ p''
in
flip tailRecM (b /\ p) \(b' /\ p') -> fromMaybe (Done b') <$> insertNext b' p'
-- | Fold every value produced with a monadic action
-- |
-- | Uses `MonadRec`, supporting producers of arbitrary length.
traverse :: forall a b m. MonadRec m => (b -> a -> m b) -> b -> Producer a m Unit -> m b
traverse f b p =
let
insertNext b' p' = runMaybeT do
a /\ p'' <- MaybeT $ hush <$> Pipes.next p'
b'' <- lift $ f b' a
pure $ Loop $ b'' /\ p''
in
flip tailRecM (b /\ p) \(b' /\ p') -> fromMaybe (Done b') <$> insertNext b' p'
-- | Execute a monadic action on every item in a producer.
-- |
-- | Uses `MonadRec`, supporting producers of arbitrary length.
foreach :: forall a m. MonadRec m => (a -> m Unit) -> Producer a m Unit -> m Unit
foreach f = traverse (const f) unit
-- | Collect all values from a `Producer` into an array.
toArray :: forall a m. MonadRec m => MonadEffect m => Producer a m Unit -> m (Array a)
toArray p = do
st <- liftEffect $ liftST $ Array.ST.new st <- liftEffect $ liftST $ Array.ST.new
Pipes.runEffect $ Pipes.for p \a -> void $ liftEffect $ liftST $ Array.ST.push a st foreach (void <<< liftEffect <<< liftST <<< flip Array.ST.push st) p
liftEffect $ liftST $ Array.ST.unsafeFreeze st liftEffect $ liftST $ Array.ST.unsafeFreeze st
-- | Collect all values from a `Producer` into a list.
toList :: forall a m. MonadRec m => MonadEffect m => Producer a m Unit -> m (List a)
toList = map List.reverse <<< fold (flip List.Cons) List.Nil
-- | Collect all values from a `Producer` into a Javascript Object.
toObject :: forall a m. MonadRec m => MonadEffect m => Producer (String /\ a) m Unit -> m (Object a)
toObject p = do
st <- liftEffect $ liftST $ Object.ST.new
foreach (\(k /\ v) -> void $ liftEffect $ liftST $ Object.ST.poke k v st) p
liftEffect $ liftST $ Object.ST.Unsafe.unsafeFreeze st
-- | Collect all values from a `Producer` into a `HashMap`
toHashMap :: forall k v m. Hashable k => MonadRec m => Producer (k /\ v) m Unit -> m (HashMap k v)
toHashMap = fold (\map (k /\ v) -> HashMap.insert k v map) HashMap.empty
-- | Collect all values from a `Producer` into a `Map`
toMap :: forall k v m. Ord k => MonadRec m => Producer (k /\ v) m Unit -> m (Map k v)
toMap = fold (\map (k /\ v) -> Map.insert k v map) Map.empty

View File

@ -23,8 +23,10 @@ import Prim.Row (class Union)
-- | into `Producer (Maybe a)`, emitting `Nothing` before exiting. -- | into `Producer (Maybe a)`, emitting `Nothing` before exiting.
write write
:: forall r trash :: forall r trash
. Union r trash WriteStreamOptions . Union r trash WriteStreamOptions
=> Record r -> FilePath -> Consumer (Maybe Buffer) Aff Unit => Record r
-> FilePath
-> Consumer (Maybe Buffer) Aff Unit
write o p = do write o p = do
w <- liftEffect $ FS.Stream.createWriteStream' p o w <- liftEffect $ FS.Stream.createWriteStream' p o
fromWritable $ O.fromBufferWritable w fromWritable $ O.fromBufferWritable w
@ -33,19 +35,19 @@ write o p = do
-- | -- |
-- | `write {flags: "wx"}` -- | `write {flags: "wx"}`
create :: FilePath -> Consumer (Maybe Buffer) Aff Unit create :: FilePath -> Consumer (Maybe Buffer) Aff Unit
create = write {flags: "wx"} create = write { flags: "wx" }
-- | Open a file in write mode, truncating it if the file already exists. -- | Open a file in write mode, truncating it if the file already exists.
-- | -- |
-- | `write {flags: "w"}` -- | `write {flags: "w"}`
truncate :: FilePath -> Consumer (Maybe Buffer) Aff Unit truncate :: FilePath -> Consumer (Maybe Buffer) Aff Unit
truncate = write {flags: "w"} truncate = write { flags: "w" }
-- | Open a file in write mode, appending written contents if the file already exists. -- | Open a file in write mode, appending written contents if the file already exists.
-- | -- |
-- | `write {flags: "a"}` -- | `write {flags: "a"}`
append :: FilePath -> Consumer (Maybe Buffer) Aff Unit append :: FilePath -> Consumer (Maybe Buffer) Aff Unit
append = write {flags: "a"} append = write { flags: "a" }
-- | Creates a `fs.Readable` stream for the file at the given path. -- | Creates a `fs.Readable` stream for the file at the given path.
-- | -- |

View File

@ -30,19 +30,20 @@ fromReadable r =
liftEffect rmErrorListener liftEffect rmErrorListener
pure $ Done unit pure $ Done unit
go {error, cancel} = do go { error, cancel } = do
liftAff $ delay $ wrap 0.0 liftAff $ delay $ wrap 0.0
err <- liftEffect $ liftST $ STRef.read error err <- liftEffect $ liftST $ STRef.read error
for_ err throwError for_ err throwError
res <- liftEffect $ O.read r res <- liftEffect $ O.read r
case res of case res of
O.ReadJust a -> yield (Just a) $> Loop {error, cancel} O.ReadJust a -> yield (Just a) $> Loop { error, cancel }
O.ReadWouldBlock -> lift (O.awaitReadableOrClosed r) $> Loop {error, cancel} O.ReadWouldBlock -> lift (O.awaitReadableOrClosed r) $> Loop { error, cancel }
O.ReadClosed -> yield Nothing *> cleanup cancel O.ReadClosed -> yield Nothing *> cleanup cancel
in do in
e <- liftEffect $ O.withErrorST r do
tailRecM go e e <- liftEffect $ O.withErrorST r
tailRecM go e
-- | Convert a `Writable` stream to a `Pipe`. -- | Convert a `Writable` stream to a `Pipe`.
-- | -- |
@ -56,7 +57,7 @@ fromWritable w =
liftEffect $ O.end w liftEffect $ O.end w
pure $ Done unit pure $ Done unit
go {error, cancel} = do go { error, cancel } = do
liftAff $ delay $ wrap 0.0 liftAff $ delay $ wrap 0.0
err <- liftEffect $ liftST $ STRef.read error err <- liftEffect $ liftST $ STRef.read error
for_ err throwError for_ err throwError
@ -67,14 +68,15 @@ fromWritable w =
Just a -> do Just a -> do
res <- liftEffect $ O.write w a res <- liftEffect $ O.write w a
case res of case res of
O.WriteOk -> pure $ Loop {error, cancel} O.WriteOk -> pure $ Loop { error, cancel }
O.WriteWouldBlock -> do O.WriteWouldBlock -> do
liftAff (O.awaitWritableOrClosed w) liftAff (O.awaitWritableOrClosed w)
pure $ Loop {error, cancel} pure $ Loop { error, cancel }
O.WriteClosed -> cleanup cancel O.WriteClosed -> cleanup cancel
in do in
r <- liftEffect $ O.withErrorST w do
tailRecM go r r <- liftEffect $ O.withErrorST w
tailRecM go r
-- | Convert a `Transform` stream to a `Pipe`. -- | Convert a `Transform` stream to a `Pipe`.
-- | -- |
@ -94,7 +96,7 @@ fromTransform t =
O.ReadJust a -> yield (Just a) O.ReadJust a -> yield (Just a)
O.ReadWouldBlock -> pure unit O.ReadWouldBlock -> pure unit
O.ReadClosed -> yield Nothing *> pure unit O.ReadClosed -> yield Nothing *> pure unit
go {error, cancel} = do go { error, cancel } = do
liftAff $ delay $ wrap 0.0 liftAff $ delay $ wrap 0.0
err <- liftEffect $ liftST $ STRef.read error err <- liftEffect $ liftST $ STRef.read error
for_ err throwError for_ err throwError
@ -107,13 +109,14 @@ fromTransform t =
yieldFromReadableHalf yieldFromReadableHalf
case res of case res of
O.WriteClosed -> cleanup cancel O.WriteClosed -> cleanup cancel
O.WriteOk -> pure $ Loop {error, cancel} O.WriteOk -> pure $ Loop { error, cancel }
O.WriteWouldBlock -> do O.WriteWouldBlock -> do
lift (O.awaitWritableOrClosed t) lift (O.awaitWritableOrClosed t)
pure $ Loop {error, cancel} pure $ Loop { error, cancel }
in do in
r <- liftEffect $ O.withErrorST t do
tailRecM go r r <- liftEffect $ O.withErrorST t
tailRecM go r
-- | Given a `Producer` of values, wrap them in `Just`. -- | Given a `Producer` of values, wrap them in `Just`.
-- | -- |

View File

@ -33,7 +33,7 @@ split pat = do
Nothing -> void $ liftEffect $ liftST $ Array.ST.push chunk buf Nothing -> void $ liftEffect $ liftST $ Array.ST.push chunk buf
Just ix -> do Just ix -> do
let let
{before, after} = String.splitAt ix chunk { before, after } = String.splitAt ix chunk
len <- liftEffect $ liftST $ Array.ST.length buf len <- liftEffect $ liftST $ Array.ST.length buf
buf' <- liftEffect $ liftST $ Array.ST.splice 0 len [] buf buf' <- liftEffect $ liftST $ Array.ST.splice 0 len [] buf
lift $ yield $ Just $ (fold buf') <> before lift $ yield $ Just $ (fold buf') <> before

View File

@ -8,6 +8,7 @@ import Effect.Aff (launchAff_)
import Test.Pipes.Node.Stream as Test.Pipes.Node.Stream import Test.Pipes.Node.Stream as Test.Pipes.Node.Stream
import Test.Pipes.Node.Buffer as Test.Pipes.Node.Buffer import Test.Pipes.Node.Buffer as Test.Pipes.Node.Buffer
import Test.Pipes.Node.FS as Test.Pipes.Node.FS import Test.Pipes.Node.FS as Test.Pipes.Node.FS
import Test.Pipes.Collect as Test.Pipes.Collect
import Test.Spec.Reporter (specReporter) import Test.Spec.Reporter (specReporter)
import Test.Spec.Runner (defaultConfig, runSpec') import Test.Spec.Runner (defaultConfig, runSpec')
@ -16,3 +17,4 @@ main = launchAff_ $ runSpec' (defaultConfig { failFast = true, timeout = Nothing
Test.Pipes.Node.Stream.spec Test.Pipes.Node.Stream.spec
Test.Pipes.Node.Buffer.spec Test.Pipes.Node.Buffer.spec
Test.Pipes.Node.FS.spec Test.Pipes.Node.FS.spec
Test.Pipes.Collect.spec

View File

@ -0,0 +1,111 @@
module Test.Pipes.Collect where
import Prelude
import Control.Monad.Gen (chooseInt)
import Control.Monad.Rec.Class (Step(..), tailRecM)
import Control.Monad.ST as ST
import Control.Monad.ST.Ref as STRef
import Data.Array as Array
import Data.Bifunctor (lmap)
import Data.HashMap (HashMap)
import Data.HashMap as HashMap
import Data.List (List)
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Traversable (traverse)
import Data.Tuple.Nested (type (/\), (/\))
import Effect.Aff (Aff)
import Effect.Class (liftEffect)
import Effect.Unsafe (unsafePerformEffect)
import Foreign.Object (Object)
import Foreign.Object as Object
import Pipes (yield)
import Pipes.Collect as Pipes.Collect
import Pipes.Core (Producer)
import Test.QuickCheck.Gen (randomSampleOne)
import Test.Spec (Spec, describe, it)
import Test.Spec.Assertions (shouldEqual)
testData
:: { array :: Array (Int /\ Int)
, list :: List (Int /\ Int)
, strarray :: Array (String /\ Int)
, object :: Object Int
, map :: Map Int Int
, hashMap :: HashMap Int Int
, stream :: Producer (Int /\ Int) Aff Unit
, streamStr :: Producer (String /\ Int) Aff Unit
}
testData =
unsafePerformEffect $ do
array <-
flip traverse (Array.range 0 99999) \k -> do
v <- liftEffect $ randomSampleOne $ chooseInt 0 99999
pure $ k /\ v
let
strarray = lmap show <$> array
object = Object.fromFoldable strarray
map' :: forall m. m -> (Int -> Int -> m -> m) -> m
map' empty insert = ST.run do
st <- STRef.new empty
ST.foreach array \(k /\ v) -> void $ STRef.modify (insert k v) st
STRef.read st
hashMap = map' HashMap.empty HashMap.insert
map = map' Map.empty Map.insert
pure
{ array
, strarray
, list: List.fromFoldable array
, object
, hashMap
, map
, stream: flip tailRecM 0 \ix -> case Array.index array ix of
Just a -> yield a $> Loop (ix + 1)
Nothing -> pure $ Done unit
, streamStr: flip tailRecM 0 \ix -> case Array.index strarray ix of
Just a -> yield a $> Loop (ix + 1)
Nothing -> pure $ Done unit
}
spec :: Spec Unit
spec =
describe "Test.Pipes.Collect" do
describe "toArray" do
it "collects an array" do
act <- Pipes.Collect.toArray testData.stream
act `shouldEqual` testData.array
it "empty ok" do
act :: Array Int <- Pipes.Collect.toArray (pure unit)
act `shouldEqual` []
describe "toObject" do
it "collects" do
act <- Pipes.Collect.toObject $ testData.streamStr
act `shouldEqual` testData.object
it "empty ok" do
act :: Object Int <- Pipes.Collect.toObject (pure unit)
act `shouldEqual` Object.empty
describe "toMap" do
it "collects" do
act <- Pipes.Collect.toMap testData.stream
act `shouldEqual` testData.map
it "empty ok" do
act :: Map String Int <- Pipes.Collect.toMap (pure unit)
act `shouldEqual` Map.empty
describe "toHashMap" do
it "collects" do
act <- Pipes.Collect.toHashMap testData.stream
act `shouldEqual` testData.hashMap
it "empty ok" do
act :: HashMap String Int <- Pipes.Collect.toHashMap (pure unit)
act `shouldEqual` HashMap.empty
describe "toList" do
it "collects" do
act <- Pipes.Collect.toList testData.stream
act `shouldEqual` testData.list
it "empty ok" do
act :: List (String /\ Int) <- Pipes.Collect.toList (pure unit)
act `shouldEqual` List.Nil

View File

@ -27,6 +27,7 @@ import Test.Spec (Spec, describe, it)
import Test.Spec.Assertions (fail, shouldEqual) import Test.Spec.Assertions (fail, shouldEqual)
data BufferJunk = BufferJunk Buffer data BufferJunk = BufferJunk Buffer
instance Arbitrary BufferJunk where instance Arbitrary BufferJunk where
arbitrary = sized \s -> do arbitrary = sized \s -> do
ns <- vectorOf s (chooseInt 0 7) ns <- vectorOf s (chooseInt 0 7)
@ -36,6 +37,7 @@ instance Arbitrary BufferJunk where
pure $ BufferJunk buf pure $ BufferJunk buf
data BufferUTF8 = BufferUTF8 String Buffer data BufferUTF8 = BufferUTF8 String Buffer
instance Arbitrary BufferUTF8 where instance Arbitrary BufferUTF8 where
arbitrary = do arbitrary = do
s <- genAsciiString s <- genAsciiString
@ -43,27 +45,27 @@ instance Arbitrary BufferUTF8 where
spec :: Spec Unit spec :: Spec Unit
spec = describe "Pipes.Node.Buffer" do spec = describe "Pipes.Node.Buffer" do
describe "toString" do describe "toString" do
it "fails when encoding wrong" do it "fails when encoding wrong" do
vals <- Pipes.each <$> (map \(BufferJunk b) -> b) <$> liftEffect (randomSample' 10 arbitrary) vals <- Pipes.each <$> (map \(BufferJunk b) -> b) <$> liftEffect (randomSample' 10 arbitrary)
let let
uut = Pipes.runEffect $ vals >-> Pipes.Node.Buffer.toString UTF8 >-> Pipes.drain uut = Pipes.runEffect $ vals >-> Pipes.Node.Buffer.toString UTF8 >-> Pipes.drain
ok = do ok = do
uut uut
fail "Should have thrown" fail "Should have thrown"
err _ = pure unit err _ = pure unit
catchError ok err catchError ok err
it "junk OK in hex" do it "junk OK in hex" do
vals <- Pipes.each <$> (map \(BufferJunk b) -> b) <$> liftEffect (randomSample' 10 arbitrary) vals <- Pipes.each <$> (map \(BufferJunk b) -> b) <$> liftEffect (randomSample' 10 arbitrary)
Pipes.runEffect $ vals >-> Pipes.Node.Buffer.toString Hex >-> Pipes.drain Pipes.runEffect $ vals >-> Pipes.Node.Buffer.toString Hex >-> Pipes.drain
it "UTF8 ok" do it "UTF8 ok" do
vals <- (map \(BufferUTF8 s b) -> s /\ b) <$> liftEffect (randomSample' 100 arbitrary) vals <- (map \(BufferUTF8 s b) -> s /\ b) <$> liftEffect (randomSample' 100 arbitrary)
let let
bufs = Pipes.each $ snd <$> vals bufs = Pipes.each $ snd <$> vals
strs = fst <$> vals strs = fst <$> vals
act <- Array.fromFoldable <$> Pipes.toListM (bufs >-> Pipes.Node.Buffer.toString UTF8) act <- Array.fromFoldable <$> Pipes.toListM (bufs >-> Pipes.Node.Buffer.toString UTF8)
act `shouldEqual` strs act `shouldEqual` strs
describe "fromString" do describe "fromString" do
it "ok" do it "ok" do
vals <- Pipes.each <$> liftEffect (randomSample' 100 genAsciiString) vals <- Pipes.each <$> liftEffect (randomSample' 100 genAsciiString)
Pipes.runEffect $ vals >-> Pipes.Node.Buffer.fromString UTF8 >-> Pipes.drain Pipes.runEffect $ vals >-> Pipes.Node.Buffer.fromString UTF8 >-> Pipes.drain

View File

@ -24,63 +24,63 @@ import Test.Spec.Assertions (fail, shouldEqual)
spec :: Spec Unit spec :: Spec Unit
spec = describe "Pipes.Node.FS" do spec = describe "Pipes.Node.FS" do
describe "read" do describe "read" do
around tmpFile $ it "fails if the file does not exist" \p -> do around tmpFile $ it "fails if the file does not exist" \p -> do
flip catchError (const $ pure unit) do flip catchError (const $ pure unit) do
Pipes.runEffect $ Pipes.Node.FS.read p >-> Pipes.drain Pipes.runEffect $ Pipes.Node.FS.read p >-> Pipes.drain
fail "should have thrown" fail "should have thrown"
around tmpFile $ it "reads ok" \p -> do around tmpFile $ it "reads ok" \p -> do
liftEffect $ FS.writeTextFile UTF8 p "foo" liftEffect $ FS.writeTextFile UTF8 p "foo"
s <- fold <$> Pipes.toListM (Pipes.Node.FS.read p >-> unEOS >-> Pipes.Node.Buffer.toString UTF8) s <- fold <$> Pipes.toListM (Pipes.Node.FS.read p >-> unEOS >-> Pipes.Node.Buffer.toString UTF8)
s `shouldEqual` "foo" s `shouldEqual` "foo"
around tmpFile $ it "fails if the file already exists" \p -> do around tmpFile $ it "fails if the file already exists" \p -> do
liftEffect $ FS.writeTextFile UTF8 "foo" p liftEffect $ FS.writeTextFile UTF8 "foo" p
flip catchError (const $ pure unit) do flip catchError (const $ pure unit) do
Pipes.runEffect $ withEOS (yield "foo" >-> Pipes.Node.Buffer.fromString UTF8) >-> Pipes.Node.FS.create p
fail "should have thrown"
describe "create" do
around tmpFile $ it "creates the file when not exists" \p -> do
Pipes.runEffect $ withEOS (yield "foo" >-> Pipes.Node.Buffer.fromString UTF8) >-> Pipes.Node.FS.create p Pipes.runEffect $ withEOS (yield "foo" >-> Pipes.Node.Buffer.fromString UTF8) >-> Pipes.Node.FS.create p
contents <- liftEffect $ FS.readTextFile UTF8 p fail "should have thrown"
contents `shouldEqual` "foo" describe "create" do
around tmpFile $ it "fails if the file already exists" \p -> do around tmpFile $ it "creates the file when not exists" \p -> do
liftEffect $ FS.writeTextFile UTF8 "foo" p Pipes.runEffect $ withEOS (yield "foo" >-> Pipes.Node.Buffer.fromString UTF8) >-> Pipes.Node.FS.create p
flip catchError (const $ pure unit) do contents <- liftEffect $ FS.readTextFile UTF8 p
Pipes.runEffect $ withEOS (yield "foo" >-> Pipes.Node.Buffer.fromString UTF8) >-> Pipes.Node.FS.create p contents `shouldEqual` "foo"
fail "should have thrown" around tmpFile $ it "fails if the file already exists" \p -> do
describe "append" do liftEffect $ FS.writeTextFile UTF8 "foo" p
around tmpFile $ it "creates the file when not exists" \p -> do flip catchError (const $ pure unit) do
Pipes.runEffect $ withEOS (yield "foo" >-> Pipes.Node.Buffer.fromString UTF8) >-> Pipes.Node.FS.append p Pipes.runEffect $ withEOS (yield "foo" >-> Pipes.Node.Buffer.fromString UTF8) >-> Pipes.Node.FS.create p
contents <- liftEffect $ FS.readTextFile UTF8 p fail "should have thrown"
contents `shouldEqual` "foo" describe "append" do
around tmpFile $ it "appends" \p -> do around tmpFile $ it "creates the file when not exists" \p -> do
Pipes.runEffect $ withEOS (yield "foo" >-> Pipes.Node.Buffer.fromString UTF8) >-> Pipes.Node.FS.append p Pipes.runEffect $ withEOS (yield "foo" >-> Pipes.Node.Buffer.fromString UTF8) >-> Pipes.Node.FS.append p
Pipes.runEffect $ withEOS (yield "\n" >-> Pipes.Node.Buffer.fromString UTF8) >-> Pipes.Node.FS.append p contents <- liftEffect $ FS.readTextFile UTF8 p
Pipes.runEffect $ withEOS (yield "bar" >-> Pipes.Node.Buffer.fromString UTF8) >-> Pipes.Node.FS.append p contents `shouldEqual` "foo"
contents <- liftEffect $ FS.readTextFile UTF8 p around tmpFile $ it "appends" \p -> do
contents `shouldEqual` "foo\nbar" Pipes.runEffect $ withEOS (yield "foo" >-> Pipes.Node.Buffer.fromString UTF8) >-> Pipes.Node.FS.append p
describe "truncate" do Pipes.runEffect $ withEOS (yield "\n" >-> Pipes.Node.Buffer.fromString UTF8) >-> Pipes.Node.FS.append p
around tmpFile $ it "creates the file when not exists" \p -> do Pipes.runEffect $ withEOS (yield "bar" >-> Pipes.Node.Buffer.fromString UTF8) >-> Pipes.Node.FS.append p
Pipes.runEffect $ withEOS (yield "foo" >-> Pipes.Node.Buffer.fromString UTF8) >-> Pipes.Node.FS.truncate p contents <- liftEffect $ FS.readTextFile UTF8 p
contents <- liftEffect $ FS.readTextFile UTF8 p contents `shouldEqual` "foo\nbar"
contents `shouldEqual` "foo" describe "truncate" do
around tmpFile $ it "overwrites contents" \p -> do around tmpFile $ it "creates the file when not exists" \p -> do
Pipes.runEffect $ withEOS (yield "foo" >-> Pipes.Node.Buffer.fromString UTF8) >-> Pipes.Node.FS.truncate p Pipes.runEffect $ withEOS (yield "foo" >-> Pipes.Node.Buffer.fromString UTF8) >-> Pipes.Node.FS.truncate p
Pipes.runEffect $ withEOS (yield "bar" >-> Pipes.Node.Buffer.fromString UTF8) >-> Pipes.Node.FS.truncate p contents <- liftEffect $ FS.readTextFile UTF8 p
contents <- liftEffect $ FS.readTextFile UTF8 p contents `shouldEqual` "foo"
contents `shouldEqual` "bar" around tmpFile $ it "overwrites contents" \p -> do
around tmpFiles $ it "json lines >-> parse >-> _.foo >-> write" \(a /\ b) -> do Pipes.runEffect $ withEOS (yield "foo" >-> Pipes.Node.Buffer.fromString UTF8) >-> Pipes.Node.FS.truncate p
let Pipes.runEffect $ withEOS (yield "bar" >-> Pipes.Node.Buffer.fromString UTF8) >-> Pipes.Node.FS.truncate p
exp = [{foo: "a"}, {foo: "bar"}, {foo: "123"}] contents <- liftEffect $ FS.readTextFile UTF8 p
liftEffect $ FS.writeTextFile UTF8 a $ intercalate "\n" $ writeJSON <$> exp contents `shouldEqual` "bar"
Pipes.runEffect $ around tmpFiles $ it "json lines >-> parse >-> _.foo >-> write" \(a /\ b) -> do
Pipes.Node.FS.read a let
exp = [ { foo: "a" }, { foo: "bar" }, { foo: "123" } ]
liftEffect $ FS.writeTextFile UTF8 a $ intercalate "\n" $ writeJSON <$> exp
Pipes.runEffect $
Pipes.Node.FS.read a
>-> inEOS (Pipes.Node.Buffer.toString UTF8) >-> inEOS (Pipes.Node.Buffer.toString UTF8)
>-> Pipes.String.split (wrap "\n") >-> Pipes.String.split (wrap "\n")
>-> inEOS (jsonParse @{foo :: String}) >-> inEOS (jsonParse @{ foo :: String })
>-> inEOS (Pipes.map _.foo) >-> inEOS (Pipes.map _.foo)
>-> Pipes.Util.intersperse "\n" >-> Pipes.Util.intersperse "\n"
>-> inEOS (Pipes.Node.Buffer.fromString UTF8) >-> inEOS (Pipes.Node.Buffer.fromString UTF8)
>-> Pipes.Node.FS.create b >-> Pipes.Node.FS.create b
act <- liftEffect $ FS.readTextFile UTF8 b act <- liftEffect $ FS.readTextFile UTF8 b
act `shouldEqual` "a\nbar\n123" act `shouldEqual` "a\nbar\n123"

View File

@ -96,7 +96,7 @@ spec =
str :: String <- genAlphaString str :: String <- genAlphaString
num :: Int <- arbitrary num :: Int <- arbitrary
stuff :: Array String <- arbitrary stuff :: Array String <- arbitrary
pure {str, num, stuff} pure { str, num, stuff }
objs <- liftEffect (randomSample' 1 obj) objs <- liftEffect (randomSample' 1 obj)
let let
exp = fold (writeJSON <$> objs) exp = fold (writeJSON <$> objs)
@ -108,14 +108,14 @@ spec =
describe "Transform" do describe "Transform" do
it "gzip" do it "gzip" do
let let
json = yield $ writeJSON {foo: "bar"} json = yield $ writeJSON { foo: "bar" }
exp = "1f8b0800000000000003ab564acbcf57b2524a4a2c52aa0500eff52bfe0d000000" exp = "1f8b0800000000000003ab564acbcf57b2524a4a2c52aa0500eff52bfe0d000000"
gzip <- S.fromTransform <$> O.fromBufferTransform <$> liftEffect (Zlib.toDuplex <$> Zlib.createGzip) gzip <- S.fromTransform <$> O.fromBufferTransform <$> liftEffect (Zlib.toDuplex <$> Zlib.createGzip)
outs :: List.List String <- Pipes.toListM (S.withEOS (json >-> Pipes.Buffer.fromString UTF8) >-> gzip >-> S.unEOS >-> Pipes.Buffer.toString Hex) outs :: List.List String <- Pipes.toListM (S.withEOS (json >-> Pipes.Buffer.fromString UTF8) >-> gzip >-> S.unEOS >-> Pipes.Buffer.toString Hex)
fold outs `shouldEqual` exp fold outs `shouldEqual` exp
around tmpFiles around tmpFiles
$ it "file >-> gzip >-> file >-> gunzip" \(a /\ b) -> do $ it "file >-> gzip >-> file >-> gunzip" \(a /\ b) -> do
liftEffect $ FS.writeTextFile UTF8 a $ writeJSON [1, 2, 3, 4] liftEffect $ FS.writeTextFile UTF8 a $ writeJSON [ 1, 2, 3, 4 ]
areader <- liftEffect $ reader a areader <- liftEffect $ reader a
bwritestream /\ bwriter <- liftEffect $ writer b bwritestream /\ bwriter <- liftEffect $ writer b
gzip <- S.fromTransform <$> O.fromBufferTransform <$> liftEffect (Zlib.toDuplex <$> Zlib.createGzip) gzip <- S.fromTransform <$> O.fromBufferTransform <$> liftEffect (Zlib.toDuplex <$> Zlib.createGzip)
@ -125,7 +125,7 @@ spec =
gunzip <- S.fromTransform <$> O.fromBufferTransform <$> liftEffect (Zlib.toDuplex <$> Zlib.createGunzip) gunzip <- S.fromTransform <$> O.fromBufferTransform <$> liftEffect (Zlib.toDuplex <$> Zlib.createGunzip)
breader <- liftEffect $ reader b breader <- liftEffect $ reader b
nums <- Pipes.toListM (breader >-> gunzip >-> S.unEOS >-> Pipes.Buffer.toString UTF8 >-> jsonParse @(Array Int) >-> Pipes.mapFoldable identity) nums <- Pipes.toListM (breader >-> gunzip >-> S.unEOS >-> Pipes.Buffer.toString UTF8 >-> jsonParse @(Array Int) >-> Pipes.mapFoldable identity)
Array.fromFoldable nums `shouldEqual` [1, 2, 3, 4] Array.fromFoldable nums `shouldEqual` [ 1, 2, 3, 4 ]
around tmpFile $ it "file >-> discardTransform" \(p :: String) -> do around tmpFile $ it "file >-> discardTransform" \(p :: String) -> do
liftEffect $ FS.writeTextFile UTF8 p "foo" liftEffect $ FS.writeTextFile UTF8 p "foo"
r <- reader p r <- reader p
@ -137,4 +137,4 @@ spec =
r <- reader p r <- reader p
chars' <- liftEffect charsTransform chars' <- liftEffect charsTransform
out :: List.List String <- Pipes.toListM $ r >-> S.inEOS (Pipes.Buffer.toString UTF8) >-> S.fromTransform chars' >-> S.unEOS out :: List.List String <- Pipes.toListM $ r >-> S.inEOS (Pipes.Buffer.toString UTF8) >-> S.fromTransform chars' >-> S.unEOS
out `shouldEqual` List.fromFoldable ["f", "o", "o", " ", "b", "a", "r"] out `shouldEqual` List.fromFoldable [ "f", "o", "o", " ", "b", "a", "r" ]