{-# LANGUAGE CPP #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
module Shpadoinkle.Backend.Snabbdom
( SnabbdomT (..)
, runSnabbdom
, stage
) where
import Control.Category
import Control.Monad.Reader
import Data.FileEmbed
import Data.Text
import Data.Traversable
import GHC.Conc
import Language.Javascript.JSaddle hiding (( # ))
import Prelude hiding ((.))
import Shpadoinkle hiding (children, name, props)
default (Text)
newtype SnabVNode = SnabVNode { unVNode :: JSVal }
instance ToJSVal SnabVNode where toJSVal = return . unVNode
instance FromJSVal SnabVNode where fromJSVal = return . Just . SnabVNode
newtype SnabbdomT model m a = Snabbdom { unSnabbdom :: ReaderT (TVar model) m a }
deriving (Functor, Applicative, Monad, MonadIO, MonadReader (TVar model), MonadTrans)
#ifndef ghcjs_HOST_OS
deriving instance MonadJSM m => MonadJSM (SnabbdomT model m)
#endif
runSnabbdom :: TVar model -> SnabbdomT model m a -> m a
runSnabbdom t (Snabbdom r) = runReaderT r t
props :: (m ~> JSM) -> TVar a -> [(Text, Prop (SnabbdomT a m) a)] -> JSM Object
props toJSM i xs = do
o <- create
a <- create
e <- create
c <- create
void $ xs `for` \(k, p) -> case p of
PText t -> do
t' <- toJSVal t
true <- toJSVal True
case k of
"className" | t /= "" -> unsafeSetProp (toJSString t) true c
_ -> unsafeSetProp (toJSString k) t' a
PListener f -> do
f' <- toJSVal . fun $ \_ _ -> \case
[] -> return ()
ev:_ -> do
rn <- unsafeGetProp "target" =<< valToObject ev
liftIO . atomically . writeTVar i =<< (toJSM . runSnabbdom i) (f (RawNode rn) (RawEvent ev))
unsafeSetProp (toJSString k) f' e
PFlag b -> do
f <- toJSVal b
unsafeSetProp (toJSString k) f a
p <- toJSVal a
l <- toJSVal e
k <- toJSVal c
unsafeSetProp "props" p o
unsafeSetProp "class" k o
unsafeSetProp "on" l o
return o
instance (MonadJSM m, Eq a) => Backend (SnabbdomT a) m a where
type VNode (SnabbdomT a) m = SnabVNode
interpret :: (m ~> JSM) -> Html (SnabbdomT a m) a -> SnabbdomT a m SnabVNode
interpret toJSM = \case
TextNode t -> liftJSM $ fromJSValUnchecked =<< toJSVal t
Node name ps [TextNode t] -> do
i <- ask; liftJSM $ do
o <- props toJSM i ps
fromJSValUnchecked =<< jsg3 "vnode" name o t
Node name ps children -> do
i <- ask; liftJSM $ do
o <- props toJSM i ps
traverse ((toJSM . runSnabbdom i) . interpret toJSM >=> toJSVal) children
>>= jsg3 "vnode" name o >>= fromJSValUnchecked
Potato mrn -> liftJSM $ do
o <- create
hook <- create
rn <- mrn
ins <- toJSVal =<< function (\_ _ -> \case
[n] -> void $ jsg2 "potato" n rn
_ -> return ())
unsafeSetProp "insert" ins hook
hoo <- toJSVal hook
unsafeSetProp "hook" hoo o
fromJSValUnchecked =<< jsg2 "vnode" "div" o
patch :: RawNode -> Maybe SnabVNode -> SnabVNode -> SnabbdomT a m SnabVNode
patch (RawNode r) f t = t <$ (liftJSM . void $ jsg2 "patchh" f' t)
where f' = maybe r unVNode f
setup :: JSM () -> SnabbdomT a m ()
setup cb = liftJSM $ do
void $ eval @Text $(embedStringFile "Shpadoinkle/Backend/Snabbdom/Setup.js")
void . jsg1 "startApp" . fun $ \_ _ _ -> cb
stage :: MonadJSM m => SnabbdomT a m RawNode
stage = liftJSM $ fromJSValUnchecked =<< jsg "container"