Demonstration of using functions that return commands as a possible replacement for Message(s) and large reducer blocks.

EffectFn.elm

-- Demonstrates
-- * Dispatching a function Model -> (Model, Msg) rather than a message subsequently pattern matching in the reducer.
-- * Benefits include
--   * Module Oriented Programming. Grouping related operations with the type. Improved transparency. Better organization.
--   * Good ergonomics for composing larger states from smaller througn the use of Lenses.
--   * Slightly more succinct.
-- * Drawbacks
--   * The need to aggregate Cmd's (effects) adds a bit of overhead, but then when have effects ever been elegant?
--   * Replay is lost because messages cannot be serialized.
--   * Logic cannot run in a web worker because functions will not serialize across boundary.
--
-- NOTE: The logic for the application starts on line 54. Everything before that point consists of
-- definitions that would be found in a library but which are implemented here for a self-contained example.
--
-- Paste this code into: http://elm-lang.org/try


module Main exposing (..)

import Browser
import Html exposing (Html, a, button, div, text)
import Html.Attributes exposing (style)
import Html.Events exposing (onClick)
import Random


{-| Updater (would belong to a library)
-}
type EffectUpdater a
    = EffectUpdater (a -> ( a, Cmd (EffectUpdater a) ))


type alias Updater a =
    a -> a


liftEffectUpdater : (a -> a) -> EffectUpdater a
liftEffectUpdater fn =
    EffectUpdater (\a -> ( fn a, Cmd.none ))


updateWithEffect : EffectUpdater a -> a -> ( a, Cmd (EffectUpdater a) )
updateWithEffect (EffectUpdater fn) a =
    fn a


{-| Simple Lens (would belong to a library)
-}
type alias Lens a b =
    { get : a -> b
    , set : a -> b -> a
    }


lens : (a -> b) -> (( a, b ) -> a) -> Lens a b
lens get tupleSet =
    { get = get
    , set = \a -> \b -> tupleSet ( a, b )
    }


over : Lens a b -> Updater b -> Updater a
over abL bUpdater a =
    abL.set a (bUpdater <| abL.get a)


overEffect : Lens a b -> EffectUpdater b -> EffectUpdater a
overEffect abL (EffectUpdater bUpdater) =
    EffectUpdater
        (\a ->
            let
                ( x, y ) =
                    bUpdater <| abL.get a
            in
            ( abL.set a x, Cmd.map (overEffect abL) y )
        )


{-| Html Utility (would belong to a library)
-}
viewThroughLens : (b -> Html (EffectUpdater b)) -> a -> Lens a b -> Html (EffectUpdater a)
viewThroughLens bView a abLens =
    bView (abLens.get a) |> Html.map (overEffect abLens)


main : Program () App (EffectUpdater App)
main =
    Browser.element
        { init =
            \() ->
                ( { left = Adder 0, right = Adder 10 }, Cmd.none )
        , update = updateWithEffect
        , view = view
        , subscriptions = \_ -> Sub.none
        }


{-| Adder Module
-}
type Adder
    = Adder Int


inc : Adder -> Adder
inc (Adder n) =
    Adder (n + 1)


incRandom : EffectUpdater Adder
incRandom =
    EffectUpdater
        (\m ->
            ( m, Random.generate (\v -> liftEffectUpdater (\(Adder n) -> Adder (n + v))) (Random.int 1 10) )
        )


show : Adder -> String
show (Adder n) =
    String.fromInt n


reset : Adder -> Adder
reset _ =
    Adder 0


viewAdder : Adder -> Html (EffectUpdater Adder)
viewAdder model =
    div []
        [ div [ style "display" "inline-block", style "width" "40px" ] [ text (show model) ]
        , button [ onClick (liftEffectUpdater inc) ] [ text "+" ]
        , button [ onClick incRandom ] [ text "+Random" ]
        , button [ onClick (liftEffectUpdater reset) ] [ text "Reset" ]
        ]


{-| App
-}
type alias App =
    { left : Adder
    , right : Adder
    }


leftL : Lens App Adder
leftL =
    lens .left (\( a, b ) -> { a | left = b })


rightL : Lens App Adder
rightL =
    lens .right (\( a, b ) -> { a | right = b })


incBoth : App -> App
incBoth { left, right } =
    { left = inc left
    , right = inc right
    }


incBothRandom : EffectUpdater App
incBothRandom =
    EffectUpdater
        (\{ left, right } ->
            let
                ( newLeft, cmdLeft ) =
                    updateWithEffect incRandom left

                ( newRight, cmdRight ) =
                    updateWithEffect incRandom right
            in
            ( { left = newLeft, right = newRight }, Cmd.batch [ cmdLeft |> Cmd.map (overEffect leftL), cmdRight |> Cmd.map (overEffect rightL) ] )
        )


view : App -> Html (EffectUpdater App)
view app =
    div []
        [ div [] <| List.map (viewThroughLens viewAdder app) [ leftL, rightL ]
        , button [ onClick (liftEffectUpdater incBoth) ] [ text "+ Both" ]
        , button [ onClick incBothRandom ] [ text "+ Both Random" ]
        ]