{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Miso.Html.Types (
VTree (..)
, View (..)
, ToView (..)
, runView
, node
, text
, textRaw
, rawHtml
, Attribute (..)
, Key (..)
, ToKey (..)
, NS(..)
, prop
, style_
, on
, onWithOptions
, onCreated
, onDestroyed
, onBeforeDestroyed
) where
import Control.Monad (forM_, (<=<))
import Control.Monad.IO.Class (liftIO)
import Data.Aeson (ToJSON, Value, toJSON)
import qualified Data.Aeson as A
import Data.Aeson.Types (parseEither)
import Data.JSString (JSString)
import qualified Data.Map as M
import Data.Proxy (Proxy(Proxy))
import Data.String (IsString, fromString)
import qualified Data.Text as T
import GHCJS.Marshal (ToJSVal, fromJSVal, toJSVal)
import GHCJS.Types (jsval)
import qualified JavaScript.Array as JSArray
import JavaScript.Object (create, getProp)
import JavaScript.Object.Internal (Object(Object))
import qualified Lucid as L
import qualified Lucid.Base as L
import Prelude hiding (null)
import Servant.API (Get, HasLink, MkLink, toLink)
import Text.HTML.TagSoup.Tree (parseTree, TagTree(..))
import Text.HTML.TagSoup (Tag(..))
import Miso.Effect
import Miso.Event
import Miso.FFI
import Miso.String hiding (reverse)
data View action
= Node NS MisoString (Maybe Key) [Attribute action] [View action]
| Text MisoString
| MisoString
deriving a -> View b -> View a
(a -> b) -> View a -> View b
(forall a b. (a -> b) -> View a -> View b)
-> (forall a b. a -> View b -> View a) -> Functor View
forall a b. a -> View b -> View a
forall a b. (a -> b) -> View a -> View b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> View b -> View a
$c<$ :: forall a b. a -> View b -> View a
fmap :: (a -> b) -> View a -> View b
$cfmap :: forall a b. (a -> b) -> View a -> View b
Functor
instance HasLink (View a) where
#if MIN_VERSION_servant(0,14,0)
type MkLink (View a) b = MkLink (Get '[] ()) b
toLink :: (Link -> a) -> Proxy (View a) -> Link -> MkLink (View a) a
toLink Link -> a
toA Proxy (View a)
Proxy = (Link -> a) -> Proxy (Get '[] ()) -> Link -> MkLink (Get '[] ()) a
forall k (endpoint :: k) a.
HasLink endpoint =>
(Link -> a) -> Proxy endpoint -> Link -> MkLink endpoint a
toLink Link -> a
toA (Proxy (Get '[] ())
forall k (t :: k). Proxy t
Proxy :: Proxy (Get '[] ()))
#else
type MkLink (View a) = MkLink (Get '[] ())
toLink _ = toLink (Proxy :: Proxy (Get '[] ()))
#endif
class ToView v where toView :: v -> View action
rawHtml
:: MisoString
-> View action
rawHtml :: MisoString -> View action
rawHtml = MisoString -> View action
forall action. MisoString -> View action
TextRaw
node :: NS
-> MisoString
-> Maybe Key
-> [Attribute action]
-> [View action]
-> View action
node :: NS
-> MisoString
-> Maybe Key
-> [Attribute action]
-> [View action]
-> View action
node = NS
-> MisoString
-> Maybe Key
-> [Attribute action]
-> [View action]
-> View action
forall action.
NS
-> MisoString
-> Maybe Key
-> [Attribute action]
-> [View action]
-> View action
Node
text :: MisoString -> View action
text :: MisoString -> View action
text = MisoString -> View action
forall action. MisoString -> View action
Text
textRaw :: MisoString -> View action
= MisoString -> View action
forall action. MisoString -> View action
TextRaw
instance IsString (View a) where
fromString :: String -> View a
fromString = MisoString -> View a
forall action. MisoString -> View action
text (MisoString -> View a)
-> (String -> MisoString) -> String -> View a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> MisoString
forall a. IsString a => String -> a
fromString
instance L.ToHtml (View action) where
toHtmlRaw :: View action -> HtmlT m ()
toHtmlRaw = View action -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
L.toHtml
toHtml :: View action -> HtmlT m ()
toHtml (Node NS
_ MisoString
vType Maybe Key
_ [Attribute action]
attrs [View action]
vChildren) = HtmlT m () -> [Attribute] -> HtmlT m ()
forall a. With a => a -> [Attribute] -> a
L.with HtmlT m ()
ele [Attribute]
lattrs
where
noEnd :: [MisoString]
noEnd = [MisoString
"img", MisoString
"input", MisoString
"br", MisoString
"hr", MisoString
"meta"]
tag :: MisoString
tag = MisoString -> MisoString
toTag (MisoString -> MisoString) -> MisoString -> MisoString
forall a b. (a -> b) -> a -> b
$ MisoString -> MisoString
forall a. FromMisoString a => MisoString -> a
fromMisoString MisoString
vType
ele :: HtmlT m ()
ele = if MisoString
tag MisoString -> [MisoString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [MisoString]
noEnd
then MisoString -> HtmlT m ()
forall (m :: * -> *). Applicative m => MisoString -> HtmlT m ()
L.makeElementNoEnd MisoString
tag
else MisoString -> HtmlT m () -> HtmlT m ()
forall (m :: * -> *) a.
Functor m =>
MisoString -> HtmlT m a -> HtmlT m a
L.makeElement MisoString
tag HtmlT m ()
kids
classes :: MisoString
classes = MisoString -> [MisoString] -> MisoString
T.intercalate MisoString
" " [ MisoString
v | P MisoString
"class" (A.String MisoString
v) <- [Attribute action]
attrs ]
propClass :: Map MisoString Value
propClass = [(MisoString, Value)] -> Map MisoString Value
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(MisoString, Value)] -> Map MisoString Value)
-> [(MisoString, Value)] -> Map MisoString Value
forall a b. (a -> b) -> a -> b
$ [Attribute action]
attrs [Attribute action]
-> (Attribute action -> [(MisoString, Value)])
-> [(MisoString, Value)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
P MisoString
k Value
v -> [(MisoString
k, Value
v)]
E Sink action -> Object -> JSM ()
_ -> []
S Map MisoString MisoString
m -> [(MisoString
"style", MisoString -> Value
A.String (MisoString -> Value)
-> (MisoString -> MisoString) -> MisoString -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MisoString -> MisoString
forall a. FromMisoString a => MisoString -> a
fromMisoString (MisoString -> Value) -> MisoString -> Value
forall a b. (a -> b) -> a -> b
$ (MisoString -> MisoString -> MisoString -> MisoString)
-> MisoString -> Map MisoString MisoString -> MisoString
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey MisoString -> MisoString -> MisoString -> MisoString
go MisoString
forall a. Monoid a => a
mempty Map MisoString MisoString
m)]
where
go :: MisoString -> MisoString -> MisoString -> MisoString
go :: MisoString -> MisoString -> MisoString -> MisoString
go MisoString
k MisoString
v MisoString
ys = [MisoString] -> MisoString
forall a. Monoid a => [a] -> a
mconcat [ MisoString
k, MisoString
":", MisoString
v, MisoString
";" ] MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
ys
xs :: Map MisoString Value
xs = if Bool -> Bool
not (MisoString -> Bool
T.null MisoString
classes)
then MisoString -> Value -> Map MisoString Value -> Map MisoString Value
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert MisoString
"class" (MisoString -> Value
A.String MisoString
classes) Map MisoString Value
propClass
else Map MisoString Value
propClass
lattrs :: [Attribute]
lattrs = [ MisoString -> MisoString -> Attribute
L.makeAttribute MisoString
k' (if MisoString
k MisoString -> [MisoString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [MisoString]
exceptions Bool -> Bool -> Bool
&& Value
v Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Value
A.Bool Bool
True then MisoString
k' else MisoString
v')
| (MisoString
k,Value
v) <- Map MisoString Value -> [(MisoString, Value)]
forall k a. Map k a -> [(k, a)]
M.toList Map MisoString Value
xs
, let k' :: MisoString
k' = MisoString -> MisoString
forall a. FromMisoString a => MisoString -> a
fromMisoString MisoString
k
, let v' :: MisoString
v' = Value -> MisoString
toHtmlFromJSON Value
v
, Bool -> Bool
not (MisoString
k MisoString -> [MisoString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [MisoString]
exceptions Bool -> Bool -> Bool
&& Value
v Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Value
A.Bool Bool
False)
]
exceptions :: [MisoString]
exceptions = [ MisoString
"checked"
, MisoString
"disabled"
, MisoString
"selected"
, MisoString
"hidden"
, MisoString
"readOnly"
, MisoString
"autoplay"
, MisoString
"required"
, MisoString
"default"
, MisoString
"autofocus"
, MisoString
"multiple"
, MisoString
"noValidate"
, MisoString
"autocomplete"
]
toTag :: MisoString -> MisoString
toTag = MisoString -> MisoString
T.toLower
kids :: HtmlT m ()
kids = (View action -> HtmlT m ()) -> [View action] -> HtmlT m ()
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap View action -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
L.toHtml ([View action] -> HtmlT m ()) -> [View action] -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ [View action] -> [View action]
forall a. [View a] -> [View a]
collapseSiblingTextNodes [View action]
vChildren
toHtml (Text MisoString
x) | MisoString -> Bool
null MisoString
x = MisoString -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
L.toHtml (MisoString
" " :: T.Text)
| Bool
otherwise = MisoString -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
L.toHtml (MisoString -> MisoString
forall a. FromMisoString a => MisoString -> a
fromMisoString MisoString
x :: T.Text)
toHtml (TextRaw MisoString
x)
| MisoString -> Bool
null MisoString
x = MisoString -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
L.toHtml (MisoString
" " :: T.Text)
| Bool
otherwise = MisoString -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
L.toHtmlRaw (MisoString -> MisoString
forall a. FromMisoString a => MisoString -> a
fromMisoString MisoString
x :: T.Text)
collapseSiblingTextNodes :: [View a] -> [View a]
collapseSiblingTextNodes :: [View a] -> [View a]
collapseSiblingTextNodes [] = []
collapseSiblingTextNodes (Text MisoString
x : Text MisoString
y : [View a]
xs) =
[View a] -> [View a]
forall a. [View a] -> [View a]
collapseSiblingTextNodes (MisoString -> View a
forall action. MisoString -> View action
Text (MisoString
x MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
y) View a -> [View a] -> [View a]
forall a. a -> [a] -> [a]
: [View a]
xs)
collapseSiblingTextNodes (View a
x:[View a]
xs) =
View a
x View a -> [View a] -> [View a]
forall a. a -> [a] -> [a]
: [View a] -> [View a]
forall a. [View a] -> [View a]
collapseSiblingTextNodes [View a]
xs
toHtmlFromJSON :: Value -> T.Text
toHtmlFromJSON :: Value -> MisoString
toHtmlFromJSON (A.String MisoString
t) = MisoString
t
toHtmlFromJSON (A.Number Scientific
t) = String -> MisoString
T.pack (Scientific -> String
forall a. Show a => a -> String
show Scientific
t)
toHtmlFromJSON (A.Bool Bool
b) = if Bool
b then MisoString
"true" else MisoString
"false"
toHtmlFromJSON Value
A.Null = MisoString
"null"
toHtmlFromJSON (A.Object Object
o) = String -> MisoString
T.pack (Object -> String
forall a. Show a => a -> String
show Object
o)
toHtmlFromJSON (A.Array Array
a) = String -> MisoString
T.pack (Array -> String
forall a. Show a => a -> String
show Array
a)
newtype VTree = VTree { VTree -> Object
getTree :: Object }
runView :: View action -> Sink action -> JSM VTree
runView :: View action -> Sink action -> JSM VTree
runView (Node NS
ns MisoString
tag Maybe Key
key [Attribute action]
attrs [View action]
kids) Sink action
sink = do
Object
vnode <- JSM Object
create
JSVal
cssObj <- Object -> JSM JSVal
objectToJSVal (Object -> JSM JSVal) -> JSM Object -> JSM JSVal
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSM Object
create
JSVal
propsObj <- Object -> JSM JSVal
objectToJSVal (Object -> JSM JSVal) -> JSM Object -> JSM JSVal
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSM Object
create
JSVal
eventObj <- Object -> JSM JSVal
objectToJSVal (Object -> JSM JSVal) -> JSM Object -> JSM JSVal
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSM Object
create
MisoString -> JSVal -> Object -> JSM ()
forall v. ToJSVal v => MisoString -> v -> Object -> JSM ()
set MisoString
"css" JSVal
cssObj Object
vnode
MisoString -> JSVal -> Object -> JSM ()
forall v. ToJSVal v => MisoString -> v -> Object -> JSM ()
set MisoString
"props" JSVal
propsObj Object
vnode
MisoString -> JSVal -> Object -> JSM ()
forall v. ToJSVal v => MisoString -> v -> Object -> JSM ()
set MisoString
"events" JSVal
eventObj Object
vnode
MisoString -> JSString -> Object -> JSM ()
forall v. ToJSVal v => MisoString -> v -> Object -> JSM ()
set MisoString
"type" (JSString
"vnode" :: JSString) Object
vnode
MisoString -> NS -> Object -> JSM ()
forall v. ToJSVal v => MisoString -> v -> Object -> JSM ()
set MisoString
"ns" NS
ns Object
vnode
MisoString -> MisoString -> Object -> JSM ()
forall v. ToJSVal v => MisoString -> v -> Object -> JSM ()
set MisoString
"tag" MisoString
tag Object
vnode
MisoString -> Maybe Key -> Object -> JSM ()
forall v. ToJSVal v => MisoString -> v -> Object -> JSM ()
set MisoString
"key" Maybe Key
key Object
vnode
Object -> JSM ()
setAttrs Object
vnode
(JSVal -> Object -> JSM ()) -> Object -> JSVal -> JSM ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (MisoString -> JSVal -> Object -> JSM ()
forall v. ToJSVal v => MisoString -> v -> Object -> JSM ()
set MisoString
"children") Object
vnode
(JSVal -> JSM ()) -> JSM JSVal -> JSM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< GHCJSPure JSVal -> JSM JSVal
forall a. GHCJSPure a -> JSM a
ghcjsPure (GHCJSPure JSVal -> JSM JSVal)
-> (SomeJSArray Any -> GHCJSPure JSVal)
-> SomeJSArray Any
-> JSM JSVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeJSArray Any -> GHCJSPure JSVal
forall a. IsJSVal a => a -> GHCJSPure JSVal
jsval
(SomeJSArray Any -> JSM JSVal)
-> JSM (SomeJSArray Any) -> JSM JSVal
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSM (SomeJSArray Any)
setKids
VTree -> JSM VTree
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VTree -> JSM VTree) -> VTree -> JSM VTree
forall a b. (a -> b) -> a -> b
$ Object -> VTree
VTree Object
vnode
where
setAttrs :: Object -> JSM ()
setAttrs Object
vnode =
[Attribute action] -> (Attribute action -> JSM ()) -> JSM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Attribute action]
attrs ((Attribute action -> JSM ()) -> JSM ())
-> (Attribute action -> JSM ()) -> JSM ()
forall a b. (a -> b) -> a -> b
$ \case
P MisoString
k Value
v -> do
JSVal
val <- Value -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal Value
v
JSVal
o <- JSString -> Object -> JSM JSVal
getProp JSString
"props" Object
vnode
MisoString -> JSVal -> Object -> JSM ()
forall v. ToJSVal v => MisoString -> v -> Object -> JSM ()
set MisoString
k JSVal
val (JSVal -> Object
Object JSVal
o)
E Sink action -> Object -> JSM ()
attr -> Sink action -> Object -> JSM ()
attr Sink action
sink Object
vnode
S Map MisoString MisoString
m -> do
JSVal
cssObj <- JSString -> Object -> JSM JSVal
getProp JSString
"css" Object
vnode
[(MisoString, MisoString)]
-> ((MisoString, MisoString) -> JSM ()) -> JSM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map MisoString MisoString -> [(MisoString, MisoString)]
forall k a. Map k a -> [(k, a)]
M.toList Map MisoString MisoString
m) (((MisoString, MisoString) -> JSM ()) -> JSM ())
-> ((MisoString, MisoString) -> JSM ()) -> JSM ()
forall a b. (a -> b) -> a -> b
$ \(MisoString
k,MisoString
v) -> do
MisoString -> MisoString -> Object -> JSM ()
forall v. ToJSVal v => MisoString -> v -> Object -> JSM ()
set MisoString
k MisoString
v (JSVal -> Object
Object JSVal
cssObj)
setKids :: JSM (SomeJSArray Any)
setKids = do
[JSVal]
kidsViews <- (View action -> JSM JSVal) -> [View action] -> JSM [JSVal]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Object -> JSM JSVal
objectToJSVal (Object -> JSM JSVal) -> (VTree -> Object) -> VTree -> JSM JSVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VTree -> Object
getTree (VTree -> JSM JSVal)
-> (View action -> JSM VTree) -> View action -> JSM JSVal
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (View action -> Sink action -> JSM VTree)
-> Sink action -> View action -> JSM VTree
forall a b c. (a -> b -> c) -> b -> a -> c
flip View action -> Sink action -> JSM VTree
forall action. View action -> Sink action -> JSM VTree
runView Sink action
sink) [View action]
kids
GHCJSPure (SomeJSArray Any) -> JSM (SomeJSArray Any)
forall a. GHCJSPure a -> JSM a
ghcjsPure ([JSVal] -> GHCJSPure (SomeJSArray Any)
forall (m :: MutabilityType *).
[JSVal] -> GHCJSPure (SomeJSArray m)
JSArray.fromList [JSVal]
kidsViews)
runView (Text MisoString
t) Sink action
_ = do
Object
vtree <- JSM Object
create
MisoString -> JSString -> Object -> JSM ()
forall v. ToJSVal v => MisoString -> v -> Object -> JSM ()
set MisoString
"type" (JSString
"vtext" :: JSString) Object
vtree
MisoString -> MisoString -> Object -> JSM ()
forall v. ToJSVal v => MisoString -> v -> Object -> JSM ()
set MisoString
"text" MisoString
t Object
vtree
VTree -> JSM VTree
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VTree -> JSM VTree) -> VTree -> JSM VTree
forall a b. (a -> b) -> a -> b
$ Object -> VTree
VTree Object
vtree
runView (TextRaw MisoString
str) Sink action
sink =
case MisoString -> [View action]
forall a. MisoString -> [View a]
parseView MisoString
str of
[] ->
View action -> Sink action -> JSM VTree
forall action. View action -> Sink action -> JSM VTree
runView (MisoString -> View action
forall action. MisoString -> View action
Text (MisoString
" " :: MisoString)) Sink action
sink
[View action
parent] ->
View action -> Sink action -> JSM VTree
forall action. View action -> Sink action -> JSM VTree
runView View action
parent Sink action
sink
[View action]
kids -> do
View action -> Sink action -> JSM VTree
forall action. View action -> Sink action -> JSM VTree
runView (NS
-> MisoString
-> Maybe Key
-> [Attribute action]
-> [View action]
-> View action
forall action.
NS
-> MisoString
-> Maybe Key
-> [Attribute action]
-> [View action]
-> View action
Node NS
HTML MisoString
"div" Maybe Key
forall a. Maybe a
Nothing [Attribute action]
forall a. Monoid a => a
mempty [View action]
kids) Sink action
sink
parseView :: MisoString -> [View a]
parseView :: MisoString -> [View a]
parseView MisoString
html = [View a] -> [View a]
forall a. [a] -> [a]
reverse ([TagTree MisoString] -> [View a] -> [View a]
forall action.
[TagTree MisoString] -> [View action] -> [View action]
go (MisoString -> [TagTree MisoString]
forall str. StringLike str => str -> [TagTree str]
parseTree MisoString
html) [])
where
go :: [TagTree MisoString] -> [View action] -> [View action]
go [] [View action]
xs = [View action]
xs
go (TagLeaf (TagText MisoString
s) : [TagTree MisoString]
next) [View action]
views =
[TagTree MisoString] -> [View action] -> [View action]
go [TagTree MisoString]
next (MisoString -> View action
forall action. MisoString -> View action
Text MisoString
s View action -> [View action] -> [View action]
forall a. a -> [a] -> [a]
: [View action]
views)
go (TagBranch MisoString
name [(MisoString, MisoString)]
attrs [TagTree MisoString]
kids : [TagTree MisoString]
next) [View action]
views =
let
attrs' :: [Attribute action]
attrs' = [ MisoString -> Value -> Attribute action
forall action. MisoString -> Value -> Attribute action
P MisoString
key (Value -> Attribute action) -> Value -> Attribute action
forall a b. (a -> b) -> a -> b
$ MisoString -> Value
A.String (MisoString -> MisoString
forall a. FromMisoString a => MisoString -> a
fromMisoString MisoString
val)
| (MisoString
key, MisoString
val) <- [(MisoString, MisoString)]
attrs
]
newNode :: View action
newNode =
NS
-> MisoString
-> Maybe Key
-> [Attribute action]
-> [View action]
-> View action
forall action.
NS
-> MisoString
-> Maybe Key
-> [Attribute action]
-> [View action]
-> View action
Node NS
HTML MisoString
name Maybe Key
forall a. Maybe a
Nothing [Attribute action]
attrs' ([View action] -> [View action]
forall a. [a] -> [a]
reverse ([TagTree MisoString] -> [View action] -> [View action]
go [TagTree MisoString]
kids []))
in
[TagTree MisoString] -> [View action] -> [View action]
go [TagTree MisoString]
next (View action
newNodeView action -> [View action] -> [View action]
forall a. a -> [a] -> [a]
:[View action]
views)
go (TagLeaf Tag MisoString
_ : [TagTree MisoString]
next) [View action]
views =
[TagTree MisoString] -> [View action] -> [View action]
go [TagTree MisoString]
next [View action]
views
data NS
= HTML
| SVG
| MATHML
deriving (Int -> NS -> ShowS
[NS] -> ShowS
NS -> String
(Int -> NS -> ShowS)
-> (NS -> String) -> ([NS] -> ShowS) -> Show NS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NS] -> ShowS
$cshowList :: [NS] -> ShowS
show :: NS -> String
$cshow :: NS -> String
showsPrec :: Int -> NS -> ShowS
$cshowsPrec :: Int -> NS -> ShowS
Show, NS -> NS -> Bool
(NS -> NS -> Bool) -> (NS -> NS -> Bool) -> Eq NS
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NS -> NS -> Bool
$c/= :: NS -> NS -> Bool
== :: NS -> NS -> Bool
$c== :: NS -> NS -> Bool
Eq)
instance ToJSVal NS where
toJSVal :: NS -> JSM JSVal
toJSVal NS
SVG = JSString -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal (JSString
"svg" :: JSString)
toJSVal NS
HTML = JSString -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal (JSString
"html" :: JSString)
toJSVal NS
MATHML = JSString -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal (JSString
"mathml" :: JSString)
newtype Key = Key MisoString
instance ToJSVal Key where toJSVal :: Key -> JSM JSVal
toJSVal (Key MisoString
x) = MisoString -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal MisoString
x
class ToKey key where toKey :: key -> Key
instance ToKey Key where toKey :: Key -> Key
toKey = Key -> Key
forall a. a -> a
id
instance ToKey JSString where toKey :: JSString -> Key
toKey = MisoString -> Key
Key (MisoString -> Key) -> (JSString -> MisoString) -> JSString -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSString -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString
instance ToKey T.Text where toKey :: MisoString -> Key
toKey = MisoString -> Key
Key (MisoString -> Key)
-> (MisoString -> MisoString) -> MisoString -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MisoString -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString
instance ToKey String where toKey :: String -> Key
toKey = MisoString -> Key
Key (MisoString -> Key) -> (String -> MisoString) -> String -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString
instance ToKey Int where toKey :: Int -> Key
toKey = MisoString -> Key
Key (MisoString -> Key) -> (Int -> MisoString) -> Int -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString
instance ToKey Double where toKey :: Double -> Key
toKey = MisoString -> Key
Key (MisoString -> Key) -> (Double -> MisoString) -> Double -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString
instance ToKey Float where toKey :: Float -> Key
toKey = MisoString -> Key
Key (MisoString -> Key) -> (Float -> MisoString) -> Float -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString
instance ToKey Word where toKey :: Word -> Key
toKey = MisoString -> Key
Key (MisoString -> Key) -> (Word -> MisoString) -> Word -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString
data Attribute action
= P MisoString Value
| E (Sink action -> Object -> JSM ())
| S (M.Map MisoString MisoString)
deriving a -> Attribute b -> Attribute a
(a -> b) -> Attribute a -> Attribute b
(forall a b. (a -> b) -> Attribute a -> Attribute b)
-> (forall a b. a -> Attribute b -> Attribute a)
-> Functor Attribute
forall a b. a -> Attribute b -> Attribute a
forall a b. (a -> b) -> Attribute a -> Attribute b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Attribute b -> Attribute a
$c<$ :: forall a b. a -> Attribute b -> Attribute a
fmap :: (a -> b) -> Attribute a -> Attribute b
$cfmap :: forall a b. (a -> b) -> Attribute a -> Attribute b
Functor
prop :: ToJSON a => MisoString -> a -> Attribute action
prop :: MisoString -> a -> Attribute action
prop MisoString
k a
v = MisoString -> Value -> Attribute action
forall action. MisoString -> Value -> Attribute action
P MisoString
k (a -> Value
forall a. ToJSON a => a -> Value
toJSON a
v)
on :: MisoString
-> Decoder r
-> (r -> action)
-> Attribute action
on :: MisoString -> Decoder r -> (r -> action) -> Attribute action
on = Options
-> MisoString -> Decoder r -> (r -> action) -> Attribute action
forall r action.
Options
-> MisoString -> Decoder r -> (r -> action) -> Attribute action
onWithOptions Options
defaultOptions
onWithOptions
:: Options
-> MisoString
-> Decoder r
-> (r -> action)
-> Attribute action
onWithOptions :: Options
-> MisoString -> Decoder r -> (r -> action) -> Attribute action
onWithOptions Options
options MisoString
eventName Decoder{DecodeTarget
Value -> Parser r
decodeAt :: forall a. Decoder a -> DecodeTarget
decoder :: forall a. Decoder a -> Value -> Parser a
decodeAt :: DecodeTarget
decoder :: Value -> Parser r
..} r -> action
toAction =
(Sink action -> Object -> JSM ()) -> Attribute action
forall action.
(Sink action -> Object -> JSM ()) -> Attribute action
E ((Sink action -> Object -> JSM ()) -> Attribute action)
-> (Sink action -> Object -> JSM ()) -> Attribute action
forall a b. (a -> b) -> a -> b
$ \Sink action
sink Object
n -> do
JSVal
eventObj <- JSString -> Object -> JSM JSVal
getProp JSString
"events" Object
n
eventHandlerObject :: Object
eventHandlerObject@(Object JSVal
eo) <- JSM Object
create
JSVal
jsOptions <- Options -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal Options
options
JSVal
decodeAtVal <- DecodeTarget -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal DecodeTarget
decodeAt
JSVal
cb <- Function -> JSM JSVal
callbackToJSVal (Function -> JSM JSVal)
-> ((JSVal -> JSM ()) -> JSM Function)
-> (JSVal -> JSM ())
-> JSM JSVal
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (JSVal -> JSM ()) -> JSM Function
asyncCallback1 ((JSVal -> JSM ()) -> JSM JSVal) -> (JSVal -> JSM ()) -> JSM JSVal
forall a b. (a -> b) -> a -> b
$ \JSVal
e -> do
Just Value
v <- JSVal -> JSM (Maybe Value)
forall a. FromJSVal a => JSVal -> JSM (Maybe a)
fromJSVal (JSVal -> JSM (Maybe Value)) -> JSM JSVal -> JSM (Maybe Value)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSVal -> JSVal -> JSM JSVal
objectToJSON JSVal
decodeAtVal JSVal
e
case (Value -> Parser r) -> Value -> Either String r
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Value -> Parser r
decoder Value
v of
Left String
s -> String -> JSM ()
forall a. HasCallStack => String -> a
error (String -> JSM ()) -> String -> JSM ()
forall a b. (a -> b) -> a -> b
$ String
"Parse error on " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> MisoString -> String
unpack MisoString
eventName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
s
Right r
r -> IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Sink action
sink (r -> action
toAction r
r))
MisoString -> JSVal -> Object -> JSM ()
forall v. ToJSVal v => MisoString -> v -> Object -> JSM ()
set MisoString
"runEvent" JSVal
cb Object
eventHandlerObject
JSVal -> JSM ()
registerCallback JSVal
cb
MisoString -> JSVal -> Object -> JSM ()
forall v. ToJSVal v => MisoString -> v -> Object -> JSM ()
set MisoString
"options" JSVal
jsOptions Object
eventHandlerObject
MisoString -> JSVal -> Object -> JSM ()
forall v. ToJSVal v => MisoString -> v -> Object -> JSM ()
set MisoString
eventName JSVal
eo (JSVal -> Object
Object JSVal
eventObj)
onCreated :: action -> Attribute action
onCreated :: action -> Attribute action
onCreated action
action =
(Sink action -> Object -> JSM ()) -> Attribute action
forall action.
(Sink action -> Object -> JSM ()) -> Attribute action
E ((Sink action -> Object -> JSM ()) -> Attribute action)
-> (Sink action -> Object -> JSM ()) -> Attribute action
forall a b. (a -> b) -> a -> b
$ \Sink action
sink Object
n -> do
JSVal
cb <- Function -> JSM JSVal
callbackToJSVal (Function -> JSM JSVal) -> JSM Function -> JSM JSVal
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSM () -> JSM Function
asyncCallback (IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Sink action
sink action
action))
MisoString -> JSVal -> Object -> JSM ()
forall v. ToJSVal v => MisoString -> v -> Object -> JSM ()
set MisoString
"onCreated" JSVal
cb Object
n
JSVal -> JSM ()
registerCallback JSVal
cb
onDestroyed :: action -> Attribute action
onDestroyed :: action -> Attribute action
onDestroyed action
action =
(Sink action -> Object -> JSM ()) -> Attribute action
forall action.
(Sink action -> Object -> JSM ()) -> Attribute action
E ((Sink action -> Object -> JSM ()) -> Attribute action)
-> (Sink action -> Object -> JSM ()) -> Attribute action
forall a b. (a -> b) -> a -> b
$ \Sink action
sink Object
n -> do
JSVal
cb <- Function -> JSM JSVal
callbackToJSVal (Function -> JSM JSVal) -> JSM Function -> JSM JSVal
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSM () -> JSM Function
asyncCallback (IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Sink action
sink action
action))
MisoString -> JSVal -> Object -> JSM ()
forall v. ToJSVal v => MisoString -> v -> Object -> JSM ()
set MisoString
"onDestroyed" JSVal
cb Object
n
JSVal -> JSM ()
registerCallback JSVal
cb
onBeforeDestroyed :: action -> Attribute action
onBeforeDestroyed :: action -> Attribute action
onBeforeDestroyed action
action =
(Sink action -> Object -> JSM ()) -> Attribute action
forall action.
(Sink action -> Object -> JSM ()) -> Attribute action
E ((Sink action -> Object -> JSM ()) -> Attribute action)
-> (Sink action -> Object -> JSM ()) -> Attribute action
forall a b. (a -> b) -> a -> b
$ \Sink action
sink Object
n -> do
JSVal
cb <- Function -> JSM JSVal
callbackToJSVal (Function -> JSM JSVal) -> JSM Function -> JSM JSVal
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSM () -> JSM Function
asyncCallback (IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Sink action
sink action
action))
MisoString -> JSVal -> Object -> JSM ()
forall v. ToJSVal v => MisoString -> v -> Object -> JSM ()
set MisoString
"onBeforeDestroyed" JSVal
cb Object
n
JSVal -> JSM ()
registerCallback JSVal
cb
style_ :: M.Map MisoString MisoString -> Attribute action
style_ :: Map MisoString MisoString -> Attribute action
style_ = Map MisoString MisoString -> Attribute action
forall action. Map MisoString MisoString -> Attribute action
S