Repository: ekmett/machines Branch: master Commit: 614a257be71d Files: 35 Total size: 133.5 KB Directory structure: gitextract_ol479cyg/ ├── .github/ │ └── workflows/ │ └── haskell-ci.yml ├── .gitignore ├── .vim.custom ├── CHANGELOG.markdown ├── LICENSE ├── README.markdown ├── Setup.lhs ├── benchmarks/ │ └── Benchmarks.hs ├── cabal.haskell-ci ├── cabal.project ├── config ├── examples/ │ ├── Examples.hs │ ├── LICENSE │ └── machines-examples.cabal ├── machines.cabal ├── src/ │ └── Data/ │ ├── Machine/ │ │ ├── Fanout.hs │ │ ├── Group/ │ │ │ └── General.hs │ │ ├── Group.hs │ │ ├── Is.hs │ │ ├── Lift.hs │ │ ├── Mealy.hs │ │ ├── MealyT.hs │ │ ├── Moore.hs │ │ ├── MooreT.hs │ │ ├── Pipe.hs │ │ ├── Plan.hs │ │ ├── Process.hs │ │ ├── Runner.hs │ │ ├── Source.hs │ │ ├── Stack.hs │ │ ├── Tee.hs │ │ ├── Type.hs │ │ └── Wye.hs │ └── Machine.hs └── tests/ └── doctests.hs ================================================ FILE CONTENTS ================================================ ================================================ FILE: .github/workflows/haskell-ci.yml ================================================ # This GitHub workflow config has been generated by a script via # # haskell-ci 'github' 'cabal.project' # # To regenerate the script (for example after adjusting tested-with) run # # haskell-ci regenerate # # For more information, see https://github.com/haskell-CI/haskell-ci # # version: 0.19.20250216 # # REGENDATA ("0.19.20250216",["github","cabal.project"]) # name: Haskell-CI on: - push - pull_request jobs: linux: name: Haskell-CI - Linux - ${{ matrix.compiler }} runs-on: ubuntu-24.04 timeout-minutes: 60 container: image: buildpack-deps:jammy continue-on-error: ${{ matrix.allow-failure }} strategy: matrix: include: - compiler: ghc-9.12.1 compilerKind: ghc compilerVersion: 9.12.1 setup-method: ghcup allow-failure: false - compiler: ghc-9.10.1 compilerKind: ghc compilerVersion: 9.10.1 setup-method: ghcup allow-failure: false - compiler: ghc-9.8.4 compilerKind: ghc compilerVersion: 9.8.4 setup-method: ghcup allow-failure: false - compiler: ghc-9.6.6 compilerKind: ghc compilerVersion: 9.6.6 setup-method: ghcup allow-failure: false - compiler: ghc-9.4.8 compilerKind: ghc compilerVersion: 9.4.8 setup-method: ghcup allow-failure: false - compiler: ghc-9.2.8 compilerKind: ghc compilerVersion: 9.2.8 setup-method: ghcup allow-failure: false - compiler: ghc-9.0.2 compilerKind: ghc compilerVersion: 9.0.2 setup-method: ghcup allow-failure: false - compiler: ghc-8.10.7 compilerKind: ghc compilerVersion: 8.10.7 setup-method: ghcup allow-failure: false - compiler: ghc-8.8.4 compilerKind: ghc compilerVersion: 8.8.4 setup-method: ghcup allow-failure: false - compiler: ghc-8.6.5 compilerKind: ghc compilerVersion: 8.6.5 setup-method: ghcup allow-failure: false - compiler: ghc-8.4.4 compilerKind: ghc compilerVersion: 8.4.4 setup-method: ghcup allow-failure: false - compiler: ghc-8.2.2 compilerKind: ghc compilerVersion: 8.2.2 setup-method: ghcup allow-failure: false - compiler: ghc-8.0.2 compilerKind: ghc compilerVersion: 8.0.2 setup-method: ghcup allow-failure: false fail-fast: false steps: - name: apt-get install run: | apt-get update apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev - name: Install GHCup run: | mkdir -p "$HOME/.ghcup/bin" curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup" chmod a+x "$HOME/.ghcup/bin/ghcup" - name: Install cabal-install run: | "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" - name: Install GHC (GHCup) if: matrix.setup-method == 'ghcup' run: | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') echo "HC=$HC" >> "$GITHUB_ENV" echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" env: HCKIND: ${{ matrix.compilerKind }} HCNAME: ${{ matrix.compiler }} HCVER: ${{ matrix.compilerVersion }} - name: Set PATH and environment variables run: | echo "$HOME/.cabal/bin" >> $GITHUB_PATH echo "LANG=C.UTF-8" >> "$GITHUB_ENV" echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" echo "HEADHACKAGE=false" >> "$GITHUB_ENV" echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" env: HCKIND: ${{ matrix.compilerKind }} HCNAME: ${{ matrix.compiler }} HCVER: ${{ matrix.compilerVersion }} - name: env run: | env - name: write cabal config run: | mkdir -p $CABAL_DIR cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan rm -f cabal-plan.xz chmod a+x $HOME/.cabal/bin/cabal-plan cabal-plan --version - name: install cabal-docspec run: | mkdir -p $HOME/.cabal/bin curl -sL https://github.com/phadej/cabal-extras/releases/download/cabal-docspec-0.0.0.20240703/cabal-docspec-0.0.0.20240703-x86_64-linux.xz > cabal-docspec.xz echo '48bf3b7fd2f7f0caa6162afee57a755be8523e7f467b694900eb420f5f9a7b76 cabal-docspec.xz' | sha256sum -c - xz -d < cabal-docspec.xz > $HOME/.cabal/bin/cabal-docspec rm -f cabal-docspec.xz chmod a+x $HOME/.cabal/bin/cabal-docspec cabal-docspec --version - name: checkout uses: actions/checkout@v4 with: path: source - name: initial cabal.project for sdist run: | touch cabal.project echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project echo "packages: $GITHUB_WORKSPACE/source/./examples" >> cabal.project cat cabal.project - name: sdist run: | mkdir -p sdist $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist - name: unpack run: | mkdir -p unpacked find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; - name: generate cabal.project run: | PKGDIR_machines="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/machines-[0-9.]*')" echo "PKGDIR_machines=${PKGDIR_machines}" >> "$GITHUB_ENV" PKGDIR_machines_examples="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/machines-examples-[0-9.]*')" echo "PKGDIR_machines_examples=${PKGDIR_machines_examples}" >> "$GITHUB_ENV" rm -f cabal.project cabal.project.local touch cabal.project touch cabal.project.local echo "packages: ${PKGDIR_machines}" >> cabal.project echo "packages: ${PKGDIR_machines_examples}" >> cabal.project if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package machines" >> cabal.project ; fi if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package machines-examples" >> cabal.project ; fi if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi cat >> cabal.project <> cabal.project.local cat cabal.project cat cabal.project.local - name: dump install plan run: | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all cabal-plan - name: restore cache uses: actions/cache/restore@v4 with: key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} path: ~/.cabal/store restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- - name: install dependencies run: | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all - name: build run: | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always - name: docspec run: | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all cabal-docspec $ARG_COMPILER - name: cabal check run: | cd ${PKGDIR_machines} || false ${CABAL} -vnormal check cd ${PKGDIR_machines_examples} || false ${CABAL} -vnormal check - name: haddock run: | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all - name: save cache if: always() uses: actions/cache/save@v4 with: key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} path: ~/.cabal/store ================================================ FILE: .gitignore ================================================ dist dist-newstyle docs wiki TAGS tags wip .DS_Store .*.swp .*.swo *.o *.hi *~ *# .stack-work/ cabal-dev *.chi *.chs.h *.dyn_o *.dyn_hi .hpc .hsenv .cabal-sandbox/ cabal.sandbox.config *.prof *.aux *.hp *.eventlog cabal.project.local cabal.project.local~ .HTF/ .ghc.environment.* ================================================ FILE: .vim.custom ================================================ " Add the following to your .vimrc to automatically load this on startup " if filereadable(".vim.custom") " so .vim.custom " endif function StripTrailingWhitespace() let myline=line(".") let mycolumn = col(".") silent %s/ *$// call cursor(myline, mycolumn) endfunction syntax on set tags=TAGS;/ set listchars=tab:‗‗,trail:‗ set list map :exec ":!hasktags -x -c --ignore src" au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace() au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src" ================================================ FILE: CHANGELOG.markdown ================================================ 0.7.4 [2025.03.03] ------------------ * Drop support for pre-8.0 versions of GHC. 0.7.3 [2022.05.18] ------------------ * Allow building with `mtl-2.3.*` and `transformers-0.6.*`. 0.7.2 [2021.02.17] ------------------ * The build-type has been changed from `Custom` to `Simple`. To achieve this, the `doctests` test suite has been removed in favor of using [`cabal-docspec`](https://github.com/phadej/cabal-extras/tree/master/cabal-docspec) to run the doctests. 0.7.1 [2020.10.02] ------------------ * Allow building with GHC 9.0. * Add a `Data.Machine.MooreT` module. * Tweak the `Corepresentable Moore` instance's implementation of `cotabulate` to ensure that `index . tabulate ≡ id` (note that for `Moore`, `tabulate = cotabulate`). 0.7 [2019.05.10] ---------------- * Remove the `Monad` instances for `Mealy` and `MealyT`, as they were inconsistent with the `Applicative` instances. * Add a `Data.Machine.Group.General` module. * Add a `takingJusts` function to `Data.Machine.Process`. * Add `Semigroup` and `Monoid` instances for `Moore`. * Support building with `base-4.13` (GHC 8.8). 0.6.4 [2018.07.03] ------------------ * Add `Semigroup` and `Monoid` instances for `Mealy` and `MealyT`. * Mark `runT` and `runT_` as `INLINEABLE`. * Increase the scope of the benchmarks. Also include the `streaming` library among the things that are benchmarked. * Allow building with `containers-0.6`. 0.6.3 ----- * Add `Semigroup` instance for `Is` * Add `MonadFail` instance for `PlanT` * Support `doctest-0.12` 0.6.2 ----- * Revamp `Setup.hs` to use `cabal-doctest`. This makes it build with `Cabal-2.0`, and makes the `doctest`s work with `cabal new-build` and sandboxes. * Various performance improvements * Add the `flattened` and `traversing` functions, as well as the `AutomatonM` class, to `Data.Machine.Process` * Add the `Data.Machine.MealyT` module * Add `plug` to `Data.Machine.Source` * Add `capT` to `Data.Machine.Tee` * Fix a bug in `teeT` that caused it to run actions too many times * Add `capWye` to `Data.Machine.Wye` 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` * Added a module for lifting machines that run in transformed monads. `Data.Machine.Lift` * Added instances for `Mealy` and `Moore`. * Explicitly implemented `(<*>)` `(*>)` and `(<*)` for `PlanT`. * Added `Data.Machine.Runner` with various tools for running machines. * Added `teeT`. * Added `unfoldPlan` and `preplan` 0.5.1 ----- * `profunctors` 5 support * GHC 7.10 warnings have been cleaned up 0.5 --- * Major bug fix (and semantic change) for `Plan`'s `(<|>)`. 0.4.2 ----- * Add `Monoid` and `Semigroups` instances for `MachineT` 0.4.1 ----- * Support `void` 0.7, fixed upper bounds on dependencies going forward. 0.4.0.1 ----- * Bumped the bounds for `mtl` and `transformers` 0.4 ----- 0.2.5 ----- * Added `deconstruct`, `tagDone` and `finishWith` 0.2.4 ----- * Added `asParts`, `sinkPart_`, `autoM`, and `fitM` 0.2.1 ----- * Fixed the `Mealy` Monad 0.2 --- * Removed the input type parameter from (almost) all of the types. 0.1 --- * Initial release ================================================ FILE: LICENSE ================================================ Copyright 2012-2015 Edward Kmett, Runar Bjarnason, Paul Chiusano All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ================================================ FILE: README.markdown ================================================ machines ======== [![Hackage](https://img.shields.io/hackage/v/machines.svg)](https://hackage.haskell.org/package/machines) [![Build Status](https://github.com/ekmett/machines/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/machines/actions?query=workflow%3AHaskell-CI) *Ceci n'est pas une pipe* Machines are demand driven input sources like pipes or conduits, but can support multiple inputs. You design a `Machine` by writing a `Plan`. You then `construct` the machine. Simple machines that take one input are called a `Process` and processes form a `Category`. More generally you can attach a `Process` to the output of any type of `Machine`, yielding a new `Machine`. More complicated machines provide other ways of connecting to them. Typically the use of machines proceeds by using simple plans into machine `Tee`s and `Wye`s, capping many of the inputs to those with possibly monadic sources, feeding the rest input (possibly repeatedly) and calling `run` or `runT` to get the answers out. There is a lot of flexibility when building a machine in choosing between empowering the machine to run its own monadic effects or delegating that responsibility to a custom driver. A port of this design to scala is available from runarorama/scala-machines Runar's slides are also available from http://web.archive.org/web/20161029161813/https://dl.dropboxusercontent.com/u/4588997/Machines.pdf Some worked examples are here https://github.com/alanz/machines-play Contact Information ------------------- Contributions and bug reports are welcome! Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. -Edward Kmett ================================================ FILE: Setup.lhs ================================================ #!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain ================================================ FILE: benchmarks/Benchmarks.hs ================================================ module Main (main) where import Control.Applicative import Data.Function ((&)) import Control.Monad (void) import Control.Monad.Identity import Criterion.Main import Data.Void import qualified Data.Conduit as C import qualified Data.Conduit.Combinators as CC import qualified Data.Conduit.List as C import qualified Data.Machine as M import qualified Pipes as P import qualified Pipes.Prelude as P import qualified Streaming.Prelude as S import Prelude value :: Int value = 1000000 drainM :: M.ProcessT Identity Int o -> () drainM m = runIdentity $ M.runT_ (sourceM M.~> m) drainMIO :: M.ProcessT IO Int o -> IO () drainMIO m = M.runT_ (sourceM M.~> m) drainP :: P.Proxy () Int () a Identity () -> () drainP p = runIdentity $ P.runEffect $ P.for (sourceP P.>-> p) P.discard drainPIO :: P.Proxy () Int () a IO () -> IO () drainPIO p = P.runEffect $ sourceP P.>-> p P.>-> P.mapM_ (\_ -> return ()) drainC :: C.ConduitT Int a Identity () -> () drainC c = runIdentity $ C.runConduit $ (sourceC C..| c) C..| C.sinkNull drainCIO :: C.ConduitT Int a IO () -> IO () drainCIO c = C.runConduit $ (sourceC C..| c) C..| C.mapM_ (\_ -> return ()) drainSC :: C.ConduitT Int Void Identity b -> () drainSC c = runIdentity $ void $! C.runConduit $ sourceC C..| c drainS :: (S.Stream (S.Of Int) Identity () -> S.Stream (S.Of Int) Identity ()) -> () drainS s = runIdentity $ S.effects $ sourceS & s drainSIO :: (S.Stream (S.Of Int) IO () -> S.Stream (S.Of Int) IO ()) -> IO () drainSIO s = sourceS & s & S.mapM_ (\_ -> return ()) sourceM :: M.Source Int sourceM = M.enumerateFromTo 1 value sourceC :: Monad m => C.ConduitT i Int m () sourceC = C.enumFromTo 1 value sourceP :: Monad m => P.Producer' Int m () sourceP = P.each [1..value] sourceS :: Monad m => S.Stream (S.Of Int) m () sourceS = S.each [1..value] main :: IO () main = defaultMain [ bgroup "map" [ bench "machines" $ whnf drainM (M.mapping (+1)) , bench "streaming" $ whnf drainS (S.map (+1)) , bench "pipes" $ whnf drainP (P.map (+1)) , bench "conduit" $ whnf drainC (C.map (+1)) ] , bgroup "drop" [ bench "machines" $ whnf drainM (M.dropping value) , bench "streaming" $ whnf drainS (S.drop value) , bench "pipes" $ whnf drainP (P.drop value) , bench "conduit" $ whnf drainC (C.drop value) ] , bgroup "dropWhile" [ bench "machines" $ whnf drainM (M.droppingWhile (<= value)) , bench "streaming" $ whnf drainS (S.dropWhile (<= value)) , bench "pipes" $ whnf drainP (P.dropWhile (<= value)) , bench "conduit" $ whnf drainC (CC.dropWhile (<= value)) ] , bgroup "scan" [ bench "machines" $ whnf drainM (M.scan (+) 0) , bench "streaming" $ whnf drainS (S.scan (+) 0 id) , bench "pipes" $ whnf drainP (P.scan (+) 0 id) , bench "conduit" $ whnf drainC (CC.scanl (+) 0) ] , bgroup "take" [ bench "machines" $ whnf drainM (M.taking value) , bench "streaming" $ whnf drainS (S.take value) , bench "pipes" $ whnf drainP (P.take value) , bench "conduit" $ whnf drainC (C.isolate value) ] , bgroup "takeWhile" [ bench "machines" $ whnf drainM (M.takingWhile (<= value)) , bench "streaming" $ whnf drainS (S.takeWhile (<= value)) , bench "pipes" $ whnf drainP (P.takeWhile (<= value)) , bench "conduit" $ whnf drainC (CC.takeWhile (<= value)) ] , bgroup "fold" [ bench "machines" $ whnf drainM (M.fold (+) 0) , bench "streaming" $ whnf runIdentity $ (S.fold (+) 0 id) sourceS , bench "pipes" $ whnf runIdentity $ (P.fold (+) 0 id) sourceP , bench "conduit" $ whnf drainSC (C.fold (+) 0) ] , bgroup "filter" [ bench "machines" $ whnf drainM (M.filtered even) , bench "streaming" $ whnf drainS (S.filter even) , bench "pipes" $ whnf drainP (P.filter even) , bench "conduit" $ whnf drainC (C.filter even) ] , bgroup "mapM" [ bench "machines" $ whnf drainM (M.autoM Identity) , bench "streaming" $ whnf drainS (S.mapM Identity) , bench "pipes" $ whnf drainP (P.mapM Identity) , bench "conduit" $ whnf drainC (C.mapM Identity) ] , bgroup "zip" [ bench "machines" $ whnf (\x -> runIdentity $ M.runT_ x) (M.capT sourceM sourceM M.zipping) , bench "streaming" $ whnf (\x -> runIdentity $ S.effects $ x) (S.zip sourceS sourceS) , bench "pipes" $ whnf (\x -> runIdentity $ P.runEffect $ P.for x P.discard) (P.zip sourceP sourceP) , bench "conduit" $ whnf (\x -> runIdentity $ C.runConduit $ x C..| C.sinkNull) (C.getZipSource $ (,) <$> C.ZipSource sourceC <*> C.ZipSource sourceC) ] , bgroup "concat" [ bench "machines" $ whnf drainM (M.mapping (replicate 10) M.~> M.asParts) , bench "streaming" $ whnf drainS (S.concat . S.map (replicate 10)) , bench "pipes" $ whnf drainP (P.map (replicate 10) P.>-> P.concat) , bench "conduit" $ whnf drainC (C.map (replicate 10) C..| C.concat) ] , bgroup "last" [ bench "machines" $ whnf drainM (M.final) , bench "streaming" $ whnf runIdentity $ S.last sourceS , bench "pipes" $ whnf runIdentity $ P.last sourceP ] , bgroup "buffered" [ bench "machines" $ whnf drainM (M.buffered 1000) ] , bgroup "toList" [ bench "machines" $ whnf (length . runIdentity) $ M.runT sourceM , bench "streaming" $ whnf (length . runIdentity) $ S.toList sourceS >>= (\(xs S.:> _) -> return xs) , bench "pipes" $ whnf (length . runIdentity) $ P.toListM sourceP , bench "conduit" $ whnf (length . runIdentity) $ C.runConduit $ sourceC C..| CC.sinkList ] , bgroup "toListIO" [ bench "machines" $ whnfIO $ M.runT sourceM , bench "streaming" $ whnfIO $ S.toList sourceS , bench "pipes" $ whnfIO $ P.toListM sourceP , bench "conduit" $ whnfIO $ C.runConduit $ sourceC C..| CC.sinkList ] , bgroup "compose" [ -- Compose multiple ops, all stages letting everything through let m = M.filtered (<= value) s = S.filter (<= value) p = P.filter (<= value) c = C.filter (<= value) in bgroup "summary" [ bench "machines" $ whnf drainM $ m M.~> m M.~> m M.~> m , bench "streaming" $ whnf drainS $ \x -> s x & s & s & s , bench "pipes" $ whnf drainP $ p P.>-> p P.>-> p P.>-> p , bench "conduit" $ whnf drainC $ c C..| c C..| c C..| c ] -- IO monad makes a big difference especially for machines , let m = M.filtered (<= value) s = S.filter (<= value) p = P.filter (<= value) c = C.filter (<= value) in bgroup "summary-io" [ bench "machines" $ whnfIO $ drainMIO $ m M.~> m M.~> m M.~> m , bench "streaming" $ whnfIO $ drainSIO $ \x -> s x & s & s & s , bench "pipes" $ whnfIO $ drainPIO $ p P.>-> p P.>-> p P.>-> p , bench "conduit" $ whnfIO $ drainCIO $ c C..| c C..| c C..| c ] -- Scaling with same operation in sequence , let f = M.filtered (<= value) in bgroup "machines" [ bench "1-filter" $ whnf drainM f , bench "2-filters" $ whnf drainM $ f M.~> f , bench "3-filters" $ whnf drainM $ f M.~> f M.~> f , bench "4-filters" $ whnf drainM $ f M.~> f M.~> f M.~> f ] , let f = S.filter (<= value) in bgroup "streaming" [ bench "1-filter" $ whnf drainS (\x -> f x) , bench "2-filters" $ whnf drainS $ \x -> f x & f , bench "3-filters" $ whnf drainS $ \x -> f x & f & f , bench "4-filters" $ whnf drainS $ \x -> f x & f & f & f ] , let f = P.filter (<= value) in bgroup "pipes" [ bench "1-filter" $ whnf drainP f , bench "2-filters" $ whnf drainP $ f P.>-> f , bench "3-filters" $ whnf drainP $ f P.>-> f P.>-> f , bench "4-filters" $ whnf drainP $ f P.>-> f P.>-> f P.>-> f ] , let f = C.filter (<= value) in bgroup "conduit" [ bench "1-filter" $ whnf drainC f , bench "2-filters" $ whnf drainC $ f C..| f , bench "3-filters" $ whnf drainC $ f C..| f C..| f , bench "4-filters" $ whnf drainC $ f C..| f C..| f C..| f ] , let m = M.mapping (subtract 1) M.~> M.filtered (<= value) s = S.filter (<= value) . S.map (subtract 1) p = P.map (subtract 1) P.>-> P.filter (<= value) c = C.map (subtract 1) C..| C.filter (<= value) in bgroup "summary-alternate" [ bench "machines" $ whnf drainM $ m M.~> m M.~> m M.~> m , bench "streaming" $ whnf drainS $ \x -> s x & s & s & s , bench "pipes" $ whnf drainP $ p P.>-> p P.>-> p P.>-> p , bench "conduit" $ whnf drainC $ c C..| c C..| c C..| c ] , let f = M.mapping (subtract 1) M.~> M.filtered (<= value) in bgroup "machines-alternate" [ bench "1-map-filter" $ whnf drainM f , bench "2-map-filters" $ whnf drainM $ f M.~> f , bench "3-map-filters" $ whnf drainM $ f M.~> f M.~> f , bench "4-map-filters" $ whnf drainM $ f M.~> f M.~> f M.~> f ] , let f = S.filter (<= value) . S.map (subtract 1) in bgroup "streaming-alternate" [ bench "1-map-filter" $ whnf drainS (\x -> f x) , bench "2-map-filters" $ whnf drainS $ \x -> f x & f , bench "3-map-filters" $ whnf drainS $ \x -> f x & f & f , bench "4-map-filters" $ whnf drainS $ \x -> f x & f & f & f ] , let f = P.map (subtract 1) P.>-> P.filter (<= value) in bgroup "pipes-alternate" [ bench "1-map-filter" $ whnf drainP f , bench "2-map-filters" $ whnf drainP $ f P.>-> f , bench "3-map-filters" $ whnf drainP $ f P.>-> f P.>-> f , bench "4-map-filters" $ whnf drainP $ f P.>-> f P.>-> f P.>-> f ] , let f = C.map (subtract 1) C..| C.filter (<= value) in bgroup "conduit-alternate" [ bench "1-map-filter" $ whnf drainC f , bench "2-map-filters" $ whnf drainC $ f C..| f , bench "3-map-filters" $ whnf drainC $ f C..| f C..| f , bench "4-map-filters" $ whnf drainC $ f C..| f C..| f C..| f ] -- how filtering affects the subsequent composition , let m = M.filtered (> value) s = S.filter (> value) p = P.filter (> value) c = C.filter (> value) in bgroup "summary-filter-effect" [ bench "machines" $ whnf drainM $ m M.~> m M.~> m M.~> m , bench "streaming" $ whnf drainS $ \x -> s x & s & s & s , bench "pipes" $ whnf drainP $ p P.>-> p P.>-> p P.>-> p , bench "conduit" $ whnf drainC $ c C..| c C..| c C..| c ] , let m = M.filtered (> value) s = S.filter (> value) p = P.filter (> value) c = C.filter (> value) in bgroup "summary-filter-effect-io" [ bench "machines" $ whnfIO $ drainMIO $ m M.~> m M.~> m M.~> m , bench "streaming" $ whnfIO $ drainSIO $ \x -> s x & s & s & s , bench "pipes" $ whnfIO $ drainPIO $ p P.>-> p P.>-> p P.>-> p , bench "conduit" $ whnfIO $ drainCIO $ c C..| c C..| c C..| c ] , let f = M.filtered (> value) in bgroup "machines-filter-effect" [ bench "filter1" $ whnf drainM f , bench "filter2" $ whnf drainM $ f M.~> f , bench "filter3" $ whnf drainM $ f M.~> f M.~> f , bench "filter4" $ whnf drainM $ f M.~> f M.~> f M.~> f ] , let f = S.filter (> value) in bgroup "streaming-filter-effect" [ bench "filter1" $ whnf drainS (\x -> f x) , bench "filter2" $ whnf drainS $ \x -> f x & f , bench "filter3" $ whnf drainS $ \x -> f x & f & f , bench "filter4" $ whnf drainS $ \x -> f x & f & f & f ] , let f = P.filter (> value) in bgroup "pipes-filter-effect" [ bench "filter1" $ whnf drainP f , bench "filter2" $ whnf drainP $ f P.>-> f , bench "filter3" $ whnf drainP $ f P.>-> f P.>-> f , bench "filter4" $ whnf drainP $ f P.>-> f P.>-> f P.>-> f ] , let f = C.filter (> value) in bgroup "conduit-filter-effect" [ bench "filter1" $ whnf drainC f , bench "filter2" $ whnf drainC $ f C..| f , bench "filter3" $ whnf drainC $ f C..| f C..| f , bench "filter4" $ whnf drainC $ f C..| f C..| f C..| f ] ] ] ================================================ FILE: cabal.haskell-ci ================================================ no-tests-no-benchmarks: False unconstrained: False -- irc-channels: irc.freenode.org#haskell-lens irc-if-in-origin-repo: True docspec: True ================================================ FILE: cabal.project ================================================ packages: . ./examples ================================================ FILE: config ================================================ -- This provides a custom ~/.cabal/config file for use when hackage is down that should work on unix -- -- This is particularly useful for travis-ci to get it to stop complaining -- about a broken build when everything is still correct on our end. -- -- This uses Luite Stegman's mirror of hackage provided by his 'hdiff' site instead -- -- To enable this, uncomment the before_script in .travis.yml remote-repo: hdiff.luite.com:http://hdiff.luite.com/packages/archive remote-repo-cache: ~/.cabal/packages world-file: ~/.cabal/world build-summary: ~/.cabal/logs/build.log remote-build-reporting: anonymous install-dirs user install-dirs global ================================================ FILE: examples/Examples.hs ================================================ {-# LANGUAGE RankNTypes #-} module Examples where import Control.Exception import Control.Monad.Trans import Data.Machine import Data.Machine.Group.General import System.IO -- this slurp slurps until an eof exception is raised. slurpHandleBad :: Handle -> IO [String] slurpHandleBad h = do s <- hGetLine h (s:) <$> slurpHandleBad h -- this is the good slurp -- it catches the exception, and cleans up. slurpHandle :: Handle -> IO [String] slurpHandle h = clean <$> slurp where clean = either (\(SomeException _) -> []) id slurp = try $ do { s <- hGetLine h; (s:) <$> slurpHandle h } -- read a file, returning each line in a list readLines :: FilePath -> IO [String] readLines f = withFile f ReadMode slurpHandle -- | bad slurping machine crashes :: Handle -> MachineT IO k String crashes h = repeatedly $ do x <- lift (hGetLine h) yield x -- | here is a plan that yields all the lines at once. slurpHandlePlan :: Handle -> PlanT k [String] IO () slurpHandlePlan h = do x <- lift (slurpHandle h) yield x {- - but we want a plan that will yield one line at a time - until we are done reading the file - but before we can do that, we need a few helper combinators. -} -- | getFileLines reads each line out of the given file and pumps them into the given process. getFileLines :: FilePath -> ProcessT IO String a -> SourceT IO a getFileLines path proc = src ~> proc where src :: SourceT IO String src = construct $ lift (openFile path ReadMode) >>= slurpLinesPlan slurpLinesPlan :: Handle -> PlanT k String IO () slurpLinesPlan h = exhaust (clean <$> try (hGetLine h)) where clean = either (\(SomeException _) -> Nothing) Just -- | lineCount counts the number of lines in a file lineCount :: FilePath -> IO Int lineCount path = runHead src where src = getFileLines path (fold (\a _ -> a + 1) 0) -- | run a machine and just take the first value out of it. runHead :: (Functor f, Monad f) => MachineT f k b -> f b runHead src = do vs <- runT src case vs of v:_ -> return v [] -> error "No values from machine" -- | lineCharCount counts the number of lines, and characters in a file lineCharCount :: FilePath -> IO (Int, Int) lineCharCount path = runHead src where src = getFileLines path (fold (\(l,c) s -> (l+1, c + length s)) (0,0)) -- | A Process that takes in a String and outputs all the words in that String wordsProc :: Process String String wordsProc = repeatedly $ do { s <- await; mapM_ (\x -> yield x) (words s) } -- | A Plan to print all input. printPlan :: PlanT (Is String) () IO () printPlan = await >>= lift . putStrLn >> yield () -- | A Process that prints all its input. printProcess :: ProcessT IO String () printProcess = repeatedly printPlan -- | A machine that prints all the lines in a file. printLines :: FilePath -> IO () printLines path = runT_ $ getFileLines path printProcess -- | A machine that prints all the words in a file. printWords :: FilePath -> IO () printWords path = runT_ $ getFileLines path (wordsProc ~> printProcess) -- | A machine that prints all the lines in a file with the line numbers. printLinesWithLineNumbers :: FilePath -> IO () printLinesWithLineNumbers path = runT_ (t ~> printProcess) where t :: TeeT IO Int String String t = tee (source [1..]) (getFileLines path echo) lineNumsT lineNumsT :: MachineT IO (T Integer String) String lineNumsT = repeatedly $ zipWithT $ \i s -> show i ++ ": " ++ s uniq :: Bool uniq = run (supply xs uniqMachine) == [1,2,3] where -- | Unix's "uniq" command using groupingOn_ -- (==) means "groups are contiguous values" -- final means "run the 'final' machine over each group" uniqMachine :: (Monad m, Eq a) => ProcessT m a a uniqMachine = groupingOn_ (==) final xs :: [Int] xs = [1,2,2,3,3,3] {- def lineWordCount(fileName: String) = getFileLines(new File(fileName), (id split words) outmap (_.fold(_ => (1, 0), _ => (0, 1)))) execute lineWordCount FilePath -> IO (Int, Int) lineWordCount path = runHead lineWordCountSrc where lineWordCountSrc = echo -} ================================================ FILE: examples/LICENSE ================================================ Copyright 2014 Edward Kmett All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ================================================ FILE: examples/machines-examples.cabal ================================================ name: machines-examples category: Control, Enumerator version: 0.1 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE author: Josh Cough maintainer: Edward A. Kmett stability: provisional homepage: http://github.com/ekmett/machines/ bug-reports: http://github.com/ekmett/machines/issues copyright: Copyright (C) 2014 Edward A. Kmett synopsis: Networked stream transducers description: Networked stream transducers . @machines@ examples build-type: Simple tested-with: GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 , GHC == 9.2.8 , GHC == 9.4.8 , GHC == 9.6.6 , GHC == 9.8.4 , GHC == 9.10.1 , GHC == 9.12.1 source-repository head type: git location: git://github.com/ekmett/machines.git library build-depends: base >= 4.9 && < 5, machines == 0.7.*, mtl >= 2 && < 2.4 exposed-modules: Examples default-language: Haskell2010 ghc-options: -Wall ================================================ FILE: machines.cabal ================================================ name: machines category: Control, Enumerator version: 0.7.4 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE author: Edward A. Kmett, Rúnar Bjarnason, Josh Cough maintainer: Edward A. Kmett stability: provisional homepage: http://github.com/ekmett/machines/ bug-reports: http://github.com/ekmett/machines/issues copyright: Copyright (C) 2012-2015 Edward A. Kmett synopsis: Networked stream transducers description: Networked stream transducers . Rúnar Bjarnason's talk on machines can be downloaded from: build-type: Simple tested-with: GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 , GHC == 9.2.8 , GHC == 9.4.8 , GHC == 9.6.6 , GHC == 9.8.4 , GHC == 9.10.1 , GHC == 9.12.1 extra-source-files: .gitignore .vim.custom config README.markdown CHANGELOG.markdown examples/LICENSE examples/machines-examples.cabal examples/*.hs source-repository head type: git location: https://github.com/ekmett/machines.git library build-depends: adjunctions >= 4.2 && < 5, base >= 4.9 && < 5, comonad >= 3 && < 6, containers >= 0.3 && < 0.9, distributive < 0.7, pointed >= 3 && < 6, profunctors >= 4 && < 6, semigroupoids >= 5 && < 7, semigroups >= 0.8.3 && < 1, transformers >= 0.3 && < 0.7, transformers-compat >= 0.3, mtl >= 2.2 && < 2.4, void >= 0.6.1 && < 1 exposed-modules: Data.Machine Data.Machine.Is Data.Machine.Fanout Data.Machine.Lift Data.Machine.Mealy Data.Machine.MealyT Data.Machine.Moore Data.Machine.MooreT Data.Machine.Process Data.Machine.Plan Data.Machine.Runner Data.Machine.Source Data.Machine.Stack Data.Machine.Tee Data.Machine.Type Data.Machine.Wye Data.Machine.Group Data.Machine.Group.General Data.Machine.Pipe default-language: Haskell2010 other-extensions: FlexibleInstances GADTs MultiParamTypeClasses Rank2Types UndecidableInstances ghc-options: -Wall -Wtabs -O2 -fdicts-cheap -funbox-strict-fields -- See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0#base-4.9.0.0 ghc-options: -Wcompat -Wnoncanonical-monad-instances if !impl(ghc >= 8.8) ghc-options: -Wnoncanonical-monadfail-instances hs-source-dirs: src benchmark benchmarks default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: benchmarks main-is: Benchmarks.hs ghc-options: -O2 -rtsopts -threaded build-depends: base >= 4.9 && < 5, conduit >= 1.3 && < 1.4, criterion >= 0.6 && < 1.7, machines, mtl >= 2 && < 2.4, pipes >= 4 && < 4.4, streaming >= 0.1.4 && < 0.3 ================================================ FILE: src/Data/Machine/Fanout.hs ================================================ {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Provide a notion of fanout wherein a single input is passed to -- several consumers. module Data.Machine.Fanout (fanout, fanoutSteps) where import Data.List.NonEmpty (NonEmpty (..)) import Data.Machine import Data.Semigroup (Semigroup (sconcat)) continue :: ([b] -> r) -> [(a -> b, b)] -> Step (Is a) o r continue _ [] = Stop continue f ws = Await (f . traverse fst ws) Refl (f $ map snd ws) semigroupDlist :: Semigroup a => ([a] -> [a]) -> Maybe a semigroupDlist f = case f [] of [] -> Nothing x:xs -> Just $ sconcat (x:|xs) -- | 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 :: 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 go waiting acc (m:ms) = runMachineT m >>= \v -> case v of Stop -> go waiting acc ms Yield x k -> go waiting (acc . (x:)) (k:ms) Await f Refl k -> go (waiting . ((f, k):)) acc ms -- | Share inputs with each of a list of processes in lockstep. If -- none of the processes yields a value, the composite process will -- itself yield 'mempty'. The idea is to provide a handle on steps -- only executed for their side effects. For instance, if you want to -- 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 :: 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 Stop -> go waiting acc ms Yield x k -> go waiting (acc . (x:)) (k:ms) Await f Refl k -> go (waiting . ((f, k):)) acc ms ================================================ FILE: src/Data/Machine/Group/General.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} -- | Split up input streams into groups with separator values and process the -- groups with their own 'MachineT'. module Data.Machine.Group.General ( groupingOn , groupingOn_ , groupingN -- * Tagging a stream , taggedState , taggedM , taggedOn , taggedOnM , taggedOn_ , taggedAt , taggedAt_ , taggedCount -- * Reset a machine for each group , partitioning , partitioning_ -- * Helpers , starve , awaitUntil ) where import Control.Monad (guard) import Data.Machine -- $setup -- >>> import Control.Monad.Trans.Reader (ask, runReader) -- >>> import Control.Monad (guard) -- >>> import Control.Applicative ((<$)) -- >>> import Data.Machine -- A strict tuple type. data Strict2 a b = Strict2 !a !b isLeft :: Either a b -> Bool isLeft = either (const True) (const False) -- | Using a function to signal group changes, run a machine independently over -- each group. groupingOn_ :: Monad m => (a -> a -> Bool) -> ProcessT m a b -> ProcessT m a b groupingOn_ f m = taggedOn_ f ~> partitioning_ m {-# INLINE groupingOn_ #-} -- | Using a function to signal group changes, run a machine independently over -- each group with the value returned provided. groupingOn :: Monad m => i -> (a -> a -> Maybe i) -> (i -> ProcessT m a b) -> ProcessT m a b groupingOn i0 f m = taggedOn f ~> partitioning i0 m {-# INLINE groupingOn #-} -- | Run a machine repeatedly over 'n'-element segments of the stream, providing -- an incrementing value to each run. groupingN :: Monad m => Int -> (Int -> ProcessT m a b) -> ProcessT m a b groupingN n m = taggedAt n 1 succ ~> partitioning 0 m {-# INLINE groupingN #-} -- | Mark a transition point between two groups when a state passing function -- returns a 'Just' i. -- Examples -- -- >>> runT $ supply [1,3,3,2] (taggedState (-1) (\x y -> (even x <$ guard (x /= y), x))) -- [Left False,Right 1,Left False,Right 3,Right 3,Left True,Right 2] taggedState :: Monad m => s -> (a -> s -> (Maybe i, s)) -> ProcessT m a (Either i a) taggedState s0 f = go s0 where go s = encased $ Await (\x -> MachineT $ case f x s of (Nothing, s') -> return $ Yield (Right x) (go s') (Just i, s') -> return $ Yield (Left i) (encased (Yield (Right x) (s' `seq` go s')))) Refl stopped {-# INLINE taggedState #-} -- | Mark a transition point between two groups when an action returns a 'Just' -- i. Could be useful for breaking up a stream based on time passed. -- Examples -- -- >>> let f x = do{ y <- ask; return (even x <$ guard (x > y)) } -- >>> flip runReader 1 . runT $ supply [1,3,3,2] (taggedM f) -- [Right 1,Left False,Right 3,Left False,Right 3,Left True,Right 2] taggedM :: Monad m => (a -> m (Maybe i)) -> ProcessT m a (Either i a) taggedM f = go where go = encased $ Await (\x -> MachineT $ f x >>= \v -> case v of Nothing -> return $ Yield (Right x) go Just i -> return $ Yield (Left i) (encased (Yield (Right x) go)) ) Refl stopped {-# INLINE taggedM #-} -- | Mark a transition point between two groups as a function of adjacent -- elements, and insert the value returned as the separator. -- Examples -- -- >>> runT $ supply [1,3,3,2] (taggedOn (\x y -> (x < y) <$ guard (x /= y))) -- [Right 1,Left True,Right 3,Right 3,Left False,Right 2] taggedOn :: Monad m => (a -> a -> Maybe i) -> ProcessT m a (Either i a) taggedOn f = encased $ Await (\x0 -> encased $ Yield (Right x0) (taggedState x0 (\y x -> (f x y, y)))) Refl stopped {-# INLINE taggedOn #-} -- | Mark a transition point between two groups using an action on adjacent -- elements, and insert the value returned as the separator. -- Examples -- -- >>> let f x y = do{ z <- ask; return ((x + y <$ guard (z < x + y))) } -- >>> flip runReader 5 . runT $ supply [1..5] (taggedOnM f) -- [Right 1,Right 2,Right 3,Left 7,Right 4,Left 9,Right 5] taggedOnM :: Monad m => (a -> a -> m (Maybe i)) -> ProcessT m a (Either i a) taggedOnM f = encased $ Await go Refl stopped where go x = encased $ Yield (Right x) $ encased $ Await (\y -> MachineT $ f x y >>= \v -> case v of Nothing -> runMachineT (go y) Just z -> return $ Yield (Left z) (go y)) Refl stopped {-# INLINE taggedOnM #-} -- | Mark a transition point between two groups as a function of adjacent -- elements. -- Examples -- -- >>> runT $ supply [1,2,2] (taggedOn_ (==)) -- [Right 1,Left (),Right 2,Right 2] taggedOn_ :: Monad m => (a -> a -> Bool) -> ProcessT m a (Either () a) taggedOn_ f = taggedOn (\x y -> guard (not (f x y))) {-# INLINE taggedOn_ #-} -- | Mark a transition point between two groups at every 'n' values, stepping -- the separator by a function. -- Examples -- -- >>> runT $ supply [1..5] (taggedAt 2 True not) -- [Right 1,Right 2,Left True,Right 3,Right 4,Left False,Right 5] taggedAt :: Monad m => Int -> s -> (s -> s) -> ProcessT m a (Either s a) taggedAt n s0 f = taggedState (Strict2 n s0) g where g _ (Strict2 i s) = if i <= 0 then (Just s, Strict2 (n-1) (f s)) else (Nothing, Strict2 (i-1) s) {-# INLINE taggedAt #-} -- | Mark a transition point between two groups at every 'n' values. -- Examples -- -- >>> runT $ supply [1..5] (taggedAt_ 2) -- [Right 1,Right 2,Left (),Right 3,Right 4,Left (),Right 5] taggedAt_ :: Monad m => Int -> ProcessT m a (Either () a) taggedAt_ n = taggedAt n () id {-# INLINE taggedAt_ #-} -- | Mark a transition point between two groups at every 'n' values, using the -- counter as the separator. -- Examples -- -- >>> runT $ supply [1..5] (taggedCount 2) -- [Right 1,Right 2,Left 1,Right 3,Right 4,Left 2,Right 5] taggedCount :: Monad m => Int -> ProcessT m a (Either Int a) taggedCount n = taggedAt n 1 succ {-# INLINE taggedCount #-} -- | Run a machine multiple times over partitions of the input stream specified -- by 'Left' () values. -- Examples -- -- >>> let input = [Right 1,Left (),Right 3,Right 4,Left ()] -- >>> runT $ supply input (partitioning_ (fold (flip (:)) [])) -- [[1],[4,3],[]] partitioning_ :: Monad m => ProcessT m a b -> ProcessT m (Either () a) b partitioning_ m = partitioning () (const m) {-# INLINE partitioning_ #-} -- | Run a machine multiple times over partitions of the input stream specified -- by 'Left' i values, passing the 'i's to each 'MachineT' run. -- Examples -- -- >>> let input = [Right 1, Right 2,Left 1, Right 3,Left 2, Right 4] -- >>> runT $ supply input (partitioning 0 (\x -> mapping (\y -> (x,y)))) -- [(0,1),(0,2),(1,3),(2,4)] partitioning :: Monad m => i -> (i -> ProcessT m a b) -> ProcessT m (Either i a) b partitioning i0 k0 = go (k0 i0) where go m = MachineT $ runMachineT m >>= \v -> case v of -- Machine stops (possibly before inputs) Stop -> runMachineT $ awaitUntil isLeft (const $ go (k0 i0)) -- Machine yields a value Yield o r -> return $ Yield o (go r) -- Machine waits for a value Await f Refl r -> return $ Await g Refl (starve r $ encased Stop) where -- No change: unwrap input and give to underlying machine. g (Right a) = go (f a) -- New group: starve r, then wait for more input, restarting machine -- with next input. g (Left i) = starve r $ go (k0 i) -- | Read inputs until a condition is met, then behave as cont with input -- matching condition as first input of cont. If await fails, stop. awaitUntil :: Monad m => (a -> Bool) -> (a -> ProcessT m a b) -> ProcessT m a b awaitUntil f cont = encased $ Await g Refl stopped where g a = if f a then cont a else awaitUntil f cont ================================================ FILE: src/Data/Machine/Group.hs ================================================ {-# LANGUAGE GADTs #-} module Data.Machine.Group ( groupingOn , taggedBy , partitioning , starve , awaitUntil )where import Data.Machine import qualified Data.Machine.Group.General as Group -- $setup -- >>> import Data.Machine -- | Using a function to signal group changes, apply a machine independently over each group. groupingOn :: Monad m => (a -> a -> Bool) -> ProcessT m a b -> ProcessT m a b groupingOn = Group.groupingOn_ -- | Mark a transition point between two groups as a function of adjacent elements. -- Examples -- -- >>> runT $ supply [1,2,2] (taggedBy (==)) -- [Right 1,Left (),Right 2,Right 2] taggedBy :: Monad m => (a -> a -> Bool) -> ProcessT m a (Either () a) taggedBy = Group.taggedOn_ -- | Run a machine multiple times over partitions of the input stream specified by -- Left () values. partitioning :: Monad m => ProcessT m a b -> ProcessT m (Either () a) b partitioning = Group.partitioning_ -- | Read inputs until a condition is met, then behave as cont with -- | input matching condition as first input of cont. -- | If await fails, stop. awaitUntil :: Monad m => (a -> Bool) -> (a -> ProcessT m a b) -> ProcessT m a b awaitUntil = Group.awaitUntil ================================================ FILE: src/Data/Machine/Is.hs ================================================ {-# LANGUAGE GADTs, TypeFamilies, TypeOperators #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Machine.Is -- Copyright : (C) 2012 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : GADTs, Type Families -- ---------------------------------------------------------------------------- module Data.Machine.Is ( Is(..) ) where import Control.Category import Data.Semigroup import Prelude -- | Witnessed type equality data Is a b where Refl :: Is a a instance Show (Is a b) where showsPrec _ Refl = showString "Refl" instance Eq (Is a b) where Refl == Refl = True {-# INLINE (==) #-} instance Ord (Is a b) where Refl `compare` Refl = EQ {-# INLINE compare #-} instance (a ~ b) => Semigroup (Is a b) where Refl <> Refl = Refl {-# INLINE (<>) #-} instance (a ~ b) => Monoid (Is a b) where mempty = Refl {-# INLINE mempty #-} mappend = (<>) {-# INLINE mappend #-} instance (a ~ b) => Read (Is a b) where readsPrec d = readParen (d > 10) (\r -> [(Refl,s) | ("Refl",s) <- lex r ]) instance Category Is where id = Refl {-# INLINE id #-} Refl . Refl = Refl {-# INLINE (.) #-} ================================================ FILE: src/Data/Machine/Lift.hs ================================================ -- | Utilities for working with machines that run in transformed monads, -- inspired by @Pipes.Lift@. module Data.Machine.Lift (execStateM, catchExcept, runReaderM) where import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader import Control.Monad.Trans.Except import Data.Machine.Type -- | Given an initial state and a 'MachineT' that runs in @'StateT' s m@, -- produce a 'MachineT' that runs in @m@. execStateM :: Monad m => s -> MachineT (StateT s m) k o -> MachineT m k o execStateM s m = MachineT $ do (stp, s') <- runStateT (runMachineT m) s case stp of Stop -> return Stop Yield o m' -> return $ Yield o (execStateM s' m') Await f k q -> return $ Await (execStateM s' . f) k (execStateM s' q) -- | 'catchExcept' allows a broken machine to be replaced without stopping the -- assembly line. catchExcept :: Monad m => MachineT (ExceptT e m) k o -> (e -> MachineT (ExceptT e m) k o) -> MachineT (ExceptT e m) k o catchExcept m c = MachineT $ do step <- runMachineT m `catchE` \e -> runMachineT (catchExcept (c e) c) case step of Stop -> return Stop Yield o m' -> return $ Yield o (catchExcept m' c) Await f k m' -> return $ Await (flip catchExcept c . f) k (catchExcept m' c) -- | Given an environment and a 'MachineT' that runs in @'ReaderT' e m@, -- produce a 'MachineT' that runs in @m@. runReaderM :: Monad m => e -> MachineT (ReaderT e m) k o -> MachineT m k o runReaderM e = fitM (flip runReaderT e) ================================================ FILE: src/Data/Machine/Mealy.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Machine.Mealy -- Copyright : (C) 2012 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- ---------------------------------------------------------------------------- module Data.Machine.Mealy ( Mealy(..) , unfoldMealy , logMealy ) where import Control.Applicative import Control.Arrow import Control.Category import Data.Distributive import Data.Functor.Extend import Data.Functor.Rep as Functor import Data.List.NonEmpty as NonEmpty import Data.Machine.Plan import Data.Machine.Type import Data.Machine.Process import Data.Profunctor.Closed import Data.Profunctor import Data.Profunctor.Sieve import Data.Profunctor.Rep as Profunctor import Data.Pointed import Data.Semigroup import Data.Sequence as Seq import Prelude hiding ((.),id) -- $setup -- >>> import Data.Machine -- | 'Mealy' machines -- -- ==== Examples -- -- We can enumerate inputs: -- -- >>> let countingMealy = unfoldMealy (\i x -> ((i, x), i + 1)) 0 -- >>> run (auto countingMealy <~ source "word") -- [(0,'w'),(1,'o'),(2,'r'),(3,'d')] -- newtype Mealy a b = Mealy { runMealy :: a -> (b, Mealy a b) } instance Functor (Mealy a) where fmap f (Mealy m) = Mealy $ \a -> case m a of (b, n) -> (f b, fmap f n) {-# INLINE fmap #-} b <$ _ = pure b {-# INLINE (<$) #-} instance Applicative (Mealy a) where pure b = r where r = Mealy (const (b, r)) {-# INLINE pure #-} Mealy m <*> Mealy n = Mealy $ \a -> case m a of (f, m') -> case n a of (b, n') -> (f b, m' <*> n') m <* _ = m {-# INLINE (<*) #-} _ *> n = n {-# INLINE (*>) #-} instance Pointed (Mealy a) where point b = r where r = Mealy (const (b, r)) {-# INLINE point #-} instance Extend (Mealy a) where duplicated (Mealy m) = Mealy $ \a -> case m a of (_, b) -> (b, duplicated b) -- | A 'Mealy' machine modeled with explicit state. unfoldMealy :: (s -> a -> (b, s)) -> s -> Mealy a b unfoldMealy f = go where go s = Mealy $ \a -> case f s a of (b, t) -> (b, go t) {-# INLINE unfoldMealy #-} instance Profunctor Mealy where rmap = fmap {-# INLINE rmap #-} lmap f = go where go (Mealy m) = Mealy $ \a -> case m (f a) of (b, n) -> (b, go n) {-# INLINE lmap #-} dimap f g = go where go (Mealy m) = Mealy $ \a -> case m (f a) of (b, n) -> (g b, go n) {-# INLINE dimap #-} instance Automaton Mealy where auto x = construct $ go x where go (Mealy f) = await >>= \a -> case f a of (b, m) -> do yield b go m {-# INLINE auto #-} instance Category Mealy where id = Mealy (\a -> (a, id)) Mealy bc . Mealy ab = Mealy $ \ a -> case ab a of (b, nab) -> case bc b of (c, nbc) -> (c, nbc . nab) instance Arrow Mealy where arr f = r where r = Mealy (\a -> (f a, r)) {-# INLINE arr #-} first (Mealy m) = Mealy $ \(a,c) -> case m a of (b, n) -> ((b, c), first n) instance ArrowChoice Mealy where left m = Mealy $ \a -> case a of Left l -> case runMealy m l of (b, m') -> (Left b, left m') Right r -> (Right r, left m) right m = Mealy $ \a -> case a of Left l -> (Left l, right m) Right r -> case runMealy m r of (b, m') -> (Right b, right m') m +++ n = Mealy $ \a -> case a of Left b -> case runMealy m b of (c, m') -> (Left c, m' +++ n) Right b -> case runMealy n b of (c, n') -> (Right c, m +++ n') m ||| n = Mealy $ \a -> case a of Left b -> case runMealy m b of (d, m') -> (d, m' ||| n) Right b -> case runMealy n b of (d, n') -> (d, m ||| n') instance Strong Mealy where first' = first instance Choice Mealy where left' = left right' = right -- | Fast forward a mealy machine forward driveMealy :: Mealy a b -> Seq a -> a -> (b, Mealy a b) driveMealy m xs z = case viewl xs of y :< ys -> case runMealy m y of (_, n) -> driveMealy n ys z EmptyL -> runMealy m z -- | Accumulate history. logMealy :: Semigroup a => Mealy a a logMealy = Mealy $ \a -> (a, h a) where h a = Mealy $ \b -> let c = a <> b in (c, h c) {-# INLINE logMealy #-} instance ArrowApply Mealy where app = go Seq.empty where go xs = Mealy $ \(m,x) -> case driveMealy m xs x of (c, _) -> (c, go (xs |> x)) {-# INLINE app #-} instance Distributive (Mealy a) where distribute fm = Mealy $ \a -> let fp = fmap (`runMealy` a) fm in (fmap fst fp, collect snd fp) collect k fa = Mealy $ \a -> let fp = fmap (\x -> runMealy (k x) a) fa in (fmap fst fp, collect snd fp) instance Functor.Representable (Mealy a) where type Rep (Mealy a) = NonEmpty a index = cosieve tabulate = cotabulate instance Cosieve Mealy NonEmpty where cosieve m0 (a0 :| as0) = go m0 a0 as0 where go (Mealy m) a as = case m a of (b, m') -> case as of [] -> b a':as' -> go m' a' as' instance Costrong Mealy where unfirst = unfirstCorep unsecond = unsecondCorep instance Profunctor.Corepresentable Mealy where type Corep Mealy = NonEmpty cotabulate f0 = Mealy $ \a -> go [a] f0 where go as f = (f (NonEmpty.fromList (Prelude.reverse as)), Mealy $ \b -> go (b:as) f) instance Closed Mealy where closed m = cotabulate $ \fs x -> cosieve m (fmap ($ x) fs) instance Semigroup b => Semigroup (Mealy a b) where f <> g = Mealy $ \x -> runMealy f x <> runMealy g x instance Monoid b => Monoid (Mealy a b) where mempty = Mealy mempty #if !(MIN_VERSION_base(4,11,0)) mappend f g = Mealy $ \x -> runMealy f x `mappend` runMealy g x #endif ================================================ FILE: src/Data/Machine/MealyT.hs ================================================ {-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Machine.MealyT -- License : BSD-style (see the file LICENSE) -- -- -- -- -- ---------------------------------------------------------------------------- module Data.Machine.MealyT ( MealyT(..) , arrPure , arrM , upgrade , scanMealyT , scanMealyTM ) where import Data.Machine import Control.Arrow import Control.Applicative import Control.Monad.Trans import Data.Pointed import Control.Monad.Identity import Data.Profunctor import Data.Semigroup import qualified Control.Category as C import Prelude -- | 'Mealy' machine, with applicative effects newtype MealyT m a b = MealyT { runMealyT :: a -> m (b, MealyT m a b) } instance Functor m => Functor (MealyT m a) where {-# INLINE fmap #-} fmap f (MealyT m) = MealyT $ \a -> fmap (\(x,y) -> (f x, fmap f y)) (m a) instance Pointed m => Pointed (MealyT m a) where {-# INLINE point #-} point b = r where r = MealyT (const (point (b, r))) instance Applicative m => Applicative (MealyT m a) where {-# INLINE pure #-} pure b = r where r = MealyT (const (pure (b, r))) -- Stolen from Pointed MealyT m <*> MealyT n = MealyT $ \a -> (\(mb, mm) (nb, nm) -> (mb nb, mm <*> nm)) <$> m a <*> n a instance Functor m => Profunctor (MealyT m) where rmap = fmap {-# INLINE rmap #-} lmap f = go where go (MealyT m) = MealyT $ \a -> fmap (\(b,n) -> (b, go n)) (m (f a)) {-# INLINE lmap #-} dimap f g = go where go (MealyT m) = MealyT $ \a -> fmap (\(b,n) -> (g b, go n)) (m (f a)) {-# INLINE dimap #-} instance Monad m => C.Category (MealyT m) where {-# INLINE id #-} id = MealyT $ \a -> return (a, C.id) MealyT bc . MealyT ab = MealyT $ \a -> do (b, nab) <- ab a (c, nbc) <- bc b return (c, nbc C.. nab) instance Monad m => Arrow (MealyT m) where {-# INLINE arr #-} arr f = r where r = MealyT (\a -> return (f a, r)) first (MealyT m) = MealyT $ \(a,c) -> do (b, n) <- m a return ((b, c), first n) arrPure :: (a -> b) -> MealyT Identity a b arrPure = arr arrM :: Functor m => (a -> m b) -> MealyT m a b arrM f = r where r = MealyT $ \a -> fmap (,r) (f a) upgrade :: Applicative m => Mealy a b -> MealyT m a b upgrade (Mealy f) = MealyT $ \a -> let (r, g) = f a in pure (r, upgrade g) scanMealyT :: Applicative m => (a -> b -> a) -> a -> MealyT m b a scanMealyT f a = MealyT (\b -> pure (a, scanMealyT f (f a b))) scanMealyTM :: Functor m => (a -> b -> m a) -> a -> MealyT m b a scanMealyTM f a = MealyT $ \b -> (\x -> (a, scanMealyTM f x)) <$> f a b autoMealyTImpl :: Monad m => MealyT m a b -> ProcessT m a b autoMealyTImpl = construct . go where go (MealyT f) = do a <- await (b, m) <- lift $ f a yield b go m instance AutomatonM MealyT where autoT = autoMealyTImpl instance (Semigroup b, Applicative m) => Semigroup (MealyT m a b) where f <> g = MealyT $ \x -> (\(fx, f') (gx, g') -> (fx <> gx, f' <> g')) <$> runMealyT f x <*> runMealyT g x instance (Semigroup b, Monoid b, Applicative m) => Monoid (MealyT m a b) where mempty = MealyT $ \_ -> pure mempty mappend = (<>) ================================================ FILE: src/Data/Machine/Moore.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Machine.Moore -- Copyright : (C) 2012 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- ---------------------------------------------------------------------------- module Data.Machine.Moore ( Moore(..) , logMoore , unfoldMoore ) where import Control.Applicative import Control.Comonad import Control.Monad.Fix import Control.Monad.Reader.Class import Control.Monad.Zip import Data.Copointed import Data.Distributive import Data.Functor.Rep as Functor import Data.Machine.Plan import Data.Machine.Type import Data.Machine.Process import Data.Semigroup import Data.Pointed import Data.Profunctor.Closed import Data.Profunctor import Data.Profunctor.Sieve import Data.Profunctor.Rep as Profunctor import Prelude -- | 'Moore' machines data Moore a b = Moore b (a -> Moore a b) -- | Accumulate the input as a sequence. logMoore :: Monoid m => Moore m m logMoore = h mempty where h m = Moore m (\a -> h (m `mappend` a)) {-# INLINE logMoore #-} -- | Construct a Moore machine from a state valuation and transition function unfoldMoore :: (s -> (b, a -> s)) -> s -> Moore a b unfoldMoore f = go where go s = case f s of (b, g) -> Moore b (go . g) {-# INLINE unfoldMoore #-} instance Automaton Moore where auto x = construct $ go x where go (Moore b f) = do yield b await >>= go . f {-# INLINE auto #-} instance Functor (Moore a) where fmap f (Moore b g) = Moore (f b) (fmap f . g) {-# INLINE fmap #-} a <$ _ = return a {-# INLINE (<$) #-} instance Profunctor Moore where rmap = fmap {-# INLINE rmap #-} lmap f = go where go (Moore b g) = Moore b (go . g . f) {-# INLINE lmap #-} dimap f g = go where go (Moore b h) = Moore (g b) (go . h . f) {-# INLINE dimap #-} instance Applicative (Moore a) where pure a = r where r = Moore a (const r) {-# INLINE pure #-} Moore f ff <*> Moore a fa = Moore (f a) (\i -> ff i <*> fa i) m <* _ = m {-# INLINE (<*) #-} _ *> n = n {-# INLINE (*>) #-} instance Pointed (Moore a) where point a = r where r = Moore a (const r) {-# INLINE point #-} -- | slow diagonalization instance Monad (Moore a) where return = pure {-# INLINE return #-} k >>= f = j (fmap f k) where j (Moore a g) = Moore (extract a) (\x -> j $ fmap (\(Moore _ h) -> h x) (g x)) (>>) = (*>) instance Copointed (Moore a) where copoint (Moore b _) = b {-# INLINE copoint #-} instance Comonad (Moore a) where extract (Moore b _) = b {-# INLINE extract #-} extend f w@(Moore _ g) = Moore (f w) (extend f . g) instance ComonadApply (Moore a) where Moore f ff <@> Moore a fa = Moore (f a) (\i -> ff i <@> fa i) m <@ _ = m {-# INLINE (<@) #-} _ @> n = n {-# INLINE (@>) #-} instance Distributive (Moore a) where distribute m = Moore (fmap extract m) (distribute . collect (\(Moore _ k) -> k) m) instance Functor.Representable (Moore a) where type Rep (Moore a) = [a] index = cosieve tabulate = cotabulate {-# INLINE tabulate #-} instance Cosieve Moore [] where cosieve (Moore b _) [] = b cosieve (Moore _ k) (a:as) = cosieve (k a) as instance Costrong Moore where unfirst = unfirstCorep unsecond = unsecondCorep instance Profunctor.Corepresentable Moore where type Corep Moore = [] cotabulate f = Moore (f []) $ \a -> cotabulate (f.(a:)) instance MonadFix (Moore a) where mfix = mfixRep instance MonadZip (Moore a) where mzipWith = mzipWithRep munzip m = (fmap fst m, fmap snd m) instance MonadReader [a] (Moore a) where ask = askRep local = localRep instance Closed Moore where closed m = cotabulate $ \fs x -> cosieve m (fmap ($ x) fs) instance Semigroup b => Semigroup (Moore a b) where Moore x f <> Moore y g = Moore (x <> y) (f <> g) instance Monoid b => Monoid (Moore a b) where mempty = Moore mempty mempty #if !(MIN_VERSION_base(4,11,0)) Moore x f `mappend` Moore y g = Moore (x `mappend` y) (f `mappend` g) #endif ================================================ FILE: src/Data/Machine/MooreT.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Machine.MooreT -- Copyright : (C) 2012 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- ---------------------------------------------------------------------------- module Data.Machine.MooreT ( MooreT(..) , unfoldMooreT , upgrade , hoist , couple , firstM , secondM ) where import Control.Monad.Trans (lift) import Data.Distributive (Distributive(..), cotraverse) import Data.Machine import Data.Machine.MealyT (MealyT(runMealyT)) import Data.Pointed (Pointed(..)) import Data.Profunctor (Costrong(..), Profunctor(..)) #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup(..)) #endif -- | 'Moore' machine, with applicative effects newtype MooreT m a b = MooreT { runMooreT :: m (b, a -> MooreT m a b) } -- | Construct a MooreT machine from a state valuation and transition action unfoldMooreT :: Functor m => (s -> m (b, a -> s)) -> s -> MooreT m a b unfoldMooreT f = go where go s = MooreT $ (\(b, k) -> (b, go . k)) <$> f s {-# INLINE unfoldMooreT #-} upgrade :: Applicative m => Moore a b -> MooreT m a b upgrade (Moore b f) = MooreT $ pure (b, upgrade . f) {-# INLINE upgrade #-} firstM :: (Functor m, Monad m) => (a' -> m a) -> MooreT m a b -> MooreT m a' b firstM f = MooreT . fmap (fmap go) . runMooreT where go m x = MooreT $ f x >>= fmap (fmap go) . runMooreT . m {-# INLINE firstM #-} secondM :: Monad m => (b -> m b') -> MooreT m a b -> MooreT m a b' secondM f m = MooreT $ do (b, m') <- runMooreT m b' <- f b return (b', secondM f . m') {-# INLINE secondM #-} hoist :: Functor n => (forall x. m x -> n x) -> MooreT m a b -> MooreT n a b hoist f = let go = MooreT . fmap (\(b, m') -> (b, go . m')) . f . runMooreT in go {-# INLINE hoist #-} couple :: Monad m => MooreT m a b -> MealyT m b a -> m c couple x y = do (b, x') <- runMooreT x (a, y') <- runMealyT y b couple (x' a) y' {-# INLINE couple #-} instance AutomatonM MooreT where autoT = construct . go where go m = do (b, m') <- lift (runMooreT m) yield b await >>= go . m' {-# INLINE autoT #-} instance Functor m => Functor (MooreT m a) where fmap f = let go = MooreT . fmap (\(b, m') -> (f b, go . m')) . runMooreT in go {-# INLINE fmap #-} instance Functor m => Profunctor (MooreT m) where rmap = fmap {-# INLINE rmap #-} lmap f = let go = MooreT . fmap (\(b, m') -> (b, go . m' . f)) . runMooreT in go {-# INLINE lmap #-} dimap f g = let go = MooreT . fmap (\(b, m') -> (g b, go . m' . f)) . runMooreT in go {-# INLINE dimap #-} instance Applicative m => Applicative (MooreT m a) where pure x = let r = MooreT $ pure (x, const r) in r {-# INLINE pure #-} fm <*> xm = MooreT $ (\(f, fm') (x, xm') -> (f x, \a -> fm' a <*> xm' a)) <$> runMooreT fm <*> runMooreT xm {-# INLINE (<*>) #-} instance Applicative m => Pointed (MooreT m a) where point = pure {-# INLINE point #-} instance (Functor m, Monad m) => Costrong (MooreT m) where unfirst m = MooreT $ do ((b, d), m') <- runMooreT m return (b, \a -> unfirst $ m' (a, d)) {-# INLINE unfirst #-} unsecond m = MooreT $ do ((d, b), m') <- runMooreT m return (b, \a -> unsecond $ m' (d, a)) {-# INLINE unsecond #-} instance (Distributive m, Applicative m) => Distributive (MooreT m a) where distribute m = MooreT $ cotraverse (\x -> (fmap fst x, fmap distribute $ distribute $ fmap snd x)) $ fmap runMooreT m {-# INLINE distribute #-} instance (Applicative m, Semigroup b) => Semigroup (MooreT m a b) where a <> b = (<>) <$> a <*> b {-# INLINE (<>) #-} instance (Applicative m, Monoid b) => Monoid (MooreT m a b) where mempty = pure mempty {-# INLINE mempty #-} #if !(MIN_VERSION_base(4,11,0)) mappend a b = mappend <$> a <*> b {-# INLINE mappend #-} #endif ================================================ FILE: src/Data/Machine/Pipe.hs ================================================ {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Machine.Pipe -- Copyright : (C) 2015 Yorick Laupa, Gabriel Gonzalez -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Yorick Laupa -- Stability : provisional -- Portability : Rank-2 Types, GADTs -- -- Allows bidirectional communication between two MachineT. Exposed the -- same interface of Pipes library. ---------------------------------------------------------------------------- module Data.Machine.Pipe where import Control.Monad import Data.Void import Data.Machine.Plan import Data.Machine.Type infixl 8 >~> infixl 7 >+> infixl 7 >>~ infixr 6 +>> data Exchange a' a b' b c where Request :: a' -> Exchange a' a b' b a Respond :: b -> Exchange a' a b' b b' type Proxy a' a b' b m c = MachineT m (Exchange a' a b' b) c -- | 'Effect's neither 'request' nor 'respond' type Effect m r = Proxy Void () () Void m r -- | @Client a' a@ sends requests of type @a'@ and receives responses of -- type @a@. 'Client's only 'request' and never 'respond'. type Client a' a m r = Proxy a' a () Void m r -- | @Server b' b@ receives requests of type @b'@ and sends responses of type -- @b@. 'Server's only 'respond' and never 'request'. type Server b' b m r = Proxy Void () b' b m r -- | Like 'Effect', but with a polymorphic type type Effect' m r = forall x' x y' y . Proxy x' x y' y m r -- | Like 'Server', but with a polymorphic type type Server' b' b m r = forall x' x . Proxy x' x b' b m r -- | Like 'Client', but with a polymorphic type type Client' a' a m r = forall y' y . Proxy a' a y' y m r -- | Send a value of type a' upstream and block waiting for a reply of type a. -- 'request' is the identity of the request category. request :: a' -> PlanT (Exchange a' a y' y) o m a request a = awaits (Request a) -- | Send a value of type a downstream and block waiting for a reply of type a' -- 'respond' is the identity of the respond category. respond :: a -> PlanT (Exchange x' x a' a) o m a' respond a = awaits (Respond a) -- | Forward responses followed by requests. -- 'push' is the identity of the push category. push :: Monad m => a -> Proxy a' a a' a m r push = construct . go where go = respond >=> request >=> go -- | Compose two proxies blocked while 'request'ing data, creating a new proxy -- blocked while 'request'ing data. -- ('>~>') is the composition operator of the push category. (>~>) :: Monad m => (_a -> Proxy a' a b' b m r) -> (b -> Proxy b' b c' c m r) -> _a -> Proxy a' a c' c m r (fa >~> fb) a = fa a >>~ fb -- | (p >>~ f) pairs each 'respond' in p with an 'request' in f. (>>~) :: Monad m => Proxy a' a b' b m r -> (b -> Proxy b' b c' c m r) -> Proxy a' a c' c m r pm >>~ fb = MachineT $ runMachineT pm >>= \p -> case p of Stop -> return Stop Yield r n -> return $ Yield r (n >>~ fb) Await k (Request a') ff -> return $ Await (\a -> k a >>~ fb) (Request a') (ff >>~ fb) Await k (Respond b) _ -> runMachineT (k +>> fb b) -- | Forward requests followed by responses. -- 'pull' is the identity of the pull category. pull :: Monad m => a' -> Proxy a' a a' a m r pull = construct . go where go = request >=> respond >=> go -- | Compose two proxies blocked in the middle of 'respond'ing, creating a new -- proxy blocked in the middle of 'respond'ing. -- ('>+>') is the composition operator of the pull category. (>+>) :: Monad m => (b' -> Proxy a' a b' b m r) -> (_c' -> Proxy b' b c' c m r) -> _c' -> Proxy a' a c' c m r (fb' >+> fc') c' = fb' +>> fc' c' -- | (f +>> p) pairs each 'request' in p with a 'respond' in f. (+>>) :: Monad m => (b' -> Proxy a' a b' b m r) -> Proxy b' b c' c m r -> Proxy a' a c' c m r fb' +>> pm = MachineT $ runMachineT pm >>= \p -> case p of Stop -> return Stop Yield r n -> return $ Yield r (fb' +>> n) Await k (Request b') _ -> runMachineT (fb' b' >>~ k) Await k (Respond c) ff -> return $ Await (\c' -> fb' +>> k c') (Respond c) (fb' +>> ff) -- | It is impossible for an `Exchange` to hold a `Void` value. absurdExchange :: Exchange Void a b Void t -> c absurdExchange (Request z) = absurd z absurdExchange (Respond z) = absurd z -- | Run a self-contained 'Effect', converting it back to the base monad. runEffect :: Monad m => Effect m o -> m [o] runEffect (MachineT m) = m >>= \v -> case v of Stop -> return [] Yield o n -> liftM (o:) (runEffect n) Await _ y _ -> absurdExchange y -- | Like 'runEffect' but discarding any produced value. runEffect_ :: Monad m => Effect m o -> m () runEffect_ (MachineT m) = m >>= \v -> case v of Stop -> return () Yield _ n -> runEffect_ n Await _ y _ -> absurdExchange y ================================================ FILE: src/Data/Machine/Plan.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Machine.Plan -- Copyright : (C) 2012 Edward Kmett, Rúnar Bjarnason -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank-N Types, MPTCs -- ---------------------------------------------------------------------------- module Data.Machine.Plan ( -- * Plans Plan , runPlan , PlanT(..) , yield , maybeYield , await , stop , awaits , exhaust ) where import Control.Applicative import Control.Category import Control.Monad (MonadPlus(..)) import Control.Monad.Trans.Class import Control.Monad.IO.Class import Control.Monad.State.Class import Control.Monad.Reader.Class import Control.Monad.Error.Class import qualified Control.Monad.Fail as Fail import Control.Monad.Writer.Class import Data.Functor.Identity import Prelude hiding ((.),id) ------------------------------------------------------------------------------- -- Plans ------------------------------------------------------------------------------- -- | You can 'construct' a 'Plan' (or 'PlanT'), turning it into a -- 'Data.Machine.Type.Machine' (or 'Data.Machine.Type.MachineT'). -- newtype PlanT k o m a = PlanT { runPlanT :: forall r. (a -> m r) -> -- Done a (o -> m r -> m r) -> -- Yield o (Plan k o a) (forall z. (z -> m r) -> k z -> m r -> m r) -> -- forall z. Await (z -> Plan k o a) (k z) (Plan k o a) m r -> -- Fail m r } -- | A @'Plan' k o a@ is a specification for a pure 'Machine', that reads inputs selected by @k@ -- with types based on @i@, writes values of type @o@, and has intermediate results of type @a@. -- -- A @'Plan' k o a@ can be used as a @'PlanT' k o m a@ for any @'Monad' m@. -- -- It is perhaps easier to think of 'Plan' in its un-cps'ed form, which would -- look like: -- -- @ -- data 'Plan' k o a -- = Done a -- | Yield o (Plan k o a) -- | forall z. Await (z -> Plan k o a) (k z) (Plan k o a) -- | Fail -- @ type Plan k o a = forall m. PlanT k o m a -- | Deconstruct a 'Plan' without reference to a 'Monad'. runPlan :: PlanT k o Identity a -> (a -> r) -> (o -> r -> r) -> (forall z. (z -> r) -> k z -> r -> r) -> r -> r runPlan m kp ke kr kf = runIdentity $ runPlanT m (Identity . kp) (\o (Identity r) -> Identity (ke o r)) (\f k (Identity r) -> Identity (kr (runIdentity . f) k r)) (Identity kf) {-# INLINE runPlan #-} instance Functor (PlanT k o m) where fmap f (PlanT m) = PlanT $ \k -> m (k . f) {-# INLINE fmap #-} instance Applicative (PlanT k o m) where pure a = PlanT (\kp _ _ _ -> kp a) {-# INLINE pure #-} m <*> n = PlanT $ \kp ke kr kf -> runPlanT m (\f -> runPlanT n (\a -> kp (f a)) ke kr kf) ke kr kf {-# INLINE (<*>) #-} m *> n = PlanT $ \kp ke kr kf -> runPlanT m (\_ -> runPlanT n kp ke kr kf) ke kr kf {-# INLINE (*>) #-} m <* n = PlanT $ \kp ke kr kf -> runPlanT m (\a -> runPlanT n (\_ -> kp a) ke kr kf) ke kr kf {-# INLINE (<*) #-} instance Alternative (PlanT k o m) where empty = PlanT $ \_ _ _ kf -> kf {-# INLINE empty #-} PlanT m <|> PlanT n = PlanT $ \kp ke kr kf -> m kp ke kr (n kp ke kr kf) {-# INLINE (<|>) #-} instance Monad (PlanT k o m) where return = pure {-# INLINE return #-} PlanT m >>= f = PlanT (\kp ke kr kf -> m (\a -> runPlanT (f a) kp ke kr kf) ke kr kf) {-# INLINE (>>=) #-} (>>) = (*>) {-# INLINE (>>) #-} #if !(MIN_VERSION_base(4,13,0)) fail = Fail.fail #endif instance Fail.MonadFail (PlanT k o m) where fail _ = PlanT (\_ _ _ kf -> kf) instance MonadPlus (PlanT k o m) where mzero = empty {-# INLINE mzero #-} mplus = (<|>) {-# INLINE mplus #-} instance MonadTrans (PlanT k o) where lift m = PlanT (\kp _ _ _ -> m >>= kp) {-# INLINE lift #-} instance MonadIO m => MonadIO (PlanT k o m) where liftIO m = PlanT (\kp _ _ _ -> liftIO m >>= kp) {-# INLINE liftIO #-} instance MonadState s m => MonadState s (PlanT k o m) where get = lift get {-# INLINE get #-} put = lift . put {-# INLINE put #-} state f = PlanT $ \kp _ _ _ -> state f >>= kp {-# INLINE state #-} instance MonadReader e m => MonadReader e (PlanT k o m) where ask = lift ask reader = lift . reader local f m = PlanT $ \kp ke kr kf -> local f (runPlanT m kp ke kr kf) instance MonadWriter w m => MonadWriter w (PlanT k o m) where writer = lift . writer tell = lift . tell listen m = PlanT $ \kp ke kr kf -> runPlanT m ((kp =<<) . listen . return) ke kr kf pass m = PlanT $ \kp ke kr kf -> runPlanT m ((kp =<<) . pass . return) ke kr kf instance MonadError e m => MonadError e (PlanT k o m) where throwError = lift . throwError catchError m k = PlanT $ \kp ke kr kf -> runPlanT m kp ke kr kf `catchError` \e -> runPlanT (k e) kp ke kr kf -- | Output a result. yield :: o -> Plan k o () yield o = PlanT (\kp ke _ _ -> ke o (kp ())) -- | Like yield, except stops if there is no value to yield. maybeYield :: Maybe o -> Plan k o () maybeYield m = maybe stop (\x -> yield x) m -- | Wait for input. -- -- @'await' = 'awaits' 'id'@ await :: Category k => Plan (k i) o i await = PlanT (\kp _ kr kf -> kr kp id kf) -- | Wait for a particular input. -- -- @ -- awaits 'L' :: 'Plan' ('T' a b) o a -- awaits 'R' :: 'Plan' ('T' a b) o b -- awaits 'id' :: 'Plan' ('Data.Machine.Is.Is' i) o i -- @ awaits :: k i -> Plan k o i awaits h = PlanT $ \kp _ kr -> kr kp h -- | @'stop' = 'empty'@ stop :: Plan k o a stop = empty -- | Run a monadic action repeatedly yielding its results, until it returns Nothing. exhaust :: Monad m => m (Maybe a) -> PlanT k a m () exhaust f = do x <- lift f maybeYield x exhaust f ================================================ FILE: src/Data/Machine/Process.hs ================================================ {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Machine.Process -- Copyright : (C) 2012 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank 2 Types, GADTs -- ---------------------------------------------------------------------------- module Data.Machine.Process ( -- * Processes Process , ProcessT , Automaton(..) , AutomatonM(..) , process -- ** Common Processes , (<~), (~>) , echo , supply , prepended , filtered , dropping , taking , droppingWhile , takingWhile , takingJusts , buffered , flattened , fold , fold1 , scan , scan1 , scanMap , asParts , sinkPart_ , autoM , final , finalOr , intersperse , largest , smallest , sequencing , mapping , traversing , reading , showing , strippingPrefix ) where import Control.Category import Control.Arrow (Kleisli(..)) import Control.Monad (liftM) import Data.Foldable hiding (fold) import Data.Machine.Is import Data.Machine.Plan import Data.Machine.Type import Data.Monoid import Data.Void import Prelude hiding (id, (.)) -- $setup -- >>> import Data.Machine -- >>> import Data.Monoid (Sum (..)) infixr 9 <~ infixl 9 ~> ------------------------------------------------------------------------------- -- Processes ------------------------------------------------------------------------------- -- | A @'Process' a b@ is a stream transducer that can consume values of type @a@ -- from its input, and produce values of type @b@ for its output. type Process a b = Machine (Is a) b -- | A @'ProcessT' m a b@ is a stream transducer that can consume values of type @a@ -- from its input, and produce values of type @b@ and has side-effects in the -- 'Monad' @m@. type ProcessT m a b = MachineT m (Is a) b -- | An 'Automaton' can be automatically lifted into a 'Process' class Automaton k where auto :: k a b -> Process a b instance Automaton (->) where auto = mapping instance Automaton Is where auto Refl = echo class AutomatonM x where autoT :: Monad m => x m a b -> ProcessT m a b instance AutomatonM Kleisli where autoT (Kleisli k) = autoM k -- | The trivial 'Process' that simply repeats each input it receives. -- -- This can be constructed from a plan with -- -- @ -- echo :: Process a a -- echo = repeatedly $ do -- i <- await -- yield i -- @ -- -- Examples: -- -- >>> run $ echo <~ source [1..5] -- [1,2,3,4,5] -- echo :: Process a a echo = loop where loop = encased (Await (\t -> encased (Yield t loop)) Refl stopped) {-# INLINABLE echo #-} -- | A 'Process' that prepends the elements of a 'Foldable' onto its input, then repeats its input from there. prepended :: Foldable f => f a -> Process a a prepended f = before echo $ traverse_ (\x -> yield x) f -- | A 'Process' that only passes through inputs that match a predicate. -- -- This can be constructed from a plan with -- -- @ -- filtered :: (a -> Bool) -> Process a a -- filtered p = repeatedly $ do -- i <- await -- when (p i) $ yield i -- @ -- -- Examples: -- -- >>> run $ filtered even <~ source [1..5] -- [2,4] -- filtered :: (a -> Bool) -> Process a a filtered p = loop where loop = encased $ Await (\a -> if p a then encased (Yield a loop) else loop) Refl stopped {-# INLINABLE filtered #-} -- | A 'Process' that drops the first @n@, then repeats the rest. -- -- This can be constructed from a plan with -- -- @ -- dropping n = before echo $ replicateM_ n await -- @ -- -- Examples: -- -- >>> run $ dropping 3 <~ source [1..5] -- [4,5] -- dropping :: Int -> Process a a dropping i = loop i where loop cnt | cnt <= 0 = echo | otherwise = encased (Await (\_ -> loop (cnt - 1)) Refl stopped) {-# INLINABLE dropping #-} -- | A 'Process' that passes through the first @n@ elements from its input then stops -- -- This can be constructed from a plan with -- -- @ -- taking n = construct . replicateM_ n $ await >>= yield -- @ -- -- Examples: -- -- >>> run $ taking 3 <~ source [1..5] -- [1,2,3] -- taking :: Int -> Process a a taking i = loop i where loop cnt | cnt <= 0 = stopped | otherwise = encased (Await (\v -> encased $ Yield v (loop (cnt - 1))) Refl stopped) {-# INLINABLE taking #-} -- | A 'Process' that passes through elements until a predicate ceases to hold, then stops -- -- This can be constructed from a plan with -- -- @ -- takingWhile :: (a -> Bool) -> Process a a -- takingWhile p = repeatedly $ await >>= \v -> if p v then yield v else stop -- @ -- -- Examples: -- -- >>> run $ takingWhile (< 3) <~ source [1..5] -- [1,2] -- takingWhile :: (a -> Bool) -> Process a a takingWhile p = loop where loop = encased $ Await (\a -> if p a then encased (Yield a loop) else stopped) Refl stopped {-# INLINABLE takingWhile #-} -- | A 'Process' that passes through elements unwrapped from 'Just' until a -- 'Nothing' is found, then stops. -- -- This can be constructed from a plan with -- -- @ -- takingJusts :: Process (Maybe a) a -- takingJusts = repeatedly $ await >>= maybe stop yield -- @ -- -- Examples: -- -- >>> run $ takingJusts <~ source [Just 1, Just 2, Nothing, Just 3, Just 4] -- [1,2] -- takingJusts :: Process (Maybe a) a takingJusts = loop where loop = encased $ Await (maybe stopped (\x -> encased (Yield x loop))) Refl stopped {-# INLINABLE takingJusts #-} -- | A 'Process' that drops elements while a predicate holds -- -- This can be constructed from a plan with -- -- @ -- droppingWhile :: (a -> Bool) -> Process a a -- droppingWhile p = before echo loop where -- loop = await >>= \v -> if p v then loop else yield v -- @ -- -- Examples: -- -- >>> run $ droppingWhile (< 3) <~ source [1..5] -- [3,4,5] -- droppingWhile :: (a -> Bool) -> Process a a droppingWhile p = loop where loop = encased $ Await (\a -> if p a then loop else encased (Yield a echo)) Refl stopped {-# INLINABLE droppingWhile #-} -- | Chunk up the input into `n` element lists. -- -- Avoids returning empty lists and deals with the truncation of the final group. -- -- An approximation of this can be constructed from a plan with -- -- @ -- buffered :: Int -> Process a [a] -- buffered = repeatedly . go [] where -- go acc 0 = yield (reverse acc) -- go acc n = do -- i <- await <|> yield (reverse acc) *> stop -- go (i:acc) $! n-1 -- @ -- -- Examples: -- -- >>> run $ buffered 3 <~ source [1..6] -- [[1,2,3],[4,5,6]] -- -- >>> run $ buffered 3 <~ source [1..5] -- [[1,2,3],[4,5]] -- -- >>> run $ buffered 3 <~ source [] -- [] -- buffered :: Int -> Process a [a] buffered n = begin where -- The buffer is empty, if we don't get anything -- then we shouldn't yield at all. begin = encased $ Await (\v -> loop (v:) (n - 1)) Refl stopped -- The buffer (a diff list) contains elements, and -- we're at the requisite number, yield the -- buffer and restart loop dl 0 = encased $ Yield (dl []) begin -- The buffer contains elements and we're not yet -- done, continue waiting, but if we don't receive -- anything, then yield what we have and stop. loop dl r = encased $ Await (\v -> loop (dl . (v:)) (r - 1)) Refl (finish dl) -- All data has been retrieved, emit and stop. finish dl = encased $ Yield (dl []) stopped {-# INLINABLE buffered #-} -- | Build a new 'Machine' by adding a 'Process' to the output of an old 'Machine' -- -- @ -- ('<~') :: 'Process' b c -> 'Process' a b -> 'Process' a c -- ('<~') :: 'Process' c d -> 'Data.Machine.Tee.Tee' a b c -> 'Data.Machine.Tee.Tee' a b d -- ('<~') :: 'Process' b c -> 'Machine' k b -> 'Machine' k c -- @ (<~) :: Monad m => ProcessT m b c -> MachineT m k b -> MachineT m k c mp <~ ma = MachineT $ runMachineT mp >>= \v -> case v of Stop -> return Stop Yield o k -> return $ Yield o (k <~ ma) Await f Refl ff -> runMachineT ma >>= \u -> case u of Stop -> runMachineT $ ff <~ stopped Yield o k -> runMachineT $ f o <~ k Await g kg fg -> return $ Await (\a -> encased v <~ g a) kg (encased v <~ fg) {-# INLINABLE (<~) #-} -- | Flipped ('<~'). (~>) :: Monad m => MachineT m k b -> ProcessT m b c -> MachineT m k c ma ~> mp = mp <~ ma {-# INLINABLE (~>) #-} -- | Feed a 'Process' some input. -- -- Examples: -- -- >>> run $ supply [1,2,3] echo <~ source [4..6] -- [1,2,3,4,5,6] -- supply :: forall f m a b . (Foldable f, Monad m) => f a -> ProcessT m a b -> ProcessT m a b supply = foldr go id where go :: a -> (ProcessT m a b -> ProcessT m a b) -> ProcessT m a b -> ProcessT m a b go x r m = MachineT $ do v <- runMachineT m case v of Stop -> return Stop Await f Refl _ -> runMachineT $ r (f x) Yield o k -> return $ Yield o (go x r k) {-# INLINABLE supply #-} -- | -- Convert a machine into a process, with a little bit of help. -- -- @ -- choose :: 'Data.Machine.Tee.T' a b x -> (a, b) -> x -- choose t = case t of -- 'Data.Machine.Tee.L' -> 'fst' -- 'Data.Machine.Tee.R' -> 'snd' -- -- 'process' choose :: 'Data.Machine.Tee.Tee' a b c -> 'Data.Machine.Process.Process' (a, b) c -- 'process' choose :: 'Data.Machine.Tee.Tee' a b c -> 'Data.Machine.Process.Process' (a, b) c -- 'process' ('const' 'id') :: 'Data.Machine.Process.Process' a b -> 'Data.Machine.Process.Process' a b -- @ process :: Monad m => (forall a. k a -> i -> a) -> MachineT m k o -> ProcessT m i o process f (MachineT m) = MachineT (liftM f' m) where f' (Yield o k) = Yield o (process f k) f' Stop = Stop f' (Await g kir h) = Await (process f . g . f kir) Refl (process f h) -- | -- Construct a 'Process' from a left-scanning operation. -- -- Like 'fold', but yielding intermediate values. -- -- It may be useful to consider this alternative signature -- -- @ -- 'scan' :: (a -> b -> a) -> a -> Process b a -- @ -- -- For stateful 'scan' use 'auto' with "Data.Machine.Mealy" machine. -- This can be constructed from a plan with -- -- @ -- scan :: Category k => (a -> b -> a) -> a -> Machine (k b) a -- scan func seed = construct $ go seed where -- go cur = do -- yield cur -- next <- await -- go $! func cur next -- @ -- -- Examples: -- -- >>> run $ scan (+) 0 <~ source [1..5] -- [0,1,3,6,10,15] -- -- >>> run $ scan (\a _ -> a + 1) 0 <~ source [1..5] -- [0,1,2,3,4,5] -- scan :: Category k => (a -> b -> a) -> a -> Machine (k b) a scan func seed = let step t = t `seq` encased $ Yield t $ encased $ Await (step . func t) id stopped in step seed {-# INLINABLE scan #-} -- | -- 'scan1' is a variant of 'scan' that has no starting value argument -- -- This can be constructed from a plan with -- -- @ -- scan1 :: Category k => (a -> a -> a) -> Machine (k a) a -- scan1 func = construct $ await >>= go where -- go cur = do -- yield cur -- next <- await -- go $! func cur next -- @ -- -- Examples: -- -- >>> run $ scan1 (+) <~ source [1..5] -- [1,3,6,10,15] -- scan1 :: Category k => (a -> a -> a) -> Machine (k a) a scan1 func = let step t = t `seq` encased $ Yield t $ encased $ Await (step . func t) id stopped in encased $ Await step id stopped {-# INLINABLE scan1 #-} -- | -- Like 'scan' only uses supplied function to map and uses Monoid for -- associative operation -- -- Examples: -- -- >>> run $ mapping getSum <~ scanMap Sum <~ source [1..5] -- [0,1,3,6,10,15] -- scanMap :: (Category k, Monoid b) => (a -> b) -> Machine (k a) b scanMap f = scan (\b a -> mappend b (f a)) mempty {-# INLINABLE scanMap #-} -- | -- Construct a 'Process' from a left-folding operation. -- -- Like 'scan', but only yielding the final value. -- -- It may be useful to consider this alternative signature -- -- @ -- 'fold' :: (a -> b -> a) -> a -> Process b a -- @ -- -- This can be constructed from a plan with -- -- @ -- fold :: Category k => (a -> b -> a) -> a -> Machine (k b) a -- fold func seed = construct $ go seed where -- go cur = do -- next <- await <|> yield cur *> stop -- go $! func cur next -- @ -- -- Examples: -- -- >>> run $ fold (+) 0 <~ source [1..5] -- [15] -- -- >>> run $ fold (\a _ -> a + 1) 0 <~ source [1..5] -- [5] -- fold :: Category k => (a -> b -> a) -> a -> Machine (k b) a fold func x = let step t = t `seq` encased $ Await (step . func t) id (encased $ Yield t stopped) in step x {-# INLINABLE fold #-} -- | -- 'fold1' is a variant of 'fold' that has no starting value argument -- -- This can be constructed from a plan with -- -- @ -- fold1 :: Category k => (a -> a -> a) -> Machine (k a) a -- fold1 func = construct $ await >>= go where -- go cur = do -- next <- await <|> yield cur *> stop -- go $! func cur next -- @ -- -- Examples: -- -- >>> run $ fold1 (+) <~ source [1..5] -- [15] -- fold1 :: Category k => (a -> a -> a) -> Machine (k a) a fold1 func = let step t = t `seq` encased $ Await (step . func t) id (encased $ Yield t stopped) in encased $ Await step id stopped {-# INLINABLE fold1 #-} -- | Break each input into pieces that are fed downstream -- individually. -- -- This can be constructed from a plan with -- -- @ -- asParts :: Foldable f => Process (f a) a -- asParts = repeatedly $ await >>= traverse_ yield -- @ -- -- Examples: -- -- >>> run $ asParts <~ source [[1..3],[4..6]] -- [1,2,3,4,5,6] -- asParts :: Foldable f => Process (f a) a asParts = let step = encased $ Await (foldr (\b s -> encased (Yield b s)) step) id stopped in step {-# INLINABLE asParts #-} -- | Break each input into pieces that are fed downstream -- individually. -- -- Alias for @asParts@ -- flattened :: Foldable f => Process (f a) a flattened = asParts {-# INLINABLE flattened #-} -- | @sinkPart_ toParts sink@ creates a process that uses the -- @toParts@ function to break input into a tuple of @(passAlong, -- sinkPart)@ for which the second projection is given to the supplied -- @sink@ 'ProcessT' (that produces no output) while the first -- projection is passed down the pipeline. sinkPart_ :: Monad m => (a -> (b,c)) -> ProcessT m c Void -> ProcessT m a b sinkPart_ p = go where go m = MachineT $ runMachineT m >>= \v -> case v of Stop -> return Stop Yield o _ -> absurd o Await f Refl ff -> return $ Await (\x -> let (keep,sink) = p x in encased . Yield keep $ go (f sink)) Refl (go ff) -- | Apply a monadic function to each element of a 'ProcessT'. -- -- This can be constructed from a plan with -- -- @ -- autoM :: Monad m => (a -> m b) -> ProcessT m a b -- autoM :: (Category k, Monad m) => (a -> m b) -> MachineT m (k a) b -- autoM f = repeatedly $ await >>= lift . f >>= yield -- @ -- -- Examples: -- -- >>> runT $ autoM Left <~ source [3, 4] -- Left 3 -- -- >>> runT $ autoM Right <~ source [3, 4] -- Right [3,4] -- autoM :: (Category k, Monad m) => (a -> m b) -> MachineT m (k a) b autoM f = loop where loop = encased (Await (\t -> MachineT (flip Yield loop `liftM` f t)) id stopped) {-# INLINABLE autoM #-} -- | -- Skip all but the final element of the input -- -- This can be constructed from a plan with -- -- @ -- 'final' :: 'Process' a a -- final :: Category k => Machine (k a) a -- final = construct $ await >>= go where -- go prev = do -- next <- await <|> yield prev *> stop -- go next -- @ -- -- Examples: -- -- >>> runT $ final <~ source [1..10] -- [10] -- >>> runT $ final <~ source [] -- [] -- final :: Category k => Machine (k a) a final = let step x = encased (Await step id (emit x)) emit x = encased (Yield x stopped) in encased $ Await step id stopped {-# INLINABLE final #-} -- | -- Skip all but the final element of the input. -- If the input is empty, the default value is emitted -- -- This can be constructed from a plan with -- -- @ -- 'finalOr' :: a -> 'Process' a a -- finalOr :: Category k => a -> Machine (k a) a -- finalOr = construct . go where -- go prev = do -- next <- await <|> yield prev *> stop -- go next -- @ -- -- Examples: -- -- >>> runT $ finalOr (-1) <~ source [1..10] -- [10] -- >>> runT $ finalOr (-1) <~ source [] -- [-1] -- finalOr :: Category k => a -> Machine (k a) a finalOr y = let step x = encased (Await step id (emit x)) emit x = encased (Yield x stopped) in step y {-# INLINABLE finalOr #-} -- | -- Intersperse an element between the elements of the input -- -- @ -- 'intersperse' :: a -> 'Process' a a -- @ intersperse :: Category k => a -> Machine (k a) a intersperse sep = construct $ await >>= go where go cur = do yield cur next <- await yield sep go next -- | -- Return the maximum value from the input largest :: (Category k, Ord a) => Machine (k a) a largest = fold1 max {-# INLINABLE largest #-} -- | -- Return the minimum value from the input smallest :: (Category k, Ord a) => Machine (k a) a smallest = fold1 min {-# INLINABLE smallest #-} -- | -- Convert a stream of actions to a stream of values -- -- This can be constructed from a plan with -- -- @ -- sequencing :: Monad m => (a -> m b) -> ProcessT m a b -- sequencing :: (Category k, Monad m) => MachineT m (k (m a)) a -- sequencing = repeatedly $ do -- ma <- await -- a <- lift ma -- yield a -- @ -- -- Examples: -- -- >>> runT $ sequencing <~ source [Just 3, Nothing] -- Nothing -- -- >>> runT $ sequencing <~ source [Just 3, Just 4] -- Just [3,4] -- sequencing :: (Category k, Monad m) => MachineT m (k (m a)) a sequencing = autoM id {-# INLINABLE sequencing #-} -- | -- Apply a function to all values coming from the input -- -- This can be constructed from a plan with -- -- @ -- mapping :: Category k => (a -> b) -> Machine (k a) b -- mapping f = repeatedly $ await >>= yield . f -- @ -- -- Examples: -- -- >>> runT $ mapping (*2) <~ source [1..3] -- [2,4,6] -- mapping :: Category k => (a -> b) -> Machine (k a) b mapping f = loop where loop = encased (Await (\t -> encased (Yield (f t) loop)) id stopped) {-# INLINABLE mapping #-} -- | -- Apply an effectful to all values coming from the input. -- -- Alias to 'autoM'. traversing :: (Category k, Monad m) => (a -> m b) -> MachineT m (k a) b traversing = autoM -- | -- Parse 'Read'able values, only emitting the value if the parse succceeds. -- This 'Machine' stops at first parsing error reading :: (Category k, Read a) => Machine (k String) a reading = repeatedly $ do s <- await case reads s of [(a, "")] -> yield a _ -> stop -- | -- Convert 'Show'able values to 'String's showing :: (Category k, Show a) => Machine (k a) String showing = mapping show {-# INLINABLE showing #-} -- | -- '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 (MachineT . verify b nxt . f) ki (MachineT $ verify b nxt ff) ================================================ FILE: src/Data/Machine/Runner.hs ================================================ {-# LANGUAGE BangPatterns #-} module Data.Machine.Runner ( foldrT , foldlT , foldMapT , foldT , runT1 -- Re-exports , runT , runT_ ) where import Data.Machine.Type import Control.Monad (liftM) -- | Right fold over a stream. This will be lazy if the underlying -- monad is. -- -- @runT = foldrT (:) []@ foldrT :: Monad m => (o -> b -> b) -> b -> MachineT m k o -> m b foldrT c n = go where go m = do step <- runMachineT m case step of Stop -> return n Yield o m' -> c o `liftM` go m' Await _ _ m' -> go m' -- | Strict left fold over a stream. foldlT :: Monad m => (b -> o -> b) -> b -> MachineT m k o -> m b foldlT f = go where go !b m = do step <- runMachineT m case step of Stop -> return b Yield o m' -> go (f b o) m' Await _ _ m' -> go b m' -- | Strict fold over a stream. Items are accumulated on the right: -- -- @... ((f o1 <> f o2) <> f o3) ...@ -- -- Where this is expensive, use the dual monoid instead. foldMapT :: (Monad m, Monoid r) => (o -> r) -> MachineT m k o -> m r foldMapT f = foldlT (\b o -> mappend b (f o)) mempty -- | Strict fold over a monoid stream. Items are accumulated on the -- right: -- -- @... ((o1 <> o2) <> o3) ...@ -- -- Where this is expensive, use the dual monoid instead. -- -- @foldT = foldMapT id@ foldT :: (Monad m, Monoid o) => MachineT m k o -> m o foldT = foldlT mappend mempty -- | Run a machine with no input until it yields for the first time, -- then stop it. This is intended primarily for use with accumulating -- machines, such as the ones produced by 'fold' or 'fold1' -- -- @runT1 m = getFirst <$> foldMapT (First . Just) (m ~> taking 1)@ runT1 :: Monad m => MachineT m k o -> m (Maybe o) runT1 m = do step <- runMachineT m case step of Stop -> return Nothing Yield o _ -> return $ Just o Await _ _ m' -> runT1 m' ================================================ FILE: src/Data/Machine/Source.hs ================================================ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Machine.Source -- Copyright : (C) 2012 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank-2 Types -- ---------------------------------------------------------------------------- module Data.Machine.Source ( -- * Sources Source, SourceT , source , repeated , cycled , cap , plug , iterated , replicated , enumerateFromTo , unfold , unfoldT ) where import Control.Monad.Trans import Data.Foldable import Data.Machine.Plan import Data.Machine.Type import Data.Machine.Process import Prelude (Enum, Int, Maybe, Monad, ($), (>>=), return) -- $setup -- >>> import Data.Machine ------------------------------------------------------------------------------- -- Source ------------------------------------------------------------------------------- -- | A 'Source' never reads from its inputs. type Source b = forall k. Machine k b -- | A 'SourceT' never reads from its inputs, but may have monadic side-effects. type SourceT m b = forall k. MachineT m k b -- | Repeat the same value, over and over. -- -- This can be constructed from a plan with -- @ -- repeated :: o -> Source o -- repeated = repeatedly . yield -- @ -- -- Examples: -- -- >>> run $ taking 5 <~ repeated 1 -- [1,1,1,1,1] -- repeated :: o -> Source o repeated o = loop where loop = encased (Yield o loop) -- | Loop through a 'Foldable' container over and over. -- -- This can be constructed from a plan with -- @ -- cycled :: Foldable f => f b -> Source b -- cycled = repeatedly (traverse_ yield xs) -- @ -- -- Examples: -- -- >>> run $ taking 5 <~ cycled [1,2] -- [1,2,1,2,1] -- cycled :: Foldable f => f b -> Source b cycled xs = foldr go (cycled xs) xs where go x m = encased $ Yield x m -- | Generate a 'Source' from any 'Foldable' container. -- -- This can be constructed from a plan with -- @ -- source :: Foldable f => f b -> Source b -- source = construct (traverse_ yield xs) -- @ -- -- Examples: -- -- >>> run $ source [1,2] -- [1,2] -- source :: Foldable f => f b -> Source b source f = foldr go stopped f where go x m = encased $ Yield x m -- | -- You can transform a 'Source' with a 'Process'. -- -- Alternately you can view this as capping the 'Source' end of a 'Process', -- yielding a new 'Source'. -- -- @'cap' l r = l '<~' r@ -- cap :: Process a b -> Source a -> Source b cap l r = l <~ r -- | -- You can transform any 'MachineT' into a 'SourceT', blocking its input. -- -- This is used by capT, and capWye, and allows an efficient way to plug -- together machines of different input languages. -- plug :: Monad m => MachineT m k o -> SourceT m o plug (MachineT m) = MachineT $ m >>= \x -> case x of Yield o k -> return (Yield o (plug k)) Stop -> return Stop Await _ _ h -> runMachineT $ plug h -- | 'iterated' @f x@ returns an infinite source of repeated applications -- of @f@ to @x@ iterated :: (a -> a) -> a -> Source a iterated f x = construct (go x) where go a = do yield a go (f a) -- | 'replicated' @n x@ is a source of @x@ emitted @n@ time(s) replicated :: Int -> a -> Source a replicated n x = repeated x ~> taking n -- | Enumerate from a value to a final value, inclusive, via 'succ' -- -- Examples: -- -- >>> run $ enumerateFromTo 1 3 -- [1,2,3] -- enumerateFromTo :: Enum a => a -> a -> Source a enumerateFromTo start end = source [ start .. end ] -- | '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' ================================================ FILE: src/Data/Machine/Stack.hs ================================================ {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Machine.Stack -- Copyright : (C) 2012 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : GADTs -- ---------------------------------------------------------------------------- module Data.Machine.Stack ( Stack(..) , stack , peek , pop , push ) where import Data.Machine.Plan import Data.Machine.Type -- | This is a simple process type that knows how to push back input. data Stack a r where Push :: a -> Stack a () Pop :: Stack a a -- | Peek at the next value in the input stream without consuming it peek :: Plan (Stack a) b a peek = do a <- pop push a return a {-# INLINABLE peek #-} -- | Push back into the input stream push :: a -> Plan (Stack a) b () push a = awaits (Push a) {-# INLINABLE push #-} -- | Pop the next value in the input stream pop :: Plan (Stack a) b a pop = awaits Pop {-# INLINABLE pop #-} -- | Stream outputs from one 'Machine' into another with the possibility -- of pushing inputs back. stack :: Monad m => MachineT m k a -> MachineT m (Stack a) o -> MachineT m k o stack up down = stepMachine down $ \stepD -> case stepD of Stop -> stopped Yield o down' -> encased (Yield o (up `stack` down')) Await down' (Push a) _ -> encased (Yield a up) `stack` down' () Await down' Pop ffD -> stepMachine up $ \stepU -> case stepU of Stop -> stopped `stack` ffD Yield o up' -> up' `stack` down' o Await up' req ffU -> encased (Await (\a -> up' a `stack` encased stepD) req ( ffU `stack` encased stepD)) {-# INLINABLE stack #-} ================================================ FILE: src/Data/Machine/Tee.hs ================================================ {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Machine.Tee -- Copyright : (C) 2012 Edward Kmett, Rúnar Bjarnason, Paul Chiusano -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank-2 Types, GADTs -- ---------------------------------------------------------------------------- module Data.Machine.Tee ( -- * Tees Tee, TeeT , T(..) , tee, teeT , addL, addR , capL, capR, capT , zipWithT , zipWith , zipping ) where import Data.Machine.Is import Data.Machine.Plan import Data.Machine.Process import Data.Machine.Type import Data.Machine.Source import Prelude hiding ((.), id, zipWith) -- $setup -- >>> import Data.Machine ------------------------------------------------------------------------------- -- Tees ------------------------------------------------------------------------------- -- | The input descriptor for a 'Tee' or 'TeeT' data T a b c where L :: T a b a R :: T a b b -- | A 'Machine' that can read from two input stream in a deterministic manner. type Tee a b c = Machine (T a b) c -- | A 'Machine' that can read from two input stream in a deterministic manner with monadic side-effects. type TeeT m a b c = MachineT m (T a b) c -- | Compose a pair of pipes onto the front of a Tee. -- -- Examples: -- -- >>> import Data.Machine.Source -- >>> run $ tee (source [1..]) (source ['a'..'c']) zipping -- [(1,'a'),(2,'b'),(3,'c')] -- tee :: Monad m => ProcessT m a a' -> ProcessT m b b' -> TeeT m a' b' c -> TeeT m a b c tee ma mb m = MachineT $ runMachineT m >>= \v -> case v of Stop -> return Stop Yield o k -> return $ Yield o $ tee ma mb k Await f L ff -> runMachineT ma >>= \u -> case u of Stop -> runMachineT $ tee stopped mb ff Yield a k -> runMachineT $ tee k mb $ f a Await g Refl fg -> return $ Await (\a -> tee (g a) mb $ encased v) L $ tee fg mb $ encased v Await f R ff -> runMachineT mb >>= \u -> case u of Stop -> runMachineT $ tee ma stopped ff Yield b k -> runMachineT $ tee ma k $ f b Await g Refl fg -> return $ Await (\b -> tee ma (g b) $ encased v) R $ tee ma fg $ encased v -- | `teeT mt ma mb` Use a `Tee` to interleave or combine the outputs of `ma` -- and `mb`. -- -- The resulting machine will draw from a single source. -- -- Examples: -- -- >>> import Data.Machine.Source -- >>> run $ teeT zipping echo echo <~ source [1..5] -- [(1,2),(3,4)] -- teeT :: Monad m => TeeT m a b c -> MachineT m k a -> MachineT m k b -> MachineT m k c teeT mt ma mb = MachineT $ runMachineT mt >>= \v -> case v of Stop -> return Stop Yield o k -> return $ Yield o $ teeT k ma mb Await f L ff -> runMachineT ma >>= \u -> case u of Stop -> runMachineT $ teeT ff stopped mb Yield a k -> runMachineT $ teeT (f a) k mb Await g rq fg -> return $ Await (\r -> teeT (encased v) (g r) mb) rq $ teeT (encased v) fg mb Await f R ff -> runMachineT mb >>= \u -> case u of Stop -> runMachineT $ teeT ff ma stopped Yield a k -> runMachineT $ teeT (f a) ma k Await g rq fg -> return $ Await (\r -> teeT (encased v) ma (g r)) rq $ teeT (encased v) ma fg -- | Precompose a pipe onto the left input of a tee. addL :: Monad m => ProcessT m a b -> TeeT m b c d -> TeeT m a c d addL p = tee p echo {-# INLINE addL #-} -- | Precompose a pipe onto the right input of a tee. addR :: Monad m => ProcessT m b c -> TeeT m a c d -> TeeT m a b d addR = tee echo {-# INLINE addR #-} -- | Tie off one input of a tee by connecting it to a known source. capL :: Monad m => SourceT m a -> TeeT m a b c -> ProcessT m b c capL s t = fit cappedT $ addL s t {-# INLINE capL #-} -- | Tie off one input of a tee by connecting it to a known source. capR :: Monad m => SourceT m b -> TeeT m a b c -> ProcessT m a c capR s t = fit cappedT $ addR s t {-# INLINE capR #-} -- | Tie off both inputs to a tee by connecting them to known sources. -- This is recommended over capping each side separately, as it is -- far more efficient. capT :: Monad m => SourceT m a -> SourceT m b -> TeeT m a b c -> SourceT m c capT l r t = plug $ tee l r t {-# INLINE capT #-} -- | Natural transformation used by 'capL' and 'capR'. cappedT :: T a a b -> Is a b cappedT R = Refl cappedT L = Refl {-# INLINE cappedT #-} -- | wait for both the left and the right sides of a T and then merge them with f. 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 #-} -- | Zip together two inputs, then apply the given function, -- halting as soon as either input is exhausted. -- This implementation reads from the left, then the right zipWith :: (a -> b -> c) -> Tee a b c zipWith f = repeatedly $ do a <- awaits L 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 #-} ================================================ FILE: src/Data/Machine/Type.hs ================================================ {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Machine.Type -- Copyright : (C) 2012 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : rank-2, GADTs -- ---------------------------------------------------------------------------- module Data.Machine.Type ( -- * Machines MachineT(..) , Step(..) , Machine , runT_ , runT , run , runMachine , encased -- ** Building machines from plans , construct , repeatedly , unfoldPlan , before , preplan -- , sink -- ** Deconstructing machines back into plans , deconstruct , tagDone , finishWith -- * Reshaping machines , fit , fitM , pass , starve , stopped , stepMachine -- * Applicative Machines , Appliance(..) ) where import Control.Applicative import Control.Category import Control.Monad (liftM) import Data.Foldable import Data.Functor.Identity import Data.Machine.Plan import Data.Monoid hiding ((<>)) import Data.Pointed import Data.Profunctor.Unsafe ((#.)) import Data.Semigroup import Prelude hiding ((.),id) ------------------------------------------------------------------------------- -- Transduction Machines ------------------------------------------------------------------------------- -- | This is the base functor for a 'Machine' or 'MachineT'. -- -- Note: A 'Machine' is usually constructed from 'Plan', so it does not need to be CPS'd. data Step k o r = Stop | Yield o r | forall t. Await (t -> r) (k t) r instance Functor (Step k o) where fmap _ Stop = Stop fmap f (Yield o k) = Yield o (f k) fmap f (Await g kg fg) = Await (f . g) kg (f fg) -- | A 'MachineT' reads from a number of inputs and may yield results before stopping -- with monadic side-effects. newtype MachineT m k o = MachineT { runMachineT :: m (Step k o (MachineT m k o)) } -- | A 'Machine' reads from a number of inputs and may yield results before stopping. -- -- A 'Machine' can be used as a @'MachineT' m@ for any @'Monad' m@. type Machine k o = forall m. Monad m => MachineT m k o -- | @'runMachine' = 'runIdentity' . 'runMachineT'@ runMachine :: MachineT Identity k o -> Step k o (MachineT Identity k o) runMachine = runIdentity . runMachineT -- | Pack a 'Step' of a 'Machine' into a 'Machine'. encased :: Monad m => Step k o (MachineT m k o) -> MachineT m k o encased = MachineT #. return -- | Transform a 'Machine' by looking at a single step of that machine. stepMachine :: Monad m => MachineT m k o -> (Step k o (MachineT m k o) -> MachineT m k' o') -> MachineT m k' o' stepMachine m f = MachineT (runMachineT #. f =<< runMachineT m) instance Monad m => Functor (MachineT m k) where fmap f (MachineT m) = MachineT (liftM f' m) where f' (Yield o xs) = Yield (f o) (f <$> xs) f' (Await k kir e) = Await (fmap f . k) kir (f <$> e) f' Stop = Stop instance Monad m => Pointed (MachineT m k) where point x = repeatedly $ yield x instance Monad m => Semigroup (MachineT m k o) where a <> b = stepMachine a $ \step -> case step of Yield o a' -> encased (Yield o (mappend a' b)) Await k kir e -> encased (Await (\x -> k x <> b) kir (e <> b)) Stop -> b instance Monad m => Monoid (MachineT m k o) where mempty = stopped mappend = (<>) -- | An input type that supports merging requests from multiple machines. class Appliance k where applied :: Monad m => MachineT m k (a -> b) -> MachineT m k a -> MachineT m k b instance (Monad m, Appliance k) => Applicative (MachineT m k) where pure = point (<*>) = applied {- -- TODO instance Appliance (Is i) where applied = appliedTo (Just mempty) (Just mempty) id (flip id) where -- applied appliedTo :: Maybe (Seq i) -> Maybe (i -> MachineT m (Is i) b, MachineT m (Is i) b) -> Either (Seq a) (Seq b) -> (a -> b -> c) -> (b -> a -> c) -> MachineT m (Is i) a -> MachineT m (Is i) b -> MachineT m (Is i) c appliedTo mis blocking ss f g m n = MachineT $ runMachineT m >>= \v -> case v of Stop -> return Stop Yield a k -> case ss of Left as -> Right bs -> case viewl bs of b :< bs' -> return $ Yield (f a b) (appliedTo mis bs' f g m n) EmptyL -> runMachine $ appliedTo mis blocking (singleton a) g f n m Await ak Refl e -> case mis of Nothing -> runMachine $ appliedTo Nothing blocking bs f g e n Just is -> case viewl is of i :< is' -> runMachine $ appliedTo (Just is') blocking bs f g (ak i) m EmptyL -> case blocking of Just (bk, be) -> Nothing -> runMachine $ appliedTo mis (Just (ak, e)) | blocking -> return $ Await (\i -> appliedTo (Just (singleton i)) False f g (ak i) n) Refl $ | otherwise -> -} -- | Stop feeding input into model, taking only the effects. {-# INLINABLE runT_ #-} runT_ :: Monad m => MachineT m k b -> m () runT_ m = runMachineT m >>= \v -> case v of Stop -> return () Yield _ k -> runT_ k Await _ _ e -> runT_ e -- | Stop feeding input into model and extract an answer {-# INLINABLE runT #-} runT :: Monad m => MachineT m k b -> m [b] runT (MachineT m) = m >>= \v -> case v of Stop -> return [] Yield o k -> liftM (o:) (runT k) Await _ _ e -> runT e -- | Run a pure machine and extract an answer. run :: MachineT Identity k b -> [b] run = runIdentity . runT -- | This permits toList to be used on a Machine. instance (m ~ Identity) => Foldable (MachineT m k) where foldMap f (MachineT (Identity m)) = go m where go Stop = mempty go (Yield o k) = f o `mappend` foldMap f k go (Await _ _ fg) = foldMap f fg -- | -- Connect different kinds of machines. -- -- @'fit' 'id' = 'id'@ fit :: Monad m => (forall a. k a -> k' a) -> MachineT m k o -> MachineT m k' o fit f (MachineT m) = MachineT (liftM f' m) where f' (Yield o k) = Yield o (fit f k) f' Stop = Stop f' (Await g kir h) = Await (fit f . g) (f kir) (fit f h) {-# INLINE fit #-} --- | Connect machine transformers over different monads using a monad --- morphism. fitM :: (Monad m, Monad m') => (forall a. m a -> m' a) -> MachineT m k o -> MachineT m' k o fitM f (MachineT m) = MachineT $ f (liftM aux m) where aux Stop = Stop aux (Yield o k) = Yield o (fitM f k) aux (Await g kg gg) = Await (fitM f . g) kg (fitM f gg) {-# INLINE fitM #-} -- | Compile a machine to a model. construct :: Monad m => PlanT k o m a -> MachineT m k o construct m = MachineT $ runPlanT m (const (return Stop)) (\o k -> return (Yield o (MachineT k))) (\f k g -> return (Await (MachineT #. f) k (MachineT g))) (return Stop) {-# INLINE construct #-} -- | Generates a model that runs a machine until it stops, then start it up again. -- -- @'repeatedly' m = 'construct' ('Control.Monad.forever' m)@ repeatedly :: Monad m => PlanT k o m a -> MachineT m k o repeatedly m = r where r = MachineT $ runPlanT m (const (runMachineT r)) (\o k -> return (Yield o (MachineT k))) (\f k g -> return (Await (MachineT #. f) k (MachineT g))) (return Stop) {-# INLINE repeatedly #-} -- | Unfold a stateful PlanT into a MachineT. unfoldPlan :: Monad m => s -> (s -> PlanT k o m s) -> MachineT m k o unfoldPlan s0 sp = r s0 where r s = MachineT $ runPlanT (sp s) (\sx -> runMachineT $ r sx) (\o k -> return (Yield o (MachineT k))) (\f k g -> return (Await (MachineT #. f) k (MachineT g))) (return Stop) {-# INLINE unfoldPlan #-} -- | Evaluate a machine until it stops, and then yield answers according to the supplied model. before :: Monad m => MachineT m k o -> PlanT k o m a -> MachineT m k o before (MachineT n) m = MachineT $ runPlanT m (const n) (\o k -> return (Yield o (MachineT k))) (\f k g -> return (Await (MachineT #. f) k (MachineT g))) (return Stop) {-# INLINE before #-} -- | Incorporate a 'Plan' into the resulting machine. preplan :: Monad m => PlanT k o m (MachineT m k o) -> MachineT m k o preplan m = MachineT $ runPlanT m runMachineT (\o k -> return (Yield o (MachineT k))) (\f k g -> return (Await (MachineT #. f) k (MachineT g))) (return Stop) {-# INLINE preplan #-} -- | Given a handle, ignore all other inputs and just stream input from that handle. -- -- @ -- 'pass' 'id' :: 'Data.Machine.Process.Process' a a -- 'pass' 'Data.Machine.Tee.L' :: 'Data.Machine.Tee.Tee' a b a -- 'pass' 'Data.Machine.Tee.R' :: 'Data.Machine.Tee.Tee' a b b -- 'pass' 'Data.Machine.Wye.X' :: 'Data.Machine.Wye.Wye' a b a -- 'pass' 'Data.Machine.Wye.Y' :: 'Data.Machine.Wye.Wye' a b b -- 'pass' 'Data.Machine.Wye.Z' :: 'Data.Machine.Wye.Wye' a b (Either a b) -- @ -- pass :: k o -> Machine k o pass k = loop where loop = encased (Await (\t -> encased (Yield t loop)) k stopped) {-# INLINE pass #-} -- | Run a machine with no input until it stops, then behave as another machine. starve :: Monad m => MachineT m k0 b -> MachineT m k b -> MachineT m k b starve m cont = MachineT $ runMachineT m >>= \v -> case v of Stop -> runMachineT cont -- Continue with cont instead of stopping Yield o r -> return $ Yield o (starve r cont) Await _ _ r -> runMachineT (starve r cont) {-# INLINE starve #-} -- | This is a stopped 'Machine' stopped :: Machine k b stopped = encased Stop {-# INLINE stopped #-} -------------------------------------------------------------------------------- -- Deconstruction -------------------------------------------------------------------------------- --- | Convert a 'Machine' back into a 'Plan'. The first value the --- machine yields that is tagged with the 'Left' data constructor is --- used as the return value of the resultant 'Plan'. Machine-yielded --- values tagged with 'Right' are yielded -- sans tag -- by the --- result 'Plan'. This may be used when monadic binding of results is --- required. deconstruct :: Monad m => MachineT m k (Either a o) -> PlanT k o m a deconstruct m = PlanT $ \r y a f -> let aux k = runPlanT (deconstruct k) r y a f in runMachineT m >>= \v -> case v of Stop -> f Yield (Left o) _ -> r o Yield (Right o) k -> y o (aux k) Await g fk h -> a (aux . g) fk (aux h) -- | Use a predicate to mark a yielded value as the terminal value of -- this 'Machine'. This is useful in combination with 'deconstruct' to -- combine 'Plan's. tagDone :: Monad m => (o -> Bool) -> MachineT m k o -> MachineT m k (Either o o) tagDone f = fmap aux where aux x = if f x then Left x else Right x -- | Use a function to produce and mark a yielded value as the -- terminal value of a 'Machine'. All yielded values for which the -- given function returns 'Nothing' are yielded down the pipeline, but -- the first value for which the function returns a 'Just' value will -- be returned by a 'Plan' created via 'deconstruct'. finishWith :: Monad m => (o -> Maybe r) -> MachineT m k o -> MachineT m k (Either r o) finishWith f = fmap aux where aux x = maybe (Right x) Left $ f x ------------------------------------------------------------------------------- -- Sink ------------------------------------------------------------------------------- {- -- | -- A Sink in this model is a 'Data.Machine.Process.Process' -- (or 'Data.Machine.Tee.Tee', etc) that produces a single answer. -- -- \"Is that your final answer?\" sink :: Monad m => (forall o. PlanT k o m a) -> MachineT m k a sink m = runPlanT m (\a -> Yield a Stop) id (Await id) Stop -} ================================================ FILE: src/Data/Machine/Wye.hs ================================================ {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Machine.Wye -- Copyright : (C) 2012 Edward Kmett, Rúnar Bjarnason, Paul Chiusano -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank-2 Types, GADTs -- ---------------------------------------------------------------------------- module Data.Machine.Wye ( -- * Wyes Wye, WyeT , Y(..) , wye , addX, addY , capX, capY, capWye ) where import Control.Category import Data.Machine.Process import Data.Machine.Type import Data.Machine.Is import Data.Machine.Source import Prelude hiding ((.),id) ------------------------------------------------------------------------------- -- Wyes ------------------------------------------------------------------------------- -- | The input descriptor for a 'Wye' or 'WyeT' data Y a b c where X :: Y a b a -- block waiting on the left input Y :: Y a b b -- block waiting on the right input Z :: Y a b (Either a b) -- block waiting on either input -- | A 'Machine' that can read from two input stream in a non-deterministic manner. type Wye a b c = Machine (Y a b) c -- | A 'Machine' that can read from two input stream in a non-deterministic manner with monadic side-effects. type WyeT m a b c = MachineT m (Y a b) c -- | Compose a pair of pipes onto the front of a 'Wye'. -- | Precompose a 'Process' onto each input of a 'Wye' (or 'WyeT'). -- -- This is left biased in that it tries to draw values from the 'X' input whenever they are -- available, and only draws from the 'Y' input when 'X' would block. wye :: Monad m => ProcessT m a a' -> ProcessT m b b' -> WyeT m a' b' c -> WyeT m a b c wye ma mb m = MachineT $ runMachineT m >>= \v -> case v of Yield o k -> return $ Yield o (wye ma mb k) Stop -> return Stop Await f X ff -> runMachineT ma >>= \u -> case u of Yield a k -> runMachineT . wye k mb $ f a Stop -> runMachineT $ wye stopped mb ff Await g Refl fg -> return . Await (\a -> wye (g a) mb $ encased v) X . wye fg mb $ encased v Await f Y ff -> runMachineT mb >>= \u -> case u of Yield b k -> runMachineT . wye ma k $ f b Stop -> runMachineT $ wye ma stopped ff Await g Refl fg -> return . Await (\b -> wye ma (g b) $ encased v) Y . wye ma fg $ encased v Await f Z ff -> runMachineT ma >>= \u -> case u of Yield a k -> runMachineT . wye k mb . f $ Left a Stop -> runMachineT mb >>= \w -> case w of Yield b k -> runMachineT . wye stopped k . f $ Right b Stop -> runMachineT $ wye stopped stopped ff Await g Refl fg -> return . Await (\b -> wye stopped (g b) $ encased v) Y . wye stopped fg $ encased v Await g Refl fg -> runMachineT mb >>= \w -> case w of Yield b k -> runMachineT . wye (encased u) k . f $ Right b Stop -> return . Await (\a -> wye (g a) stopped $ encased v) X . wye fg stopped $ encased v Await h Refl fh -> return . Await (\c -> case c of Left a -> wye (g a) (encased w) $ encased v Right b -> wye (encased u) (h b) $ encased v) Z . wye fg fh $ encased v -- | Precompose a pipe onto the left input of a wye. addX :: Monad m => ProcessT m a b -> WyeT m b c d -> WyeT m a c d addX p = wye p echo {-# INLINE addX #-} -- | Precompose a pipe onto the right input of a wye. addY :: Monad m => ProcessT m b c -> WyeT m a c d -> WyeT m a b d addY = wye echo {-# INLINE addY #-} -- | Tie off one input of a wye by connecting it to a known source. capX :: Monad m => SourceT m a -> WyeT m a b c -> ProcessT m b c capX s t = process (capped Right) (addX s t) {-# INLINE capX #-} -- | Tie off one input of a wye by connecting it to a known source. capY :: Monad m => SourceT m b -> WyeT m a b c -> ProcessT m a c capY s t = process (capped Left) (addY s t) {-# INLINE capY #-} -- | Tie off both inputs of a wye by connecting them to known sources. capWye :: Monad m => SourceT m a -> SourceT m b -> WyeT m a b c -> SourceT m c capWye a b w = plug $ wye a b w {-# INLINE capWye #-} -- | Natural transformation used by 'capX' and 'capY' capped :: (a -> Either a a) -> Y a a b -> a -> b capped _ X = id capped _ Y = id capped f Z = f {-# INLINE capped #-} ================================================ FILE: src/Data/Machine.hs ================================================ ----------------------------------------------------------------------------- -- | -- Module : Data.Machine -- Copyright : (C) 2012 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : non-portable -- ---------------------------------------------------------------------------- module Data.Machine ( module Data.Machine.Is , module Data.Machine.Moore , module Data.Machine.Mealy , module Data.Machine.Plan , module Data.Machine.Process , module Data.Machine.Source , module Data.Machine.Tee , module Data.Machine.Type , module Data.Machine.Wye ) where import Data.Machine.Is import Data.Machine.Mealy import Data.Machine.Moore import Data.Machine.Plan import Data.Machine.Process import Data.Machine.Source import Data.Machine.Tee import Data.Machine.Type import Data.Machine.Wye ================================================ FILE: tests/doctests.hs ================================================ ----------------------------------------------------------------------------- -- | -- Module : Main (doctests) -- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- This module provides doctests for a project based on the actual versions -- of the packages it was built with. It requires a corresponding Setup.lhs -- to be added to the project ----------------------------------------------------------------------------- module Main where import Build_doctests (flags, pkgs, module_sources) import Data.Foldable (traverse_) import Test.DocTest main :: IO () main = do traverse_ putStrLn args doctest args where args = flags ++ pkgs ++ module_sources