{-# LANGUAGE CPP #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
module Shpadoinkle.Backend.Snabbdom
( SnabbdomT (..)
, runSnabbdom
, stage
) where
import Control.Category
import Control.Monad.Base (MonadBase (..), liftBaseDefault)
import Control.Monad.Catch (MonadCatch, MonadThrow)
import Control.Monad.Reader
import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),
MonadTransControl,
defaultLiftBaseWith,
defaultRestoreM)
import Data.FileEmbed
import Data.Text
import Data.Traversable
import Language.Javascript.JSaddle hiding (JSM, MonadJSM, liftJSM,
(#))
import Prelude hiding (id, (.))
import UnliftIO (MonadUnliftIO (..), TVar,
UnliftIO (UnliftIO, unliftIO),
withUnliftIO)
import UnliftIO.Concurrent (forkIO)
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
, MonadTransControl
, MonadThrow
, MonadCatch
)
#ifndef ghcjs_HOST_OS
deriving instance MonadJSM m => MonadJSM (SnabbdomT model m)
#endif
instance MonadBase n m => MonadBase n (SnabbdomT model m) where
liftBase = liftBaseDefault
instance MonadBaseControl n m => MonadBaseControl n (SnabbdomT model m) where
type StM (SnabbdomT model m) a = ComposeSt (SnabbdomT model) m a
liftBaseWith = defaultLiftBaseWith
restoreM = defaultRestoreM
instance MonadUnliftIO m => MonadUnliftIO (SnabbdomT r m) where
{-# INLINE askUnliftIO #-}
askUnliftIO = Snabbdom . ReaderT $ \r ->
withUnliftIO $ \u ->
return (UnliftIO (unliftIO u . flip runReaderT r . unSnabbdom))
{-# INLINE withRunInIO #-}
withRunInIO inner =
Snabbdom . ReaderT $ \r ->
withRunInIO $ \run' ->
inner (run' . flip runReaderT r . unSnabbdom)
runSnabbdom :: TVar model -> SnabbdomT model m ~> m
runSnabbdom t (Snabbdom r) = runReaderT r t
props :: Monad m => (m ~> JSM) -> TVar a -> [(Text, Prop (SnabbdomT a m) a)] -> JSM Object
props toJSM i xs = do
o <- create
propsObj <- create
listenersObj <- create
classesObj <- create
attrsObj <- create
hooksObj <- create
void $ xs `for` \(k, p) -> case p of
PData d -> unsafeSetProp (toJSString k) d propsObj
PPotato pot -> do
f' <- toJSVal . fun $ \_ _ ->
let
g vnode = do
vnode' <- valToObject vnode
stm <- pot . RawNode =<< unsafeGetProp "elm" vnode'
let go = atomically stm >>= writeUpdate i . hoist (toJSM . runSnabbdom i)
void $ forkIO go
in \case
[vnode] -> g vnode
[_, vnode] -> g vnode
_ -> return ()
unsafeSetProp "insert" f' hooksObj
unsafeSetProp "update" f' hooksObj
PText t -> do
t' <- toJSVal t
true <- toJSVal True
case k of
"className" | t /= "" -> forM_ (split (== ' ') t) $ \u -> unsafeSetProp (toJSString u) true classesObj
"style" | t /= "" -> unsafeSetProp (toJSString k) t' attrsObj
"type" | t /= "" -> unsafeSetProp (toJSString k) t' attrsObj
"autofocus" | t /= "" -> unsafeSetProp (toJSString k) t' attrsObj
_ -> unsafeSetProp (toJSString k) t' propsObj
PListener f -> do
f' <- toJSVal . fun $ \_ _ -> \case
[] -> return ()
ev:_ -> do
rn <- unsafeGetProp "target" =<< valToObject ev
x <- f (RawNode rn) (RawEvent ev)
writeUpdate i $ hoist (toJSM . runSnabbdom i) x
unsafeSetProp (toJSString k) f' listenersObj
PFlag b -> do
f <- toJSVal b
unsafeSetProp (toJSString k) f propsObj
p <- toJSVal propsObj
l <- toJSVal listenersObj
k <- toJSVal classesObj
a <- toJSVal attrsObj
h' <- toJSVal hooksObj
unsafeSetProp "props" p o
unsafeSetProp "class" k o
unsafeSetProp "on" l o
unsafeSetProp "attrs" a o
unsafeSetProp "hook" h' 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 () -> JSM ()
setup cb = 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"