├── .travis.yml ├── LICENSE ├── README.md ├── Setup.hs ├── default.nix ├── mvc.cabal ├── release.nix ├── shell.nix ├── src ├── MVC.hs └── MVC │ └── Prelude.hs └── stack.yaml /.travis.yml: -------------------------------------------------------------------------------- 1 | # This file has been generated -- see https://github.com/hvr/multi-ghc-travis 2 | language: c 3 | sudo: false 4 | 5 | cache: 6 | directories: 7 | - $HOME/.cabsnap 8 | - $HOME/.cabal/packages 9 | 10 | before_cache: 11 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log 12 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar 13 | 14 | matrix: 15 | include: 16 | - env: CABALVER=1.24 GHCVER=8.0.2 17 | compiler: ": #GHC 8.0.2" 18 | addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2], sources: [hvr-ghc]}} 19 | 20 | before_install: 21 | - unset CC 22 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH 23 | 24 | install: 25 | - cabal --version 26 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 27 | - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ]; 28 | then 29 | zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz > 30 | $HOME/.cabal/packages/hackage.haskell.org/00-index.tar; 31 | fi 32 | - travis_retry cabal update -v 33 | - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config 34 | - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt 35 | - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt 36 | 37 | # check whether current requested install-plan matches cached package-db snapshot 38 | - if diff -u $HOME/.cabsnap/installplan.txt installplan.txt; 39 | then 40 | echo "cabal build-cache HIT"; 41 | rm -rfv .ghc; 42 | cp -a $HOME/.cabsnap/ghc $HOME/.ghc; 43 | cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/; 44 | else 45 | echo "cabal build-cache MISS"; 46 | rm -rf $HOME/.cabsnap; 47 | mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; 48 | cabal install --only-dependencies --enable-tests --enable-benchmarks; 49 | fi 50 | 51 | # snapshot package-db on cache miss 52 | - if [ ! -d $HOME/.cabsnap ]; 53 | then 54 | echo "snapshotting package-db to build-cache"; 55 | mkdir $HOME/.cabsnap; 56 | cp -a $HOME/.ghc $HOME/.cabsnap/ghc; 57 | cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/; 58 | fi 59 | 60 | # Here starts the actual work to be performed for the package under test; 61 | # any command which exits with a non-zero exit code causes the build to fail. 62 | script: 63 | - if [ -f configure.ac ]; then autoreconf -i; fi 64 | - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging 65 | - cabal build # this builds all libraries and executables (including tests/benchmarks) 66 | - cabal test 67 | - cabal check 68 | - cabal sdist # tests that a source-distribution can be generated 69 | 70 | # Check that the resulting source distribution can be built & installed. 71 | # If there are no other `.tar.gz` files in `dist`, this can be even simpler: 72 | # `cabal install --force-reinstalls dist/*-*.tar.gz` 73 | - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && 74 | (cd dist && cabal install --force-reinstalls "$SRC_TGZ") 75 | 76 | # EOF 77 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Gabriella Gonzalez 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, 5 | are permitted provided that the following conditions are met: 6 | * Redistributions of source code must retain the above copyright notice, 7 | this list of conditions and the following disclaimer. 8 | * Redistributions in binary form must reproduce the above copyright notice, 9 | this list of conditions and the following disclaimer in the documentation 10 | and/or other materials provided with the distribution. 11 | * Neither the name of Gabriella Gonzalez nor the names of other contributors 12 | may be used to endorse or promote products derived from this software 13 | without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 16 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR 19 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 22 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # MVC v1.1.7 2 | 3 | Use the `mvc` library to distill concurrent programs into pure and 4 | single-threaded programs using the `Model`-`View`-`Controller` pattern. The 5 | `mvc` library makes pervasive purity practical. 6 | 7 | `mvc` is guided by a single overarching design principle: application 8 | architectures inspired by category theory scale in the large because they 9 | reduce complexity and prevent proliferation of concepts. Use `mvc` if you wish 10 | to learn how to practically apply theory to tame large applications. 11 | 12 | ## Quick start 13 | 14 | * Install the [Haskell Platform](http://www.haskell.org/platform/) 15 | * `cabal install mvc` 16 | * Read the documentation in the `MVC` module and the `MVC.Prelude` module 17 | 18 | Optionally begin from this program skeleton: 19 | 20 | import MVC 21 | import qualified MVC.Prelude as MVC 22 | import qualified Pipes.Prelude as Pipes 23 | 24 | external :: Managed (View String, Controller String) 25 | external = do 26 | c1 <- MVC.stdinLines 27 | c2 <- MVC.tick 1 28 | return (MVC.stdoutLines, c1 <> fmap show c2) 29 | 30 | model :: Model () String String 31 | model = asPipe (Pipes.takeWhile (/= "quit")) 32 | 33 | main :: IO () 34 | main = runMVC () model external 35 | 36 | ## Features 37 | 38 | * *Determinism*: Perform property-based testing on your model (like 39 | `QuickCheck`) 40 | 41 | * *Purity*: Move a substantial amount of your application logic into pure code 42 | 43 | * *Semantics*: Equationally reason about your concurrency-free and pure core 44 | 45 | * *Best practices*: Statically enforce decoupling 46 | 47 | * *Concise API*: Only four types, and 8 primitive functions 48 | 49 | * *Elegant semantics*: Use practical category theory 50 | 51 | * *Extensive Documentation*: The haddocks contain extensive tips and idioms 52 | 53 | ## Development Status 54 | 55 | The API is stable because I do not plan to generalize the API further. Any 56 | future generalizations will be released as separate libraries. The goal of this 57 | library is to serve as a stepping stone towards understanding more sophisticated 58 | and general application architectures, so I wish to preserve its simplicity for 59 | pedagogical reasons. 60 | 61 | Future development will focus on building an ecosystem of pre-built `View`s and 62 | `Controller`s that applications can use, with a focus on tools useful for 63 | user interfaces and games. 64 | 65 | ## How to contribute 66 | 67 | * Build derived libraries 68 | 69 | * Write `mvc` tutorials 70 | 71 | ## License (BSD 3-clause) 72 | 73 | Copyright (c) 2014 Gabriella Gonzalez 74 | All rights reserved. 75 | 76 | Redistribution and use in source and binary forms, with or without modification, 77 | are permitted provided that the following conditions are met: 78 | 79 | * Redistributions of source code must retain the above copyright notice, this 80 | list of conditions and the following disclaimer. 81 | 82 | * Redistributions in binary form must reproduce the above copyright notice, this 83 | list of conditions and the following disclaimer in the documentation and/or 84 | other materials provided with the distribution. 85 | 86 | * Neither the name of Gabriella Gonzalez nor the names of other contributors may 87 | be used to endorse or promote products derived from this software without 88 | specific prior written permission. 89 | 90 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 91 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 92 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 93 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR 94 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 95 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 96 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 97 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 98 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 99 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 100 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, async, base, contravariant, foldl, managed, mmorph 2 | , pipes, pipes-concurrency, stdenv, transformers 3 | }: 4 | mkDerivation { 5 | pname = "mvc"; 6 | version = "1.1.7"; 7 | src = ./.; 8 | libraryHaskellDepends = [ 9 | async base contravariant foldl managed mmorph pipes 10 | pipes-concurrency transformers 11 | ]; 12 | description = "Model-view-controller"; 13 | license = stdenv.lib.licenses.bsd3; 14 | } 15 | -------------------------------------------------------------------------------- /mvc.cabal: -------------------------------------------------------------------------------- 1 | Name: mvc 2 | Version: 1.1.7 3 | Cabal-Version: >=1.8.0.2 4 | Build-Type: Simple 5 | License: BSD3 6 | License-File: LICENSE 7 | Copyright: 2014 Gabriella Gonzalez 8 | Author: Gabriella Gonzalez 9 | Maintainer: GenuineGabriella@gmail.com 10 | Tested-With: GHC == 8.0.2 11 | Bug-Reports: https://github.com/Gabriella439/Haskell-MVC-Library/issues 12 | Synopsis: Model-view-controller 13 | Description: Use the @mvc@ library to distill concurrent programs into pure and 14 | single-threaded programs using the @Model@-@View@-@Controller@ pattern. This 15 | transformation lets you: 16 | . 17 | * replay your program deterministically, 18 | . 19 | * do property-based testing of your model (like @QuickCheck@), and: 20 | . 21 | * equationally reason about your pure core. 22 | Category: Control, Concurrency 23 | Source-Repository head 24 | Type: git 25 | Location: https://github.com/Gabriella439/Haskell-MVC-Library 26 | 27 | Library 28 | Hs-Source-Dirs: src 29 | Build-Depends: 30 | base >= 4 && < 5 , 31 | async >= 2.0.0 && < 2.3, 32 | contravariant < 1.5, 33 | foldl >= 1.4, 34 | managed < 1.1, 35 | mmorph >= 1.0.2 && < 1.2, 36 | pipes >= 4.1.7 && < 4.4, 37 | pipes-concurrency >= 2.0.3 && < 2.1, 38 | transformers >= 0.2.0.0 && < 0.6 39 | if !impl(ghc >= 8.0) 40 | Build-depends: semigroups == 0.18.* 41 | Exposed-Modules: 42 | MVC, 43 | MVC.Prelude 44 | GHC-Options: -Wall 45 | -------------------------------------------------------------------------------- /release.nix: -------------------------------------------------------------------------------- 1 | # You can build this repository using Nix by running: 2 | # 3 | # $ nix-build -A mvc release.nix 4 | # 5 | # You can also open up this repository inside of a Nix shell by running: 6 | # 7 | # $ nix-shell -A mvc.env release.nix 8 | # 9 | # ... and then Nix will supply the correct Haskell development environment for 10 | # you 11 | let 12 | config = { 13 | packageOverrides = pkgs: { 14 | haskellPackages = pkgs.haskellPackages.override { 15 | overrides = haskellPackagesNew: haskellPackagesOld: { 16 | mvc = haskellPackagesNew.callPackage ./default.nix { }; 17 | }; 18 | }; 19 | }; 20 | }; 21 | 22 | pkgs = 23 | import { inherit config; }; 24 | 25 | in 26 | { mvc = pkgs.haskellPackages.mvc; 27 | } 28 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | (import ./release.nix).mvc.env 2 | -------------------------------------------------------------------------------- /src/MVC.hs: -------------------------------------------------------------------------------- 1 | {-| Use the `Model` - `View` - `Controller` pattern to separate impure inputs 2 | and outputs from pure application logic so that you can: 3 | 4 | * Equationally reason about your model 5 | 6 | * Exercise your model with property-based testing (like @QuickCheck@) 7 | 8 | * Reproducibly replay your model 9 | 10 | The @mvc@ library uses the type system to statically enforce the separation 11 | of impure `View`s and `Controller`s from the pure `Model`. 12 | 13 | Here's a small example program written using the @mvc@ library to illustrate 14 | the core types and concepts: 15 | 16 | > import MVC 17 | > import qualified MVC.Prelude as MVC 18 | > import qualified Pipes.Prelude as Pipes 19 | > 20 | > external :: Managed (View String, Controller String) 21 | > external = do 22 | > c1 <- MVC.stdinLines 23 | > c2 <- MVC.tick 1 24 | > return (MVC.stdoutLines, c1 <> fmap show c2) 25 | > 26 | > model :: Model () String String 27 | > model = asPipe (Pipes.takeWhile (/= "quit")) 28 | > 29 | > main :: IO () 30 | > main = runMVC () model external 31 | 32 | This program has three components: 33 | 34 | * A `Controller` that interleaves lines from standard input with periodic 35 | ticks 36 | 37 | * A `View` that writes lines to standard output 38 | 39 | * A pure `Model`, which forwards lines until the user inputs \"quit\" 40 | 41 | 'runMVC' connects them into a complete program, which outputs a @()@ every 42 | second and also echoes standard input to standard output until the user 43 | enters \"quit\": 44 | 45 | >>> main 46 | () 47 | Test 48 | Test 49 | () 50 | () 51 | 42 52 | 42 53 | () 54 | quit 55 | >>> 56 | 57 | The following sections give extended guidance for how to structure @mvc@ 58 | programs. Additionally, there is an "MVC.Prelude" module, which provides 59 | several utilities and provides a more elaborate code example using the 60 | @sdl@ library. 61 | -} 62 | 63 | {-# LANGUAGE RankNTypes #-} 64 | 65 | module MVC ( 66 | -- * Controllers 67 | -- $controller 68 | Controller 69 | , asInput 70 | , keeps 71 | 72 | -- * Views 73 | -- $view 74 | , View 75 | , asSink 76 | , asFold 77 | , handles 78 | 79 | -- * Models 80 | -- $model 81 | , Model 82 | , ModelM 83 | , asPipe 84 | 85 | -- * MVC 86 | -- $mvc 87 | , runMVC 88 | , generalizeMVC 89 | 90 | -- * Managed resources 91 | -- $managed 92 | , Managed 93 | , managed 94 | 95 | -- *ListT 96 | , loop 97 | -- $listT 98 | 99 | -- * Re-exports 100 | -- $reexports 101 | , module Data.Functor.Constant 102 | , module Data.Functor.Contravariant 103 | , module Data.Monoid 104 | , module Pipes 105 | , module Pipes.Concurrent 106 | ) where 107 | 108 | import Control.Category (Category(..)) 109 | import Control.Foldl (FoldM(..), HandlerM, impurely, premapM) 110 | import qualified Control.Foldl as Fold 111 | import Control.Monad.Managed (Managed, managed, with) 112 | import Control.Monad.Morph (generalize) 113 | import Control.Monad.Trans.State.Strict (execStateT, StateT) 114 | import Data.Functor.Constant (Constant(Constant, getConstant)) 115 | import Data.Functor.Contravariant (Contravariant(contramap)) 116 | import Data.Monoid (Monoid(mempty, mappend, mconcat), (<>), First) 117 | import qualified Data.Monoid as M 118 | import qualified Data.Semigroup as S 119 | import Pipes 120 | import Pipes.Concurrent 121 | import Pipes.Prelude (foldM, loop) 122 | import Data.Functor.Identity (Identity) 123 | 124 | import Prelude hiding ((.), id) 125 | 126 | {- $controller 127 | `Controller`s represent concurrent inputs to your system. Use the `Functor` 128 | and `Monoid` instances for `Controller` and `Managed` to unify multiple 129 | `Managed` `Controller`s together into a single `Managed` `Controller`: 130 | 131 | > controllerA :: Managed (Controller A) 132 | > controllerB :: Managed (Controller B) 133 | > controllerC :: Managed (Controller C) 134 | > 135 | > data TotalInput = InA A | InB B | InC C 136 | > 137 | > controllerTotal :: Managed (Controller TotalInput) 138 | > controllerTotal = 139 | > fmap (fmap InA) controllerA 140 | > <> fmap (fmap InB) controllerB 141 | > <> fmap (fmap InC) controllerC 142 | 143 | Combining `Controller`s interleaves their values. 144 | -} 145 | 146 | {-| A concurrent source 147 | 148 | > fmap f (c1 <> c2) = fmap f c1 <> fmap f c2 149 | > 150 | > fmap f mempty = mempty 151 | -} 152 | newtype Controller a = AsInput (Input a) 153 | -- This is just a newtype wrapper around `Input` because: 154 | -- 155 | -- * I want the `Controller` name to "stick" in inferred types 156 | -- 157 | -- * I want to restrict the API to ensure that `runMVC` is the only way to 158 | -- consume `Controller`s. This enforces strict separation of `Controller` 159 | -- logic from `Model` or `View` logic 160 | 161 | -- Deriving `Functor` 162 | instance Functor Controller where 163 | fmap f (AsInput i) = AsInput (fmap f i) 164 | 165 | -- Deriving `Semigroup` 166 | instance S.Semigroup (Controller a) where 167 | (AsInput i1) <> (AsInput i2) = AsInput (i1 S.<> i2) 168 | 169 | -- Deriving `Monoid` 170 | instance Monoid (Controller a) where 171 | mappend = (<>) 172 | 173 | mempty = AsInput mempty 174 | 175 | -- | Create a `Controller` from an `Input` 176 | asInput :: Input a -> Controller a 177 | asInput = AsInput 178 | {-# INLINABLE asInput #-} 179 | 180 | {-| Think of the type as one of the following types: 181 | 182 | > keeps :: Prism' a b -> Controller a -> Controller b 183 | > keeps :: Traversal' a b -> Controller a -> Controller b 184 | 185 | @(keeps prism controller)@ only emits values if the @prism@ matches the 186 | @controller@'s output. 187 | 188 | > keeps (p1 . p2) = keeps p2 . keeps p1 189 | > 190 | > keeps id = id 191 | 192 | > keeps p (c1 <> c2) = keeps p c1 <> keeps p c2 193 | > 194 | > keeps p mempty = mempty 195 | -} 196 | keeps 197 | :: ((b -> Constant (First b) b) -> (a -> Constant (First b) a)) 198 | -- ^ 199 | -> Controller a 200 | -- ^ 201 | -> Controller b 202 | keeps k (AsInput (Input recv_)) = AsInput (Input recv_') 203 | where 204 | recv_' = do 205 | ma <- recv_ 206 | case ma of 207 | Nothing -> return Nothing 208 | Just a -> case match a of 209 | Nothing -> recv_' 210 | Just b -> return (Just b) 211 | match = M.getFirst . getConstant . k (Constant . M.First . Just) 212 | {-# INLINABLE keeps #-} 213 | 214 | {- $view 215 | `View`s represent outputs of your system. Use `handles` and the `Monoid` 216 | instance of `View` to unify multiple `View`s together into a single `View`: 217 | 218 | > viewD :: Managed (View D) 219 | > viewE :: Managed (View E) 220 | > viewF :: Managed (View F) 221 | > 222 | > data TotalOutput = OutD D | OutE E | OutF F 223 | > 224 | > makePrisms ''TotalOutput -- Generates _OutD, _OutE, and _OutF prisms 225 | > 226 | > viewTotal :: Managed (View TotalOutput) 227 | > viewTotal = 228 | > fmap (handles _OutD) viewD 229 | > <> fmap (handles _OutE) viewE 230 | > <> fmap (handles _OutF) viewF 231 | 232 | Combining `View`s sequences their outputs. 233 | 234 | If a @lens@ dependency is too heavy-weight, then you can manually generate 235 | `Traversal`s, which `handles` will also accept. Here is an example of how 236 | you can generate `Traversal`s by hand with no dependencies: 237 | 238 | > -- _OutD :: Traversal' TotalOutput D 239 | > _OutD :: Applicative f => (D -> f D) -> (TotalOutput -> f TotalOutput) 240 | > _OutD k (OutD d) = fmap OutD (k d) 241 | > _OutD k t = pure t 242 | > 243 | > -- _OutE :: Traversal' TotalOutput E 244 | > _OutE :: Applicative f => (E -> f E) -> (TotalOutput -> f TotalOutput) 245 | > _OutE k (OutE d) = fmap OutE (k d) 246 | > _OutE k t = pure t 247 | > 248 | > -- _OutF :: Traversal' TotalOutput F 249 | > _OutF :: Applicative f => (F -> f F) -> (TotalOutput -> f TotalOutput) 250 | > _OutF k (OutF d) = fmap OutF (k d) 251 | > _OutF k t = pure t 252 | -} 253 | 254 | {-| An effectful sink 255 | 256 | > contramap f (v1 <> v2) = contramap f v1 <> contramap f v2 257 | > 258 | > contramap f mempty = mempty 259 | -} 260 | newtype View a = AsFold (FoldM IO a ()) 261 | 262 | instance S.Semigroup (View a) where 263 | (AsFold fold1) <> (AsFold fold2) = AsFold (fold1 S.<> fold2) 264 | 265 | instance Monoid (View a) where 266 | mempty = AsFold mempty 267 | mappend = (<>) 268 | 269 | instance Contravariant View where 270 | contramap f (AsFold fold) = AsFold (premapM (return . f) fold) 271 | 272 | -- | Create a `View` from a sink 273 | asSink :: (a -> IO ()) -> View a 274 | asSink sink = AsFold (FoldM step begin done) 275 | where 276 | step x a = do 277 | sink a 278 | return x 279 | begin = return () 280 | done = return 281 | {-# INLINABLE asSink #-} 282 | 283 | -- | Create a `View` from a `FoldM` 284 | asFold :: FoldM IO a () -> View a 285 | asFold = AsFold 286 | {-# INLINABLE asFold #-} 287 | 288 | {-| Think of the type as one of the following types: 289 | 290 | > handles :: Prism' a b -> View b -> View a 291 | > handles :: Traversal' a b -> View b -> View a 292 | 293 | @(handles prism view)@ only runs the @view@ if the @prism@ matches the 294 | input. 295 | 296 | > handles (p1 . p2) = handles p1 . handles p2 297 | > 298 | > handles id = id 299 | 300 | > handles p (v1 <> v2) = handles p v1 <> handles p v2 301 | > 302 | > handles p mempty = mempty 303 | -} 304 | handles 305 | :: HandlerM IO a b 306 | -- ^ 307 | -> View b 308 | -- ^ 309 | -> View a 310 | handles k (AsFold fold) = AsFold (Fold.handlesM k fold) 311 | {-# INLINABLE handles #-} 312 | 313 | {- $model 314 | `Model`s are stateful streams and they sit in between `Controller`s and 315 | `View`s. 316 | 317 | Use `State` to internally communicate within the `Model`. 318 | 319 | Read the \"ListT\" section which describes why you should prefer `ListT` 320 | over `Pipe` when possible. 321 | 322 | Also, try to defer converting your `Pipe` to a `Model` until you call 323 | `runMVC`, because the conversion is not reversible and `Pipe` is strictly 324 | more featureful than `Model`. 325 | -} 326 | 327 | {-| A @(Model s a b)@ converts a stream of @(a)@s into a stream of @(b)@s while 328 | interacting with a state @(s)@ 329 | -} 330 | newtype ModelM m s a b = AsPipe (Pipe a b (StateT s m) ()) 331 | type Model = ModelM Identity 332 | 333 | instance Monad m => Category (ModelM m s) where 334 | (AsPipe m1) . (AsPipe m2) = AsPipe (m1 <-< m2) 335 | 336 | id = AsPipe cat 337 | 338 | {-| Create a `Model` from a `Pipe` 339 | 340 | > asPipe (p1 <-< p2) = asPipe p1 . asPipe p2 341 | > 342 | > asPipe cat = id 343 | -} 344 | asPipe :: Pipe a b (StateT s m) () -> ModelM m s a b 345 | asPipe = AsPipe 346 | {-# INLINABLE asPipe #-} 347 | 348 | {- $mvc 349 | Connect a `Model`, `View`, and `Controller` and an initial state 350 | together using `runMVC` to complete your application. 351 | 352 | `runMVC` is the only way to consume `View`s and `Controller`s. The types 353 | forbid you from mixing `View` and `Controller` logic with your `Model` 354 | logic. 355 | 356 | Note that `runMVC` only accepts one `View` and one `Controller`. This 357 | enforces a single entry point and exit point for your `Model` so that you 358 | can cleanly separate your `Model` logic from your `View` logic and 359 | `Controller` logic. The way you add more `View`s and `Controller`s to your 360 | program is by unifying them into a single `View` or `Controller` by using 361 | their `Monoid` instances. See the \"Controllers\" and \"Views\" sections 362 | for more details on how to do this. 363 | -} 364 | 365 | {-| Connect a `Model`, `View`, and `Controller` and initial state into a 366 | complete application. 367 | -} 368 | 369 | runMVC :: s 370 | -- ^ Initial state 371 | -> Model s a b 372 | -- ^ Program logic 373 | -> Managed (View b, Controller a) 374 | -- ^ Effectful output and input 375 | -> IO s 376 | -- ^ Returns final state 377 | runMVC = generalizeMVC generalize 378 | 379 | {-| Connect a `Model`, `View`, and `Controller` and initial state into a 380 | complete application over arbitrary monad given a morphism to IO. 381 | -} 382 | generalizeMVC 383 | :: Monad m => (forall x . m x -> IO x) 384 | -- ^ Monad morphism 385 | -> s 386 | -- ^ Initial state 387 | -> ModelM m s a b 388 | -- ^ Program logic 389 | -> Managed (View b, Controller a) 390 | -- ^ Effectful output and input 391 | -> IO s 392 | -- ^ Returns final state 393 | generalizeMVC cb initialState (AsPipe pipe) viewController = 394 | with viewController $ \(AsFold (FoldM step begin done), AsInput input) -> do 395 | let step' x a = lift (step x a) 396 | let begin' = lift begin 397 | let done' x = lift (done x) 398 | let fold' = FoldM step' begin' done' 399 | flip execStateT initialState $ 400 | impurely foldM fold' (fromInput input >-> hoist (hoist cb) pipe) 401 | {-# INLINABLE runMVC #-} 402 | 403 | {- $managed 404 | Use `managed` to create primitive `Managed` resources and use the `Functor`, 405 | `Applicative`, `Monad`, and `Monoid` instances for `Managed` to bundle 406 | multiple `Managed` resources into a single `Managed` resource. 407 | 408 | See the source code for the \"Utilities\" section below for several examples 409 | of how to create `Managed` resources. 410 | -} 411 | 412 | {- $listT 413 | `ListT` computations can be combined in more ways than `Pipe`s, so try to 414 | program in `ListT` as much as possible and defer converting it to a `Pipe` 415 | as late as possible using `loop`. 416 | 417 | You can combine `ListT` computations even if their inputs and outputs are 418 | completely different: 419 | 420 | > -- Independent computations 421 | > 422 | > modelAToD :: A -> ListT (State S) D 423 | > modelBToE :: B -> ListT (State S) E 424 | > modelCToF :: C -> ListT (State s) F 425 | > 426 | > modelInToOut :: TotalInput -> ListT (State S) TotalOutput 427 | > modelInToOut totalInput = case totalInput of 428 | > InA a -> fmap OutD (modelAToD a) 429 | > InB b -> fmap OutE (modelBToE b) 430 | > InC c -> fmap OutF (modelCToF c) 431 | 432 | Sometimes you have multiple computations that handle different inputs but 433 | the same output, in which case you don't need to unify their outputs: 434 | 435 | > -- Overlapping outputs 436 | > 437 | > modelAToOut :: A -> ListT (State S) Out 438 | > modelBToOut :: B -> ListT (State S) Out 439 | > modelCToOut :: C -> ListT (State S) Out 440 | > 441 | > modelInToOut :: TotalInput -> ListT (State S) TotalOutput 442 | > modelInToOut totalInput = case totalInput of 443 | > InA a -> modelAToOut a 444 | > InB b -> modelBToOut b 445 | > InC c -> modelCToOut c 446 | 447 | Other times you have multiple computations that handle the same input but 448 | produce different outputs. You can unify their outputs using the `Monoid` 449 | and `Functor` instances for `ListT`: 450 | 451 | > -- Overlapping inputs 452 | > 453 | > modelInToA :: TotalInput -> ListT (State S) A 454 | > modelInToB :: TotalInput -> ListT (State S) B 455 | > modelInToC :: TotalInput -> ListT (State S) C 456 | > 457 | > modelInToOut :: TotalInput -> ListT (State S) TotalOutput 458 | > modelInToOut totalInput = 459 | > fmap OutA (modelInToA totalInput) 460 | > <> fmap OutB (modelInToB totalInput) 461 | > <> fmap OutC (modelInToC totalInput) 462 | 463 | You can also chain `ListT` computations, feeding the output of the first 464 | computation as the input to the next computation: 465 | 466 | > -- End-to-end 467 | > 468 | > modelInToMiddle :: TotalInput -> ListT (State S) MiddleStep 469 | > modelMiddleToOut :: MiddleStep -> ListT (State S) TotalOutput 470 | > 471 | > modelInToOut :: TotalInput -> ListT (State S) TotalOutput 472 | > modelInToOut = modelInToMiddle >=> modelMiddleToOut 473 | 474 | ... or you can just use @do@ notation if you prefer. 475 | 476 | However, the `Pipe` type is more general than `ListT` and can represent 477 | things like termination. Therefore you should consider mixing `Pipe`s with 478 | `ListT` when you need to take advantage of these extra features: 479 | 480 | > -- Mix ListT with Pipes 481 | > 482 | > pipe :: Pipe TotalInput TotalOutput (State S) () 483 | > pipe = Pipes.takeWhile (not . isC)) >-> loop modelInToOut 484 | > where 485 | > isC (InC _) = True 486 | > isC _ = False 487 | 488 | So promote your `ListT` logic to a `Pipe` when you need to take advantage of 489 | these `Pipe`-specific features. 490 | -} 491 | 492 | {- $reexports 493 | "Data.Functor.Constant" re-exports `Constant` 494 | 495 | "Data.Functor.Contravariant" re-exports `Contravariant` 496 | 497 | "Data.Monoid" re-exports `Monoid`, (`<>`), `mconcat`, and `First` (the type 498 | only) 499 | 500 | "Pipes" re-exports everything 501 | 502 | "Pipes.Concurrent" re-exports everything 503 | -} 504 | -------------------------------------------------------------------------------- /src/MVC/Prelude.hs: -------------------------------------------------------------------------------- 1 | {-| Simple utilities 2 | 3 | The \"Example\" section at the bottom of this module contains an extended 4 | example of how to interact with the @sdl@ library using the @mvc@ library 5 | -} 6 | 7 | module MVC.Prelude ( 8 | -- * Controllers 9 | producer 10 | , stdinLines 11 | , inLines 12 | , inRead 13 | , tick 14 | 15 | -- * Views 16 | , consumer 17 | , stdoutLines 18 | , outLines 19 | , outShow 20 | 21 | -- * Handles 22 | , inHandle 23 | , outHandle 24 | 25 | -- * Threads 26 | , forkManaged 27 | 28 | -- * Example 29 | -- $example 30 | ) where 31 | 32 | import Control.Applicative (pure, (<*)) 33 | import Control.Concurrent.Async (withAsync) 34 | import Control.Concurrent (threadDelay) 35 | import Data.IORef (newIORef, readIORef, writeIORef) 36 | import MVC 37 | import Pipes.Internal (Proxy(..), closed) 38 | import qualified Pipes.Prelude as Pipes 39 | import qualified System.IO as IO 40 | 41 | -- | Fork managed computation in a new thread. See `producer` source for usage example. 42 | forkManaged :: IO (IO (), a, IO ()) -- ^ Setup action returning thread's main, 43 | -- managed value, finalizer. 44 | -> Managed a 45 | forkManaged cb = managed $ \k -> do 46 | (io, ret, fin) <- cb 47 | withAsync (io >> fin) $ \_ -> k ret <* fin 48 | {-# INLINABLE forkManaged #-} 49 | 50 | {-| Create a `Controller` from a `Producer`, using the given `Buffer` 51 | 52 | If you're not sure what `Buffer` to use, try `Single` 53 | -} 54 | producer :: Buffer a -> Producer a IO () -> Managed (Controller a) 55 | producer buffer prod = forkManaged $ do 56 | (o, i, seal) <- spawn' buffer 57 | return (runEffect $ prod >-> toOutput o, asInput i, atomically seal) 58 | {-# INLINABLE producer #-} 59 | 60 | -- | Read lines from standard input 61 | stdinLines :: Managed (Controller String) 62 | stdinLines = producer (bounded 1) Pipes.stdinLn 63 | {-# INLINABLE stdinLines #-} 64 | 65 | -- | Read lines from a file 66 | inLines :: FilePath -> Managed (Controller String) 67 | inLines filePath = do 68 | handle <- inHandle filePath 69 | producer (bounded 1) (Pipes.fromHandle handle) 70 | {-# INLINABLE inLines #-} 71 | 72 | -- | 'read' values from a file, one value per line, skipping failed parses 73 | inRead :: Read a => FilePath -> Managed (Controller a) 74 | inRead filePath = fmap (keeps parsed) (inLines filePath) 75 | where 76 | parsed k str = case reads str of 77 | [(a, "")] -> Constant (getConstant (k a)) 78 | _ -> pure str 79 | {-# INLINABLE inRead #-} 80 | 81 | -- | Emit empty values spaced by a delay in seconds 82 | tick :: Double -> Managed (Controller ()) 83 | tick n = producer (bounded 1) $ 84 | lift (threadDelay (truncate (n * 1000000))) >~ cat 85 | {-# INLINABLE tick #-} 86 | 87 | -- | Create a `View` from a `Consumer` 88 | consumer :: Consumer a IO () -> Managed (View a) 89 | consumer cons0 = managed $ \k -> do 90 | mf0 <- nextRequest cons0 91 | ref <- newIORef mf0 92 | k $ asSink $ \a -> do 93 | mf <- readIORef ref 94 | case mf of 95 | Nothing -> return () 96 | Just f -> do 97 | mf' <- nextRequest (f a) 98 | writeIORef ref mf' 99 | where 100 | nextRequest :: Consumer a IO () -> IO (Maybe (a -> Consumer a IO ())) 101 | nextRequest cons = case cons of 102 | Request () fa -> return (Just fa) 103 | Respond v _ -> closed v 104 | M m -> m >>= nextRequest 105 | Pure () -> return Nothing 106 | {-# INLINABLE consumer #-} 107 | 108 | -- | Write lines to standard output 109 | stdoutLines :: View String 110 | stdoutLines = asSink putStrLn 111 | {-# INLINABLE stdoutLines #-} 112 | 113 | -- | Write lines to a file 114 | outLines :: FilePath -> Managed (View String) 115 | outLines filePath = do 116 | handle <- outHandle filePath 117 | return (asSink (IO.hPutStrLn handle)) 118 | {-# INLINABLE outLines #-} 119 | 120 | -- | 'show' values to a file, one value per line 121 | outShow :: Show a => FilePath -> Managed (View a) 122 | outShow filePath = fmap (contramap show) (outLines filePath) 123 | {- 124 | outShow filePath = do 125 | handle <- outHandle filePath 126 | return (asSink (IO.hPrint handle)) 127 | -} 128 | {-# INLINABLE outShow #-} 129 | 130 | -- | Read from a `FilePath` using a `Managed` `IO.Handle` 131 | inHandle :: FilePath -> Managed IO.Handle 132 | inHandle filePath = managed (IO.withFile filePath IO.ReadMode) 133 | {-# INLINABLE inHandle #-} 134 | 135 | -- | Write to a `FilePath` using a `Managed` `IO.Handle` 136 | outHandle :: FilePath -> Managed IO.Handle 137 | outHandle filePath = managed (IO.withFile filePath IO.WriteMode) 138 | {-# INLINABLE outHandle #-} 139 | 140 | {- $example 141 | The following example distils a @sdl@-based program into pure and impure 142 | components. This program will draw a white rectangle between every two 143 | mouse clicks. 144 | 145 | The first half of the program contains all the concurrent and impure logic. 146 | The `View` and `Controller` must be `Managed` together since they both share 147 | the same initialization logic: 148 | 149 | > import Control.Monad (join) 150 | > import Control.Monad.Managed (managed_) 151 | > import Graphics.UI.SDL as SDL 152 | > import Lens.Family.Stock (_Left, _Right) -- from `lens-family-core` 153 | > import MVC 154 | > import MVC.Prelude 155 | > import qualified Pipes.Prelude as Pipes 156 | > 157 | > data Done = Done deriving (Eq, Show) 158 | > 159 | > sdl :: Managed (View (Either Rect Done), Controller Event) 160 | > sdl = do 161 | > managed_ (withInit [InitVideo, InitEventthread]) 162 | > surface <- liftIO $ setVideoMode 640 480 32 [SWSurface] 163 | > white <- liftIO $ mapRGB (surfaceGetPixelFormat surface) 255 255 255 164 | > 165 | > let done :: View Done 166 | > done = asSink (\Done -> SDL.quit) 167 | > 168 | > drawRect :: View Rect 169 | > drawRect = asSink $ \rect -> do 170 | > _ <- fillRect surface (Just rect) white 171 | > SDL.flip surface 172 | > 173 | > totalOut :: View (Either Rect Done) 174 | > totalOut = handles _Left drawRect <> handles _Right done 175 | > 176 | > totalIn <- producer Single (lift waitEvent >~ cat) 177 | > return (totalOut, totalIn) 178 | 179 | Note that `Managed` is a `Monad`, so you can use @do@ notation to 180 | combine multiple `Managed` resources into a single `Managed` resource. 181 | 182 | The second half of the program contains the pure logic. 183 | 184 | > pipe :: Monad m => Pipe Event (Either Rect Done) m () 185 | > pipe = do 186 | > Pipes.takeWhile (/= Quit) >-> (click >~ rectangle >~ Pipes.map Left) 187 | > yield (Right Done) 188 | > 189 | > rectangle :: Monad m => Consumer' (Int, Int) m Rect 190 | > rectangle = do 191 | > (x1, y1) <- await 192 | > (x2, y2) <- await 193 | > let x = min x1 x2 194 | > y = min y1 y2 195 | > w = abs (x1 - x2) 196 | > h = abs (y1 - y2) 197 | > return (Rect x y w h) 198 | > 199 | > click :: Monad m => Consumer' Event m (Int, Int) 200 | > click = do 201 | > e <- await 202 | > case e of 203 | > MouseButtonDown x y ButtonLeft -> 204 | > return (fromIntegral x, fromIntegral y) 205 | > _ -> click 206 | > 207 | > main :: IO () 208 | > main = runMVC () (asPipe pipe) sdl 209 | 210 | Run the program to verify that clicks create rectangles. 211 | 212 | The more logic you move into the pure core the more you can exercise your 213 | program purely, either manually: 214 | 215 | >>> let leftClick (x, y) = MouseButtonDown x y ButtonLeft 216 | >>> Pipes.toList (each [leftClick (10, 10), leftClick (15, 16), Quit] >-> pipe) 217 | [Left (Rect {rectX = 10, rectY = 10, rectW = 5, rectH = 6}),Right Done] 218 | 219 | ... or automatically using property-based testing (such as @QuickCheck@): 220 | 221 | >>> import Test.QuickCheck 222 | >>> quickCheck $ \xs -> length (Pipes.toList (each (map leftClick xs) >-> pipe)) == length xs `div` 2 223 | +++ OK, passed 100 tests. 224 | 225 | Equally important, you can formally prove properties about your model using 226 | equational reasoning because the model is `IO`-free and concurrency-free. 227 | -} 228 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-5.5 2 | --------------------------------------------------------------------------------