{-# LANGUAGE CPP                  #-}
{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE DeriveFunctor        #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE RecordWildCards      #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE UndecidableInstances #-}

module Miso.Html.Types (
    -- * Core types and interface
      VTree  (..)
    , View   (..)
    , ToView (..)
    -- * `View` runner
    , runView
    -- * Smart `View` constructors
    , node
    , text
    , textRaw
    , rawHtml
    -- * Core types and interface
    , Attribute (..)
    -- * Key patch internals
    , Key    (..)
    , ToKey  (..)
    -- * Namespace
    , NS(..)
    -- * Setting properties on virtual DOM nodes
    , prop
    -- * Setting css
    , style_
    -- * Handling events
    , on
    , onWithOptions
    -- * Life cycle events
    , 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, elem)

-- | Core type for constructing a `VTree`, use this instead of `VTree` directly.
data View action
    = Node NS MisoString (Maybe Key) [Attribute action] [View action]
    | Text MisoString
    | TextRaw MisoString
    deriving (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
$cfmap :: forall a b. (a -> b) -> View a -> View b
fmap :: forall a b. (a -> b) -> View a -> View b
$c<$ :: forall a b. a -> View b -> View a
<$ :: forall a b. a -> View b -> View a
Functor

-- | For constructing type-safe links
instance HasLink (View a) where
#if MIN_VERSION_servant(0,14,0)
  type MkLink (View a) b = MkLink (Get '[] ()) b
  toLink :: forall a.
(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 a.
(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

-- | Convenience class for using View
class ToView v where toView :: v -> View action

-- | Create a new @Miso.Html.Types.TextRaw@.
--
-- @expandable@
-- a 'rawHtml' node takes raw HTML and attempts to convert it to a 'VTree'
-- at runtime. This is a way to dynamically populate the virtual DOM from
-- HTML received at runtime. If rawHtml cannot parse the HTML it will not render.
rawHtml
  :: MisoString
  -> View action
rawHtml :: forall action. Text -> View action
rawHtml = Text -> View action
forall action. Text -> View action
TextRaw


-- | Create a new @Miso.Html.Types.Node@.
--
-- @node ns tag key attrs children@ creates a new node with tag @tag@
-- and 'Key' @key@ in the namespace @ns@. All @attrs@ are called when
-- the node is created and its children are initialized to @children@.
node :: NS
     -> MisoString
     -> Maybe Key
     -> [Attribute action]
     -> [View action]
     -> View action
node :: forall action.
NS
-> Text
-> Maybe Key
-> [Attribute action]
-> [View action]
-> View action
node = NS
-> Text
-> Maybe Key
-> [Attribute action]
-> [View action]
-> View action
forall action.
NS
-> Text
-> Maybe Key
-> [Attribute action]
-> [View action]
-> View action
Node

-- | Create a new @Text@ with the given content.
text :: MisoString -> View action
text :: forall action. Text -> View action
text = Text -> View action
forall action. Text -> View action
Text

-- | `TextRaw` creation. Don't use directly
textRaw :: MisoString -> View action
textRaw :: forall action. Text -> View action
textRaw = Text -> View action
forall action. Text -> View action
TextRaw

-- | `IsString` instance
instance IsString (View a) where
  fromString :: String -> View a
fromString = Text -> View a
forall action. Text -> View action
text (Text -> View a) -> (String -> Text) -> String -> View a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
fromString

-- | Converting `View` to Lucid's `L.Html`
instance L.ToHtml (View action) where
  toHtmlRaw :: forall (m :: * -> *). Monad m => View action -> HtmlT m ()
toHtmlRaw = View action -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => View action -> HtmlT m ()
L.toHtml
  toHtml :: forall (m :: * -> *). Monad m => View action -> HtmlT m ()
toHtml (Node NS
_ Text
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 :: [Text]
noEnd = [Text
"img", Text
"input", Text
"br", Text
"hr", Text
"meta"]
      tag :: Text
tag = Text -> Text
toTag (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
forall a. FromMisoString a => Text -> a
fromMisoString Text
vType
      ele :: HtmlT m ()
ele = if Text
tag Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
noEnd
          then Text -> HtmlT m ()
forall (m :: * -> *). Applicative m => Text -> HtmlT m ()
L.makeElementNoEnd Text
tag
          else Text -> HtmlT m () -> HtmlT m ()
forall (m :: * -> *) a. Functor m => Text -> HtmlT m a -> HtmlT m a
L.makeElement Text
tag HtmlT m ()
kids
      classes :: Text
classes = Text -> [Text] -> Text
T.intercalate Text
" " [ Text
v | P Text
"class" (A.String Text
v) <- [Attribute action]
attrs ]
      propClass :: Map Text Value
propClass = [(Text, Value)] -> Map Text Value
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Text, Value)] -> Map Text Value)
-> [(Text, Value)] -> Map Text Value
forall a b. (a -> b) -> a -> b
$ [Attribute action]
attrs [Attribute action]
-> (Attribute action -> [(Text, Value)]) -> [(Text, Value)]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          P Text
k Value
v -> [(Text
k, Value
v)]
          E Sink action -> Object -> JSM ()
_ -> []
          S Map Text Text
m -> [(Text
"style", Text -> Value
A.String (Text -> Value) -> (Text -> Text) -> Text -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
forall a. FromMisoString a => Text -> a
fromMisoString (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ (Text -> Text -> Text -> Text) -> Text -> Map Text Text -> Text
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey Text -> Text -> Text -> Text
go Text
forall a. Monoid a => a
mempty Map Text Text
m)]
            where
              go :: MisoString -> MisoString -> MisoString -> MisoString
              go :: Text -> Text -> Text -> Text
go Text
k Text
v Text
ys = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [ Text
k, Text
":", Text
v, Text
";" ] Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ys
      xs :: Map Text Value
xs = if Bool -> Bool
not (Text -> Bool
T.null Text
classes)
          then Text -> Value -> Map Text Value -> Map Text Value
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
"class" (Text -> Value
A.String Text
classes) Map Text Value
propClass
          else Map Text Value
propClass
      lattrs :: [Attribute]
lattrs = [ Text -> Text -> Attribute
L.makeAttribute Text
k' (if Text
k Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
exceptions Bool -> Bool -> Bool
&& Value
v Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Value
A.Bool Bool
True then Text
k' else Text
v')
               | (Text
k,Value
v) <- Map Text Value -> [(Text, Value)]
forall k a. Map k a -> [(k, a)]
M.toList Map Text Value
xs
               , let k' :: Text
k' = Text -> Text
forall a. FromMisoString a => Text -> a
fromMisoString Text
k
               , let v' :: Text
v' = Value -> Text
toHtmlFromJSON Value
v
               , Bool -> Bool
not (Text
k Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
exceptions Bool -> Bool -> Bool
&& Value
v Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Value
A.Bool Bool
False)
               ]
      exceptions :: [Text]
exceptions = [ Text
"checked"
                   , Text
"disabled"
                   , Text
"selected"
                   , Text
"hidden"
                   , Text
"readOnly"
                   , Text
"autoplay"
                   , Text
"required"
                   , Text
"default"
                   , Text
"autofocus"
                   , Text
"multiple"
                   , Text
"noValidate"
                   , Text
"autocomplete"
                   ]
      toTag :: Text -> Text
toTag = Text -> Text
T.toLower
      kids :: HtmlT m ()
kids = (View action -> HtmlT m ()) -> [View action] -> HtmlT m ()
forall m a. Monoid m => (a -> m) -> [a] -> 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 ()
forall (m :: * -> *). Monad m => View action -> 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 Text
x) | Text -> Bool
null Text
x = Text -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
L.toHtml (Text
" " :: T.Text)
                  | Bool
otherwise = Text -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
L.toHtml (Text -> Text
forall a. FromMisoString a => Text -> a
fromMisoString Text
x :: T.Text)
  toHtml (TextRaw Text
x)
    | Text -> Bool
null Text
x = Text -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
L.toHtml (Text
" " :: T.Text)
    | Bool
otherwise = Text -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
L.toHtmlRaw (Text -> Text
forall a. FromMisoString a => Text -> a
fromMisoString Text
x :: T.Text)

collapseSiblingTextNodes :: [View a] -> [View a]
collapseSiblingTextNodes :: forall a. [View a] -> [View a]
collapseSiblingTextNodes [] = []
collapseSiblingTextNodes (Text Text
x : Text Text
y : [View a]
xs) =
  [View a] -> [View a]
forall a. [View a] -> [View a]
collapseSiblingTextNodes (Text -> View a
forall action. Text -> View action
Text (Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
y) View a -> [View a] -> [View a]
forall a. a -> [a] -> [a]
: [View a]
xs)
-- TextRaw is the only child, so no need to collapse.
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

-- | Helper for turning JSON into Text
-- Object, Array and Null are kind of non-sensical here
toHtmlFromJSON :: Value -> T.Text
toHtmlFromJSON :: Value -> Text
toHtmlFromJSON (A.String Text
t) = Text
t
toHtmlFromJSON (A.Number Scientific
t) = String -> Text
T.pack (Scientific -> String
forall a. Show a => a -> String
show Scientific
t)
toHtmlFromJSON (A.Bool Bool
b) = if Bool
b then Text
"true" else Text
"false"
toHtmlFromJSON Value
A.Null = Text
"null"
toHtmlFromJSON (A.Object Object
o) = String -> Text
T.pack (Object -> String
forall a. Show a => a -> String
show Object
o)
toHtmlFromJSON (A.Array Array
a) = String -> Text
T.pack (Array -> String
forall a. Show a => a -> String
show Array
a)

-- | Virtual DOM implemented as a JavaScript `Object`.
--   Used for diffing, patching and event delegation.
--   Not meant to be constructed directly, see `View` instead.
newtype VTree = VTree { VTree -> Object
getTree :: Object }

runView :: View action -> Sink action -> JSM VTree
runView :: forall action. View action -> Sink action -> JSM VTree
runView (Node NS
ns Text
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
  Text -> JSVal -> Object -> JSM ()
forall v. ToJSVal v => Text -> v -> Object -> JSM ()
set Text
"css" JSVal
cssObj Object
vnode
  Text -> JSVal -> Object -> JSM ()
forall v. ToJSVal v => Text -> v -> Object -> JSM ()
set Text
"props" JSVal
propsObj Object
vnode
  Text -> JSVal -> Object -> JSM ()
forall v. ToJSVal v => Text -> v -> Object -> JSM ()
set Text
"events" JSVal
eventObj Object
vnode
  Text -> JSString -> Object -> JSM ()
forall v. ToJSVal v => Text -> v -> Object -> JSM ()
set Text
"type" (JSString
"vnode" :: JSString) Object
vnode
  Text -> NS -> Object -> JSM ()
forall v. ToJSVal v => Text -> v -> Object -> JSM ()
set Text
"ns" NS
ns Object
vnode
  Text -> Text -> Object -> JSM ()
forall v. ToJSVal v => Text -> v -> Object -> JSM ()
set Text
"tag" Text
tag Object
vnode
  Text -> Maybe Key -> Object -> JSM ()
forall v. ToJSVal v => Text -> v -> Object -> JSM ()
set Text
"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 (Text -> JSVal -> Object -> JSM ()
forall v. ToJSVal v => Text -> v -> Object -> JSM ()
set Text
"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 a. a -> JSM a
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 Text
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
            Text -> JSVal -> Object -> JSM ()
forall v. ToJSVal v => Text -> v -> Object -> JSM ()
set Text
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 Text Text
m -> do
            JSVal
cssObj <- JSString -> Object -> JSM JSVal
getProp JSString
"css" Object
vnode
            [(Text, Text)] -> ((Text, Text) -> JSM ()) -> JSM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map Text Text -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
M.toList Map Text Text
m) (((Text, Text) -> JSM ()) -> JSM ())
-> ((Text, Text) -> JSM ()) -> JSM ()
forall a b. (a -> b) -> a -> b
$ \(Text
k,Text
v) -> do
              Text -> Text -> Object -> JSM ()
forall v. ToJSVal v => Text -> v -> Object -> JSM ()
set Text
k Text
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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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 Text
t) Sink action
_ = do
  Object
vtree <- JSM Object
create
  Text -> JSString -> Object -> JSM ()
forall v. ToJSVal v => Text -> v -> Object -> JSM ()
set Text
"type" (JSString
"vtext" :: JSString) Object
vtree
  Text -> Text -> Object -> JSM ()
forall v. ToJSVal v => Text -> v -> Object -> JSM ()
set Text
"text" Text
t Object
vtree
  VTree -> JSM VTree
forall a. a -> JSM a
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 Text
str) Sink action
sink =
  case Text -> [View action]
forall a. Text -> [View a]
parseView Text
str of
    [] ->
      View action -> Sink action -> JSM VTree
forall action. View action -> Sink action -> JSM VTree
runView (Text -> View action
forall action. Text -> View action
Text (Text
" " :: 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
-> Text
-> Maybe Key
-> [Attribute action]
-> [View action]
-> View action
forall action.
NS
-> Text
-> Maybe Key
-> [Attribute action]
-> [View action]
-> View action
Node NS
HTML Text
"div" Maybe Key
forall a. Maybe a
Nothing [Attribute action]
forall a. Monoid a => a
mempty [View action]
kids) Sink action
sink

-- Filters tree to only branches and leaves w/ Text tags.
-- converts to View a. Note: if HTML is malformed,
-- (e.g. closing tags and opening tags are present) they will
-- be removed.
parseView :: MisoString -> [View a]
parseView :: forall a. Text -> [View a]
parseView Text
html = [View a] -> [View a]
forall a. [a] -> [a]
reverse ([TagTree Text] -> [View a] -> [View a]
forall {action}. [TagTree Text] -> [View action] -> [View action]
go (Text -> [TagTree Text]
forall str. StringLike str => str -> [TagTree str]
parseTree Text
html) [])
  where
    go :: [TagTree Text] -> [View action] -> [View action]
go [] [View action]
xs = [View action]
xs
    go (TagLeaf (TagText Text
s) : [TagTree Text]
next) [View action]
views =
      [TagTree Text] -> [View action] -> [View action]
go [TagTree Text]
next (Text -> View action
forall action. Text -> View action
Text Text
s View action -> [View action] -> [View action]
forall a. a -> [a] -> [a]
: [View action]
views)
    go (TagLeaf (TagOpen Text
name [(Text, Text)]
attrs) : [TagTree Text]
next) [View action]
views =
      [TagTree Text] -> [View action] -> [View action]
go (Text -> [(Text, Text)] -> [TagTree Text] -> TagTree Text
forall str. str -> [Attribute str] -> [TagTree str] -> TagTree str
TagBranch Text
name [(Text, Text)]
attrs [] TagTree Text -> [TagTree Text] -> [TagTree Text]
forall a. a -> [a] -> [a]
: [TagTree Text]
next) [View action]
views
    go (TagBranch Text
name [(Text, Text)]
attrs [TagTree Text]
kids : [TagTree Text]
next) [View action]
views =
      let
        attrs' :: [Attribute action]
attrs' = [ Text -> Value -> Attribute action
forall action. Text -> Value -> Attribute action
P Text
key (Value -> Attribute action) -> Value -> Attribute action
forall a b. (a -> b) -> a -> b
$ Text -> Value
A.String (Text -> Text
forall a. FromMisoString a => Text -> a
fromMisoString Text
val)
                 | (Text
key, Text
val) <- [(Text, Text)]
attrs
                 ]
        newNode :: View action
newNode =
          NS
-> Text
-> Maybe Key
-> [Attribute action]
-> [View action]
-> View action
forall action.
NS
-> Text
-> Maybe Key
-> [Attribute action]
-> [View action]
-> View action
Node NS
HTML Text
name Maybe Key
forall a. Maybe a
Nothing [Attribute action]
attrs' ([View action] -> [View action]
forall a. [a] -> [a]
reverse ([TagTree Text] -> [View action] -> [View action]
go [TagTree Text]
kids []))
      in
        [TagTree Text] -> [View action] -> [View action]
go [TagTree Text]
next (View action
newNodeView action -> [View action] -> [View action]
forall a. a -> [a] -> [a]
:[View action]
views)
    go (TagLeaf Tag Text
_ : [TagTree Text]
next) [View action]
views =
      [TagTree Text] -> [View action] -> [View action]
go [TagTree Text]
next [View action]
views

-- | Namespace of DOM elements.
data NS
  = HTML -- ^ HTML Namespace
  | SVG  -- ^ SVG Namespace
  | MATHML  -- ^ MATHML Namespace
  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
$cshowsPrec :: Int -> NS -> ShowS
showsPrec :: Int -> NS -> ShowS
$cshow :: NS -> String
show :: NS -> String
$cshowList :: [NS] -> ShowS
showList :: [NS] -> ShowS
Show, NS -> NS -> Bool
(NS -> NS -> Bool) -> (NS -> NS -> Bool) -> Eq NS
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NS -> NS -> Bool
== :: NS -> NS -> Bool
$c/= :: NS -> NS -> Bool
/= :: 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)

-- | A unique key for a dom node.
--
-- This key is only used to speed up diffing the children of a DOM
-- node, the actual content is not important. The keys of the children
-- of a given DOM node must be unique. Failure to satisfy this
-- invariant gives undefined behavior at runtime.
newtype Key = Key MisoString

instance ToJSVal Key where toJSVal :: Key -> JSM JSVal
toJSVal (Key Text
x) = Text -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal Text
x

-- | Convert custom key types to `Key`.
--
-- Instances of this class do not have to guarantee uniqueness of the
-- generated keys, it is up to the user to do so. `toKey` must be an
-- injective function.
class ToKey key where toKey :: key -> Key
-- | Identity instance
instance ToKey Key where toKey :: Key -> Key
toKey = Key -> Key
forall a. a -> a
id
-- | Convert `MisoString` to `Key`
instance ToKey JSString where toKey :: JSString -> Key
toKey = Text -> Key
Key (Text -> Key) -> (JSString -> Text) -> JSString -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSString -> Text
forall str. ToMisoString str => str -> Text
toMisoString
-- | Convert `T.Text` to `Key`
instance ToKey T.Text where toKey :: Text -> Key
toKey = Text -> Key
Key (Text -> Key) -> (Text -> Text) -> Text -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
forall str. ToMisoString str => str -> Text
toMisoString
-- | Convert `String` to `Key`
instance ToKey String where toKey :: String -> Key
toKey = Text -> Key
Key (Text -> Key) -> (String -> Text) -> String -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall str. ToMisoString str => str -> Text
toMisoString
-- | Convert `Int` to `Key`
instance ToKey Int where toKey :: Int -> Key
toKey = Text -> Key
Key (Text -> Key) -> (Int -> Text) -> Int -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text
forall str. ToMisoString str => str -> Text
toMisoString
-- | Convert `Double` to `Key`
instance ToKey Double where toKey :: Double -> Key
toKey = Text -> Key
Key (Text -> Key) -> (Double -> Text) -> Double -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Text
forall str. ToMisoString str => str -> Text
toMisoString
-- | Convert `Float` to `Key`
instance ToKey Float where toKey :: Float -> Key
toKey = Text -> Key
Key (Text -> Key) -> (Float -> Text) -> Float -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Text
forall str. ToMisoString str => str -> Text
toMisoString
-- | Convert `Word` to `Key`
instance ToKey Word where toKey :: Word -> Key
toKey = Text -> Key
Key (Text -> Key) -> (Word -> Text) -> Word -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Text
forall str. ToMisoString str => str -> Text
toMisoString

-- | Attribute of a vnode in a `View`.
--
-- The 'Sink' callback can be used to dispatch actions which are fed back to
-- the @update@ function. This is especially useful for event handlers
-- like the @onclick@ attribute. The second argument represents the
-- vnode the attribute is attached to.
data Attribute action
    = P MisoString Value
    | E (Sink action -> Object -> JSM ())
    | S (M.Map MisoString MisoString)
    deriving (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
$cfmap :: forall a b. (a -> b) -> Attribute a -> Attribute b
fmap :: forall a b. (a -> b) -> Attribute a -> Attribute b
$c<$ :: forall a b. a -> Attribute b -> Attribute a
<$ :: forall a b. a -> Attribute b -> Attribute a
Functor

-- | @prop k v@ is an attribute that will set the attribute @k@ of the DOM node associated with the vnode
-- to @v@.
prop :: ToJSON a => MisoString -> a -> Attribute action
prop :: forall a action. ToJSON a => Text -> a -> Attribute action
prop Text
k a
v = Text -> Value -> Attribute action
forall action. Text -> Value -> Attribute action
P Text
k (a -> Value
forall a. ToJSON a => a -> Value
toJSON a
v)

-- | Convenience wrapper for @onWithOptions defaultOptions@.
--
-- > let clickHandler = on "click" emptyDecoder $ \() -> Action
-- > in button_ [ clickHandler, class_ "add" ] [ text_ "+" ]
--
on :: MisoString
   -> Decoder r
   -> (r -> action)
   -> Attribute action
on :: forall r action.
Text -> Decoder r -> (r -> action) -> Attribute action
on = Options -> Text -> Decoder r -> (r -> action) -> Attribute action
forall r action.
Options -> Text -> Decoder r -> (r -> action) -> Attribute action
onWithOptions Options
defaultOptions

-- | @onWithOptions opts eventName decoder toAction@ is an attribute
-- that will set the event handler of the associated DOM node to a function that
-- decodes its argument using @decoder@, converts it to an action
-- using @toAction@ and then feeds that action back to the @update@ function.
--
-- @opts@ can be used to disable further event propagation.
--
-- > let clickHandler = onWithOptions defaultOptions "click" emptyDecoder $ \() -> Action
-- > in button_ [ clickHandler, class_ "add" ] [ text_ "+" ]
--
onWithOptions
  :: Options
  -> MisoString
  -> Decoder r
  -> (r -> action)
  -> Attribute action
onWithOptions :: forall r action.
Options -> Text -> Decoder r -> (r -> action) -> Attribute action
onWithOptions Options
options Text
eventName Decoder{DecodeTarget
Value -> Parser r
decoder :: Value -> Parser r
decodeAt :: DecodeTarget
decoder :: forall a. Decoder a -> Value -> Parser a
decodeAt :: forall a. Decoder a -> DecodeTarget
..} 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
<> Text -> String
unpack Text
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 a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Sink action
sink (r -> action
toAction r
r))
   Text -> JSVal -> Object -> JSM ()
forall v. ToJSVal v => Text -> v -> Object -> JSM ()
set Text
"runEvent" JSVal
cb Object
eventHandlerObject
   JSVal -> JSM ()
registerCallback JSVal
cb
   Text -> JSVal -> Object -> JSM ()
forall v. ToJSVal v => Text -> v -> Object -> JSM ()
set Text
"options" JSVal
jsOptions Object
eventHandlerObject
   Text -> JSVal -> Object -> JSM ()
forall v. ToJSVal v => Text -> v -> Object -> JSM ()
set Text
eventName JSVal
eo (JSVal -> Object
Object JSVal
eventObj)

-- | @onCreated action@ is an event that gets called after the actual DOM
-- element is created.
--
-- Important note: Any node that uses this event MUST have a unique @Key@,
-- otherwise the event may not be reliably called!
onCreated :: action -> Attribute action
onCreated :: forall action. 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 a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Sink action
sink action
action))
    Text -> JSVal -> Object -> JSM ()
forall v. ToJSVal v => Text -> v -> Object -> JSM ()
set Text
"onCreated" JSVal
cb Object
n
    JSVal -> JSM ()
registerCallback JSVal
cb

-- | @onDestroyed action@ is an event that gets called after the DOM element
-- is removed from the DOM. The @action@ is given the DOM element that was
-- removed from the DOM tree.
--
-- Important note: Any node that uses this event MUST have a unique @Key@,
-- otherwise the event may not be reliably called!
onDestroyed :: action -> Attribute action
onDestroyed :: forall action. 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 a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Sink action
sink action
action))
    Text -> JSVal -> Object -> JSM ()
forall v. ToJSVal v => Text -> v -> Object -> JSM ()
set Text
"onDestroyed" JSVal
cb Object
n
    JSVal -> JSM ()
registerCallback JSVal
cb

-- | @onBeforeDestroyed action@ is an event that gets called before the DOM element
-- is removed from the DOM. The @action@ is given the DOM element that was
-- removed from the DOM tree.
--
-- Important note: Any node that uses this event MUST have a unique @Key@,
-- otherwise the event may not be reliably called!
onBeforeDestroyed :: action -> Attribute action
onBeforeDestroyed :: forall action. 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 a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Sink action
sink action
action))
    Text -> JSVal -> Object -> JSM ()
forall v. ToJSVal v => Text -> v -> Object -> JSM ()
set Text
"onBeforeDestroyed" JSVal
cb Object
n
    JSVal -> JSM ()
registerCallback JSVal
cb

-- | @style_ attrs@ is an attribute that will set the @style@
-- attribute of the associated DOM node to @attrs@.
--
-- @style@ attributes not contained in @attrs@ will be deleted.
--
-- > import qualified Data.Map as M
-- > div_ [ style_  $ M.singleton "background" "red" ] [ ]
--
-- <https://developer.mozilla.org/en-US/docs/Web/CSS>
--
style_ :: M.Map MisoString MisoString -> Attribute action
style_ :: forall action. Map Text Text -> Attribute action
style_ = Map Text Text -> Attribute action
forall action. Map Text Text -> Attribute action
S