{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
#ifndef ghcjs_HOST_OS
{-# LANGUAGE StandaloneDeriving #-}
#endif
{-|
This backend is to serve as a canonical representation of a well-behaved
backend. Defining well-behaved in the context of web development
is rather difficult and complex.
The rules of a backend are informal. Roughly, if we give the backend
some Html, we expect it to update the DOM at runtime in the way we expect.
Since this is canonical, all other backends are expected to behave
identically to this one. If differences exist they should be patched
so that we retain renderer polymorphism, such that we can change out
the renderer of our application; without updating the application logic
with confidence it will behave as expected.
-}
module Shpadoinkle.Backend.ParDiff
( ParDiffT (..)
, runParDiff
, stage
) where
import Control.Applicative (Alternative)
import Control.Monad (forM_, void, when)
import Control.Monad.Base (MonadBase (..), liftBaseDefault)
import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
import Control.Monad.Cont (MonadCont)
import Control.Monad.Except (MonadError)
import Control.Monad.RWS (MonadRWS)
import Control.Monad.Reader (MonadIO, MonadReader (ask),
MonadTrans (..), ReaderT (..),
guard)
import Control.Monad.State (MonadState)
import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),
MonadTransControl,
defaultLiftBaseWith,
defaultRestoreM)
import Control.Monad.Writer (MonadWriter)
import Data.Kind (Type)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Map.Internal (Map (Bin, Tip))
import Data.Maybe (isJust)
import Data.Monoid ((<>))
import Data.Once (Once, newOnce, runOnce)
import Data.Text (Text, intercalate)
import Language.Javascript.JSaddle (FromJSVal (fromJSValUnchecked),
JSString, MakeObject (makeObject),
Object, ToJSString (toJSString),
ToJSVal (toJSVal), eval, fun,
jsFalse, jsTrue, jsg, jsg2,
liftJSM, unsafeSetProp,
valMakeText, (#))
import UnliftIO (MonadUnliftIO (..), TVar,
UnliftIO (UnliftIO, unliftIO),
withUnliftIO)
import UnliftIO.Concurrent (forkIO)
import UnliftIO.STM (STM, atomically)
import Shpadoinkle (Backend (..), Continuation,
Html (..), JSM, MonadJSM, NFData,
Prop (..), Props (..),
RawEvent (RawEvent),
RawNode (RawNode, unRawNode),
hoist, toProps, 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
, MonadMask
, MonadWriter w
, MonadState s
, MonadRWS (TVar model) w s
, MonadError e
, MonadCont
)
#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)
-- | 'ParDiffT' is a @newtype@ of 'ReaderT', this is the 'runReaderT' equivalent.
runParDiff :: TVar model -> ParDiffT model m ~> m
runParDiff t (ParDiffT r) = runReaderT r t
data ParVNode :: Type -> Type where
ParNode :: Once JSM RawNode -> {-# UNPACK #-} !Text -> ParVProps a -> [ParVNode a] -> ParVNode a
ParPotato :: Once JSM RawNode -> ParVNode a
ParTextNode :: Once JSM RawNode -> {-# UNPACK #-} !Text -> ParVNode a
type ParVProps = Props JSM
type ParVProp = Prop JSM
props :: Monad m => NFData a => (m ~> JSM) -> TVar a -> Props (ParDiffT a m) a -> RawNode -> JSM ()
props toJSM i (Props ps) (RawNode raw) = do
raw' <- makeObject raw
traverseWithKey_ (prop toJSM i raw') ps
prop :: Monad m => NFData a => (m ~> JSM) -> TVar a -> Object -> Text -> Prop (ParDiffT a m) a -> JSM ()
prop toJSM i raw k = \case
PData d -> unsafeSetProp k' d raw
PText t -> do
t' <- valMakeText t
unsafeSetProp k' t' raw
PPotato p -> setProptado i (fmap (fmap (hoist (toJSM . runParDiff i))) . p) raw
PListener f -> setListener i (\x y -> hoist (toJSM . runParDiff i) <$> f x y) raw k'
PFlag True -> unsafeSetProp k' jsTrue raw
PFlag False -> return ()
where
k' = toJSString k
setProptado :: forall a. NFData 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 :: NFData a => TVar a -> (RawNode -> RawEvent -> JSM (Continuation JSM a)) -> Object -> JSString -> JSM ()
setListener i m o k = do
elm <- RawNode <$> toJSVal o
f <- toJSVal . fun $ \_ _ -> \case
e:_ -> do
x <- m elm (RawEvent e)
writeUpdate i x
_ -> return ()
unsafeSetProp ("on" <> k) f o
getRaw :: ParVNode a -> Once JSM RawNode
getRaw = \case
ParNode mk _ _ _ -> mk
ParPotato mk -> mk
ParTextNode mk _ -> mk
makeProp :: Monad m => (m ~> JSM) -> TVar a -> Prop (ParDiffT a m) a -> ParVProp a
makeProp toJSM i = \case
PText t -> PText t
PData t -> PData t
PPotato p -> PPotato $ fmap (fmap (hoist (toJSM . runParDiff i))) . p
PListener m -> PListener $ \x y -> hoist (toJSM . runParDiff i) <$> m x y
PFlag b -> PFlag 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
setFlag :: Object -> Text -> Bool -> JSM ()
setFlag obj' k b
| b = unsafeSetProp k' jsTrue obj'
| otherwise = case k of
"checked" -> unsafeSetProp k' jsFalse obj'
"disabled" -> void (obj' # "removeAttribute" $ "disabled")
_ -> void (jsg2 "deleteProp" k' obj')
where
k' = toJSString k
traverseWithKey_ :: Applicative t => (k -> a -> t ()) -> Map k a -> t ()
traverseWithKey_ f = go
where
go Tip = pure ()
go (Bin 1 k v _ _) = f k v
go (Bin _ k v l r) = go l *> f k v *> go r
managePropertyState :: NFData a => TVar a -> Object -> ParVProps a -> ParVProps a -> JSM ()
managePropertyState i obj' (Props !old) (Props !new) = void $ do
-- The following step may be necessary if the old DOM and the new VDOM both have checked == False
-- but the user just checked this checkbox / radio button and the browser set its
-- checked property to true without setting its checked attribute.
-- As far as we know this issue only occurs with the checked property.
-- As far as we know this issue only occurs with the value properties of input controls,
-- which include but are not necessarily limited to:
-- * The value properties of input, select, and textarea elements
-- * The checked properties of input type={checkbox,radio} elements
-- * The src properties of image elements
-- * The files properties of file elements
-- Of these properties, checked is the only one where we know that the absence of the attribute
-- in both the old and new (V)DOMs is consistent with the property needing to be updated
-- because the property was updated with the corresponding attribute being absent the whole time.
let isFalseFlag (PFlag f) = not f
isFalseFlag _ = False
when (isJust (M.lookup "checked" new >>= guard . isFalseFlag))
(unsafeSetProp "checked" jsFalse obj')
let toRemove = M.difference old new
willInclude new' old'
| new' == old' = Nothing
| otherwise = Just new'
toInclude = M.differenceWith willInclude new old
remove k _ = case k of
"className" -> void $ obj' # "removeAttribute" $ "class"
"href" -> void $ obj' # "removeAttribute" $ "href"
"htmlFor" -> void $ obj' # "removeAttribute" $ "for"
"style" -> void $ obj' # "removeAttribute" $ "style"
"checked" -> unsafeSetProp (toJSString k) jsFalse obj'
"disabled" -> void $ obj' # "removeAttribute" $ "disabled"
_ -> void $ jsg2 "deleteProp" (toJSString k) obj'
traverseWithKey_ remove toRemove
let include k v =
let k' = toJSString k
in case v of
PPotato p -> void . p . RawNode =<< toJSVal obj' -- FIXME why throw away continuation...???
PData j -> unsafeSetProp k' j obj'
-- new text prop, set
PText t -> do
t' <- valMakeText t
unsafeSetProp k' t' obj'
-- new flag prop, set
PFlag b -> setFlag obj' k b
-- new listener, set
PListener h -> setListener i h obj' k'
traverseWithKey_ include toInclude
patchChildren
:: MonadUnliftIO m
#ifndef ghcjs_HOST_OS
=> MonadJSM m
#endif
=> Show a
=> NFData a
=> RawNode -> [ParVNode a] -> [ParVNode a] -> ParDiffT a m [ParVNode a]
patchChildren (RawNode p) [] new = liftJSM $ do
forM_ new $ \newChild -> do
RawNode cRaw <- runOnce (getRaw newChild)
p # "appendChild" $ cRaw
pure new
patchChildren _ old [] = liftJSM $ do
doc <- jsg "document"
tmp <- doc # "createElement" $ "div"
old' <- traverse (fmap unRawNode . runOnce . getRaw) old
void (tmp # "replaceChildren" $ old')
void (tmp # "remove" $ ())
pure []
patchChildren parent (old:olds) (new:news) =
(:) <$> patch' parent old new <*> patchChildren parent olds news
patch'
:: MonadUnliftIO m
#ifndef ghcjs_HOST_OS
=> MonadJSM m
#endif
=> Show a
=> NFData a
=> RawNode -> ParVNode a -> ParVNode a -> ParDiffT a m (ParVNode a)
patch' parent old new = do
i <- ask
case (old, new) of
(ParTextNode raw t', ParTextNode _ t)
-- text node did not change
| t == t' -> return old
-- text node changed
| otherwise -> liftJSM $ do
RawNode r <- runOnce raw
obj' <- makeObject r
tNew <- valMakeText t
unsafeSetProp "nodeValue" tNew obj'
return (ParTextNode raw t)
-- node may have changed
(ParNode raw name ps cs, ParNode _ name' ps' cs')
| name == name' -> do
raw' <- liftJSM $ do
RawNode r <- runOnce raw
obj' <- makeObject r
managePropertyState i obj' ps ps'
pure (RawNode r)
cs'' <- patchChildren raw' cs cs'
return $ ParNode raw name ps' cs''
-- node definitely has changed
_ -> liftJSM $ do
let RawNode p = parent
RawNode r <- runOnce $ getRaw old
RawNode c <- runOnce $ getRaw new
_ <- p # "replaceChild" $ (c, r)
return new
{-# SPECIALIZE interpret' :: forall a. NFData a => (JSM ~> JSM) -> Html (ParDiffT a JSM) a -> ParDiffT a JSM (ParVNode a) #-}
interpret'
:: forall m a
. MonadJSM m
=> NFData a
=> (m ~> JSM) -> Html (ParDiffT a m) a -> ParDiffT a m (ParVNode a)
interpret' toJSM (Html h') = h' mkNode mkPotato mkText
where
mkNode :: Text -> [(Text, Prop (ParDiffT a m) a)] -> [ParDiffT a m (ParVNode a)] -> ParDiffT a m (ParVNode a)
mkNode name ps cs = do
cs' <- sequence cs
i <- ask
let ps' = toProps ps
raw <- liftJSM . newOnce $ do
doc <- jsg "document"
raw' <- doc # "createElement" $ name
props toJSM i ps' (RawNode raw')
forM_ cs' $ \c -> do
RawNode cRaw <- runOnce (getRaw c)
raw' # "appendChild" $ cRaw
return (RawNode raw')
let p = Props (makeProp toJSM i <$> getProps ps')
return $ ParNode raw name p cs'
mkPotato :: JSM (RawNode, STM (Continuation (ParDiffT a m) a)) -> ParDiffT a m (ParVNode a)
mkPotato mrn = ask >>= \i -> liftJSM $ do
(rn, stm) <- mrn
let go = atomically stm >>= writeUpdate i . hoist (toJSM . runParDiff i) >> go
void $ forkIO go
fmap ParPotato $ newOnce $ pure rn
mkText :: Text -> ParDiffT a m (ParVNode a)
mkText t = liftJSM $ do
raw <- newOnce $ do
doc <- jsg "document"
RawNode <$> (doc # "createTextNode" $ t)
return $ ParTextNode raw t
instance
( MonadUnliftIO m
, MonadJSM m
, NFData a
, Show a ) => Backend (ParDiffT a) m a where
type VNode (ParDiffT a) m = ParVNode a
interpret = interpret'
setup = setup'
patch parent mOld new = case mOld of
-- first patch
Nothing ->
liftJSM $ do
let RawNode p = parent
RawNode c <- runOnce (getRaw new)
_ <- p # "appendChild" $ c
return new
Just old -> patch' parent old new
-- | Get the DOM node produced by 'setup'.
stage :: FromJSVal b => MonadJSM m => ParDiffT a m b
stage = liftJSM $ fromJSValUnchecked =<< jsg "container"