VDOM in Pure Elm + Ports

index.js

function render(struct, port) {
   switch(struct.type) {
     case "node":
       var el = document.createElement(struct.name);
       applyFacts(struct.attributes, el, port)
       struct.children.forEach(child => el.appendChild(render(child, port)));
       return el;
     case "text":
       return document.createTextNode(struct.value);
   }
}

function applyChange(change, element, port) {
  switch(change.type) {
    case "change":
      return applyPatch(change.patch, element, port);
    case "at":
      return applyChange(change.change, element.childNodes[change.index], port);
    case "batch":
      return change.changes.forEach(c => applyChange(c, element, port));
      
  }
}

function applyPatch(patch, out, port) {
    switch(patch.type) {
      case "facts":
        return applyFacts(patch.facts, out, port);
      case "text":
        out.nodeValue = patch.value;
        return;
      case "redraw":
        return out.parentNode.replaceChild(render(patch.value, port), out);
      case "insert":
        return out.appendChild(render(patch.value, port));
      case "remove":
        return out.parentNode.removeChild(out);
    }
}

function applyFacts(facts, el, port) {
  facts.forEach(attr => {
    switch(attr.type) {
      case "attribute":
        return attr.value == null ? 
          el.removeAttribute(attr.key) : 
          el.setAttribute(attr.key, attr.value);
      case "property":
        if (attr.value == null) {
          delete el[attr.key];
          return;
        } else {
          el[attr.key] = attr.value;
          return;
        }
      case "event":
       if (attr.value == null) { 
         el.removeEventListener(attr.key, el[attr.value]);
         delete el[attr.value];
       } else {
         const handler = e => {
           port.send([attr.value, e]);
           if (attr.stopPropagation) {
             e.stopPropagation();
           }
           if (attr.preventDefault) {
             e.preventDefault();
           }
         };
         el.addEventListener(attr.key, handler);
         // store a reference to the function so we can remove the handler
         el['handler-' + attr.value] = handler;
       }
     }
  });
}

var app = Elm.Main.worker();

app.ports.renderPort.subscribe(function(change) {
  const output = document.getElementById("output");
  applyChange(change, output, app.ports.eventPort);
});

Main.elm

module Main exposing (main)

import MyHtml exposing (program, text, a, onClick, div)


type Msg
    = Inc
    | Dec


main =
    program
        { init = ( 0, Cmd.none )
        , update =
            \msg model ->
                case msg of
                    Inc ->
                        ( model + 1, Cmd.none )

                    Dec ->
                        ( model - 1, Cmd.none )
        , subscriptions = \model -> Sub.none
        , view =
            \model ->
                div []
                    [ text (model |> toString)
                    , a [ onClick Inc ] [ text "+" ]
                    , a [ onClick Dec ] [ text "-" ]
                    , div [] (List.repeat model (text "."))
                    ]
        }

MyHtml.elm

port module MyHtml exposing (program, Html, Attribute, onWithOptions, on, onClick, a, text, div, href)

import Dict exposing (Dict)
import Json.Decode exposing (Decoder)
import Json.Encode as Json
import Platform


--- platform


type alias PrivateModel model msg =
    { userModel : model
    , handlers : Dict String (Decoder msg)
    , view : SafeHtml
    }


init : ( model, Cmd msg ) -> (model -> Html msg) -> ( PrivateModel model msg, Cmd (Maybe msg) )
init userInit userView =
    let
        ( initModel, initCmd ) =
            userInit

        ( handlers, safeView ) =
            extractListeners "" (userView initModel)
    in
    ( { userModel = initModel
      , handlers = handlers
      , view = safeView
      }
    , Cmd.batch [ initialRender safeView, Cmd.map Just initCmd ]
    )


subscriptions : (model -> Sub msg) -> PrivateModel model msg -> Sub (Maybe msg)
subscriptions userSubscribtions model =
    let
        eventDispatcher ( key, event ) =
            Dict.get key model.handlers
                |> Maybe.andThen
                    (\decoder ->
                        Json.Decode.decodeValue decoder event
                            |> Result.toMaybe
                    )
    in
    Sub.batch [ eventPort eventDispatcher, Sub.map Just (userSubscribtions model.userModel) ]


update :
    (msg -> model -> ( model, Cmd msg ))
    -> (model -> Html msg)
    -> Maybe msg
    -> PrivateModel model msg
    -> ( PrivateModel model msg, Cmd (Maybe msg) )
update userUpdate view maybeMsg model =
    case maybeMsg of
        Just msg ->
            let
                ( newModel, newCmd ) =
                    userUpdate msg model.userModel

                ( handlers, safeView ) =
                    extractListeners "" (view newModel)
            in
            ( { userModel = newModel, handlers = handlers, view = safeView }, render model.view safeView newCmd )

        Nothing ->
            ( model, Cmd.none )


program userProgram =
    Platform.program
        { init = init userProgram.init userProgram.view
        , update = update userProgram.update userProgram.view
        , subscriptions = subscriptions userProgram.subscriptions
        }

--- HTML types

type Node handler
    = Node String (List (NodeAttribute handler)) (List (Node handler))
    | Text String


type NodeAttribute handler
    = Attr String String
    | Property String Json.Value
    | Event String Options handler


type alias Options =
    { preventDefault : Bool
    , stopPropagation : Bool
    }


type alias Html msg =
    Node (Json.Decode.Decoder msg)


type alias Attribute msg =
    NodeAttribute (Json.Decode.Decoder msg)

type alias SafeHtml =
    Node String


type alias SafeAttribute =
    NodeAttribute String
    
--- Changes

type Change
    = Change Patch
    | At Int Change
    | Batch (List Change)


type Patch
    = Redraw SafeHtml
    | Facts (List ( Bool, SafeAttribute ))
    | TextChange String
    | Remove
    | Insert SafeHtml


--- Ports


port renderPort : Json.Value -> Cmd msg


port eventPort : (( String, Json.Value ) -> msg) -> Sub msg

--- Event handling

extractListeners : String -> Html msg -> ( Dict String (Decoder msg), SafeHtml )
extractListeners prefix html =
    case html of
        Node name attrs children ->
            let
                key =
                    prefix ++ "." ++ name

                safeAttrs =
                    List.map (makeAttrSafe key) attrs

                listeners =
                    List.filterMap getListener attrs

                kids =
                    List.indexedMap (\index -> extractListeners (key ++ "." ++ toString index)) children

                childListeners =
                    List.foldr (\( a, _ ) b -> Dict.union a b) Dict.empty kids
            in
            ( List.foldr (\( k, fn ) d -> Dict.insert (key ++ ":" ++ k) fn d) childListeners listeners
            , Node name safeAttrs (List.map Tuple.second kids)
            )

        Text s ->
            ( Dict.empty, Text s )


makeAttrSafe : String -> Attribute msg -> SafeAttribute
makeAttrSafe prefix attr =
    case attr of
        Event key options tagger ->
            Event key options (prefix ++ ":" ++ key)

        Attr k v ->
            Attr k v

        Property k v ->
            Property k v

getListener : Attribute msg -> Maybe ( String, Decoder msg )
getListener attr =
    case attr of
        Event key _ tagger ->
            Just ( key, tagger )

        _ ->
            Nothing

--- Diffing

wrapAt : Int -> List Change -> List Change
wrapAt i changes =
    case changes of
        [] ->
            []

        list ->
            [ At i (batchIfNecessary changes) ]


batchIfNecessary : List Change -> Change
batchIfNecessary changes =
    case changes of
        [] ->
            Batch []

        -- This should never happen
        x :: [] ->
            x

        list ->
            Batch list


diff : SafeHtml -> SafeHtml -> List Change
diff before after =
    if before == after then
        []
    else
        case ( before, after ) of
            ( Text bstr, Text astr ) ->
                [ Change (TextChange astr) ]

            ( Node bName bAttrs bChildren, Node aName aAttrs aChildren ) ->
                if aName == bName then
                    let
                        attrsDiff =
                            if aAttrs == bAttrs then
                                []
                            else
                                List.map2 diffAttrs bAttrs aAttrs |> List.concat |> Facts |> Change |> List.singleton

                        childrenDiff =
                            if bChildren == aChildren then
                                []
                            else
                                diffChildren 0 bChildren aChildren
                    in
                    [ batchIfNecessary (attrsDiff ++ childrenDiff) ]
                else
                    [ Change (Redraw after) ]

            _ ->
                [ Change (Redraw after) ]


diffAttrs : SafeAttribute -> SafeAttribute -> List ( Bool, SafeAttribute )
diffAttrs before after =
    if before == after then
        []
    else
        [ ( False, before ), ( True, after ) ]


diffChildren : List SafeHtml -> List SafeHtml -> List Change
diffChildren index before after =
    case ( before, after ) of
        ( [], [] ) ->
            []

        ( b :: efore, [] ) ->
            At index (Change Remove) :: diffChildren (index + 1) efore after

        ( [], a :: fter ) ->
            Change (Insert a) :: diffChildren (index + 1) before fter

        ( b :: efore, a :: fter ) ->
            case diff b a of
                [] ->
                    diffChildren (index + 1) efore fter

                diffs ->
                    At index (batchIfNecessary diffs) :: diffChildren (index + 1) efore fter

--- Rendering

initialRender : SafeHtml -> Cmd (Maybe msg)
initialRender =
    Insert >> Change >> encodeChange >> renderPort


render : SafeHtml -> SafeHtml -> Cmd msg -> Cmd (Maybe msg)
render before after cmd =
    case diff before after of
        [] ->
            Cmd.map Just cmd

        changes ->
            changes
                |> batchIfNecessary
                |> At 0
                |> encodeChange
                |> renderPort
                |> (\renderCmd -> Cmd.batch [ renderCmd, Cmd.map Just cmd ])


--- Encoders

encodeChange change =
    case change of
        Change patch ->
            Json.object
                [ ( "type", Json.string "change" )
                , ( "patch", encodePatch patch )
                ]

        At index change ->
            Json.object
                [ ( "type", Json.string "at" )
                , ( "index", Json.int index )
                , ( "change", encodeChange change )
                ]

        Batch changes ->
            Json.object
                [ ( "type", Json.string "batch" )
                , ( "changes", Json.list (List.map encodeChange changes) )
                ]


encodePatch patch =
    case patch of
        Redraw html ->
            Json.object
                [ ( "type", Json.string "redraw" )
                , ( "value", encodeHtml html )
                ]

        Insert html ->
            Json.object
                [ ( "type", Json.string "insert" )
                , ( "value", encodeHtml html )
                ]

        Facts facts ->
            Json.object
                [ ( "type", Json.string "facts" )
                , ( "value", Json.list (List.map encodeAttrDiff facts) )
                ]

        TextChange s ->
            Json.object
                [ ( "type", Json.string "text" )
                , ( "value", Json.string s )
                ]

        Remove ->
            Json.object
                [ ( "type", Json.string "remove" )
                ]


encodeHtml html =
    case html of
        Node name attrs children ->
            Json.object
                [ ( "type", Json.string "node" )
                , ( "name", Json.string name )
                , ( "attributes", Json.list (List.map encodeAttr attrs) )
                , ( "children", Json.list (List.map encodeHtml children) )
                ]

        Text str ->
            Json.object [ ( "type", Json.string "text" ), ( "value", Json.string str ) ]


encodeAttr attr =
    case attr of
        Attr key val ->
            Json.object [ ( "type", Json.string "attribute" ), ( "key", Json.string key ), ( "value", Json.string val ) ]

        Property key val ->
            Json.object [ ( "type", Json.string "property" ), ( "key", Json.string key ), ( "value", val ) ]

        Event key { preventDefault, stopPropagation } value ->
            Json.object
                [ ( "type", Json.string "event" )
                , ( "key", Json.string key )
                , ( "value", Json.string value )
                , ( "preventDefault", Json.bool preventDefault )
                , ( "stopPropagation", Json.bool stopPropagation )
                ]


encodeAttrDiff ( add, attr ) =
    case attr of
        Attr key val ->
            Json.object
                [ ( "type", Json.string "attribute" )
                , ( "key", Json.string key )
                , ( "value"
                  , if add then
                        Json.string val
                    else
                        Json.null
                  )
                ]

        Property key val ->
            Json.object
                [ ( "type", Json.string "property" )
                , ( "key", Json.string key )
                , ( "value"
                  , if add then
                        val
                    else
                        Json.null
                  )
                ]

        Event key { preventDefault, stopPropagation } value ->
            Json.object
                [ ( "type", Json.string "event" )
                , ( "key", Json.string key )
                , ( "value"
                  , if add then
                        Json.string value
                    else
                        Json.null
                  )
                , ( "preventDefault", Json.bool preventDefault )
                , ( "stopPropagation", Json.bool stopPropagation )
                ]



--- HTML library


defaultOptions : Options
defaultOptions =
    { preventDefault = False
    , stopPropagation = False
    }


onWithOptions : String -> Options -> Decoder msg -> Attribute msg
onWithOptions =
    Event


on : String -> Decoder msg -> Attribute msg
on event =
    Event event defaultOptions


div =
    Node "div"


a =
    Node "a"


href s =
    Property "href" (Json.string s)


onClick tagger =
    on "click" (Json.Decode.succeed tagger)


text =
    Text