module Miso.Html.Internal (
VTree (..)
, View (..)
, ToView (..)
, Attribute (..)
, node
, text
, Key (..)
, ToKey (..)
, NS (..)
, prop
, style_
, on
, onWithOptions
, module Miso.String
) where
import Data.Aeson
import qualified Data.Map as M
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified Lucid as L
import qualified Lucid.Base as L
import Miso.String hiding (map)
import Miso.Event
data VTree model where
VNode :: { vType :: Text
, vNs :: NS
, vProps :: Props
, vCss :: CSS
, vKey :: Maybe Key
, vChildren :: V.Vector (VTree model)
} -> VTree model
VText :: { vText :: Text
} -> VTree model
instance Show (VTree model) where
show = show . L.toHtml
instance L.ToHtml (VTree model) where
toHtmlRaw = L.toHtml
toHtml (VText x) = L.toHtml x
toHtml VNode{..} =
let ele = L.makeElement (toTag vType) kids
in L.with ele as
where
Props xs = vProps
as = [ L.makeAttribute k v'
| (k,v) <- M.toList xs
, let v' = toHtmlFromJSON v
]
toTag = T.toLower
kids = foldMap L.toHtml vChildren
toHtmlFromJSON :: Value -> Text
toHtmlFromJSON (String t) = t
toHtmlFromJSON (Number t) = pack (show t)
toHtmlFromJSON (Bool b) = if b then "true" else "false"
toHtmlFromJSON Null = "null"
toHtmlFromJSON (Object o) = pack (show o)
toHtmlFromJSON (Array a) = pack (show a)
newtype View model = View { runView :: VTree model }
class ToView v where toView :: v -> View model
instance Show (View model) where
show (View xs) = show xs
instance L.ToHtml (View model) where
toHtmlRaw = L.toHtml
toHtml (View xs) = L.toHtml xs
data NS
= HTML
| SVG
deriving (Show, Eq)
node :: NS -> MisoString -> Maybe Key -> [Attribute model] -> [View model] -> View model
node vNs vType vKey as xs =
let vProps = Props $ M.fromList [ (k,v) | P k v <- as ]
vCss = CSS $ M.fromList [ (k,v) | C k v <- as ]
vChildren = V.fromList $ map runView xs
in View VNode {..}
text :: ToMisoString str => str -> View model
text x = View $ VText (toMisoString x)
newtype Key = Key MisoString
deriving (Show, Eq, Ord)
class ToKey key where toKey :: key -> Key
instance ToKey Key where toKey = id
instance ToKey MisoString where toKey = Key
instance ToKey String where toKey = Key . T.pack
instance ToKey Int where toKey = Key . T.pack . show
instance ToKey Double where toKey = Key . T.pack . show
instance ToKey Float where toKey = Key . T.pack . show
instance ToKey Word where toKey = Key . T.pack . show
newtype Props = Props (M.Map MisoString Value)
newtype CSS = CSS (M.Map MisoString MisoString)
data Attribute model
= C MisoString MisoString
| P MisoString Value
| E ()
newtype AllowDrop = AllowDrop Bool
deriving (Show, Eq)
prop :: ToJSON a => MisoString -> a -> Attribute model
prop k v = P k (toJSON v)
on :: MisoString
-> Decoder r
-> (r -> action)
-> Attribute action
on _ _ _ = E ()
onWithOptions
:: Options
-> MisoString
-> Decoder r
-> (r -> action)
-> Attribute action
onWithOptions _ _ _ _ = E ()
style_ :: M.Map MisoString MisoString -> Attribute action
style_ = C "style" . M.foldrWithKey go mempty
where
go :: MisoString -> MisoString -> MisoString -> MisoString
go k v xs = mconcat [ k, ":", v, ";" ] <> xs