{-# 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 (elem, reverse)
data View action
= Node NS MisoString (Maybe Key) [Attribute action] [View action]
| Text MisoString
| TextRaw MisoString
deriving Functor
instance HasLink (View a) where
#if MIN_VERSION_servant(0,14,0)
type MkLink (View a) b = MkLink (Get '[] ()) b
toLink toA Proxy = toLink toA (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 = TextRaw
node :: NS
-> MisoString
-> Maybe Key
-> [Attribute action]
-> [View action]
-> View action
node = Node
text :: MisoString -> View action
text = Text
textRaw :: MisoString -> View action
textRaw = TextRaw
instance IsString (View a) where
fromString = text . fromString
instance L.ToHtml (View action) where
toHtmlRaw = L.toHtml
toHtml (Node _ vType _ attrs vChildren) = L.with ele lattrs
where
noEnd = ["img", "input", "br", "hr", "meta"]
tag = toTag $ fromMisoString vType
ele = if tag `elem` noEnd
then L.makeElementNoEnd tag
else L.makeElement tag kids
classes = T.intercalate " " [ v | P "class" (A.String v) <- attrs ]
propClass = M.fromList $ attrs >>= \case
P k v -> [(k, v)]
E _ -> []
S m -> [("style", A.String . fromMisoString $ M.foldrWithKey go mempty m)]
where
go :: MisoString -> MisoString -> MisoString -> MisoString
go k v ys = mconcat [ k, ":", v, ";" ] <> ys
xs = if not (T.null classes)
then M.insert "class" (A.String classes) propClass
else propClass
lattrs = [ L.makeAttribute k' (if k `elem` exceptions && v == A.Bool True then k' else v')
| (k,v) <- M.toList xs
, let k' = fromMisoString k
, let v' = toHtmlFromJSON v
, not (k `elem` exceptions && v == A.Bool False)
]
exceptions = [ "checked"
, "disabled"
, "selected"
, "hidden"
, "readOnly"
, "autoplay"
, "required"
, "default"
, "autofocus"
, "multiple"
, "noValidate"
, "autocomplete"
]
toTag = T.toLower
kids = foldMap L.toHtml $ collapseSiblingTextNodes vChildren
toHtml (Text x) | null x = L.toHtml (" " :: T.Text)
| otherwise = L.toHtml (fromMisoString x :: T.Text)
toHtml (TextRaw x)
| null x = L.toHtml (" " :: T.Text)
| otherwise = L.toHtmlRaw (fromMisoString x :: T.Text)
collapseSiblingTextNodes :: [View a] -> [View a]
collapseSiblingTextNodes [] = []
collapseSiblingTextNodes (Text x : Text y : xs) =
collapseSiblingTextNodes (Text (x <> y) : xs)
collapseSiblingTextNodes (x:xs) =
x : collapseSiblingTextNodes xs
toHtmlFromJSON :: Value -> T.Text
toHtmlFromJSON (A.String t) = t
toHtmlFromJSON (A.Number t) = T.pack (show t)
toHtmlFromJSON (A.Bool b) = if b then "true" else "false"
toHtmlFromJSON A.Null = "null"
toHtmlFromJSON (A.Object o) = T.pack (show o)
toHtmlFromJSON (A.Array a) = T.pack (show a)
newtype VTree = VTree { getTree :: Object }
runView :: View action -> Sink action -> JSM VTree
runView (Node ns tag key attrs kids) sink = do
vnode <- create
cssObj <- objectToJSVal =<< create
propsObj <- objectToJSVal =<< create
eventObj <- objectToJSVal =<< create
set "css" cssObj vnode
set "props" propsObj vnode
set "events" eventObj vnode
set "type" ("vnode" :: JSString) vnode
set "ns" ns vnode
set "tag" tag vnode
set "key" key vnode
setAttrs vnode
flip (set "children") vnode
=<< ghcjsPure . jsval
=<< setKids
pure $ VTree vnode
where
setAttrs vnode =
forM_ attrs $ \case
P k v -> do
val <- toJSVal v
o <- getProp "props" vnode
set k val (Object o)
E attr -> attr sink vnode
S m -> do
cssObj <- getProp "css" vnode
forM_ (M.toList m) $ \(k,v) -> do
set k v (Object cssObj)
setKids = do
kidsViews <- traverse (objectToJSVal . getTree <=< flip runView sink) kids
ghcjsPure (JSArray.fromList kidsViews)
runView (Text t) _ = do
vtree <- create
set "type" ("vtext" :: JSString) vtree
set "text" t vtree
pure $ VTree vtree
runView (TextRaw str) sink =
case parseView str of
[] ->
runView (Text (" " :: MisoString)) sink
[parent] ->
runView parent sink
kids -> do
runView (Node HTML "div" Nothing mempty kids) sink
parseView :: MisoString -> [View a]
parseView html = reverse (go (parseTree html) [])
where
go [] xs = xs
go (TagLeaf (TagText s) : next) views =
go next (Text s : views)
go (TagLeaf (TagOpen name attrs) : next) views =
go (TagBranch name attrs [] : next) views
go (TagBranch name attrs kids : next) views =
let
attrs' = [ P key $ A.String (fromMisoString val)
| (key, val) <- attrs
]
newNode =
Node HTML name Nothing attrs' (reverse (go kids []))
in
go next (newNode:views)
go (TagLeaf _ : next) views =
go next views
data NS
= HTML
| SVG
| MATHML
deriving (Show, Eq)
instance ToJSVal NS where
toJSVal SVG = toJSVal ("svg" :: JSString)
toJSVal HTML = toJSVal ("html" :: JSString)
toJSVal MATHML = toJSVal ("mathml" :: JSString)
newtype Key = Key MisoString
instance ToJSVal Key where toJSVal (Key x) = toJSVal x
class ToKey key where toKey :: key -> Key
instance ToKey Key where toKey = id
instance ToKey JSString where toKey = Key . toMisoString
instance ToKey T.Text where toKey = Key . toMisoString
instance ToKey String where toKey = Key . toMisoString
instance ToKey Int where toKey = Key . toMisoString
instance ToKey Double where toKey = Key . toMisoString
instance ToKey Float where toKey = Key . toMisoString
instance ToKey Word where toKey = Key . toMisoString
data Attribute action
= P MisoString Value
| E (Sink action -> Object -> JSM ())
| S (M.Map MisoString MisoString)
deriving Functor
prop :: ToJSON a => MisoString -> a -> Attribute action
prop k v = P k (toJSON v)
on :: MisoString
-> Decoder r
-> (r -> action)
-> Attribute action
on = onWithOptions defaultOptions
onWithOptions
:: Options
-> MisoString
-> Decoder r
-> (r -> action)
-> Attribute action
onWithOptions options eventName Decoder{..} toAction =
E $ \sink n -> do
eventObj <- getProp "events" n
eventHandlerObject@(Object eo) <- create
jsOptions <- toJSVal options
decodeAtVal <- toJSVal decodeAt
cb <- callbackToJSVal <=< asyncCallback1 $ \e -> do
Just v <- fromJSVal =<< objectToJSON decodeAtVal e
case parseEither decoder v of
Left s -> error $ "Parse error on " <> unpack eventName <> ": " <> s
Right r -> liftIO (sink (toAction r))
set "runEvent" cb eventHandlerObject
registerCallback cb
set "options" jsOptions eventHandlerObject
set eventName eo (Object eventObj)
onCreated :: action -> Attribute action
onCreated action =
E $ \sink n -> do
cb <- callbackToJSVal =<< asyncCallback (liftIO (sink action))
set "onCreated" cb n
registerCallback cb
onDestroyed :: action -> Attribute action
onDestroyed action =
E $ \sink n -> do
cb <- callbackToJSVal =<< asyncCallback (liftIO (sink action))
set "onDestroyed" cb n
registerCallback cb
onBeforeDestroyed :: action -> Attribute action
onBeforeDestroyed action =
E $ \sink n -> do
cb <- callbackToJSVal =<< asyncCallback (liftIO (sink action))
set "onBeforeDestroyed" cb n
registerCallback cb
style_ :: M.Map MisoString MisoString -> Attribute action
style_ = S