diff --git a/conduit-resumablesink.cabal b/conduit-resumablesink.cabal index 092c58c..77a573e 100644 --- a/conduit-resumablesink.cabal +++ b/conduit-resumablesink.cabal @@ -1,5 +1,5 @@ Name: conduit-resumablesink -Version: 0.2 +Version: 0.3 Synopsis: Allows conduit to resume sinks to feed multiple sources into it. Description: @conduit-resumablesink@ is a solution to the problem where you have a @conduit@ @@ -20,9 +20,10 @@ Library Exposed-modules: Data.Conduit.ResumableSink Build-depends: base >= 4 && < 5, - conduit >= 1.2 && <1.3, + conduit >= 1.2 && < 1.4, void >= 0.6 && < 0.8 ghc-options: -Wall + extensions: CPP, PatternSynonyms, Rank2Types test-suite test hs-source-dirs: test diff --git a/hssrc/Data/Conduit/ResumableSink.hs b/hssrc/Data/Conduit/ResumableSink.hs index b3226ab..4c8282a 100644 --- a/hssrc/Data/Conduit/ResumableSink.hs +++ b/hssrc/Data/Conduit/ResumableSink.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE CPP, PatternSynonyms, Rank2Types #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + module Data.Conduit.ResumableSink ( ResumableSink(..), connectResumeSink, newResumableSink, closeResumableSink, (+$$), (++$$), (-++$$) @@ -7,12 +10,39 @@ where import Data.Conduit.Internal import Data.Void --- | -data ResumableSink i m r = ResumableSink (Sink i m r) +#if MIN_VERSION_conduit(1,3,0) +pattern ConduitM :: forall i o m r. (forall b. (r -> Pipe i i o () m b) -> Pipe i i o () m b) -> ConduitT i o m r +pattern ConduitM act = ConduitT act +#else +(.|) :: Monad m => ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r +(.|) = (=$=) +#endif +newtype ResumableSink i m r = ResumableSink (ConduitM i Void m r) + +#if MIN_VERSION_conduit(1,3,0) -- | Connects a new source to a resumable sink. The result will be Right an updated -- ResumableSink or Left result if the Sink completes. -connectResumeSink :: Monad m => Source m i -> ResumableSink i m r -> m (Either r (ResumableSink i m r)) +connectResumeSink :: Monad m => ConduitM () i m () -> ResumableSink i m r -> m (Either r (ResumableSink i m r)) +connectResumeSink (ConduitM left') (ResumableSink (ConduitM right')) = go (left' Done) (right' Done) + where + go :: Monad m + => Pipe () () i () m () + -> Pipe i i Void () m r + -> m (Either r (ResumableSink i m r)) + go (NeedInput cont0 _ ) right = go (cont0 ()) right + go (Done ()) right = return . Right . ResumableSink $ ConduitM (\finalize -> right >>= finalize) + go (PipeM pm) right = pm >>= \left -> go left right + go (Leftover left ()) right = go left right + go (HaveOutput left1 o) (NeedInput cont0 _) = go left1 (cont0 o) + go _ (HaveOutput _ o) = absurd o + go _ (Done r) = return $ Left r + go left (PipeM pm) = pm >>= go left + go left (Leftover right i) = go (HaveOutput left i) right +#else +-- | Connects a new source to a resumable sink. The result will be Right an updated +-- ResumableSink or Left result if the Sink completes. +connectResumeSink :: Monad m => ConduitM () i m () -> ResumableSink i m r -> m (Either r (ResumableSink i m r)) connectResumeSink (ConduitM left') (ResumableSink (ConduitM right')) = go (return ()) (left' Done) (right' Done) where go :: Monad m @@ -21,7 +51,7 @@ connectResumeSink (ConduitM left') (ResumableSink (ConduitM right')) = go (retur -> Pipe i i Void () m r -> m (Either r (ResumableSink i m r)) go final (NeedInput cont0 _ ) right = go final (cont0 ()) right - go final (Done ()) right = return . Right . ResumableSink $ ConduitM (\finalize -> right >>= finalize) + go final (Done ()) right = (Right . ResumableSink $ ConduitM (\finalize -> right >>= finalize)) <$ final go final (PipeM pm) right = pm >>= \left -> go final left right go final (Leftover left ()) right = go final left right go final0 (HaveOutput left1 final1 o) (NeedInput cont0 _) = go (final0 >> final1) left1 (cont0 o) @@ -29,25 +59,26 @@ connectResumeSink (ConduitM left') (ResumableSink (ConduitM right')) = go (retur go final _ (Done r) = Left r <$ final go final left (PipeM pm) = pm >>= go final left go final left (Leftover right i) = go final (HaveOutput left (return ()) i) right +#endif -- | Converts a sink into a ResumableSink that can be used with ++$$ -newResumableSink :: Monad m => Sink i m r -> ResumableSink i m r +newResumableSink :: Monad m => ConduitM i Void m r -> ResumableSink i m r newResumableSink = ResumableSink -- | Closes a ResumableSink and gets the final result. closeResumableSink :: Monad m => ResumableSink i m r -> m r -closeResumableSink (ResumableSink sink) = runConduit $ return () =$= sink +closeResumableSink (ResumableSink sink) = runConduit $ return () .| sink -- | Connects a source and a sink. The result will be Right a -- ResumableSink or Left result if the Sink completes. -(+$$) :: Monad m => Source m i -> Sink i m r -> m (Either r (ResumableSink i m r)) +(+$$) :: Monad m => ConduitM () i m () -> ConduitM i Void m r -> m (Either r (ResumableSink i m r)) source +$$ sink = source `connectResumeSink` newResumableSink sink -- | Connects a new source to a resumable sink. The result will be Right an updated -- ResumableSink or Left result if the Sink completes. -(++$$) :: Monad m => Source m i -> ResumableSink i m r -> m (Either r (ResumableSink i m r)) +(++$$) :: Monad m => ConduitM () i m () -> ResumableSink i m r -> m (Either r (ResumableSink i m r)) (++$$) = connectResumeSink -- | Attaches a source to a resumable sink, finishing the sink and returning a result. -(-++$$) :: Monad m => Source m i -> ResumableSink i m r -> m r -source -++$$ ResumableSink sink = source $$ sink +(-++$$) :: Monad m => ConduitM () i m () -> ResumableSink i m r -> m r +source -++$$ ResumableSink sink = runConduit $ source .| sink diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..38dd6dd --- /dev/null +++ b/stack.yaml @@ -0,0 +1,66 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# resolver: ghcjs-0.1.0_ghc-7.10.2 +# resolver: +# name: custom-snapshot +# location: "./custom-snapshot.yaml" +resolver: lts-12.05 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# extra-dep: true +# subdirs: +# - auto-update +# - wai +# +# A package marked 'extra-dep: true' will only be built if demanded by a +# non-dependency (i.e. a user package), and its test suites and benchmarks +# will not be run. This is useful for tweaking upstream packages. +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver +# (e.g., acme-missiles-0.3) +extra-deps: [] + +# Override default flag values for local packages and extra-deps +flags: {} + +# Extra package databases containing global packages +extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.5" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor