mvc-1.0.5: src/MVC.hs

{-| 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
    , 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
-}