├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── cabal.project ├── example ├── Setup.hs ├── counter │ └── Main.hs ├── lib │ └── conduit-adaptor │ │ ├── Automaton.hs │ │ └── ConduitAdaptor.hs ├── machinecell-example.cabal ├── reader │ └── reader.hs ├── wx │ ├── hello │ │ └── Main.hs │ ├── lib │ │ └── WxHandler.hs │ └── stone │ │ └── Main.hs └── xml-parser │ └── Main.hs ├── machinecell.cabal ├── src └── Control │ └── Arrow │ ├── Machine.hs │ └── Machine │ ├── ArrowUtil.hs │ ├── Evolution.hs │ ├── Misc │ ├── Discrete.hs │ ├── Exception.hs │ └── Pump.hs │ ├── Types.hs │ └── Utils.hs └── test ├── Common └── RandomProc.hs ├── Misc └── PumpSpec.hs ├── Spec.hs ├── Types ├── BasicSpec.hs ├── ChoiceSpec.hs ├── LoopSpec.hs ├── PlanSpec.hs ├── RuleSpec.hs ├── StepExecutionSpec.hs └── SwitchSpec.hs ├── Utils └── SourceSpec.hs └── doctest.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | .virthualenv 8 | 9 | 10 | 11 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 2 | 4.0.0 3 | ---------- 4 | ### Breaking changes of APIs 5 | * Side-effects are represented by `Monad`s rather than `ArrowApply`ies. 6 | * Replace the base arrow `ProcessA` with `ProcessT` 7 | * `ProcessA` is now type alias for compatibility 8 | * Change the signatures of construction functions 9 | * `constructT`, `repeatedlyT` 10 | * `construct`, `repeatedly` 11 | * Change the signatures of running functions 12 | * `runT`, `runT_`, `run`, `run_` 13 | * `stepRun`, `stepYield` 14 | * Delete `ExecInfo`. 15 | * Change the `Occasional'` type class 16 | * Add method `burst` 17 | * Move `noEvent` `end` out of the type class 18 | * Delete `echo`. Use `id` instead. 19 | 20 | ### Additions 21 | * Add `ZeroEvent`. Change the signatures of blocking sources with it. 22 | * Add `Evolution` 23 | * Add type classes `MonadAwait`, `MonadYield`, `MonadStop` 24 | * Generalize `await`, `yield`, and `stop` to `Evolution` 25 | * Add `fire`, `fire0` 26 | 27 | 3.3.2 28 | ---------- 29 | * Modify again the versions of depending packages. 30 | * Make the default of 'arrow-tr' flag False. 31 | 32 | 3.3.1 33 | ---------- 34 | * Modify the versions of depending packages. 35 | 36 | 3.3.0 37 | ---------- 38 | * Correct a space leak problem 39 | * Add `splitEvent`, `oneshot` 40 | * Generalize some functions 41 | * construct, repeatedly 42 | * filterEvent, filterJust, filterLeft, filterRight 43 | 44 | 3.2.0 45 | ---------- 46 | * Add arrow-tr flag 47 | * add `gSwitch`, `dgSwitch` 48 | 49 | 3.1.0 50 | ----------- 51 | * Add `Discrete` utilities 52 | * eval 53 | * refer 54 | * kSwitch 55 | * dkSwitch 56 | * Num instance definition 57 | * Add source utilities 58 | * blockingSource 59 | * interleave 60 | * blocking 61 | * Delete `sample` 62 | * Change a switching behavior. With previous implementation, a switching doesn't occur 63 | when a runnning transducer emits a trigger event using `now` transducer. 64 | 65 | 66 | 3.0.1 67 | ----------- 68 | * Fix performance issue of switch, dSwitch, accum, dAccum. 69 | 70 | 3.0.0 71 | ----------- 72 | * ArrowLoop instance now independent of base arrow's 73 | * Make PlanT newtype and add stop handling MonadPlus instance 74 | * API changes 75 | * Added `filterJust`, `filterLeft`, `filterRight` 76 | * Deleted Show and Eq instance of Event type 77 | * Added Isos of ArrowUtil module 78 | * Delete state monad handling. 79 | * Delete unsafe primitives `cycleDelay`, `fitEx`, `unsafeSteady`, `loop'` 80 | * Delete deperecated `passRecent`, `withRecent` 81 | * Delete ProcessA ArrowReader instance and added `readerProc` 82 | 83 | 84 | 2.1.0 85 | ----------- 86 | * Added `dHold`, `dAccum`. 87 | * Deprecated `cycleDelay`. 88 | * Fixed `muted`. 89 | * Slightly changed the ArrowLoop instance declaration. 90 | * Right tightening rule will be preserved. 91 | * For IO processes, "Indefinite access to MVar" errors, which used to occur in some 92 | situations in old versions, will be suppressed. 93 | * This will not change any existing code unless it loops back 94 | any Event-type signal. 95 | 96 | 2.0.1 97 | ------------ 98 | * Support free-4.12 99 | 100 | 2.0.0 101 | ------------ 102 | * Relocate files 103 | * `catch` and its families are moved to Misc.Exception 104 | * Performance improve 105 | * Added primitives: `fitEx`, `unsafeSteady`, `unsafeExhaust` 106 | * Added: `condEvent`, `filterEvent`, `muted` 107 | * Added to Misc: `Discrete`, `Pump.asUpdater`, `Pump.Alg` 108 | * Deleted deprecated: `hEv`, `hEv'`, `evMaybe`, `fromEvent`, `split`, 109 | `join`, `split2`, `join2`, `feedback`, `feedback1`, `isNoEvent`, `isOccasional`, `isEnd` 110 | * Deleted `Foldable` and `Traversable` instance of `Event`. 111 | * Added `Occasional'` by splitting some members from `Occasional` 112 | 113 | 1.3.1 114 | ------------ 115 | * (Fix test suite of 1.3.0) 116 | 117 | 1.3.0 118 | ------------ 119 | * Support of `ArrowState`. 120 | * Added utilities related to `ArrowLoop` (cycleDelay, Pump) 121 | * Correct EOS behaviour of some utilities. 122 | 123 | 1.2.0 124 | ------------ 125 | * Support of `ArrowReader`. 126 | * Added await fail handling. 127 | * Improved performance by church-encoded free monads. 128 | * Arrow stack of newest GHC support for some utilities. 129 | 130 | 1.1.1 131 | ------------ 132 | * Eliminated banana brackets to support newest GHC. 133 | 134 | 1.1.0 135 | ------------ 136 | * Hide `Event` constructors and some instances (`Applicative`, `Monad`). 137 | * Added `feedback` 138 | * Fixed `accum` 139 | 140 | 1.0.1 141 | ------------ 142 | * Fix some bugs of core part. 143 | * Added `onEnd`. 144 | * Added `sample`. 145 | 146 | 1.0.0 147 | ------------- 148 | * First release. 149 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, as_capabl 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of as_capabl nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | machinecell 2 | =========== 3 | 4 | Arrow based stream transducer. 5 | 6 | Description 7 | --------------- 8 | 9 | As other iteratee or pipe libraries, machinecell abstracts general iteration processes. 10 | 11 | Here is an example that is a simple iteration over a list. 12 | 13 | ``` 14 | >>> run (evMap (+1)) [1, 2, 3] 15 | [2, 3, 4] 16 | ``` 17 | 18 | In above statement, "`evMap` (+1)" has a type "ProcessA (-\>) (Event Int) (Event Int)", 19 | which denotes "A stream transducer that takes a series of Int as input, 20 | gives a series of Int as output, run on base arrow (-\>)." 21 | 22 | 23 | In addition to this simple iteration, machinecell has following features. 24 | 25 | * Side effects 26 | * Composite pipelines 27 | * Arrow compositions 28 | * Behaviours and switches 29 | 30 | See [Control.Arrow.Machine](https://hackage.haskell.org/package/machinecell/docs/Control-Arrow-Machine.html) documentation. 31 | 32 | 33 | 34 | Comparison to other libraries. 35 | --------------- 36 | 37 | Some part of machinecell is similar to other stream transducer 38 | libraries, namely pipes, conduit, or machines. machinecell can be 39 | seen as a restricted variation of them to one-directional. But 40 | additionally, machinecell supports arrow compositions. 41 | Bidirectional communications can be taken place by ArrowLoop 42 | feature. 43 | 44 | Rather, there are several other arrowised stream transducer 45 | libraries. streamproc shares the most concept to machinecell. But 46 | actually it has a problem described later in this post. Machinecell 47 | can be said as "Streamproc done right." 48 | 49 | auto is a brand-new arrowised stream transducer library. Compared 50 | to it, machinecell's advantage is await/yield coroutines, while 51 | auto's one is serialization. 52 | 53 | 54 | 55 | Motivation and background 56 | --------------- 57 | 58 | "Generalizing monads to arrows," The original paper of arrow calculation 59 | mentions a kind of stream transducer, which later implemented as streamproc. 60 | 61 | http://www.cse.chalmers.se/~rjmh/Papers/arrows.pdf 62 | 63 | 64 | And other people propose instance declarations of Arrow class for several existing stream processors. 65 | 66 | http://stackoverflow.com/questions/19758744/haskell-splitting-pipes-broadcast-without-using-spawn 67 | 68 | https://www.fpcomplete.com/school/to-infinity-and-beyond/pick-of-the-week/coroutines-for-streaming/part-4-category-and-arrow 69 | 70 | 71 | But actually, there is a problem argued in this post. 72 | 73 | https://mail.haskell.org/pipermail/haskell-cafe/2010-January/072193.html 74 | 75 | 76 | The core problem is, while arrow uses tuples as parallel data 77 | stream, they cannot represent a composite streams if they carry 78 | different numbers of data in parallel. 79 | 80 | To solve this problem, some arrow libraries restrict transducers to 81 | one-to-one data transformation. Yampa and netwire does so, as 82 | mentioned in above post. And auto also takes this approach. 83 | 84 | Machinecell's approach is different, but simple too. The key idea 85 | is wrapping all types of data stream into a maybe-like type. Then 86 | even tuples can represent different numbers of data, by inserting 87 | appropreate number of 'Nothing's. 88 | 89 | Furthermore, I identified the maybe-like type as the 'Event' type, 90 | which appears in Yampa and netwire. Then I successively implemented 91 | several arrows of Yampa and netwire. 92 | 93 | API names come from stream libraries are named after machines', 94 | while ones from FRPs are after Yampa's. Now, machinecell may be 95 | seen as a hybrid of machines and Yampa. 96 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | ./*.cabal 3 | 4 | write-ghc-environment-files: 5 | always -------------------------------------------------------------------------------- /example/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /example/counter/Main.hs: -------------------------------------------------------------------------------- 1 | -- 参考：http://d.hatena.ne.jp/haxis_fx/20110726/1311657175 2 | 3 | {-# LANGUAGE Arrows #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | module 6 | Main 7 | where 8 | 9 | import qualified Control.Arrow.Machine as P 10 | import Control.Applicative ((<$>), (<*>)) 11 | import qualified Control.Category as Cat 12 | import Control.Arrow 13 | import Control.Monad.State 14 | import Control.Monad 15 | import Control.Monad.Trans 16 | import Debug.Trace 17 | 18 | counter = 19 | proc ev -> 20 | do 21 | rec output <- returnA -< (\reset -> if reset then 0 else next) <$> ev 22 | next <- P.dHold 0 -< (+1) <$> output 23 | returnA -< output 24 | 25 | main = print $ P.run counter (map b "ffffffffttfftt") 26 | where b 't' = True 27 | b 'f' = False 28 | -------------------------------------------------------------------------------- /example/lib/conduit-adaptor/Automaton.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | 6 | module 7 | Automaton ( 8 | Automaton(..), 9 | constructAuto 10 | ) 11 | where 12 | 13 | import Prelude hiding ((.), id) 14 | import Control.Category 15 | import Control.Arrow 16 | import Control.Arrow.Machine.Types 17 | import Control.Arrow.Machine.ArrowUtil 18 | import qualified Control.Arrow.Machine.Utils as Mc 19 | 20 | class 21 | Automaton m p q a | a -> m, a -> p, a -> q 22 | where 23 | auto :: a -> PlanT p q m r 24 | 25 | constructAuto :: 26 | (Automaton m i o a, Monad m) => 27 | a -> 28 | ProcessT m (Event i) (Event o) 29 | constructAuto = constructT . auto 30 | 31 | -------------------------------------------------------------------------------- /example/lib/conduit-adaptor/ConduitAdaptor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE TypeSynonymInstances #-} 4 | 5 | module 6 | ConduitAdaptor ( 7 | module Automaton 8 | ) 9 | where 10 | 11 | import qualified Control.Arrow.Machine as Machinecell 12 | import qualified Data.Conduit as Conduit 13 | import Data.Conduit ((=$=), ($$+-)) 14 | import Control.Monad.Morph (hoist) 15 | import Control.Monad.Trans (lift) 16 | import Control.Monad (forever) 17 | 18 | import Automaton 19 | 20 | instance 21 | Monad m => 22 | Automaton m i o (Conduit.ConduitM i o m r) 23 | where 24 | auto cd = 25 | let 26 | cd' = hoist lift cd >> return () 27 | cd'' = sourcePlan =$= cd' =$= sinkPlan 28 | in 29 | Conduit.runConduit cd'' 30 | 31 | instance 32 | Monad m => 33 | Automaton m () o (Conduit.ResumableSource m o) 34 | where 35 | auto rs = 36 | hoist lift rs $$+- sinkPlan 37 | 38 | -- 39 | -- private 40 | -- 41 | sourcePlan :: 42 | Monad m => Conduit.Source (Machinecell.PlanT a s m) a 43 | sourcePlan = forever $ 44 | do 45 | x <- lift Machinecell.await 46 | Conduit.yieldOr x Machinecell.stop 47 | 48 | sinkPlan :: 49 | Monad m => Conduit.Sink a (Machinecell.PlanT s a m) r 50 | sinkPlan = forever $ 51 | do 52 | mx <- Conduit.await 53 | maybe (lift Machinecell.stop) (lift . Machinecell.yield) mx 54 | 55 | -------------------------------------------------------------------------------- /example/machinecell-example.cabal: -------------------------------------------------------------------------------- 1 | name: machinecell-example 2 | version: 0.1.0.0 3 | synopsis: Machiecell example 4 | description: Some examples of machinecell library. 5 | license: PublicDomain 6 | -- license-file: 7 | author: Hidenori Azuma 8 | maintainer: as-capabl@gmail.com 9 | -- copyright: 10 | category: Control 11 | build-type: Simple 12 | -- extra-source-files: 13 | cabal-version: >=1.10 14 | 15 | executable counter 16 | main-is: Main.hs 17 | other-extensions: Arrows 18 | build-depends: base >=4.6 && <5.0, arrows, mtl, machinecell >= 3.0.0 19 | hs-source-dirs: counter 20 | default-language: Haskell2010 21 | 22 | -- Compiles if arrow-tr flag is enabled. -------------------------- 23 | -- executable reader 24 | -- main-is: reader.hs 25 | -- other-extensions: Arrows, RankNTypes, FlexibleInstances, RecursiveDo, TypeSynonymInstances, RecordWildCards, MultiWayIf, TemplateHaskell 26 | -- build-depends: base >=4.6 && <5.0, arrows, mtl, random >=1.1 && <1.2, machinecell >= 3.0.0, lens 27 | -- hs-source-dirs: reader 28 | -- default-language: Haskell2010 29 | 30 | -- Planning to move to another package. -------------------------- 31 | -- executable wx-hello 32 | -- main-is: Main.hs 33 | -- build-depends: base >=4.6 && <5.0, arrows, mtl, random >=1.1 && <1.2, hxt, wxcore, wx, machinecell >= 3.0.0 34 | -- other-extensions: Arrows, RankNTypes, FlexibleInstances, RecursiveDo, TypeSynonymInstances, RecordWildCards, MultiWayIf, TemplateHaskell 35 | -- hs-source-dirs: wx/lib, wx/hello 36 | -- default-language: Haskell2010 37 | -- 38 | -- executable wx-stone 39 | -- main-is: Main.hs 40 | -- build-depends: base >=4.6 && <5.0, arrows, mtl, random >=1.1 && <1.2, lens, 41 | -- hxt, wxcore, wx, machinecell >= 3.0.0 42 | -- other-extensions: Arrows, RankNTypes, FlexibleInstances, RecursiveDo, TypeSynonymInstances, RecordWildCards, MultiWayIf, TemplateHaskell 43 | -- hs-source-dirs: wx/lib, wx/stone 44 | -- default-language: Haskell2010 45 | 46 | executable xml-parser 47 | main-is: Main.hs 48 | other-extensions: TemplateHaskell 49 | build-depends: base >= 4.6 && < 5.0, machinecell >= 3.0.0, mtl, conduit, mmorph, 50 | conduit-extra, lens, bytestring, resourcet, transformers, 51 | xml-conduit, xml-types, text 52 | hs-source-dirs: xml-parser, lib/conduit-adaptor 53 | other-modules: Automaton, ConduitAdaptor 54 | default-language: Haskell2010 55 | -------------------------------------------------------------------------------- /example/reader/reader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | 3 | import Control.Arrow 4 | import qualified Control.Arrow.Machine as P 5 | import Control.Arrow.Transformer.Reader (ReaderArrow, elimReader) 6 | import Control.Monad.Reader (ReaderT, ask) 7 | import Control.Monad.Trans (lift) 8 | import Control.Lens 9 | 10 | 11 | mainPlan = P.constructT (^. P.uc0 . P.rd P.kl) $ 12 | do 13 | P.await 14 | (a, y) <- ask 15 | lift $ lift $ putStrLn $ "a" ++ show (a::Int, y::Int) 16 | P.await 17 | (a, y) <- ask 18 | lift $ lift $ putStrLn $ "b" ++ show (a, y) 19 | P.await 20 | (a, y) <- ask 21 | lift $ lift $ putStrLn $ "c" ++ show (a, y) 22 | P.yield 1 23 | (a, y) <- ask 24 | lift $ lift $ putStrLn $ "d" ++ show (a, y) 25 | P.await 26 | (a, y) <- ask 27 | lift $ lift $ putStrLn $ "e" ++ show (a, y) 28 | P.yield 2 29 | (a, y) <- ask 30 | lift $ lift $ putStrLn $ "f" ++ show (a, y) 31 | P.yield 3 32 | (a, y) <- ask 33 | lift $ lift $ putStrLn $ "g" ++ show (a, y) 34 | 35 | mainProc = proc eva -> 36 | do 37 | rec 38 | a <- P.hold 0 -< eva 39 | evy <- P.readerProc mainPlan -< (eva, (a, y)) 40 | y <- P.dHold 0 -< evy 41 | returnA -< evy 42 | 43 | main = return [1..] >>= P.kl # P.run mainProc 44 | 45 | -------------------------------------------------------------------------------- /example/wx/hello/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE Arrows #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE RecursiveDo #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | 7 | module 8 | Main 9 | where 10 | 11 | import qualified Control.Arrow.Machine as P 12 | import Control.Applicative ((<$>), (<*>), (<$)) 13 | import qualified Control.Category as Cat 14 | import Control.Arrow 15 | import Control.Arrow.ArrowIO 16 | import Control.Monad 17 | import Debug.Trace 18 | 19 | import qualified Graphics.UI.WX as Wx 20 | import Graphics.UI.WX (Prop ((:=))) 21 | import qualified Graphics.UI.WXCore as WxC 22 | 23 | import qualified WxHandler as WxP 24 | 25 | type MainArrow = Kleisli IO 26 | runMainArrow = runKleisli 27 | instance ArrowIO MainArrow 28 | where 29 | arrIO = Kleisli 30 | 31 | 32 | data MyForm a b c = MyForm { 33 | myFormF :: Wx.Frame a, 34 | myFormBtnDlg :: Wx.Button b, 35 | myFormBtnQuit :: Wx.Button c 36 | } 37 | 38 | machine = proc world -> 39 | do 40 | initMsg <- WxP.onInit -< world 41 | form <- P.anytime (arrIO0 setup) -< initMsg 42 | 43 | P.rSwitch P.muted -< (world, drive <$> form) 44 | where 45 | setup = 46 | do 47 | f <- Wx.frame [Wx.text := "Hello!"] 48 | btnDialog <- Wx.button f [Wx.text := "Show Dialog"] 49 | btnQuit <- Wx.button f [Wx.text := "Quit"] 50 | Wx.set f [Wx.layout := Wx.column 5 51 | [Wx.widget btnDialog, Wx.widget btnQuit]] 52 | 53 | return $ MyForm f btnDialog btnQuit 54 | 55 | drive (MyForm f btnDlg btnQuit) = proc world -> 56 | do 57 | dialogMsg <- WxP.on0 Wx.command -< (world, btnDlg) 58 | P.anytime (arrIO (\f -> Wx.infoDialog f "Hello" "Hello")) 59 | -< f <$ dialogMsg 60 | 61 | quitMsg <- WxP.on0 Wx.command -< (world, btnQuit) 62 | P.anytime (arrIO Wx.close) -< f <$ quitMsg 63 | 64 | main = 65 | do 66 | WxP.wxReactimate runMainArrow machine 67 | -------------------------------------------------------------------------------- /example/wx/lib/WxHandler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE Arrows #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE RecursiveDo #-} 5 | 6 | module 7 | WxHandler 8 | ( 9 | World, 10 | -- * Event 11 | on, 12 | on0, 13 | onInit, 14 | 15 | -- * Property 16 | bind, 17 | 18 | -- * Running 19 | wxReactimate 20 | ) 21 | where 22 | 23 | import qualified Control.Arrow.Machine as P 24 | import qualified Control.Arrow.Machine.Misc.Discrete as D 25 | import Data.Functor ((<$>), (<$)) 26 | import qualified Control.Category as Cat 27 | import Control.Arrow 28 | import Control.Arrow.ArrowIO 29 | import Control.Monad 30 | 31 | import Unsafe.Coerce 32 | 33 | import qualified Graphics.UI.WX as Wx 34 | import Graphics.UI.WX (Prop ((:=))) 35 | import qualified Graphics.UI.WXCore as WxC 36 | 37 | 38 | -- IORefのラップ 39 | type MyRef a = Wx.Var a 40 | newMyRef = Wx.varCreate 41 | myRefGet = Wx.varGet 42 | myRefSet = Wx.varSet 43 | 44 | 45 | -- イベントID 46 | newtype EventID = EventID Int deriving (Eq, Show) 47 | 48 | initialID = EventID 0 49 | inclID (EventID n) = EventID (n+1) 50 | newID env = Wx.varUpdate (envGetIDPool env) inclID 51 | 52 | 53 | -- Internal data. 54 | data Any 55 | 56 | type MainState a = P.ProcessA a 57 | (P.Event (EventID, Any)) (P.Event ()) 58 | 59 | data EventEnv a = EventEnv { 60 | envGetIDPool :: MyRef EventID, 61 | envGetState :: MyRef (MainState a), 62 | envGetRun :: forall b c. a b c -> b -> IO c 63 | } 64 | 65 | data World a = World { 66 | worldGetEnv :: EventEnv a, 67 | worldGetEvent :: P.Event (EventID, Any) 68 | } 69 | 70 | instance 71 | P.Occasional' (World a) 72 | where 73 | collapse = P.collapse . worldGetEvent 74 | 75 | 76 | -- Internal functions. 77 | listenID :: 78 | ArrowApply a => 79 | P.ProcessA a (World a, EventID) (P.Event Any) 80 | listenID = proc (World _ etp, myID) -> 81 | do 82 | returnA -< P.filterJust $ go myID <$> etp 83 | where 84 | go myID (curID, ea) | curID == myID = Just ea 85 | go _ _ = Nothing 86 | 87 | 88 | listen :: 89 | (ArrowIO a, ArrowApply a, Eq w) => 90 | a (Any -> IO (), w) () -> 91 | a Any ev -> 92 | P.ProcessA a (World a, w) (P.Event ev) 93 | listen reg getter = proc (world@(World env _), ia) -> 94 | do 95 | initMsg <- P.edge -< ia 96 | evId <- P.anytime (arrIO newID) -< env <$ initMsg 97 | 98 | P.rSwitch (P.muted <<< arr fst) -< ((world, (initMsg, ia)), listener <$> evId) 99 | where 100 | listener myID = proc (world@(World env _), (initMsg, ia)) -> 101 | do 102 | P.anytime reg -< (handleProc env myID, ia) <$ initMsg 103 | 104 | ea <- listenID -< (world, myID) 105 | P.anytime getter -< ea 106 | 107 | 108 | handleProc env eid arg = 109 | do 110 | stH <- myRefGet $ envGetState env 111 | (_, stH') <- envGetRun env (P.stepRun stH) (eid, arg) 112 | envGetState env `myRefSet` stH' 113 | 114 | 115 | -- |Fires once on initialization. 116 | onInit :: 117 | (ArrowApply a) => 118 | P.ProcessA a (World a) (P.Event ()) 119 | onInit = proc world -> 120 | do 121 | ea <- listenID -< (world, initialID) 122 | P.echo -< () <$ ea 123 | 124 | 125 | -- |Fires on Wx events. 126 | on :: 127 | (Eq w, ArrowIO a, ArrowApply a) => 128 | Wx.Event w (arg -> IO ()) -> 129 | P.ProcessA a (World a, w) (P.Event arg) 130 | on signal = listen (arrIO2 regIO) (arr getter) 131 | where 132 | regIO handler w = 133 | Wx.set w [Wx.on signal := (handler . unsafeCoerce)] 134 | getter = arr unsafeCoerce 135 | 136 | 137 | -- |No argument version of `on`. 138 | on0 :: 139 | (ArrowIO a, Arrow a, ArrowApply a, Eq w) => 140 | Wx.Event w (IO ()) -> 141 | P.ProcessA a (World a, w) (P.Event ()) 142 | on0 signal = listen (arrIO2 regIO) (arr getter) 143 | where 144 | regIO handler w = 145 | Wx.set w [Wx.on signal := handler (unsafeCoerce ())] 146 | getter = const () 147 | 148 | -- |Bind a behaviour to an attribute. 149 | bind :: 150 | (ArrowIO a, Arrow a, ArrowApply a, Eq w) => 151 | Wx.Attr w b -> 152 | P.ProcessA a (w, D.T b) () 153 | bind attr = proc (w, x) -> 154 | do 155 | wd <- D.fromEq -< w 156 | ev <- D.edge <<< D.arr2 (,) -< (wd, x) 157 | P.anytime 158 | (arrIO (\(w, val) -> Wx.set w [attr := val])) 159 | -< ev 160 | returnA -< () 161 | 162 | -- |Actuate an event handling process. 163 | wxReactimate :: 164 | (ArrowIO a, ArrowApply a) => 165 | (forall b c. a b c -> b -> IO c) -> 166 | P.ProcessA a (World a) (P.Event ()) -> 167 | IO () 168 | wxReactimate run init = 169 | do 170 | rec vID <- newMyRef $ inclID initialID 171 | vSt <- newMyRef st 172 | 173 | let env = EventEnv { 174 | envGetIDPool = vID, 175 | envGetState = vSt, 176 | envGetRun = run 177 | } 178 | 179 | let init' = proc etp -> init -< World env etp 180 | 181 | let st = init' 182 | Wx.start $ go env 183 | 184 | -- Clean up 185 | stH <- myRefGet $ envGetState env 186 | envGetRun env (P.run_ stH) [] 187 | where 188 | go env = 189 | do 190 | handleProc env initialID (unsafeCoerce ()) 191 | 192 | -------------------------------------------------------------------------------- /example/wx/stone/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE Arrows #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE MultiWayIf #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE TupleSections #-} 8 | 9 | module 10 | Main 11 | where 12 | 13 | import qualified Control.Arrow.Machine as P 14 | import qualified Control.Arrow.Machine.Misc.Discrete as D 15 | import Control.Applicative ((<$>), (<*>), (<$)) 16 | import qualified Control.Category as Cat 17 | import Control.Arrow 18 | import Control.Arrow.ArrowIO 19 | import Control.Monad 20 | import Control.Monad.Trans 21 | import Control.Lens 22 | import System.Random 23 | import Debug.Trace 24 | 25 | import qualified Graphics.UI.WX as Wx 26 | import Graphics.UI.WX (Prop ((:=))) 27 | import qualified Graphics.UI.WXCore as WxC 28 | 29 | import qualified WxHandler as WxP 30 | 31 | 32 | -- 33 | -- 定義 34 | -- 35 | 36 | -- Mainアロー 37 | type MainArrow = Kleisli IO 38 | runMainArrow = runKleisli 39 | instance ArrowIO MainArrow 40 | where 41 | arrIO = Kleisli 42 | 43 | 44 | -- フォーム 45 | data MyForm a = MyForm { 46 | myFormF :: Wx.Frame a, 47 | myFormLabel :: Wx.StaticText a, 48 | myFormCounter :: Wx.StaticText a, 49 | myFormBtns :: [(Int, Wx.Button a)] 50 | } 51 | 52 | 53 | -- コマンド 54 | data Command = NewGame | Message String | Stone Int 55 | makePrisms ''Command 56 | 57 | forkOf :: 58 | ArrowApply a => 59 | Fold s b -> P.ProcessA a (P.Event s) (P.Event b) 60 | forkOf fd = P.repeatedly $ P.await >>= mapMOf_ fd P.yield 61 | 62 | 63 | -- 64 | -- 処理 65 | -- 66 | 67 | -- ボタンリストのイベント待機 68 | onBtnAll :: (ArrowApply a, ArrowIO a) => 69 | [(b, Wx.Button c)] -> P.ProcessA a (WxP.World a) (P.Event b) 70 | onBtnAll btns = 71 | P.gather <<< P.parB (make <$> btns) 72 | where 73 | make (num, btn) = proc world -> 74 | do 75 | ev <- WxP.on0 Wx.command -< (world, btn) 76 | returnA -< num <$ ev 77 | 78 | 79 | -- 処理の本体 80 | machine = proc world -> 81 | do 82 | initMsg <- WxP.onInit -< world 83 | form <- P.anytime (arrIO0 setup) -< initMsg 84 | 85 | -- formが作成されたらgoにスイッチ 86 | P.rSwitch P.muted -< (world, go <$> form) 87 | 88 | where 89 | -- GUI初期化 90 | setup = 91 | do 92 | f <- Wx.frame [Wx.text := "Take stones"] 93 | lbl <- Wx.staticText f [Wx.text := "A player who takes the last stone will lose."] 94 | cntr <- Wx.staticText f [Wx.text := "000"] 95 | 96 | btns <- forM [1, 2, 3] $ \i -> 97 | do 98 | btn <- Wx.button f [Wx.text := show i] 99 | return (i, btn) 100 | 101 | Wx.set f [Wx.layout := Wx.column 5 102 | ([Wx.widget lbl, Wx.widget cntr] ++ (Wx.widget <$> snd <$> btns))] 103 | 104 | return $ MyForm f lbl cntr btns 105 | 106 | -- メインの処理 107 | go MyForm{..} = proc world -> 108 | do 109 | rec 110 | -- ボタンから入力 111 | took <- onBtnAll myFormBtns -< world 112 | 113 | -- ゲームコルーチンを走らせる 114 | command <- game myFormF -< (D.value numStones,) <$> took 115 | 116 | -- ゲーム開始ならばランダムに石の数を決める 117 | newGameMsg <- forkOf _NewGame -< command 118 | newGameStones <- P.anytime (arrIO0 $ randomRIO (7, 30)) -< newGameMsg 119 | 120 | -- コルーチンが石の数を変えたら追従 121 | newStones <- forkOf _Stone -< command 122 | 123 | -- 現在の石の数を保持 124 | numStones <- D.hold (-1) <<< P.gather -< [newStones, newGameStones] 125 | 126 | -- 数ラベルの表示 127 | counterText <- D.arr show -< numStones 128 | WxP.bind Wx.text -< (myFormCounter, counterText) 129 | 130 | -- メッセージの表示 131 | message <- D.hold "" <<< forkOf _Message -< command 132 | WxP.bind Wx.text -< (myFormLabel, message) 133 | 134 | P.muted -< world 135 | 136 | 137 | game f = P.constructT arrIO0 $ 138 | do 139 | P.yield NewGame 140 | P.yield $ Message "A player who takes the last stone will lose." 141 | 142 | forever $ 143 | do 144 | -- ボタン入力を待つ 145 | (n, youTook) <- P.await 146 | 147 | let 148 | n' = n - youTook -- プレイヤーが取った後の石 149 | cpuTook' = (n' - 1) `mod` 4 150 | cpuTook = if cpuTook' == 0 then 1 else cpuTook' -- CPUが取る石 151 | P.yield $ Stone $ if n' <= 0 then n' else n' - cpuTook 152 | P.yield $ Message $ 153 | "You took " ++ show youTook ++ 154 | if n' > 0 then ", CPU took " ++ show cpuTook ++ "." 155 | else "." 156 | 157 | -- ダイアログの表示(別にコルーチンの中でする必要はないが、デモとして) 158 | if 159 | | n' <= 0 -> 160 | do 161 | lift $ Wx.infoDialog f "Game over" "You lose." 162 | P.yield NewGame 163 | P.yield $ Message $ "New game." 164 | 165 | | n' - cpuTook <= 0 -> 166 | do 167 | lift $ Wx.infoDialog f "Game over" "You win." 168 | P.yield NewGame 169 | P.yield $ Message $ "New game." 170 | 171 | | otherwise -> 172 | return () 173 | 174 | 175 | 176 | 177 | main = 178 | do 179 | WxP.wxReactimate runMainArrow machine 180 | -------------------------------------------------------------------------------- /example/xml-parser/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE BangPatterns #-} 5 | 6 | import Prelude hiding ((.), id) 7 | import Control.Category 8 | import Control.Arrow 9 | import Control.Monad 10 | 11 | import Control.Lens 12 | import qualified Data.Conduit as Cd 13 | import qualified Data.XML.Types as XML 14 | import qualified Text.XML.Stream.Parse as XML 15 | import qualified Data.Conduit.Binary as CE 16 | import qualified Data.ByteString.Char8 as BS 17 | import qualified Data.Text as Txt 18 | import qualified Data.Text.IO as Txt 19 | import System.Environment (getArgs) 20 | import Control.Monad.Trans.Resource 21 | import Control.Monad.IO.Class 22 | 23 | import Control.Arrow.Machine.Types 24 | import qualified Control.Arrow.Machine.Utils as Mc 25 | import ConduitAdaptor 26 | 27 | 28 | -- 29 | -- Local definitions 30 | -- 31 | makePrisms ''XML.Event 32 | forkOf :: 33 | Monad m => 34 | Fold s b -> ProcessT m (Event s) (Event b) 35 | forkOf fd = repeatedly $ await >>= mapMOf_ fd yield 36 | 37 | -- 38 | -- Program 39 | -- 40 | mainArrow file = proc start -> 41 | do 42 | -- File read 43 | source <- constructAuto $ CE.sourceFile file -< start 44 | 45 | -- XML Parse 46 | parseEvents <- constructAuto $ XML.parseBytes XML.def -< source 47 | 48 | -- Remember depth 49 | beginElem <- forkOf _EventBeginElement -< parseEvents 50 | endElem <- forkOf _EventEndElement -< parseEvents 51 | depth <- Mc.dAccum (0::Int) <<< Mc.gather -< [(+1) <$ beginElem, (\x->x-1) <$ endElem] 52 | 53 | -- output tag name at the depth 54 | let tagName = XML.nameLocalName . fst <$> beginElem 55 | Mc.fire $ liftIO . Txt.putStrLn -< 56 | (Txt.pack (join $ replicate depth " ") `mappend`) <$> tagName 57 | 58 | main = 59 | do 60 | args <- getArgs 61 | runResourceT $ runT_ (mainArrow $ head args) [] 62 | -------------------------------------------------------------------------------- /machinecell.cabal: -------------------------------------------------------------------------------- 1 | name: machinecell 2 | version: 4.0.1 3 | synopsis: Arrow based stream transducers 4 | license: BSD3 5 | license-file: LICENSE 6 | author: Hidenori Azuma 7 | maintainer: Hidenori Azuma 8 | stability: experimental 9 | homepage: http://github.com/as-capabl/machinecell 10 | bug-reports: http://github.com/as-capabl/machinecell/issues 11 | copyright: Copyright (c) 2014 Hidenori Azuma 12 | category: Control, FRP, Reactivity 13 | build-type: Simple 14 | extra-source-files: README.md, CHANGELOG.md .gitignore 15 | cabal-version: >=1.10 16 | 17 | description: 18 | Stream processing library similar to pipes, couduit, or machines. 19 | . 20 | Arrow combinatins are supported and can be used with the arrow notation. 21 | AFRP-like utilities are also available. 22 | . 23 | A quick introduction is available in the Control.Arrow.Machine documentation. 24 | 25 | flag arrow-tr 26 | description: 27 | Arrow transformer support. 28 | . 29 | A few environments(stackage, haste, etc) don't support this package. 30 | default: False 31 | manual: True 32 | 33 | library 34 | exposed-modules: 35 | Control.Arrow.Machine, 36 | Control.Arrow.Machine.Types, 37 | Control.Arrow.Machine.Utils, 38 | Control.Arrow.Machine.Evolution, 39 | Control.Arrow.Machine.ArrowUtil, 40 | Control.Arrow.Machine.Misc.Exception, 41 | Control.Arrow.Machine.Misc.Pump, 42 | Control.Arrow.Machine.Misc.Discrete 43 | other-extensions: FlexibleInstances, Arrows, RankNTypes, TypeSynonymInstances, MultiParamTypeClasses, GADTs, FlexibleContexts, NoMonomorphismRestriction, RecursiveDo 44 | ghc-options: -Wall 45 | build-depends: base >=4.8 && <5.0 46 | , mtl >=2.2.1 && <3 47 | , free >=4.12.3 && <6 48 | , semigroups >=0.18.1 && <1 49 | , profunctors >=5.2 && <6 50 | , transformers >=0.5.0.0 && <1 51 | hs-source-dirs: src 52 | default-language: Haskell2010 53 | 54 | if flag(arrow-tr) 55 | build-depends: arrows >=0.2 56 | 57 | Test-suite spec 58 | type: exitcode-stdio-1.0 59 | default-language: Haskell2010 60 | hs-source-dirs: test 61 | main-is: Spec.hs 62 | other-modules: Common.RandomProc, 63 | Types.BasicSpec, 64 | Types.ChoiceSpec, 65 | Types.LoopSpec, 66 | Types.PlanSpec, 67 | Types.RuleSpec, 68 | Types.SwitchSpec, 69 | Types.StepExecutionSpec, 70 | Utils.SourceSpec, 71 | Misc.PumpSpec 72 | build-depends: base >=4.0 && <5.0, mtl >=2.2.1, profunctors >=5.2, QuickCheck >=1.0, hspec >=0.2.0, semigroups >=0.18.1, machinecell 73 | build-tool-depends: hspec-discover:hspec-discover 74 | 75 | Test-suite doctest 76 | type: exitcode-stdio-1.0 77 | default-language: Haskell2010 78 | hs-source-dirs: test 79 | main-is: doctest.hs 80 | build-depends: base >=4.8 && <5.0 81 | , mtl >=2.2.1 && <3 82 | , free >=4.12.3 && <6.0 83 | , semigroups >=0.18.1 && <1 84 | , semigroupoids 85 | , comonad 86 | , profunctors >=5.2 && <6 87 | , transformers >=0.5.0.0 && <1 88 | , doctest >=0.3.0 89 | build-tool-depends: doctest-discover:doctest-discover 90 | 91 | source-repository head 92 | type: git 93 | location: https://github.com/as-capabl/machinecell.git 94 | branch: master 95 | 96 | source-repository this 97 | type: git 98 | location: https://github.com/as-capabl/machinecell.git 99 | tag: release-4.0.1-1 100 | -------------------------------------------------------------------------------- /src/Control/Arrow/Machine.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE Arrows #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE GADTs #-} 8 | 9 | {-| 10 | Module: Control.Arrow.Machine 11 | Description: Contains the main documentation and module imports. 12 | -} 13 | module 14 | Control.Arrow.Machine 15 | ( 16 | -- * Quick introduction 17 | -- $introduction 18 | 19 | -- * Note 20 | -- $note 21 | 22 | -- * Modules 23 | -- | "Control.Arrow.Machine" is good to import qualified, because no operators are exported. 24 | -- 25 | -- Alternatively, you can import libraries below individually, 26 | -- with only "Control.Arrow.Machine.Utils" qualified or identifier specified. 27 | -- 28 | -- Control.Arrow.Machine.Misc.* are not included by default. 29 | -- They are all designed to import qualified. 30 | module Control.Arrow.Machine.ArrowUtil, 31 | module Control.Arrow.Machine.Types, 32 | module Control.Arrow.Machine.Evolution, 33 | module Control.Arrow.Machine.Utils 34 | ) 35 | where 36 | 37 | import Control.Arrow.Machine.ArrowUtil 38 | import Control.Arrow.Machine.Types 39 | import Control.Arrow.Machine.Evolution 40 | import Control.Arrow.Machine.Utils 41 | 42 | -- $setup 43 | -- >>> :set -XArrows 44 | -- >>> import Control.Arrow 45 | -- >>> import Control.Monad.Trans 46 | 47 | -- $introduction 48 | -- As other iteratee or pipe libraries, machinecell abstracts general iteration processes. 49 | -- 50 | -- Here is an example that is a simple iteration over a list. 51 | -- 52 | -- >>> run (evMap (+1)) [1, 2, 3] 53 | -- [2,3,4] 54 | -- 55 | -- In above statement, "`evMap` (+1)" has a type __"ProcessT Identity (Event Int) (Event Int)"__ , 56 | -- which denotes "A stream transducer that takes a series of Int as input, 57 | -- gives a series of Int as output, run on base monad `Identity`." 58 | -- 59 | -- `ProcessT` is the transducer type of machinecell library. 60 | -- 61 | -- = Side effects 62 | -- 63 | -- The first type argurment of `ProcessT` is the underlying monad. 64 | -- Transtucers can have side effects of the type. 65 | -- 66 | -- ProcessT can run the effects as following. 67 | -- 68 | -- >>> runT_ (fire print) [1, 2, 3] 69 | -- 1 70 | -- 2 71 | -- 3 72 | -- 73 | -- Where `fire` makes a transducer that executes side effects for each input. 74 | -- `runT_` is almost same as `run` but discards transducer's output. 75 | -- 76 | -- That is useful in the case rather side effects are main concern. 77 | -- 78 | -- = ProcessT as pipes 79 | -- 80 | -- "ProcessT a (Event b) (Event c)" transducers are actually one-directional composable pipes. 81 | -- 82 | -- They can be constructed from the `Plan` monad. 83 | -- In `Plan` monad context, `await` and `yield` can be used to get and emit values. 84 | -- And actions of base monads can be `lift`ed to the context. 85 | -- 86 | -- Then, resulting processes are composed as `Category` using `(\>\>\>)` operator. 87 | -- 88 | -- >>> :{ 89 | -- let mySource = repeatedly $ 90 | -- do 91 | -- _ <- await 92 | -- yield 1 93 | -- myPipe = construct $ 94 | -- do 95 | -- s1 <- await 96 | -- s2 <- await 97 | -- yield (s1 + s2) 98 | -- mySink = repeatedlyT $ 99 | -- do 100 | -- x <- await 101 | -- lift $ print x 102 | -- in 103 | -- runT_ (mySource >>> myPipe >>> mySink) (repeat ()) 104 | -- :} 105 | -- 2 106 | -- 107 | -- Unlike other pipe libraries, even the source calls `await`. 108 | -- The source awaits dummy input, namely "(repeat ())", and discard input values. 109 | -- 110 | -- Even the input is an infinite list, this program stops when the "pipe" transducer stops. 111 | -- 112 | -- == More details on finalizing 113 | -- 114 | -- Finalizing behavior of transducers obey the following scenario. 115 | -- 116 | -- 1. Signals of type `Event` can carry /end signs/. 117 | -- 2. Most transducers stop when they get an end sign. 118 | -- (Some exceptions can be made by `onEnd` or `catchP`) 119 | -- 3. If `run` function detects an end sign as an output of a running transducer, 120 | -- it stops feeding input values and alternatively feeds end signs. 121 | -- 4. Continue iteration until no more events can be occurred. 122 | -- 123 | -- So "await \`catchP\` some_cleanup" can handle any stop of both upstream and downstream. 124 | -- 125 | -- On the other hand, a plan never gets end sign without calling await. 126 | -- So it is better that even a source calls await. 127 | -- 128 | -- A source that calls await periodically is an "interleaved source". 129 | -- Interleaved sources have a number of advantages. 130 | -- They can be controled their output timings by their upstream, or can be stopped any time. 131 | -- 132 | -- There is another kind of source that doesn't call await, namely "blocking source". 133 | -- 134 | -- see "sources" section of "Control.Arrow.Machine.Utils" documentation. 135 | -- 136 | -- = Arrow composition 137 | -- 138 | -- One of the most attractive feature of machinecell is the /arrow composition/. 139 | -- 140 | -- In addition to `Category`, ProcessT has `Arrow` instance declaration, 141 | -- which allows parallel compositions. 142 | -- 143 | -- If a type has an `Arrow` instance, it can be wrote by ghc extended proc-do notation as following. 144 | -- 145 | -- >>> :{ 146 | -- let f :: ProcessT IO (Event Int) (Event ()) 147 | -- f = proc x -> 148 | -- do 149 | -- -- Process odd integers. 150 | -- odds <- filterEvent odd -< x 151 | -- fire (putStrLn . ("Odd: " ++)) -< show <$> odds 152 | -- -- Process even integers. 153 | -- evens <- filterEvent even -< x 154 | -- fire (putStrLn . ("Even: " ++)) -< show <$> evens 155 | -- in 156 | -- runT_ f [1..10] 157 | -- :} 158 | -- Odd: 1 159 | -- Even: 2 160 | -- Odd: 3 161 | -- Even: 4 162 | -- ... 163 | -- 164 | -- The result implies that two statements that inputs x and their downstreams are 165 | -- executed in parallel. 166 | -- 167 | -- = Behaviours 168 | -- 169 | -- The transducers we have already seen are all have input and output type wrapped by `Event`. 170 | -- We have not taken care of them so far because all of them are cancelled each other. 171 | -- 172 | -- But several built-in transducers provide non-event values like below. 173 | -- 174 | -- @ 175 | -- hold :: ArrowApply a =\> b -\> ProcessT a (Event b) b 176 | -- accum :: ArrowApply a =\> b -\> ProcessT a (Event (b-\>b)) b 177 | -- @ 178 | -- 179 | -- `hold` keeps the last input until a new value is provided. 180 | -- 181 | -- `accum` updates its outputting by applying every input function. 182 | -- 183 | -- According to a knowledge from arrowized FRP(functional reactive programming), 184 | -- values that appear naked in arrow notations are /behaviour/, 185 | -- that means /coutinuous/ time-varying values, 186 | -- whereas /event/ values are /discrete/. 187 | -- 188 | -- Note that all values that can be input, output, or taken effects must be discrete. 189 | -- 190 | -- To use continuous values anyhow interacting the real world, 191 | -- they must be encoded to discrete values. 192 | -- 193 | -- That's done by functor calculations between any existing events. 194 | -- 195 | -- An example is below. 196 | -- 197 | -- >>> :{ 198 | -- let f = proc x -> 199 | -- do 200 | -- y <- accum 0 -< (+) <$> x 201 | -- returnA -< y <$ x 202 | -- in 203 | -- run f [1, 2, 3] 204 | -- :} 205 | -- [1,3,6] 206 | -- 207 | -- `(\<$)` operator discards the value of rhs and only uses that's container structure 208 | -- e.g. 1 \<$ Just "a" =\> Just 1, 1 \<$ Nothing =\> Nothing, 209 | -- 1 \<$ [True, False, undefined] =\> [1, 1, 1]. 210 | -- 211 | -- In this case, the value of y are outputed according to the timing of x. 212 | -- 213 | 214 | 215 | 216 | -- $note 217 | -- = Purity of `ProcessT (-\>)` 218 | -- Since the 1st type parameter of `ProcessT` represents base monad(ArrowApply), 219 | -- "ProcessT (-\>)" is expected to be pure. 220 | -- 221 | -- In other words, the following arrow results the same result for arbitrary f. 222 | -- 223 | -- @ 224 | -- proc x -\> 225 | -- do 226 | -- _ \<- `fit` arr f -\< x 227 | -- g -\< x 228 | -- @ 229 | -- 230 | -- Which is desugared to "fit arr f &&& g \>\>\> arr snd". At least if `Event` constructor is exported, 231 | -- someone can make a counter example. 232 | -- When f is "arr (replicate k) \>\>\> fork" for some integer k and g is "arr (const $ Event ())", 233 | -- g yields ()s for k times. That is because, the result value of arrow "f &&& g" is 234 | -- nothing but "(Event x, Event ())" and its number of yields is k because "Event x" must 235 | -- be yielded k times. 236 | -- 237 | -- This is the reason why the `Event` constructor is hidden. 238 | -- Using exported primitives, it works almost correctly. 239 | -- Event number is conserved by inserting an appropriate number of `NoEvent`s. 240 | -- But there is still a loophole. 241 | -- 242 | -- Under the current implementation, the arrow below behaves like "arr (const $ Event x)". 243 | -- 244 | -- @ 245 | -- proc x -\> hold noEvent -\< ev \<$ ev 246 | -- @ 247 | -- 248 | -- I have an idea to correct this, such that the above arrow always be `NoEvent`. 249 | -- But in the result `Event` is no longer a functor in the meaning of haskell type class. 250 | -- 251 | -- For now, if you never make value of nested event type like "ev \<$ ev", 252 | -- the problem will be avoided. 253 | -- 254 | -- = Looping 255 | -- 256 | -- Although `ProcessT` is an instance of `ArrowLoop`, 257 | -- there is a large limitation. 258 | -- 259 | -- The limitation is, Events mustn't be looped back to upstream. 260 | -- 261 | -- In example below, result is [0, 0, 0, 0], not [1, 2, 3, 4]. 262 | -- 263 | -- >>> :{ 264 | -- let f = proc x -> 265 | -- do 266 | -- rec 267 | -- b <- hold 0 -< y 268 | -- y <- fork -< (\xx -> [xx, xx+1, xx+2, xx+3]) <$> x 269 | -- returnA -< b <$ y 270 | -- in 271 | -- run f [1] 272 | -- :} 273 | -- [0,0,0,0] 274 | -- 275 | -- In general, `Event` values refered at upstream in rec statements are 276 | -- almost always `NoEvent`s. 277 | -- 278 | -- A better way to send events to upstream is, to encode them to behaviours using `dHold`, 279 | -- `dAccum` and so on, then send to upstream in rec statement. 280 | -- 281 | 282 | -------------------------------------------------------------------------------- /src/Control/Arrow/Machine/ArrowUtil.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE Arrows #-} 4 | 5 | #if __GLASGOW_HASKELL__ >= 708 6 | {-# LANGUAGE Safe #-} 7 | #else 8 | {-# LANGUAGE Trustworthy #-} 9 | #endif 10 | 11 | -- | Arrow utilities not related to machinecell library. 12 | module 13 | Control.Arrow.Machine.ArrowUtil ( 14 | -- * Arrow construction helper 15 | ary0, 16 | ary1, 17 | ary2, 18 | ary3, 19 | ary4, 20 | ary5, 21 | 22 | kleisli, 23 | kleisli0, 24 | kleisli2, 25 | kleisli3, 26 | kleisli4, 27 | kleisli5, 28 | 29 | unArrowMonad, 30 | arrowMonad, 31 | 32 | #if defined(MIN_VERSION_arrows) 33 | reading, 34 | statefully, 35 | #endif 36 | 37 | -- * Arrow construction helper (Lens) 38 | -- |Lens Isomorphisms between arrows and monads. 39 | -- All definitions are defined arrow->monad directions. 40 | -- Use with lens operator (^.) and (#). 41 | kl, 42 | am, 43 | #if defined(MIN_VERSION_arrows) 44 | rd, 45 | #endif 46 | uc0, 47 | uc1, 48 | uc2, 49 | uc3, 50 | uc4, 51 | uc5, 52 | 53 | -- * Custom arrow syntax helper 54 | -- |To absorve arrow stack signature difference bettween ghc 7.8 and older. 55 | AS, 56 | toAS, 57 | fromAS, 58 | 59 | #if defined(MIN_VERSION_arrows) 60 | elimR 61 | #endif 62 | ) 63 | where 64 | 65 | import Prelude hiding ((.), id) 66 | import Control.Category 67 | import Control.Arrow 68 | #if defined(MIN_VERSION_arrows) 69 | import Control.Arrow.Operations (store, fetch) 70 | import Control.Arrow.Transformer.Reader 71 | import Control.Arrow.Transformer.State 72 | import Control.Monad.Reader (ReaderT(..), runReaderT) 73 | import Control.Monad.State (StateT, runStateT) 74 | #endif 75 | import Data.Profunctor 76 | 77 | 78 | #if __GLASGOW_HASKELL__ >= 708 79 | 80 | type AS e = (e, ()) 81 | 82 | toAS :: e -> AS e 83 | toAS e = (e, ()) 84 | 85 | fromAS :: AS e -> e 86 | fromAS = fst 87 | 88 | #else 89 | 90 | type AS e = e 91 | 92 | toAS :: e -> AS e 93 | toAS = id 94 | 95 | fromAS :: AS e -> e 96 | fromAS = id 97 | 98 | #endif 99 | 100 | ary0 :: 101 | (forall p q. (p -> m q) -> a p q) -> 102 | m b -> 103 | a () b 104 | ary0 f = f . const 105 | 106 | ary1 :: 107 | (forall p q. (p -> m q) -> a p q) -> 108 | (a1 -> m b) -> 109 | a a1 b 110 | ary1 f = f 111 | 112 | ary2 :: 113 | (forall p q. (p -> m q) -> a p q) -> 114 | (a1 -> a2 -> m b) -> 115 | a (a1, a2) b 116 | ary2 f fmx = f $ \(x1, x2) -> fmx x1 x2 117 | 118 | ary3 :: 119 | (forall p q. (p -> m q) -> a p q) -> 120 | (a1 -> a2 -> a3 -> m b) -> 121 | a (a1, a2, a3) b 122 | ary3 f fmx = f $ \(x1, x2, x3) -> fmx x1 x2 x3 123 | 124 | ary4 :: 125 | (forall p q. (p -> m q) -> a p q) -> 126 | (a1 -> a2 -> a3 -> a4 -> m b) -> 127 | a (a1, a2, a3, a4) b 128 | ary4 f fmx = f $ \(x1, x2, x3, x4) -> fmx x1 x2 x3 x4 129 | 130 | ary5 :: 131 | (forall p q. (p -> m q) -> a p q) -> 132 | (a1 -> a2 -> a3 -> a4 -> a5 -> m b) -> 133 | a (a1, a2, a3, a4, a5) b 134 | ary5 f fmx = f $ \(x1, x2, x3, x4, x5) -> fmx x1 x2 x3 x4 x5 135 | 136 | 137 | kleisli :: Monad m => (a->m b) -> Kleisli m a b 138 | kleisli = ary1 Kleisli 139 | 140 | kleisli0 :: Monad m => m b -> Kleisli m () b 141 | kleisli0 = ary0 Kleisli 142 | 143 | kleisli2 :: Monad m => (a1 -> a2 -> m b) -> Kleisli m (a1, a2) b 144 | kleisli2 = ary2 Kleisli 145 | 146 | kleisli3 :: Monad m => (a1 -> a2 -> a3 -> m b) -> Kleisli m (a1, a2, a3) b 147 | kleisli3 = ary3 Kleisli 148 | 149 | kleisli4 :: Monad m => (a1 -> a2 -> a3 -> a4 -> m b) -> Kleisli m (a1, a2, a3, a4) b 150 | kleisli4 = ary4 Kleisli 151 | 152 | kleisli5 :: Monad m => (a1 -> a2 -> a3 -> a4 -> a5 -> m b) -> Kleisli m (a1, a2, a3, a4, a5) b 153 | kleisli5 = ary5 Kleisli 154 | 155 | 156 | unArrowMonad :: 157 | ArrowApply a => 158 | (p -> ArrowMonad a q) -> a p q 159 | unArrowMonad fmx = proc x -> case fmx x of { ArrowMonad a -> a } -<< () 160 | 161 | arrowMonad :: 162 | ArrowApply a => 163 | a p q -> p -> ArrowMonad a q 164 | arrowMonad af x = ArrowMonad $ arr (const x) >>> af 165 | 166 | 167 | #if defined(MIN_VERSION_arrows) 168 | reading :: 169 | (Monad m, Arrow a) => 170 | (forall p q. (p->m q)->a p q) -> 171 | (b -> ReaderT r m c) -> 172 | ReaderArrow r a b c 173 | reading f mr = ReaderArrow . f $ uncurry (runReaderT . mr) 174 | 175 | statefully :: 176 | (Monad m, Arrow a) => 177 | (forall p q. (p->m q)->a p q) -> 178 | (b -> StateT s m c) -> 179 | StateArrow s a b c 180 | statefully f ms = proc x -> 181 | do 182 | s <- fetch -< () 183 | (y, s') <- liftState (f $ \(x, s) -> runStateT (ms x) s) -< (x, s) 184 | store -< s' 185 | returnA -< y 186 | #endif 187 | 188 | type MyIso s t a b = 189 | forall p f. (Profunctor p, Functor f) => 190 | p a (f b) -> p s (f t) 191 | 192 | type MyIso' s a = MyIso s s a a 193 | 194 | myIso :: 195 | (s -> a) -> (b -> t) -> MyIso s t a b 196 | myIso sa bt = dimap sa (fmap bt) 197 | 198 | -- |Isomorphsm between m and (Kleisli m) 199 | kl :: 200 | MyIso' (a -> m b) (Kleisli m a b) 201 | kl = myIso Kleisli runKleisli 202 | 203 | -- |Isomorphism between (ArrowMonad a) and a 204 | am :: 205 | ArrowApply a => 206 | MyIso' (b -> ArrowMonad a c) (a b c) 207 | am = myIso unArrowMonad arrowMonad 208 | 209 | #if defined(MIN_VERSION_arrows) 210 | rd :: 211 | (Arrow a) => 212 | (forall p q. MyIso' (p -> m q) (a p q)) -> 213 | MyIso' (b -> ReaderT r m c) (ReaderArrow r a b c) 214 | rd f = e . f . g 215 | where 216 | e = myIso 217 | (\frmy -> uncurry (runReaderT . frmy)) 218 | (\fmy -> ReaderT . (curry fmy)) 219 | g = myIso ReaderArrow runReader 220 | #endif 221 | 222 | uc0 :: MyIso' (m b) (() -> m b) 223 | uc0 = myIso const ($()) 224 | 225 | uc1 :: MyIso' (a1 -> m b) (a1 -> m b) 226 | uc1 = id 227 | 228 | uc2 :: MyIso' (a1 -> a2 -> m b) ((a1, a2) -> m b) 229 | uc2 = myIso 230 | (\f (a1, a2) -> f a1 a2) 231 | (\f a1 a2 -> f (a1, a2)) 232 | 233 | uc3 :: MyIso' (a1 -> a2 -> a3 -> m b) ((a1, a2, a3) -> m b) 234 | uc3 = myIso 235 | (\f (a1, a2, a3) -> f a1 a2 a3) 236 | (\f a1 a2 a3 -> f (a1, a2, a3)) 237 | 238 | uc4 :: MyIso' (a1 -> a2 -> a3 -> a4 -> m b) ((a1, a2, a3, a4) -> m b) 239 | uc4 = myIso 240 | (\f (a1, a2, a3, a4) -> f a1 a2 a3 a4) 241 | (\f a1 a2 a3 a4 -> f (a1, a2, a3, a4)) 242 | 243 | uc5 :: MyIso' (a1 -> a2 -> a3 -> a4 -> a5 -> m b) ((a1, a2, a3, a4, a5) -> m b) 244 | uc5 = myIso 245 | (\f (a1, a2, a3, a4, a5) -> f a1 a2 a3 a4 a5) 246 | (\f a1 a2 a3 a4 a5 -> f (a1, a2, a3, a4, a5)) 247 | 248 | #if defined(MIN_VERSION_arrows) 249 | -- |Alternate for `elimReader` that can be used with both ghc 7.8 and older. 250 | elimR :: 251 | ArrowAddReader r a a' => 252 | a (AS e) b -> a' (e, AS r) b 253 | elimR f = 254 | second (arr $ fromAS) >>> elimReader (arr toAS >>> f) 255 | #endif 256 | 257 | -------------------------------------------------------------------------------- /src/Control/Arrow/Machine/Evolution.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | {-# LANGUAGE Arrows #-} 3 | 4 | module 5 | Control.Arrow.Machine.Evolution 6 | ( 7 | switchAfter, 8 | dSwitchAfter, 9 | kSwitchAfter, 10 | dkSwitchAfter, 11 | gSwitchAfter, 12 | dgSwitchAfter, 13 | finishWith, 14 | evolve 15 | ) 16 | where 17 | 18 | import Prelude hiding (id, (.)) 19 | import Data.Void 20 | import Control.Category 21 | import Control.Arrow.Machine.Types 22 | import Control.Monad.Cont (cont, runCont) 23 | 24 | {-# INLINE switchAfter #-} 25 | switchAfter :: 26 | Monad m => 27 | ProcessT m i (o, Event r) -> 28 | Evolution i o m r 29 | switchAfter pf = Evolution $ cont $ switch pf 30 | 31 | {-# INLINE dSwitchAfter #-} 32 | dSwitchAfter :: 33 | Monad m => 34 | ProcessT m i (o, Event r) -> 35 | Evolution i o m r 36 | dSwitchAfter pf = Evolution $ cont $ dSwitch pf 37 | 38 | {-# INLINE kSwitchAfter #-} 39 | kSwitchAfter :: 40 | Monad m => 41 | ProcessT m (i, o) (Event r) -> 42 | ProcessT m i o -> 43 | Evolution i o m (ProcessT m i o, r) 44 | kSwitchAfter test pf = Evolution $ cont $ kSwitch pf test . curry 45 | 46 | {-# INLINE dkSwitchAfter #-} 47 | dkSwitchAfter :: 48 | Monad m => 49 | ProcessT m (i, o) (Event r) -> 50 | ProcessT m i o -> 51 | Evolution i o m (ProcessT m i o, r) 52 | dkSwitchAfter test pf = Evolution $ cont $ dkSwitch pf test . curry 53 | 54 | {-# INLINE gSwitchAfter #-} 55 | gSwitchAfter :: 56 | Monad m => 57 | ProcessT m i (p, r) -> 58 | ProcessT m (q, r) (o, Event t) -> 59 | ProcessT m p q -> 60 | Evolution i o m (ProcessT m p q, t) 61 | gSwitchAfter pre post pf = Evolution $ cont $ gSwitch pre pf post . curry 62 | 63 | {-# INLINE dgSwitchAfter #-} 64 | dgSwitchAfter :: 65 | Monad m => 66 | ProcessT m i (p, r) -> 67 | ProcessT m (q, r) (o, Event t) -> 68 | ProcessT m p q -> 69 | Evolution i o m (ProcessT m p q, t) 70 | dgSwitchAfter pre post pf = Evolution $ cont $ dgSwitch pre pf post . curry 71 | 72 | {-# INLINE finishWith #-} 73 | finishWith :: 74 | Monad m => 75 | ProcessT m i o -> 76 | Evolution i o m r 77 | finishWith pf = Evolution $ cont $ const pf 78 | 79 | {-# INLINE evolve #-} 80 | evolve :: 81 | Evolution i o m Void -> 82 | ProcessT m i o 83 | evolve ev = runCont (runEvolution ev) absurd 84 | -------------------------------------------------------------------------------- /src/Control/Arrow/Machine/Misc/Discrete.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE Arrows #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | 8 | 9 | module 10 | Control.Arrow.Machine.Misc.Discrete 11 | ( 12 | -- * Discrete type 13 | -- $type 14 | 15 | T(), 16 | updates, 17 | value, 18 | 19 | arr, 20 | arr2, 21 | arr3, 22 | arr4, 23 | arr5, 24 | 25 | constant, 26 | unsafeConstant, 27 | hold, 28 | accum, 29 | fromEq, 30 | 31 | edge, 32 | asUpdater, 33 | kSwitch, 34 | dkSwitch, 35 | 36 | -- * Discrete algebra 37 | -- $alg 38 | 39 | Alg(Alg), 40 | eval, 41 | refer 42 | ) 43 | where 44 | 45 | import Prelude hiding (id, (.)) 46 | import Control.Category 47 | import Control.Arrow hiding (arr) 48 | import Control.Applicative 49 | import qualified Control.Arrow as Arr 50 | import qualified Control.Arrow.Machine as P 51 | import Data.Monoid (mconcat, mappend) 52 | 53 | {-$type 54 | This module should be imported manually. Qualified import is recommended. 55 | 56 | This module provides an abstraction that continuous values with 57 | finite number of changing points. 58 | 59 | >>> import qualified Control.Arrow.Machine.Misc.Discrete as D 60 | >>> P.run (D.hold "apple" >>> D.arr reverse >>> D.edge) ["orange", "grape"] 61 | ["elppa","egnaro","eparg"] 62 | 63 | In above example, input data of "reverse" is continuous. 64 | But the "D.edge" transducer extracts changing points without calling string comparison. 65 | 66 | This is possible because the intermediate type `T` has the information of changes 67 | together with the value information. 68 | -} 69 | 70 | -- |The discrete signal type. 71 | data T a = T { 72 | updates :: (P.Event ()), 73 | value :: a 74 | } 75 | 76 | makeT :: 77 | Monad m => 78 | P.ProcessT m (P.Event (), b) (T b) 79 | makeT = Arr.arr $ uncurry T 80 | 81 | 82 | stimulate :: 83 | Monad m => 84 | P.ProcessT m b (T c) -> 85 | P.ProcessT m b (T c) 86 | stimulate sf = P.dgSwitch (id &&& id) sf body $ \sf' _ -> sf' 87 | where 88 | body = proc (dy, _) -> 89 | do 90 | n <- P.now -< () 91 | disc <- makeT -< (updates dy `mappend` n, value dy) 92 | returnA -< (disc, updates disc) 93 | 94 | arr :: 95 | Monad m => 96 | (b->c) -> 97 | P.ProcessT m (T b) (T c) 98 | arr f = 99 | Arr.arr $ \(T ev x) -> 100 | T ev (f x) 101 | 102 | arr2 :: 103 | Monad m => 104 | (b1->b2->c) -> 105 | P.ProcessT m (T b1, T b2) (T c) 106 | arr2 f = 107 | Arr.arr $ \(T ev1 x1, T ev2 x2) -> 108 | T (mconcat [ev1, ev2]) (f x1 x2) 109 | 110 | arr3 :: 111 | Monad m => 112 | (b1->b2->b3->c) -> 113 | P.ProcessT m (T b1, T b2, T b3) (T c) 114 | arr3 f = 115 | Arr.arr $ \(T ev1 x1, T ev2 x2, T ev3 x3) -> 116 | T (mconcat [ev1, ev2, ev3]) (f x1 x2 x3) 117 | 118 | arr4 :: 119 | Monad m => 120 | (b1->b2->b3->b4->c) -> 121 | P.ProcessT m (T b1, T b2, T b3, T b4) (T c) 122 | arr4 f = 123 | Arr.arr $ \(T ev1 x1, T ev2 x2, T ev3 x3, T ev4 x4) -> 124 | T (mconcat [ev1, ev2, ev3, ev4]) (f x1 x2 x3 x4) 125 | 126 | arr5 :: 127 | Monad m => 128 | (b1->b2->b3->b4->b5->c) -> 129 | P.ProcessT m (T b1, T b2, T b3, T b4, T b5) (T c) 130 | arr5 f = 131 | Arr.arr $ \(T ev1 x1, T ev2 x2, T ev3 x3, T ev4 x4, T ev5 x5) -> 132 | T (mconcat [ev1, ev2, ev3, ev4, ev5]) (f x1 x2 x3 x4 x5) 133 | 134 | constant:: 135 | Monad m => 136 | c -> 137 | P.ProcessT m b (T c) 138 | constant x = 139 | (P.now &&& Arr.arr (const x)) >>> makeT 140 | 141 | -- |Constant without initial notifications. 142 | -- Users must manage initialization manually. 143 | unsafeConstant:: 144 | Monad m => 145 | c -> 146 | P.ProcessT m b (T c) 147 | unsafeConstant x = 148 | (pure P.noEvent &&& Arr.arr (const x)) >>> makeT 149 | 150 | onUpdate :: 151 | Monad m => 152 | P.ProcessT m (P.Event b) (P.Event ()) 153 | onUpdate = proc ev -> 154 | do 155 | n <- P.now -< () 156 | returnA -< n `mappend` P.collapse ev 157 | 158 | hold :: 159 | Monad m => 160 | b -> 161 | P.ProcessT m (P.Event b) (T b) 162 | hold i = 163 | (onUpdate &&& P.hold i) >>> makeT 164 | 165 | accum :: 166 | Monad m => 167 | b -> 168 | P.ProcessT m (P.Event (b->b)) (T b) 169 | accum i = 170 | (onUpdate &&& P.accum i) >>> makeT 171 | 172 | fromEq :: 173 | (Monad m, Eq b) => 174 | P.ProcessT m b (T b) 175 | fromEq = proc x -> 176 | do 177 | ev <- P.edge -< x 178 | returnA -< T (P.collapse ev) x 179 | 180 | edge :: 181 | Monad m => 182 | P.ProcessT m (T b) (P.Event b) 183 | edge = Arr.arr $ \(T ev x) -> x <$ ev 184 | 185 | asUpdater :: 186 | Monad m => 187 | (b -> m c) -> 188 | P.ProcessT m (T b) (P.Event c) 189 | asUpdater fmx = edge >>> P.fire fmx 190 | 191 | 192 | kSwitch :: 193 | Monad m => 194 | P.ProcessT m b (T c) -> 195 | P.ProcessT m (b, T c) (P.Event t) -> 196 | (P.ProcessT m b (T c) -> t -> P.ProcessT m b (T c)) -> 197 | P.ProcessT m b (T c) 198 | kSwitch sf test k = P.kSwitch sf test (\sf' x -> stimulate (k sf' x)) 199 | 200 | dkSwitch :: 201 | Monad m => 202 | P.ProcessT m b (T c) -> 203 | P.ProcessT m (b, T c) (P.Event t) -> 204 | (P.ProcessT m b (T c) -> t -> P.ProcessT m b (T c)) -> 205 | P.ProcessT m b (T c) 206 | dkSwitch sf test k = P.dkSwitch sf test (\sf' x -> stimulate (k sf' x)) 207 | 208 | 209 | {-$alg 210 | Calculations between discrete types. 211 | 212 | An example is below. 213 | 214 | @ 215 | holdAdd :: 216 | (Monad m, Num b) => 217 | ProcessT m (Event b, Event b) (Discrete b) 218 | holdAdd = proc (evx, evy) -> 219 | do 220 | x <- D.hold 0 -< evx 221 | y <- D.hold 0 -< evy 222 | D.eval (refer fst + refer snd) -< (x, y) 223 | @ 224 | 225 | The last line is equivalent to "arr2 (+) -< (x, y)". 226 | Using Alg, you can construct more complex calculations 227 | between discrete signals. 228 | -} 229 | 230 | -- |Discrete algebra type. 231 | newtype Alg m i o = 232 | Alg { eval :: P.ProcessT m i (T o) } 233 | 234 | refer :: 235 | Monad m => 236 | (e -> T b) -> Alg m e b 237 | refer = Alg . Arr.arr 238 | 239 | instance 240 | Monad m => Functor (Alg m i) 241 | where 242 | fmap f alg = Alg $ eval alg >>> arr f 243 | 244 | instance 245 | Monad m => Applicative (Alg m i) 246 | where 247 | pure = Alg . constant 248 | af <*> aa = Alg $ (eval af &&& eval aa) >>> arr2 ($) 249 | 250 | instance 251 | (Monad m, Num o) => 252 | Num (Alg m i o) 253 | where 254 | abs = fmap abs 255 | signum = fmap signum 256 | fromInteger = pure . fromInteger 257 | (+) = liftA2 (+) 258 | (-) = liftA2 (-) 259 | (*) = liftA2 (*) 260 | 261 | -------------------------------------------------------------------------------- /src/Control/Arrow/Machine/Misc/Exception.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | module 4 | Control.Arrow.Machine.Misc.Exception 5 | ( 6 | -- * Variations of catchP 7 | -- $variation 8 | 9 | catch, 10 | handle, 11 | bracket, 12 | bracket_, 13 | bracketOnError, 14 | finally, 15 | onException 16 | ) 17 | where 18 | 19 | import Control.Arrow.Machine.Types 20 | 21 | 22 | {-$variation 23 | This module provides variations of catchP. 24 | 25 | If you use this module together with "Control.Exception" module of base package, 26 | import this package qualified. 27 | -} 28 | 29 | catch :: Monad m => 30 | PlanT i o m a -> PlanT i o m a -> PlanT i o m a 31 | 32 | catch = catchP 33 | 34 | 35 | handle :: Monad m => 36 | PlanT i o m a -> PlanT i o m a -> PlanT i o m a 37 | 38 | handle = flip catch 39 | 40 | 41 | bracket :: Monad m => 42 | PlanT i o m a -> (a -> PlanT i o m b)-> (a -> PlanT i o m c) -> PlanT i o m c 43 | bracket before after thing = 44 | do 45 | a <- before 46 | r <- thing a `catch` (after a >> stop) 47 | _ <- after a 48 | return r 49 | 50 | 51 | bracket_ :: Monad m => 52 | PlanT i o m a -> PlanT i o m b-> PlanT i o m c -> PlanT i o m c 53 | bracket_ before after thing = 54 | do 55 | _ <- before 56 | r <- thing `catch` (after >> stop) 57 | _ <- after 58 | return r 59 | 60 | 61 | bracketOnError :: Monad m => 62 | PlanT i o m a -> (a -> PlanT i o m b)-> (a -> PlanT i o m c) -> PlanT i o m c 63 | bracketOnError before after thing = 64 | do 65 | a <- before 66 | r <- thing a `catch` (after a >> stop) 67 | return r 68 | 69 | 70 | finally :: Monad m => 71 | PlanT i o m a -> PlanT i o m b-> PlanT i o m a 72 | finally thing after = 73 | do 74 | r <- thing `catch` (after >> stop) 75 | _ <- after 76 | return r 77 | 78 | 79 | onException :: Monad m => 80 | PlanT i o m a -> PlanT i o m b-> PlanT i o m a 81 | onException thing after = 82 | do 83 | thing `catch` (after >> stop) 84 | 85 | 86 | -------------------------------------------------------------------------------- /src/Control/Arrow/Machine/Misc/Pump.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE Arrows #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | 8 | module 9 | Control.Arrow.Machine.Misc.Pump 10 | ( 11 | -- *Pump 12 | -- | This module should be imported manually. 13 | -- 14 | -- `intake` records events and `outlet` emits recorded events. 15 | -- 16 | -- Tipically they are used with rec statement. 17 | -- 18 | -- `clock` arguments are needed to drive a `Pump`. 19 | -- For a pair of `intake` and `outlet`, `clock` arguments must point the 20 | -- same event stream. 21 | Duct(), 22 | intake, 23 | outlet 24 | ) 25 | where 26 | 27 | import Prelude hiding (id, (.)) 28 | import Data.Functor ((<$), (<$>)) 29 | import Control.Category 30 | import Control.Arrow 31 | import qualified Control.Arrow.Machine as P 32 | import Data.Monoid (Endo(Endo), mappend, appEndo) 33 | 34 | newtype Duct a = Duct (Endo [a]) 35 | 36 | oneMore :: 37 | Monad m => 38 | P.ProcessT m (P.Event ()) (P.Event ()) 39 | oneMore = proc ev -> 40 | do 41 | ed <- P.onEnd -< ev 42 | P.gather -< [ev, ed] 43 | 44 | intake :: 45 | Monad m => 46 | P.ProcessT m (P.Event b, P.Event ()) (Duct b) 47 | intake = proc (ev, clock) -> 48 | do 49 | cl2 <- oneMore -< clock 50 | append <- returnA -< (\x y -> y `mappend` Endo (x:)) <$> ev 51 | e <- P.dAccum (Endo id) <<< P.gather -< [ (const $ Endo id) <$ cl2, append ] 52 | returnA -< Duct e 53 | 54 | outlet :: 55 | Monad m => 56 | P.ProcessT m (Duct b, P.Event ()) (P.Event b) 57 | outlet = proc (~(Duct dct), clock) -> 58 | do 59 | cl2 <- oneMore -< clock 60 | P.fork -< appEndo dct [] <$ cl2 61 | 62 | -------------------------------------------------------------------------------- /src/Control/Arrow/Machine/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} -- Safe if eliminate GeneralizedNewtypeInstance 2 | {-# LANGUAGE Arrows #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE BangPatterns #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE RecordWildCards #-} 10 | {-# LANGUAGE MultiWayIf #-} 11 | {-# LANGUAGE TupleSections #-} 12 | {-# LANGUAGE GADTs #-} 13 | {-# LANGUAGE FlexibleContexts #-} 14 | {-# LANGUAGE ScopedTypeVariables #-} 15 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 16 | {-# LANGUAGE KindSignatures #-} 17 | 18 | module 19 | Control.Arrow.Machine.Types 20 | ( 21 | -- * Stream transducer type 22 | ProcessT(), 23 | ProcessA, 24 | 25 | -- * Event type and utility 26 | Occasional' (..), 27 | Occasional (..), 28 | Event (), 29 | noEvent, 30 | end, 31 | ZeroEvent(..), 32 | condEvent, 33 | filterEvent, 34 | filterJust, 35 | filterLeft, 36 | filterRight, 37 | splitEvent, 38 | evMap, 39 | 40 | -- * Coroutine monad 41 | -- | Procedural coroutine monad that can await or yield values. 42 | -- 43 | -- Coroutines can be encoded to machines by `constructT` or so on and 44 | -- then put into `ProcessT` compositions. 45 | PlanT(..), 46 | Plan, 47 | 48 | MonadAwait (..), 49 | MonadYield (..), 50 | MonadStop (..), 51 | catchP, 52 | 53 | stopped, 54 | muted, 55 | 56 | -- * Constructing machines from plans 57 | constructT, 58 | repeatedlyT, 59 | 60 | construct, 61 | repeatedly, 62 | 63 | -- * Evolution monad 64 | -- | Time-evolution monad, or generalized plan monad. 65 | Evolution(..), 66 | packProc, 67 | awaitProc, 68 | yieldProc, 69 | 70 | -- * Running machines (at once) 71 | runT, 72 | runT_, 73 | run, 74 | run_, 75 | 76 | -- * Running machines (step-by-step) 77 | stepRun, 78 | stepYield, 79 | 80 | -- * Primitive machines - switches 81 | -- | Switches inspired by the Yampa library. 82 | -- Signature is almost same, but collection requirement is not only 'Functor', 83 | -- but 'Tv.Traversable'. This is because of side effects. 84 | switch, 85 | dSwitch, 86 | rSwitch, 87 | drSwitch, 88 | kSwitch, 89 | dkSwitch, 90 | gSwitch, 91 | dgSwitch, 92 | pSwitch, 93 | pSwitchB, 94 | dpSwitch, 95 | dpSwitchB, 96 | rpSwitch, 97 | rpSwitchB, 98 | drpSwitch, 99 | drpSwitchB, 100 | par, 101 | parB, 102 | 103 | -- * Primitive machines - other safe primitives 104 | fit, 105 | fitW, 106 | 107 | -- * Primitive machines - unsafe 108 | unsafeExhaust, 109 | ) 110 | where 111 | 112 | import qualified Control.Category as Cat 113 | import Data.Profunctor (Profunctor, dimap, rmap) 114 | import Data.Void 115 | import Control.Arrow 116 | import Control.Monad 117 | import Control.Monad.Trans 118 | import Control.Monad.State.Strict 119 | import Control.Monad.Reader 120 | import Control.Monad.Writer hiding ((<>)) 121 | import Control.Monad.Identity 122 | import Control.Monad.Trans.Cont 123 | import Control.Applicative 124 | import qualified Data.Foldable as Fd 125 | import Data.Traversable as Tv 126 | import Data.Semigroup (Semigroup ((<>))) 127 | import Data.Maybe (fromMaybe, isNothing, isJust) 128 | import qualified Control.Monad.Trans.Free.Church as F 129 | import GHC.Exts (build) 130 | 131 | 132 | -- | To get multiple outputs by one input, the `Phase` parameter is introduced. 133 | -- 134 | -- Once a value `Feed`ed, the machine is `Sweep`ed until it `Suspend`s. 135 | data Phase = Feed | Sweep | Suspend deriving (Eq, Show) 136 | 137 | instance 138 | Semigroup Phase 139 | where 140 | (<>) Feed _ = Feed 141 | (<>) _ Feed = Feed 142 | (<>) Suspend _ = Suspend 143 | (<>) _ Suspend = Suspend 144 | (<>) Sweep Sweep = Sweep 145 | 146 | instance 147 | Monoid Phase 148 | where 149 | mempty = Sweep 150 | 151 | mappend = (<>) 152 | 153 | 154 | type ProcType a b c = ProcessT a b c 155 | 156 | class Stepper m b c s | s -> m, s -> b, s -> c 157 | where 158 | feed :: s -> b -> m (c, s) 159 | sweep :: s -> b -> m (Maybe c, s) 160 | suspend :: s -> b -> c 161 | 162 | -- | The stream transducer arrow. 163 | -- 164 | -- To construct `ProcessT` instances, use `Control.Arrow.Machine.Plan.Plan`, 165 | -- `arr`, functions declared in `Control.Arrow.Machine.Utils`, 166 | -- or arrow combinations of them. 167 | -- 168 | -- See an introduction at "Control.Arrow.Machine" documentation. 169 | data ProcessT m b c = ProcessT { 170 | paFeed :: b -> m (c, ProcessT m b c), 171 | paSweep :: b -> m (Maybe c, ProcessT m b c), 172 | paSuspend :: !(b -> c) 173 | } 174 | 175 | -- | Isomorphic to ProcessT when 'a' is ArrowApply. 176 | type ProcessA a = ProcessT (ArrowMonad a) 177 | 178 | instance 179 | Stepper a b c (ProcessT a b c) 180 | where 181 | feed = paFeed 182 | sweep = paSweep 183 | suspend = paSuspend 184 | 185 | toProcessT :: 186 | (Monad m, Stepper m b c s) => 187 | s -> ProcessT m b c 188 | toProcessT s = ProcessT { 189 | paFeed = liftM (second toProcessT) . feed s, 190 | paSweep = liftM (second toProcessT) . sweep s, 191 | paSuspend = suspend s 192 | } 193 | {-# INLINE[2] toProcessT #-} 194 | 195 | -- For internal use 196 | class 197 | (Applicative f, Monad f) => ProcessHelper f 198 | where 199 | step :: 200 | (Monad m, Stepper m b c s) => 201 | s -> b -> m (f c, s) 202 | helperToMaybe :: f a -> Maybe a 203 | weakly :: a -> f a 204 | 205 | compositeStep :: 206 | (Monad m, Stepper m b p s1, Stepper m p c s2) => 207 | s1 -> s2 -> 208 | b -> m (f c, s1, s2) 209 | 210 | 211 | instance 212 | ProcessHelper Identity 213 | where 214 | step pa = liftM (first Identity) . feed pa 215 | helperToMaybe = Just . runIdentity 216 | weakly = Identity 217 | compositeStep sf test x = 218 | do 219 | (y, sf') <- feed sf x 220 | (z, test') <- feed test y 221 | return (return z, sf', test') 222 | 223 | instance 224 | ProcessHelper Maybe 225 | where 226 | step = sweep 227 | helperToMaybe = id 228 | weakly _ = Nothing 229 | compositeStep sf0 test0 x = 230 | do 231 | let y = suspend sf0 x 232 | (mt, test') <- sweep test0 y 233 | case mt 234 | of 235 | Just t -> return (Just t, sf0, test') 236 | Nothing -> next sf0 test' 237 | 238 | where 239 | next sf test = 240 | do 241 | (my, sf') <- sweep sf x 242 | case my 243 | of 244 | Just y -> next2 y sf' test 245 | Nothing -> return (Nothing, sf', test) 246 | 247 | next2 y sf test = 248 | do 249 | (t, test') <- feed test y 250 | return (Just t, sf, test') 251 | 252 | makePA :: 253 | Monad m => 254 | (forall f. ProcessHelper f => 255 | b -> m (f c, ProcessT m b c)) -> 256 | (b -> c) -> 257 | ProcessT m b c 258 | makePA h !sus = ProcessT { 259 | paFeed = liftM (first runIdentity) . h, 260 | paSweep = h, 261 | paSuspend = sus 262 | } 263 | 264 | 265 | data CompositeStep m b c s1 s2 266 | where 267 | CompositeStep :: 268 | (Stepper m b p s1, Stepper m p c s2) => 269 | s1 -> s2 -> 270 | CompositeStep m b c s1 s2 271 | 272 | instance 273 | Monad m => Stepper m b c (CompositeStep m b c s1 s2) 274 | where 275 | feed (CompositeStep s1 s2) x = 276 | do 277 | (fz, s1', s2') <- compositeStep s1 s2 x 278 | return (runIdentity fz, CompositeStep s1' s2') 279 | sweep (CompositeStep s1 s2) x = 280 | do 281 | (fz, s1', s2') <- compositeStep s1 s2 x 282 | return (fz, CompositeStep s1' s2') 283 | suspend (CompositeStep s1 s2) = 284 | suspend s2 . suspend s1 285 | 286 | 287 | data IDStep m b c 288 | where 289 | IDStep :: IDStep (m :: * -> *) b b 290 | 291 | instance 292 | Monad m => Stepper m b c (IDStep m b c) 293 | where 294 | feed IDStep x = return (x, IDStep) 295 | sweep IDStep _ = return (Nothing, IDStep) 296 | suspend IDStep = id 297 | 298 | newtype ArrStep (m :: * -> *) b c = ArrStep (b -> c) 299 | 300 | instance 301 | Monad m => Stepper m b c (ArrStep m b c) 302 | where 303 | feed (ArrStep f) x = return (f x, ArrStep f) 304 | sweep (ArrStep f) _ = return (Nothing, ArrStep f) 305 | suspend (ArrStep f) = f 306 | 307 | 308 | data ParStep m b c s1 s2 309 | where 310 | ParStep :: 311 | (Stepper m b1 c1 s1, Stepper m b2 c2 s2) => 312 | s1 -> s2 -> 313 | ParStep m (b1, b2) (c1, c2) s1 s2 314 | 315 | instance 316 | Monad m => Stepper m b c (ParStep m b c s1 s2) 317 | where 318 | feed (ParStep f g) (x1, x2) = 319 | do 320 | (y1, f') <- feed f x1 321 | (y2, g') <- feed g x2 322 | return ((y1, y2), ParStep f' g') 323 | sweep (ParStep f g) (x1, x2) = 324 | do 325 | (my1, f') <- sweep f x1 326 | (my2, g') <- sweep g x2 327 | let y1 = fromMaybe (suspend f' x1) my1 -- suspend f ? 328 | y2 = fromMaybe (suspend g' x2) my2 329 | r = if (isNothing my1 && isNothing my2) then Nothing else Just (y1, y2) 330 | return (r, ParStep f' g') 331 | suspend (ParStep f g) = suspend f *** suspend g 332 | 333 | 334 | -- |Natural transformation 335 | fit :: 336 | (Monad m, Monad m') => 337 | (forall p. m p -> m' p) -> 338 | ProcessT m b c -> ProcessT m' b c 339 | fit f pa = 340 | arr Identity >>> 341 | fitW runIdentity (\ar (Identity x) -> f (ar x)) pa 342 | 343 | -- |Experimental: more general fit. 344 | -- 345 | -- Should w be a comonad? 346 | fitW :: (Monad m, Monad m', Functor w) => 347 | (forall p. w p -> p) -> 348 | (forall p q. (p -> m q) -> w p -> m' q) -> 349 | ProcessT m b c -> ProcessT m' (w b) c 350 | fitW extr f pa = makePA 351 | (liftM (second $ fitW extr f) . f (step pa)) 352 | (extr >>> suspend pa) 353 | 354 | instance 355 | Monad m => Profunctor (ProcessT m) 356 | where 357 | dimap = dimapProc 358 | {-# INLINE dimap #-} 359 | 360 | dimapProc :: 361 | Monad m => 362 | (b->c)->(d->e)-> 363 | ProcType m c d -> ProcType m b e 364 | dimapProc f g pa = makePA 365 | (liftM (fmap g *** dimapProc f g) . step pa . f) 366 | (dimap f g (suspend pa)) 367 | 368 | {-# NOINLINE dimapProc #-} 369 | 370 | 371 | instance 372 | Monad m => Functor (ProcessT m i) 373 | where 374 | fmap = rmap 375 | 376 | instance 377 | Monad m => Applicative (ProcessT m i) 378 | where 379 | pure = arr . const 380 | pf <*> px = (pf &&& px) >>> arr (uncurry ($)) 381 | 382 | instance 383 | (Monad m, Semigroup o) => Semigroup (ProcessT m i o) 384 | where 385 | (<>) = liftA2 (<>) 386 | 387 | instance 388 | (Monad m, Monoid o) => Monoid (ProcessT m i o) 389 | where 390 | mempty = pure mempty 391 | mappend = liftA2 mappend 392 | 393 | instance 394 | Monad m => Cat.Category (ProcessT m) 395 | where 396 | id = idProc 397 | {-# INLINE id #-} 398 | 399 | g . f = compositeProc f g 400 | {-# INLINE (.) #-} 401 | 402 | 403 | instance 404 | Monad m => Arrow (ProcessT m) 405 | where 406 | arr = arrProc 407 | {-# INLINE arr #-} 408 | 409 | first pa = parProc pa idProc 410 | {-# INLINE first #-} 411 | 412 | second pa = parProc idProc pa 413 | {-# INLINE second #-} 414 | 415 | (***) = parProc 416 | {-# INLINE (***) #-} 417 | 418 | 419 | parProc :: Monad m => 420 | ProcType m b c -> 421 | ProcType m d e -> 422 | ProcType m (b, d) (c, e) 423 | parProc f g = toProcessT $ ParStep f g 424 | {-# INLINE [0] parProc #-} 425 | 426 | idProc :: Monad m => ProcType m b b 427 | idProc = let pa = makePA (\x -> return (weakly x, pa)) id in pa 428 | {-# NOINLINE idProc #-} 429 | 430 | arrProc :: Monad m => (b->c) -> ProcType m b c 431 | arrProc f = let pa = makePA (\x -> return (weakly (f x), pa)) f in pa 432 | {-# NOINLINE arrProc #-} 433 | 434 | -- |Composition is proceeded by the backtracking strategy. 435 | compositeProc :: Monad m => 436 | ProcType m b d -> ProcType m d c -> ProcType m b c 437 | compositeProc f0 g0 = ProcessT { 438 | paFeed = \x -> 439 | do 440 | (y, f') <- feed f0 x 441 | (z, g') <- feed g0 y 442 | return (z, compositeProc f' g'), 443 | paSweep = \x -> 444 | do 445 | (mz, g') <- sweep g0 $ suspend f0 x 446 | case mz 447 | of 448 | Just z -> return (Just z, compositeProc f0 g') 449 | Nothing -> btrk f0 g' x, 450 | paSuspend = suspend f0 >>> suspend g0 451 | } 452 | where 453 | btrk f g x = 454 | do 455 | (my, f') <- sweep f x 456 | (mz, g') <- 457 | case my 458 | of 459 | Just y -> 460 | do 461 | (z, g') <- feed g y 462 | return (Just z, g') 463 | Nothing -> 464 | return (Nothing, g) 465 | return (mz, compositeProc f' g') 466 | 467 | {-# NOINLINE compositeProc #-} 468 | 469 | -- rules 470 | {-# RULES 471 | "ProcessT: id/*" 472 | forall g. compositeProc idProc g = g 473 | "ProcessT: */id" 474 | forall f. compositeProc f idProc = f 475 | 476 | "ProcessT: concat/concat" 477 | forall f g h. compositeProc (compositeProc f g) h = compositeProc f (compositeProc g h) 478 | 479 | "ProcessT: dimap/dimap" 480 | forall f g h i j. dimapProc f j (dimapProc g i h) = dimapProc (g . f) (j . i) h 481 | "ProcessT: dimap/arr" 482 | forall f g h. dimapProc f h (arrProc g) = arrProc (h . g . f) 483 | 484 | "ProcessT: arr***/par" 485 | forall f1 f2 g1 g2 h. compositeProc (parProc f1 (arrProc f2)) (compositeProc (parProc g1 g2) h) = 486 | compositeProc (parProc (compositeProc f1 g1) (dimapProc f2 id g2)) h 487 | "ProcessT: arr***/par-2" 488 | forall f1 f2 g1 g2. compositeProc (parProc f1 (arrProc f2)) (parProc g1 g2) = 489 | parProc (compositeProc f1 g1) (dimapProc f2 id g2) 490 | "ProcessT: par/***arr" 491 | forall f1 f2 g1 g2 h. compositeProc (parProc f1 f2) (compositeProc (parProc (arrProc g1) g2) h) = 492 | compositeProc (parProc (dimapProc id g1 f1) (compositeProc f2 g2)) h 493 | "ProcessT: par/***arr-2" 494 | forall f1 f2 g1 g2. compositeProc (parProc f1 f2) (parProc (arrProc g1) g2) = 495 | parProc (dimapProc id g1 f1) (compositeProc f2 g2) 496 | 497 | "ProcessT: first/par" 498 | forall f1 g1 g2 h. compositeProc (parProc f1 idProc) (compositeProc (parProc g1 g2) h) = 499 | compositeProc (parProc (compositeProc f1 g1) g2) h 500 | "ProcessT: first/par-2" 501 | forall f1 g1 g2. compositeProc (parProc f1 idProc) (parProc g1 g2) = 502 | parProc (compositeProc f1 g1) g2 503 | "ProcessT: par/second" 504 | forall f1 f2 g2 h. compositeProc (parProc f1 f2) (compositeProc (parProc idProc g2) h) = 505 | compositeProc (parProc f1 (compositeProc f2 g2)) h 506 | "ProcessT: par/second-2" 507 | forall f1 f2 g2. compositeProc (parProc f1 f2) (parProc idProc g2) = 508 | parProc f1 (compositeProc f2 g2) 509 | 510 | "ProcessT: arr/arr" 511 | forall f g h. compositeProc (arrProc f) (compositeProc (arrProc g) h) = 512 | compositeProc (arrProc (g . f)) h 513 | "ProcessT: arr/arr-2" 514 | forall f g. compositeProc (arrProc f) (arrProc g) = arrProc (g . f) 515 | "ProcessT: arr/*" [1] 516 | forall f g. compositeProc (arrProc f) g = dimapProc f id g 517 | "ProcessT: */arr" [1] 518 | forall f g. compositeProc f (arrProc g) = dimapProc id g f 519 | "ProcessT: arr***arr" [1] 520 | forall f g. parProc (arrProc f) (arrProc g) = arrProc (f *** g) 521 | #-} 522 | 523 | instance 524 | Monad m => ArrowChoice (ProcessT m) 525 | where 526 | left pa0 = makePA 527 | (\eth -> sweep' pa0 eth) 528 | (left $ suspend pa0) 529 | where 530 | sweep' pa (Left x) = 531 | do 532 | (my, pa') <- step pa x 533 | return (Left <$> my, left pa') 534 | sweep' pa (Right d) = 535 | return (weakly (Right d), left pa) 536 | 537 | instance 538 | Monad m => ArrowLoop (ProcessT m) 539 | where 540 | loop pa = 541 | makePA 542 | (\x -> 543 | do 544 | (hyd, pa') <- step pa (x, loopSusD x) 545 | return (fst <$> hyd, loop pa')) 546 | (loop $ suspend pa) 547 | where 548 | loopSusD = loop (suspend pa >>> \(_, d) -> (d, d)) 549 | 550 | 551 | -- | Discrete events on a time line. 552 | -- Created and consumed by various transducers. 553 | data Event a = Event a | NoEvent | End 554 | 555 | 556 | instance 557 | Functor Event 558 | where 559 | fmap _ NoEvent = NoEvent 560 | fmap _ End = End 561 | fmap f (Event x) = Event (f x) 562 | 563 | 564 | instance 565 | Semigroup a => Semigroup (Event a) 566 | where 567 | Event x <> Event y = Event (x <> y) 568 | Event x <> _ = Event x 569 | _ <> Event y = Event y 570 | NoEvent <> _ = NoEvent 571 | _ <> NoEvent = NoEvent 572 | _ <> _ = End 573 | 574 | instance 575 | Semigroup a => Monoid (Event a) 576 | where 577 | mempty = End 578 | mappend = (<>) 579 | 580 | -- | Signals that can be absent(`NoEvent`) or end. 581 | -- For composite structure, `collapse` can be defined as monoid sum of all member occasionals. 582 | class 583 | Occasional' a 584 | where 585 | collapse :: a -> Event () 586 | 587 | -- | Occasional signals with creation methods. 588 | class 589 | Occasional' a => Occasional a 590 | where 591 | burst :: Event Void -> a 592 | 593 | 594 | instance 595 | (Occasional' a, Occasional' b) => Occasional' (a, b) 596 | where 597 | collapse (x, y) = collapse x `mappend` collapse y 598 | 599 | instance 600 | (Occasional a, Occasional b) => Occasional (a, b) 601 | where 602 | burst = burst &&& burst 603 | 604 | instance 605 | Occasional' (Event a) 606 | where 607 | collapse = (() <$) 608 | 609 | instance 610 | Occasional (Event a) 611 | where 612 | burst = fmap absurd 613 | 614 | noEvent :: Occasional a => a 615 | noEvent = burst NoEvent 616 | 617 | end :: Occasional a => a 618 | end = burst End 619 | 620 | data ZeroEvent = ZeroEvent deriving (Eq, Show, Enum, Bounded) 621 | 622 | instance 623 | Semigroup ZeroEvent 624 | where 625 | _ <> _ = ZeroEvent 626 | 627 | instance 628 | Monoid ZeroEvent 629 | where 630 | mempty = ZeroEvent 631 | mappend _ _ = ZeroEvent 632 | 633 | instance 634 | Occasional' ZeroEvent 635 | where 636 | collapse _ = mempty 637 | 638 | 639 | condEvent :: Bool -> Event a -> Event a 640 | condEvent _ End = End 641 | condEvent True ev = ev 642 | condEvent False _ = NoEvent 643 | 644 | filterEvent :: 645 | Arrow ar => 646 | (a -> Bool) -> 647 | ar (Event a) (Event a) 648 | filterEvent cond = filterJust <<< evMap mcond 649 | where 650 | mcond x 651 | | cond x = Just x 652 | | otherwise = Nothing 653 | 654 | filterJust :: 655 | Arrow ar => ar (Event (Maybe a)) (Event a) 656 | filterJust = arr filterJust' 657 | where 658 | filterJust' (Event (Just x)) = Event x 659 | filterJust' (Event Nothing) = NoEvent 660 | filterJust' NoEvent = NoEvent 661 | filterJust' End = End 662 | 663 | -- |Split an event stream. 664 | -- 665 | -- >>> run (filterLeft) [Left 1, Right 2, Left 3, Right 4] 666 | -- [1,3] 667 | filterLeft :: 668 | Arrow ar => 669 | ar (Event (Either a b)) (Event a) 670 | filterLeft = filterJust <<< evMap (either Just (const Nothing)) 671 | 672 | -- |Split an event stream. 673 | -- 674 | -- >>> run filterRight [Left 1, Right 2, Left 3, Right 4] 675 | -- [2,4] 676 | filterRight :: 677 | Arrow ar => 678 | ar (Event (Either a b)) (Event b) 679 | filterRight = filterJust <<< evMap (either (const Nothing) Just) 680 | 681 | -- |Split an event stream. 682 | -- 683 | -- >>> run (splitEvent >>> arr fst) [Left 1, Right 2, Left 3, Right 4] 684 | -- [1,3] 685 | -- 686 | -- >>> run (splitEvent >>> arr snd) [Left 1, Right 2, Left 3, Right 4] 687 | -- [2,4] 688 | splitEvent :: 689 | Arrow ar => 690 | ar (Event (Either a b)) (Event a, Event b) 691 | splitEvent = filterLeft &&& filterRight 692 | 693 | -- | Alias of "arr . fmap" 694 | -- 695 | -- While "ProcessT a (Event b) (Event c)" means a transducer from b to c, 696 | -- function b->c can be lifted into a transducer by fhis function. 697 | -- 698 | -- But in most cases you needn't call this function in proc-do notations, 699 | -- because `arr`s are completed automatically while desugaring. 700 | -- 701 | -- For example, 702 | -- 703 | -- @ 704 | -- proc x -> returnA -\< f \<$\> x 705 | -- @ 706 | -- 707 | -- is equivalent to 708 | -- 709 | -- @ 710 | -- evMap f 711 | -- @ 712 | evMap :: Arrow a => (b->c) -> a (Event b) (Event c) 713 | evMap = arr . fmap 714 | 715 | 716 | 717 | muted :: 718 | (Monad m, Occasional' b, Occasional c) => ProcessT m b c 719 | muted = arr collapse >>> repeatedly await >>> arr burst 720 | 721 | -- | A monad type represents time evolution of ProcessT 722 | newtype Evolution i o m r = Evolution 723 | { 724 | runEvolution :: Cont (ProcessT m i o) r 725 | } 726 | deriving 727 | (Functor, Applicative, Monad) 728 | 729 | instance 730 | Occasional o => 731 | MonadTrans (Evolution i o) 732 | where 733 | {-# INLINE lift #-} 734 | lift ma = Evolution $ cont $ \fmpf -> packProc (fmpf <$> ma) 735 | 736 | instance 737 | (MonadIO m, Occasional o) => 738 | MonadIO (Evolution i o m) 739 | where 740 | {-# INLINE liftIO #-} 741 | liftIO ma = lift $ liftIO ma 742 | 743 | 744 | data 745 | PlanF i o a 746 | where 747 | AwaitPF :: (i->a) -> a -> PlanF i o a 748 | YieldPF :: o -> a -> PlanF i o a 749 | StopPF :: PlanF i o a 750 | 751 | instance 752 | Functor (PlanF i o) 753 | where 754 | fmap g (AwaitPF f ff) = AwaitPF (g . f) (g ff) 755 | fmap g (YieldPF x r) = YieldPF x (g r) 756 | fmap _ StopPF = StopPF 757 | 758 | 759 | newtype PlanT i o m a = 760 | PlanT { freePlanT :: F.FT (PlanF i o) m a } 761 | deriving 762 | (Functor, Applicative, Monad) 763 | 764 | type Plan i o a = forall m. Monad m => PlanT i o m a 765 | 766 | packProc :: 767 | (Monad m, Occasional o) => 768 | m (ProcessT m i o) -> 769 | ProcessT m i o 770 | packProc !mp = ProcessT { 771 | paFeed = \ex -> mp >>= \p -> feed p ex , 772 | paSweep = \ex -> mp >>= \p -> sweep p ex, 773 | paSuspend = const noEvent 774 | } 775 | {-# INLINE[0] packProc #-} 776 | {-# RULES 777 | "ProcessT: return/packProc" 778 | forall p. return (packProc p) = p 779 | #-} 780 | {- 781 | "ProcessT: packProc/return" 782 | forall p. packProc (return p) = p 783 | -} 784 | 785 | instance 786 | MonadTrans (PlanT i o) 787 | where 788 | lift mx = PlanT $ lift mx 789 | {-# INLINE lift #-} 790 | 791 | instance 792 | MonadReader r m => MonadReader r (PlanT i o m) 793 | where 794 | ask = lift ask 795 | local f mx = PlanT $ local f (freePlanT mx) 796 | 797 | instance 798 | MonadWriter w m => MonadWriter w (PlanT i o m) 799 | where 800 | tell = lift . tell 801 | listen mx = PlanT $ listen (freePlanT mx) 802 | pass mx = PlanT $ pass (freePlanT mx) 803 | 804 | instance 805 | MonadState s m => MonadState s (PlanT i o m) 806 | where 807 | get = lift get 808 | put x = lift $ put x 809 | 810 | instance 811 | Monad m => Alternative (PlanT i o m) 812 | where 813 | empty = stop 814 | (<|>) = catchP 815 | 816 | instance 817 | Monad m => MonadPlus (PlanT i o m) 818 | where 819 | mzero = stop 820 | mplus = catchP 821 | 822 | instance 823 | MonadIO m => MonadIO (PlanT i o m) 824 | where 825 | liftIO = lift . liftIO 826 | {-# INLINE liftIO #-} 827 | 828 | class 829 | MonadAwait m a | m -> a 830 | where 831 | await :: m a 832 | 833 | instance 834 | Monad m => MonadAwait (PlanT i o m) i 835 | where 836 | {-# INLINE await #-} 837 | await = PlanT $ F.wrap $ AwaitPF return (F.liftF StopPF) 838 | 839 | instance 840 | (Monad m, Occasional o) => 841 | MonadAwait (Evolution (Event a) o m) a 842 | where 843 | {-# INLINE await #-} 844 | await = Evolution $ cont $ \next -> awaitProc next stopped 845 | 846 | class 847 | MonadYield m a | m -> a 848 | where 849 | yield :: a -> m () 850 | 851 | instance 852 | Monad m => MonadYield (PlanT i o m) o 853 | where 854 | {-# INLINE yield #-} 855 | yield x = PlanT $ F.liftF $ YieldPF x () 856 | 857 | instance 858 | Monad m => MonadYield (Evolution i (Event a) m) a 859 | where 860 | {-# INLINE yield #-} 861 | yield x = Evolution $ cont $ \next -> yieldProc x (next ()) 862 | 863 | class 864 | MonadStop m 865 | where 866 | stop :: m a 867 | 868 | instance 869 | Monad m => MonadStop (PlanT i o m) 870 | where 871 | {-# INLINE stop #-} 872 | stop = PlanT $ F.liftF StopPF 873 | 874 | instance 875 | (Monad m, Occasional o) => 876 | MonadStop (Evolution i o m) 877 | where 878 | {-# INLINE stop #-} 879 | stop = Evolution $ cont $ const stopped 880 | 881 | catchP:: Monad m => 882 | PlanT i o m a -> PlanT i o m a -> PlanT i o m a 883 | 884 | catchP (PlanT pl) next0 = 885 | PlanT $ F.FT $ \pr free -> 886 | F.runFT pl pr (free' next0 pr free) 887 | where 888 | free' :: 889 | Monad m => 890 | PlanT i o m a -> 891 | (a -> m r) -> 892 | (forall x. (x -> m r) -> PlanF i o x -> m r) -> 893 | (y -> m r) -> 894 | (PlanF i o y) -> 895 | m r 896 | free' (PlanT next) pr free r pl' = 897 | let nextR = F.runFT next pr free 898 | go StopPF = nextR 899 | go (AwaitPF f ff) = 900 | free (either (\_ -> nextR) r) $ AwaitPF (Right . f) (Left ff) 901 | go _ = free r pl' 902 | in 903 | go pl' 904 | 905 | {-# INLINE awaitProc #-} 906 | awaitProc :: 907 | (Monad m, Occasional o) => 908 | (a -> ProcessT m (Event a) o) -> 909 | ProcessT m (Event a) o -> 910 | ProcessT m (Event a) o 911 | awaitProc f ff = awaitProc' 912 | where 913 | awaitProc' = ProcessT { 914 | paFeed = awaitFeed, 915 | paSweep = awaitSweep, 916 | paSuspend = const noEvent 917 | } 918 | 919 | awaitFeed (Event x) = feed (f x) NoEvent 920 | awaitFeed NoEvent = return (noEvent, awaitProc') 921 | awaitFeed End = feed ff End 922 | 923 | awaitSweep (Event x) = sweep (f x) NoEvent 924 | awaitSweep NoEvent = return (Nothing, awaitProc') 925 | awaitSweep End = sweep ff End 926 | 927 | {-# INLINE yieldProc #-} 928 | yieldProc :: 929 | Monad m => 930 | a -> 931 | ProcessT m i (Event a) -> 932 | ProcessT m i (Event a) 933 | yieldProc y pa = ProcessT { 934 | paFeed = \_ -> return (Event y, pa), 935 | paSweep = \_ -> return (Just (Event y), pa), 936 | paSuspend = const NoEvent 937 | } 938 | 939 | {-# INLINE stopped #-} 940 | stopped :: 941 | (Monad m, Occasional o) => 942 | ProcessT m i o 943 | stopped = ProcessT { 944 | paFeed = \_ -> return (end, arr (const end)), 945 | paSweep = \_ -> return (Just end, arr (const end)), 946 | paSuspend = pure end 947 | } 948 | 949 | {-# INLINE constructT #-} 950 | constructT :: 951 | (Monad m) => 952 | PlanT i o m r -> 953 | ProcessT m (Event i) (Event o) 954 | constructT pl0 = runCont (runEvolution $ realizePlan pl0) (const stopped) 955 | 956 | {-# INLINE realizePlan #-} 957 | realizePlan :: 958 | Monad m => 959 | PlanT i o m a -> 960 | Evolution (Event i) (Event o) m a 961 | realizePlan pl = Evolution $ cont $ \next -> 962 | packProc $ F.runFT (freePlanT pl) (return . next) (\b fr -> return $ free (packProc . b <$> fr)) 963 | where 964 | free :: 965 | Monad m => PlanF i o (ProcessT m (Event i) (Event o)) -> ProcessT m (Event i) (Event o) 966 | free (AwaitPF f ff) = awaitProc f ff 967 | free (YieldPF y pa) = yieldProc y pa 968 | free StopPF = stopped 969 | 970 | {-# INLINE repeatedlyT #-} 971 | repeatedlyT :: 972 | Monad m => 973 | PlanT i o m r -> 974 | ProcessT m (Event i) (Event o) 975 | repeatedlyT pl0 = runCont (forever $ runEvolution $ realizePlan pl0) absurd 976 | 977 | 978 | -- for pure 979 | {-# INLINE construct #-} 980 | construct :: 981 | Monad m => 982 | PlanT i o Identity r -> 983 | ProcessT m (Event i) (Event o) 984 | construct = fit (return . runIdentity) . constructT 985 | 986 | {-# INLINE repeatedly #-} 987 | repeatedly :: 988 | Monad m => 989 | PlanT i o Identity r -> 990 | ProcessT m (Event i) (Event o) 991 | repeatedly = fit (return . runIdentity) . repeatedlyT 992 | 993 | 994 | -- 995 | -- Switches 996 | -- 997 | 998 | -- |Run the 1st transducer at the beggining. Then switch to 2nd when Event t occurs. 999 | -- 1000 | -- >>> :{ 1001 | -- let 1002 | -- before = proc x -> 1003 | -- do 1004 | -- trigger <- filterEvent (== 3) -< x 1005 | -- returnA -< ((*10) <$> x, trigger) 1006 | -- after t = proc x -> returnA -< (*100) <$> x 1007 | -- in 1008 | -- run (switch before after) [1..5] 1009 | -- :} 1010 | -- [10,20,300,400,500] 1011 | switch :: 1012 | Monad m => 1013 | ProcessT m b (c, Event t) -> 1014 | (t -> ProcessT m b c) -> 1015 | ProcessT m b c 1016 | switch sf k = ggSwitch (const ()) sf (\() -> k) 1017 | 1018 | 1019 | -- |Delayed version of `switch` 1020 | -- 1021 | -- >>> :{ 1022 | -- let 1023 | -- before = proc x -> 1024 | -- do 1025 | -- trigger <- filterEvent (== 3) -< x 1026 | -- returnA -< ((*10) <$> x, trigger) 1027 | -- after t = proc x -> returnA -< (*100) <$> x 1028 | -- in 1029 | -- run (dSwitch before after) [1..5] 1030 | -- :} 1031 | -- [10,20,30,400,500] 1032 | dSwitch :: 1033 | Monad m => 1034 | ProcessT m b (c, Event t) -> 1035 | (t -> ProcessT m b c) -> 1036 | ProcessT m b c 1037 | dSwitch sf k = dggSwitch (const ()) sf (\() -> k) 1038 | 1039 | -- |Recurring switch. 1040 | -- 1041 | -- >>> :{ 1042 | -- let pa = proc evtp -> 1043 | -- do 1044 | -- evx <- returnA -< fst <$> evtp 1045 | -- evarr <- filterJust -< snd <$> evtp 1046 | -- rSwitch (evMap (*10)) -< (evx, evarr) 1047 | -- l = [(1, Nothing), 1048 | -- (2, Just (arr $ fmap (*100))), 1049 | -- (3, Nothing), 1050 | -- (4, Just (arr $ fmap (*1000))), 1051 | -- (5, Nothing)] 1052 | -- in 1053 | -- run pa l 1054 | -- :} 1055 | -- [10,200,300,4000,5000] 1056 | rSwitch :: 1057 | Monad m => 1058 | ProcessT m b c -> 1059 | ProcessT m (b, Event (ProcessT m b c)) c 1060 | rSwitch p = rSwitch' (p *** Cat.id) >>> arr fst 1061 | where 1062 | rSwitch' pid = kSwitch pid test $ \_ p' -> rSwitch'' (p' *** Cat.id) 1063 | rSwitch'' pid = dkSwitch pid test $ \s _ -> rSwitch' s 1064 | test = proc (_, (_, r)) -> returnA -< r 1065 | 1066 | 1067 | -- |Delayed version of `rSwitch`. 1068 | -- 1069 | -- >>> :{ 1070 | -- let pa = proc evtp -> 1071 | -- do 1072 | -- evx <- returnA -< fst <$> evtp 1073 | -- evarr <- filterJust -< snd <$> evtp 1074 | -- drSwitch (evMap (*10)) -< (evx, evarr) 1075 | -- l = [(1, Nothing), 1076 | -- (2, Just (arr $ fmap (*100))), 1077 | -- (3, Nothing), 1078 | -- (4, Just (arr $ fmap (*1000))), 1079 | -- (5, Nothing)] 1080 | -- in 1081 | -- run pa l 1082 | -- :} 1083 | -- [10,20,300,400,5000] 1084 | drSwitch :: 1085 | Monad m => ProcessT m b c -> 1086 | ProcessT m (b, Event (ProcessT m b c)) c 1087 | 1088 | drSwitch p = drSwitch' (p *** Cat.id) 1089 | where 1090 | drSwitch' pid = dSwitch pid $ \p' -> drSwitch' (p' *** Cat.id) 1091 | 1092 | 1093 | kSwitch :: 1094 | Monad m => 1095 | ProcessT m b c -> 1096 | ProcessT m (b, c) (Event t) -> 1097 | (ProcessT m b c -> t -> ProcessT m b c) -> 1098 | ProcessT m b c 1099 | kSwitch sf test = 1100 | ggSwitch 1101 | (\(CompositeStep _ (CompositeStep (ParStep IDStep sf') _)) -> sf') 1102 | (CompositeStep (ArrStep (id &&& id)) 1103 | (CompositeStep (ParStep IDStep sf) (arr snd &&& test))) 1104 | 1105 | 1106 | dkSwitch :: 1107 | Monad m => 1108 | ProcessT m b c -> 1109 | ProcessT m (b, c) (Event t) -> 1110 | (ProcessT m b c -> t -> ProcessT m b c) -> 1111 | ProcessT m b c 1112 | dkSwitch sf test = 1113 | dggSwitch 1114 | (\(CompositeStep _ (CompositeStep (ParStep IDStep sf') _)) -> sf') 1115 | (CompositeStep (ArrStep (id &&& id)) 1116 | (CompositeStep (ParStep IDStep sf) (arr snd &&& test))) 1117 | 1118 | ggSwitch :: 1119 | (Monad m, Stepper m b (c, Event t) sWhole) => 1120 | (sWhole -> s) -> 1121 | sWhole -> 1122 | (s -> t -> ProcessT m b c) -> 1123 | ProcessT m b c 1124 | ggSwitch picker whole k = makePA 1125 | (\x -> 1126 | do 1127 | let 1128 | (hyevt, whole') <- step whole x 1129 | let hy = fst <$> hyevt 1130 | hevt = snd <$> hyevt 1131 | case (helperToMaybe hevt) 1132 | of 1133 | Just (Event t) -> step (k (picker whole') t) x 1134 | _ -> return (hy, ggSwitch picker whole' k)) 1135 | (arr fst . suspend whole) 1136 | 1137 | dggSwitch :: 1138 | (Monad m, Stepper m b (c, Event t) sWhole) => 1139 | (sWhole -> s) -> 1140 | sWhole -> 1141 | (s -> t -> ProcessT m b c) -> 1142 | ProcessT m b c 1143 | dggSwitch picker whole k = makePA 1144 | (\x -> 1145 | do 1146 | let 1147 | (hyevt, whole') <- step whole x 1148 | let hy = fst <$> hyevt 1149 | hevt = snd <$> hyevt 1150 | case (helperToMaybe hevt) 1151 | of 1152 | Just (Event t) -> return (hy, k (picker whole') t) 1153 | _ -> return (hy, dggSwitch picker whole' k)) 1154 | (arr fst . suspend whole) 1155 | 1156 | gSwitch :: 1157 | Monad m => 1158 | ProcessT m b (p, r) -> 1159 | ProcessT m p q -> 1160 | ProcessT m (q, r) (c, Event t) -> 1161 | (ProcessT m p q -> t -> ProcessT m b c) -> 1162 | ProcessT m b c 1163 | gSwitch pre sf post = 1164 | ggSwitch 1165 | (\(CompositeStep _ (CompositeStep (ParStep sf' IDStep) _)) -> sf') 1166 | (CompositeStep pre (CompositeStep (ParStep sf IDStep) post)) 1167 | 1168 | dgSwitch :: 1169 | Monad m => 1170 | ProcessT m b (p, r) -> 1171 | ProcessT m p q -> 1172 | ProcessT m (q, r) (c, Event t) -> 1173 | (ProcessT m p q -> t -> ProcessT m b c) -> 1174 | ProcessT m b c 1175 | dgSwitch pre sf post = 1176 | dggSwitch 1177 | (\(CompositeStep _ (CompositeStep (ParStep sf' IDStep) _)) -> sf') 1178 | (CompositeStep pre (CompositeStep (ParStep sf IDStep) post)) 1179 | 1180 | broadcast :: 1181 | Functor col => 1182 | b -> col sf -> col (b, sf) 1183 | broadcast x sfs = fmap (\sf -> (x, sf)) sfs 1184 | 1185 | par :: 1186 | (Monad m, Tv.Traversable col) => 1187 | (forall sf. (b -> col sf -> col (ext, sf))) -> 1188 | col (ProcessT m ext c) -> 1189 | ProcessT m b (col c) 1190 | par r sfs = toProcessT (PluralStep r sfs) 1191 | 1192 | parB :: 1193 | (Monad m, Tv.Traversable col) => 1194 | col (ProcessT m b c) -> 1195 | ProcessT m b (col c) 1196 | parB = par broadcast 1197 | 1198 | 1199 | data PluralStep ext col m b c 1200 | where 1201 | PluralStep :: 1202 | (forall sf. (b -> col sf -> col (ext, sf))) -> 1203 | (col (ProcessT m ext c)) -> 1204 | PluralStep ext col m b c 1205 | 1206 | 1207 | instance 1208 | (Monad m, Tv.Traversable col) => 1209 | Stepper m b (col c) (PluralStep ext col m b c) 1210 | where 1211 | feed (PluralStep r sfs) = liftM (runIdentity *** PluralStep r) . parCore r sfs 1212 | sweep (PluralStep r sfs) = liftM (id *** PluralStep r) . parCore r sfs 1213 | suspend (PluralStep r sfs) = suspendAll r sfs 1214 | 1215 | suspendAll :: 1216 | (Monad m, Tv.Traversable col) => 1217 | (forall sf. (b -> col sf -> col (ext, sf))) -> 1218 | col (ProcessT m ext c) -> 1219 | b -> col c 1220 | suspendAll r sfs = (sus <$>) . (r `flip` sfs) 1221 | where 1222 | sus (ext, sf) = suspend sf ext 1223 | 1224 | traverseResult :: 1225 | forall h col c. 1226 | (Tv.Traversable col, ProcessHelper h) => 1227 | col (h c, c) -> h (col c) 1228 | traverseResult zs = 1229 | let 1230 | pr :: (h c, c) -> StateT Bool h c 1231 | pr (hx, d) = 1232 | do 1233 | let mx = helperToMaybe hx 1234 | if isJust mx then put True else return () 1235 | return (fromMaybe d mx) 1236 | hxs = runStateT (Tv.sequence (pr <$> zs)) False 1237 | exist = fromMaybe False $ helperToMaybe (snd <$> hxs) 1238 | result = fst <$> hxs 1239 | in 1240 | if exist then result else join (weakly result) 1241 | 1242 | parCore :: 1243 | (Applicative m, Monad m, Tv.Traversable col, ProcessHelper h) => 1244 | (forall sf. (b -> col sf -> col (ext, sf))) -> 1245 | col (ProcessT m ext c) -> 1246 | b -> m (h (col c), col (ProcessT m ext c)) 1247 | parCore r sfs x = 1248 | do 1249 | let input = r x sfs 1250 | ret <- Tv.sequenceA $ fmap app' input 1251 | let zs = traverseResult $ fmap fst ret 1252 | sfs' = fmap snd ret 1253 | return (zs, sfs') 1254 | where 1255 | app' (y, sf) = 1256 | do 1257 | (hz, sf') <- step sf y 1258 | return ((hz, suspend sf' y), sf') 1259 | 1260 | pSwitch :: 1261 | (Monad m, Tv.Traversable col) => 1262 | (forall sf. (b -> col sf -> col (ext, sf))) -> 1263 | col (ProcessT m ext c) -> 1264 | ProcessT m (b, col c) (Event mng) -> 1265 | (col (ProcessT m ext c) -> mng -> ProcessT m b (col c)) -> 1266 | ProcessT m b (col c) 1267 | pSwitch r sfs test = 1268 | ggSwitch 1269 | (\(CompositeStep _ 1270 | (CompositeStep (ParStep IDStep (PluralStep _ sfs')) _)) -> sfs') 1271 | (CompositeStep (ArrStep (id &&& id)) 1272 | (CompositeStep (ParStep IDStep (PluralStep r sfs)) (arr snd &&& test))) 1273 | 1274 | pSwitchB :: 1275 | (Monad m, Tv.Traversable col) => 1276 | col (ProcessT m b c) -> 1277 | ProcessT m (b, col c) (Event mng) -> 1278 | (col (ProcessT m b c) -> mng -> ProcessT m b (col c)) -> 1279 | ProcessT m b (col c) 1280 | pSwitchB = pSwitch broadcast 1281 | 1282 | dpSwitch :: 1283 | (Monad m, Tv.Traversable col) => 1284 | (forall sf. (b -> col sf -> col (ext, sf))) -> 1285 | col (ProcessT m ext c) -> 1286 | ProcessT m (b, col c) (Event mng) -> 1287 | (col (ProcessT m ext c) -> mng -> ProcessT m b (col c)) -> 1288 | ProcessT m b (col c) 1289 | dpSwitch r sfs test = 1290 | dggSwitch 1291 | (\(CompositeStep _ 1292 | (CompositeStep (ParStep IDStep (PluralStep _ sfs')) _)) -> sfs') 1293 | (CompositeStep (ArrStep (id &&& id)) 1294 | (CompositeStep (ParStep IDStep (PluralStep r sfs)) (arr snd &&& test))) 1295 | 1296 | dpSwitchB :: 1297 | (Monad m, Tv.Traversable col) => 1298 | col (ProcessT m b c) -> 1299 | ProcessT m (b, col c) (Event mng) -> 1300 | (col (ProcessT m b c) -> mng -> ProcessT m b (col c)) -> 1301 | ProcessT m b (col c) 1302 | dpSwitchB = dpSwitch broadcast 1303 | 1304 | rpSwitch :: 1305 | (Monad m, Tv.Traversable col) => 1306 | (forall sf. (b -> col sf -> col (ext, sf))) -> 1307 | col (ProcessT m ext c) -> 1308 | ProcessT m 1309 | (b, Event (col (ProcessT m ext c) -> col (ProcessT m ext c))) 1310 | (col c) 1311 | rpSwitch r sfs = 1312 | ggSwitch 1313 | (\(ParStep (PluralStep _ sfs') IDStep) -> sfs') 1314 | (ParStep (PluralStep r sfs) IDStep) 1315 | (\sfs' tr -> next r (tr sfs')) 1316 | where 1317 | next :: 1318 | (Monad m, Tv.Traversable col) => 1319 | (forall sf. (b -> col sf -> col (ext, sf))) -> 1320 | col (ProcessT m ext c) -> 1321 | ProcessT m 1322 | (b, Event (col (ProcessT m ext c) -> col (ProcessT m ext c))) 1323 | (col c) 1324 | next r' sfs' = 1325 | dggSwitch 1326 | (\(ParStep (PluralStep _ sfs'') IDStep) -> sfs'') 1327 | (ParStep (PluralStep r' sfs') IDStep) 1328 | (\sfs'' _ -> rpSwitch r' sfs'') 1329 | 1330 | 1331 | rpSwitchB :: 1332 | (Monad m, Tv.Traversable col) => 1333 | col (ProcessT m b c) -> 1334 | ProcessT m 1335 | (b, Event (col (ProcessT m b c) -> col (ProcessT m b c))) 1336 | (col c) 1337 | rpSwitchB = rpSwitch broadcast 1338 | 1339 | 1340 | drpSwitch :: 1341 | (Monad m, Tv.Traversable col) => 1342 | (forall sf. (b -> col sf -> col (ext, sf))) -> 1343 | col (ProcessT m ext c) -> 1344 | ProcessT m 1345 | (b, Event (col (ProcessT m ext c) -> col (ProcessT m ext c))) 1346 | (col c) 1347 | drpSwitch r sfs = 1348 | dggSwitch 1349 | (\(ParStep (PluralStep _ sfs') IDStep) -> sfs') 1350 | (ParStep (PluralStep r sfs) IDStep) 1351 | (\sfs' tr -> drpSwitch r (tr sfs')) 1352 | 1353 | drpSwitchB :: 1354 | (Monad m, Tv.Traversable col) => 1355 | col (ProcessT m b c) -> 1356 | ProcessT m 1357 | (b, Event (col (ProcessT m b c) -> col (ProcessT m b c))) 1358 | (col c) 1359 | drpSwitchB = drpSwitch broadcast 1360 | 1361 | 1362 | -- 1363 | -- Unsafe primitives 1364 | -- 1365 | 1366 | -- | Repeatedly call `p`. 1367 | -- 1368 | -- How many times `p` is called is indefinite. 1369 | -- So `p` must satisfy the equation below; 1370 | -- 1371 | -- @p &&& (p >>> arr null) === p &&& arr (const True)@ 1372 | -- 1373 | -- where 1374 | -- 1375 | -- @null = getAll . foldMap (\_ -> All False)@ 1376 | unsafeExhaust :: 1377 | (Monad m, Fd.Foldable f) => 1378 | (b -> m (f c)) -> 1379 | ProcessT m b (Event c) 1380 | unsafeExhaust p = 1381 | go >>> fork 1382 | where 1383 | go = ProcessT { 1384 | paFeed = \x -> do {y <- p x; return (Event y, go)}, 1385 | paSweep = \x -> do {y <- p x; return (if nullFd y then Nothing else Just (Event y), go)}, 1386 | paSuspend = const NoEvent 1387 | } 1388 | 1389 | fork = repeatedly $ await >>= Fd.mapM_ yield 1390 | 1391 | nullFd = getAll . Fd.foldMap (\_ -> All False) 1392 | 1393 | 1394 | -- 1395 | -- Running 1396 | -- 1397 | 1398 | -- 1399 | -- Running Monad (To be exported) 1400 | -- 1401 | data RunInfo i o m = RunInfo { 1402 | freezeRI :: !(ProcessT m i o), 1403 | getInputRI :: !i, 1404 | getPaddingRI :: !i, 1405 | getPhaseRI :: !Phase 1406 | } 1407 | 1408 | type RM i o m = StateT (RunInfo i o m) m 1409 | 1410 | runRM :: 1411 | Monad m' => 1412 | ProcessT m (Event i) o -> 1413 | StateT (RunInfo (Event i) o m) m' x -> 1414 | m' x 1415 | runRM pa mx = 1416 | evalStateT mx $ 1417 | RunInfo { 1418 | freezeRI = pa, 1419 | getInputRI = NoEvent, 1420 | getPaddingRI = NoEvent, 1421 | getPhaseRI = Sweep 1422 | } 1423 | 1424 | 1425 | 1426 | feed_ :: 1427 | (Monad m, MonadState (RunInfo i o m') m) => 1428 | i -> i -> m Bool 1429 | feed_ input padding = 1430 | do 1431 | ph <- gets getPhaseRI 1432 | if ph == Suspend 1433 | then 1434 | do 1435 | ri <- get 1436 | put $ ri { 1437 | getInputRI = input, 1438 | getPaddingRI = padding, 1439 | getPhaseRI = Feed 1440 | } 1441 | return True 1442 | else 1443 | return False 1444 | 1445 | feedR :: 1446 | (Monad m, MonadState (RunInfo (Event i) o m') m) => 1447 | i -> m Bool 1448 | feedR x = feed_ (Event x) NoEvent 1449 | 1450 | 1451 | freeze :: 1452 | Monad m => 1453 | RM i o m (ProcessT m i o) 1454 | freeze = gets freezeRI 1455 | 1456 | sweepR :: 1457 | Monad m => 1458 | RM i o m o 1459 | sweepR = 1460 | do 1461 | pa <- freeze 1462 | ph <- gets getPhaseRI 1463 | ri <- get 1464 | case ph of 1465 | Feed -> 1466 | do 1467 | x <- gets getInputRI 1468 | (y, pa') <- lift $ feed pa x 1469 | put $ ri { 1470 | freezeRI = pa', 1471 | getPhaseRI = Sweep 1472 | } 1473 | return y 1474 | Sweep -> 1475 | do 1476 | x <- gets getPaddingRI 1477 | (my, pa') <- lift $ sweep pa x 1478 | put $ ri { 1479 | freezeRI = pa', 1480 | getPhaseRI = if isJust my then Sweep else Suspend 1481 | } 1482 | return $ fromMaybe (suspend pa x) my 1483 | Suspend -> 1484 | do 1485 | x <- gets getPaddingRI 1486 | return $ suspend pa x 1487 | 1488 | 1489 | sweepAll :: 1490 | (Monad m, Monad m') => 1491 | (forall p. RM i (Event o) m p -> m' p) -> 1492 | (o -> m' ()) -> 1493 | ContT Bool m' () 1494 | sweepAll lft outpre = 1495 | callCC $ \sus -> forever $ cond sus >> body 1496 | where 1497 | cond sus = 1498 | do 1499 | ph <- lift $ lft $ gets getPhaseRI 1500 | if ph == Suspend then sus () else return () 1501 | body = 1502 | do 1503 | evx <- lift $ lft $ sweepR 1504 | case evx 1505 | of 1506 | Event x -> 1507 | do 1508 | lift $ outpre x 1509 | NoEvent -> 1510 | return () 1511 | End -> 1512 | breakCont False 1513 | 1514 | breakCont :: Monad m => r -> ContT r m a 1515 | breakCont = ContT . const . return 1516 | 1517 | 1518 | -- | Run a machine. 1519 | runT :: 1520 | (Monad m, Fd.Foldable f) => 1521 | (c -> m ()) -> 1522 | ProcessT m (Event b) (Event c) -> 1523 | f b -> m () 1524 | runT outpre0 pa0 xs = 1525 | runRM pa0 $ 1526 | do 1527 | _ <- evalContT $ 1528 | do 1529 | -- Sweep initial events. 1530 | sweepAll id outpre 1531 | 1532 | -- Feed values 1533 | Fd.mapM_ feedSweep xs 1534 | 1535 | return True 1536 | 1537 | -- Terminate. 1538 | _ <- feed_ End End 1539 | _ <- evalContT $ sweepAll id outpre >> return True 1540 | return () 1541 | where 1542 | feedSweep x = 1543 | do 1544 | _ <- lift $ feedR x 1545 | sweepAll id outpre 1546 | 1547 | outpre = lift . outpre0 1548 | 1549 | type Builder b = F.F ((,) b) 1550 | 1551 | putB :: b -> Builder b () 1552 | putB x = F.liftF (x, ()) 1553 | 1554 | bToList :: Builder b a -> [b] 1555 | bToList x = build $ \cons nil -> F.runF x (const nil) (uncurry cons) 1556 | 1557 | -- | Run a machine discarding all results. 1558 | runT_ :: 1559 | (Monad m, Fd.Foldable f) => 1560 | ProcessT m (Event a) (Event b) -> 1561 | f a -> m () 1562 | runT_ pa l = 1563 | runT (const $ return ()) pa l 1564 | 1565 | run :: 1566 | Fd.Foldable f => 1567 | ProcessT Identity (Event a) (Event b) -> 1568 | f a -> [b] 1569 | run pa = bToList . runT putB (fit lift pa) 1570 | 1571 | run_ :: 1572 | (Fd.Foldable f, ArrowApply a) => 1573 | ProcessA a (Event b) (Event c) -> 1574 | a (f b) () 1575 | run_ pa = proc l -> case runT_ pa l of {ArrowMonad f -> f} -<< () 1576 | 1577 | lftRM :: (Monad m, Monad m') => 1578 | (forall p. m p -> m' p) -> 1579 | RM i o m a -> 1580 | StateT (RunInfo i o m) m' a 1581 | lftRM lft' st = StateT $ \s -> lft' $ runStateT st s 1582 | 1583 | 1584 | -- | Execute until an input consumed and the machine suspends. 1585 | -- 1586 | -- During the execution, the machine may yield values or stops. 1587 | -- It can be handled by two callbacks. 1588 | -- 1589 | -- In some case the machine failed to consume the input value. 1590 | -- If so, the value is passed to the termination callback. 1591 | stepRun :: 1592 | (Monad m, Monad m') => 1593 | (forall p. m p -> m' p) -- ^ Lifting function (pass `id` if m' ~ m) 1594 | -> 1595 | (b -> m' ()) -- ^ Callback on every output value. 1596 | -> 1597 | (Maybe a -> m' ()) -- ^ Callback on termination. 1598 | -> 1599 | ProcessT m (Event a) (Event b) -- ^ The machine to run. 1600 | -> 1601 | a -- ^ The argument to the machine. 1602 | -> 1603 | m' (ProcessT m (Event a) (Event b)) 1604 | stepRun lft yd stp pa0 x = 1605 | do 1606 | pa <- runRM pa0 $ 1607 | do 1608 | csmd <- evalContT $ 1609 | do 1610 | sweepAll (lftRM lft) (lift . yd) 1611 | return True 1612 | if csmd 1613 | then do 1614 | ct <- evalContT $ 1615 | do 1616 | _ <- lift $ feedR x 1617 | sweepAll (lftRM lft) (lift . yd) 1618 | return True 1619 | if ct 1620 | then return () 1621 | else lift $ stp $ Nothing 1622 | else 1623 | lift $ stp $ Just x 1624 | pa <- lftRM lft freeze 1625 | return pa 1626 | return pa 1627 | 1628 | 1629 | -- | Execute until an output produced. 1630 | -- 1631 | -- During the execution, the machine may await values or stops. 1632 | -- It can be handled by two callbacks. 1633 | -- 1634 | -- If the machine stops without producing any value, 1635 | -- The first element of the return tuple is `Nothing`. 1636 | stepYield :: 1637 | (Monad m, Monad m') => 1638 | (forall p. m p -> m' p) -- ^ Lifting function (pass `id` if m' ~ m) 1639 | -> 1640 | m' a -- ^ Callback on input value request. 1641 | -> 1642 | m' () -- ^ Callback on termination 1643 | -> 1644 | ProcessT m (Event a) (Event b) -- ^ The machine to run. 1645 | -> 1646 | m' (Maybe b, ProcessT m (Event a) (Event b)) 1647 | stepYield lft aw stp pa0 = runRM pa0 $ 1648 | do 1649 | r <- go False 1650 | pa <- lftRM lft freeze 1651 | return (r, pa) 1652 | 1653 | where 1654 | go csmd = 1655 | lftRM lft sweepR >>= handleEv csmd 1656 | 1657 | handleEv _ (Event y) = 1658 | return $ Just y 1659 | 1660 | handleEv True NoEvent = 1661 | return Nothing 1662 | 1663 | handleEv False NoEvent = 1664 | do 1665 | x <- lift $ aw 1666 | _ <- lftRM lft $ feedR x 1667 | go True 1668 | 1669 | handleEv _ End = 1670 | lift stp >> return Nothing 1671 | -------------------------------------------------------------------------------- /src/Control/Arrow/Machine/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE Arrows #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE BangPatterns #-} 9 | 10 | #if __GLASGOW_HASKELL__ >= 708 11 | {-# LANGUAGE Safe #-} 12 | #else 13 | {-# LANGUAGE Trustworthy #-} 14 | #endif 15 | 16 | module 17 | Control.Arrow.Machine.Utils 18 | ( 19 | -- * AFRP-like utilities 20 | hold, 21 | dHold, 22 | accum, 23 | dAccum, 24 | edge, 25 | 26 | -- * Switches 27 | -- | Switches inspired by Yampa library. 28 | -- Signature is almost same, but collection requirement is not only 'Functor', 29 | -- but 'Tv.Traversable'. This is because of side effects. 30 | switch, 31 | dSwitch, 32 | rSwitch, 33 | drSwitch, 34 | kSwitch, 35 | dkSwitch, 36 | pSwitch, 37 | pSwitchB, 38 | rpSwitch, 39 | rpSwitchB, 40 | 41 | -- * Sources 42 | -- $sources 43 | 44 | source, 45 | blockingSource, 46 | interleave, 47 | blocking, 48 | 49 | -- * Other utility arrows 50 | tee, 51 | gather, 52 | fork, 53 | fire, 54 | fire0, 55 | anytime, 56 | par, 57 | parB, 58 | oneshot, 59 | now, 60 | onEnd, 61 | #if defined(MIN_VERSION_arrows) 62 | -- * Transformer 63 | -- readerProc 64 | #endif 65 | ) 66 | where 67 | 68 | import Prelude hiding (filter) 69 | 70 | import qualified Data.List.NonEmpty as NonEmpty 71 | import qualified Data.Foldable as Fd 72 | import qualified Control.Category as Cat 73 | import Control.Monad.Trans 74 | import Control.Monad.State 75 | import Control.Arrow 76 | #if defined(MIN_VERSION_arrows) 77 | import Control.Arrow.Transformer.Reader (ArrowAddReader(..)) 78 | #endif 79 | -- import Control.Arrow.Machine.ArrowUtil 80 | import Control.Arrow.Machine.Types 81 | 82 | -- $setup 83 | -- >>> :set -XArrows 84 | 85 | 86 | 87 | hold :: 88 | Monad m => b -> ProcessT m (Event b) b 89 | hold old = proc evx -> 90 | do 91 | rSwitch (pure old) -< ((), pure <$> evx) 92 | 93 | dHold :: 94 | Monad m => b -> ProcessT m (Event b) b 95 | dHold old = proc evx -> 96 | do 97 | drSwitch (pure old) -< ((), pure <$> evx) 98 | 99 | -- | Accumulate inputs like fold. 100 | -- 101 | -- >>> :{ 102 | -- let pa = proc evx -> 103 | -- do 104 | -- val <- accum 0 -< (+1) <$ evx 105 | -- returnA -< val <$ evx 106 | -- in 107 | -- run pa (replicate 10 ()) 108 | -- :} 109 | -- [1,2,3,4,5,6,7,8,9,10] 110 | -- 111 | -- Since 4.0.0, this function become strict for the first argument 112 | -- because lazy one could rarely be used. 113 | -- 114 | -- You can make `switch`es to make lazy one. 115 | 116 | accum :: 117 | Monad m => b -> ProcessT m (Event (b->b)) b 118 | accum !x = switch (pure x &&& arr (($x)<$>)) accum' 119 | where 120 | accum' y = dSwitch (pure y &&& Cat.id) (const (accum y)) 121 | 122 | -- | Delayed version of `accum`. 123 | -- 124 | -- >>> :{ 125 | -- let pa = proc evx -> 126 | -- do 127 | -- val <- dAccum 0 -< (+1) <$ evx 128 | -- returnA -< val <$ evx 129 | -- in 130 | -- run pa (replicate 10 ()) 131 | -- :} 132 | -- [0,1,2,3,4,5,6,7,8,9] 133 | -- 134 | -- Since 4.0.0, this function become strict for the first argument 135 | -- because lazy one could rarely be used. 136 | -- 137 | -- You can make `switch`es to make lazy one. 138 | 139 | dAccum :: 140 | Monad m => b -> ProcessT m (Event (b->b)) b 141 | dAccum !x = dSwitch (pure x &&& arr (($x)<$>)) dAccum 142 | 143 | 144 | -- |Detects edges of input behaviour. 145 | -- 146 | -- >>> run (hold 0 >>> edge) [1, 1, 2, 2, 2, 3] 147 | -- [0,1,2,3] 148 | -- 149 | -- >>> run (hold 0 >>> edge) [0, 1, 1, 2, 2, 2, 3] 150 | -- [0,1,2,3] 151 | edge :: 152 | (Monad m, Eq b) => 153 | ProcessT m b (Event b) 154 | edge = proc x -> 155 | do 156 | rec 157 | ev <- unsafeExhaust (return . judge) -< (prv, x) 158 | prv <- dHold Nothing -< Just x <$ ev 159 | returnA -< ev 160 | where 161 | judge (prv, x) = if prv == Just x then Nothing else Just x 162 | 163 | 164 | -- $sources 165 | -- In addition to the main event stream privided by `run`, 166 | -- there are two other ways to provide additional input streams, 167 | -- "interleaved" sources and "blocking" sources. 168 | -- 169 | -- Interleaved sources are actually Event -> Event transformers 170 | -- that don't see the values of the input events. 171 | -- They discard input values and emit their values according to input event timing. 172 | -- 173 | -- Blocking sources emit their events independent from upstream. 174 | -- Until they exhaust their values, they block upstream transducers. 175 | -- 176 | -- Here is a demonstration of two kind of sources. 177 | -- 178 | -- @ 179 | -- a = proc x -> 180 | -- do 181 | -- y1 <- source [1, 2, 3] -< x 182 | -- y2 <- source [4, 5, 6] -< x 183 | -- 184 | -- gather -< [y1, y2] 185 | -- -- run a (repeat ()) => [1, 4, 2, 5, 3, 6] 186 | -- 187 | -- b = proc _ -> 188 | -- do 189 | -- y1 <- blockingSource [1, 2, 3] -< () 190 | -- y2 <- blockingSource [4, 5, 6] -< () 191 | -- 192 | -- gather -< [y1, y2] 193 | -- -- run b [] => [4, 5, 6, 1, 2, 3] 194 | -- @ 195 | -- 196 | -- In above code, you'll see that output values of `source` 197 | -- (an interleaved source) are actually interelaved, 198 | -- while `blockingSource` blocks another upstream source. 199 | -- 200 | -- And they can both implemented using `PlanT`. 201 | -- The only one deference is `await` call to listen upstream event timing. 202 | -- 203 | -- An example is below. 204 | -- 205 | -- @ 206 | -- interleavedStdin = constructT kleisli0 (forever pl) 207 | -- where 208 | -- pl = 209 | -- do 210 | -- _ <- await 211 | -- eof <- isEOF 212 | -- if isEOF then stop else return() 213 | -- getLine >>= yield 214 | -- 215 | -- blockingStdin = pure noEvent >>> constructT kleisli0 (forever pl) 216 | -- where 217 | -- pl = 218 | -- do 219 | -- -- No await here 220 | -- eof <- isEOF 221 | -- if isEOF then stop else return() 222 | -- getLine >>= yield 223 | -- @ 224 | -- 225 | -- They are different in the end behavior. 226 | -- When upstream stops, an interleaved source stops because await call fails. 227 | -- But a blocking source doesn't stop until its own termination. 228 | 229 | 230 | -- | Provides a source event stream. 231 | -- A dummy input event stream is needed. 232 | -- 233 | -- @ 234 | -- run af [...] 235 | -- @ 236 | -- 237 | -- is equivalent to 238 | -- 239 | -- @ 240 | -- run (source [...] >>> af) (repeat ()) 241 | -- @ 242 | source :: 243 | (Monad m, Fd.Foldable f) => 244 | f a -> ProcessT m (Event i) (Event a) 245 | source l = construct (Fd.mapM_ yd l) 246 | where 247 | yd x = await >> yield x 248 | 249 | -- | Provides a blocking event stream. 250 | blockingSource :: 251 | (Monad m, Fd.Foldable f) => 252 | f a -> ProcessT m ZeroEvent (Event a) 253 | blockingSource l = arr collapse >>> construct (Fd.mapM_ yield l) 254 | 255 | -- | Make a blocking source interleaved. 256 | interleave :: 257 | Monad m => 258 | ProcessT m ZeroEvent (Event a) -> 259 | ProcessT m (Event i) (Event a) 260 | interleave bs0 = sweep1 (mempty >>> bs0) 261 | where 262 | waiting bs r = 263 | dSwitch 264 | (handler bs r) 265 | sweep1 266 | sweep1 bs = 267 | kSwitch 268 | bs 269 | (arr snd) 270 | waiting 271 | handler bs r = proc ev -> 272 | do 273 | ev' <- splitter bs r -< ev 274 | returnA -< (filterJust (fst <$> ev'), snd <$> ev') 275 | splitter bs r = 276 | (arr collapse >>>) . construct $ 277 | do 278 | _ <- await 279 | yield (Just r, bs) 280 | `catchP` 281 | yield (Nothing, bs >>> muted) 282 | 283 | -- | Make an interleaved source blocking. 284 | blocking :: 285 | Monad m => 286 | ProcessT m (Event ()) (Event a) -> 287 | ProcessT m ZeroEvent (Event a) 288 | blocking is = dSwitch (blockingSource (repeat ()) >>> is >>> (Cat.id &&& onEnd)) (const stopped) 289 | 290 | 291 | -- 292 | -- other utility arrow 293 | 294 | -- |Make two event streams into one. 295 | -- Actually `gather` is more general and convenient; 296 | -- 297 | -- @... \<- tee -\< (e1, e2)@ 298 | -- 299 | -- is equivalent to 300 | -- 301 | -- @... \<- gather -\< [Left \<$\> e1, Right \<$\> e2]@ 302 | -- 303 | tee :: 304 | Monad m => ProcessT m (Event b1, Event b2) (Event (Either b1 b2)) 305 | tee = proc (e1, e2) -> gather -< [Left <$> e1, Right <$> e2] 306 | 307 | 308 | 309 | -- |Make multiple event channels into one. 310 | -- If simultaneous events are given, lefter one is emitted earlier. 311 | -- 312 | -- >>> :{ 313 | -- let pa = proc x -> 314 | -- do 315 | -- r1 <- filterEvent (\x -> x `mod` 2 == 0) -< x 316 | -- r2 <- filterEvent (\x -> x `mod` 3 == 0) -< x 317 | -- gather -< [r1, r2] 318 | -- in 319 | -- run pa [1..6] 320 | -- :} 321 | -- [2,3,4,6,6] 322 | -- 323 | -- It is terminated when the last input finishes. 324 | -- 325 | -- >>> :{ 326 | -- let pa = proc x -> 327 | -- do 328 | -- r1 <- filterEvent (\x -> x `mod` 3 == 0) -< x :: Event Int 329 | -- r2 <- stopped -< x 330 | -- r3 <- returnA -< r2 331 | -- fin <- gather -< [r1, r2, r3] 332 | -- val <- hold 0 -< r1 333 | -- end <- onEnd -< fin 334 | -- returnA -< val <$ end 335 | -- in 336 | -- run pa [1..5] 337 | -- :} 338 | -- [3] 339 | 340 | gather :: 341 | (Monad m, Fd.Foldable f) => 342 | ProcessT m (f (Event b)) (Event b) 343 | gather = arr (Fd.foldMap $ fmap singleton) >>> fork 344 | where 345 | singleton x = x NonEmpty.:| [] 346 | 347 | 348 | -- |Given an array-valued event and emit it's values as inidvidual events. 349 | -- 350 | -- >>> run fork [[1,2,3],[],[4,5]] 351 | -- [1,2,3,4,5] 352 | fork :: 353 | (Monad m, Fd.Foldable f) => 354 | ProcessT m (Event (f b)) (Event b) 355 | 356 | fork = repeatedly $ 357 | await >>= Fd.mapM_ yield 358 | 359 | -- |Executes an action once per an input event is provided. 360 | fire :: 361 | Monad m => 362 | (b -> m c) -> 363 | ProcessT m (Event b) (Event c) 364 | fire fmy = repeatedlyT $ 365 | do 366 | x <- await 367 | y <- lift $ fmy x 368 | yield y 369 | 370 | -- |Executes an action once per an input event is provided. 371 | fire0 :: 372 | Monad m => 373 | m c -> 374 | ProcessT m (Event ()) (Event c) 375 | fire0 = fire . const 376 | 377 | -- |Executes an action once per an input event is provided. 378 | anytime :: 379 | ArrowApply a => 380 | a b c -> 381 | ProcessA a (Event b) (Event c) 382 | anytime f = fire (\x -> ArrowMonad (arr (const x) >>> f)) 383 | 384 | -- |Emit an event of given value as soon as possible. 385 | oneshot :: 386 | Monad m => 387 | c -> 388 | ProcessT m b (Event c) 389 | oneshot x = arr (const noEvent) >>> go 390 | where 391 | go = construct $ 392 | yield x >> forever await 393 | 394 | -- |Emit an event as soon as possible. 395 | -- 396 | -- @ 397 | -- now = oneshot () 398 | -- @ 399 | now :: 400 | Monad m => 401 | ProcessT m b (Event ()) 402 | now = oneshot () 403 | 404 | -- |Emit an event at the end of the input stream. 405 | -- >>> :{ 406 | -- let 407 | -- pa = proc evx -> 408 | -- do 409 | -- x <- hold 0 -< evx 410 | -- ed <- onEnd -< evx 411 | -- returnA -< x <$ ed 412 | -- in 413 | -- run pa [1..10] 414 | -- :} 415 | -- [10] 416 | onEnd :: 417 | (Monad m, Occasional' b) => 418 | ProcessT m b (Event ()) 419 | onEnd = arr collapse >>> go 420 | where 421 | go = repeatedly $ 422 | await `catchP` (yield () >> stop) 423 | 424 | 425 | #if defined(MIN_VERSION_arrows) 426 | {- 427 | -- | Run reader of base arrow. 428 | readerProc :: 429 | (Monad m, Monad m', ArrowAddReader r a a') => 430 | ProcessT m b c -> 431 | ProcessT m' (b, r) c 432 | readerProc pa = arr swap >>> fitW snd (\ar -> arr swap >>> elimReader ar) pa 433 | where 434 | swap :: (a, b) -> (b, a) 435 | swap ~(a, b) = (b, a) 436 | -} 437 | #endif 438 | -------------------------------------------------------------------------------- /test/Common/RandomProc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE Arrows #-} 4 | 5 | module 6 | Common.RandomProc 7 | where 8 | 9 | import Prelude 10 | import Control.Arrow.Machine as P 11 | import Control.Arrow 12 | import qualified Control.Category as Cat 13 | import Control.Applicative 14 | import Control.Monad 15 | import Control.Monad.Trans 16 | import Control.Monad.State 17 | import Control.Monad.Writer 18 | import Test.QuickCheck (Arbitrary, arbitrary, oneof, frequency, sized) 19 | import Data.Maybe (fromJust) 20 | import Data.Monoid (Sum(..), getSum, mappend) 21 | import Data.Foldable (foldMap) 22 | 23 | 24 | data ProcJoin = PjFst ProcGen | PjSnd ProcGen | PjSum ProcGen 25 | deriving Show 26 | 27 | data ProcGen = PgNop | 28 | PgStop | 29 | PgPush ProcGen | 30 | PgPop (ProcGen, ProcGen) ProcJoin | 31 | PgOdd ProcGen | 32 | PgDouble ProcGen | 33 | PgIncl ProcGen | 34 | PgHarf ProcGen 35 | deriving Show 36 | 37 | instance 38 | Arbitrary ProcJoin 39 | where 40 | arbitrary = oneof [liftM PjFst arbitrary, 41 | liftM PjSnd arbitrary, 42 | liftM PjSum arbitrary] 43 | 44 | instance 45 | Arbitrary ProcGen 46 | where 47 | arbitrary = sized $ \i -> 48 | frequency [(40, rest), (40 + i, content)] 49 | where 50 | rest = return PgNop 51 | content = oneof [ 52 | return PgNop, 53 | return PgStop, 54 | liftM PgPush arbitrary, 55 | liftM2 PgPop arbitrary arbitrary, 56 | liftM PgOdd arbitrary, 57 | liftM PgDouble arbitrary, 58 | liftM PgIncl arbitrary, 59 | liftM PgHarf arbitrary 60 | ] 61 | type MyProcT = ProcessT (State [Int]) 62 | 63 | mkProc :: ProcGen 64 | -> MyProcT (Event Int) (Event Int) 65 | 66 | 67 | mkProc PgNop = Cat.id 68 | 69 | mkProc (PgPush next) = mc >>> mkProc next 70 | where 71 | mc = repeatedlyT $ 72 | do 73 | x <- await 74 | lift $ modify (\xs -> x:xs) 75 | yield x 76 | 77 | mkProc (PgPop (fx, fy) fz) = 78 | mc >>> ((evMap fst >>> fork) &&& (evMap snd >>> fork)) 79 | >>> (mkProc fx *** mkProc fy) >>> mkProcJ fz 80 | where 81 | mc = repeatedlyT $ 82 | do 83 | x <- await 84 | ys <- lift $ get 85 | case ys 86 | of 87 | [] -> 88 | yield (Just x, Nothing) 89 | (y:yss) -> 90 | do 91 | lift $ put yss 92 | yield (Just x, Just y) 93 | 94 | mkProc (PgOdd next) = P.filterEvent cond >>> mkProc next 95 | where 96 | cond x = x `mod` 2 == 1 97 | 98 | mkProc (PgDouble next) = arr (fmap $ \x -> [x, x]) >>> fork >>> mkProc next 99 | 100 | mkProc (PgIncl next) = arr (fmap (+1)) >>> mkProc next 101 | 102 | mkProc (PgHarf next) = arr (fmap (`div`2)) >>> mkProc next 103 | 104 | mkProc (PgStop) = stopped 105 | 106 | mkProcJ :: ProcJoin -> MyProcT (Event Int, Event Int) (Event Int) 107 | 108 | mkProcJ (PjFst pg) = arr fst 109 | mkProcJ (PjSnd pg) = arr snd 110 | mkProcJ (PjSum pg) = proc (evx, evy) -> 111 | returnA -< getSum <$> foldMap (Sum <$>) [evx, evy] 112 | 113 | 114 | stateProc :: MyProcT (Event a) (Event b) -> [a] -> ([b], [Int]) 115 | stateProc pa i = 116 | runState (execWriterT $ runT (\x -> tell [x]) (fit lift pa) i) [] 117 | 118 | class 119 | TestIn a 120 | where 121 | input :: MyProcT (Event Int) a 122 | 123 | class 124 | TestOut a 125 | where 126 | output :: MyProcT a (Event Int) 127 | 128 | instance 129 | TestIn (Event Int) 130 | where 131 | input = Cat.id 132 | 133 | instance 134 | TestOut (Event Int) 135 | where 136 | output = Cat.id 137 | 138 | instance 139 | (TestIn a, TestIn b) => TestIn (a, b) 140 | where 141 | input = mc >>> 142 | ((evMap fst >>> fork >>> input) &&& (evMap snd >>> fork >>> input)) 143 | where 144 | mc = repeatedly $ 145 | do 146 | x <- await 147 | y <- await 148 | yield (Just x, Just y) 149 | 150 | instance 151 | (TestOut a, TestOut b) => TestOut (a, b) 152 | where 153 | output = proc (x1, x2) -> 154 | do 155 | y1 <- output -< x1 156 | y2 <- output -< x2 157 | gather -< [y1, y2] 158 | 159 | instance 160 | (TestIn a, TestIn b) => 161 | TestIn (Either a b) 162 | where 163 | input = proc evx -> 164 | do 165 | -- 一個前の値で分岐してみる 166 | b <- dHold True -< 167 | (\x -> x `mod` 2 == 0) <$> evx 168 | 169 | if b 170 | then 171 | arr Left <<< input -< evx 172 | else 173 | arr Right <<< input -< evx 174 | 175 | instance 176 | (TestOut a, TestOut b) => TestOut (Either a b) 177 | where 178 | output = output ||| output 179 | 180 | type MyTestT a b = MyProcT a b -> MyProcT a b -> Bool 181 | 182 | mkEquivTest :: (TestIn a, TestOut b) => 183 | (Maybe (ProcGen, ProcJoin), ProcGen, ProcGen, [Int]) -> 184 | MyTestT a b 185 | mkEquivTest (Nothing, pre, post, l) pa pb = 186 | let 187 | preA = mkProc pre 188 | postA = mkProc post 189 | mkCompared p = preA >>> input >>> p >>> output >>> postA 190 | x = stateProc (mkCompared pa) l 191 | y = stateProc (mkCompared pb) l 192 | in 193 | x == y 194 | 195 | mkEquivTest (Just (par, j), pre, post, l) pa pb = 196 | let 197 | preA = mkProc pre 198 | postA = mkProc post 199 | parA = mkProc par 200 | joinA = mkProcJ j 201 | mkCompared p = preA >>> input >>> p >>> output >>> postA 202 | x = stateProc (mkCompared pa) l 203 | y = stateProc (mkCompared pb) l 204 | in 205 | x == y 206 | 207 | mkEquivTest2 ::(Maybe (ProcGen, ProcJoin), ProcGen, ProcGen, [Int]) -> 208 | MyProcT (Event Int, Event Int) (Event Int, Event Int) -> 209 | MyProcT (Event Int, Event Int) (Event Int, Event Int) -> 210 | Bool 211 | mkEquivTest2 = mkEquivTest 212 | 213 | -------------------------------------------------------------------------------- /test/Misc/PumpSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | 3 | module 4 | Misc.PumpSpec 5 | where 6 | 7 | import Data.Functor 8 | import Control.Arrow 9 | import Test.Hspec 10 | 11 | import Control.Category ((>>>)) 12 | 13 | import Control.Arrow.Machine as P 14 | import Control.Monad.Trans (liftIO) 15 | import qualified Control.Arrow.Machine.Misc.Pump as Pump 16 | 17 | import Data.Monoid (Endo(Endo), mappend, appEndo) 18 | 19 | import Data.IORef 20 | 21 | newtype Duct a = Duct (Endo [a]) 22 | 23 | doubler = arr (fmap $ \x -> [x, x]) >>> P.fork 24 | 25 | spec = 26 | do 27 | it "pumps up an event stream." $ 28 | do 29 | ref <- newIORef ([] :: [Int]) 30 | let 31 | pa :: ProcessT IO (Event Int) (Event ()) 32 | pa = proc evx -> 33 | do 34 | rec 35 | evOut <- Pump.outlet -< (dct, () <$ evx) 36 | fire (putStr) -< "" <$ evx -- side effect 37 | so <- doubler -< evx 38 | dct <- Pump.intake -< (so, () <$ evx) 39 | fire (\x -> modifyIORef ref (x:)) -< evOut 40 | 41 | liftIO $ P.runT_ pa [4, 5, 6] 42 | ret <- readIORef ref 43 | reverse ret `shouldBe` [4, 4, 5, 5, 6, 6] 44 | 45 | 46 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | 3 | -------------------------------------------------------------------------------- /test/Types/BasicSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE Arrows #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE NoMonomorphismRestriction #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | 9 | module 10 | Types.BasicSpec 11 | where 12 | 13 | import qualified Control.Arrow.Machine as P 14 | 15 | import Control.Arrow.Machine hiding (filter, source) 16 | import Control.Applicative 17 | import qualified Control.Category as Cat 18 | import Control.Arrow 19 | import Control.Monad.State 20 | import Control.Monad 21 | import Control.Monad.Trans 22 | import Control.Monad.Identity (Identity, runIdentity) 23 | import Debug.Trace 24 | import Test.Hspec 25 | import Test.Hspec.QuickCheck (prop) 26 | import Test.QuickCheck (Arbitrary, arbitrary, oneof, frequency, sized) 27 | 28 | import Common.RandomProc 29 | 30 | 31 | spec = 32 | do 33 | it "is stream transducer." $ 34 | do 35 | let 36 | process = repeatedly $ 37 | do 38 | x <- await 39 | yield x 40 | yield (x + 1) 41 | 42 | resultA = run process [1,2,4] 43 | 44 | resultA `shouldBe` [1, 2, 2, 3, 4, 5] 45 | 46 | let 47 | -- 入力1度につき同じ値を2回出力する 48 | doubler = repeatedly $ 49 | do {x <- await; yield x; yield x} 50 | -- 入力値をStateのリストの先頭にPushする副作用を行い、同じ値を出力する 51 | pusher = repeatedlyT $ 52 | do {x <- await; lift $ modify (x:); yield x} 53 | 54 | it "has stop state" $ 55 | let 56 | -- 一度だけ入力をそのまま出力し、すぐに停止する 57 | onlyOnce = construct $ await >>= yield 58 | 59 | x = stateProc (doubler >>> pusher >>> onlyOnce) [3, 3] 60 | in 61 | -- 最後尾のMachineが停止した時点で処理を停止するが、 62 | -- 既にa2が出力した値の副作用は処理する 63 | x `shouldBe` ([3], [3, 3]) 64 | 65 | it "has side-effect" $ 66 | let 67 | incl = evMap (+1) 68 | 69 | -- doublerで信号が2つに分岐する。 70 | -- このとき、副作用は1つ目の信号について末尾まで 71 | -- -> 二つ目の信号について分岐点から末尾まで ... 72 | -- の順で処理される。 73 | a = pusher >>> doubler >>> incl >>> pusher >>> incl >>> pusher 74 | 75 | x = stateProc a [1000] 76 | in 77 | x `shouldBe` ([1002, 1002], reverse [1000,1001,1002,1001,1002]) 78 | 79 | it "never spoils any FEED" $ 80 | let 81 | counter = construct $ counterDo 1 82 | counterDo n = 83 | do 84 | x <- await 85 | yield $ n * 100 + x 86 | counterDo (n+1) 87 | x = stateProc (doubler >>> doubler >>> counter) [1,2] 88 | in 89 | fst x `shouldBe` [101, 201, 301, 401, 502, 602, 702, 802] 90 | 91 | prop "each path can have independent number of events" $ \l -> 92 | let 93 | split2' = fmap fst &&& fmap snd 94 | gen = arr (fmap $ \x -> [x, x]) >>> fork >>> arr split2' 95 | r1 = run (gen >>> arr fst) (l::[(Int, [Int])]) 96 | r2 = run (gen >>> second (fork >>> repeatedly (await >>= yield)) >>> arr fst) 97 | (l::[(Int, [Int])]) 98 | in 99 | r1 == r2 100 | 101 | it "is lazy for individual input values" $ 102 | do 103 | let l = run Cat.id (take 10 $ repeat undefined) 104 | length l `shouldBe` 10 105 | 106 | {- 107 | it "is lazy for inpurt stream" $ 108 | do 109 | let l = take 10 $ run Cat.id (repeat undefined) 110 | length l `shouldBe` 10 111 | -} 112 | -------------------------------------------------------------------------------- /test/Types/ChoiceSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE Arrows #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE NoMonomorphismRestriction #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | 9 | module 10 | Types.ChoiceSpec 11 | where 12 | 13 | import qualified Control.Arrow.Machine as P 14 | 15 | import Control.Arrow.Machine hiding (filter, source) 16 | import Control.Applicative 17 | import qualified Control.Category as Cat 18 | import Control.Arrow 19 | import Control.Monad.State 20 | import Control.Monad 21 | import Control.Monad.Trans 22 | import Control.Monad.Identity (Identity, runIdentity) 23 | import Debug.Trace 24 | import Test.Hspec 25 | import Test.Hspec.QuickCheck (prop) 26 | import Test.QuickCheck (Arbitrary, arbitrary, oneof, frequency, sized) 27 | 28 | import Common.RandomProc 29 | 30 | 31 | spec = 32 | do 33 | it "temp1" $ 34 | do 35 | let 36 | af = mkProc $ PgStop 37 | ag = mkProc $ PgOdd PgNop 38 | aj1 = arr Right 39 | aj2 = arr $ either id id 40 | l = [1] 41 | r1 = stateProc 42 | (aj1 >>> left af >>> aj2) 43 | l 44 | in 45 | r1 `shouldBe` ([1],[]) 46 | 47 | prop "left (f >>> g) = left f >>> left g" $ \fx gx cond -> 48 | let 49 | f = mkProc fx 50 | g = mkProc gx 51 | 52 | equiv = mkEquivTest cond 53 | ::(MyTestT (Either (Event Int) (Event Int)) 54 | (Either (Event Int) (Event Int))) 55 | in 56 | (left (f >>> g)) `equiv` (left f >>> left g) 57 | 58 | -------------------------------------------------------------------------------- /test/Types/LoopSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | 3 | module 4 | Types.LoopSpec 5 | where 6 | 7 | import Data.Functor 8 | import Control.Arrow 9 | import Test.Hspec 10 | 11 | import Control.Arrow.Machine as P 12 | import Control.Monad.Trans (liftIO) 13 | 14 | import Data.IORef 15 | 16 | import Common.RandomProc 17 | 18 | doubler = arr (fmap $ \x -> [x, x]) >>> P.fork 19 | 20 | spec = 21 | do 22 | it "is possible that value by `dHold` or `dAccum` can refer at upstream." $ 23 | do 24 | ref <- newIORef ([] :: [Int]) 25 | let 26 | pa :: ProcessT IO (Event Int) (Event ()) 27 | pa = proc evx -> 28 | do 29 | rec 30 | P.fire print -< y <$ evx 31 | P.fire putStr -< "" <$ evx -- side effect 32 | evx2 <- doubler -< evx 33 | y <- P.dAccum 0 -< (+) <$> evx2 34 | fire (\x -> modifyIORef ref (x:)) -< y <$ evx 35 | 36 | liftIO $ P.runT_ pa [1, 2, 3] 37 | ret <- readIORef ref 38 | reverse ret `shouldBe` [0, 1+1, 1+1+2+2] 39 | 40 | it "can be used with rec statement(pure)" $ 41 | let 42 | a = proc ev -> 43 | do 44 | x <- hold 0 -< ev 45 | rec l <- returnA -< x:l 46 | returnA -< l <$ ev 47 | result = fst $ stateProc a [2, 5] 48 | in 49 | take 3 (result!!1) `shouldBe` [5, 5, 5] 50 | 51 | it "the last value is valid." $ 52 | do 53 | let 54 | mc = repeatedly $ 55 | do 56 | x <- await 57 | yield x 58 | yield (x*2) 59 | pa = proc x -> 60 | do 61 | rec y <- mc -< (+z) <$> x 62 | z <- dHold 0 -< y 63 | returnA -< y 64 | run pa [1, 10] `shouldBe` [1, 2, 12, 24] 65 | 66 | it "carries no events to upstream." $ 67 | do 68 | let 69 | pa = proc ev -> 70 | do 71 | rec r <- dHold True -< False <$ ev2 72 | ev2 <- fork -< [(), ()] <$ ev 73 | returnA -< r <$ ev 74 | run pa [1, 2, 3] `shouldBe` [True, True, True] 75 | 76 | -------------------------------------------------------------------------------- /test/Types/PlanSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE Arrows #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE NoMonomorphismRestriction #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | 9 | module 10 | Types.PlanSpec 11 | where 12 | 13 | import qualified Control.Arrow.Machine as P 14 | 15 | import Control.Arrow.Machine hiding (filter, source) 16 | import Control.Applicative 17 | import qualified Control.Category as Cat 18 | import Control.Arrow 19 | import Control.Monad.State 20 | import Control.Monad 21 | import Control.Monad.Trans 22 | import Control.Monad.Identity (Identity, runIdentity) 23 | import Debug.Trace 24 | import Test.Hspec 25 | import Test.Hspec.QuickCheck (prop) 26 | import Test.QuickCheck (Arbitrary, arbitrary, oneof, frequency, sized) 27 | 28 | import Common.RandomProc 29 | 30 | 31 | spec = 32 | do 33 | let pl = 34 | do 35 | x <- await 36 | yield x 37 | yield (x+1) 38 | x <- await 39 | yield x 40 | yield (x+1) 41 | l = [2, 5, 10, 20, 100] 42 | 43 | it "can be constructed into ProcessA" $ 44 | do 45 | let 46 | result = run (construct pl) l 47 | result `shouldBe` [2, 3, 5, 6] 48 | 49 | it "can be repeatedly constructed into ProcessA" $ 50 | do 51 | let 52 | result = run (repeatedly pl) l 53 | result `shouldBe` [2, 3, 5, 6, 10, 11, 20, 21, 100, 101] 54 | 55 | it "can handle the end with catchP." $ 56 | do 57 | let 58 | plCatch = 59 | do 60 | x <- await `catchP` (yield 1 >> stop) 61 | yield x 62 | y <- (yield 2 >> await >> yield 3 >> await) `catchP` (yield 4 >> return 5) 63 | yield y 64 | y <- (await >>= yield >> stop) `catchP` (yield 6 >> return 7) 65 | yield y 66 | run (construct plCatch) [] `shouldBe` [1] 67 | run (construct plCatch) [100] `shouldBe` [100, 2, 4, 5, 6, 7] 68 | run (construct plCatch) [100, 200] `shouldBe` [100, 2, 3, 4, 5, 6, 7] 69 | run (construct plCatch) [100, 200, 300] `shouldBe` [100, 2, 3, 300, 6, 7] 70 | run (construct plCatch) [100, 200, 300, 400] `shouldBe` [100, 2, 3, 300, 400, 6, 7] 71 | -------------------------------------------------------------------------------- /test/Types/RuleSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE Arrows #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE NoMonomorphismRestriction #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | 9 | module 10 | Types.RuleSpec 11 | where 12 | 13 | import qualified Control.Arrow.Machine as P 14 | 15 | import Control.Arrow.Machine hiding (filter, source) 16 | import Control.Applicative 17 | import qualified Control.Category as Cat 18 | import Control.Arrow 19 | import Control.Monad.State 20 | import Control.Monad 21 | import Control.Monad.Trans 22 | import Control.Monad.Identity (Identity, runIdentity) 23 | import Debug.Trace 24 | import Test.Hspec 25 | import Test.Hspec.QuickCheck (prop) 26 | import Test.QuickCheck (Arbitrary, arbitrary, oneof, frequency, sized) 27 | 28 | import Common.RandomProc 29 | 30 | 31 | spec = 32 | do 33 | describe "ProcessA as Category" $ catSpec 34 | describe "ProcessA as Arrow" $ arrSpec 35 | describe "Rules for ArrowLoop" $ arrowLoopSpec 36 | 37 | catSpec = 38 | do 39 | prop "has asocciative composition" $ \fx gx hx cond -> 40 | let 41 | f = mkProc fx 42 | g = mkProc gx 43 | h = mkProc hx 44 | equiv = mkEquivTest cond 45 | in 46 | ((f >>> g) >>> h) `equiv` (f >>> (g >>> h)) 47 | 48 | prop "has identity" $ \fx gx cond -> 49 | let 50 | f = mkProc fx 51 | g = mkProc gx 52 | equiv = mkEquivTest cond 53 | in 54 | (f >>> g) `equiv` (f >>> Cat.id >>> g) 55 | 56 | arrSpec = 57 | do 58 | it "can be made from pure function(arr)" $ 59 | do 60 | (run . arr . fmap $ (+ 2)) [1, 2, 3] 61 | `shouldBe` [3, 4, 5] 62 | 63 | prop "arr id is identity" $ \fx gx cond -> 64 | let 65 | f = mkProc fx 66 | g = mkProc gx 67 | equiv = mkEquivTest cond 68 | in 69 | (f >>> g) `equiv` (f >>> arr id >>> g) 70 | 71 | it "can be parallelized" $ 72 | do 73 | pendingWith "to correct" 74 | {- 75 | let 76 | myProc2 = repeatedlyT (Kleisli . const) $ 77 | do 78 | x <- await 79 | lift $ modify (++ [x]) 80 | yield `mapM` (take x $ repeat x) 81 | 82 | toN = evMaybe Nothing Just 83 | en (ex, ey) = Event (toN ex, toN ey) 84 | de evxy = (fst <$> evxy, snd <$> evxy) 85 | 86 | l = map (\x->(x,x)) [1,2,3] 87 | 88 | (result, state) = 89 | stateProc (arr de >>> first myProc2 >>> arr en) l 90 | 91 | (result >>= maybe mzero return . fst) 92 | `shouldBe` [1,2,2,3,3,3] 93 | (result >>= maybe mzero return . snd) 94 | `shouldBe` [1,2,3] 95 | state `shouldBe` [1,2,3] 96 | -} 97 | 98 | prop "first and composition." $ \fx gx cond -> 99 | let 100 | f = mkProc fx 101 | g = mkProc gx 102 | equiv = mkEquivTest2 cond 103 | in 104 | (first (f >>> g)) `equiv` (first f >>> first g) 105 | 106 | prop "first-second commutes" $ \fx cond -> 107 | let 108 | f = first $ mkProc fx 109 | g = second (arr $ fmap (+2)) 110 | 111 | equiv = mkEquivTest2 cond 112 | in 113 | (f >>> g) `equiv` (g >>> f) 114 | 115 | prop "first-fst commutes" $ \fx cond -> 116 | let 117 | f = mkProc fx 118 | equiv = mkEquivTest cond 119 | ::(MyTestT (Event Int, Event Int) (Event Int)) 120 | in 121 | (first f >>> arr fst) `equiv` (arr fst >>> f) 122 | 123 | prop "assoc relation" $ \fx cond -> 124 | let 125 | f = mkProc fx 126 | assoc ((a,b),c) = (a,(b,c)) 127 | 128 | equiv = mkEquivTest cond 129 | ::(MyTestT ((Event Int, Event Int), Event Int) 130 | (Event Int, (Event Int, Event Int))) 131 | in 132 | (first (first f) >>> arr assoc) `equiv` (arr assoc >>> first f) 133 | 134 | arrowLoopSpec = 135 | do 136 | let 137 | fixcore f y = if y `mod` 5 == 0 then y else y + f (y-1) 138 | pure (evx, f) = (f <$> evx, fixcore f) 139 | apure = arr pure 140 | 141 | prop "left tightening" $ \fx cond -> 142 | let 143 | f = mkProc fx 144 | 145 | equiv = mkEquivTest cond 146 | in 147 | (loop (first f >>> apure)) `equiv` (f >>> loop apure) 148 | 149 | prop "right tightening" $ \fx cond -> 150 | let 151 | f = mkProc fx 152 | 153 | equiv = mkEquivTest cond 154 | in 155 | (loop (apure >>> first f)) `equiv` (loop apure >>> f) 156 | -------------------------------------------------------------------------------- /test/Types/StepExecutionSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE Arrows #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE NoMonomorphismRestriction #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | {-# LANGUAGE NamedFieldPuns #-} 9 | 10 | module 11 | Types.StepExecutionSpec 12 | where 13 | 14 | import qualified Control.Arrow.Machine as P 15 | 16 | import Data.Maybe (isJust) 17 | import Control.Arrow.Machine hiding (filter, source) 18 | import Control.Applicative 19 | import qualified Control.Category as Cat 20 | import Control.Arrow 21 | import Control.Monad.State 22 | import Control.Monad 23 | import Control.Monad.Trans 24 | import Control.Monad.Identity (Identity, runIdentity) 25 | import Debug.Trace 26 | import Test.Hspec 27 | import Test.Hspec.QuickCheck (prop) 28 | import Test.QuickCheck (Arbitrary, arbitrary, oneof, frequency, sized) 29 | 30 | import Common.RandomProc 31 | 32 | -- | Represents return values and informations of step executions. 33 | data ExecInfo a = 34 | ExecInfo 35 | { 36 | yields :: [a], -- ^ Values yielded while the step. 37 | hasConsumed :: Bool, -- ^ True if the input value is consumed. 38 | -- 39 | -- False if the machine has stopped unless consuming the input. 40 | -- 41 | -- Or in the case of `stepYield`, this field become false when 42 | -- the machine produces a value unless consuming the input. 43 | hasStopped :: Bool -- ^ True if the machine has stopped at the end of the step. 44 | } 45 | deriving (Eq, Show) 46 | 47 | 48 | spec = 49 | do 50 | it "supports step execution" $ 51 | do 52 | let 53 | pl = 54 | do 55 | x <- await 56 | yield x 57 | yield (x+1) 58 | x <- await 59 | yield x 60 | yield (x+1) 61 | yield (x+5) 62 | init = construct pl 63 | 64 | pl2 = 65 | do 66 | _ <- await 67 | return () 68 | init2 = construct pl2 69 | 70 | emptyEI = ExecInfo 71 | { 72 | yields = [], 73 | hasConsumed = True, -- Set False if there's any leftover 74 | hasStopped = False 75 | } 76 | 77 | onYield x = 78 | modify $ \ei@ExecInfo{yields = xs} -> ei {yields = xs ++ [x]} 79 | 80 | onStop ma = 81 | modify $ \ei -> ei {hasConsumed = not (isJust ma), hasStopped = True} 82 | 83 | -- execution part 84 | -- x <- await 85 | -- yield x 86 | -- yield (x+1) 87 | (now, ret) <- runStateT (stepRun lift onYield onStop init 1) emptyEI 88 | yields ret `shouldBe` [1, 2] 89 | hasConsumed ret `shouldBe` True 90 | hasStopped ret `shouldBe` False 91 | 92 | -- execution part 93 | -- x <- await 94 | -- yield x 95 | -- yield (x+1) 96 | -- yield (x+5) 97 | (now, ret) <- runStateT (stepRun lift onYield onStop now 1) emptyEI 98 | yields ret `shouldBe` [1, 2, 6] 99 | hasConsumed ret `shouldBe` True 100 | hasStopped ret `shouldBe` True 101 | 102 | -- no execution part is left 103 | (now, ret) <- runStateT (stepRun lift onYield onStop now 1) emptyEI 104 | yields ret `shouldBe` ([]::[Int]) 105 | hasConsumed ret `shouldBe` False 106 | hasStopped ret `shouldBe` True 107 | 108 | -- execution part 109 | -- _ <- await 110 | -- return () 111 | (now, ret) <- runStateT (stepRun lift onYield onStop init2 1) emptyEI 112 | yields ret `shouldBe` ([]::[Int]) 113 | hasConsumed ret `shouldBe` True 114 | hasStopped ret `shouldBe` True 115 | 116 | it "supports yield-driven step" $ 117 | do 118 | let 119 | init = construct $ 120 | do 121 | yield (-1) 122 | _ <- await 123 | x <- await 124 | mapM yield (iterate (+1) x) -- infinite 125 | init2 = construct $ 126 | do 127 | return () 128 | init3 = construct $ 129 | do 130 | _ <- await 131 | return () 132 | 133 | emptyEI = ExecInfo 134 | { 135 | yields = [], -- Not used 136 | hasConsumed = False, 137 | hasStopped = False 138 | } 139 | 140 | provide x = 141 | do 142 | modify $ \ei -> ei {hasConsumed = True} 143 | return x 144 | 145 | onStop = 146 | modify $ \ei -> ei {hasStopped = True} 147 | 148 | -- execution part 149 | -- yield (-1) 150 | ((val, now), ret) <- runStateT (stepYield lift (provide 5) onStop init) emptyEI 151 | val `shouldBe` Just (-1) 152 | hasConsumed ret `shouldBe` False 153 | hasStopped ret `shouldBe` False 154 | 155 | -- execution part 156 | -- _ <- await 157 | ((val, now), ret) <- runStateT (stepYield lift (provide 6) onStop now) emptyEI 158 | val `shouldBe` Nothing 159 | hasConsumed ret `shouldBe` True 160 | hasStopped ret `shouldBe` False 161 | 162 | -- execution part 163 | -- x <- await 164 | -- mapM yield (iterate (+1) x) -- first one 165 | ((val, now), ret) <- runStateT (stepYield lift (provide 10) onStop now) emptyEI 166 | val `shouldBe` Just 10 167 | hasConsumed ret `shouldBe` True 168 | hasStopped ret `shouldBe` False 169 | 170 | -- execution part 171 | -- mapM yield (iterate (+1) x) -- second one 172 | ((val, now), ret) <- runStateT (stepYield lift (provide 10) onStop now) emptyEI 173 | val `shouldBe` Just 11 174 | hasConsumed ret `shouldBe` False 175 | hasStopped ret `shouldBe` False 176 | 177 | -- execution part 178 | -- return () 179 | ((val, now), ret) <- runStateT (stepYield lift (provide 0) onStop init2) emptyEI 180 | val `shouldBe` (Nothing :: Maybe Int) 181 | hasConsumed ret `shouldBe` False 182 | hasStopped ret `shouldBe` True 183 | 184 | -- execution part 185 | -- _ <- await 186 | -- return () 187 | ((val, now), ret) <- runStateT (stepYield lift (provide 0) onStop init3) emptyEI 188 | val `shouldBe` (Nothing :: Maybe Int) 189 | hasConsumed ret `shouldBe` True 190 | hasStopped ret `shouldBe` True 191 | 192 | 193 | -------------------------------------------------------------------------------- /test/Types/SwitchSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE Arrows #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE NoMonomorphismRestriction #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | 9 | module 10 | Types.SwitchSpec 11 | where 12 | 13 | import Data.Maybe (fromMaybe) 14 | import qualified Control.Arrow.Machine as P 15 | import Control.Arrow.Machine hiding (filter, source) 16 | import Control.Applicative 17 | import qualified Control.Category as Cat 18 | import Control.Arrow 19 | import Control.Monad.State 20 | import Control.Monad 21 | import Control.Monad.Trans 22 | import Control.Monad.Identity (Identity, runIdentity) 23 | import Debug.Trace 24 | import Test.Hspec 25 | import Test.Hspec.QuickCheck (prop) 26 | import Test.QuickCheck (Arbitrary, arbitrary, oneof, frequency, sized) 27 | 28 | import Common.RandomProc 29 | 30 | 31 | spec = 32 | do 33 | describe "kSwitch" $ 34 | do 35 | it "switches spontaneously" $ 36 | do 37 | let 38 | theArrow sw = sw (oneshot False) (arr snd) $ \_ _ -> oneshot True 39 | run (theArrow kSwitch) [] `shouldBe` [True] 40 | run (theArrow dkSwitch) [] `shouldBe` [False, True] 41 | -------------------------------------------------------------------------------- /test/Utils/SourceSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE Arrows #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE NoMonomorphismRestriction #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | 9 | module 10 | Utils.SourceSpec 11 | where 12 | 13 | import Data.Maybe (fromMaybe) 14 | import qualified Control.Arrow.Machine as P 15 | import Control.Arrow.Machine hiding (filter, source) 16 | import Control.Applicative 17 | import qualified Control.Category as Cat 18 | import Control.Arrow 19 | import Control.Monad.State 20 | import Control.Monad 21 | import Control.Monad.Trans 22 | import Control.Monad.Identity (Identity, runIdentity) 23 | import Debug.Trace 24 | import Test.Hspec 25 | import Test.Hspec.QuickCheck (prop) 26 | import Test.QuickCheck (Arbitrary, arbitrary, oneof, frequency, sized) 27 | 28 | import Common.RandomProc 29 | 30 | spec = 31 | do 32 | describe "source" $ 33 | do 34 | it "provides interleaved source stream" $ 35 | do 36 | let 37 | pa = proc cl -> 38 | do 39 | s1 <- P.source [1, 2, 3] -< cl 40 | s2 <- P.source [4, 5, 6] -< cl 41 | P.gather -< [s1, s2] 42 | P.run pa (repeat ()) `shouldBe` [1, 4, 2, 5, 3, 6] 43 | describe "blockingSource" $ 44 | do 45 | it "provides blocking source stream" $ 46 | do 47 | let 48 | pa = proc _ -> 49 | do 50 | s1 <- P.blockingSource [1, 2, 3] -< mempty 51 | s2 <- P.blockingSource [4, 5, 6] -< mempty 52 | P.gather -< [s1, s2] 53 | P.run pa (repeat ()) `shouldBe` [4, 5, 6, 1, 2, 3] 54 | 55 | describe "source and blockingSource" $ 56 | do 57 | prop "[interleave blockingSource = source]" $ \l cond -> 58 | let 59 | _ = l::[Int] 60 | equiv = mkEquivTest cond 61 | ::(MyTestT (Event Int) (Event Int)) 62 | in 63 | P.source l `equiv` P.interleave (P.blockingSource l) 64 | 65 | prop "[blocking source = blockingSource]" $ \l cond -> 66 | let 67 | _ = l::[Int] 68 | equiv = mkEquivTest cond 69 | ::(MyTestT (Event Int) (Event Int)) 70 | in 71 | (mempty >>> P.blockingSource l) 72 | `equiv` (mempty >>> P.blocking (P.source l)) 73 | 74 | 75 | -------------------------------------------------------------------------------- /test/doctest.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.DocTest 4 | 5 | main :: IO () 6 | main = doctest ["src"] 7 | 8 | 9 | --------------------------------------------------------------------------------