Translator Pattern

Main.elm

import Page exposing (..)
import Http
import Json.Decode as Decode
import Task
import Html

main =
  Html.program
    { init = init
    , view = view
    , update = update
    , subscriptions = subscriptions
    }

init : (Model, Cmd Msg)
init =
  let
    (pageState, pageCmd) = Page.init
  in
    { loading = 0
    , pageState = pageState
    } ! [Cmd.map pageTranslator pageCmd]


type alias Model =
  { loading : Int
  , pageState : Page.Model
  }

type Msg
  = PageMsg Page.InternalMsg
  | FetchResource (Result Http.Error String -> Page.InternalMsg) String
  | FetchedResource Page.InternalMsg

translationDictionary
  = { onInternalMessage = PageMsg
    , onFetchResource = FetchResource
    }

pageTranslator = Page.translator translationDictionary

view model = Html.map pageTranslator <| Page.view model.pageState

update : Msg -> Model -> (Model, Cmd Msg)
update msg model =
  case msg of
    PageMsg internalMsg ->
      let (pageState_, cmd_)
        = Page.update internalMsg model.pageState
      in
        {model | pageState = pageState_} ! [Cmd.map pageTranslator cmd_]

    FetchResource constructor topic ->
      {model | loading = model.loading + 1} ! [fetchResource constructor topic]

    FetchedResource msg ->
      {model | loading = model.loading - 1} ! [pure <| PageMsg msg]

fetchResource : (Result Http.Error String -> Page.InternalMsg) -> String -> Cmd Msg
fetchResource constructor topic =
  let
    url =
      "https://api.giphy.com/v1/gifs/random?api_key=dc6zaTOxFJmzC&tag=" ++ topic
  in
    Http.send (FetchedResource << constructor) (Http.get url decodeGifUrl)

pure : msg -> Cmd msg
pure x = Task.perform (always x) (Task.succeed ())

decodeGifUrl : Decode.Decoder String
decodeGifUrl =
  Decode.at ["data", "image_url"] Decode.string

subscriptions : Model -> Sub Msg
subscriptions model =
  Sub.none

Page.elm

-- Read more about this program in the official Elm guide:
-- https://guide.elm-lang.org/architecture/effects/http.html
module Page exposing (..)

import Html exposing (..)
import Html.Attributes exposing (..)
import Html.Events exposing (..)
import Http
import Json.Decode as Decode




-- MODEL


type alias Model =
  { topic : String
  , gifUrl : String
  }


init : (Model, Cmd Msg)
init =
  ( Model "cats" "waiting.gif"
  , Cmd.none
  )



-- UPDATE


type Msg
  = ForSelf InternalMsg
  | ForParent OutMsg

type InternalMsg =
    NewGif (Result Http.Error String)
  | Update String

type OutMsg = FetchResource (Result Http.Error String -> InternalMsg) String

type alias TranslationDictionary msg =
  { onInternalMessage: InternalMsg -> msg
  , onFetchResource: (Result Http.Error String -> InternalMsg) -> String -> msg
  }

type alias Translator parentMsg = Msg -> parentMsg

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

    ForParent (FetchResource constructor topic) ->
      onFetchResource constructor topic

update : InternalMsg -> Model -> (Model, Cmd Msg)
update msg model =
  case msg of

    NewGif (Ok newUrl) ->
      (Model model.topic newUrl, Cmd.none)

    NewGif (Err _) ->
      (model, Cmd.none)

    Update topic ->
      {model | topic = topic} ! []


-- VIEW


view : Model -> Html Msg
view model =
  div []
    [ h2 [] [text model.topic]
    , input [ type_ "text", placeholder "Topic", onInput (ForSelf << Update) ] []
    , button [ onClick (ForParent (FetchResource NewGif model.topic)) ] [ text "More Please!" ]
    , br [] []
    , img [src model.gifUrl] []
    ]



-- SUBSCRIPTIONS


subscriptions : Model -> Sub Msg
subscriptions model =
  Sub.none