Add finished/

This commit is contained in:
Richard Feldman
2018-05-01 21:49:22 -04:00
parent 975a010c1f
commit f17c09108d
575 changed files with 79140 additions and 0 deletions

View File

@@ -0,0 +1,3 @@
node_modules
elm-stuff
tests/build

View File

@@ -0,0 +1,8 @@
sudo: false
language: none
install:
- npm install --global elm@0.16.0
- npm install
script:
- ./tests/run-tests.sh

View File

@@ -0,0 +1,30 @@
Copyright (c) 2016-present, Evan Czaplicki
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Evan Czaplicki nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

View File

@@ -0,0 +1,5 @@
# Virtual DOM for Elm
A virtual DOM implementation that backs Elm's core libraries for [HTML](http://package.elm-lang.org/packages/elm-lang/html/latest/) and [SVG](http://package.elm-lang.org/packages/elm-lang/svg/latest/). You should almost certainly use those higher-level libraries directly.
It is pretty fast! You can read about that [here](http://elm-lang.org/blog/blazing-fast-html-round-two).

View File

@@ -0,0 +1,17 @@
{
"version": "2.0.4",
"summary": "Core virtual DOM implementation, basis for HTML and SVG libraries",
"repository": "https://github.com/elm-lang/virtual-dom.git",
"license": "BSD3",
"source-directories": [
"src"
],
"exposed-modules": [
"VirtualDom"
],
"native-modules": true,
"dependencies": {
"elm-lang/core": "5.0.0 <= v < 6.0.0"
},
"elm-version": "0.18.0 <= v < 0.19.0"
}

View File

@@ -0,0 +1,280 @@
var _elm_lang$virtual_dom$Native_Debug = function() {
// IMPORT / EXPORT
function unsafeCoerce(value)
{
return value;
}
var upload = _elm_lang$core$Native_Scheduler.nativeBinding(function(callback)
{
var element = document.createElement('input');
element.setAttribute('type', 'file');
element.setAttribute('accept', 'text/json');
element.style.display = 'none';
element.addEventListener('change', function(event)
{
var fileReader = new FileReader();
fileReader.onload = function(e)
{
callback(_elm_lang$core$Native_Scheduler.succeed(e.target.result));
};
fileReader.readAsText(event.target.files[0]);
document.body.removeChild(element);
});
document.body.appendChild(element);
element.click();
});
function download(historyLength, json)
{
return _elm_lang$core$Native_Scheduler.nativeBinding(function(callback)
{
var fileName = 'history-' + historyLength + '.txt';
var jsonString = JSON.stringify(json);
var mime = 'text/plain;charset=utf-8';
var done = _elm_lang$core$Native_Scheduler.succeed(_elm_lang$core$Native_Utils.Tuple0);
// for IE10+
if (navigator.msSaveBlob)
{
navigator.msSaveBlob(new Blob([jsonString], {type: mime}), fileName);
return callback(done);
}
// for HTML5
var element = document.createElement('a');
element.setAttribute('href', 'data:' + mime + ',' + encodeURIComponent(jsonString));
element.setAttribute('download', fileName);
element.style.display = 'none';
document.body.appendChild(element);
element.click();
document.body.removeChild(element);
callback(done);
});
}
// POPOUT
function messageToString(value)
{
switch (typeof value)
{
case 'boolean':
return value ? 'True' : 'False';
case 'number':
return value + '';
case 'string':
return '"' + addSlashes(value, false) + '"';
}
if (value instanceof String)
{
return '\'' + addSlashes(value, true) + '\'';
}
if (typeof value !== 'object' || value === null || !('ctor' in value))
{
return '…';
}
var ctorStarter = value.ctor.substring(0, 5);
if (ctorStarter === '_Tupl' || ctorStarter === '_Task')
{
return '…'
}
if (['_Array', '<decoder>', '_Process', '::', '[]', 'Set_elm_builtin', 'RBNode_elm_builtin', 'RBEmpty_elm_builtin'].indexOf(value.ctor) >= 0)
{
return '…';
}
var keys = Object.keys(value);
switch (keys.length)
{
case 1:
return value.ctor;
case 2:
return value.ctor + ' ' + messageToString(value._0);
default:
return value.ctor + ' … ' + messageToString(value[keys[keys.length - 1]]);
}
}
function primitive(str)
{
return { ctor: 'Primitive', _0: str };
}
function init(value)
{
var type = typeof value;
if (type === 'boolean')
{
return {
ctor: 'Constructor',
_0: _elm_lang$core$Maybe$Just(value ? 'True' : 'False'),
_1: true,
_2: _elm_lang$core$Native_List.Nil
};
}
if (type === 'number')
{
return primitive(value + '');
}
if (type === 'string')
{
return { ctor: 'S', _0: '"' + addSlashes(value, false) + '"' };
}
if (value instanceof String)
{
return { ctor: 'S', _0: "'" + addSlashes(value, true) + "'" };
}
if (value instanceof Date)
{
return primitive('<' + value.toString() + '>');
}
if (value === null)
{
return primitive('XXX');
}
if (type === 'object' && 'ctor' in value)
{
var ctor = value.ctor;
if (ctor === '::' || ctor === '[]')
{
return {
ctor: 'Sequence',
_0: {ctor: 'ListSeq'},
_1: true,
_2: A2(_elm_lang$core$List$map, init, value)
};
}
if (ctor === 'Set_elm_builtin')
{
return {
ctor: 'Sequence',
_0: {ctor: 'SetSeq'},
_1: true,
_2: A3(_elm_lang$core$Set$foldr, initCons, _elm_lang$core$Native_List.Nil, value)
};
}
if (ctor === 'RBNode_elm_builtin' || ctor == 'RBEmpty_elm_builtin')
{
return {
ctor: 'Dictionary',
_0: true,
_1: A3(_elm_lang$core$Dict$foldr, initKeyValueCons, _elm_lang$core$Native_List.Nil, value)
};
}
if (ctor === '_Array')
{
return {
ctor: 'Sequence',
_0: {ctor: 'ArraySeq'},
_1: true,
_2: A3(_elm_lang$core$Array$foldr, initCons, _elm_lang$core$Native_List.Nil, value)
};
}
var ctorStarter = value.ctor.substring(0, 5);
if (ctorStarter === '_Task')
{
return primitive('<task>');
}
if (ctor === '<decoder>')
{
return primitive(ctor);
}
if (ctor === '_Process')
{
return primitive('<process>');
}
var list = _elm_lang$core$Native_List.Nil;
for (var i in value)
{
if (i === 'ctor') continue;
list = _elm_lang$core$Native_List.Cons(init(value[i]), list);
}
return {
ctor: 'Constructor',
_0: ctorStarter === '_Tupl' ? _elm_lang$core$Maybe$Nothing : _elm_lang$core$Maybe$Just(ctor),
_1: true,
_2: _elm_lang$core$List$reverse(list)
};
}
if (type === 'object')
{
var dict = _elm_lang$core$Dict$empty;
for (var i in value)
{
dict = A3(_elm_lang$core$Dict$insert, i, init(value[i]), dict);
}
return { ctor: 'Record', _0: true, _1: dict };
}
return primitive('XXX');
}
var initCons = F2(initConsHelp);
function initConsHelp(value, list)
{
return _elm_lang$core$Native_List.Cons(init(value), list);
}
var initKeyValueCons = F3(initKeyValueConsHelp);
function initKeyValueConsHelp(key, value, list)
{
return _elm_lang$core$Native_List.Cons(
_elm_lang$core$Native_Utils.Tuple2(init(key), init(value)),
list
);
}
function addSlashes(str, isChar)
{
var s = str.replace(/\\/g, '\\\\')
.replace(/\n/g, '\\n')
.replace(/\t/g, '\\t')
.replace(/\r/g, '\\r')
.replace(/\v/g, '\\v')
.replace(/\0/g, '\\0');
if (isChar)
{
return s.replace(/\'/g, '\\\'');
}
else
{
return s.replace(/\"/g, '\\"');
}
}
return {
upload: upload,
download: F2(download),
unsafeCoerce: unsafeCoerce,
messageToString: messageToString,
init: init
}
}();

File diff suppressed because it is too large Load Diff

View File

@@ -0,0 +1,331 @@
module VirtualDom exposing
( Node
, text, node
, Property, property, attribute, attributeNS, mapProperty
, style
, on, onWithOptions, Options, defaultOptions
, map
, lazy, lazy2, lazy3
, keyedNode
, program, programWithFlags
)
{-| API to the core diffing algorithm. Can serve as a foundation for libraries
that expose more helper functions for HTML or SVG.
# Create
@docs Node, text, node
# Declare Properties and Attributes
@docs Property, property, attribute, attributeNS, mapProperty
# Styles
@docs style
# Events
@docs on, onWithOptions, Options, defaultOptions
# Routing Messages
@docs map
# Optimizations
@docs lazy, lazy2, lazy3, keyedNode
# Programs
@docs program, programWithFlags
-}
import Json.Decode as Json
import Native.VirtualDom
import VirtualDom.Debug as Debug
{-| An immutable chunk of data representing a DOM node. This can be HTML or SVG.
-}
type Node msg = Node
{-| Create a DOM node with a tag name, a list of HTML properties that can
include styles and event listeners, a list of CSS properties like `color`, and
a list of child nodes.
import Json.Encode as Json
hello : Node msg
hello =
node "div" [] [ text "Hello!" ]
greeting : Node msg
greeting =
node "div"
[ property "id" (Json.string "greeting") ]
[ text "Hello!" ]
-}
node : String -> List (Property msg) -> List (Node msg) -> Node msg
node =
Native.VirtualDom.node
{-| Just put plain text in the DOM. It will escape the string so that it appears
exactly as you specify.
text "Hello World!"
-}
text : String -> Node msg
text =
Native.VirtualDom.text
{-| This function is useful when nesting components with [the Elm
Architecture](https://github.com/evancz/elm-architecture-tutorial/). It lets
you transform the messages produced by a subtree.
Say you have a node named `button` that produces `()` values when it is
clicked. To get your model updating properly, you will probably want to tag
this `()` value like this:
type Msg = Click | ...
update msg model =
case msg of
Click ->
...
view model =
map (\_ -> Click) button
So now all the events produced by `button` will be transformed to be of type
`Msg` so they can be handled by your update function!
-}
map : (a -> msg) -> Node a -> Node msg
map =
Native.VirtualDom.map
-- PROPERTIES
{-| When using HTML and JS, there are two ways to specify parts of a DOM node.
1. Attributes &mdash; You can set things in HTML itself. So the `class`
in `<div class="greeting"></div>` is called an *attribute*.
2. Properties &mdash; You can also set things in JS. So the `className`
in `div.className = 'greeting'` is called a *property*.
So the `class` attribute corresponds to the `className` property. At first
glance, perhaps this distinction is defensible, but it gets much crazier.
*There is not always a one-to-one mapping between attributes and properties!*
Yes, that is a true fact. Sometimes an attribute exists, but there is no
corresponding property. Sometimes changing an attribute does not change the
underlying property. For example, as of this writing, the `webkit-playsinline`
attribute can be used in HTML, but there is no corresponding property!
-}
type Property msg = Property
{-| Create arbitrary *properties*.
import JavaScript.Encode as Json
greeting : Html
greeting =
node "div" [ property "className" (Json.string "greeting") ] [
text "Hello!"
]
Notice that you must give the *property* name, so we use `className` as it
would be in JavaScript, not `class` as it would appear in HTML.
-}
property : String -> Json.Value -> Property msg
property =
Native.VirtualDom.property
{-| Create arbitrary HTML *attributes*. Maps onto JavaScripts `setAttribute`
function under the hood.
greeting : Html
greeting =
node "div" [ attribute "class" "greeting" ] [
text "Hello!"
]
Notice that you must give the *attribute* name, so we use `class` as it would
be in HTML, not `className` as it would appear in JS.
-}
attribute : String -> String -> Property msg
attribute =
Native.VirtualDom.attribute
{-| Would you believe that there is another way to do this?! This corresponds
to JavaScript's `setAttributeNS` function under the hood. It is doing pretty
much the same thing as `attribute` but you are able to have "namespaced"
attributes. This is used in some SVG stuff at least.
-}
attributeNS : String -> String -> String -> Property msg
attributeNS =
Native.VirtualDom.attributeNS
{-| Transform the messages produced by a `Property`.
-}
mapProperty : (a -> b) -> Property a -> Property b
mapProperty =
Native.VirtualDom.mapProperty
{-| Specify a list of styles.
myStyle : Property msg
myStyle =
style
[ ("backgroundColor", "red")
, ("height", "90px")
, ("width", "100%")
]
greeting : Node msg
greeting =
node "div" [ myStyle ] [ text "Hello!" ]
-}
style : List (String, String) -> Property msg
style =
Native.VirtualDom.style
-- EVENTS
{-| Create a custom event listener.
import Json.Decode as Json
onClick : msg -> Property msg
onClick msg =
on "click" (Json.succeed msg)
You first specify the name of the event in the same format as with JavaScripts
`addEventListener`. Next you give a JSON decoder, which lets you pull
information out of the event object. If the decoder succeeds, it will produce
a message and route it to your `update` function.
-}
on : String -> Json.Decoder msg -> Property msg
on eventName decoder =
onWithOptions eventName defaultOptions decoder
{-| Same as `on` but you can set a few options.
-}
onWithOptions : String -> Options -> Json.Decoder msg -> Property msg
onWithOptions =
Native.VirtualDom.on
{-| Options for an event listener. If `stopPropagation` is true, it means the
event stops traveling through the DOM so it will not trigger any other event
listeners. If `preventDefault` is true, any built-in browser behavior related
to the event is prevented. For example, this is used with touch events when you
want to treat them as gestures of your own, not as scrolls.
-}
type alias Options =
{ stopPropagation : Bool
, preventDefault : Bool
}
{-| Everything is `False` by default.
defaultOptions =
{ stopPropagation = False
, preventDefault = False
}
-}
defaultOptions : Options
defaultOptions =
{ stopPropagation = False
, preventDefault = False
}
-- OPTIMIZATION
{-| A performance optimization that delays the building of virtual DOM nodes.
Calling `(view model)` will definitely build some virtual DOM, perhaps a lot of
it. Calling `(lazy view model)` delays the call until later. During diffing, we
can check to see if `model` is referentially equal to the previous value used,
and if so, we just stop. No need to build up the tree structure and diff it,
we know if the input to `view` is the same, the output must be the same!
-}
lazy : (a -> Node msg) -> a -> Node msg
lazy =
Native.VirtualDom.lazy
{-| Same as `lazy` but checks on two arguments.
-}
lazy2 : (a -> b -> Node msg) -> a -> b -> Node msg
lazy2 =
Native.VirtualDom.lazy2
{-| Same as `lazy` but checks on three arguments.
-}
lazy3 : (a -> b -> c -> Node msg) -> a -> b -> c -> Node msg
lazy3 =
Native.VirtualDom.lazy3
{-| Works just like `node`, but you add a unique identifier to each child
node. You want this when you have a list of nodes that is changing: adding
nodes, removing nodes, etc. In these cases, the unique identifiers help make
the DOM modifications more efficient.
-}
keyedNode : String -> List (Property msg) -> List ( String, Node msg ) -> Node msg
keyedNode =
Native.VirtualDom.keyedNode
-- PROGRAMS
{-| Check out the docs for [`Html.App.program`][prog].
It works exactly the same way.
[prog]: http://package.elm-lang.org/packages/elm-lang/html/latest/Html-App#program
-}
program
: { init : (model, Cmd msg)
, update : msg -> model -> (model, Cmd msg)
, subscriptions : model -> Sub msg
, view : model -> Node msg
}
-> Program Never model msg
program impl =
Native.VirtualDom.program Debug.wrap impl
{-| Check out the docs for [`Html.App.programWithFlags`][prog].
It works exactly the same way.
[prog]: http://package.elm-lang.org/packages/elm-lang/html/latest/Html-App#programWithFlags
-}
programWithFlags
: { init : flags -> (model, Cmd msg)
, update : msg -> model -> (model, Cmd msg)
, subscriptions : model -> Sub msg
, view : model -> Node msg
}
-> Program flags model msg
programWithFlags impl =
Native.VirtualDom.programWithFlags Debug.wrapWithFlags impl

View File

@@ -0,0 +1,567 @@
module VirtualDom.Debug exposing (wrap, wrapWithFlags)
import Json.Decode as Decode
import Json.Encode as Encode
import Task exposing (Task)
import Native.Debug
import Native.VirtualDom
import VirtualDom.Expando as Expando exposing (Expando)
import VirtualDom.Helpers as VDom exposing (Node)
import VirtualDom.History as History exposing (History)
import VirtualDom.Metadata as Metadata exposing (Metadata)
import VirtualDom.Overlay as Overlay
import VirtualDom.Report as Report
-- WRAP PROGRAMS
wrap metadata { init, update, subscriptions, view } =
{ init = wrapInit metadata init
, view = wrapView view
, update = wrapUpdate update
, viewIn = viewIn
, viewOut = viewOut
, subscriptions = wrapSubs subscriptions
}
wrapWithFlags metadata { init, update, subscriptions, view } =
{ init = \flags -> wrapInit metadata (init flags)
, view = wrapView view
, update = wrapUpdate update
, viewIn = viewIn
, viewOut = viewOut
, subscriptions = wrapSubs subscriptions
}
-- MODEL
type alias Model model msg =
{ history : History model msg
, state : State model
, expando : Expando
, metadata : Result Metadata.Error Metadata
, overlay : Overlay.State
, isDebuggerOpen : Bool
}
type State model
= Running model
| Paused Int model model
wrapInit : Encode.Value -> ( model, Cmd msg ) -> ( Model model msg, Cmd (Msg msg) )
wrapInit metadata ( userModel, userCommands ) =
{ history = History.empty userModel
, state = Running userModel
, expando = Expando.init userModel
, metadata = Metadata.decode metadata
, overlay = Overlay.none
, isDebuggerOpen = False
}
! [ Cmd.map UserMsg userCommands ]
-- UPDATE
type Msg msg
= NoOp
| UserMsg msg
| ExpandoMsg Expando.Msg
| Resume
| Jump Int
| Open
| Close
| Up
| Down
| Import
| Export
| Upload String
| OverlayMsg Overlay.Msg
type alias UserUpdate model msg =
msg -> model -> ( model, Cmd msg )
wrapUpdate
: UserUpdate model msg
-> Task Never ()
-> Msg msg
-> Model model msg
-> (Model model msg, Cmd (Msg msg))
wrapUpdate userUpdate scrollTask msg model =
case msg of
NoOp ->
model ! []
UserMsg userMsg ->
updateUserMsg userUpdate scrollTask userMsg model
ExpandoMsg eMsg ->
{ model
| expando = Expando.update eMsg model.expando
}
! []
Resume ->
case model.state of
Running _ ->
model ! []
Paused _ _ userModel ->
{ model
| state = Running userModel
, expando = Expando.merge userModel model.expando
}
! [ runIf model.isDebuggerOpen scrollTask ]
Jump index ->
let
(indexModel, indexMsg) =
History.get userUpdate index model.history
in
{ model
| state = Paused index indexModel (getLatestModel model.state)
, expando = Expando.merge indexModel model.expando
}
! []
Open ->
{ model | isDebuggerOpen = True } ! []
Close ->
{ model | isDebuggerOpen = False } ! []
Up ->
let
index =
case model.state of
Paused index _ _ ->
index
Running _ ->
History.size model.history
in
if index > 0 then
wrapUpdate userUpdate scrollTask (Jump (index - 1)) model
else
model ! []
Down ->
case model.state of
Running _ ->
model ! []
Paused index _ userModel ->
if index == History.size model.history - 1 then
wrapUpdate userUpdate scrollTask Resume model
else
wrapUpdate userUpdate scrollTask (Jump (index + 1)) model
Import ->
withGoodMetadata model <| \_ ->
model ! [ upload ]
Export ->
withGoodMetadata model <| \metadata ->
model ! [ download metadata model.history ]
Upload jsonString ->
withGoodMetadata model <| \metadata ->
case Overlay.assessImport metadata jsonString of
Err newOverlay ->
{ model | overlay = newOverlay } ! []
Ok rawHistory ->
loadNewHistory rawHistory userUpdate model
OverlayMsg overlayMsg ->
case Overlay.close overlayMsg model.overlay of
Nothing ->
{ model | overlay = Overlay.none } ! []
Just rawHistory ->
loadNewHistory rawHistory userUpdate model
-- COMMANDS
upload : Cmd (Msg msg)
upload =
Task.perform Upload Native.Debug.upload
download : Metadata -> History model msg -> Cmd (Msg msg)
download metadata history =
let
historyLength =
History.size history
json =
Encode.object
[ ("metadata", Metadata.encode metadata)
, ("history", History.encode history)
]
in
Task.perform (\_ -> NoOp) (Native.Debug.download historyLength json)
-- UPDATE OVERLAY
withGoodMetadata
: Model model msg
-> (Metadata -> (Model model msg, Cmd (Msg msg)))
-> (Model model msg, Cmd (Msg msg))
withGoodMetadata model func =
case model.metadata of
Ok metadata ->
func metadata
Err error ->
{ model | overlay = Overlay.badMetadata error } ! []
loadNewHistory
: Encode.Value
-> UserUpdate model msg
-> Model model msg
-> ( Model model msg, Cmd (Msg msg) )
loadNewHistory rawHistory userUpdate model =
let
initialUserModel =
History.initialModel model.history
pureUserUpdate msg userModel =
Tuple.first (userUpdate msg userModel)
decoder =
History.decoder initialUserModel pureUserUpdate
in
case Decode.decodeValue decoder rawHistory of
Err _ ->
{ model | overlay = Overlay.corruptImport } ! []
Ok (latestUserModel, newHistory) ->
{ model
| history = newHistory
, state = Running latestUserModel
, expando = Expando.init latestUserModel
, overlay = Overlay.none
}
! []
-- UPDATE - USER MESSAGES
updateUserMsg
: UserUpdate model msg
-> Task Never ()
-> msg
-> Model model msg
-> (Model model msg, Cmd (Msg msg))
updateUserMsg userUpdate scrollTask userMsg ({ history, state, expando } as model) =
let
userModel =
getLatestModel state
newHistory =
History.add userMsg userModel history
(newUserModel, userCmds) =
userUpdate userMsg userModel
commands =
Cmd.map UserMsg userCmds
in
case state of
Running _ ->
{ model
| history = newHistory
, state = Running newUserModel
, expando = Expando.merge newUserModel expando
}
! [ commands, runIf model.isDebuggerOpen scrollTask ]
Paused index indexModel _ ->
{ model
| history = newHistory
, state = Paused index indexModel newUserModel
}
! [ commands ]
runIf : Bool -> Task Never () -> Cmd (Msg msg)
runIf bool task =
if bool then
Task.perform (always NoOp) task
else
Cmd.none
getLatestModel : State model -> model
getLatestModel state =
case state of
Running model ->
model
Paused _ _ model ->
model
-- SUBSCRIPTIONS
wrapSubs : (model -> Sub msg) -> Model model msg -> Sub (Msg msg)
wrapSubs userSubscriptions {state} =
getLatestModel state
|> userSubscriptions
|> Sub.map UserMsg
-- VIEW
wrapView : (model -> Node msg) -> Model model msg -> Node (Msg msg)
wrapView userView { state } =
let
currentModel =
case state of
Running model ->
model
Paused _ oldModel _ ->
oldModel
in
VDom.map UserMsg (userView currentModel)
-- SMALL DEBUG VIEW
viewIn : Model model msg -> ( Overlay.Block, Node (Msg msg) )
viewIn { history, state, overlay, isDebuggerOpen } =
let
isPaused =
case state of
Running _ ->
False
Paused _ _ _ ->
True
in
Overlay.view overlayConfig isPaused isDebuggerOpen (History.size history) overlay
overlayConfig : Overlay.Config (Msg msg)
overlayConfig =
{ resume = Resume
, open = Open
, importHistory = Import
, exportHistory = Export
, wrap = OverlayMsg
}
-- BIG DEBUG VIEW
viewOut : Model model msg -> Node (Msg msg)
viewOut { history, state, expando } =
VDom.div
[ VDom.id "debugger" ]
[ styles
, viewSidebar state history
, VDom.map ExpandoMsg <|
VDom.div [ VDom.id "values" ] [ Expando.view Nothing expando ]
]
viewSidebar : State model -> History model msg -> Node (Msg msg)
viewSidebar state history =
let
maybeIndex =
case state of
Running _ ->
Nothing
Paused index _ _ ->
Just index
in
VDom.div [ VDom.class "debugger-sidebar" ]
[ VDom.map Jump (History.view maybeIndex history)
, playButton maybeIndex
]
playButton : Maybe Int -> Node (Msg msg)
playButton maybeIndex =
VDom.div [ VDom.class "debugger-sidebar-controls" ]
[ viewResumeButton maybeIndex
, VDom.div [ VDom.class "debugger-sidebar-controls-import-export" ]
[ button Import "Import"
, VDom.text " / "
, button Export "Export"
]
]
button msg label =
VDom.span
[ VDom.onClick msg
, VDom.style [("cursor","pointer")]
]
[ VDom.text label ]
viewResumeButton maybeIndex =
case maybeIndex of
Nothing ->
VDom.text ""
Just _ ->
resumeButton
resumeButton =
VDom.div
[ VDom.onClick Resume
, VDom.class "debugger-sidebar-controls-resume"
]
[ VDom.text "Resume"
]
-- STYLE
styles : Node msg
styles =
VDom.node "style" [] [ VDom.text """
html {
overflow: hidden;
height: 100%;
}
body {
height: 100%;
overflow: auto;
}
#debugger {
width: 100%
height: 100%;
font-family: monospace;
}
#values {
display: block;
float: left;
height: 100%;
width: calc(100% - 30ch);
margin: 0;
overflow: auto;
cursor: default;
}
.debugger-sidebar {
display: block;
float: left;
width: 30ch;
height: 100%;
color: white;
background-color: rgb(61, 61, 61);
}
.debugger-sidebar-controls {
width: 100%;
text-align: center;
background-color: rgb(50, 50, 50);
}
.debugger-sidebar-controls-import-export {
width: 100%;
height: 24px;
line-height: 24px;
font-size: 12px;
}
.debugger-sidebar-controls-resume {
width: 100%;
height: 30px;
line-height: 30px;
cursor: pointer;
}
.debugger-sidebar-controls-resume:hover {
background-color: rgb(41, 41, 41);
}
.debugger-sidebar-messages {
width: 100%;
overflow-y: auto;
height: calc(100% - 24px);
}
.debugger-sidebar-messages-paused {
width: 100%;
overflow-y: auto;
height: calc(100% - 54px);
}
.messages-entry {
cursor: pointer;
width: 100%;
}
.messages-entry:hover {
background-color: rgb(41, 41, 41);
}
.messages-entry-selected, .messages-entry-selected:hover {
background-color: rgb(10, 10, 10);
}
.messages-entry-content {
width: calc(100% - 7ch);
padding-top: 4px;
padding-bottom: 4px;
padding-left: 1ch;
text-overflow: ellipsis;
white-space: nowrap;
overflow: hidden;
display: inline-block;
}
.messages-entry-index {
color: #666;
width: 5ch;
padding-top: 4px;
padding-bottom: 4px;
padding-right: 1ch;
text-align: right;
display: block;
float: right;
}
""" ]

View File

@@ -0,0 +1,659 @@
module VirtualDom.Expando exposing
( Expando
, init
, merge
, Msg, update
, view
)
import Dict exposing (Dict)
import Json.Decode as Json
import Native.Debug
import VirtualDom.Helpers as VDom exposing (Node, text, div, span, class, onClick)
-- MODEL
type Expando
= S String
| Primitive String
| Sequence SeqType Bool (List Expando)
| Dictionary Bool (List (Expando, Expando))
| Record Bool (Dict String Expando)
| Constructor (Maybe String) Bool (List Expando)
type SeqType = ListSeq | SetSeq | ArraySeq
seqTypeToString : Int -> SeqType -> String
seqTypeToString n seqType =
case seqType of
ListSeq ->
"List(" ++ toString n ++ ")"
SetSeq ->
"Set(" ++ toString n ++ ")"
ArraySeq ->
"Array(" ++ toString n ++ ")"
-- INITIALIZE
init : a -> Expando
init value =
initHelp True (Native.Debug.init value)
initHelp : Bool -> Expando -> Expando
initHelp isOuter expando =
case expando of
S _ ->
expando
Primitive _ ->
expando
Sequence seqType isClosed items ->
if isOuter then
Sequence seqType False (List.map (initHelp False) items)
else if List.length items <= 8 then
Sequence seqType False items
else
expando
Dictionary isClosed keyValuePairs ->
if isOuter then
Dictionary False (List.map (\(k,v) -> (k, initHelp False v)) keyValuePairs)
else if List.length keyValuePairs <= 8 then
Dictionary False keyValuePairs
else
expando
Record isClosed entries ->
if isOuter then
Record False (Dict.map (\_ v -> initHelp False v) entries)
else if Dict.size entries <= 4 then
Record False entries
else
expando
Constructor maybeName isClosed args ->
if isOuter then
Constructor maybeName False (List.map (initHelp False) args)
else if List.length args <= 4 then
Constructor maybeName False args
else
expando
-- PRESERVE OLD EXPANDO STATE (open/closed)
merge : a -> Expando -> Expando
merge value expando =
mergeHelp expando (Native.Debug.init value)
mergeHelp : Expando -> Expando -> Expando
mergeHelp old new =
case ( old, new ) of
( _, S _ ) ->
new
( _, Primitive _ ) ->
new
( Sequence _ isClosed oldValues, Sequence seqType _ newValues ) ->
Sequence seqType isClosed (mergeListHelp oldValues newValues)
( Dictionary isClosed _, Dictionary _ keyValuePairs ) ->
Dictionary isClosed keyValuePairs
( Record isClosed oldDict, Record _ newDict ) ->
Record isClosed <| Dict.map (mergeDictHelp oldDict) newDict
( Constructor _ isClosed oldValues, Constructor maybeName _ newValues ) ->
Constructor maybeName isClosed (mergeListHelp oldValues newValues)
_ ->
new
mergeListHelp : List Expando -> List Expando -> List Expando
mergeListHelp olds news =
case (olds, news) of
( [], _ ) ->
news
( _, [] ) ->
news
( x :: xs, y :: ys ) ->
mergeHelp x y :: mergeListHelp xs ys
mergeDictHelp : Dict String Expando -> String -> Expando -> Expando
mergeDictHelp oldDict key value =
case Dict.get key oldDict of
Nothing ->
value
Just oldValue ->
mergeHelp oldValue value
-- UPDATE
type Msg
= Toggle
| Index Redirect Int Msg
| Field String Msg
type Redirect = None | Key | Value
update : Msg -> Expando -> Expando
update msg value =
case value of
S _ ->
Debug.crash "No messages for primitives"
Primitive _ ->
Debug.crash "No messages for primitives"
Sequence seqType isClosed valueList ->
case msg of
Toggle ->
Sequence seqType (not isClosed) valueList
Index None index subMsg ->
Sequence seqType isClosed <|
updateIndex index (update subMsg) valueList
Index _ _ _ ->
Debug.crash "No redirected indexes on sequences"
Field _ _ ->
Debug.crash "No field on sequences"
Dictionary isClosed keyValuePairs ->
case msg of
Toggle ->
Dictionary (not isClosed) keyValuePairs
Index redirect index subMsg ->
case redirect of
None ->
Debug.crash "must have redirect for dictionaries"
Key ->
Dictionary isClosed <|
updateIndex index (\(k,v) -> (update subMsg k, v)) keyValuePairs
Value ->
Dictionary isClosed <|
updateIndex index (\(k,v) -> (k, update subMsg v)) keyValuePairs
Field _ _ ->
Debug.crash "no field for dictionaries"
Record isClosed valueDict ->
case msg of
Toggle ->
Record (not isClosed) valueDict
Index _ _ _ ->
Debug.crash "No index for records"
Field field subMsg ->
Record isClosed (Dict.update field (updateField subMsg) valueDict)
Constructor maybeName isClosed valueList ->
case msg of
Toggle ->
Constructor maybeName (not isClosed) valueList
Index None index subMsg ->
Constructor maybeName isClosed <|
updateIndex index (update subMsg) valueList
Index _ _ _ ->
Debug.crash "No redirected indexes on sequences"
Field _ _ ->
Debug.crash "No field for constructors"
updateIndex : Int -> (a -> a) -> List a -> List a
updateIndex n func list =
case list of
[] ->
[]
x :: xs ->
if n <= 0 then
func x :: xs
else
x :: updateIndex (n-1) func xs
updateField : Msg -> Maybe Expando -> Maybe Expando
updateField msg maybeExpando =
case maybeExpando of
Nothing ->
Debug.crash "key does not exist"
Just expando ->
Just (update msg expando)
-- VIEW
view : Maybe String -> Expando -> Node Msg
view maybeKey expando =
case expando of
S stringRep ->
div [ leftPad maybeKey ] (lineStarter maybeKey Nothing [span [red] [text stringRep]])
Primitive stringRep ->
div [ leftPad maybeKey ] (lineStarter maybeKey Nothing [span [blue] [text stringRep]])
Sequence seqType isClosed valueList ->
viewSequence maybeKey seqType isClosed valueList
Dictionary isClosed keyValuePairs ->
viewDictionary maybeKey isClosed keyValuePairs
Record isClosed valueDict ->
viewRecord maybeKey isClosed valueDict
Constructor maybeName isClosed valueList ->
viewConstructor maybeKey maybeName isClosed valueList
-- VIEW SEQUENCE
viewSequence : Maybe String -> SeqType -> Bool -> List Expando -> Node Msg
viewSequence maybeKey seqType isClosed valueList =
let
starter =
seqTypeToString (List.length valueList) seqType
in
div [ leftPad maybeKey ]
[ div [ onClick Toggle ] (lineStarter maybeKey (Just isClosed) [text starter])
, if isClosed then text "" else viewSequenceOpen valueList
]
viewSequenceOpen : List Expando -> Node Msg
viewSequenceOpen values =
div [] (List.indexedMap viewConstructorEntry values)
-- VIEW DICTIONARY
viewDictionary : Maybe String -> Bool -> List (Expando, Expando) -> Node Msg
viewDictionary maybeKey isClosed keyValuePairs =
let
starter =
"Dict(" ++ toString (List.length keyValuePairs) ++ ")"
in
div [ leftPad maybeKey ]
[ div [ onClick Toggle ] (lineStarter maybeKey (Just isClosed) [text starter])
, if isClosed then text "" else viewDictionaryOpen keyValuePairs
]
viewDictionaryOpen : List (Expando, Expando) -> Node Msg
viewDictionaryOpen keyValuePairs =
div [] (List.indexedMap viewDictionaryEntry keyValuePairs)
viewDictionaryEntry : Int -> (Expando, Expando) -> Node Msg
viewDictionaryEntry index (key, value) =
case key of
S stringRep ->
VDom.map (Index Value index) (view (Just stringRep) value)
Primitive stringRep ->
VDom.map (Index Value index) (view (Just stringRep) value)
_ ->
div []
[ VDom.map (Index Key index) (view (Just "key") key)
, VDom.map (Index Value index) (view (Just "value") value)
]
-- VIEW RECORD
viewRecord : Maybe String -> Bool -> Dict String Expando -> Node Msg
viewRecord maybeKey isClosed record =
let
(start, middle, end) =
if isClosed then
( Tuple.second (viewTinyRecord record), text "", text "" )
else
( [ text "{" ], viewRecordOpen record, div [leftPad (Just ())] [text "}"] )
in
div [ leftPad maybeKey ]
[ div [ onClick Toggle ] (lineStarter maybeKey (Just isClosed) start)
, middle
, end
]
viewRecordOpen : Dict String Expando -> Node Msg
viewRecordOpen record =
div [] (List.map viewRecordEntry (Dict.toList record))
viewRecordEntry : (String, Expando) -> Node Msg
viewRecordEntry (field, value) =
VDom.map (Field field) (view (Just field) value)
-- VIEW CONSTRUCTOR
viewConstructor : Maybe String -> Maybe String -> Bool -> List Expando -> Node Msg
viewConstructor maybeKey maybeName isClosed valueList =
let
tinyArgs =
List.map (Tuple.second << viewExtraTiny) valueList
description =
case (maybeName, tinyArgs) of
(Nothing, []) ->
[ text "()" ]
(Nothing, x :: xs) ->
text "( "
:: span [] x
:: List.foldr (\args rest -> text ", " :: span [] args :: rest) [text " )"] xs
(Just name, []) ->
[ text name ]
(Just name, x :: xs) ->
text (name ++ " ")
:: span [] x
:: List.foldr (\args rest -> text " " :: span [] args :: rest) [] xs
(maybeIsClosed, openHtml) =
case valueList of
[] ->
( Nothing, div [] [] )
[entry] ->
case entry of
S _ ->
( Nothing, div [] [] )
Primitive _ ->
( Nothing, div [] [] )
Sequence _ _ subValueList ->
( Just isClosed
, if isClosed then div [] [] else VDom.map (Index None 0) (viewSequenceOpen subValueList)
)
Dictionary _ keyValuePairs ->
( Just isClosed
, if isClosed then div [] [] else VDom.map (Index None 0) (viewDictionaryOpen keyValuePairs)
)
Record _ record ->
( Just isClosed
, if isClosed then div [] [] else VDom.map (Index None 0) (viewRecordOpen record)
)
Constructor _ _ subValueList ->
( Just isClosed
, if isClosed then div [] [] else VDom.map (Index None 0) (viewConstructorOpen subValueList)
)
_ ->
( Just isClosed
, if isClosed then div [] [] else viewConstructorOpen valueList
)
in
div [ leftPad maybeKey ]
[ div [ onClick Toggle ] (lineStarter maybeKey maybeIsClosed description)
, openHtml
]
viewConstructorOpen : List Expando -> Node Msg
viewConstructorOpen valueList =
div [] (List.indexedMap viewConstructorEntry valueList)
viewConstructorEntry : Int -> Expando -> Node Msg
viewConstructorEntry index value =
VDom.map (Index None index) (view (Just (toString index)) value)
-- VIEW TINY
viewTiny : Expando -> ( Int, List (Node msg) )
viewTiny value =
case value of
S stringRep ->
let
str =
elideMiddle stringRep
in
( String.length str
, [ span [red] [text str] ]
)
Primitive stringRep ->
( String.length stringRep
, [ span [blue] [text stringRep] ]
)
Sequence seqType _ valueList ->
viewTinyHelp <|
seqTypeToString (List.length valueList) seqType
Dictionary _ keyValuePairs ->
viewTinyHelp <|
"Dict(" ++ toString (List.length keyValuePairs) ++ ")"
Record _ record ->
viewTinyRecord record
Constructor maybeName _ [] ->
viewTinyHelp <|
Maybe.withDefault "Unit" maybeName
Constructor maybeName _ valueList ->
viewTinyHelp <|
case maybeName of
Nothing ->
"Tuple(" ++ toString (List.length valueList) ++ ")"
Just name ->
name ++ " "
viewTinyHelp : String -> ( Int, List (Node msg) )
viewTinyHelp str =
( String.length str, [text str] )
elideMiddle : String -> String
elideMiddle str =
if String.length str <= 18 then
str
else
String.left 8 str ++ "..." ++ String.right 8 str
-- VIEW TINY RECORDS
viewTinyRecord : Dict String Expando -> ( Int, List (Node msg) )
viewTinyRecord record =
if Dict.isEmpty record then
( 2, [text "{}"] )
else
viewTinyRecordHelp 0 "{ " (Dict.toList record)
viewTinyRecordHelp : Int -> String -> List (String, Expando) -> ( Int, List (Node msg) )
viewTinyRecordHelp length starter entries =
case entries of
[] ->
( length + 2, [ text " }" ] )
(field, value) :: rest ->
let
fieldLen =
String.length field
(valueLen, valueNodes) =
viewExtraTiny value
newLength =
length + fieldLen + valueLen + 5
in
if newLength > 60 then
( length + 4, [text ", }"] )
else
let
( finalLength, otherNodes ) =
viewTinyRecordHelp newLength ", " rest
in
( finalLength
, text starter
:: span [purple] [text field]
:: text " = "
:: span [] valueNodes
:: otherNodes
)
viewExtraTiny : Expando -> ( Int, List (Node msg) )
viewExtraTiny value =
case value of
Record _ record ->
viewExtraTinyRecord 0 "{" (Dict.keys record)
_ ->
viewTiny value
viewExtraTinyRecord : Int -> String -> List String -> ( Int, List (Node msg) )
viewExtraTinyRecord length starter entries =
case entries of
[] ->
( length + 1, [text "}"] )
field :: rest ->
let
nextLength =
length + String.length field + 1
in
if nextLength > 18 then
( length + 2, [text "}"])
else
let
(finalLength, otherNodes) =
viewExtraTinyRecord nextLength "," rest
in
( finalLength
, text starter :: span [purple] [text field] :: otherNodes
)
-- VIEW HELPERS
lineStarter : Maybe String -> Maybe Bool -> List (Node msg) -> List (Node msg)
lineStarter maybeKey maybeIsClosed description =
let
arrow =
case maybeIsClosed of
Nothing ->
makeArrow ""
Just True ->
makeArrow ""
Just False ->
makeArrow ""
in
case maybeKey of
Nothing ->
arrow :: description
Just key ->
arrow :: span [purple] [text key] :: text " = " :: description
makeArrow : String -> Node msg
makeArrow arrow =
span
[ VDom.style
[ ("color", "#777")
, ("padding-left", "2ch")
, ("width", "2ch")
, ("display", "inline-block")
]
]
[ text arrow ]
leftPad : Maybe a -> VDom.Property msg
leftPad maybeKey =
case maybeKey of
Nothing ->
VDom.style []
Just _ ->
VDom.style [("padding-left", "4ch")]
red : VDom.Property msg
red =
VDom.style [("color", "rgb(196, 26, 22)")]
blue : VDom.Property msg
blue =
VDom.style [("color", "rgb(28, 0, 207)")]
purple : VDom.Property msg
purple =
VDom.style [("color", "rgb(136, 19, 145)")]

View File

@@ -0,0 +1,137 @@
module VirtualDom.Helpers exposing
( Node
, text, node, div, span, a, h1
, Property, property, attribute
, class, id, href
, style
, on, onWithOptions, Options, defaultOptions
, onClick
, map
, lazy, lazy2, lazy3
, keyedNode
)
import Json.Decode as Decode
import Json.Encode as Encode
import Native.VirtualDom
type Node msg = Node
node : String -> List (Property msg) -> List (Node msg) -> Node msg
node =
Native.VirtualDom.node
text : String -> Node msg
text =
Native.VirtualDom.text
div : List (Property msg) -> List (Node msg) -> Node msg
div =
node "div"
span : List (Property msg) -> List (Node msg) -> Node msg
span =
node "span"
a : List (Property msg) -> List (Node msg) -> Node msg
a =
node "a"
h1 : List (Property msg) -> List (Node msg) -> Node msg
h1 =
node "h1"
map : (a -> msg) -> Node a -> Node msg
map =
Native.VirtualDom.map
type Property msg = Property
property : String -> Decode.Value -> Property msg
property =
Native.VirtualDom.property
attribute : String -> String -> Property msg
attribute =
Native.VirtualDom.attribute
class : String -> Property msg
class name =
property "className" (Encode.string name)
href : String -> Property msg
href name =
property "href" (Encode.string name)
id : String -> Property msg
id =
attribute "id"
style : List (String, String) -> Property msg
style =
Native.VirtualDom.style
on : String -> Decode.Decoder msg -> Property msg
on eventName decoder =
onWithOptions eventName defaultOptions decoder
onClick : msg -> Property msg
onClick msg =
on "click" (Decode.succeed msg)
onWithOptions : String -> Options -> Decode.Decoder msg -> Property msg
onWithOptions =
Native.VirtualDom.on
type alias Options =
{ stopPropagation : Bool
, preventDefault : Bool
}
defaultOptions : Options
defaultOptions =
{ stopPropagation = False
, preventDefault = False
}
lazy : (a -> Node msg) -> a -> Node msg
lazy =
Native.VirtualDom.lazy
lazy2 : (a -> b -> Node msg) -> a -> b -> Node msg
lazy2 =
Native.VirtualDom.lazy2
lazy3 : (a -> b -> c -> Node msg) -> a -> b -> c -> Node msg
lazy3 =
Native.VirtualDom.lazy3
keyedNode : String -> List (Property msg) -> List ( String, Node msg ) -> Node msg
keyedNode =
Native.VirtualDom.keyedNode

View File

@@ -0,0 +1,290 @@
module VirtualDom.History exposing
( History
, empty
, size
, initialModel
, add
, get
, view
, decoder
, encode
)
import Array exposing (Array)
import Json.Decode as Decode
import Json.Encode as Encode
import Native.Debug
import VirtualDom.Helpers as VDom exposing (Node)
import VirtualDom.Metadata as Metadata
-- CONSTANTS
maxSnapshotSize : Int
maxSnapshotSize =
64
-- HISTORY
type alias History model msg =
{ snapshots : Array (Snapshot model msg)
, recent : RecentHistory model msg
, numMessages : Int
}
type alias RecentHistory model msg =
{ model : model
, messages : List msg
, numMessages : Int
}
type alias Snapshot model msg =
{ model : model
, messages : Array msg
}
empty : model -> History model msg
empty model =
History Array.empty (RecentHistory model [] 0) 0
size : History model msg -> Int
size history =
history.numMessages
initialModel : History model msg -> model
initialModel { snapshots, recent } =
case Array.get 0 snapshots of
Just { model } ->
model
Nothing ->
recent.model
-- JSON
decoder : model -> (msg -> model -> model) -> Decode.Decoder (model, History model msg)
decoder initialModel update =
let
addMessage rawMsg (model, history) =
let
msg =
jsToElm rawMsg
in
(update msg model, add msg model history)
updateModel rawMsgs =
List.foldl addMessage (initialModel, empty initialModel) rawMsgs
in
Decode.map updateModel (Decode.list Decode.value)
jsToElm : Encode.Value -> a
jsToElm =
Native.Debug.unsafeCoerce
encode : History model msg -> Encode.Value
encode { snapshots, recent } =
let
recentJson =
List.map elmToJs (List.reverse recent.messages)
in
Encode.list <| Array.foldr encodeHelp recentJson snapshots
encodeHelp : Snapshot model msg -> List Encode.Value -> List Encode.Value
encodeHelp snapshot allMessages =
Array.foldl (\elm msgs -> elmToJs elm :: msgs) allMessages snapshot.messages
elmToJs : a -> Encode.Value
elmToJs =
Native.Debug.unsafeCoerce
-- ADD MESSAGES
add : msg -> model -> History model msg -> History model msg
add msg model { snapshots, recent, numMessages } =
case addRecent msg model recent of
(Just snapshot, newRecent) ->
History (Array.push snapshot snapshots) newRecent (numMessages + 1)
(Nothing, newRecent) ->
History snapshots newRecent (numMessages + 1)
addRecent
: msg
-> model
-> RecentHistory model msg
-> ( Maybe (Snapshot model msg), RecentHistory model msg )
addRecent msg newModel { model, messages, numMessages } =
if numMessages == maxSnapshotSize then
( Just (Snapshot model (Array.fromList messages))
, RecentHistory newModel [msg] 1
)
else
( Nothing
, RecentHistory model (msg :: messages) (numMessages + 1)
)
-- GET SUMMARY
get : (msg -> model -> (model, a)) -> Int -> History model msg -> ( model, msg )
get update index { snapshots, recent, numMessages } =
let
snapshotMax =
numMessages - recent.numMessages
in
if index >= snapshotMax then
undone <|
List.foldr (getHelp update) (Stepping (index - snapshotMax) recent.model) recent.messages
else
case Array.get (index // maxSnapshotSize) snapshots of
Nothing ->
Debug.crash "UI should only let you ask for real indexes!"
Just { model, messages } ->
undone <|
Array.foldr (getHelp update) (Stepping (rem index maxSnapshotSize) model) messages
type GetResult model msg
= Stepping Int model
| Done msg model
getHelp : (msg -> model -> (model, a)) -> msg -> GetResult model msg -> GetResult model msg
getHelp update msg getResult =
case getResult of
Done _ _ ->
getResult
Stepping n model ->
if n == 0 then
Done msg (Tuple.first (update msg model))
else
Stepping (n - 1) (Tuple.first (update msg model))
undone : GetResult model msg -> ( model, msg )
undone getResult =
case getResult of
Done msg model ->
( model, msg )
Stepping _ _ ->
Debug.crash "Bug in History.get"
-- VIEW
view : Maybe Int -> History model msg -> Node Int
view maybeIndex { snapshots, recent, numMessages } =
let
(index, className) =
case maybeIndex of
Nothing ->
( -1, "debugger-sidebar-messages" )
Just i ->
( i, "debugger-sidebar-messages-paused" )
oldStuff =
VDom.lazy2 viewSnapshots index snapshots
newStuff =
Tuple.second <| List.foldl (consMsg index) (numMessages - 1, []) recent.messages
in
VDom.div [ VDom.class className ] (oldStuff :: newStuff)
-- VIEW SNAPSHOTS
viewSnapshots : Int -> Array (Snapshot model msg) -> Node Int
viewSnapshots currentIndex snapshots =
let
highIndex =
maxSnapshotSize * Array.length snapshots
in
VDom.div [] <| Tuple.second <|
Array.foldr (consSnapshot currentIndex) (highIndex, []) snapshots
consSnapshot : Int -> Snapshot model msg -> ( Int, List (Node Int) ) -> ( Int, List (Node Int) )
consSnapshot currentIndex snapshot (index, rest) =
let
nextIndex =
index - maxSnapshotSize
currentIndexHelp =
if nextIndex <= currentIndex && currentIndex < index then currentIndex else -1
in
( index - maxSnapshotSize
, VDom.lazy3 viewSnapshot currentIndexHelp index snapshot :: rest
)
viewSnapshot : Int -> Int -> Snapshot model msg -> Node Int
viewSnapshot currentIndex index { messages } =
VDom.div [] <| Tuple.second <|
Array.foldl (consMsg currentIndex) (index - 1, []) messages
-- VIEW MESSAGE
consMsg : Int -> msg -> ( Int, List (Node Int) ) -> ( Int, List (Node Int) )
consMsg currentIndex msg (index, rest) =
( index - 1
, VDom.lazy3 viewMessage currentIndex index msg :: rest
)
viewMessage : Int -> Int -> msg -> Node Int
viewMessage currentIndex index msg =
let
className =
if currentIndex == index then
"messages-entry messages-entry-selected"
else
"messages-entry"
messageName =
Native.Debug.messageToString msg
in
VDom.div
[ VDom.class className
, VDom.on "click" (Decode.succeed index)
]
[ VDom.span [VDom.class "messages-entry-content", VDom.attribute "title" messageName ] [ VDom.text messageName ]
, VDom.span [VDom.class "messages-entry-index"] [ VDom.text (toString index) ]
]

View File

@@ -0,0 +1,326 @@
module VirtualDom.Metadata exposing
( Metadata
, check
, decode, decoder, encode
, Error, ProblemType, Problem(..)
)
import Array exposing (Array)
import Dict exposing (Dict)
import Json.Decode as Decode
import Json.Encode as Encode
import VirtualDom.Report as Report exposing (Report)
-- METADATA
type alias Metadata =
{ versions : Versions
, types : Types
}
-- VERSIONS
type alias Versions =
{ elm : String
}
-- TYPES
type alias Types =
{ message : String
, aliases : Dict String Alias
, unions : Dict String Union
}
type alias Alias =
{ args : List String
, tipe : String
}
type alias Union =
{ args : List String
, tags : Dict String (List String)
}
-- PORTABILITY
isPortable : Metadata -> Maybe Error
isPortable {types} =
let
badAliases =
Dict.foldl collectBadAliases [] types.aliases
in
case Dict.foldl collectBadUnions badAliases types.unions of
[] ->
Nothing
problems ->
Just (Error types.message problems)
type alias Error =
{ message : String
, problems : List ProblemType
}
type alias ProblemType =
{ name : String
, problems : List Problem
}
type Problem
= Function
| Decoder
| Task
| Process
| Socket
| Request
| Program
| VirtualDom
collectBadAliases : String -> Alias -> List ProblemType -> List ProblemType
collectBadAliases name {tipe} list =
case findProblems tipe of
[] ->
list
problems ->
ProblemType name problems :: list
collectBadUnions : String -> Union -> List ProblemType -> List ProblemType
collectBadUnions name {tags} list =
case List.concatMap findProblems (List.concat (Dict.values tags)) of
[] ->
list
problems ->
ProblemType name problems :: list
findProblems : String -> List Problem
findProblems tipe =
List.filterMap (hasProblem tipe) problemTable
hasProblem : String -> (Problem, String) -> Maybe Problem
hasProblem tipe (problem, token) =
if String.contains token tipe then Just problem else Nothing
problemTable : List (Problem, String)
problemTable =
[ ( Function, "->" )
, ( Decoder, "Json.Decode.Decoder" )
, ( Task, "Task.Task" )
, ( Process, "Process.Id" )
, ( Socket, "WebSocket.LowLevel.WebSocket" )
, ( Request, "Http.Request" )
, ( Program, "Platform.Program" )
, ( VirtualDom, "VirtualDom.Node" )
, ( VirtualDom, "VirtualDom.Attribute" )
]
-- CHECK
check : Metadata -> Metadata -> Report
check old new =
if old.versions.elm /= new.versions.elm then
Report.VersionChanged old.versions.elm new.versions.elm
else
checkTypes old.types new.types
checkTypes : Types -> Types -> Report
checkTypes old new =
if old.message /= new.message then
Report.MessageChanged old.message new.message
else
[]
|> Dict.merge ignore checkAlias ignore old.aliases new.aliases
|> Dict.merge ignore checkUnion ignore old.unions new.unions
|> Report.SomethingChanged
ignore : String -> value -> a -> a
ignore key value report =
report
-- CHECK ALIASES
checkAlias : String -> Alias -> Alias -> List Report.Change -> List Report.Change
checkAlias name old new changes =
if old.tipe == new.tipe && old.args == new.args then
changes
else
Report.AliasChange name :: changes
-- CHECK UNIONS
checkUnion : String -> Union -> Union -> List Report.Change -> List Report.Change
checkUnion name old new changes =
let
tagChanges =
Dict.merge removeTag checkTag addTag old.tags new.tags <|
Report.emptyTagChanges (old.args == new.args)
in
if Report.hasTagChanges tagChanges then
changes
else
Report.UnionChange name tagChanges :: changes
removeTag : String -> a -> Report.TagChanges -> Report.TagChanges
removeTag tag _ changes =
{ changes | removed = tag :: changes.removed }
addTag : String -> a -> Report.TagChanges -> Report.TagChanges
addTag tag _ changes =
{ changes | added = tag :: changes.added }
checkTag : String -> a -> a -> Report.TagChanges -> Report.TagChanges
checkTag tag old new changes =
if old == new then
changes
else
{ changes | changed = tag :: changes.changed }
-- JSON DECODE
decode : Encode.Value -> Result Error Metadata
decode value =
case Decode.decodeValue decoder value of
Err _ ->
Debug.crash "Compiler is generating bad metadata. Report this at <https://github.com/elm-lang/virtual-dom/issues>."
Ok metadata ->
case isPortable metadata of
Nothing ->
Ok metadata
Just error ->
Err error
decoder : Decode.Decoder Metadata
decoder =
Decode.map2 Metadata
(Decode.field "versions" decodeVersions)
(Decode.field "types" decodeTypes)
decodeVersions : Decode.Decoder Versions
decodeVersions =
Decode.map Versions
(Decode.field "elm" Decode.string)
decodeTypes : Decode.Decoder Types
decodeTypes =
Decode.map3 Types
(Decode.field "message" Decode.string)
(Decode.field "aliases" (Decode.dict decodeAlias))
(Decode.field "unions" (Decode.dict decodeUnion))
decodeUnion : Decode.Decoder Union
decodeUnion =
Decode.map2 Union
(Decode.field "args" (Decode.list Decode.string))
(Decode.field "tags" (Decode.dict (Decode.list Decode.string)))
decodeAlias : Decode.Decoder Alias
decodeAlias =
Decode.map2 Alias
(Decode.field "args" (Decode.list Decode.string))
(Decode.field "type" (Decode.string))
-- JSON ENCODE
encode : Metadata -> Encode.Value
encode { versions, types } =
Encode.object
[ ("versions", encodeVersions versions)
, ("types", encodeTypes types)
]
encodeVersions : Versions -> Encode.Value
encodeVersions { elm } =
Encode.object [("elm", Encode.string elm)]
encodeTypes : Types -> Encode.Value
encodeTypes { message, unions, aliases } =
Encode.object
[ ("message", Encode.string message)
, ("aliases", encodeDict encodeAlias aliases)
, ("unions", encodeDict encodeUnion unions)
]
encodeAlias : Alias -> Encode.Value
encodeAlias { args, tipe } =
Encode.object
[ ("args", Encode.list (List.map Encode.string args))
, ("type", Encode.string tipe)
]
encodeUnion : Union -> Encode.Value
encodeUnion { args, tags } =
Encode.object
[ ("args", Encode.list (List.map Encode.string args))
, ("tags", encodeDict (Encode.list << List.map Encode.string) tags)
]
encodeDict : (a -> Encode.Value) -> Dict String a -> Encode.Value
encodeDict f dict =
dict
|> Dict.map (\key value -> f value)
|> Dict.toList
|> Encode.object

View File

@@ -0,0 +1,541 @@
module VirtualDom.Overlay exposing
( State, none, corruptImport, badMetadata
, Msg, close, assessImport
, isBlocking
, Config
, Block
, view
, viewImportExport
)
import Json.Decode as Decode
import Json.Encode as Encode
import VirtualDom.Helpers exposing (..)
import VirtualDom.Metadata as Metadata exposing (Metadata)
import VirtualDom.Report as Report exposing (Report)
type State
= None
| BadMetadata Metadata.Error
| BadImport Report
| RiskyImport Report Encode.Value
none : State
none =
None
corruptImport : State
corruptImport =
BadImport Report.CorruptHistory
badMetadata : Metadata.Error -> State
badMetadata =
BadMetadata
isBlocking : State -> Bool
isBlocking state =
case state of
None ->
False
_ ->
True
-- UPDATE
type Msg = Cancel | Proceed
close : Msg -> State -> Maybe Encode.Value
close msg state =
case state of
None ->
Nothing
BadMetadata _ ->
Nothing
BadImport _ ->
Nothing
RiskyImport _ rawHistory ->
case msg of
Cancel ->
Nothing
Proceed ->
Just rawHistory
assessImport : Metadata -> String -> Result State Encode.Value
assessImport metadata jsonString =
case Decode.decodeString uploadDecoder jsonString of
Err _ ->
Err corruptImport
Ok (foreignMetadata, rawHistory) ->
let
report =
Metadata.check foreignMetadata metadata
in
case Report.evaluate report of
Report.Impossible ->
Err (BadImport report)
Report.Risky ->
Err (RiskyImport report rawHistory)
Report.Fine ->
Ok rawHistory
uploadDecoder : Decode.Decoder (Metadata, Encode.Value)
uploadDecoder =
Decode.map2 (,)
(Decode.field "metadata" Metadata.decoder)
(Decode.field "history" Decode.value)
-- VIEW
type alias Config msg =
{ resume : msg
, open : msg
, importHistory : msg
, exportHistory : msg
, wrap : Msg -> msg
}
type Block = Normal | Pause | Message
view : Config msg -> Bool -> Bool -> Int -> State -> ( Block, Node msg )
view config isPaused isOpen numMsgs state =
let
(block, nodes) =
viewHelp config isPaused isOpen numMsgs state
in
( block
, div [ class "elm-overlay" ] (styles :: nodes)
)
viewHelp : Config msg -> Bool -> Bool -> Int -> State -> ( Block, List (Node msg) )
viewHelp config isPaused isOpen numMsgs state =
case state of
None ->
let
miniControls =
if isOpen then [] else [ viewMiniControls config numMsgs ]
in
( if isPaused then Pause else Normal
, if isPaused && not isOpen then
viewResume config :: miniControls
else
miniControls
)
BadMetadata badMetadata ->
viewMessage config
"Cannot use Import or Export"
(viewBadMetadata badMetadata)
(Accept "Ok")
BadImport report ->
viewMessage config
"Cannot Import History"
(viewReport True report)
(Accept "Ok")
RiskyImport report _ ->
viewMessage config
"Warning"
(viewReport False report)
(Choose "Cancel" "Import Anyway")
viewResume config =
div [ class "elm-overlay-resume", onClick config.resume ]
[ div [class "elm-overlay-resume-words"] [text "Click to Resume"] ]
-- VIEW MESSAGE
viewMessage : Config msg -> String -> List (Node msg) -> Buttons -> ( Block, List (Node msg) )
viewMessage config title details buttons =
( Message
, [ div [ class "elm-overlay-message" ]
[ div [ class "elm-overlay-message-title" ] [ text title ]
, div [ class "elm-overlay-message-details" ] details
, map config.wrap (viewButtons buttons)
]
]
)
viewReport : Bool -> Report -> List (Node msg)
viewReport isBad report =
case report of
Report.CorruptHistory ->
[ text "Looks like this history file is corrupt. I cannot understand it."
]
Report.VersionChanged old new ->
[ text <|
"This history was created with Elm "
++ old ++ ", but you are using Elm "
++ new ++ " right now."
]
Report.MessageChanged old new ->
[ text <|
"To import some other history, the overall message type must"
++ " be the same. The old history has "
, viewCode old
, text " messages, but the new program works with "
, viewCode new
, text " messages."
]
Report.SomethingChanged changes ->
[ node "p" [] [ text (if isBad then explanationBad else explanationRisky) ]
, node "ul" [] (List.map viewChange changes)
]
explanationBad : String
explanationBad = """
The messages in this history do not match the messages handled by your
program. I noticed changes in the following types:
"""
explanationRisky : String
explanationRisky = """
This history seems old. It will work with this program, but some
messages have been added since the history was created:
"""
viewCode : String -> Node msg
viewCode name =
node "code" [] [ text name ]
viewChange : Report.Change -> Node msg
viewChange change =
node "li" [] <|
case change of
Report.AliasChange name ->
[ span [ class "elm-overlay-message-details-type" ] [ viewCode name ]
]
Report.UnionChange name { removed, changed, added, argsMatch } ->
[ span [ class "elm-overlay-message-details-type" ] [ viewCode name ]
, node "ul" []
[ viewMention removed "Removed "
, viewMention changed "Changed "
, viewMention added "Added "
]
, if argsMatch then
text ""
else
text "This may be due to the fact that the type variable names changed."
]
viewMention : List String -> String -> Node msg
viewMention tags verbed =
case List.map viewCode (List.reverse tags) of
[] ->
text ""
[tag] ->
node "li" []
[ text verbed, tag, text "." ]
[tag2, tag1] ->
node "li" []
[ text verbed, tag1, text " and ", tag2, text "." ]
lastTag :: otherTags ->
node "li" [] <|
text verbed
:: List.intersperse (text ", ") (List.reverse otherTags)
++ [ text ", and ", lastTag, text "." ]
viewBadMetadata : Metadata.Error -> List (Node msg)
viewBadMetadata {message, problems} =
[ node "p" []
[ text "The "
, viewCode message
, text " type of your program cannot be reliably serialized for history files."
]
, node "p" [] [ text "Functions cannot be serialized, nor can values that contain functions. This is a problem in these places:" ]
, node "ul" [] (List.map viewProblemType problems)
, node "p" []
[ text goodNews1
, a [ href "https://guide.elm-lang.org/types/union_types.html" ] [ text "union types" ]
, text ", in your messages. From there, your "
, viewCode "update"
, text goodNews2
]
]
goodNews1 = """
The good news is that having values like this in your message type is not
so great in the long run. You are better off using simpler data, like
"""
goodNews2 = """
function can pattern match on that data and call whatever functions, JSON
decoders, etc. you need. This makes the code much more explicit and easy to
follow for other readers (or you in a few months!)
"""
viewProblemType : Metadata.ProblemType -> Node msg
viewProblemType { name, problems } =
node "li" []
[ viewCode name
, text (" can contain " ++ addCommas (List.map problemToString problems) ++ ".")
]
problemToString : Metadata.Problem -> String
problemToString problem =
case problem of
Metadata.Function ->
"functions"
Metadata.Decoder ->
"JSON decoders"
Metadata.Task ->
"tasks"
Metadata.Process ->
"processes"
Metadata.Socket ->
"web sockets"
Metadata.Request ->
"HTTP requests"
Metadata.Program ->
"programs"
Metadata.VirtualDom ->
"virtual DOM values"
addCommas : List String -> String
addCommas items =
case items of
[] ->
""
[item] ->
item
[item1, item2] ->
item1 ++ " and " ++ item2
lastItem :: otherItems ->
String.join ", " (otherItems ++ [ " and " ++ lastItem ])
-- VIEW MESSAGE BUTTONS
type Buttons
= Accept String
| Choose String String
viewButtons : Buttons -> Node Msg
viewButtons buttons =
div [ class "elm-overlay-message-buttons" ] <|
case buttons of
Accept proceed ->
[ node "button" [ onClick Proceed ] [ text proceed ]
]
Choose cancel proceed ->
[ node "button" [ onClick Cancel ] [ text cancel ]
, node "button" [ onClick Proceed ] [ text proceed ]
]
-- VIEW MINI CONTROLS
viewMiniControls : Config msg -> Int -> Node msg
viewMiniControls config numMsgs =
div
[ class "elm-mini-controls"
]
[ div
[ onClick config.open
, class "elm-mini-controls-button"
]
[ text ("Explore History (" ++ toString numMsgs ++ ")")
]
, viewImportExport
[class "elm-mini-controls-import-export"]
config.importHistory
config.exportHistory
]
viewImportExport : List (Property msg) -> msg -> msg -> Node msg
viewImportExport props importMsg exportMsg =
div
props
[ button importMsg "Import"
, text " / "
, button exportMsg "Export"
]
button : msg -> String -> Node msg
button msg label =
span [ onClick msg, style [("cursor","pointer")] ] [ text label ]
-- STYLE
styles : Node msg
styles =
node "style" [] [ text """
.elm-overlay {
position: fixed;
top: 0;
left: 0;
width: 100%;
height: 100%;
color: white;
pointer-events: none;
font-family: 'Trebuchet MS', 'Lucida Grande', 'Bitstream Vera Sans', 'Helvetica Neue', sans-serif;
}
.elm-overlay-resume {
width: 100%;
height: 100%;
cursor: pointer;
text-align: center;
pointer-events: auto;
background-color: rgba(200, 200, 200, 0.7);
}
.elm-overlay-resume-words {
position: absolute;
top: calc(50% - 40px);
font-size: 80px;
line-height: 80px;
height: 80px;
width: 100%;
}
.elm-mini-controls {
position: fixed;
bottom: 0;
right: 6px;
border-radius: 4px;
background-color: rgb(61, 61, 61);
font-family: monospace;
pointer-events: auto;
}
.elm-mini-controls-button {
padding: 6px;
cursor: pointer;
text-align: center;
min-width: 24ch;
}
.elm-mini-controls-import-export {
padding: 4px 0;
font-size: 0.8em;
text-align: center;
background-color: rgb(50, 50, 50);
}
.elm-overlay-message {
position: absolute;
width: 600px;
height: 100%;
padding-left: calc(50% - 300px);
padding-right: calc(50% - 300px);
background-color: rgba(200, 200, 200, 0.7);
pointer-events: auto;
}
.elm-overlay-message-title {
font-size: 36px;
height: 80px;
background-color: rgb(50, 50, 50);
padding-left: 22px;
vertical-align: middle;
line-height: 80px;
}
.elm-overlay-message-details {
padding: 8px 20px;
overflow-y: auto;
max-height: calc(100% - 156px);
background-color: rgb(61, 61, 61);
}
.elm-overlay-message-details-type {
font-size: 1.5em;
}
.elm-overlay-message-details ul {
list-style-type: none;
padding-left: 20px;
}
.elm-overlay-message-details ul ul {
list-style-type: disc;
padding-left: 2em;
}
.elm-overlay-message-details li {
margin: 8px 0;
}
.elm-overlay-message-buttons {
height: 60px;
line-height: 60px;
text-align: right;
background-color: rgb(50, 50, 50);
}
.elm-overlay-message-buttons button {
margin-right: 20px;
}
""" ]

View File

@@ -0,0 +1,99 @@
module VirtualDom.Report exposing
( Report(..)
, Change(..)
, TagChanges
, emptyTagChanges
, hasTagChanges
, Status(..), evaluate
)
-- REPORTS
type Report
= CorruptHistory
| VersionChanged String String
| MessageChanged String String
| SomethingChanged (List Change)
type Change
= AliasChange String
| UnionChange String TagChanges
type alias TagChanges =
{ removed : List String
, changed : List String
, added : List String
, argsMatch : Bool
}
emptyTagChanges : Bool -> TagChanges
emptyTagChanges argsMatch =
TagChanges [] [] [] argsMatch
hasTagChanges : TagChanges -> Bool
hasTagChanges tagChanges =
tagChanges == TagChanges [] [] [] True
type Status = Impossible | Risky | Fine
evaluate : Report -> Status
evaluate report =
case report of
CorruptHistory ->
Impossible
VersionChanged _ _ ->
Impossible
MessageChanged _ _ ->
Impossible
SomethingChanged changes ->
worstCase Fine (List.map evaluateChange changes)
worstCase : Status -> List Status -> Status
worstCase status statusList =
case statusList of
[] ->
status
Impossible :: _ ->
Impossible
Risky :: rest ->
worstCase Risky rest
Fine :: rest ->
worstCase status rest
evaluateChange : Change -> Status
evaluateChange change =
case change of
AliasChange _ ->
Impossible
UnionChange _ { removed, changed, added, argsMatch } ->
if not argsMatch || some changed || some removed then
Impossible
else if some added then
Risky
else
Fine
some : List a -> Bool
some list =
not (List.isEmpty list)

View File

@@ -0,0 +1,35 @@
Elm.Native.TestHelpers = {};
Elm.Native.TestHelpers.make = function(localRuntime)
{
localRuntime.Native = localRuntime.Native || {};
localRuntime.Native.TestHelpers = localRuntime.Native.TestHelpers || {};
if (localRuntime.Native.TestHelpers.values)
{
return localRuntime.Native.TestHelpers.values;
}
var VirtualDom = Elm.Native.VirtualDom.make(localRuntime);
function unsafeRecordCallCount(f) {
function wrapper(a) {
wrapper.__elm_test_call_count += 1;
return f(a);
}
wrapper.__elm_test_call_count = 0;
return wrapper;
}
function unsafeQueryCallCount(f) {
if (f.__elm_test_call_count === undefined) {
return -1;
}
return f.__elm_test_call_count;
}
Elm.Native.TestHelpers.values = {
unsafeRecordCallCount: unsafeRecordCallCount,
unsafeQueryCallCount: unsafeQueryCallCount,
updateAndReplace: F3(VirtualDom.updateAndReplace)
};
return localRuntime.Native.TestHelpers.values = Elm.Native.TestHelpers.values;
};

View File

@@ -0,0 +1,72 @@
module TestCases.Lazy where
import VirtualDom exposing (Node, lazy)
import ElmTest.Assertion exposing (assertEqual)
import ElmTest.Test exposing (Test, suite, test)
import TestHelpers exposing (renderDom, updateDom, unsafeRecordCallCount, unsafeQueryCallCount)
renderRecord : { x: String, y: String } -> Node
renderRecord r =
VirtualDom.text <| "The values: " ++ r.x ++ ", " ++ r.y
renderPrimitive : Int -> Node
renderPrimitive x =
VirtualDom.text <| "The value: " ++ (toString x)
testLazyIdenticalRecord =
test "isn't called again with identical record" <|
let record = { x = "a", y = "b" }
wrappedRender = unsafeRecordCallCount renderRecord
v1 = renderDom <| lazy wrappedRender record
v2 = updateDom v1 <| lazy wrappedRender record
v3 = updateDom v2 <| lazy wrappedRender record
in
assertEqual 1 <| unsafeQueryCallCount wrappedRender
testLazyIdenticalPrimitive =
test "isn't called again with identical primitive" <|
let wrappedRender = unsafeRecordCallCount renderPrimitive
v1 = renderDom <| lazy wrappedRender 5
v2 = updateDom v1 <| lazy wrappedRender 5
v3 = updateDom v2 <| lazy wrappedRender 5
in
assertEqual 1 <| unsafeQueryCallCount wrappedRender
testLazyRecordMutationOfIdenticalValue =
test "isn't called again with record mutation of identical value" <|
let record = { x = "a", y = "b" }
wrappedRender = unsafeRecordCallCount renderRecord
v1 = renderDom <| lazy wrappedRender record
v2 = updateDom v1 <| lazy wrappedRender { record | x = "a" }
v3 = updateDom v2 <| lazy wrappedRender { record | x = "a", y = "b" }
in
assertEqual 1 <| unsafeQueryCallCount wrappedRender
testNotLazyDifferentRecord =
test "is called again with an equivalent but different record" <|
let wrappedRender = unsafeRecordCallCount renderRecord
v1 = renderDom <| lazy wrappedRender { x = "a", y = "b" }
v2 = updateDom v1 <| lazy wrappedRender { x = "a", y = "b" }
v3 = updateDom v2 <| lazy wrappedRender { x = "a", y = "b" }
in
assertEqual 3 <| unsafeQueryCallCount wrappedRender
tests : Test
tests =
suite
"Lazy"
[
testLazyIdenticalRecord,
testLazyIdenticalPrimitive,
-- Re-enable this test when core supports checking
-- record update values for identity before copying:
-- testLazyRecordMutationOfIdenticalValue,
testNotLazyDifferentRecord
]

View File

@@ -0,0 +1,34 @@
module TestHelpers where
import VirtualDom exposing (Node)
import Native.TestHelpers
import Native.VirtualDom
unsafeRecordCallCount : (a -> b) -> (a -> b)
unsafeRecordCallCount =
Native.TestHelpers.unsafeRecordCallCount
unsafeQueryCallCount : (a -> b) -> Int
unsafeQueryCallCount =
Native.TestHelpers.unsafeQueryCallCount
type OpaqueDom = OpaqueDom
render : Node -> OpaqueDom
render =
Native.VirtualDom.render
updateAndReplace : OpaqueDom -> Node -> Node -> OpaqueDom
updateAndReplace =
Native.TestHelpers.updateAndReplace
renderDom : Node -> (OpaqueDom, Node)
renderDom vdom =
(render vdom, vdom)
updateDom : (OpaqueDom, Node) -> Node -> (OpaqueDom, Node)
updateDom (oldDom, oldVDom) newVDom =
(updateAndReplace oldDom oldVDom newVDom, newVDom)

View File

@@ -0,0 +1,18 @@
import ElmTest.Runner.Console exposing (runDisplay)
import ElmTest.Test exposing (Test, suite)
import Console exposing (IO)
import Task exposing (Task)
import TestCases.Lazy
tests : Test
tests =
suite
"VirtualDom Library Tests"
[
TestCases.Lazy.tests
]
port runner : Signal (Task x ())
port runner = Console.run (runDisplay tests)

View File

@@ -0,0 +1,18 @@
{
"version": "1.0.0",
"summary": "Test for VirtualDom",
"license": "BSD3",
"repository": "https://github.com/evancz/virtual-dom.git",
"exposed-modules": [],
"source-directories": [
".",
"build/virtual-dom/"
],
"native-modules": true,
"dependencies": {
"elm-lang/core": "2.0.0 <= v < 4.0.0",
"laszlopandy/elm-console": "1.0.0 <= v < 2.0.0",
"deadfoxygrandpa/elm-test": "1.0.3 <= v < 2.0.0"
},
"elm-version": "0.16.0 <= v < 0.17.0"
}

View File

@@ -0,0 +1,24 @@
#!/bin/sh
set -e
cd "$(dirname "$0")"
mkdir -p build/virtual-dom/Native
cp ../src/VirtualDom.elm build/virtual-dom/
$(npm bin)/browserify ../src/wrapper.js -o build/VirtualDom.browser.js
set +e
diff -u ../src/Native/VirtualDom.js build/VirtualDom.browser.js
if [ $? != 0 ]; then
echo "ERROR:"
echo "src/Native/VirtualDom.js has local modifications or is out of date. Please run rebuild.sh"
exit 1
fi
set -e
$(npm bin)/browserify --no-browser-field ../src/wrapper.js -o build/virtual-dom/Native/VirtualDom.js
elm-make --yes --output build/test.js TestMain.elm
echo "Elm.worker(Elm.Main);" >> build/test.js
node build/test.js