Preliminary (ugly) demo of Translator pattern

Child.elm

module Child exposing (Translator, update, view, init, translator, Model, Msg, InternalMsg)

import Html exposing (Html, div, p, text)
import Html.Attributes exposing (style)
import Html.Events exposing (onClick)
import Html.App


type OutMsg
    = ShowPopup


type InternalMsg
    = Increment
    | Decrement


type alias Model =
    Int


type Msg
    = ForSelf InternalMsg
    | ForParent OutMsg


type alias TranslationDictionary msg =
    { onInternalMessage : InternalMsg -> msg
    , onShowPopup : msg
    }


type alias Translator msg =
    Msg -> msg


init =
    0


translator : TranslationDictionary msg -> Translator msg
translator { onInternalMessage, onShowPopup } msg =
    case msg of
        ForSelf internal ->
            onInternalMessage internal

        ForParent ShowPopup ->
            onShowPopup


view : Model -> Html Msg
view model =
    div [ style [ ( "display", "block" ), ( "width", "100px" ), ( "height", "300px" ), ( "background-color", "red" ) ] ]
        [ p [ onClick (ForSelf Increment) ] [ text "increment" ]
        , p [] [ text (toString model) ]
        , p [ onClick (ForSelf Decrement) ] [ text "decrement" ]
        , p [ onClick (ForParent ShowPopup) ] [ text "show me a popup" ]
        ]


update : InternalMsg -> Model -> ( Model, Cmd Msg )
update msg model =
    case msg of
        Increment ->
            (model + 1) ! []

        Decrement ->
            (model - 1) ! []

Main.elm

module Main exposing (..)

import Child
import Html exposing (Html, div, text)
import Html.App
import Html.Attributes exposing (style)
import Html.Events exposing (onClick)


type Msg
    = ChildMsg Child.InternalMsg
    | ShowPopup
    | ChangeColor


type alias Model =
    { child : Child.Model
    , color : String
    , popupShowing : Bool
    }


childTranslator : Child.Translator Msg
childTranslator =
    Child.translator { onInternalMessage = ChildMsg, onShowPopup = ShowPopup }


main =
    Html.App.program { init = init, subscriptions = \_ -> Sub.none, view = view, update = update }


init : ( Model, Cmd Msg )
init =
    { child = Child.init, color = "blue", popupShowing = False } ! []


changeColorLink : Html Msg
changeColorLink =
    div [ onClick ChangeColor ] [ text "Click to change bg color" ]


popup : Html Msg
popup =
    div [ style [ ( "display", "block" ), ( "background-color", "green" ), ( "height", "300px" ), ( "width", "300px" ) ] ]
        [ text "A popup" ]


view : Model -> Html Msg
view model =
    div [ style [ ( "height", "500px" ), ( "background-color", model.color ) ] ]
        [ Html.App.map childTranslator (Child.view model.child)
        , if model.popupShowing then
            popup
          else
            changeColorLink
        ]


switchColor : String -> String
switchColor color =
    if color == "red" then
        "blue"
    else
        "red"


update : Msg -> Model -> ( Model, Cmd Msg )
update msg model =
    case msg of
        ChildMsg internal ->
            let
                ( child', cmd ) =
                    Child.update internal model.child
            in
                { model | child = child' } ! [ Cmd.map childTranslator cmd ]

        ChangeColor ->
            { model | color = switchColor model.color } ! []

        ShowPopup ->
            { model | popupShowing = True } ! []

👍 This is great.