miso-examples-1.2.0.0: compose-update/Main.hs

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where

-- This example demonstrates how you can split your update function
-- into separate update functions for parts of your model and then
-- combine them into a single update function operating on the whole
-- model which combines their effects.

import Control.Monad
import Data.Monoid

import Miso
import Miso.String

-- In this slightly contrived example, our model consists of two
-- counters. When one of those counters is incremented, the other is
-- decremented and the other way around.
type Model = (Int, Int)

data Action
  = Increment
  | Decrement
  | NoOp
  deriving (Show, Eq)

-- We are going to use 'Lens'es in this example. Since @miso@ does not
-- depend on a lens library we are going to define a couple of
-- utilities ourselves. We recommend that in your own applications,
-- you depend on a lens library such as @lens@ or @microlens@ to get
-- these definitions.
type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t

-- | You can find this under the same name in @lens@ and
-- @microlens@. @lens@ also provides the infix operator '%%~' as a
-- synonym for 'traverseOf'.
--
-- In this example we are only going to use this when applied to
-- 'Lens' m a' and using 'Effect Action' for the @f@ type variable. In
-- that case the specialized type signature is:
--
-- @traverseOf :: Functor f => Lens' m a -> (a -> Effect Action a) -> s -> Effect action s
traverseOf :: Functor f => Lens s t a b -> (a -> f b) -> s -> f t
traverseOf = id

-- | A lens into the first element of a tuple. Both @lens@ and
-- @microlens@ provide this under the same name.
_1 :: Lens (a,c) (b,c) a b
_1 f (a,c) = (,c) <$> f a

-- | A lens into the second element of a tuple. Both @lens@ and
-- @microlens@ provide this under the same name.
_2 :: Lens (c,a) (c,b) a b
_2 f (c,a) = (c,) <$> f a

-- | Update function for the first counter in our 'Model'.
updateFirstCounter :: Action -> Int -> Effect Action Int
updateFirstCounter Increment m = noEff (m + 1)
updateFirstCounter Decrement m = noEff (m - 1)
updateFirstCounter NoOp m = noEff m

-- | Update function for the second counter in our 'Model'. As we’ve
-- mentioned before, this counter is decremented when the first
-- counter is incremented and the other way around.
updateSecondCounter :: Action -> Int -> Effect Action Int
updateSecondCounter Increment m = noEff (m - 1)
updateSecondCounter Decrement m = noEff (m + 1)
updateSecondCounter NoOp m = noEff m

-- | This is the combined update function for both counters.
updateModel :: Action -> Model -> Effect Action Model
updateModel act =
  let -- We use 'traverseOf' to lift an update function for one
      -- counter to an update function that operates on both
      -- counters. The lifted function leaves the other counter
      -- untouched.
      liftedUpdateFirst :: Model -> Effect Action Model
      liftedUpdateFirst = traverseOf _1 (updateFirstCounter act)
      liftedUpdateSecond :: Model -> Effect Action Model
      liftedUpdateSecond = traverseOf _2 (updateSecondCounter act)
  in -- Since 'Effect Action' is an instance of 'Monad', we can just
     -- use '<=<' to compose these lifted update functions.  It might
     -- be helpful to look at the type signature of '<=<' specialized
     -- for 'Effect Action':
     --
     -- @(<=<) :: (b -> Effect Action c) -> (a -> Effect Action b) -> a -> Effect Action c
     liftedUpdateFirst <=< liftedUpdateSecond

main :: IO ()
main = startApp App { initialAction = NoOp, ..}
  where
    model  = (0, 0)
    update = updateModel
    view   = viewModel
    events = defaultEvents
    subs   = []
    mountPoint = Nothing

viewModel :: Model -> View Action
viewModel (x, y) =
  div_
    []
    [ button_ [onClick Increment] [text "+"]
    , text (ms x <> " | " <> ms y)
    , button_ [onClick Decrement] [text "-"]
    ]