machines 0.6.1 → 0.6.2
raw patch · 20 files changed
+1000/−186 lines, 20 filesdep −directorydep −filepathdep −freedep ~basedep ~conduit-combinatorsdep ~criterionsetup-changednew-uploader
Dependencies removed: directory, filepath, free
Dependency ranges changed: base, conduit-combinators, criterion, doctest, pipes
Files
- .ghci +0/−1
- .gitignore +1/−0
- .travis.yml +14/−12
- CHANGELOG.markdown +15/−1
- Setup.lhs +163/−29
- benchmarks/Benchmarks.hs +36/−4
- examples/Examples.hs +5/−5
- machines.cabal +13/−10
- src/Data/Machine/Group.hs +7/−6
- src/Data/Machine/Mealy.hs +12/−0
- src/Data/Machine/MealyT.hs +130/−0
- src/Data/Machine/Pipe.hs +1/−1
- src/Data/Machine/Plan.hs +1/−1
- src/Data/Machine/Process.hs +458/−67
- src/Data/Machine/Source.hs +68/−10
- src/Data/Machine/Stack.hs +4/−2
- src/Data/Machine/Tee.hs +28/−5
- src/Data/Machine/Type.hs +16/−3
- src/Data/Machine/Wye.hs +9/−4
- tests/doctests.hs +19/−25
− .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
.travis.yml view
@@ -13,21 +13,24 @@ matrix: include:- - env: CABALVER=1.18 GHCVER=7.4.2+ - env: CABALVER=1.24 GHCVER=7.4.2 compiler: ": #GHC 7.4.2"- addons: {apt: {packages: [cabal-install-1.18,ghc-7.4.2], sources: [hvr-ghc]}}- - env: CABALVER=1.18 GHCVER=7.6.3+ addons: {apt: {packages: [cabal-install-1.24,ghc-7.4.2], sources: [hvr-ghc]}}+ - env: CABALVER=1.24 GHCVER=7.6.3 compiler: ": #GHC 7.6.3"- addons: {apt: {packages: [cabal-install-1.18,ghc-7.6.3], sources: [hvr-ghc]}}- - env: CABALVER=1.18 GHCVER=7.8.4+ addons: {apt: {packages: [cabal-install-1.24,ghc-7.6.3], sources: [hvr-ghc]}}+ - env: CABALVER=1.24 GHCVER=7.8.4 compiler: ": #GHC 7.8.4"- addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}}- - env: CABALVER=1.22 GHCVER=7.10.3+ addons: {apt: {packages: [cabal-install-1.24,ghc-7.8.4], sources: [hvr-ghc]}}+ - env: CABALVER=1.24 GHCVER=7.10.3 compiler: ": #GHC 7.10.3"- addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}}- - env: CABALVER=1.24 GHCVER=8.0.1- compiler: ": #GHC 8.0.1"- addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}}+ addons: {apt: {packages: [cabal-install-1.24,ghc-7.10.3], sources: [hvr-ghc]}}+ - env: CABALVER=1.24 GHCVER=8.0.2+ compiler: ": #GHC 8.0.2"+ addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2], sources: [hvr-ghc]}}+ - env: CABALVER=1.24 GHCVER=8.2.1+ compiler: ": #GHC 8.2.1"+ addons: {apt: {packages: [cabal-install-1.24,ghc-8.2.1], sources: [hvr-ghc]}} - env: CABALVER=1.24 GHCVER=head compiler: ": #GHC head" addons: {apt: {packages: [cabal-install-1.24,ghc-head], sources: [hvr-ghc]}}@@ -64,7 +67,6 @@ rm -rf $HOME/.cabsnap; mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; cabal install -j --only-dependencies --enable-tests;- if [ "$GHCVER" = "7.10.3" ]; then cabal install Cabal-1.22.4.0; fi; fi # snapshot package-db on cache miss
CHANGELOG.markdown view
@@ -1,3 +1,17 @@+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`@@ -44,7 +58,7 @@ 0.2.4 ------* Added `asPats`, `sinkPart_`, `autoM`, and `fitM`+* Added `asParts`, `sinkPart_`, `autoM`, and `fitM` 0.2.1 -----
Setup.lhs view
@@ -1,48 +1,182 @@-#!/usr/bin/runhaskell \begin{code}-{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} module Main (main) where +#ifndef MIN_VERSION_cabal_doctest+#define MIN_VERSION_cabal_doctest(x,y,z) 0+#endif+++#if MIN_VERSION_cabal_doctest(1,0,0)+import Distribution.Extra.Doctest ( defaultMainWithDoctests )+#else++-- Otherwise we provide a shim++#ifndef MIN_VERSION_Cabal+#define MIN_VERSION_Cabal(x,y,z) 0+#endif+#ifndef MIN_VERSION_directory+#define MIN_VERSION_directory(x,y,z) 0+#endif+#if MIN_VERSION_Cabal(1,24,0)+#define InstalledPackageId UnitId+#endif++import Control.Monad ( when ) import Data.List ( nub )-import Data.Version ( showVersion )-import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName )-import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )+import Data.String ( fromString )+import Distribution.Package ( InstalledPackageId )+import Distribution.Package ( PackageId, Package (..), packageVersion )+import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) , Library (..), BuildInfo (..)) 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 Distribution.Simple.Setup ( BuildFlags(buildDistPref, buildVerbosity), fromFlag)+import Distribution.Simple.LocalBuildInfo ( withPackageDB, withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps), compiler )+import Distribution.Simple.Compiler ( showCompilerId , PackageDB (..))+import Distribution.Text ( display , simpleParse ) 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- }+#if MIN_VERSION_Cabal(1,25,0)+import Distribution.Simple.BuildPaths ( autogenComponentModulesDir )+#endif -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"+#if MIN_VERSION_directory(1,2,2)+import System.Directory (makeAbsolute)+#else+import System.Directory (getCurrentDirectory)+import System.FilePath (isAbsolute)++makeAbsolute :: FilePath -> IO FilePath+makeAbsolute p | isAbsolute p = return p+ | otherwise = do+ cwd <- getCurrentDirectory+ return $ cwd </> p+#endif++generateBuildModule :: String -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()+generateBuildModule testsuiteName flags pkg lbi = do+ let verbosity = fromFlag (buildVerbosity flags)+ let distPref = fromFlag (buildDistPref flags)++ -- Package DBs+ let dbStack = withPackageDB lbi ++ [ SpecificPackageDB $ distPref </> "package.conf.inplace" ]+ let dbFlags = "-hide-all-packages" : packageDbArgs dbStack++ withLibLBI pkg lbi $ \lib libcfg -> do+ let libBI = libBuildInfo lib++ -- modules+ let modules = exposedModules lib ++ otherModules libBI+ -- it seems that doctest is happy to take in module names, not actual files!+ let module_sources = modules++ -- We need the directory with library's cabal_macros.h!+#if MIN_VERSION_Cabal(1,25,0)+ let libAutogenDir = autogenComponentModulesDir lbi libcfg+#else+ let libAutogenDir = autogenModulesDir lbi+#endif++ -- Lib sources and includes+ iArgs <- mapM (fmap ("-i"++) . makeAbsolute) $ libAutogenDir : hsSourceDirs libBI+ includeArgs <- mapM (fmap ("-I"++) . makeAbsolute) $ includeDirs libBI++ -- CPP includes, i.e. include cabal_macros.h+ let cppFlags = map ("-optP"++) $+ [ "-include", libAutogenDir ++ "/cabal_macros.h" ]+ ++ cppOptions libBI++ withTestLBI pkg lbi $ \suite suitecfg -> when (testName suite == fromString testsuiteName) $ do++ -- get and create autogen dir+#if MIN_VERSION_Cabal(1,25,0)+ let testAutogenDir = autogenComponentModulesDir lbi suitecfg+#else+ let testAutogenDir = autogenModulesDir lbi+#endif+ createDirectoryIfMissingVerbose verbosity True testAutogenDir++ -- write autogen'd file+ rewriteFile (testAutogenDir </> "Build_doctests.hs") $ unlines+ [ "module Build_doctests where" , ""- , "autogen_dir :: String"- , "autogen_dir = " ++ show dir+ -- -package-id etc. flags+ , "pkgs :: [String]"+ , "pkgs = " ++ (show $ formatDeps $ testDeps libcfg suitecfg) , ""- , "deps :: [String]"- , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))+ , "flags :: [String]"+ , "flags = " ++ show (iArgs ++ includeArgs ++ dbFlags ++ cppFlags)+ , ""+ , "module_sources :: [String]"+ , "module_sources = " ++ show (map display module_sources) ] where- formatdeps = map (formatone . snd)- formatone p = case packageName p of- PackageName n -> n ++ "-" ++ showVersion (packageVersion p)+ -- we do this check in Setup, as then doctests don't need to depend on Cabal+ isOldCompiler = maybe False id $ do+ a <- simpleParse $ showCompilerId $ compiler lbi+ b <- simpleParse "7.5"+ return $ packageVersion (a :: PackageId) < b + formatDeps = map formatOne+ formatOne (installedPkgId, pkgId)+ -- The problem is how different cabal executables handle package databases+ -- when doctests depend on the library+ | packageId pkg == pkgId = "-package=" ++ display pkgId+ | otherwise = "-package-id=" ++ display installedPkgId++ -- From Distribution.Simple.Program.GHC+ packageDbArgs :: [PackageDB] -> [String]+ packageDbArgs | isOldCompiler = packageDbArgsConf+ | otherwise = packageDbArgsDb++ -- GHC <7.6 uses '-package-conf' instead of '-package-db'.+ packageDbArgsConf :: [PackageDB] -> [String]+ packageDbArgsConf dbstack = case dbstack of+ (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs+ (GlobalPackageDB:dbs) -> ("-no-user-package-conf")+ : concatMap specific dbs+ _ -> ierror+ where+ specific (SpecificPackageDB db) = [ "-package-conf=" ++ db ]+ specific _ = ierror+ ierror = error $ "internal error: unexpected package db stack: "+ ++ show dbstack++ -- GHC >= 7.6 uses the '-package-db' flag. See+ -- https://ghc.haskell.org/trac/ghc/ticket/5977.+ packageDbArgsDb :: [PackageDB] -> [String]+ -- special cases to make arguments prettier in common scenarios+ packageDbArgsDb dbstack = case dbstack of+ (GlobalPackageDB:UserPackageDB:dbs)+ | all isSpecific dbs -> concatMap single dbs+ (GlobalPackageDB:dbs)+ | all isSpecific dbs -> "-no-user-package-db"+ : concatMap single dbs+ dbs -> "-clear-package-db"+ : concatMap single dbs+ where+ single (SpecificPackageDB db) = [ "-package-db=" ++ db ]+ single GlobalPackageDB = [ "-global-package-db" ]+ single UserPackageDB = [ "-user-package-db" ]+ isSpecific (SpecificPackageDB _) = True+ isSpecific _ = False+ testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys++defaultMainWithDoctests :: String -> IO ()+defaultMainWithDoctests testSuiteName = defaultMainWithHooks simpleUserHooks+ { buildHook = \pkg lbi hooks flags -> do+ generateBuildModule testSuiteName flags pkg lbi+ buildHook simpleUserHooks pkg lbi hooks flags+ }++#endif++main :: IO ()+main = defaultMainWithDoctests "doctests" \end{code}
benchmarks/Benchmarks.hs view
@@ -1,5 +1,6 @@ module Main (main) where +import Control.Applicative import Control.Monad (void) import Control.Monad.Identity import Criterion.Main@@ -9,6 +10,7 @@ import qualified Data.Machine as M import qualified Pipes as P import qualified Pipes.Prelude as P+import Prelude value :: Int value = 1000000@@ -23,7 +25,7 @@ drainC c = runIdentity $ (sourceC C.$= c) C.$$ C.sinkNull drainSC :: C.Sink Int Identity b -> ()-drainSC c = runIdentity $ void $ sourceC C.$$ c+drainSC c = runIdentity $ void $! sourceC C.$$ c sourceM = M.enumerateFromTo 1 value sourceC = C.enumFromTo 1 value@@ -33,7 +35,7 @@ main = defaultMain [ bgroup "map"- [ bench "machines" $ whnf drainM (M.auto (+1))+ [ bench "machines" $ whnf drainM (M.mapping (+1)) , bench "pipes" $ whnf drainP (P.map (+1)) , bench "conduit" $ whnf drainC (C.map (+1)) ]@@ -55,16 +57,46 @@ , bgroup "take" [ bench "machines" $ whnf drainM (M.taking 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 "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 "conduit" $ whnf drainSC (C.fold (+) 0)+ ]+ , bgroup "filter"+ [ bench "machines" $ whnf drainM (M.filtered 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 "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 "pipes" $ whnf (\x -> runIdentity $ P.runEffect $ P.for x P.discard)+ (P.zip sourceP sourceP)+ , bench "conduit" $ whnf (\x -> runIdentity $ x C.$$ C.sinkNull)+ (C.getZipSource $ (,) <$> C.ZipSource sourceC <*> C.ZipSource sourceC)+ ]+ , bgroup "last"+ [ bench "machines" $ whnf drainM (M.final)+ , bench "pipes" $ whnf P.last sourceP+ ]+ , bgroup "buffered"+ [ bench "machines" $ whnf drainM (M.buffered 1000)+ ]+ , bgroup "concat"+ [ bench "machines" $ whnf drainM (M.mapping (replicate 10) M.~> M.asParts)+ , bench "pipes" $ whnf drainP (P.map (replicate 10) P.>-> P.concat)+ , bench "conduit" $ whnf drainC (C.map (replicate 10) C.$= C.concat) ] ]
examples/Examples.hs view
@@ -22,7 +22,7 @@ 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 @@ -41,8 +41,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 ()@@ -97,7 +97,7 @@ -- (==) 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 +109,6 @@ lineWordCount FilePath -> IO (Int, Int) lineWordCount path = runHead lineWordCountSrc where- lineWordCountSrc = echo + lineWordCountSrc = echo -}
machines.cabal view
@@ -1,6 +1,6 @@ name: machines category: Control, Enumerator-version: 0.6.1+version: 0.6.2 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE@@ -17,10 +17,9 @@ 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+tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.1 extra-source-files: .travis.yml- .ghci .gitignore .vim.custom config@@ -34,6 +33,12 @@ type: git location: git://github.com/ekmett/machines.git +custom-setup+ setup-depends:+ base >= 4 && < 5,+ Cabal,+ cabal-doctest >= 1 && < 1.1+ library build-depends: adjunctions >= 4.2 && < 5,@@ -41,7 +46,6 @@ comonad >= 3 && < 6, containers >= 0.3 && < 0.6, distributive < 0.6,- free >= 3.1.1 && < 5, pointed >= 3 && < 6, profunctors >= 3 && < 6, semigroupoids >= 5 && < 6,@@ -57,6 +61,7 @@ Data.Machine.Fanout Data.Machine.Lift Data.Machine.Mealy+ Data.Machine.MealyT Data.Machine.Moore Data.Machine.Process Data.Machine.Plan@@ -86,10 +91,8 @@ main-is: doctests.hs default-language: Haskell2010 build-depends:- base == 4.*,- directory >= 1.0 && < 1.3,- doctest >= 0.8 && < 0.12,- filepath >= 1.3 && < 1.5+ base == 4.*,+ doctest >= 0.11.1 && < 0.12 ghc-options: -Wall -threaded hs-source-dirs: tests @@ -103,8 +106,8 @@ build-depends: base == 4.*, conduit >= 1.0 && < 1.3,- conduit-combinators >= 0.2.5 && < 1.1,+ conduit-combinators >= 0.2.5 && < 1.2, criterion >= 0.6 && < 1.2, machines, mtl >= 2 && < 2.3,- pipes >= 4 && < 4.2+ pipes >= 4 && < 4.4
src/Data/Machine/Group.hs view
@@ -16,18 +16,19 @@ groupingOn f m = taggedBy f ~> partitioning m -- | 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+ if not (f x y) then yield (Left ()) >> go y else go y --- | 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@@ -54,5 +55,5 @@ -- | 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)+awaitUntil f cont = encased $ Await g Refl stopped where g a = if f a then cont a else awaitUntil f cont
src/Data/Machine/Mealy.hs view
@@ -45,7 +45,19 @@ import Data.Sequence as Seq import Prelude hiding ((.),id) +-- $setup+-- >>> import Data.Machine.Source+ -- | '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
+ src/Data/Machine/MealyT.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TupleSections #-}++-----------------------------------------------------------------------------+-- |+-- Module : Data.Machine.Mealy+-- 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+ , embedMealyT+ ) where++import Data.Machine+import Control.Arrow+import Control.Applicative+import Data.Pointed+import Control.Monad.Trans+import Control.Monad.Identity+import Data.Profunctor+import qualified Control.Category as C+import Prelude++-- | 'Mealy' machine, with monadic 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 Monad m => Monad (MealyT m a) where+ {-# INLINE return #-}+ return b = r where r = MealyT (const (return (b, r))) -- Stolen from Pointed+ MealyT g >>= f = MealyT $ \a ->+ do (b, MealyT _h) <- g a+ runMealyT (f b) a++-- | Profunctor Example:+--+-- >>> embedMealyT (dimap (+21) (+1) (arr (+1))) [1,2,3 :: Int]+-- [24,25,26]+--+instance Functor m => Profunctor (MealyT m) where+ rmap = fmap+ {-# INLINE rmap #-}+ lmap f = go where+ go (MealyT m) = MealyT $ \a -> fmap (\(b,n) -> (b, go n)) (m (f a))+ {-# INLINE lmap #-}+#if MIN_VERSION_profunctors(3,1,1)+ dimap f g = go where+ go (MealyT m) = MealyT $ \a -> fmap (\(b,n) -> (g b, go n)) (m (f a))+ {-# INLINE dimap #-}+#endif++instance Monad m => C.Category (MealyT m) where+ {-# INLINE id #-}+ 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 :: Monad m => Mealy a b -> MealyT m a b+upgrade (Mealy f) = MealyT $ \a ->+ do let (r, g) = f a+ return (r, upgrade g)++scanMealyT :: Monad m => (a -> b -> a) -> a -> MealyT m b a+scanMealyT f a = MealyT (\b -> return (a, scanMealyT f (f a b)))++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++-- | embedMealyT Example:+--+-- >>> embedMealyT (arr (+1)) [1,2,3]+-- [2,3,4]+--+embedMealyT :: Monad m => MealyT m a b -> [a] -> m [b]+embedMealyT _ [] = return []+embedMealyT sf (a:as) = do+ (b, sf') <- runMealyT sf a+ bs <- embedMealyT sf' as+ return (b:bs)++instance AutomatonM MealyT where+ autoT = autoMealyTImpl+
src/Data/Machine/Pipe.hs view
@@ -123,7 +123,7 @@ 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 ->
src/Data/Machine/Plan.hs view
@@ -168,7 +168,7 @@ 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
src/Data/Machine/Process.hs view
@@ -23,6 +23,7 @@ Process , ProcessT , Automaton(..)+ , AutomatonM(..) , process -- ** Common Processes , (<~), (~>)@@ -35,6 +36,7 @@ , droppingWhile , takingWhile , buffered+ , flattened , fold , fold1 , scan@@ -50,15 +52,15 @@ , 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@@ -67,9 +69,14 @@ import Data.Void import Prelude #if !(MIN_VERSION_base(4,8,0))- hiding (foldr)+ hiding (id, (.), foldr)+#else+ hiding (id, (.)) #endif +-- $setup+-- >>> import Data.Machine.Source+ infixr 9 <~ infixl 9 ~> @@ -91,58 +98,216 @@ 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 -- | 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 =+ loop+ 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 =+ loop+ 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 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' -- -- @@@ -157,15 +322,23 @@ 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.+--+-- 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 xs = foldr go id xs+supply = foldr go id where go :: a -> (ProcessT m a b -> ProcessT m a b) ->@@ -177,14 +350,20 @@ 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@@ -197,58 +376,177 @@ -- -- 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 = construct $ go seed where- go cur = do- next <- await <|> yield cur *> stop- go $! func cur next+fold func =+ let step t = t `seq` encased+ $ Await (step . func t)+ id+ (encased $ Yield t stopped)+ in step+{-# 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 = construct $ await >>= go where- go cur = do- next <- await <|> yield cur *> stop- go $! func cur next+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@@ -258,7 +556,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))@@ -266,33 +564,83 @@ (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 =+ let step x = encased (Await step id (emit x))+ emit x = encased (Yield x stopped)+ in step+{-# INLINABLE finalOr #-} -- | -- Intersperse an element between the elements of the input@@ -312,26 +660,68 @@ -- 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@@ -345,6 +735,7 @@ -- 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@@@ -366,5 +757,5 @@ | b == b' -> runMachineT $ strippingPrefix nxt nxt' | otherwise -> return Stop Await f ki ff ->- return $ Await (\a -> MachineT $ verify b nxt (f a))- ki (MachineT $ verify b nxt ff)+ return $ Await (MachineT . verify b nxt . f)+ ki (MachineT $ verify b nxt ff)
src/Data/Machine/Source.hs view
@@ -19,6 +19,7 @@ , repeated , cycled , cap+ , plug , iterated , replicated , enumerateFromTo@@ -26,13 +27,12 @@ , 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, Maybe, Monad, otherwise, succ, (==), (>>), ($))+import Prelude (Enum, Int, Maybe, Monad, ($), (>>=), return) ------------------------------------------------------------------------------- -- Source@@ -45,16 +45,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 = foldr go stopped+ where+ go x m = encased $ Yield x m -- | -- You can transform a 'Source' with a 'Process'.@@ -67,6 +110,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@@ -80,11 +135,14 @@ 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
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
@@ -17,7 +17,7 @@ , T(..) , tee, teeT , addL, addR- , capL, capR+ , capL, capR, capT , zipWithT , zipWith , zipping@@ -28,7 +28,7 @@ import Data.Machine.Process import Data.Machine.Type import Data.Machine.Source-import Prelude hiding ((.),id, zipWith)+import Prelude hiding ((.), id, zipWith) ------------------------------------------------------------------------------- -- Tees@@ -46,6 +46,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@@ -62,7 +69,16 @@ 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`+-- 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@@ -71,12 +87,12 @@ Stop -> runMachineT $ teeT ff stopped mb Yield a k -> runMachineT $ teeT (f a) k mb Await g rq fg ->- return $ Await (\r -> teeT mt (g r) mb) rq $ teeT mt fg mb+ 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 mt ma (g r)) rq $ teeT mt ma 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@@ -97,6 +113,13 @@ capR :: Monad m => SourceT m b -> TeeT m a b c -> ProcessT m a c capR s t = fit cappedT $ addR s t {-# INLINE capR #-}++-- | Tie off both inputs to a tee by connecting them to known sources.+-- This is recommended over capping each side separately, as it is+-- far more efficient.+capT :: Monad m => SourceT m a -> SourceT m b -> TeeT m a b c -> SourceT m c+capT l r t = plug $ tee l r t+{-# INLINE capT #-} -- | Natural transformation used by 'capL' and 'capR'. cappedT :: T a a b -> Is a b
src/Data/Machine/Type.hs view
@@ -197,6 +197,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.@@ -206,6 +207,7 @@ 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@@ -214,6 +216,7 @@ (\o k -> return (Yield o (MachineT k))) (\f k g -> return (Await (MachineT #. f) k (MachineT g))) (return Stop)+{-# INLINE construct #-} -- | Generates a model that runs a machine until it stops, then start it up again. --@@ -225,6 +228,7 @@ (\o k -> return (Yield o (MachineT k))) (\f k g -> return (Await (MachineT #. f) k (MachineT g))) (return Stop)+{-# INLINE repeatedly #-} -- | Unfold a stateful PlanT into a MachineT. unfoldPlan :: Monad m => s -> (s -> PlanT k o m s) -> MachineT m k o@@ -234,6 +238,7 @@ (\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@@ -242,6 +247,7 @@ (\o k -> return (Yield o (MachineT k))) (\f k g -> return (Await (MachineT #. f) k (MachineT g))) (return Stop)+{-# INLINE before #-} -- | Incorporate a 'Plan' into the resulting machine. preplan :: Monad m => PlanT k o m (MachineT m k o) -> MachineT m k o@@ -250,6 +256,7 @@ (\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. --@@ -261,22 +268,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
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 = plug . wye a b+{-# INLINE capWye #-} -- | Natural transformation used by 'capX' and 'capY' capped :: (a -> Either a a) -> Y a a b -> a -> b
tests/doctests.hs view
@@ -1,31 +1,25 @@+-----------------------------------------------------------------------------+-- |+-- Module : Main (doctests)+-- Copyright : (C) 2012-14 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- This module provides doctests for a project based on the actual versions+-- of the packages it was built with. It requires a corresponding Setup.lhs+-- to be added to the project+----------------------------------------------------------------------------- module Main where -import Build_doctests (autogen_dir, deps)-import Control.Applicative-import Control.Monad-import Data.List-import System.Directory-import System.FilePath+import Build_doctests (flags, pkgs, module_sources)+import Data.Foldable (traverse_) import Test.DocTest-import Prelude main :: IO ()-main = getSources >>= \sources -> doctest $- "-isrc"- : ("-i" ++ autogen_dir)- : "-optP-include"- : ("-optP" ++ autogen_dir ++ "/cabal_macros.h")- : "-hide-all-packages"- : map ("-package="++) deps ++ sources--getSources :: IO [FilePath]-getSources = filter (isSuffixOf ".hs") <$> go "src"+main = do+ traverse_ putStrLn args+ doctest args 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+ args = flags ++ pkgs ++ module_sources