{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
#ifndef ghcjs_HOST_OS
{-# LANGUAGE StandaloneDeriving #-}
#endif
module Shpadoinkle.Backend.ParDiff
( ParDiffT (..)
, runParDiff
, stage
) where
import Control.Applicative (Alternative)
import Control.Compactable (Compactable (traverseMaybe))
import Control.Lens ((^.))
import Control.Monad.Base (MonadBase (..), liftBaseDefault)
import Control.Monad.Catch (MonadCatch, MonadThrow)
import Control.Monad.Reader (MonadIO, MonadReader (ask),
MonadTrans (..), ReaderT (..),
guard, void)
import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),
MonadTransControl,
defaultLiftBaseWith,
defaultRestoreM)
import Data.Align (Semialign (align))
import Data.Foldable (traverse_)
import Data.Kind (Type)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Monoid ((<>))
import Data.Once (Once, newOnce, runOnce)
import Data.Text (Text, intercalate)
import Data.These (These (That, These, This))
import Data.Traversable (for)
import GHC.Generics (Generic)
import Language.Javascript.JSaddle (FromJSVal (fromJSValUnchecked),
JSVal, MakeObject (makeObject),
Object, ToJSString (toJSString),
ToJSVal (toJSVal), eval, fun, js1,
js2, jsg, jsg2, liftJSM,
strictEqual, unsafeGetProp,
unsafeSetProp)
import UnliftIO (MonadUnliftIO (..), TVar,
UnliftIO (UnliftIO, unliftIO),
withUnliftIO)
import UnliftIO.Concurrent (forkIO)
import UnliftIO.STM (STM, atomically)
import Shpadoinkle (Backend (..), Continuation,
Html (..), JSM, MonadJSM,
Prop (..), RawEvent (RawEvent),
RawNode (RawNode), hoist,
type (~>), writeUpdate)
default (Text)
newtype ParDiffT model m a = ParDiffT { unParDiff :: ReaderT (TVar model) m a }
deriving
( Functor
, Applicative
, Alternative
, Monad
, MonadIO
, MonadReader (TVar model)
, MonadTrans
, MonadTransControl
, MonadThrow
, MonadCatch
)
#ifndef ghcjs_HOST_OS
deriving instance MonadJSM m => MonadJSM (ParDiffT model m)
#endif
instance MonadBase n m => MonadBase n (ParDiffT model m) where
liftBase = liftBaseDefault
instance MonadBaseControl n m => MonadBaseControl n (ParDiffT model m) where
type StM (ParDiffT model m) a = ComposeSt (ParDiffT model) m a
liftBaseWith = defaultLiftBaseWith
restoreM = defaultRestoreM
instance MonadUnliftIO m => MonadUnliftIO (ParDiffT r m) where
{-# INLINE askUnliftIO #-}
askUnliftIO = ParDiffT . ReaderT $ \r ->
withUnliftIO $ \u ->
return (UnliftIO (unliftIO u . flip runReaderT r . unParDiff))
{-# INLINE withRunInIO #-}
withRunInIO inner =
ParDiffT . ReaderT $ \r ->
withRunInIO $ \run' ->
inner (run' . flip runReaderT r . unParDiff)
runParDiff :: TVar model -> ParDiffT model m ~> m
runParDiff t (ParDiffT r) = runReaderT r t
data ParVNode :: Type -> Type where
ParNode :: Once JSM RawNode -> Text -> Map Text (ParVProp a) -> [ParVNode a] -> ParVNode a
ParPotato :: Once JSM RawNode -> ParVNode a
ParTextNode :: Once JSM RawNode -> Text -> ParVNode a
instance Show (ParVNode a) where
show = \case
ParNode _ t ps cs -> "ParNode _ " <> show t <> " " <> show ps <> " " <> show cs
ParPotato _ -> "ParPotato _"
ParTextNode _ t -> "ParTextNode _ " <> show t
data ParVProp a
= ParVText Text
| ParVData JSVal
| ParVListen (RawNode -> RawEvent -> JSM (Continuation JSM a))
| ParVFlag Bool
| ParVPotato (RawNode -> JSM (STM (Continuation JSM a)))
deriving Generic
instance Show (ParVProp a) where
show = \case
ParVData _ -> "ParVData _"
ParVPotato _ -> "ParVPotato _"
ParVText t -> "ParVText " <> show t
ParVListen _ -> "ParVListen _"
ParVFlag b -> "ParVFlag " <> show b
props :: Monad m => (m ~> JSM) -> TVar a -> Map Text (Prop (ParDiffT a m) a) -> RawNode -> JSM ()
props toJSM i ps (RawNode raw) = do
raw' <- makeObject raw
void . traverse (uncurry $ prop toJSM i raw') $ M.toList ps
prop :: Monad m => (m ~> JSM) -> TVar a -> Object -> Text -> Prop (ParDiffT a m) a -> JSM ()
prop toJSM i raw k = \case
PData d -> setProp' raw k d
PPotato p -> setProptado i (fmap (fmap (hoist (toJSM . runParDiff i))) . p) raw
PText t -> setProp' raw k t
PListener f -> setListener i (\x y -> hoist (toJSM . runParDiff i)
<$> f x y) raw k
PFlag True -> setProp' raw k =<< toJSVal True
PFlag False -> return ()
setProp' :: ToJSVal t => Object -> Text -> t -> JSM ()
setProp' raw' k t = do
let k' = toJSString k
old <- unsafeGetProp k' raw'
t' <- toJSVal t
b <- strictEqual old t'
if b then return () else unsafeSetProp (toJSString k) t' raw'
setProptado :: forall a. TVar a -> (RawNode -> JSM (STM (Continuation JSM a))) -> Object -> JSM ()
setProptado i f o = do
elm <- RawNode <$> toJSVal o
stm <- f elm
let go = atomically stm >>= writeUpdate i >> go
void $ forkIO go
setListener :: TVar a -> (RawNode -> RawEvent -> JSM (Continuation JSM a)) -> Object -> Text -> JSM ()
setListener i m o k = do
elm <- RawNode <$> toJSVal o
setProp' o ("on" <> k) . fun $ \_ _ -> \case
e:_ -> do
x <- m elm (RawEvent e)
writeUpdate i x
_ -> return ()
getRaw :: ParVNode a -> Once JSM RawNode
getRaw = \case
ParNode mk _ _ _ -> mk
ParPotato mk -> mk
ParTextNode mk _ -> mk
setRaw :: Once JSM RawNode -> ParVNode a -> ParVNode a
setRaw r = \case
ParNode _ a b c -> ParNode r a b c
ParPotato _ -> ParPotato r
ParTextNode _ a -> ParTextNode r a
appendChild :: RawNode -> ParVNode a -> JSM (ParVNode a)
appendChild (RawNode raw) pn = do
let raw' = getRaw pn
RawNode r <- runOnce raw'
void $ raw ^. js1 "appendChild" r
return pn
makeProp :: Monad m => (m ~> JSM) -> TVar a -> Prop (ParDiffT a m) a -> JSM (ParVProp a)
makeProp toJSM i = \case
PText t -> return $ ParVText t
PData t -> return $ ParVData t
PPotato p -> return . ParVPotato $ fmap (fmap (hoist (toJSM . runParDiff i))) . p
PListener m -> return . ParVListen $ \x y -> hoist (toJSM . runParDiff i) <$> m x y
PFlag b -> return $ ParVFlag b
setup' :: JSM () -> JSM ()
setup' cb = do
void $ eval $ intercalate "\n"
[ " window.deleteProp = (k, obj) => {"
, " delete obj[k]"
, " }"
, " window.container = document.createElement('div')"
, " document.body.appendChild(container)"
]
cb
voidJSM :: MonadJSM m => JSM a -> m ()
voidJSM = void . liftJSM
setFlag :: MonadJSM m => Object -> Text -> Bool -> m ()
setFlag obj' k b = if b then
voidJSM $ setProp' obj' k =<< toJSVal True
else case k of
"checked" -> voidJSM $ setProp' obj' k =<< toJSVal False
"disabled" -> voidJSM $ obj' ^. js1 "removeAttribute" "disabled"
_ -> voidJSM $ jsg2 "deleteProp" (toJSString k) obj'
managePropertyState :: MonadJSM m => TVar a -> Object -> Map Text (ParVProp a) -> Map Text (ParVProp a) -> m ()
managePropertyState i obj' old new' = void $ do
maybe (return ()) (const . voidJSM $ setProp' obj' "checked" =<< toJSVal False)
$ M.lookup "checked" new' >>= guard . (\case { ParVFlag False -> True; _ -> False })
M.toList (align old new') `for` \(k, x) -> case x of
This _ -> case k of
"className" -> voidJSM $ obj' ^. js1 "removeAttribute" "class"
"htmlFor" -> voidJSM $ obj' ^. js1 "removeAttribute" "for"
"style" -> voidJSM $ obj' ^. js1 "removeAttribute" "style"
"checked" -> voidJSM $ setProp' obj' k =<< toJSVal False
"disabled" -> voidJSM $ obj' ^. js1 "removeAttribute" "disabled"
_ -> voidJSM $ jsg2 "deleteProp" (toJSString k) obj'
That (ParVPotato p) -> voidJSM $ p . RawNode =<< toJSVal obj'
That (ParVData j) -> voidJSM $ setProp' obj' k j
That (ParVText t) -> voidJSM $ setProp' obj' k =<< toJSVal t
These (ParVText t)
(ParVText t')
| t /= t' -> voidJSM $ setProp' obj' k =<< toJSVal t'
That (ParVFlag b) -> setFlag obj' k b
These (ParVFlag t)
(ParVFlag t')
| t /= t' -> setFlag obj' k t'
That (ParVListen h) -> voidJSM $ setListener i h obj' k
These (ParVListen _)
(ParVListen h) -> voidJSM $ setListener i h obj' k
These _ _ -> return ()
patchChildren
:: MonadUnliftIO m
#ifndef ghcjs_HOST_OS
=> MonadJSM m
#endif
=> Show a
=> RawNode -> [ParVNode a] -> [ParVNode a] -> ParDiffT a m [ParVNode a]
patchChildren parent@(RawNode p) old new'' =
traverseMaybe (\case
This child -> do
RawNode c <- lift . liftJSM . runOnce $ getRaw child
voidJSM $ p ^. js1 "removeChild" c
return Nothing
That child -> do
RawNode c <- lift . liftJSM . runOnce $ getRaw child
voidJSM $ p ^. js1 "appendChild" c
return $ Just child
These old' new' ->
Just <$> patch' parent (Just old') new'
) (align old new'')
patch'
:: MonadUnliftIO m
#ifndef ghcjs_HOST_OS
=> MonadJSM m
#endif
=> Show a
=> RawNode -> Maybe (ParVNode a) -> ParVNode a -> ParDiffT a m (ParVNode a)
patch' parent old new' = do
i <- ask
case (old, new') of
(Just old'@(ParTextNode _ t)
, ParTextNode _ t')
| t == t' -> return old'
(Just (ParTextNode raw _)
, ParTextNode _ t) -> do
RawNode r <- liftJSM $ runOnce raw
obj' <- liftJSM $ makeObject r
liftJSM $ setProp' obj' "nodeValue" =<< toJSVal t
return $ setRaw raw new'
(Just (ParNode raw name ps cs)
, ParNode _ name' ps' cs')
| name == name' -> do
raw'@(RawNode r) <- liftJSM $ runOnce raw
obj' <- liftJSM $ makeObject r
managePropertyState i obj' ps ps'
cs'' <- patchChildren raw' cs cs'
return $ ParNode raw name ps' cs''
(Just old', _) -> do
RawNode p <- return parent
RawNode r <- lift . liftJSM . runOnce $ getRaw old'
RawNode c <- lift . liftJSM . runOnce $ getRaw new'
_ <- liftJSM $ p ^. js2 "replaceChild" c r
return new'
(Nothing, _) -> do
RawNode p <- return parent
RawNode c <- lift . liftJSM . runOnce $ getRaw new'
_ <- liftJSM $ p ^. js1 "appendChild" c
return new'
interpret'
:: MonadJSM m
=> MonadUnliftIO m
=> Eq a
=> Show a
=> (m ~> JSM) -> Html (ParDiffT a m) a -> ParDiffT a m (ParVNode a)
interpret' toJSM = \case
TextNode t -> do
raw <- liftJSM . newOnce $ do
doc <- jsg "document"
RawNode <$> doc ^. js1 "createTextNode" t
return $ ParTextNode raw t
Potato p -> do
raw <- liftJSM $ newOnce p
return $ ParPotato raw
Node name (M.fromList -> ps) cs -> do
i <- ask
let makeNode = do
doc <- jsg "document"
elm <- RawNode <$> doc ^. js1 "createElement" name
props toJSM i ps elm
return elm
cs' <- traverse (interpret toJSM) cs
raw <- liftJSM . newOnce $ do
node <- makeNode
traverse_ (appendChild node) cs'
return node
p <- liftJSM $ makeProp toJSM i `traverse` ps
return $ ParNode raw name p cs'
instance
( MonadUnliftIO m
, MonadJSM m
, Eq a
, Show a ) => Backend (ParDiffT a) m a where
type VNode (ParDiffT a) m = ParVNode a
interpret = interpret'
setup = setup'
patch = patch'
stage :: FromJSVal b => MonadJSM m => ParDiffT a m b
stage = liftJSM $ fromJSValUnchecked =<< jsg "container"