machines 0.6.4 → 0.7.4
raw patch · 24 files changed
Files
- .travis.yml +0/−162
- CHANGELOG.markdown +32/−0
- README.markdown +2/−2
- Setup.lhs +5/−32
- Warning.hs +0/−5
- examples/Examples.hs +16/−12
- examples/machines-examples.cabal +15/−10
- machines.cabal +30/−44
- src/Data/Machine/Fanout.hs +0/−5
- src/Data/Machine/Group.hs +7/−29
- src/Data/Machine/Group/General.hs +216/−0
- src/Data/Machine/Is.hs +1/−1
- src/Data/Machine/Mealy.hs +5/−34
- src/Data/Machine/MealyT.hs +13/−52
- src/Data/Machine/Moore.hs +14/−11
- src/Data/Machine/MooreT.hs +131/−0
- src/Data/Machine/Plan.hs +7/−11
- src/Data/Machine/Process.hs +56/−20
- src/Data/Machine/Runner.hs +0/−7
- src/Data/Machine/Source.hs +4/−1
- src/Data/Machine/Tee.hs +3/−0
- src/Data/Machine/Type.hs +2/−1
- src/Data/Machine/Wye.hs +1/−1
- tests/doctests.hs +0/−25
− .travis.yml
@@ -1,162 +0,0 @@-# This Travis job script has been generated by a script via-#-# runghc make_travis_yml_2.hs '-o' '.travis.yml' '--ghc-head' '--irc-channel=irc.freenode.org#haskell-lens' '--no-no-tests-no-bench' '--no-unconstrained' 'cabal.project'-#-# For more information, see https://github.com/hvr/multi-ghc-travis-#-language: c-sudo: false--git:- submodules: false # whether to recursively clone submodules--notifications:- irc:- channels:- - "irc.freenode.org#haskell-lens"- skip_join: true- template:- - "\x0313machines\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"--cache:- directories:- - $HOME/.cabal/packages- - $HOME/.cabal/store--before_cache:- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log- # remove files that are regenerated by 'cabal update'- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx-- - rm -rfv $HOME/.cabal/packages/head.hackage--matrix:- include:- - compiler: "ghc-8.6.1"- env: GHCHEAD=true- addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.6.1], sources: [hvr-ghc]}}- - compiler: "ghc-8.4.3"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.4.3], sources: [hvr-ghc]}}- - compiler: "ghc-8.2.2"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.2.2], sources: [hvr-ghc]}}- - compiler: "ghc-8.0.2"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.0.2], sources: [hvr-ghc]}}- - compiler: "ghc-7.10.3"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.10.3], sources: [hvr-ghc]}}- - compiler: "ghc-7.8.4"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.8.4], sources: [hvr-ghc]}}- - compiler: "ghc-7.6.3"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.6.3], sources: [hvr-ghc]}}- - compiler: "ghc-7.4.2"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.4.2], sources: [hvr-ghc]}}- - compiler: "ghc-head"- env: GHCHEAD=true- addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-head], sources: [hvr-ghc]}}-- allow_failures:- - compiler: "ghc-head"- - compiler: "ghc-8.6.1"--before_install:- - HC=${CC}- - HCVER=${HC/ghc-/}- - HCPKG=${HC/ghc/ghc-pkg}- - unset CC- - ROOTDIR=$(pwd)- - mkdir -p $HOME/.local/bin- - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH"- - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))- - echo $HCNUMVER--install:- - cabal --version- - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"- - |- if dpkg --compare-versions "${HCVER}" ge "8.0"; then- BENCH=${BENCH---enable-benchmarks}- else- BENCH=${BENCH---disable-benchmarks}- fi- - TEST=${TEST---enable-tests}- - HADDOCK=${HADDOCK-true}- - UNCONSTRAINED=${UNCONSTRAINED-true}- - NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-false}- - GHCHEAD=${GHCHEAD-false}- - travis_retry cabal update -v- - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"- - rm -fv cabal.project cabal.project.local- # Overlay Hackage Package Index for GHC HEAD: https://github.com/hvr/head.hackage- - |- if $GHCHEAD; then- sed -i 's/-- allow-newer: .*/allow-newer: *:base/' ${HOME}/.cabal/config- for pkg in $($HCPKG list --simple-output); do pkg=$(echo $pkg | sed 's/-[^-]*$//'); sed -i "s/allow-newer: /allow-newer: *:$pkg, /" ${HOME}/.cabal/config; done-- echo 'repository head.hackage' >> ${HOME}/.cabal/config- echo ' url: http://head.hackage.haskell.org/' >> ${HOME}/.cabal/config- echo ' secure: True' >> ${HOME}/.cabal/config- echo ' root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> ${HOME}/.cabal/config- echo ' 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> ${HOME}/.cabal/config- echo ' 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config- echo ' key-threshold: 3' >> ${HOME}/.cabal.config-- grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'-- cabal new-update head.hackage -v- fi- - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'- - "printf 'packages: \".\" \"./examples\"\\n' > cabal.project"- - touch cabal.project.local- - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"- - cat cabal.project || true- - cat cabal.project.local || true- - if [ -f "./configure.ac" ]; then- (cd "." && autoreconf -i);- fi- - if [ -f "./examples/configure.ac" ]; then- (cd "./examples" && autoreconf -i);- fi- - rm -f cabal.project.freeze- - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all- - rm -rf .ghc.environment.* "."/dist "./examples"/dist- - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)--# Here starts the actual work to be performed for the package under test;-# any command which exits with a non-zero exit code causes the build to fail.-script:- # test that source-distributions can be generated- - (cd "." && cabal sdist)- - (cd "./examples" && cabal sdist)- - mv "."/dist/machines-*.tar.gz "./examples"/dist/machines-examples-*.tar.gz ${DISTDIR}/- - cd ${DISTDIR} || false- - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;- - "printf 'packages: machines-*/*.cabal machines-examples-*/*.cabal\\n' > cabal.project"- - touch cabal.project.local- - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"- - cat cabal.project || true- - cat cabal.project.local || true-- # build & run tests, build benchmarks- - cabal new-build -w ${HC} ${TEST} ${BENCH} all- - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi-- # cabal check- - (cd machines-* && cabal check)- - (cd machines-examples-* && cabal check)-- # haddock- - rm -rf ./dist-newstyle- - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi--# REGENDATA ["-o",".travis.yml","--ghc-head","--irc-channel=irc.freenode.org#haskell-lens","--no-no-tests-no-bench","--no-unconstrained","cabal.project"]-# EOF
CHANGELOG.markdown view
@@ -1,3 +1,35 @@+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`.
README.markdown view
@@ -1,7 +1,7 @@ machines ======== -[](https://hackage.haskell.org/package/machines) [](http://travis-ci.org/ekmett/machines)+[](https://hackage.haskell.org/package/machines) [](https://github.com/ekmett/machines/actions?query=workflow%3AHaskell-CI) *Ceci n'est pas une pipe* @@ -23,7 +23,7 @@ A port of this design to scala is available from runarorama/scala-machines -Runar's slides are also available from https://dl.dropbox.com/u/4588997/Machines.pdf+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
Setup.lhs view
@@ -1,34 +1,7 @@-\begin{code}-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -Wall #-}-module Main (main) where--#ifndef MIN_VERSION_cabal_doctest-#define MIN_VERSION_cabal_doctest(x,y,z) 0-#endif--#if MIN_VERSION_cabal_doctest(1,0,0)--import Distribution.Extra.Doctest ( defaultMainWithDoctests )-main :: IO ()-main = defaultMainWithDoctests "doctests"--#else--#ifdef MIN_VERSION_Cabal--- If the macro is defined, we have new cabal-install,--- but for some reason we don't have cabal-doctest in package-db------ Probably we are running cabal sdist, when otherwise using new-build--- workflow-import Warning ()-#endif--import Distribution.Simple--main :: IO ()-main = defaultMain+#!/usr/bin/runhaskell+> module Main (main) where -#endif+> import Distribution.Simple -\end{code}+> main :: IO ()+> main = defaultMain
− Warning.hs
@@ -1,5 +0,0 @@-module Warning- {-# WARNING ["You are configuring this package without cabal-doctest installed.",- "The doctests test-suite will not work as a result.",- "To fix this, install cabal-doctest before configuring."] #-}- () where
examples/Examples.hs view
@@ -1,15 +1,11 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} module Examples where -#if !(MIN_VERSION_base(4,8,0))-import Control.Applicative-#endif import Control.Exception import Control.Monad.Trans import Data.Machine-import Data.Machine.Group+import Data.Machine.Group.General import System.IO -- this slurp slurps until an eof exception is raised.@@ -31,11 +27,15 @@ -- | bad slurping machine crashes :: Handle -> MachineT IO k String-crashes h = repeatedly $ lift (hGetLine h) >>= yield+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 = lift (slurpHandle h) >>= yield+slurpHandlePlan h = do+ x <- lift (slurpHandle h)+ yield x {- - but we want a plan that will yield one line at a time@@ -54,12 +54,16 @@ -- | lineCount counts the number of lines in a file lineCount :: FilePath -> IO Int-lineCount path = head <$> (runT src) where+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 = head <$> runT src+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)@@ -68,7 +72,7 @@ -- | 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_ yield (words s) }+wordsProc = repeatedly $ do { s <- await; mapM_ (\x -> yield x) (words s) } -- | A Plan to print all input. printPlan :: PlanT (Is String) () IO ()@@ -96,11 +100,11 @@ uniq :: Bool uniq = run (supply xs uniqMachine) == [1,2,3] where- -- | Unix's "uniq" command using groupingOn+ -- | 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+ uniqMachine = groupingOn_ (==) final xs :: [Int] xs = [1,2,2,3,3,3]
examples/machines-examples.cabal view
@@ -16,14 +16,19 @@ @machines@ examples build-type: Simple-tested-with: GHC == 7.4.2- , GHC == 7.6.3- , GHC == 7.8.4- , GHC == 7.10.3- , GHC == 8.0.2+tested-with: GHC == 8.0.2 , GHC == 8.2.2- , GHC == 8.4.3- , GHC == 8.6.1+ , 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@@ -31,9 +36,9 @@ library build-depends:- base == 4.*,- machines == 0.6.*,- mtl >= 2 && < 2.3+ base >= 4.9 && < 5,+ machines == 0.7.*,+ mtl >= 2 && < 2.4 exposed-modules: Examples
machines.cabal view
@@ -1,6 +1,6 @@ name: machines category: Control, Enumerator-version: 0.6.4+version: 0.7.4 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE@@ -15,52 +15,49 @@ Networked stream transducers . Rúnar Bjarnason's talk on machines can be downloaded from:- <https://dl.dropbox.com/u/4588997/Machines.pdf>-build-type: Custom-tested-with: GHC == 7.4.2- , GHC == 7.6.3- , GHC == 7.8.4- , GHC == 7.10.3- , GHC == 8.0.2+ <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.3- , GHC == 8.6.1+ , 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:- .travis.yml .gitignore .vim.custom config README.markdown CHANGELOG.markdown- Warning.hs examples/LICENSE examples/machines-examples.cabal examples/*.hs source-repository head type: git- location: git://github.com/ekmett/machines.git--custom-setup- setup-depends:- base >= 4 && < 5,- Cabal,- cabal-doctest >= 1 && < 1.1+ location: https://github.com/ekmett/machines.git library build-depends: adjunctions >= 4.2 && < 5,- base >= 4.5 && < 5,+ base >= 4.9 && < 5, comonad >= 3 && < 6,- containers >= 0.3 && < 0.7,+ containers >= 0.3 && < 0.9, distributive < 0.7, pointed >= 3 && < 6,- profunctors >= 3 && < 6,- semigroupoids >= 5 && < 6,+ profunctors >= 4 && < 6,+ semigroupoids >= 5 && < 7, semigroups >= 0.8.3 && < 1,- transformers >= 0.3 && < 0.6,+ transformers >= 0.3 && < 0.7, transformers-compat >= 0.3,- mtl >= 2 && < 2.3,+ mtl >= 2.2 && < 2.4, void >= 0.6.1 && < 1 exposed-modules:@@ -71,6 +68,7 @@ Data.Machine.Mealy Data.Machine.MealyT Data.Machine.Moore+ Data.Machine.MooreT Data.Machine.Process Data.Machine.Plan Data.Machine.Runner@@ -80,6 +78,7 @@ Data.Machine.Type Data.Machine.Wye Data.Machine.Group+ Data.Machine.Group.General Data.Machine.Pipe default-language: Haskell2010@@ -90,28 +89,15 @@ Rank2Types UndecidableInstances - ghc-options: -Wall -fwarn-tabs -O2 -fdicts-cheap -funbox-strict-fields+ 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- if impl(ghc >= 8.0)- ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances- else- build-depends: fail == 4.9.*+ ghc-options: -Wcompat -Wnoncanonical-monad-instances+ if !impl(ghc >= 8.8)+ ghc-options: -Wnoncanonical-monadfail-instances hs-source-dirs: src --- Verify the results of the examples-test-suite doctests- type: exitcode-stdio-1.0- main-is: doctests.hs- default-language: Haskell2010- build-depends:- base == 4.*,- doctest >= 0.11.1 && < 0.17,- machines- ghc-options: -Wall -threaded- hs-source-dirs: tests- benchmark benchmarks default-language: Haskell2010 type: exitcode-stdio-1.0@@ -122,8 +108,8 @@ build-depends: base >= 4.9 && < 5, conduit >= 1.3 && < 1.4,- criterion >= 0.6 && < 1.6,+ criterion >= 0.6 && < 1.7, machines,- mtl >= 2 && < 2.3,+ mtl >= 2 && < 2.4, pipes >= 4 && < 4.4, streaming >= 0.1.4 && < 0.3
src/Data/Machine/Fanout.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -9,10 +8,6 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.Machine import Data.Semigroup (Semigroup (sconcat))-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid (Monoid (..))-import Data.Traversable (traverse)-#endif continue :: ([b] -> r) -> [(a -> b, b)] -> Step (Is a) o r continue _ [] = Stop
src/Data/Machine/Group.hs view
@@ -7,13 +7,14 @@ , awaitUntil )where import Data.Machine+import qualified Data.Machine.Group.General as Group -isLeft :: Either a b -> Bool-isLeft = either (const True) (const False)+-- $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 f m = taggedBy f ~> partitioning m+groupingOn = Group.groupingOn_ -- | Mark a transition point between two groups as a function of adjacent elements. -- Examples@@ -21,39 +22,16 @@ -- >>> 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 f = construct $ await >>= go- where go x = do- yield (Right x)- y <- await- if not (f x y) then yield (Left ()) >> go y else go y+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 s = go s where- go m = MachineT $ runMachineT m >>= \v -> case v of- -- Machine stops (possibly before inputs)- Stop -> runMachineT $ awaitUntil isLeft (const $ go s)-- -- 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)- -- NOTE: if Left () happens with no more input, this will be wrong-ish(?)- -- Meaning of "Left ()" is "stop old machine and immediately start new one."- -- That means input [Right 1, Left ()] is different to [Right 1]- g (Left ()) = starve r $ go s-+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 f cont = encased $ Await g Refl stopped- where g a = if f a then cont a else awaitUntil f cont+awaitUntil = Group.awaitUntil
+ src/Data/Machine/Group/General.hs view
@@ -0,0 +1,216 @@+{-# 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
src/Data/Machine/Is.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GADTs, TypeFamilies #-}+{-# LANGUAGE GADTs, TypeFamilies, TypeOperators #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Machine.Is
src/Data/Machine/Mealy.hs view
@@ -2,9 +2,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} -#ifndef MIN_VERSION_profunctors-#define MIN_VERSION_profunctors(x,y,z) 0-#endif ----------------------------------------------------------------------------- -- | -- Module : Data.Machine.Mealy@@ -26,9 +23,6 @@ import Control.Applicative import Control.Arrow import Control.Category-import Control.Monad.Fix-import Control.Monad.Reader.Class-import Control.Monad.Zip import Data.Distributive import Data.Functor.Extend import Data.Functor.Rep as Functor@@ -46,7 +40,7 @@ import Prelude hiding ((.),id) -- $setup--- >>> import Data.Machine.Source+-- >>> import Data.Machine -- | 'Mealy' machines --@@ -93,16 +87,6 @@ (b, t) -> (b, go t) {-# INLINE unfoldMealy #-} --- | slow diagonalization-instance Monad (Mealy a) where- return = pure- {-# INLINE return #-}- m >>= f = Mealy $ \a -> case runMealy m a of- (b, m') -> (fst (runMealy (f b) a), m' >>= f)- {-# INLINE (>>=) #-}- (>>) = (*>)- {-# INLINE (>>) #-}- instance Profunctor Mealy where rmap = fmap {-# INLINE rmap #-}@@ -110,15 +94,13 @@ go (Mealy m) = Mealy $ \a -> case m (f a) of (b, n) -> (b, go n) {-# INLINE lmap #-}-#if MIN_VERSION_profunctors(3,1,1) dimap f g = go where go (Mealy m) = Mealy $ \a -> case m (f a) of (b, n) -> (g b, go n) {-# INLINE dimap #-}-#endif instance Automaton Mealy where- auto = construct . go where+ auto x = construct $ go x where go (Mealy f) = await >>= \a -> case f a of (b, m) -> do yield b@@ -157,14 +139,12 @@ Right b -> case runMealy n b of (d, n') -> (d, m ||| n') -#if MIN_VERSION_profunctors(3,2,0) instance Strong Mealy where first' = first instance Choice Mealy where left' = left right' = right-#endif -- | Fast forward a mealy machine forward driveMealy :: Mealy a b -> Seq a -> a -> (b, Mealy a b)@@ -212,23 +192,14 @@ cotabulate f0 = Mealy $ \a -> go [a] f0 where go as f = (f (NonEmpty.fromList (Prelude.reverse as)), Mealy $ \b -> go (b:as) f) -instance MonadFix (Mealy a) where- mfix = mfixRep--instance MonadZip (Mealy a) where- mzipWith = mzipWithRep- munzip m = (fmap fst m, fmap snd m)--instance MonadReader (NonEmpty a) (Mealy a) where- ask = askRep- local = localRep- instance Closed Mealy where- closed m = cotabulate $ \fs x -> cosieve m (fmap ($x) fs)+ 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
src/Data/Machine/MealyT.hs view
@@ -1,9 +1,8 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- -- |--- Module : Data.Machine.Mealy+-- Module : Data.Machine.MealyT -- License : BSD-style (see the file LICENSE) -- -- <http://en.wikipedia.org/wiki/Mealy_machine>@@ -18,21 +17,20 @@ , upgrade , scanMealyT , scanMealyTM- , embedMealyT ) where import Data.Machine import Control.Arrow import Control.Applicative-import Data.Pointed 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 monadic effects+-- | '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@@ -49,33 +47,15 @@ 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 Monad m => Monad (MealyT m a) where-#if !MIN_VERSION_base(4,8,0)- -- pre-AMP- {-# INLINE return #-}- return b = r where r = MealyT (const (return (b, r))) -- Stolen from Pointed-#endif-- MealyT g >>= f = MealyT $ \a ->- do (b, MealyT _h) <- g a- runMealyT (f b) a---- | Profunctor Example:------ >>> embedMealyT (dimap (+21) (+1) (arr (+1))) [1,2,3 :: Int]--- [24,25,26]--- 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 #-}-#if MIN_VERSION_profunctors(3,1,1) dimap f g = go where go (MealyT m) = MealyT $ \a -> fmap (\(b,n) -> (g b, go n)) (m (f a)) {-# INLINE dimap #-}-#endif instance Monad m => C.Category (MealyT m) where {-# INLINE id #-}@@ -98,13 +78,11 @@ arrM :: Functor m => (a -> m b) -> MealyT m a b arrM f = r where r = MealyT $ \a -> fmap (,r) (f a) -upgrade :: Monad m => Mealy a b -> MealyT m a b-upgrade (Mealy f) = MealyT $ \a ->- do let (r, g) = f a- return (r, upgrade g)+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 :: Monad m => (a -> b -> a) -> a -> MealyT m b a-scanMealyT f a = MealyT (\b -> return (a, scanMealyT f (f a b)))+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@@ -118,30 +96,13 @@ yield b go m --- | embedMealyT Example:------ >>> embedMealyT (arr (+1)) [1,2,3]--- [2,3,4]----embedMealyT :: Monad m => MealyT m a b -> [a] -> m [b]-embedMealyT _ [] = return []-embedMealyT sf (a:as) = do- (b, sf') <- runMealyT sf a- bs <- embedMealyT sf' as- return (b:bs)- instance AutomatonM MealyT where autoT = autoMealyTImpl -instance (Semigroup b, Monad m) => Semigroup (MealyT m a b) where- f <> g = MealyT $ \x -> do- (fx, f') <- runMealyT f x- (gx, g') <- runMealyT g x- return (fx <> gx, f' <> g')+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 (Monoid b, Monad m) => Monoid (MealyT m a b) where- mempty = MealyT $ \_ -> return mempty- mappend f g = MealyT $ \x -> do- (fx, f') <- runMealyT f x- (gx, g') <- runMealyT g x- return (fx `mappend` gx, f' `mappend` g')+instance (Semigroup b, Monoid b, Applicative m) => Monoid (MealyT m a b) where+ mempty = MealyT $ \_ -> pure mempty+ mappend = (<>)
src/Data/Machine/Moore.hs view
@@ -2,9 +2,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} -#ifndef MIN_VERSION_profunctors-#define MIN_VERSION_profunctors(x,y,z) 0-#endif ----------------------------------------------------------------------------- -- | -- Module : Data.Machine.Moore@@ -34,7 +31,7 @@ import Data.Machine.Plan import Data.Machine.Type import Data.Machine.Process-import Data.Monoid+import Data.Semigroup import Data.Pointed import Data.Profunctor.Closed import Data.Profunctor@@ -48,7 +45,7 @@ -- | Accumulate the input as a sequence. logMoore :: Monoid m => Moore m m logMoore = h mempty where- h m = Moore m (\a -> h (m <> a))+ h m = Moore m (\a -> h (m `mappend` a)) {-# INLINE logMoore #-} -- | Construct a Moore machine from a state valuation and transition function@@ -59,7 +56,7 @@ {-# INLINE unfoldMoore #-} instance Automaton Moore where- auto = construct . go where+ auto x = construct $ go x where go (Moore b f) = do yield b await >>= go . f@@ -77,11 +74,9 @@ lmap f = go where go (Moore b g) = Moore b (go . g . f) {-# INLINE lmap #-}-#if MIN_VERSION_profunctors(3,1,1) dimap f g = go where go (Moore b h) = Moore (g b) (go . h . f) {-# INLINE dimap #-}-#endif instance Applicative (Moore a) where pure a = r where r = Moore a (const r)@@ -139,8 +134,7 @@ instance Profunctor.Corepresentable Moore where type Corep Moore = []- cotabulate f0 = go (f0 . reverse) where- go f = Moore (f []) $ \a -> go (f.(a:))+ cotabulate f = Moore (f []) $ \a -> cotabulate (f.(a:)) instance MonadFix (Moore a) where mfix = mfixRep@@ -154,4 +148,13 @@ local = localRep instance Closed Moore where- closed m = cotabulate $ \fs x -> cosieve m (fmap ($x) fs)+ 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
+ src/Data/Machine/MooreT.hs view
@@ -0,0 +1,131 @@+{-# 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
src/Data/Machine/Plan.hs view
@@ -3,9 +3,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-}-#ifndef MIN_VERSION_mtl-#define MIN_VERSION_mtl(x,y,z) 0-#endif ----------------------------------------------------------------------------- -- | -- Module : Data.Machine.Plan@@ -118,7 +115,9 @@ {-# 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)@@ -142,22 +141,16 @@ {-# INLINE get #-} put = lift . put {-# INLINE put #-}-#if MIN_VERSION_mtl(2,1,0) state f = PlanT $ \kp _ _ _ -> state f >>= kp {-# INLINE state #-}-#endif instance MonadReader e m => MonadReader e (PlanT k o m) where ask = lift ask-#if MIN_VERSION_mtl(2,1,0) reader = lift . reader-#endif 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-#if MIN_VERSION_mtl(2,1,0) writer = lift . writer-#endif tell = lift . tell listen m = PlanT $ \kp ke kr kf -> runPlanT m ((kp =<<) . listen . return) ke kr kf@@ -174,7 +167,7 @@ -- | Like yield, except stops if there is no value to yield. maybeYield :: Maybe o -> Plan k o ()-maybeYield = maybe stop yield+maybeYield m = maybe stop (\x -> yield x) m -- | Wait for input. --@@ -198,4 +191,7 @@ -- | 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 (lift f >>= maybeYield); exhaust f+exhaust f = do+ x <- lift f+ maybeYield x+ exhaust f
src/Data/Machine/Process.hs view
@@ -1,11 +1,7 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-}-#ifndef MIN_VERSION_base-#define MIN_VERSION_base(x,y,z) 0-#endif ----------------------------------------------------------------------------- -- | -- Module : Data.Machine.Process@@ -35,6 +31,7 @@ , taking , droppingWhile , takingWhile+ , takingJusts , buffered , flattened , fold@@ -67,15 +64,11 @@ import Data.Machine.Type import Data.Monoid import Data.Void-import Prelude-#if !(MIN_VERSION_base(4,8,0))- hiding (id, (.), foldr)-#else- hiding (id, (.))-#endif+import Prelude hiding (id, (.)) -- $setup--- >>> import Data.Machine.Source+-- >>> import Data.Machine+-- >>> import Data.Monoid (Sum (..)) infixr 9 <~ infixl 9 ~>@@ -112,6 +105,7 @@ -- | 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@@ -133,11 +127,12 @@ -- | 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 = before echo . traverse_ yield+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@@ -163,6 +158,7 @@ -- | 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 -- @@@ -173,8 +169,8 @@ -- [4,5] -- dropping :: Int -> Process a a-dropping =- loop+dropping i =+ loop i where loop cnt | cnt <= 0@@ -186,6 +182,7 @@ -- | 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 -- @@@ -196,8 +193,8 @@ -- [1,2,3] -- taking :: Int -> Process a a-taking =- loop+taking i =+ loop i where loop cnt | cnt <= 0@@ -209,6 +206,7 @@ -- | 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@@ -229,9 +227,34 @@ 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@@ -258,6 +281,7 @@ -- 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@@ -377,12 +401,14 @@ -- 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@@ -415,6 +441,7 @@ -- '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@@ -459,11 +486,13 @@ -- 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@@ -481,18 +510,19 @@ -- [5] -- fold :: Category k => (a -> b -> a) -> a -> Machine (k b) a-fold func =+fold func x = let step t = t `seq` encased $ Await (step . func t) id (encased $ Yield t stopped)- in step+ 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@@ -519,6 +549,7 @@ -- individually. -- -- This can be constructed from a plan with+-- -- @ -- asParts :: Foldable f => Process (f a) a -- asParts = repeatedly $ await >>= traverse_ yield@@ -566,6 +597,7 @@ -- | 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@@ -591,6 +623,7 @@ -- 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@@ -619,6 +652,7 @@ -- 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@@ -636,10 +670,10 @@ -- [-1] -- finalOr :: Category k => a -> Machine (k a) a-finalOr =+finalOr y = let step x = encased (Await step id (emit x)) emit x = encased (Yield x stopped)- in step+ in step y {-# INLINABLE finalOr #-} -- |@@ -672,6 +706,7 @@ -- 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@@ -697,6 +732,7 @@ -- 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
src/Data/Machine/Runner.hs view
@@ -1,8 +1,4 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-#ifndef MIN_VERSION_base-#define MIN_VERSION_base(x,y,z) 0-#endif module Data.Machine.Runner ( foldrT , foldlT@@ -16,9 +12,6 @@ import Data.Machine.Type import Control.Monad (liftM)-#if !MIN_VERSION_base (4,8,0)-import Data.Monoid (Monoid (..))-#endif -- | Right fold over a stream. This will be lazy if the underlying -- monad is.
src/Data/Machine/Source.hs view
@@ -34,6 +34,9 @@ import Data.Machine.Process import Prelude (Enum, Int, Maybe, Monad, ($), (>>=), return) +-- $setup+-- >>> import Data.Machine+ ------------------------------------------------------------------------------- -- Source -------------------------------------------------------------------------------@@ -95,7 +98,7 @@ -- [1,2] -- source :: Foldable f => f b -> Source b-source = foldr go stopped+source f = foldr go stopped f where go x m = encased $ Yield x m
src/Data/Machine/Tee.hs view
@@ -30,6 +30,9 @@ import Data.Machine.Source import Prelude hiding ((.), id, zipWith) +-- $setup+-- >>> import Data.Machine+ ------------------------------------------------------------------------------- -- Tees -------------------------------------------------------------------------------
src/Data/Machine/Type.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- |@@ -109,7 +110,7 @@ f' Stop = Stop instance Monad m => Pointed (MachineT m k) where- point = repeatedly . yield+ point x = repeatedly $ yield x instance Monad m => Semigroup (MachineT m k o) where a <> b = stepMachine a $ \step -> case step of
src/Data/Machine/Wye.hs view
@@ -102,7 +102,7 @@ -- | 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 = plug . wye a b+capWye a b w = plug $ wye a b w {-# INLINE capWye #-} -- | Natural transformation used by 'capX' and 'capY'
− tests/doctests.hs
@@ -1,25 +0,0 @@--------------------------------------------------------------------------------- |--- 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