machines 0.5.1 → 0.7.4
raw patch · 30 files changed
Files
- .ghci +0/−1
- .gitignore +19/−1
- .travis.yml +0/−8
- CHANGELOG.markdown +77/−1
- LICENSE +1/−1
- README.markdown +2/−2
- Setup.lhs +4/−41
- benchmarks/Benchmarks.hs +243/−8
- examples/Examples.hs +20/−13
- examples/machines-examples.cabal +22/−5
- machines.cabal +47/−36
- src/Data/Machine/Fanout.hs +41/−52
- src/Data/Machine/Group.hs +12/−39
- src/Data/Machine/Group/General.hs +216/−0
- src/Data/Machine/Is.hs +7/−3
- src/Data/Machine/Lift.hs +36/−0
- src/Data/Machine/Mealy.hs +65/−18
- src/Data/Machine/MealyT.hs +108/−0
- src/Data/Machine/Moore.hs +59/−10
- src/Data/Machine/MooreT.hs +131/−0
- src/Data/Machine/Pipe.hs +7/−2
- src/Data/Machine/Plan.hs +22/−16
- src/Data/Machine/Process.hs +538/−66
- src/Data/Machine/Runner.hs +71/−0
- src/Data/Machine/Source.hs +94/−10
- src/Data/Machine/Stack.hs +4/−2
- src/Data/Machine/Tee.hs +64/−4
- src/Data/Machine/Type.hs +56/−10
- src/Data/Machine/Wye.hs +9/−4
- tests/doctests.hs +0/−31
− .ghci
@@ -1,1 +0,0 @@-:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h
.gitignore view
@@ -1,4 +1,5 @@ dist+dist-newstyle docs wiki TAGS@@ -11,4 +12,21 @@ *.hi *~ *#-.cabal-sandbox+.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.*
− .travis.yml
@@ -1,8 +0,0 @@-language: haskell-notifications:- irc:- channels:- - "irc.freenode.org#haskell-lens"- skip_join: true- template:- - "\x0313machines\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"
CHANGELOG.markdown view
@@ -1,3 +1,79 @@+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@@ -28,7 +104,7 @@ 0.2.4 ------* Added `asPats`, `sinkPart_`, `autoM`, and `fitM`+* Added `asParts`, `sinkPart_`, `autoM`, and `fitM` 0.2.1 -----
LICENSE view
@@ -1,4 +1,4 @@-Copyright 2012 Edward Kmett, Runar Bjarnason, Paul Chiusano+Copyright 2012-2015 Edward Kmett, Runar Bjarnason, Paul Chiusano All rights reserved.
README.markdown view
@@ -1,7 +1,7 @@ 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,44 +1,7 @@ #!/usr/bin/runhaskell-\begin{code}-{-# OPTIONS_GHC -Wall #-}-module Main (main) where--import Data.List ( nub )-import Data.Version ( showVersion )-import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName )-import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )-import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )-import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose )-import Distribution.Simple.BuildPaths ( autogenModulesDir )-import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag )-import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )-import Distribution.Verbosity ( Verbosity )-import System.FilePath ( (</>) )--main :: IO ()-main = defaultMainWithHooks simpleUserHooks- { buildHook = \pkg lbi hooks flags -> do- generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi- buildHook simpleUserHooks pkg lbi hooks flags- }--generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()-generateBuildModule verbosity pkg lbi = do- let dir = autogenModulesDir lbi- createDirectoryIfMissingVerbose verbosity True dir- withLibLBI pkg lbi $ \_ libcfg -> do- withTestLBI pkg lbi $ \suite suitecfg -> do- rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines- [ "module Build_" ++ testName suite ++ " where"- , "deps :: [String]"- , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))- ]- where- formatdeps = map (formatone . snd)- formatone p = case packageName p of- PackageName n -> n ++ "-" ++ showVersion (packageVersion p)+> module Main (main) where -testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]-testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys+> import Distribution.Simple -\end{code}+> main :: IO ()+> main = defaultMain
benchmarks/Benchmarks.hs view
@@ -1,14 +1,19 @@ 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@@ -16,55 +21,285 @@ 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 -drainC :: C.Conduit Int Identity a -> ()-drainC c = runIdentity $ (sourceC C.$= c) C.$$ C.sinkNull+drainPIO :: P.Proxy () Int () a IO () -> IO ()+drainPIO p = P.runEffect $ sourceP P.>-> p P.>-> P.mapM_ (\_ -> return ()) -drainSC :: C.Sink Int Identity b -> ()-drainSC c = runIdentity $ void $ sourceC C.$$ c+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.auto (+1))+ [ 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 drainSC (C.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 drainSC (CC.takeWhile (<= value) C.=$= C.sinkNull)+ , bench "conduit" $ whnf drainC (CC.takeWhile (<= value)) ] , bgroup "fold" [ bench "machines" $ whnf drainM (M.fold (+) 0)- , bench "pipes" $ whnf (P.fold (+) 0 id) sourceP+ , 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+ ] ] ]
examples/Examples.hs view
@@ -2,11 +2,10 @@ module Examples where -import Control.Applicative 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.@@ -22,17 +21,21 @@ clean = either (\(SomeException _) -> []) id slurp = try $ do { s <- hGetLine h; (s:) <$> slurpHandle h } --- read a file, returning each line in a list +-- 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 $ 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@@ -41,8 +44,8 @@ -} -- | 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 +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 ()@@ -51,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)@@ -65,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 ()@@ -93,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]@@ -109,6 +116,6 @@ lineWordCount FilePath -> IO (Int, Int) lineWordCount path = runHead lineWordCountSrc where- lineWordCountSrc = echo + lineWordCountSrc = echo -}
examples/machines-examples.cabal view
@@ -11,10 +11,24 @@ bug-reports: http://github.com/ekmett/machines/issues copyright: Copyright (C) 2014 Edward A. Kmett synopsis: Networked stream transducers-description: machines examples+description: Networked stream transducers+ .+ @machines@ examples build-type: Simple-tested-with: GHC == 7.4.1+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@@ -22,9 +36,12 @@ library build-depends:- base == 4.*,- machines == 0.4,- mtl >= 2 && < 2.2+ base >= 4.9 && < 5,+ machines == 0.7.*,+ mtl >= 2 && < 2.4 exposed-modules: Examples++ default-language: Haskell2010+ ghc-options: -Wall
machines.cabal view
@@ -1,6 +1,6 @@ name: machines category: Control, Enumerator-version: 0.5.1+version: 0.7.4 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE@@ -9,18 +9,28 @@ stability: provisional homepage: http://github.com/ekmett/machines/ bug-reports: http://github.com/ekmett/machines/issues-copyright: Copyright (C) 2012 Edward A. Kmett+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:- <https://dl.dropbox.com/u/4588997/Machines.pdf>-build-type: Custom-tested-with: GHC == 7.4.1, GHC == 7.8.3+ <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:- .travis.yml- .ghci .gitignore .vim.custom config@@ -32,35 +42,43 @@ source-repository head type: git- location: git://github.com/ekmett/machines.git+ location: https://github.com/ekmett/machines.git library build-depends:- base == 4.*,- comonad >= 3 && < 5,- containers >= 0.3 && < 0.6,- free >= 3.1.1 && < 5,- pointed >= 3 && < 5,- profunctors >= 3 && < 6,+ 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.5,- mtl >= 2 && < 2.3,+ 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@@ -71,22 +89,15 @@ Rank2Types UndecidableInstances - ghc-options: -Wall -fwarn-tabs -O2 -fdicts-cheap -funbox-strict-fields- hs-source-dirs: src+ ghc-options: -Wall -Wtabs -O2 -fdicts-cheap -funbox-strict-fields --- 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.*,- directory >= 1.0 && < 1.3,- doctest >= 0.8 && <= 0.10,- filepath >= 1.3 && < 1.5- ghc-options: -Wall -Werror -threaded- hs-source-dirs: tests+ -- 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@@ -95,10 +106,10 @@ ghc-options: -O2 -rtsopts -threaded build-depends:- base == 4.*,- conduit >= 1.0 && < 1.3,- conduit-combinators >= 0.2.5 && < 0.4,- criterion >= 0.6 && < 1.1,+ base >= 4.9 && < 5,+ conduit >= 1.3 && < 1.4,+ criterion >= 0.6 && < 1.7, machines,- mtl >= 2 && < 2.3,- pipes >= 4 && < 4.2+ mtl >= 2 && < 2.4,+ pipes >= 4 && < 4.4,+ streaming >= 0.1.4 && < 0.3
src/Data/Machine/Fanout.hs view
@@ -1,57 +1,42 @@ {-# 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 Control.Applicative-import Control.Arrow-import Control.Monad (foldM)-import Data.Machine-import Data.Maybe (catMaybes)-import Data.Monoid-import Data.Semigroup (Semigroup(sconcat))-import Data.List.NonEmpty (NonEmpty((:|)))-import Prelude --- | Feed a value to a 'ProcessT' at an 'Await' 'Step'. If the--- 'ProcessT' is awaiting a value, then its next step is--- returned. Otherwise, the original process is returned.-feed :: Monad m => a -> ProcessT m a b -> m (Step (Is a) b (ProcessT m a b))-feed x m = runMachineT m >>= \v ->- case v of- Await f Refl _ -> runMachineT (f x)- s -> return s+import Data.List.NonEmpty (NonEmpty (..))+import Data.Machine+import Data.Semigroup (Semigroup (sconcat)) --- | Like 'Data.List.mapAccumL' but with a monadic accumulating--- function.-mapAccumLM :: (Functor m, Monad m)- => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])-mapAccumLM f z = fmap (second ($ [])) . foldM aux (z,id)- where aux (acc,ys) x = second ((. ys) . (:)) <$> f acc x+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) --- | Exhaust a sequence of all successive 'Yield' steps taken by a--- 'MachineT'. Returns the list of yielded values and the next--- (non-Yield) step of the machine.-flushYields :: Monad m- => Step k o (MachineT m k o) -> m ([o], Maybe (MachineT m k o))-flushYields = go id- where go rs (Yield o s) = runMachineT s >>= go ((o:) . rs)- go rs Stop = return (rs [], Nothing)- go rs s = return (rs [], Just $ encased s)+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 :: (Functor m, Monad m, Semigroup r)+fanout :: forall m a r. (Monad m, Semigroup r) => [ProcessT m a r] -> ProcessT m a r-fanout xs = encased $ Await (MachineT . aux) Refl (fanout xs)- where aux y = do (rs,xs') <- mapM (feed y) xs >>= mapAccumLM yields []- let nxt = fanout $ catMaybes xs'- case rs of- [] -> runMachineT nxt- (r:rs') -> return $ Yield (sconcat $ r :| rs') nxt- yields rs Stop = return (rs,Nothing)- yields rs y@(Yield _ _) = first (++ rs) <$> flushYields y- yields rs a@(Await _ _ _) = return (rs, Just $ encased a)+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@@ -60,14 +45,18 @@ -- run a collection of 'ProcessT's that await but don't yield some -- number of times, you can use 'fanOutSteps . map (fmap (const ()))' -- followed by a 'taking' process.-fanoutSteps :: (Functor m, Monad m, Monoid r)+fanoutSteps :: forall m a r. (Monad m, Monoid r) => [ProcessT m a r] -> ProcessT m a r-fanoutSteps xs = encased $ Await (MachineT . aux) Refl (fanoutSteps xs)- where aux y = do (rs,xs') <- mapM (feed y) xs >>= mapAccumLM yields []- let nxt = fanoutSteps $ catMaybes xs'- if null rs- then return $ Yield mempty nxt- else return $ Yield (mconcat rs) nxt- yields rs Stop = return (rs,Nothing)- yields rs y@(Yield _ _) = first (++rs) <$> flushYields y- yields rs a@(Await _ _ _) = return (rs, Just $ encased a)+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
src/Data/Machine/Group.hs view
@@ -7,58 +7,31 @@ , 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.--- @--- 'runT' ('supply' [1,2,2] ('taggedBy' (==))) == [Right 1, Left (), Right 2, Right 2]--- @+-- 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 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 +-- | 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---- | Run a machine with no input until it stops, then behave as another machine..-starve :: Monad m => ProcessT m a 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 _ Refl r -> runMachineT (starve r cont)+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 (encased Stop)- 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@@ -15,7 +15,7 @@ ) where import Control.Category-import Data.Monoid+import Data.Semigroup import Prelude -- | Witnessed type equality@@ -33,10 +33,14 @@ 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 Refl Refl = Refl+ mappend = (<>) {-# INLINE mappend #-} instance (a ~ b) => Read (Is a b) where
+ src/Data/Machine/Lift.hs view
@@ -0,0 +1,36 @@+-- | 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)
src/Data/Machine/Mealy.hs view
@@ -1,8 +1,7 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-} -#ifndef MIN_VERSION_profunctors-#define MIN_VERSION_profunctors(x,y,z) 0-#endif ----------------------------------------------------------------------------- -- | -- Module : Data.Machine.Mealy@@ -24,16 +23,35 @@ 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@@ -58,6 +76,10 @@ 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@@ -65,16 +87,6 @@ (b, t) -> (b, go t) {-# INLINE unfoldMealy #-} --- | slow diagonalization-instance Monad (Mealy a) where- return b = r where r = Mealy (const (b, r))- {-# INLINE return #-}- m >>= f = Mealy $ \a -> case runMealy m a of- (b, m') -> (fst (runMealy (f b) a), m' >>= f)- {-# INLINE (>>=) #-}- _ >> n = n- {-# INLINE (>>) #-}- instance Profunctor Mealy where rmap = fmap {-# INLINE rmap #-}@@ -82,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@@ -129,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)@@ -156,3 +164,42 @@ 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
+ src/Data/Machine/MealyT.hs view
@@ -0,0 +1,108 @@+{-# 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 = (<>)
src/Data/Machine/Moore.hs view
@@ -1,8 +1,7 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-} -#ifndef MIN_VERSION_profunctors-#define MIN_VERSION_profunctors(x,y,z) 0-#endif ----------------------------------------------------------------------------- -- | -- Module : Data.Machine.Moore@@ -23,13 +22,21 @@ 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.Monoid+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@@ -38,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@@ -49,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@@ -67,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)@@ -88,11 +93,11 @@ -- | slow diagonalization instance Monad (Moore a) where- return a = r where r = Moore a (const r)+ 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))- _ >> m = m+ (>>) = (*>) instance Copointed (Moore a) where copoint (Moore b _) = b@@ -109,3 +114,47 @@ {-# 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
+ 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/Pipe.hs view
@@ -119,13 +119,18 @@ 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)- _ -> error "Data.Machine.Pipe.runEffect: impossible situation"+ Await _ y _ -> absurdExchange y -- | Like 'runEffect' but discarding any produced value. runEffect_ :: Monad m => Effect m o -> m ()@@ -133,4 +138,4 @@ case v of Stop -> return () Yield _ n -> runEffect_ n- _ -> error "Data.Machine.Pipe.runEffect_: impossible situation"+ Await _ y _ -> absurdExchange y
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@@ -33,12 +30,13 @@ import Control.Applicative import Control.Category-import Control.Monad (ap, MonadPlus(..))+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)@@ -97,8 +95,12 @@ instance Applicative (PlanT k o m) where pure a = PlanT (\kp _ _ _ -> kp a) {-# INLINE pure #-}- (<*>) = ap+ 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@@ -107,12 +109,19 @@ {-# INLINE (<|>) #-} instance Monad (PlanT k o m) where- return a = PlanT (\kp _ _ _ -> kp a)+ return = pure {-# INLINE return #-} PlanT m >>= f = PlanT (\kp ke kr kf -> m (\a -> runPlanT (f a) kp ke kr kf) ke kr kf)- fail _ = PlanT (\_ _ _ kf -> 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 #-}@@ -132,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@@ -162,9 +165,9 @@ yield :: o -> Plan k o () yield o = PlanT (\kp ke _ _ -> ke o (kp ())) --- | Like yield, except stops if there is no value to yield. +-- | 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. --@@ -188,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,6 +1,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Machine.Process@@ -18,6 +19,7 @@ Process , ProcessT , Automaton(..)+ , AutomatonM(..) , process -- ** Common Processes , (<~), (~>)@@ -29,7 +31,9 @@ , taking , droppingWhile , takingWhile+ , takingJusts , buffered+ , flattened , fold , fold1 , scan@@ -45,22 +49,27 @@ , smallest , sequencing , mapping+ , traversing , reading , showing+ , strippingPrefix ) where -import Control.Applicative-import Control.Category (Category)-import Control.Monad (liftM, when, replicateM_)-import Control.Monad.Trans.Class+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+import Prelude hiding (id, (.)) +-- $setup+-- >>> import Data.Machine+-- >>> import Data.Monoid (Sum (..))+ infixr 9 <~ infixl 9 ~> @@ -82,58 +91,247 @@ auto :: k a b -> Process a b instance Automaton (->) where- auto f = repeatedly $ do- i <- await- yield (f i)+ 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 = repeatedly $ do- i <- await- yield i+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 = 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+-- i <- await+-- when (p i) $ yield i+-- @+--+-- Examples:+--+-- >>> run $ filtered even <~ source [1..5]+-- [2,4]+-- filtered :: (a -> Bool) -> Process a a-filtered p = repeatedly $ do- i <- await- when (p i) $ yield i+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 n = before echo $ replicateM_ n await+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 n = construct . replicateM_ n $ await >>= yield+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 = repeatedly $ await >>= \v -> if p v then yield v else stop+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 = before echo loop where- loop = await >>= \v -> if p v then loop else yield v+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 = repeatedly . go [] where- go [] 0 = stop- go acc 0 = yield (reverse acc)- go acc n = do- i <- await <|> yield (reverse acc) *> stop- go (i:acc) $! n-1+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' -- -- @@@ -148,27 +346,48 @@ 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 -> MachineT (return v) <~ g a) kg (MachineT (return v) <~ fg)+ 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.-supply :: Monad m => [a] -> ProcessT m a b -> ProcessT m a b-supply [] m = m-supply xxs@(x:xs) m = MachineT $ runMachineT m >>= \v -> case v of- Stop -> return Stop- Await f Refl _ -> runMachineT $ supply xs (f x)- Yield o k -> return $ Yield o (supply xxs k)+--+-- 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. -- -- @--- 'process' 'Data.Machine.Tee.L' :: 'Data.Machine.Process.Process' a c -> 'Data.Machine.Tee.Tee' a b c--- 'process' 'Data.Machine.Tee.R' :: 'Data.Machine.Process.Process' b c -> 'Data.Machine.Tee.Tee' a b c--- 'process' 'id' :: 'Data.Machine.Process.Process' a b -> 'Data.Machine.Process.Process' a b+-- 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@@ -181,52 +400,184 @@ -- -- 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 = construct $ go seed where- go cur = do- yield cur- next <- await- go $! func cur next+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 = construct $ await >>= go where- go cur = do- yield cur- next <- await- go $! func cur next+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 seed = scan func seed ~> final+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 = scan1 func ~> final+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 = repeatedly $ await >>= traverse_ yield+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@@ -236,7 +587,7 @@ sinkPart_ p = go where go m = MachineT $ runMachineT m >>= \v -> case v of Stop -> return Stop- Yield _ k -> runMachineT $ go k+ Yield o _ -> absurd o Await f Refl ff -> return $ Await (\x -> let (keep,sink) = p x in encased . Yield keep $ go (f sink))@@ -244,33 +595,86 @@ (go ff) -- | Apply a monadic function to each element of a 'ProcessT'.-autoM :: Monad m => (a -> m b) -> ProcessT m a b-autoM f = repeatedly $ await >>= lift . f >>= yield+--+-- 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 = construct $ await >>= go where- go prev = do- next <- await <|> yield prev *> stop- go next+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 = construct . go where- go prev = do- next <- await <|> yield prev *> stop- go next+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@@ -281,8 +685,8 @@ intersperse :: Category k => a -> Machine (k a) a intersperse sep = construct $ await >>= go where go cur = do- next <- await <|> yield cur *> stop yield cur+ next <- await yield sep go next @@ -290,26 +694,70 @@ -- 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 = repeatedly $ do- ma <- await- a <- lift ma- yield 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 = repeatedly $ await >>= yield . f+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@@ -323,3 +771,27 @@ -- 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)
+ src/Data/Machine/Runner.hs view
@@ -0,0 +1,71 @@+{-# 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'
src/Data/Machine/Source.hs view
@@ -19,18 +19,24 @@ , repeated , cycled , cap+ , plug , iterated , replicated , enumerateFromTo+ , unfold+ , unfoldT ) where -import Control.Category+import Control.Monad.Trans import Data.Foldable import Data.Machine.Plan import Data.Machine.Type import Data.Machine.Process-import Prelude (Enum, Eq, Int, otherwise, succ, (==), (>>))+import Prelude (Enum, Int, Maybe, Monad, ($), (>>=), return) +-- $setup+-- >>> import Data.Machine+ ------------------------------------------------------------------------------- -- Source -------------------------------------------------------------------------------@@ -42,16 +48,59 @@ 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 = repeatedly . yield+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 = repeatedly (traverse_ yield xs)+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 xs = construct (traverse_ yield xs)+source f = foldr go stopped f+ where+ go x m = encased $ Yield x m -- | -- You can transform a 'Source' with a 'Process'.@@ -64,6 +113,18 @@ 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@@ -77,8 +138,31 @@ replicated n x = repeated x ~> taking n -- | Enumerate from a value to a final value, inclusive, via 'succ'-enumerateFromTo :: (Enum a, Eq a) => a -> a -> Source a-enumerateFromTo start end = construct (go start) where- go i- | i == end = yield i- | otherwise = yield i >> go (succ i)+--+-- 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'
src/Data/Machine/Stack.hs view
@@ -33,16 +33,17 @@ 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---- TODO: make this a class?+{-# INLINABLE pop #-} -- | Stream outputs from one 'Machine' into another with the possibility -- of pushing inputs back.@@ -60,3 +61,4 @@ 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 #-}
src/Data/Machine/Tee.hs view
@@ -15,10 +15,12 @@ ( -- * Tees Tee, TeeT , T(..)- , tee+ , tee, teeT , addL, addR- , capL, capR+ , capL, capR, capT , zipWithT+ , zipWith+ , zipping ) where import Data.Machine.Is@@ -26,8 +28,11 @@ import Data.Machine.Process import Data.Machine.Type import Data.Machine.Source-import Prelude hiding ((.),id)+import Prelude hiding ((.), id, zipWith) +-- $setup+-- >>> import Data.Machine+ ------------------------------------------------------------------------------- -- Tees -------------------------------------------------------------------------------@@ -44,6 +49,13 @@ 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@@ -59,6 +71,32 @@ 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@@ -79,6 +117,13 @@ 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@@ -86,6 +131,21 @@ {-# INLINE cappedT #-} -- | wait for both the left and the right sides of a T and then merge them with f.-zipWithT :: Monad m => (a -> b -> c) -> PlanT (T a b) c m ()+zipWithT :: (a -> b -> c) -> PlanT (T a b) c m () zipWithT f = do { a <- awaits L; b <- awaits R; yield $ f a b } {-# INLINE zipWithT #-}++-- | 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 #-}
src/Data/Machine/Type.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- |@@ -27,7 +28,9 @@ -- ** Building machines from plans , construct , repeatedly+ , unfoldPlan , before+ , preplan -- , sink -- ** Deconstructing machines back into plans@@ -40,6 +43,8 @@ , fitM , pass + , starve+ , stopped , stepMachine@@ -56,6 +61,7 @@ import Data.Machine.Plan import Data.Monoid hiding ((<>)) import Data.Pointed+import Data.Profunctor.Unsafe ((#.)) import Data.Semigroup import Prelude hiding ((.),id) @@ -91,11 +97,11 @@ -- | 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+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)+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@@ -104,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@@ -159,6 +165,7 @@ -} -- | 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 ()@@ -166,6 +173,7 @@ 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 []@@ -192,6 +200,7 @@ 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.@@ -201,14 +210,16 @@ 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)))+ (\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. --@@ -218,17 +229,38 @@ r = MachineT $ runPlanT m (const (runMachineT r)) (\o k -> return (Yield o (MachineT k)))- (\f k g -> return (Await (MachineT . f) k (MachineT g)))+ (\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)))+ (\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. -- -- @@@ -239,14 +271,28 @@ -- '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 = repeatedly $ do- a <- awaits k- yield a+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@@ -259,7 +305,7 @@ --- 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 -> +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
src/Data/Machine/Wye.hs view
@@ -18,7 +18,7 @@ , Y(..) , wye , addX, addY- , capX, capY+ , capX, capY, capWye ) where import Control.Category@@ -85,20 +85,25 @@ addX p = wye p echo {-# INLINE addX #-} --- | Precompose a pipe onto the right input of a tee.+-- | 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 tee by connecting it to a known source.+-- | 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 tee by connecting it to a known source.+-- | 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
− tests/doctests.hs
@@ -1,31 +0,0 @@-module Main where--import Build_doctests (deps)-import Control.Applicative-import Control.Monad-import Data.List-import System.Directory-import System.FilePath-import Test.DocTest-import Prelude--main :: IO ()-main = getSources >>= \sources -> doctest $- "-isrc"- : "-idist/build/autogen"- : "-optP-include"- : "-optPdist/build/autogen/cabal_macros.h"- : "-hide-all-packages"- : map ("-package="++) deps ++ sources--getSources :: IO [FilePath]-getSources = filter (isSuffixOf ".hs") <$> go "src"- where- go dir = do- (dirs, files) <- getFilesAndDirectories dir- (files ++) . concat <$> mapM go dirs--getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])-getFilesAndDirectories dir = do- c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir- (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c