module Test.Html.Internal.ElmHtml.InternalTypes exposing
( ElmHtml(..), TextTagRecord, NodeRecord, CustomNodeRecord, MarkdownNodeRecord
, Facts, Tagger, EventHandler, ElementKind(..)
, Attribute(..), AttributeRecord, NamespacedAttributeRecord, PropertyRecord, EventRecord
, decodeElmHtml, emptyFacts, toElementKind, decodeAttribute, isUnsafeName
)
{-| Internal types used to represent Elm Html in pure Elm
@docs ElmHtml, TextTagRecord, NodeRecord, CustomNodeRecord, MarkdownNodeRecord
@docs Facts, Tagger, EventHandler, ElementKind
@docs Attribute, AttributeRecord, NamespacedAttributeRecord, PropertyRecord, EventRecord
@docs decodeElmHtml, emptyFacts, toElementKind, decodeAttribute, isUnsafeName
-}
import Dict exposing (Dict)
import Html.Events
import Json.Decode exposing (field)
import Json.Encode
import Regex exposing (Regex)
import Test.Html.Internal.ElmHtml.Constants as Constants exposing (..)
import Test.Html.Internal.ElmHtml.Helpers exposing (..)
import Test.Html.Internal.ElmHtml.Markdown exposing (..)
import Test.Internal.KernelConstants exposing (kernelConstants)
import VirtualDom
{-| Type tree for representing Elm's Html
- TextTag is just a plain old bit of text.
- NodeEntry is an actual HTML node, e.g a div
- CustomNode are nodes defined to work with the renderer in some way, e.g webgl/markdown
- MarkdownNode is just a wrapper for CustomNode designed just for markdown
-}
type ElmHtml msg
= TextTag TextTagRecord
| NodeEntry (NodeRecord msg)
| CustomNode (CustomNodeRecord msg)
| MarkdownNode (MarkdownNodeRecord msg)
| NoOp
{-| Text tags just contain text
-}
type alias TextTagRecord =
{ text : String }
{-| A node contains the `tag` as a string, the children, the facts (e.g attributes) and descendantsCount
-}
type alias NodeRecord msg =
{ tag : String
, children : List (ElmHtml msg)
, facts :
Facts msg
--, namespace : String
, descendantsCount : Int
}
{-| A markdown node contains facts (e.g attributes) and the model used by markdown
-}
type alias MarkdownNodeRecord msg =
{ facts : Facts msg
, model : MarkdownModel
}
{-| Custom nodes contain facts (e.g attributes) and a json value for the model
-}
type alias CustomNodeRecord msg =
{ facts : Facts msg
, model : Json.Decode.Value
}
{-| Tagger holds the map function when Html.Map is used, the tagger
should then be applied to events comming from descendant nodes, it
is basically a javascript function.
-}
type alias Tagger =
Json.Decode.Value
{-| EventHandler holds the function that is called when an event is
triggered, it is basically a javascript object like this:
{ decoder: [Function] }
-}
type alias EventHandler =
Json.Decode.Value
{-| Facts contain various dictionaries and values for a node
- styles are a mapping of rules
- events may be a json object containing event handlers
- attributes are pulled out into stringAttributes and boolAttributes - things with string values go into
stringAttributes, things with bool values go into boolAttributes
-}
type alias Facts msg =
{ styles : Dict String String
, events : Dict String (VirtualDom.Handler msg)
, attributeNamespace : Maybe Json.Decode.Value
, stringAttributes : Dict String String
, boolAttributes : Dict String Bool
}
{-| Type for representing the five kinds of elements according to HTML 5
[spec](https://html.spec.whatwg.org/multipage/syntax.html#elements-2).
Used to handle different rendering behavior depending on the type of element.
-}
type ElementKind
= VoidElements
| RawTextElements
| EscapableRawTextElements
| ForeignElements
| NormalElements
| InvalidElements
type HtmlContext msg
= HtmlContext (List Tagger) (List Tagger -> EventHandler -> VirtualDom.Handler msg)
{-| Type for representing Elm's Attributes
- Attribute is an HTML attribute, like `Html.Attributes.colspan`. These values
are applied using `element.setAttribute(key, value)` during a patch.
- NamespacedAttribute has an namespace, like `Svg.Attributes.xlinkHref`
- Property assigns a value to a node like `Html.Attributes.class`, and can
hold any encoded value. Unlike attributes, where `element.setAttribute()` is
used during the patch, properties are applied directly as
`element[key] = value`.
- Styles hold a list of key value pairs to be applied to the node's style set
- Event contains a decoder for a msg and the `Html.Event.Options` for the event
-}
type Attribute
= Attribute AttributeRecord
| NamespacedAttribute NamespacedAttributeRecord
| Property PropertyRecord
| Style { key : String, value : String }
| Event EventRecord
{-| Attribute contains a string key and a string value
-}
type alias AttributeRecord =
{ key : String
, value : String
}
{-| NamespacedAttribute contains a string key, string namespace and string value
-}
type alias NamespacedAttributeRecord =
{ key : String
, value : String
, namespace : String
}
{-| Property contains a string key and a value with an arbitrary type
-}
type alias PropertyRecord =
{ key : String
, value : Json.Decode.Value
}
{-| Event contains a string key, a decoder for a msg and event options
-}
type alias EventRecord =
{ key : String
, decoder : Json.Decode.Value
, options : EventOptions
}
type alias EventOptions =
{ stopPropagation : Bool
, preventDefault : Bool
}
{-| decode a json object into ElmHtml, you have to pass a function that decodes
events from Html Nodes. If you don't want to decode event msgs, you can ignore it:
decodeElmHtml (\_ _ -> VirtualDom.Normal (Json.Decode.succeed ())) jsonHtml
if you do want to decode them, you will probably need to write some native code
like elm-html-test does to extract the function inside those.
-}
decodeElmHtml : (List Tagger -> EventHandler -> VirtualDom.Handler msg) -> Json.Decode.Decoder (ElmHtml msg)
decodeElmHtml eventDecoder =
contextDecodeElmHtml (HtmlContext [] eventDecoder)
contextDecodeElmHtml : HtmlContext msg -> Json.Decode.Decoder (ElmHtml msg)
contextDecodeElmHtml context =
field kernelConstants.virtualDom.nodeType Json.Decode.int
|> Json.Decode.andThen
(\nodeType ->
if nodeType == kernelConstants.virtualDom.nodeTypeText then
Json.Decode.map TextTag decodeTextTag
else if nodeType == kernelConstants.virtualDom.nodeTypeKeyedNode then
Json.Decode.map NodeEntry (decodeKeyedNode context)
else if nodeType == kernelConstants.virtualDom.nodeTypeNode then
Json.Decode.map NodeEntry (decodeNode context)
else if nodeType == kernelConstants.virtualDom.nodeTypeCustom then
decodeCustomNode context
else if nodeType == kernelConstants.virtualDom.nodeTypeTagger then
decodeTagger context
else if nodeType == kernelConstants.virtualDom.nodeTypeThunk then
field kernelConstants.virtualDom.node (contextDecodeElmHtml context)
else
Json.Decode.fail ("No such type as " ++ String.fromInt nodeType)
)
{-| decode text tag
-}
decodeTextTag : Json.Decode.Decoder TextTagRecord
decodeTextTag =
field kernelConstants.virtualDom.text (Json.Decode.andThen (\text -> Json.Decode.succeed { text = text }) Json.Decode.string)
{-| decode a tagger
-}
decodeTagger : HtmlContext msg -> Json.Decode.Decoder (ElmHtml msg)
decodeTagger (HtmlContext taggers eventDecoder) =
Json.Decode.field kernelConstants.virtualDom.tagger Json.Decode.value
|> Json.Decode.andThen
(\tagger ->
let
nodeDecoder =
contextDecodeElmHtml (HtmlContext (taggers ++ [ tagger ]) eventDecoder)
in
Json.Decode.at [ kernelConstants.virtualDom.node ] nodeDecoder
)
decodeKeyedNode : HtmlContext msg -> Json.Decode.Decoder (NodeRecord msg)
decodeKeyedNode context =
let
-- elm stores keyed nodes as tuples
-- we only want to decode the html, in the second property
decodeSecondNode =
Json.Decode.field "b" (contextDecodeElmHtml context)
in
Json.Decode.map4 NodeRecord
(Json.Decode.field kernelConstants.virtualDom.tag Json.Decode.string)
(Json.Decode.field kernelConstants.virtualDom.kids (Json.Decode.list decodeSecondNode))
(Json.Decode.field kernelConstants.virtualDom.facts (decodeFacts context))
(Json.Decode.field kernelConstants.virtualDom.descendantsCount Json.Decode.int)
{-| decode a node record
-}
decodeNode : HtmlContext msg -> Json.Decode.Decoder (NodeRecord msg)
decodeNode context =
Json.Decode.map4 NodeRecord
(field kernelConstants.virtualDom.tag Json.Decode.string)
(field kernelConstants.virtualDom.kids (Json.Decode.list (contextDecodeElmHtml context)))
(field kernelConstants.virtualDom.facts (decodeFacts context))
(field kernelConstants.virtualDom.descendantsCount Json.Decode.int)
{-| decode custom node into either markdown or custom
-}
decodeCustomNode : HtmlContext msg -> Json.Decode.Decoder (ElmHtml msg)
decodeCustomNode context =
Json.Decode.oneOf
[ Json.Decode.map MarkdownNode (decodeMarkdownNodeRecord context)
, Json.Decode.map CustomNode (decodeCustomNodeRecord context)
]
{-| decode custom node record
-}
decodeCustomNodeRecord : HtmlContext msg -> Json.Decode.Decoder (CustomNodeRecord msg)
decodeCustomNodeRecord context =
Json.Decode.map2 CustomNodeRecord
(field kernelConstants.virtualDom.facts (decodeFacts context))
(field kernelConstants.virtualDom.model Json.Decode.value)
{-| decode markdown node record
-}
decodeMarkdownNodeRecord : HtmlContext msg -> Json.Decode.Decoder (MarkdownNodeRecord msg)
decodeMarkdownNodeRecord context =
Json.Decode.map2 MarkdownNodeRecord
(field kernelConstants.virtualDom.facts (decodeFacts context))
(field kernelConstants.virtualDom.model decodeMarkdownModel)
{-| decode the styles
-}
decodeStyles : Json.Decode.Decoder (Dict String String)
decodeStyles =
Json.Decode.oneOf
[ field styleKey (Json.Decode.dict Json.Decode.string)
, Json.Decode.succeed Dict.empty
]
{-| grab things from attributes via a decoder, then anything that isn't filtered on
the object
-}
decodeOthers : Json.Decode.Decoder a -> Json.Decode.Decoder (Dict String a)
decodeOthers otherDecoder =
decodeAttributes otherDecoder
|> Json.Decode.andThen
(\attributes ->
decodeDictFilterMap otherDecoder
|> Json.Decode.map (filterKnownKeys >> Dict.union attributes)
)
{-| For a given decoder, keep the values from a dict that pass the decoder
-}
decodeDictFilterMap : Json.Decode.Decoder a -> Json.Decode.Decoder (Dict String a)
decodeDictFilterMap decoder =
Json.Decode.dict Json.Decode.value
|> Json.Decode.map
(Dict.toList
>> List.filterMap
(\( key, value ) ->
case Json.Decode.decodeValue decoder value of
Err _ ->
Nothing
Ok v ->
Just ( key, v )
)
>> Dict.fromList
)
decodeAttributes : Json.Decode.Decoder a -> Json.Decode.Decoder (Dict String a)
decodeAttributes decoder =
Json.Decode.oneOf
[ Json.Decode.field attributeKey (decodeDictFilterMap decoder)
, Json.Decode.succeed Dict.empty
]
decodeEvents : (EventHandler -> VirtualDom.Handler msg) -> Json.Decode.Decoder (Dict String (VirtualDom.Handler msg))
decodeEvents taggedEventDecoder =
Json.Decode.oneOf
[ Json.Decode.field eventKey (Json.Decode.dict (Json.Decode.map taggedEventDecoder Json.Decode.value))
, Json.Decode.succeed Dict.empty
]
{-| decode fact
-}
decodeFacts : HtmlContext msg -> Json.Decode.Decoder (Facts msg)
decodeFacts (HtmlContext taggers eventDecoder) =
Json.Decode.map5 Facts
decodeStyles
(decodeEvents (eventDecoder taggers))
(Json.Decode.maybe (Json.Decode.field attributeNamespaceKey Json.Decode.value))
(decodeOthers Json.Decode.string)
(decodeOthers Json.Decode.bool)
{-| Just empty facts
-}
emptyFacts : Facts msg
emptyFacts =
{ styles = Dict.empty
, events = Dict.empty
, attributeNamespace = Nothing
, stringAttributes = Dict.empty
, boolAttributes = Dict.empty
}
{-| Decode a JSON object into an Attribute. You have to pass a function that
decodes events from event attributes. If you don't want to decode event msgs,
you can ignore it:
decodeAttribute (\_ -> ()) jsonHtml
If you do want to decode them, you will probably need to write some native code
like elm-html-test does to extract the function inside those.
-}
decodeAttribute : Json.Decode.Decoder Attribute
decodeAttribute =
Json.Decode.field "$" Json.Decode.string
|> Json.Decode.andThen
(\tag ->
if tag == Constants.attributeKey then
Json.Decode.map2 (\key val -> Attribute (AttributeRecord key val))
(Json.Decode.field "n" Json.Decode.string)
(Json.Decode.field "o" Json.Decode.string)
else if tag == Constants.attributeNamespaceKey then
Json.Decode.map3 NamespacedAttributeRecord
(Json.Decode.field "n" Json.Decode.string)
(Json.Decode.at [ "o", "o" ] Json.Decode.string)
(Json.Decode.at [ "o", "f" ] Json.Decode.string)
|> Json.Decode.map NamespacedAttribute
else if tag == Constants.styleKey then
Json.Decode.map2 (\key val -> Style { key = key, value = val })
(Json.Decode.field "n" Json.Decode.string)
(Json.Decode.field "o" Json.Decode.string)
else if tag == Constants.propKey then
Json.Decode.map2 (\key val -> Property (PropertyRecord key val))
(Json.Decode.field "n" Json.Decode.string)
(Json.Decode.at [ "o", "a" ] Json.Decode.value)
else
Json.Decode.fail ("Unexpected Html.Attribute tag: " ++ tag)
)
elmListDecoder : Json.Decode.Decoder a -> Json.Decode.Decoder (List a)
elmListDecoder itemDecoder =
elmListDecoderHelp itemDecoder []
|> Json.Decode.map List.reverse
elmListDecoderHelp : Json.Decode.Decoder a -> List a -> Json.Decode.Decoder (List a)
elmListDecoderHelp itemDecoder items =
Json.Decode.field "ctor" Json.Decode.string
|> Json.Decode.andThen
(\ctor ->
case ctor of
"[]" ->
Json.Decode.succeed items
"::" ->
Json.Decode.field "_0" itemDecoder
|> Json.Decode.andThen
(\value ->
Json.Decode.field "_1" (elmListDecoderHelp itemDecoder (value :: items))
)
_ ->
Json.Decode.fail <| "Unrecognized constructor for an Elm List: " ++ ctor
)
{-| A list of Void elements as defined by the HTML5 specification. These
elements must not have closing tags and most not be written as self closing
either
-}
voidElements : List String
voidElements =
[ "area"
, "base"
, "br"
, "col"
, "embed"
, "hr"
, "img"
, "input"
, "link"
, "meta"
, "param"
, "source"
, "track"
, "wbr"
]
{-| A list of all Raw Text Elements as defined by the HTML5 specification. They
can contain only text and have restrictions on which characters can appear
within its innerHTML
-}
rawTextElements : List String
rawTextElements =
[ "script", "style" ]
{-| A list of all Escapable Raw Text Elements as defined by the HTML5
specification. They can have text and character references, but the text must
not contain an ambiguous ampersand along with addional restrictions:
-}
escapableRawTextElements : List String
escapableRawTextElements =
[ "textarea", "title" ]
{- Foreign elements are elements from the MathML namespace and the
SVG namespace. TODO: detect these nodes and handle them correctly. Right
now they will just be treated as Normal elements.
-}
unsafeName : Regex
unsafeName =
{- https://github.com/preactjs/preact-render-to-string/blob/27f340b6e7d77ec7775a49a78d105cad26fa0857/src/lib/util.js#L2 -}
Regex.fromString "[\\s\\n\\\\/='\"\\0<>]"
|> Maybe.withDefault Regex.never
isUnsafeName : String -> Bool
isUnsafeName name =
Regex.contains unsafeName name
{-| Identify the kind of element. Helper to convert an tag name into a type for
pattern matching.
-}
toElementKind : String -> ElementKind
toElementKind element =
if isUnsafeName element then
InvalidElements
else if List.member element voidElements then
VoidElements
else if List.member element rawTextElements then
RawTextElements
else if List.member element escapableRawTextElements then
EscapableRawTextElements
else
-- All other allowed HTML elements are normal elements
NormalElements