Button.elm

module Button exposing ( Button, new, view, onClick )


import Html exposing ( Html, Attribute )
import Html.Attributes as Attributes
import Html.Events as Events
import Time exposing ( Time )

import Platform.Cmd.Extra as XCmd
import Embedding exposing ( Embedding, OpaqueUpdate )


-- MODEL


type Button msg model
    = Button
        { color : { background : String
                  , text : String
                  , flash : String
                  }
        , state : ButtonState
        , delay : Time
        , embedding : Embedding (Button msg model) msg model
        }


type ButtonState
    = Flashing
    | NotFlashing


new
    :  (OpaqueUpdate msg model -> msg)
    -> ((Button msg model -> Button msg model) -> model -> model)
    -> Button msg model
new wrapOpaque liftUpdate =
    Button
        { color = { background = "#77DD77"
                  , text = "#FFFFFF"
                  , flash = "#BFFF00"
                  }
        , state = NotFlashing
        , delay = 1.5 * Time.second
        , embedding = { liftUpdate = liftUpdate
                      , wrapOpaque = wrapOpaque
                      }
        }


-- UPDATE


type ButtonMessage
    = StartFlashing
    | StopFlashing


update : ButtonMessage -> Button msg model -> Button msg model
update msg (Button btn) =
    case msg of
        StartFlashing ->
            { btn | state = Flashing } |> Button
        StopFlashing ->
            { btn | state = NotFlashing } |> Button


-- VIEW


view
    :  Button msg model
    -> List (Button msg model -> Attribute msg)
    -> List (Html msg)
    -> Html msg
view (Button btn) customAttrs children =
    let
        { embedding } = btn

        defaultOnClick btn =
            let
                noopMessage =
                    identity
                    |> Embedding.updateToMessage embedding []
            in
                btn |> onClick noopMessage

        backgroundColor btn =
            case btn.state of
                  Flashing ->
                      btn.color.flash
                  NotFlashing ->
                      btn.color.background

        styles (Button btn) =
            Attributes.style
                [ ( "color", btn.color.text )
                , ( "background", btn |> backgroundColor )
                , ( "font-weight", "bold" )
                ]

        defaultAttrs = [ defaultOnClick, styles ]

        allAttrs =
            defaultAttrs `List.append` customAttrs
            |> List.map (\f -> f <| Button btn)
    in
        Html.button allAttrs children


onClick : msg -> Button msg model -> Attribute msg
onClick msg (Button btn) =
    let
        { embedding } = btn

        sendDelayedMsg =
            update StopFlashing
            |> Embedding.updateToMessage embedding []
            |> XCmd.delay btn.delay

        sendUserMsg = msg |> XCmd.wrap
    in
        update StartFlashing
        |> Embedding.updateToMessage
            embedding
            [ sendUserMsg , sendDelayedMsg ]
        |> Events.onClick

Embedding.elm

module Embedding exposing ( .. )


type alias Embedding part message container =
    { wrapOpaque : OpaqueUpdate message container -> message
    , liftUpdate : (part -> part) -> container -> container
    }


type alias OpaqueUpdate msg model =
    model -> (model, Cmd msg)


updateToMessage
    :  Embedding part msg model
    -> List (Cmd msg)
    -> (part -> part)
    -> msg
updateToMessage embedding cmds update =
    let
        opaqueUpdate model =
            (model |> embedding.liftUpdate update) ! cmds
    in
        opaqueUpdate |> embedding.wrapOpaque

Main.elm

module Main exposing ( .. )


import Html exposing (Html, Attribute)
import Html.App as App

import Button exposing (Button)
import Embedding exposing ( Embedding, OpaqueUpdate )


main : Program Never
main =
    App.program
        { init = (init, Cmd.none)
        , update = update
        , view = view
        , subscriptions = always Sub.none
        }


-- MODEL


type Counter
    = Counter
        { count : Int
        , upButton : Button Message Counter
        , downButton : Button Message Counter
        }


init : Counter
init =
    Counter
        { count = 0
        , upButton = Button.new Opaque upButtonL
        , downButton = Button.new Opaque downButtonL
        }


upButtonL f (Counter counter) =
    Counter { counter | upButton = f counter.upButton }


downButtonL f (Counter counter) =
    Counter { counter | downButton = f counter.downButton }


-- UPDATE


type Message
    = Decrement
    | Increment
    | Opaque (OpaqueUpdate Message Counter)


update : Message -> Counter -> (Counter, Cmd Message)
update msg model =
    let
        (Counter inner) = model
        withoutEffects = Counter >> flip (!) [ Cmd.none ]
    in
        case msg of
            Decrement ->
                { inner | count = inner.count - 1 } |> withoutEffects
            Increment ->
                { inner | count = inner.count + 1 } |> withoutEffects
            Opaque f ->
                model |> f


-- VIEW


view : Counter -> Html Message
view (Counter counter) =
    Html.div
        []
        [ Button.view counter.downButton
            [ Button.onClick Decrement ]
            [ Html.text "-" ]
        , Html.text <| toString counter.count
        , Button.view counter.upButton
            [ Button.onClick Increment ]
            [ Html.text "+" ]
        ]

Platform.Cmd.Extra.elm

module Platform.Cmd.Extra exposing ( .. )


import Process
import Task
import Time exposing ( Time )


wrap : msg -> Cmd msg
wrap msg =
    Task.succeed ()
    |> Task.perform (always msg) (always msg)


delay : Time -> a -> Cmd a
delay t msg =
    Process.sleep t
    |> Task.perform (always msg) (always msg)