diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,24 +1,24 @@ -Copyright (c) 2014 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. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/mvc.cabal b/mvc.cabal --- a/mvc.cabal +++ b/mvc.cabal @@ -1,41 +1,41 @@ -Name: mvc -Version: 1.0.5 -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, - managed < 1.1, - mmorph >= 1.0.2 && < 1.1, - pipes >= 4.1.0 && < 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.0 +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.0 && < 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 diff --git a/src/MVC.hs b/src/MVC.hs --- a/src/MVC.hs +++ b/src/MVC.hs @@ -1,487 +1,485 @@ -{-| 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 -Test -() -() -42 -42 -() -quit ->>> - - 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 - , asPipe - - -- * MVC - -- $mvc - , runMVC - - -- * 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.Applicative (Applicative) -import Control.Category (Category(..)) -import Control.Foldl (FoldM(..), impurely, premapM, pretraverseM) -import Control.Monad.Managed (Managed, managed, with) -import Control.Monad.Morph (generalize) -import Control.Monad.Trans.State.Strict (State, execStateT) -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) - -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 (mempty 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 #-} - -type Traversal' a b = forall f . Applicative f => (b -> f b) -> a -> f a - -{-| 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 - :: Traversal' a b - -- ^ - -> View b - -- ^ - -> View a -handles k (AsFold fold) = AsFold (pretraverseM 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 Model s a b = AsPipe (Pipe a b (State s) ()) - -instance Category (Model 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 (State s) () -> Model 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 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 generalize) 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. --} - -{-| Create a `Pipe` from a `ListT` transformation - -> loop (k1 >=> k2) = loop k1 >-> loop k2 -> -> loop return = cat --} -loop :: Monad m => (a -> ListT m b) -> Pipe a b m r -loop k = for cat (every . k) -{-# INLINABLE loop #-} - -{- $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 +Test +() +() +42 +42 +() +quit +>>> + + 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 + , asPipe + + -- * MVC + -- $mvc + , runMVC + + -- * 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 (State, execStateT) +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) + +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 Model s a b = AsPipe (Pipe a b (State s) ()) + +instance Category (Model 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 (State s) () -> Model 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 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 generalize) 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. +-} + +{-| Create a `Pipe` from a `ListT` transformation + +> loop (k1 >=> k2) = loop k1 >-> loop k2 +> +> loop return = cat +-} +loop :: Monad m => (a -> ListT m b) -> Pipe a b m r +loop k = for cat (every . k) +{-# INLINABLE loop #-} + +{- $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 +-} diff --git a/src/MVC/Prelude.hs b/src/MVC/Prelude.hs --- a/src/MVC/Prelude.hs +++ b/src/MVC/Prelude.hs @@ -1,223 +1,223 @@ -{-| 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 - - -- * 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 - -{-| 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 = managed $ \k -> do - (o, i, seal) <- spawn' buffer - let io = do - runEffect $ prod >-> toOutput o - atomically seal - withAsync io $ \_ -> k (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 + + -- * 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 + +{-| 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 = managed $ \k -> do + (o, i, seal) <- spawn' buffer + let io = do + runEffect $ prod >-> toOutput o + atomically seal + withAsync io $ \_ -> k (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. +-}