diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -12,3 +12,9 @@ *~ *# .cabal-sandbox +cabal.sandbox.config +*.prof +*.aux +*.hp +*.eventlog +.stack-work/ diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -1,4 +1,107 @@ -language: haskell +# This file has been generated -- see https://github.com/hvr/multi-ghc-travis +language: c +sudo: false + +cache: + directories: + - $HOME/.cabsnap + - $HOME/.cabal/packages + +before_cache: + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar + +matrix: + include: + - env: CABALVER=1.18 GHCVER=7.4.2 + compiler: ": #GHC 7.4.2" + addons: {apt: {packages: [cabal-install-1.18,ghc-7.4.2], sources: [hvr-ghc]}} + - env: CABALVER=1.18 GHCVER=7.6.3 + compiler: ": #GHC 7.6.3" + addons: {apt: {packages: [cabal-install-1.18,ghc-7.6.3], sources: [hvr-ghc]}} + - env: CABALVER=1.18 GHCVER=7.8.4 + compiler: ": #GHC 7.8.4" + addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}} + - env: CABALVER=1.22 GHCVER=7.10.3 + compiler: ": #GHC 7.10.3" + addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}} + - env: CABALVER=1.24 GHCVER=8.0.1 + compiler: ": #GHC 8.0.1" + addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}} + - env: CABALVER=1.24 GHCVER=head + compiler: ": #GHC head" + addons: {apt: {packages: [cabal-install-1.24,ghc-head], sources: [hvr-ghc]}} + + allow_failures: + - env: CABALVER=1.24 GHCVER=head + +before_install: + - unset CC + - export PATH=$HOME/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH + +install: + - cabal --version + - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" + - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ]; + then + zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz > + $HOME/.cabal/packages/hackage.haskell.org/00-index.tar; + fi + - travis_retry cabal update -v + - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config + - cabal install --only-dependencies --enable-tests --dry -v > installplan.txt + - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt + +# check whether current requested install-plan matches cached package-db snapshot + - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt; + then + echo "cabal build-cache HIT"; + rm -rfv .ghc; + cp -a $HOME/.cabsnap/ghc $HOME/.ghc; + cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/; + else + echo "cabal build-cache MISS"; + rm -rf $HOME/.cabsnap; + mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; + cabal install -j --only-dependencies --enable-tests; + if [ "$GHCVER" = "7.10.3" ]; then cabal install Cabal-1.22.4.0; fi; + fi + +# snapshot package-db on cache miss + - if [ ! -d $HOME/.cabsnap ]; + then + echo "snapshotting package-db to build-cache"; + mkdir $HOME/.cabsnap; + cp -a $HOME/.ghc $HOME/.cabsnap/ghc; + cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/; + fi + +# Here starts the actual work to be performed for the package under +# test; any command which exits with a non-zero exit code causes the +# build to fail. +script: + # -v2 provides useful information for debugging + - cabal configure --enable-tests -v2 + + # this builds all libraries and executables + # (including tests/benchmarks) + - cabal build + + - cabal test + + # tests that a source-distribution can be generated + - cabal sdist + + # check that the generated source-distribution can be built & installed + - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ; + cd dist/; + if [ -f "$SRC_TGZ" ]; then + cabal install --force-reinstalls "$SRC_TGZ"; + else + echo "expected '$SRC_TGZ' not found"; + exit 1; + fi + notifications: irc: channels: @@ -6,3 +109,5 @@ skip_join: true template: - "\x0313machines\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" + +# EOF diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,9 @@ +0.6.1 +----- +* Bumped upper version bounds for `comonad`, `conduit-combinators`, `criterion`, `distributive`, `pointed`, and `transformers` +* Fix compilation with `stack` +* Added `strippingPrefix`, `unfold`, `unfoldT`, `zipping` + 0.6 --- * Added better fanout combinators. `Data.Machine.Fanout` diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -30,6 +30,10 @@ withTestLBI pkg lbi $ \suite suitecfg -> do rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines [ "module Build_" ++ testName suite ++ " where" + , "" + , "autogen_dir :: String" + , "autogen_dir = " ++ show dir + , "" , "deps :: [String]" , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) ] diff --git a/examples/machines-examples.cabal b/examples/machines-examples.cabal --- a/examples/machines-examples.cabal +++ b/examples/machines-examples.cabal @@ -23,8 +23,8 @@ library build-depends: base == 4.*, - machines == 0.4, - mtl >= 2 && < 2.2 + machines == 0.6.*, + mtl >= 2 && < 2.3 exposed-modules: Examples diff --git a/machines.cabal b/machines.cabal --- a/machines.cabal +++ b/machines.cabal @@ -1,6 +1,6 @@ name: machines category: Control, Enumerator -version: 0.6 +version: 0.6.1 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE @@ -38,15 +38,15 @@ build-depends: adjunctions >= 4.2 && < 5, base >= 4.5 && < 5, - comonad >= 3 && < 5, + comonad >= 3 && < 6, containers >= 0.3 && < 0.6, - distributive < 0.5, + distributive < 0.6, free >= 3.1.1 && < 5, - pointed >= 3 && < 5, + pointed >= 3 && < 6, profunctors >= 3 && < 6, semigroupoids >= 5 && < 6, semigroups >= 0.8.3 && < 1, - transformers >= 0.3 && < 0.5, + transformers >= 0.3 && < 0.6, transformers-compat >= 0.3, mtl >= 2 && < 2.3, void >= 0.6.1 && < 1 @@ -88,8 +88,8 @@ build-depends: base == 4.*, directory >= 1.0 && < 1.3, - doctest >= 0.8 && < 0.11, - filepath >= 1.3 && < 1.5 + doctest >= 0.8 && < 0.12, + filepath >= 1.3 && < 1.5 ghc-options: -Wall -threaded hs-source-dirs: tests @@ -103,8 +103,8 @@ build-depends: base == 4.*, conduit >= 1.0 && < 1.3, - conduit-combinators >= 0.2.5 && < 0.4, - criterion >= 0.6 && < 1.1, + conduit-combinators >= 0.2.5 && < 1.1, + criterion >= 0.6 && < 1.2, machines, mtl >= 2 && < 2.3, pipes >= 4 && < 4.2 diff --git a/src/Data/Machine/Fanout.hs b/src/Data/Machine/Fanout.hs --- a/src/Data/Machine/Fanout.hs +++ b/src/Data/Machine/Fanout.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | Provide a notion of fanout wherein a single input is passed to -- several consumers. @@ -25,10 +26,15 @@ -- | Share inputs with each of a list of processes in lockstep. Any -- values yielded by the processes are combined into a single yield -- from the composite process. -fanout :: (Functor m, Monad m, Semigroup r) +fanout :: forall m a r. (Monad m, Semigroup r) => [ProcessT m a r] -> ProcessT m a r fanout = MachineT . go id id where + go :: ([(a -> ProcessT m a r, ProcessT m a r)] + -> [(a -> ProcessT m a r, ProcessT m a r)]) + -> ([r] -> [r]) + -> [ProcessT m a r] + -> m (Step (Is a) r (ProcessT m a r)) go waiting acc [] = case waiting [] of ws -> return . maybe k (\x -> Yield x $ encased k) $ semigroupDlist acc where k = continue fanout ws @@ -44,10 +50,15 @@ -- run a collection of 'ProcessT's that await but don't yield some -- number of times, you can use 'fanOutSteps . map (fmap (const ()))' -- followed by a 'taking' process. -fanoutSteps :: (Functor m, Monad m, Monoid r) +fanoutSteps :: forall m a r. (Monad m, Monoid r) => [ProcessT m a r] -> ProcessT m a r fanoutSteps = MachineT . go id id where + go :: ([(a -> ProcessT m a r, ProcessT m a r)] + -> [(a -> ProcessT m a r, ProcessT m a r)]) + -> ([r] -> [r]) + -> [ProcessT m a r] + -> m (Step (Is a) r (ProcessT m a r)) go waiting acc [] = case (waiting [], mconcat (acc [])) of (ws, xs) -> return . Yield xs $ encased (continue fanoutSteps ws) go waiting acc (m:ms) = runMachineT m >>= \v -> case v of diff --git a/src/Data/Machine/Process.hs b/src/Data/Machine/Process.hs --- a/src/Data/Machine/Process.hs +++ b/src/Data/Machine/Process.hs @@ -52,6 +52,7 @@ , mapping , reading , showing + , strippingPrefix ) where import Control.Applicative @@ -344,3 +345,26 @@ -- Convert 'Show'able values to 'String's showing :: (Category k, Show a) => Machine (k a) String showing = mapping show + +-- | +-- 'strippingPrefix' @mp mb@ Drops the given prefix from @mp@. It stops if @mb@ +-- did not start with the prefix given, or continues streaming after the +-- prefix, if @mb@ did. +strippingPrefix :: (Eq b, Monad m) + => MachineT m (k a) b + -> MachineT m (k a) b + -> MachineT m (k a) b +strippingPrefix mp mb = MachineT $ runMachineT mp >>= \v -> case v of + Stop -> runMachineT mb + Yield b k -> verify b k mb + Await f ki ff -> + return $ Await (\a -> strippingPrefix (f a) mb) ki (strippingPrefix ff mb) + where + verify b nxt cur = runMachineT cur >>= \u -> case u of + Stop -> return Stop + Yield b' nxt' + | b == b' -> runMachineT $ strippingPrefix nxt nxt' + | otherwise -> return Stop + Await f ki ff -> + return $ Await (\a -> MachineT $ verify b nxt (f a)) + ki (MachineT $ verify b nxt ff) diff --git a/src/Data/Machine/Source.hs b/src/Data/Machine/Source.hs --- a/src/Data/Machine/Source.hs +++ b/src/Data/Machine/Source.hs @@ -22,14 +22,17 @@ , iterated , replicated , enumerateFromTo + , unfold + , unfoldT ) where import Control.Category +import Control.Monad.Trans import Data.Foldable import Data.Machine.Plan import Data.Machine.Type import Data.Machine.Process -import Prelude (Enum, Eq, Int, otherwise, succ, (==), (>>)) +import Prelude (Enum, Eq, Int, Maybe, Monad, otherwise, succ, (==), (>>), ($)) ------------------------------------------------------------------------------- -- Source @@ -82,3 +85,23 @@ go i | i == end = yield i | otherwise = yield i >> go (succ i) + +-- | 'unfold' @k seed@ The function takes the element and returns Nothing if it +-- is done producing values or returns Just (a,r), in which case, @a@ is +-- 'yield'ed and @r@ is used as the next element in a recursive call. +unfold :: (r -> Maybe (a, r)) -> r -> Source a +unfold k seed = construct (go seed) + where + go r = for_ (k r) $ \(a, r') -> do + yield a + go r' + +-- | Effectful 'unfold' variant. +unfoldT :: Monad m => (r -> m (Maybe (a, r))) -> r -> SourceT m a +unfoldT k seed = construct (go seed) + where + go r = do + opt <- lift $ k r + for_ opt $ \(a, r') -> do + yield a + go r' diff --git a/src/Data/Machine/Tee.hs b/src/Data/Machine/Tee.hs --- a/src/Data/Machine/Tee.hs +++ b/src/Data/Machine/Tee.hs @@ -20,6 +20,7 @@ , capL, capR , zipWithT , zipWith + , zipping ) where import Data.Machine.Is @@ -104,7 +105,7 @@ {-# INLINE cappedT #-} -- | wait for both the left and the right sides of a T and then merge them with f. -zipWithT :: Monad m => (a -> b -> c) -> PlanT (T a b) c m () +zipWithT :: (a -> b -> c) -> PlanT (T a b) c m () zipWithT f = do { a <- awaits L; b <- awaits R; yield $ f a b } {-# INLINE zipWithT #-} @@ -117,3 +118,8 @@ b <- awaits R yield (f a b) {-# INLINE zipWith #-} + +-- | Zip together two inputs, halting as soon as either input is exhausted. +zipping :: Tee a b (a, b) +zipping = zipWith (,) +{-# INLINE zipping #-} diff --git a/tests/doctests.hs b/tests/doctests.hs --- a/tests/doctests.hs +++ b/tests/doctests.hs @@ -1,6 +1,6 @@ module Main where -import Build_doctests (deps) +import Build_doctests (autogen_dir, deps) import Control.Applicative import Control.Monad import Data.List @@ -12,9 +12,9 @@ main :: IO () main = getSources >>= \sources -> doctest $ "-isrc" - : "-idist/build/autogen" + : ("-i" ++ autogen_dir) : "-optP-include" - : "-optPdist/build/autogen/cabal_macros.h" + : ("-optP" ++ autogen_dir ++ "/cabal_macros.h") : "-hide-all-packages" : map ("-package="++) deps ++ sources