mvc 1.1.1 → 1.1.2
raw patch · 5 files changed
+794/−794 lines, 5 filesdep ~asyncdep ~contravariantsetup-changed
Dependency ranges changed: async, contravariant
Files
- LICENSE +24/−24
- Setup.hs +2/−2
- mvc.cabal +41/−41
- src/MVC.hs +495/−495
- src/MVC/Prelude.hs +232/−232
LICENSE view
@@ -1,24 +1,24 @@-Copyright (c) 2015 Gabriel Gonzalez -All rights reserved. - -Redistribution and use in source and binary forms, with or without modification, -are permitted provided that the following conditions are met: - * Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - * Neither the name of Gabriel Gonzalez nor the names of other contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR -ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES -(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; -LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON -ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +Copyright (c) 2015 Gabriel Gonzalez+All rights reserved.++Redistribution and use in source and binary forms, with or without modification,+are permitted provided that the following conditions are met:+ * Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.+ * Neither the name of Gabriel Gonzalez nor the names of other contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
mvc.cabal view
@@ -1,41 +1,41 @@-Name: mvc -Version: 1.1.1 -Cabal-Version: >=1.8.0.2 -Build-Type: Simple -License: BSD3 -License-File: LICENSE -Copyright: 2014 Gabriel Gonzalez -Author: Gabriel Gonzalez -Maintainer: Gabriel439@gmail.com -Bug-Reports: https://github.com/Gabriel439/Haskell-MVC-Library/issues -Synopsis: Model-view-controller -Description: Use the @mvc@ library to distill concurrent programs into pure and - single-threaded programs using the @Model@-@View@-@Controller@ pattern. This - transformation lets you: - . - * replay your program deterministically, - . - * do property-based testing of your model (like @QuickCheck@), and: - . - * equationally reason about your pure core. -Category: Control, Concurrency -Source-Repository head - Type: git - Location: https://github.com/Gabriel439/Haskell-MVC-Library - -Library - Hs-Source-Dirs: src - Build-Depends: - base >= 4 && < 5 , - async >= 2.0.0 && < 2.1, - contravariant < 1.4, - foldl >= 1.1 && < 1.2, - managed < 1.1, - mmorph >= 1.0.2 && < 1.1, - pipes >= 4.1.7 && < 4.2, - pipes-concurrency >= 2.0.3 && < 2.1, - transformers >= 0.2.0.0 && < 0.5.0.0 - Exposed-Modules: - MVC, - MVC.Prelude - GHC-Options: -O2 -Wall +Name: mvc+Version: 1.1.2+Cabal-Version: >=1.8.0.2+Build-Type: Simple+License: BSD3+License-File: LICENSE+Copyright: 2014 Gabriel Gonzalez+Author: Gabriel Gonzalez+Maintainer: Gabriel439@gmail.com+Bug-Reports: https://github.com/Gabriel439/Haskell-MVC-Library/issues+Synopsis: Model-view-controller+Description: Use the @mvc@ library to distill concurrent programs into pure and+ single-threaded programs using the @Model@-@View@-@Controller@ pattern. This+ transformation lets you:+ .+ * replay your program deterministically,+ .+ * do property-based testing of your model (like @QuickCheck@), and:+ .+ * equationally reason about your pure core.+Category: Control, Concurrency+Source-Repository head+ Type: git+ Location: https://github.com/Gabriel439/Haskell-MVC-Library++Library+ Hs-Source-Dirs: src+ Build-Depends:+ base >= 4 && < 5 ,+ async >= 2.0.0 && < 2.2,+ contravariant < 1.5,+ foldl >= 1.1 && < 1.2,+ managed < 1.1,+ mmorph >= 1.0.2 && < 1.1,+ pipes >= 4.1.7 && < 4.2,+ pipes-concurrency >= 2.0.3 && < 2.1,+ transformers >= 0.2.0.0 && < 0.5.0.0+ Exposed-Modules:+ MVC,+ MVC.Prelude+ GHC-Options: -O2 -Wall
src/MVC.hs view
@@ -1,495 +1,495 @@-{-| Use the `Model` - `View` - `Controller` pattern to separate impure inputs - and outputs from pure application logic so that you can: - - * Equationally reason about your model - - * Exercise your model with property-based testing (like @QuickCheck@) - - * Reproducibly replay your model - - The @mvc@ library uses the type system to statically enforce the separation - of impure `View`s and `Controller`s from the pure `Model`. - - Here's a small example program written using the @mvc@ library to illustrate - the core types and concepts: - -> import MVC -> import qualified MVC.Prelude as MVC -> import qualified Pipes.Prelude as Pipes -> -> external :: Managed (View String, Controller String) -> external = do -> c1 <- MVC.stdinLines -> c2 <- MVC.tick 1 -> return (MVC.stdoutLines, c1 <> fmap show c2) -> -> model :: Model () String String -> model = asPipe (Pipes.takeWhile (/= "quit")) -> -> main :: IO () -> main = runMVC () model external - - This program has three components: - - * A `Controller` that interleaves lines from standard input with periodic - ticks - - * A `View` that writes lines to standard output - - * A pure `Model`, which forwards lines until the user inputs \"quit\" - - 'runMVC' connects them into a complete program, which outputs a @()@ every - second and also echoes standard input to standard output until the user - enters \"quit\": - ->>> main -() -Test<Enter> -Test -() -() -42<Enter> -42 -() -quit<enter> ->>> - - The following sections give extended guidance for how to structure @mvc@ - programs. Additionally, there is an "MVC.Prelude" module, which provides - several utilities and provides a more elaborate code example using the - @sdl@ library. --} - -{-# LANGUAGE RankNTypes #-} - -module MVC ( - -- * Controllers - -- $controller - Controller - , asInput - , keeps - - -- * Views - -- $view - , View - , asSink - , asFold - , handles - - -- * Models - -- $model - , Model - , ModelM - , asPipe - - -- * MVC - -- $mvc - , runMVC - , generalizeMVC - - -- * Managed resources - -- $managed - , Managed - , managed - - -- *ListT - , loop - -- $listT - - -- * Re-exports - -- $reexports - , module Data.Functor.Constant - , module Data.Functor.Contravariant - , module Data.Monoid - , module Pipes - , module Pipes.Concurrent - ) where - -import Control.Category (Category(..)) -import Control.Foldl (FoldM(..), HandlerM, impurely, premapM) -import qualified Control.Foldl as Fold -import Control.Monad.Managed (Managed, managed, with) -import Control.Monad.Morph (generalize) -import Control.Monad.Trans.State.Strict (execStateT, StateT) -import Data.Functor.Constant (Constant(Constant, getConstant)) -import Data.Functor.Contravariant (Contravariant(contramap)) -import Data.Monoid (Monoid(mempty, mappend, mconcat), (<>), First) -import qualified Data.Monoid as M -import Pipes -import Pipes.Concurrent -import Pipes.Prelude (foldM, loop) -import Data.Functor.Identity (Identity) - -import Prelude hiding ((.), id) - -{- $controller - `Controller`s represent concurrent inputs to your system. Use the `Functor` - and `Monoid` instances for `Controller` and `Managed` to unify multiple - `Managed` `Controller`s together into a single `Managed` `Controller`: - -> controllerA :: Managed (Controller A) -> controllerB :: Managed (Controller B) -> controllerC :: Managed (Controller C) -> -> data TotalInput = InA A | InB B | InC C -> -> controllerTotal :: Managed (Controller TotalInput) -> controllerTotal = -> fmap (fmap InA) controllerA -> <> fmap (fmap InB) controllerB -> <> fmap (fmap InC) controllerC - - Combining `Controller`s interleaves their values. --} - -{-| A concurrent source - -> fmap f (c1 <> c2) = fmap f c1 <> fmap f c2 -> -> fmap f mempty = mempty --} -newtype Controller a = AsInput (Input a) --- This is just a newtype wrapper around `Input` because: --- --- * I want the `Controller` name to "stick" in inferred types --- --- * I want to restrict the API to ensure that `runMVC` is the only way to --- consume `Controller`s. This enforces strict separation of `Controller` --- logic from `Model` or `View` logic - --- Deriving `Functor` -instance Functor Controller where - fmap f (AsInput i) = AsInput (fmap f i) - --- Deriving `Monoid` -instance Monoid (Controller a) where - mappend (AsInput i1) (AsInput i2) = AsInput (mappend i1 i2) - - mempty = AsInput mempty - --- | Create a `Controller` from an `Input` -asInput :: Input a -> Controller a -asInput = AsInput -{-# INLINABLE asInput #-} - -{-| Think of the type as one of the following types: - -> keeps :: Prism' a b -> Controller a -> Controller b -> keeps :: Traversal' a b -> Controller a -> Controller b - - @(keeps prism controller)@ only emits values if the @prism@ matches the - @controller@'s output. - -> keeps (p1 . p2) = keeps p2 . keeps p1 -> -> keeps id = id - -> keeps p (c1 <> c2) = keeps p c1 <> keeps p c2 -> -> keeps p mempty = mempty --} -keeps - :: ((b -> Constant (First b) b) -> (a -> Constant (First b) a)) - -- ^ - -> Controller a - -- ^ - -> Controller b -keeps k (AsInput (Input recv_)) = AsInput (Input recv_') - where - recv_' = do - ma <- recv_ - case ma of - Nothing -> return Nothing - Just a -> case match a of - Nothing -> recv_' - Just b -> return (Just b) - match = M.getFirst . getConstant . k (Constant . M.First . Just) -{-# INLINABLE keeps #-} - -{- $view - `View`s represent outputs of your system. Use `handles` and the `Monoid` - instance of `View` to unify multiple `View`s together into a single `View`: - -> viewD :: Managed (View D) -> viewE :: Managed (View E) -> viewF :: Managed (View F) -> -> data TotalOutput = OutD D | OutE E | OutF F -> -> makePrisms ''TotalOutput -- Generates _OutD, _OutE, and _OutF prisms -> -> viewTotal :: Managed (View TotalOutput) -> viewTotal = -> fmap (handles _OutD) viewD -> <> fmap (handles _OutE) viewE -> <> fmap (handles _OutF) viewF - - Combining `View`s sequences their outputs. - - If a @lens@ dependency is too heavy-weight, then you can manually generate - `Traversal`s, which `handles` will also accept. Here is an example of how - you can generate `Traversal`s by hand with no dependencies: - -> -- _OutD :: Traversal' TotalOutput D -> _OutD :: Applicative f => (D -> f D) -> (TotalOutput -> f TotalOutput) -> _OutD k (OutD d) = fmap OutD (k d) -> _OutD k t = pure t -> -> -- _OutE :: Traversal' TotalOutput E -> _OutE :: Applicative f => (E -> f E) -> (TotalOutput -> f TotalOutput) -> _OutE k (OutE d) = fmap OutE (k d) -> _OutE k t = pure t -> -> -- _OutF :: Traversal' TotalOutput F -> _OutF :: Applicative f => (F -> f F) -> (TotalOutput -> f TotalOutput) -> _OutF k (OutF d) = fmap OutF (k d) -> _OutF k t = pure t --} - -{-| An effectful sink - -> contramap f (v1 <> v2) = contramap f v1 <> contramap f v2 -> -> contramap f mempty = mempty --} -newtype View a = AsFold (FoldM IO a ()) - -instance Monoid (View a) where - mempty = AsFold mempty - mappend (AsFold fold1) (AsFold fold2) = AsFold (mappend fold1 fold2) - -instance Contravariant View where - contramap f (AsFold fold) = AsFold (premapM f fold) - --- | Create a `View` from a sink -asSink :: (a -> IO ()) -> View a -asSink sink = AsFold (FoldM step begin done) - where - step x a = do - sink a - return x - begin = return () - done = return -{-# INLINABLE asSink #-} - --- | Create a `View` from a `FoldM` -asFold :: FoldM IO a () -> View a -asFold = AsFold -{-# INLINABLE asFold #-} - -{-| Think of the type as one of the following types: - -> handles :: Prism' a b -> View b -> View a -> handles :: Traversal' a b -> View b -> View a - - @(handles prism view)@ only runs the @view@ if the @prism@ matches the - input. - -> handles (p1 . p2) = handles p1 . handles p2 -> -> handles id = id - -> handles p (v1 <> v2) = handles p v1 <> handles p v2 -> -> handles p mempty = mempty --} -handles - :: HandlerM IO a b - -- ^ - -> View b - -- ^ - -> View a -handles k (AsFold fold) = AsFold (Fold.handlesM k fold) -{-# INLINABLE handles #-} - -{- $model - `Model`s are stateful streams and they sit in between `Controller`s and - `View`s. - - Use `State` to internally communicate within the `Model`. - - Read the \"ListT\" section which describes why you should prefer `ListT` - over `Pipe` when possible. - - Also, try to defer converting your `Pipe` to a `Model` until you call - `runMVC`, because the conversion is not reversible and `Pipe` is strictly - more featureful than `Model`. --} - -{-| A @(Model s a b)@ converts a stream of @(a)@s into a stream of @(b)@s while - interacting with a state @(s)@ --} -newtype ModelM m s a b = AsPipe (Pipe a b (StateT s m) ()) -type Model = ModelM Identity - -instance Monad m => Category (ModelM m s) where - (AsPipe m1) . (AsPipe m2) = AsPipe (m1 <-< m2) - - id = AsPipe cat - -{-| Create a `Model` from a `Pipe` - -> asPipe (p1 <-< p2) = asPipe p1 . asPipe p2 -> -> asPipe cat = id --} -asPipe :: Pipe a b (StateT s m) () -> ModelM m s a b -asPipe = AsPipe -{-# INLINABLE asPipe #-} - -{- $mvc - Connect a `Model`, `View`, and `Controller` and an initial state - together using `runMVC` to complete your application. - - `runMVC` is the only way to consume `View`s and `Controller`s. The types - forbid you from mixing `View` and `Controller` logic with your `Model` - logic. - - Note that `runMVC` only accepts one `View` and one `Controller`. This - enforces a single entry point and exit point for your `Model` so that you - can cleanly separate your `Model` logic from your `View` logic and - `Controller` logic. The way you add more `View`s and `Controller`s to your - program is by unifying them into a single `View` or `Controller` by using - their `Monoid` instances. See the \"Controllers\" and \"Views\" sections - for more details on how to do this. --} - -{-| Connect a `Model`, `View`, and `Controller` and initial state into a - complete application. --} - -runMVC :: s - -- ^ Initial state - -> Model s a b - -- ^ Program logic - -> Managed (View b, Controller a) - -- ^ Effectful output and input - -> IO s - -- ^ Returns final state -runMVC = generalizeMVC generalize - -{-| Connect a `Model`, `View`, and `Controller` and initial state into a - complete application over arbitrary monad given a morphism to IO. --} -generalizeMVC - :: Monad m => (forall x . m x -> IO x) - -- ^ Monad morphism - -> s - -- ^ Initial state - -> ModelM m s a b - -- ^ Program logic - -> Managed (View b, Controller a) - -- ^ Effectful output and input - -> IO s - -- ^ Returns final state -generalizeMVC cb initialState (AsPipe pipe) viewController = - with viewController $ \(AsFold (FoldM step begin done), AsInput input) -> do - let step' x a = lift (step x a) - let begin' = lift begin - let done' x = lift (done x) - let fold' = FoldM step' begin' done' - flip execStateT initialState $ - impurely foldM fold' (fromInput input >-> hoist (hoist cb) pipe) -{-# INLINABLE runMVC #-} - -{- $managed - Use `managed` to create primitive `Managed` resources and use the `Functor`, - `Applicative`, `Monad`, and `Monoid` instances for `Managed` to bundle - multiple `Managed` resources into a single `Managed` resource. - - See the source code for the \"Utilities\" section below for several examples - of how to create `Managed` resources. --} - -{- $listT - `ListT` computations can be combined in more ways than `Pipe`s, so try to - program in `ListT` as much as possible and defer converting it to a `Pipe` - as late as possible using `loop`. - - You can combine `ListT` computations even if their inputs and outputs are - completely different: - -> -- Independent computations -> -> modelAToD :: A -> ListT (State S) D -> modelBToE :: B -> ListT (State S) E -> modelCToF :: C -> ListT (State s) F -> -> modelInToOut :: TotalInput -> ListT (State S) TotalOutput -> modelInToOut totalInput = case totalInput of -> InA a -> fmap OutD (modelAToD a) -> InB b -> fmap OutE (modelBToE b) -> InC c -> fmap OutF (modelCToF c) - - Sometimes you have multiple computations that handle different inputs but - the same output, in which case you don't need to unify their outputs: - -> -- Overlapping outputs -> -> modelAToOut :: A -> ListT (State S) Out -> modelBToOut :: B -> ListT (State S) Out -> modelCToOut :: C -> ListT (State S) Out -> -> modelInToOut :: TotalInput -> ListT (State S) TotalOutput -> modelInToOut totalInput = case totalInput of -> InA a -> modelAToOut a -> InB b -> modelBToOut b -> InC c -> modelCToOut c - - Other times you have multiple computations that handle the same input but - produce different outputs. You can unify their outputs using the `Monoid` - and `Functor` instances for `ListT`: - -> -- Overlapping inputs -> -> modelInToA :: TotalInput -> ListT (State S) A -> modelInToB :: TotalInput -> ListT (State S) B -> modelInToC :: TotalInput -> ListT (State S) C -> -> modelInToOut :: TotalInput -> ListT (State S) TotalOutput -> modelInToOut totalInput = -> fmap OutA (modelInToA totalInput) -> <> fmap OutB (modelInToB totalInput) -> <> fmap OutC (modelInToC totalInput) - - You can also chain `ListT` computations, feeding the output of the first - computation as the input to the next computation: - -> -- End-to-end -> -> modelInToMiddle :: TotalInput -> ListT (State S) MiddleStep -> modelMiddleToOut :: MiddleStep -> ListT (State S) TotalOutput -> -> modelInToOut :: TotalInput -> ListT (State S) TotalOutput -> modelInToOut = modelInToMiddle >=> modelMiddleToOut - - ... or you can just use @do@ notation if you prefer. - - However, the `Pipe` type is more general than `ListT` and can represent - things like termination. Therefore you should consider mixing `Pipe`s with - `ListT` when you need to take advantage of these extra features: - -> -- Mix ListT with Pipes -> -> pipe :: Pipe TotalInput TotalOutput (State S) () -> pipe = Pipes.takeWhile (not . isC)) >-> loop modelInToOut -> where -> isC (InC _) = True -> isC _ = False - - So promote your `ListT` logic to a `Pipe` when you need to take advantage of - these `Pipe`-specific features. --} - -{- $reexports - "Data.Functor.Constant" re-exports `Constant` - - "Data.Functor.Contravariant" re-exports `Contravariant` - - "Data.Monoid" re-exports `Monoid`, (`<>`), `mconcat`, and `First` (the type - only) - - "Pipes" re-exports everything - - "Pipes.Concurrent" re-exports everything --} +{-| Use the `Model` - `View` - `Controller` pattern to separate impure inputs+ and outputs from pure application logic so that you can:++ * Equationally reason about your model++ * Exercise your model with property-based testing (like @QuickCheck@)++ * Reproducibly replay your model++ The @mvc@ library uses the type system to statically enforce the separation+ of impure `View`s and `Controller`s from the pure `Model`.++ Here's a small example program written using the @mvc@ library to illustrate+ the core types and concepts:++> import MVC+> import qualified MVC.Prelude as MVC+> import qualified Pipes.Prelude as Pipes+>+> external :: Managed (View String, Controller String)+> external = do+> c1 <- MVC.stdinLines+> c2 <- MVC.tick 1+> return (MVC.stdoutLines, c1 <> fmap show c2)+>+> model :: Model () String String+> model = asPipe (Pipes.takeWhile (/= "quit"))+> +> main :: IO ()+> main = runMVC () model external++ This program has three components:++ * A `Controller` that interleaves lines from standard input with periodic+ ticks++ * A `View` that writes lines to standard output++ * A pure `Model`, which forwards lines until the user inputs \"quit\"++ 'runMVC' connects them into a complete program, which outputs a @()@ every+ second and also echoes standard input to standard output until the user+ enters \"quit\":++>>> main+()+Test<Enter>+Test+()+()+42<Enter>+42+()+quit<enter>+>>>++ The following sections give extended guidance for how to structure @mvc@+ programs. Additionally, there is an "MVC.Prelude" module, which provides+ several utilities and provides a more elaborate code example using the+ @sdl@ library.+-}++{-# LANGUAGE RankNTypes #-}++module MVC (+ -- * Controllers+ -- $controller+ Controller+ , asInput+ , keeps++ -- * Views+ -- $view+ , View+ , asSink+ , asFold+ , handles++ -- * Models+ -- $model+ , Model+ , ModelM+ , asPipe++ -- * MVC+ -- $mvc+ , runMVC+ , generalizeMVC++ -- * Managed resources+ -- $managed+ , Managed+ , managed++ -- *ListT+ , loop+ -- $listT++ -- * Re-exports+ -- $reexports+ , module Data.Functor.Constant+ , module Data.Functor.Contravariant+ , module Data.Monoid+ , module Pipes+ , module Pipes.Concurrent+ ) where++import Control.Category (Category(..))+import Control.Foldl (FoldM(..), HandlerM, impurely, premapM)+import qualified Control.Foldl as Fold+import Control.Monad.Managed (Managed, managed, with)+import Control.Monad.Morph (generalize)+import Control.Monad.Trans.State.Strict (execStateT, StateT)+import Data.Functor.Constant (Constant(Constant, getConstant))+import Data.Functor.Contravariant (Contravariant(contramap))+import Data.Monoid (Monoid(mempty, mappend, mconcat), (<>), First)+import qualified Data.Monoid as M+import Pipes+import Pipes.Concurrent+import Pipes.Prelude (foldM, loop)+import Data.Functor.Identity (Identity)++import Prelude hiding ((.), id)++{- $controller+ `Controller`s represent concurrent inputs to your system. Use the `Functor`+ and `Monoid` instances for `Controller` and `Managed` to unify multiple+ `Managed` `Controller`s together into a single `Managed` `Controller`:++> controllerA :: Managed (Controller A)+> controllerB :: Managed (Controller B)+> controllerC :: Managed (Controller C)+>+> data TotalInput = InA A | InB B | InC C+>+> controllerTotal :: Managed (Controller TotalInput)+> controllerTotal =+> fmap (fmap InA) controllerA+> <> fmap (fmap InB) controllerB+> <> fmap (fmap InC) controllerC++ Combining `Controller`s interleaves their values.+-}++{-| A concurrent source++> fmap f (c1 <> c2) = fmap f c1 <> fmap f c2+>+> fmap f mempty = mempty+-}+newtype Controller a = AsInput (Input a)+-- This is just a newtype wrapper around `Input` because:+--+-- * I want the `Controller` name to "stick" in inferred types+--+-- * I want to restrict the API to ensure that `runMVC` is the only way to+-- consume `Controller`s. This enforces strict separation of `Controller`+-- logic from `Model` or `View` logic++-- Deriving `Functor`+instance Functor Controller where+ fmap f (AsInput i) = AsInput (fmap f i)++-- Deriving `Monoid`+instance Monoid (Controller a) where+ mappend (AsInput i1) (AsInput i2) = AsInput (mappend i1 i2)++ mempty = AsInput mempty++-- | Create a `Controller` from an `Input`+asInput :: Input a -> Controller a+asInput = AsInput+{-# INLINABLE asInput #-}++{-| Think of the type as one of the following types:++> keeps :: Prism' a b -> Controller a -> Controller b+> keeps :: Traversal' a b -> Controller a -> Controller b++ @(keeps prism controller)@ only emits values if the @prism@ matches the+ @controller@'s output.++> keeps (p1 . p2) = keeps p2 . keeps p1+>+> keeps id = id++> keeps p (c1 <> c2) = keeps p c1 <> keeps p c2+>+> keeps p mempty = mempty+-}+keeps+ :: ((b -> Constant (First b) b) -> (a -> Constant (First b) a))+ -- ^+ -> Controller a+ -- ^+ -> Controller b+keeps k (AsInput (Input recv_)) = AsInput (Input recv_')+ where+ recv_' = do+ ma <- recv_+ case ma of+ Nothing -> return Nothing+ Just a -> case match a of+ Nothing -> recv_'+ Just b -> return (Just b)+ match = M.getFirst . getConstant . k (Constant . M.First . Just)+{-# INLINABLE keeps #-}++{- $view+ `View`s represent outputs of your system. Use `handles` and the `Monoid`+ instance of `View` to unify multiple `View`s together into a single `View`:++> viewD :: Managed (View D)+> viewE :: Managed (View E)+> viewF :: Managed (View F)+>+> data TotalOutput = OutD D | OutE E | OutF F+>+> makePrisms ''TotalOutput -- Generates _OutD, _OutE, and _OutF prisms+>+> viewTotal :: Managed (View TotalOutput)+> viewTotal =+> fmap (handles _OutD) viewD+> <> fmap (handles _OutE) viewE+> <> fmap (handles _OutF) viewF++ Combining `View`s sequences their outputs.++ If a @lens@ dependency is too heavy-weight, then you can manually generate+ `Traversal`s, which `handles` will also accept. Here is an example of how+ you can generate `Traversal`s by hand with no dependencies:++> -- _OutD :: Traversal' TotalOutput D+> _OutD :: Applicative f => (D -> f D) -> (TotalOutput -> f TotalOutput)+> _OutD k (OutD d) = fmap OutD (k d)+> _OutD k t = pure t+>+> -- _OutE :: Traversal' TotalOutput E+> _OutE :: Applicative f => (E -> f E) -> (TotalOutput -> f TotalOutput)+> _OutE k (OutE d) = fmap OutE (k d)+> _OutE k t = pure t+>+> -- _OutF :: Traversal' TotalOutput F+> _OutF :: Applicative f => (F -> f F) -> (TotalOutput -> f TotalOutput)+> _OutF k (OutF d) = fmap OutF (k d)+> _OutF k t = pure t+-}++{-| An effectful sink++> contramap f (v1 <> v2) = contramap f v1 <> contramap f v2+>+> contramap f mempty = mempty+-}+newtype View a = AsFold (FoldM IO a ())++instance Monoid (View a) where+ mempty = AsFold mempty+ mappend (AsFold fold1) (AsFold fold2) = AsFold (mappend fold1 fold2)++instance Contravariant View where+ contramap f (AsFold fold) = AsFold (premapM f fold)++-- | Create a `View` from a sink+asSink :: (a -> IO ()) -> View a+asSink sink = AsFold (FoldM step begin done)+ where+ step x a = do+ sink a+ return x+ begin = return ()+ done = return+{-# INLINABLE asSink #-}++-- | Create a `View` from a `FoldM`+asFold :: FoldM IO a () -> View a+asFold = AsFold+{-# INLINABLE asFold #-}++{-| Think of the type as one of the following types:++> handles :: Prism' a b -> View b -> View a+> handles :: Traversal' a b -> View b -> View a++ @(handles prism view)@ only runs the @view@ if the @prism@ matches the+ input.++> handles (p1 . p2) = handles p1 . handles p2+>+> handles id = id++> handles p (v1 <> v2) = handles p v1 <> handles p v2+>+> handles p mempty = mempty+-}+handles+ :: HandlerM IO a b+ -- ^+ -> View b+ -- ^+ -> View a+handles k (AsFold fold) = AsFold (Fold.handlesM k fold)+{-# INLINABLE handles #-}++{- $model+ `Model`s are stateful streams and they sit in between `Controller`s and+ `View`s.++ Use `State` to internally communicate within the `Model`.++ Read the \"ListT\" section which describes why you should prefer `ListT`+ over `Pipe` when possible.++ Also, try to defer converting your `Pipe` to a `Model` until you call+ `runMVC`, because the conversion is not reversible and `Pipe` is strictly+ more featureful than `Model`.+-}++{-| A @(Model s a b)@ converts a stream of @(a)@s into a stream of @(b)@s while+ interacting with a state @(s)@+-}+newtype ModelM m s a b = AsPipe (Pipe a b (StateT s m) ())+type Model = ModelM Identity++instance Monad m => Category (ModelM m s) where+ (AsPipe m1) . (AsPipe m2) = AsPipe (m1 <-< m2)++ id = AsPipe cat++{-| Create a `Model` from a `Pipe`++> asPipe (p1 <-< p2) = asPipe p1 . asPipe p2+>+> asPipe cat = id+-}+asPipe :: Pipe a b (StateT s m) () -> ModelM m s a b+asPipe = AsPipe+{-# INLINABLE asPipe #-}++{- $mvc+ Connect a `Model`, `View`, and `Controller` and an initial state+ together using `runMVC` to complete your application.++ `runMVC` is the only way to consume `View`s and `Controller`s. The types+ forbid you from mixing `View` and `Controller` logic with your `Model`+ logic.++ Note that `runMVC` only accepts one `View` and one `Controller`. This+ enforces a single entry point and exit point for your `Model` so that you+ can cleanly separate your `Model` logic from your `View` logic and+ `Controller` logic. The way you add more `View`s and `Controller`s to your+ program is by unifying them into a single `View` or `Controller` by using+ their `Monoid` instances. See the \"Controllers\" and \"Views\" sections+ for more details on how to do this.+-}++{-| Connect a `Model`, `View`, and `Controller` and initial state into a+ complete application.+-}++runMVC :: s+ -- ^ Initial state+ -> Model s a b+ -- ^ Program logic+ -> Managed (View b, Controller a)+ -- ^ Effectful output and input+ -> IO s+ -- ^ Returns final state+runMVC = generalizeMVC generalize++{-| Connect a `Model`, `View`, and `Controller` and initial state into a+ complete application over arbitrary monad given a morphism to IO.+-}+generalizeMVC+ :: Monad m => (forall x . m x -> IO x)+ -- ^ Monad morphism+ -> s+ -- ^ Initial state+ -> ModelM m s a b+ -- ^ Program logic+ -> Managed (View b, Controller a)+ -- ^ Effectful output and input+ -> IO s+ -- ^ Returns final state+generalizeMVC cb initialState (AsPipe pipe) viewController =+ with viewController $ \(AsFold (FoldM step begin done), AsInput input) -> do+ let step' x a = lift (step x a)+ let begin' = lift begin+ let done' x = lift (done x)+ let fold' = FoldM step' begin' done'+ flip execStateT initialState $+ impurely foldM fold' (fromInput input >-> hoist (hoist cb) pipe)+{-# INLINABLE runMVC #-}++{- $managed+ Use `managed` to create primitive `Managed` resources and use the `Functor`,+ `Applicative`, `Monad`, and `Monoid` instances for `Managed` to bundle+ multiple `Managed` resources into a single `Managed` resource.++ See the source code for the \"Utilities\" section below for several examples+ of how to create `Managed` resources.+-}++{- $listT+ `ListT` computations can be combined in more ways than `Pipe`s, so try to+ program in `ListT` as much as possible and defer converting it to a `Pipe`+ as late as possible using `loop`.++ You can combine `ListT` computations even if their inputs and outputs are+ completely different:++> -- Independent computations+>+> modelAToD :: A -> ListT (State S) D+> modelBToE :: B -> ListT (State S) E+> modelCToF :: C -> ListT (State s) F+>+> modelInToOut :: TotalInput -> ListT (State S) TotalOutput+> modelInToOut totalInput = case totalInput of+> InA a -> fmap OutD (modelAToD a)+> InB b -> fmap OutE (modelBToE b)+> InC c -> fmap OutF (modelCToF c)++ Sometimes you have multiple computations that handle different inputs but+ the same output, in which case you don't need to unify their outputs:++> -- Overlapping outputs+>+> modelAToOut :: A -> ListT (State S) Out+> modelBToOut :: B -> ListT (State S) Out+> modelCToOut :: C -> ListT (State S) Out+>+> modelInToOut :: TotalInput -> ListT (State S) TotalOutput+> modelInToOut totalInput = case totalInput of+> InA a -> modelAToOut a+> InB b -> modelBToOut b+> InC c -> modelCToOut c++ Other times you have multiple computations that handle the same input but+ produce different outputs. You can unify their outputs using the `Monoid`+ and `Functor` instances for `ListT`:++> -- Overlapping inputs+>+> modelInToA :: TotalInput -> ListT (State S) A+> modelInToB :: TotalInput -> ListT (State S) B+> modelInToC :: TotalInput -> ListT (State S) C+>+> modelInToOut :: TotalInput -> ListT (State S) TotalOutput+> modelInToOut totalInput =+> fmap OutA (modelInToA totalInput)+> <> fmap OutB (modelInToB totalInput)+> <> fmap OutC (modelInToC totalInput)++ You can also chain `ListT` computations, feeding the output of the first+ computation as the input to the next computation:++> -- End-to-end+>+> modelInToMiddle :: TotalInput -> ListT (State S) MiddleStep+> modelMiddleToOut :: MiddleStep -> ListT (State S) TotalOutput+>+> modelInToOut :: TotalInput -> ListT (State S) TotalOutput+> modelInToOut = modelInToMiddle >=> modelMiddleToOut++ ... or you can just use @do@ notation if you prefer.++ However, the `Pipe` type is more general than `ListT` and can represent+ things like termination. Therefore you should consider mixing `Pipe`s with+ `ListT` when you need to take advantage of these extra features:++> -- Mix ListT with Pipes+>+> pipe :: Pipe TotalInput TotalOutput (State S) ()+> pipe = Pipes.takeWhile (not . isC)) >-> loop modelInToOut+> where+> isC (InC _) = True+> isC _ = False++ So promote your `ListT` logic to a `Pipe` when you need to take advantage of+ these `Pipe`-specific features.+-}++{- $reexports+ "Data.Functor.Constant" re-exports `Constant`++ "Data.Functor.Contravariant" re-exports `Contravariant`++ "Data.Monoid" re-exports `Monoid`, (`<>`), `mconcat`, and `First` (the type+ only)++ "Pipes" re-exports everything++ "Pipes.Concurrent" re-exports everything+-}
src/MVC/Prelude.hs view
@@ -1,232 +1,232 @@-{-| Simple utilities - - The \"Example\" section at the bottom of this module contains an extended - example of how to interact with the @sdl@ library using the @mvc@ library --} - -module MVC.Prelude ( - -- * Controllers - producer - , stdinLines - , inLines - , inRead - , tick - - -- * Views - , consumer - , stdoutLines - , outLines - , outShow - - -- * Handles - , inHandle - , outHandle - - -- * Threads - , forkManaged - - -- * Example - -- $example - ) where - -import Control.Applicative (pure, (<*)) -import Control.Concurrent.Async (withAsync) -import Control.Concurrent (threadDelay) -import Data.IORef (newIORef, readIORef, writeIORef) -import MVC -import Pipes.Internal (Proxy(..), closed) -import qualified Pipes.Prelude as Pipes -import qualified System.IO as IO - --- | Fork managed computation in a new thread. See `producer` source for usage example. -forkManaged :: IO (IO (), a, IO ()) -- ^ Setup action returning thread's main, - -- managed value, finalizer. - -> Managed a -forkManaged cb = managed $ \k -> do - (io, ret, fin) <- cb - withAsync (io >> fin) $ \_ -> k ret <* fin -{-# INLINABLE forkManaged #-} - -{-| Create a `Controller` from a `Producer`, using the given `Buffer` - - If you're not sure what `Buffer` to use, try `Single` --} -producer :: Buffer a -> Producer a IO () -> Managed (Controller a) -producer buffer prod = forkManaged $ do - (o, i, seal) <- spawn' buffer - return (runEffect $ prod >-> toOutput o, asInput i, atomically seal) -{-# INLINABLE producer #-} - --- | Read lines from standard input -stdinLines :: Managed (Controller String) -stdinLines = producer (bounded 1) Pipes.stdinLn -{-# INLINABLE stdinLines #-} - --- | Read lines from a file -inLines :: FilePath -> Managed (Controller String) -inLines filePath = do - handle <- inHandle filePath - producer (bounded 1) (Pipes.fromHandle handle) -{-# INLINABLE inLines #-} - --- | 'read' values from a file, one value per line, skipping failed parses -inRead :: Read a => FilePath -> Managed (Controller a) -inRead filePath = fmap (keeps parsed) (inLines filePath) - where - parsed k str = case reads str of - [(a, "")] -> Constant (getConstant (k a)) - _ -> pure str -{-# INLINABLE inRead #-} - --- | Emit empty values spaced by a delay in seconds -tick :: Double -> Managed (Controller ()) -tick n = producer (bounded 1) $ - lift (threadDelay (truncate (n * 1000000))) >~ cat -{-# INLINABLE tick #-} - --- | Create a `View` from a `Consumer` -consumer :: Consumer a IO () -> Managed (View a) -consumer cons0 = managed $ \k -> do - mf0 <- nextRequest cons0 - ref <- newIORef mf0 - k $ asSink $ \a -> do - mf <- readIORef ref - case mf of - Nothing -> return () - Just f -> do - mf' <- nextRequest (f a) - writeIORef ref mf' - where - nextRequest :: Consumer a IO () -> IO (Maybe (a -> Consumer a IO ())) - nextRequest cons = case cons of - Request () fa -> return (Just fa) - Respond v _ -> closed v - M m -> m >>= nextRequest - Pure () -> return Nothing -{-# INLINABLE consumer #-} - --- | Write lines to standard output -stdoutLines :: View String -stdoutLines = asSink putStrLn -{-# INLINABLE stdoutLines #-} - --- | Write lines to a file -outLines :: FilePath -> Managed (View String) -outLines filePath = do - handle <- outHandle filePath - return (asSink (IO.hPutStrLn handle)) -{-# INLINABLE outLines #-} - --- | 'show' values to a file, one value per line -outShow :: Show a => FilePath -> Managed (View a) -outShow filePath = fmap (contramap show) (outLines filePath) -{- -outShow filePath = do - handle <- outHandle filePath - return (asSink (IO.hPrint handle)) --} -{-# INLINABLE outShow #-} - --- | Read from a `FilePath` using a `Managed` `IO.Handle` -inHandle :: FilePath -> Managed IO.Handle -inHandle filePath = managed (IO.withFile filePath IO.ReadMode) -{-# INLINABLE inHandle #-} - --- | Write to a `FilePath` using a `Managed` `IO.Handle` -outHandle :: FilePath -> Managed IO.Handle -outHandle filePath = managed (IO.withFile filePath IO.WriteMode) -{-# INLINABLE outHandle #-} - -{- $example - The following example distils a @sdl@-based program into pure and impure - components. This program will draw a white rectangle between every two - mouse clicks. - - The first half of the program contains all the concurrent and impure logic. - The `View` and `Controller` must be `Managed` together since they both share - the same initialization logic: - -> import Control.Monad (join) -> import Graphics.UI.SDL as SDL -> import Lens.Family.Stock (_Left, _Right) -- from `lens-family-core` -> import MVC -> import MVC.Prelude -> import qualified Pipes.Prelude as Pipes -> -> data Done = Done deriving (Eq, Show) -> -> sdl :: Managed (View (Either Rect Done), Controller Event) -> sdl = join $ managed $ \k -> withInit [InitVideo, InitEventthread] $ do -> surface <- setVideoMode 640 480 32 [SWSurface] -> white <- mapRGB (surfaceGetPixelFormat surface) 255 255 255 -> -> let done :: View Done -> done = asSink (\Done -> SDL.quit) -> -> drawRect :: View Rect -> drawRect = asSink $ \rect -> do -> _ <- fillRect surface (Just rect) white -> SDL.flip surface -> -> totalOut :: View (Either Rect Done) -> totalOut = handles _Left drawRect <> handles _Right done -> -> k $ do -> totalIn <- producer Single (lift waitEvent >~ cat) -> return (totalOut, totalIn) - - Note the `Control.Monad.join` surrounding the `managed` block. This is - because the type before `Control.Monad.join` is: - -> Managed (Managed (View (Either Rect Done), Controller Event)) - - More generally, note that `Managed` is a `Monad`, so you can use @do@ - notation to combine multiple `Managed` resources into a single `Managed` - resource. - - The second half of the program contains the pure logic. - -> pipe :: Monad m => Pipe Event (Either Rect Done) m () -> pipe = do -> Pipes.takeWhile (/= Quit) >-> (click >~ rectangle >~ Pipes.map Left) -> yield (Right Done) -> -> rectangle :: Monad m => Consumer' (Int, Int) m Rect -> rectangle = do -> (x1, y1) <- await -> (x2, y2) <- await -> let x = min x1 x2 -> y = min y1 y2 -> w = abs (x1 - x2) -> h = abs (y1 - y2) -> return (Rect x y w h) -> -> click :: Monad m => Consumer' Event m (Int, Int) -> click = do -> e <- await -> case e of -> MouseButtonDown x y ButtonLeft -> -> return (fromIntegral x, fromIntegral y) -> _ -> click -> -> main :: IO () -> main = runMVC () (asPipe pipe) sdl - - Run the program to verify that clicks create rectangles. - - The more logic you move into the pure core the more you can exercise your - program purely, either manually: - ->>> let leftClick (x, y) = MouseButtonDown x y ButtonLeft ->>> Pipes.toList (each [leftClick (10, 10), leftClick (15, 16), Quit] >-> pipe) -[Left (Rect {rectX = 10, rectY = 10, rectW = 5, rectH = 6}),Right Done] - - ... or automatically using property-based testing (such as @QuickCheck@): - ->>> import Test.QuickCheck ->>> quickCheck $ \xs -> length (Pipes.toList (each (map leftClick xs) >-> pipe)) == length xs `div` 2 -+++ OK, passed 100 tests. - - Equally important, you can formally prove properties about your model using - equational reasoning because the model is `IO`-free and concurrency-free. --} +{-| Simple utilities++ The \"Example\" section at the bottom of this module contains an extended+ example of how to interact with the @sdl@ library using the @mvc@ library+-}++module MVC.Prelude (+ -- * Controllers+ producer+ , stdinLines+ , inLines+ , inRead+ , tick++ -- * Views+ , consumer+ , stdoutLines+ , outLines+ , outShow++ -- * Handles+ , inHandle+ , outHandle++ -- * Threads+ , forkManaged++ -- * Example+ -- $example+ ) where++import Control.Applicative (pure, (<*))+import Control.Concurrent.Async (withAsync)+import Control.Concurrent (threadDelay)+import Data.IORef (newIORef, readIORef, writeIORef)+import MVC+import Pipes.Internal (Proxy(..), closed)+import qualified Pipes.Prelude as Pipes+import qualified System.IO as IO++-- | Fork managed computation in a new thread. See `producer` source for usage example.+forkManaged :: IO (IO (), a, IO ()) -- ^ Setup action returning thread's main,+ -- managed value, finalizer.+ -> Managed a+forkManaged cb = managed $ \k -> do+ (io, ret, fin) <- cb+ withAsync (io >> fin) $ \_ -> k ret <* fin+{-# INLINABLE forkManaged #-}++{-| Create a `Controller` from a `Producer`, using the given `Buffer`++ If you're not sure what `Buffer` to use, try `Single`+-}+producer :: Buffer a -> Producer a IO () -> Managed (Controller a)+producer buffer prod = forkManaged $ do+ (o, i, seal) <- spawn' buffer+ return (runEffect $ prod >-> toOutput o, asInput i, atomically seal)+{-# INLINABLE producer #-}++-- | Read lines from standard input+stdinLines :: Managed (Controller String)+stdinLines = producer (bounded 1) Pipes.stdinLn+{-# INLINABLE stdinLines #-}++-- | Read lines from a file+inLines :: FilePath -> Managed (Controller String)+inLines filePath = do+ handle <- inHandle filePath+ producer (bounded 1) (Pipes.fromHandle handle)+{-# INLINABLE inLines #-}++-- | 'read' values from a file, one value per line, skipping failed parses+inRead :: Read a => FilePath -> Managed (Controller a)+inRead filePath = fmap (keeps parsed) (inLines filePath)+ where+ parsed k str = case reads str of+ [(a, "")] -> Constant (getConstant (k a))+ _ -> pure str+{-# INLINABLE inRead #-}++-- | Emit empty values spaced by a delay in seconds+tick :: Double -> Managed (Controller ())+tick n = producer (bounded 1) $+ lift (threadDelay (truncate (n * 1000000))) >~ cat+{-# INLINABLE tick #-}++-- | Create a `View` from a `Consumer`+consumer :: Consumer a IO () -> Managed (View a)+consumer cons0 = managed $ \k -> do+ mf0 <- nextRequest cons0+ ref <- newIORef mf0+ k $ asSink $ \a -> do+ mf <- readIORef ref+ case mf of+ Nothing -> return ()+ Just f -> do+ mf' <- nextRequest (f a)+ writeIORef ref mf'+ where+ nextRequest :: Consumer a IO () -> IO (Maybe (a -> Consumer a IO ()))+ nextRequest cons = case cons of+ Request () fa -> return (Just fa)+ Respond v _ -> closed v+ M m -> m >>= nextRequest+ Pure () -> return Nothing+{-# INLINABLE consumer #-}+ +-- | Write lines to standard output+stdoutLines :: View String+stdoutLines = asSink putStrLn+{-# INLINABLE stdoutLines #-}++-- | Write lines to a file+outLines :: FilePath -> Managed (View String)+outLines filePath = do+ handle <- outHandle filePath+ return (asSink (IO.hPutStrLn handle))+{-# INLINABLE outLines #-}++-- | 'show' values to a file, one value per line+outShow :: Show a => FilePath -> Managed (View a)+outShow filePath = fmap (contramap show) (outLines filePath)+{-+outShow filePath = do+ handle <- outHandle filePath+ return (asSink (IO.hPrint handle))+-}+{-# INLINABLE outShow #-}++-- | Read from a `FilePath` using a `Managed` `IO.Handle`+inHandle :: FilePath -> Managed IO.Handle+inHandle filePath = managed (IO.withFile filePath IO.ReadMode)+{-# INLINABLE inHandle #-}++-- | Write to a `FilePath` using a `Managed` `IO.Handle`+outHandle :: FilePath -> Managed IO.Handle+outHandle filePath = managed (IO.withFile filePath IO.WriteMode)+{-# INLINABLE outHandle #-}++{- $example+ The following example distils a @sdl@-based program into pure and impure+ components. This program will draw a white rectangle between every two+ mouse clicks.++ The first half of the program contains all the concurrent and impure logic.+ The `View` and `Controller` must be `Managed` together since they both share+ the same initialization logic:++> import Control.Monad (join)+> import Graphics.UI.SDL as SDL+> import Lens.Family.Stock (_Left, _Right) -- from `lens-family-core`+> import MVC+> import MVC.Prelude+> import qualified Pipes.Prelude as Pipes+> +> data Done = Done deriving (Eq, Show)+> +> sdl :: Managed (View (Either Rect Done), Controller Event)+> sdl = join $ managed $ \k -> withInit [InitVideo, InitEventthread] $ do+> surface <- setVideoMode 640 480 32 [SWSurface]+> white <- mapRGB (surfaceGetPixelFormat surface) 255 255 255+> +> let done :: View Done+> done = asSink (\Done -> SDL.quit)+> +> drawRect :: View Rect+> drawRect = asSink $ \rect -> do+> _ <- fillRect surface (Just rect) white+> SDL.flip surface+> +> totalOut :: View (Either Rect Done)+> totalOut = handles _Left drawRect <> handles _Right done+> +> k $ do+> totalIn <- producer Single (lift waitEvent >~ cat)+> return (totalOut, totalIn)++ Note the `Control.Monad.join` surrounding the `managed` block. This is+ because the type before `Control.Monad.join` is:++> Managed (Managed (View (Either Rect Done), Controller Event))++ More generally, note that `Managed` is a `Monad`, so you can use @do@+ notation to combine multiple `Managed` resources into a single `Managed`+ resource.++ The second half of the program contains the pure logic.++> pipe :: Monad m => Pipe Event (Either Rect Done) m ()+> pipe = do+> Pipes.takeWhile (/= Quit) >-> (click >~ rectangle >~ Pipes.map Left)+> yield (Right Done)+> +> rectangle :: Monad m => Consumer' (Int, Int) m Rect+> rectangle = do+> (x1, y1) <- await+> (x2, y2) <- await+> let x = min x1 x2+> y = min y1 y2+> w = abs (x1 - x2)+> h = abs (y1 - y2)+> return (Rect x y w h)+> +> click :: Monad m => Consumer' Event m (Int, Int)+> click = do+> e <- await+> case e of+> MouseButtonDown x y ButtonLeft ->+> return (fromIntegral x, fromIntegral y)+> _ -> click+> +> main :: IO ()+> main = runMVC () (asPipe pipe) sdl++ Run the program to verify that clicks create rectangles.++ The more logic you move into the pure core the more you can exercise your+ program purely, either manually:++>>> let leftClick (x, y) = MouseButtonDown x y ButtonLeft+>>> Pipes.toList (each [leftClick (10, 10), leftClick (15, 16), Quit] >-> pipe)+[Left (Rect {rectX = 10, rectY = 10, rectW = 5, rectH = 6}),Right Done]++ ... or automatically using property-based testing (such as @QuickCheck@):++>>> import Test.QuickCheck+>>> quickCheck $ \xs -> length (Pipes.toList (each (map leftClick xs) >-> pipe)) == length xs `div` 2++++ OK, passed 100 tests.++ Equally important, you can formally prove properties about your model using+ equational reasoning because the model is `IO`-free and concurrency-free.+-}