{-# 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)

-- | 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 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

-- | 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 :: (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

-- | 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 :: MisoString -> View action
rawHtml = MisoString -> View action
forall action. MisoString -> 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 :: 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

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

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

-- | `IsString` instance
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

-- | Converting `View` to Lucid's `L.Html`
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)
-- 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 -> 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)

-- | 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 :: 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

-- 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 :: 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

-- | 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
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)

-- | 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 MisoString
x) = MisoString -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal MisoString
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 = 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
-- | Convert `T.Text` to `Key`
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
-- | Convert `String` to `Key`
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
-- | Convert `Int` to `Key`
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
-- | Convert `Double` to `Key`
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
-- | Convert `Float` to `Key`
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
-- | Convert `Word` to `Key`
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

-- | 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 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 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 :: 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)

-- | 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 :: 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 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 :: 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@ 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 :: 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@ 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 :: 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@ 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 :: 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_ 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_ :: Map MisoString MisoString -> Attribute action
style_ = Map MisoString MisoString -> Attribute action
forall action. Map MisoString MisoString -> Attribute action
S