Skip to content

Instantly share code, notes, and snippets.

@gampleman
Created Mar 8, 2018
Embed
What would you like to do?
VDOM in Pure Elm + Ports
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);
});
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 "."))
]
}
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment