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 <<EOF
remote-build-reporting: anonymous
write-ghc-environment-files: never
remote-repo-cache: $CABAL_DIR/packages
logs-dir: $CABAL_DIR/logs
world-file: $CABAL_DIR/world
extra-prog-path: $CABAL_DIR/bin
symlink-bindir: $CABAL_DIR/bin
installdir: $CABAL_DIR/bin
build-summary: $CABAL_DIR/logs/build.log
store-dir: $CABAL_DIR/store
install-dirs user
prefix: $CABAL_DIR
repository hackage.haskell.org
url: http://hackage.haskell.org/
EOF
cat >> $CABAL_CONFIG <<EOF
program-default-options
ghc-options: $GHCJOBS +RTS -M3G -RTS
EOF
cat $CABAL_CONFIG
- name: versions
run: |
$HC --version || true
$HC --print-project-git-commit-id || true
$CABAL --version || true
- name: update cabal index
run: |
$CABAL v2-update -v
- name: install cabal-plan
run: |
mkdir -p $HOME/.cabal/bin
curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.7.3.0/cabal-plan-0.7.3.0-x86_64-linux.xz > 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 <<EOF
EOF
$HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(machines|machines-examples)$/; }' >> 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 <F2> :exec ":!hasktags -x -c --ignore src"<CR><CR>
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
========
[](https://hackage.haskell.org/package/machines) [](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 <ekmett@gmail.com>
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 <ekmett@gmail.com>
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:
<http://web.archive.org/web/20161029161813/https://dl.dropboxusercontent.com/u/4588997/Machines.pdf>
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 <ekmett@gmail.com>
-- 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 <ekmett@gmail.com>
-- Stability : provisional
-- Portability : portable
--
-- <http://en.wikipedia.org/wiki/Mealy_machine>
----------------------------------------------------------------------------
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)
--
-- <http://en.wikipedia.org/wiki/Mealy_machine>
-- <https://github.com/ivanperez-keera/dunai/blob/develop/src/Data/MonadicStreamFunction/Core.hs#L35>
-- <https://hackage.haskell.org/package/auto-0.4.3.0/docs/Control-Auto.html>
-- <https://hackage.haskell.org/package/varying-0.6.0.0/docs/Control-Varying-Core.html>
----------------------------------------------------------------------------
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 <ekmett@gmail.com>
-- Stability : provisional
-- Portability : portable
--
-- <http://en.wikipedia.org/wiki/Moore_machine>
----------------------------------------------------------------------------
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 <ekmett@gmail.com>
-- Stability : provisional
-- Portability : portable
--
-- <http://en.wikipedia.org/wiki/Moore_machine>
----------------------------------------------------------------------------
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 <yo.eight@gmail.com>
-- 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 <ekmett@gmail.com>
-- 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 <ekmett@gmail.com>
-- 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 <ekmett@gmail.com>
-- 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 <ekmett@gmail.com>
-- 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 <ekmett@gmail.com>
-- 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 <ekmett@gmail.com>
-- 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 <ekmett@gmail.com>
-- 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 <ekmett@gmail.com>
-- 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 <ekmett@gmail.com>
-- 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
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
Condensed preview — 35 files, each showing path, character count, and a content snippet. Download the .json file or copy for the full structured content (143K chars).
[
{
"path": ".github/workflows/haskell-ci.yml",
"chars": 10913,
"preview": "# This GitHub workflow config has been generated by a script via\n#\n# haskell-ci 'github' 'cabal.project'\n#\n# To regene"
},
{
"path": ".gitignore",
"chars": 280,
"preview": "dist\ndist-newstyle\ndocs\nwiki\nTAGS\ntags\nwip\n.DS_Store\n.*.swp\n.*.swo\n*.o\n*.hi\n*~\n*#\n.stack-work/\ncabal-dev\n*.chi\n*.chs.h\n*"
},
{
"path": ".vim.custom",
"chars": 541,
"preview": "\" Add the following to your .vimrc to automatically load this on startup\n\" if filereadable(\".vim.custom\")\n\" so .vim."
},
{
"path": "CHANGELOG.markdown",
"chars": 3321,
"preview": "0.7.4 [2025.03.03]\n------------------\n* Drop support for pre-8.0 versions of GHC.\n\n0.7.3 [2022.05.18]\n------------------"
},
{
"path": "LICENSE",
"chars": 1488,
"preview": "Copyright 2012-2015 Edward Kmett, Runar Bjarnason, Paul Chiusano\n\nAll rights reserved.\n\nRedistribution and use in source"
},
{
"path": "README.markdown",
"chars": 1682,
"preview": "machines\n========\n\n[](https://hackage.haskell.org/package/machi"
},
{
"path": "Setup.lhs",
"chars": 117,
"preview": "#!/usr/bin/runhaskell\n> module Main (main) where\n\n> import Distribution.Simple\n\n> main :: IO ()\n> main = defaultMain\n"
},
{
"path": "benchmarks/Benchmarks.hs",
"chars": 12824,
"preview": "module Main (main) where\n\nimport Control.Applicative\nimport Data.Function ((&))\nimport Control.Monad (void)\nimport Contr"
},
{
"path": "cabal.haskell-ci",
"chars": 175,
"preview": "no-tests-no-benchmarks: False\nunconstrained: False\n-- irc-channels: irc.freenode.org#haskell-lens\nirc"
},
{
"path": "cabal.project",
"chars": 33,
"preview": "packages: .\n ./examples\n"
},
{
"path": "config",
"chars": 645,
"preview": "-- This provides a custom ~/.cabal/config file for use when hackage is down that should work on unix\n--\n-- This is parti"
},
{
"path": "examples/Examples.hs",
"chars": 4035,
"preview": "{-# LANGUAGE RankNTypes #-}\n\nmodule Examples where\n\nimport Control.Exception\nimport Control.Monad.Trans\nimport Data.Mach"
},
{
"path": "examples/LICENSE",
"chars": 1451,
"preview": "Copyright 2014 Edward Kmett\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmo"
},
{
"path": "examples/machines-examples.cabal",
"chars": 1235,
"preview": "name: machines-examples\ncategory: Control, Enumerator\nversion: 0.1\nlicense: BSD3\ncabal-version"
},
{
"path": "machines.cabal",
"chars": 3205,
"preview": "name: machines\ncategory: Control, Enumerator\nversion: 0.7.4\nlicense: BSD3\ncabal-version: >= 1."
},
{
"path": "src/Data/Machine/Fanout.hs",
"chars": 2633,
"preview": "{-# LANGUAGE GADTs #-}\n{-# LANGUAGE ScopedTypeVariables #-}\n\n-- | Provide a notion of fanout wherein a single input is p"
},
{
"path": "src/Data/Machine/Group/General.hs",
"chars": 7795,
"preview": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE GADTs #-}\n\n-- | Split up input streams into groups with separator values and process"
},
{
"path": "src/Data/Machine/Group.hs",
"chars": 1194,
"preview": "{-# LANGUAGE GADTs #-}\nmodule Data.Machine.Group\n ( groupingOn\n , taggedBy\n , partitioning\n , starve\n , awaitUntil\n"
},
{
"path": "src/Data/Machine/Is.hs",
"chars": 1290,
"preview": "{-# LANGUAGE GADTs, TypeFamilies, TypeOperators #-}\n--------------------------------------------------------------------"
},
{
"path": "src/Data/Machine/Lift.hs",
"chars": 1509,
"preview": "-- | Utilities for working with machines that run in transformed monads,\n-- inspired by @Pipes.Lift@.\nmodule Data.Machin"
},
{
"path": "src/Data/Machine/Mealy.hs",
"chars": 5778,
"preview": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE TypeFamilies #-}\n{-# LANGUAGE MultiParamTypeClasses #-}\n\n-----------------------------"
},
{
"path": "src/Data/Machine/MealyT.hs",
"chars": 3497,
"preview": "{-# LANGUAGE TupleSections #-}\n\n-----------------------------------------------------------------------------\n-- |\n-- Mo"
},
{
"path": "src/Data/Machine/Moore.hs",
"chars": 4262,
"preview": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE TypeFamilies #-}\n{-# LANGUAGE MultiParamTypeClasses #-}\n\n-----------------------------"
},
{
"path": "src/Data/Machine/MooreT.hs",
"chars": 4105,
"preview": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE RankNTypes #-}\n\n---------------------------------------------------------------"
},
{
"path": "src/Data/Machine/Pipe.hs",
"chars": 4939,
"preview": "{-# LANGUAGE GADTs #-}\n{-# LANGUAGE Rank2Types #-}\n----------------------------------------------------------------"
},
{
"path": "src/Data/Machine/Plan.hs",
"chars": 6012,
"preview": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE RankNTypes #-}\n{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE FlexibleInstances #"
},
{
"path": "src/Data/Machine/Process.hs",
"chars": 20293,
"preview": "{-# LANGUAGE GADTs #-}\n{-# LANGUAGE Rank2Types #-}\n{-# LANGUAGE FlexibleInstances #-}\n{-# LANGUAGE ScopedTypeVariables #"
},
{
"path": "src/Data/Machine/Runner.hs",
"chars": 1932,
"preview": "{-# LANGUAGE BangPatterns #-}\nmodule Data.Machine.Runner\n ( foldrT\n , foldlT\n , foldMapT\n , foldT\n , runT"
},
{
"path": "src/Data/Machine/Source.hs",
"chars": 4254,
"preview": "{-# LANGUAGE Rank2Types #-}\n{-# LANGUAGE FlexibleInstances #-}\n---------------------------------------------------------"
},
{
"path": "src/Data/Machine/Stack.hs",
"chars": 1935,
"preview": "{-# LANGUAGE GADTs #-}\n{-# LANGUAGE Rank2Types #-}\n---------------------------------------------------------------------"
},
{
"path": "src/Data/Machine/Tee.hs",
"chars": 5185,
"preview": "{-# LANGUAGE GADTs #-}\n{-# LANGUAGE Rank2Types #-}\n---------------------------------------------------------------------"
},
{
"path": "src/Data/Machine/Type.hs",
"chars": 11616,
"preview": "{-# LANGUAGE GADTs #-}\n{-# LANGUAGE Rank2Types #-}\n{-# LANGUAGE TypeOperators #-}\n{-# LANGUAGE FlexibleInstances #-}\n---"
},
{
"path": "src/Data/Machine/Wye.hs",
"chars": 4776,
"preview": "{-# LANGUAGE GADTs #-}\n{-# LANGUAGE Rank2Types #-}\n---------------------------------------------------------------------"
},
{
"path": "src/Data/Machine.hs",
"chars": 922,
"preview": "-----------------------------------------------------------------------------\n-- |\n-- Module : Data.Machine\n-- Cop"
},
{
"path": "tests/doctests.hs",
"chars": 826,
"preview": "-----------------------------------------------------------------------------\n-- |\n-- Module : Main (doctests)\n-- "
}
]
About this extraction
This page contains the full source code of the ekmett/machines GitHub repository, extracted and formatted as plain text for AI agents and large language models (LLMs). The extraction includes 35 files (133.5 KB), approximately 42.2k tokens. Use this with OpenClaw, Claude, ChatGPT, Cursor, Windsurf, or any other AI tool that accepts text input. You can copy the full output to your clipboard or download it as a .txt file.
Extracted by GitExtract — free GitHub repo to text converter for AI. Built by Nikandr Surkov.