{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
#ifndef ghcjs_HOST_OS
{-# LANGUAGE StandaloneDeriving #-}
#endif
{-|
This backend is to serve as a cannonical 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 cannonical, 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
import Control.Compactable
import Control.Lens
import Control.Monad.Reader
import Data.Align
import Data.Foldable
import Data.Kind
import Data.Map (Map)
import qualified Data.Map as M
import Data.Monoid ((<>))
import Data.Once
import Data.Text
import Data.These
import Data.Traversable
import Data.UUID
import GHC.Generics
import Language.Javascript.JSaddle hiding (( # ))
import NeatInterpolation
import System.Random
import UnliftIO
import Shpadoinkle hiding (h, name, props, text)
default (Text)
newtype ParDiffT s model m a = ParDiffT { unParDiff :: ReaderT (s model) m a }
deriving
( Functor
, Applicative
, Alternative
, Monad
, MonadIO
, MonadReader (s model)
, MonadTrans
)
#ifndef ghcjs_HOST_OS
deriving instance MonadJSM m => MonadJSM (ParDiffT s model m)
#endif
instance MonadUnliftIO m => MonadUnliftIO (ParDiffT s 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 :: t model -> ParDiffT t 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 | ParVListen UUID (RawNode -> RawEvent -> JSM a) | ParVFlag Bool
deriving (Functor, Generic)
instance Show (ParVProp a) where
show = \case
ParVText t -> "ParVText " <> show t
ParVListen u _ -> "ParVListen " <> show u <>" _"
ParVFlag b -> "ParVFlag " <> show b
props :: Territory s => (m ~> JSM) -> s a -> Map Text (Prop (ParDiffT s 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 :: Territory s => (m ~> JSM) -> s a -> Object -> Text -> Prop (ParDiffT s a m) a -> JSM ()
prop toJSM i raw k = \case
PText t -> setProp' raw k t
PListener f -> setListener i (\x y -> 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'
setListener :: Territory s => s a -> (RawNode -> RawEvent -> JSM a) -> Object -> Text -> JSM ()
setListener i m o k = do
elm <- RawNode <$> toJSVal o
setProp' o ("on" <> k) . fun $ \_ _ -> \case
e:_ -> writeUpdate i . const $ m elm (RawEvent e)
_ -> 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 :: (m ~> JSM) -> t a -> Prop (ParDiffT t a m) a -> JSM (ParVProp a)
makeProp toJSM i = \case
PText t -> return $ ParVText t
PListener m -> do
u <- liftIO randomIO
return . ParVListen u $ \x y -> toJSM . runParDiff i $ m x y
PFlag b -> return $ ParVFlag b
setup' :: MonadJSM m => JSM () -> ParDiffT s a m ()
setup' cb = liftJSM $ do
void $ eval @Text [text|
window.deleteProp = (k, obj) => {
delete obj[k]
}
window.container = document.createElement('div')
document.body.appendChild(container)
|]
liftJSM 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 :: Territory s => MonadJSM m => s a -> Object -> Map Text (ParVProp a) -> Map Text (ParVProp a) -> m ()
managePropertyState i obj' old new' = void $
M.toList (align old new') `for` \(k, x) -> case x of
-- only old had it, delete
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'
-- new text prop, set
That (ParVText t) -> voidJSM $ setProp' obj' k =<< toJSVal t
-- changed text prop, set
These (ParVText t)
(ParVText t')
| t /= t' -> voidJSM $ setProp' obj' k =<< toJSVal t'
-- new flag prop, set
That (ParVFlag b) -> setFlag obj' k b
-- changed flag prop, set
These (ParVFlag t)
(ParVFlag t')
| t /= t' -> setFlag obj' k t'
-- new listner, set
That (ParVListen _ h) -> voidJSM $ setListener i h obj' k
-- changed listener, set
These (ParVListen u _) (ParVListen u' h) | u /= u' -> voidJSM $ setListener i h obj' k
-- no change, do nothing
These _ _ -> return ()
patchChildren
:: MonadUnliftIO m
#ifndef ghcjs_HOST_OS
=> MonadJSM m
#endif
=> Show a
=> Territory s
=> RawNode -> [ParVNode a] -> [ParVNode a] -> ParDiffT s 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
=> Territory s
=> RawNode -> Maybe (ParVNode a) -> ParVNode a -> ParDiffT s a m (ParVNode a)
patch' parent old new' = do
i <- ask
case (old, new') of
-- text node did not change
(Just old'@(ParTextNode _ t)
, ParTextNode _ t')
| t == t' -> return old'
-- text node changed
(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'
-- node may have changed
(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''
-- node definately has changed
(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'
-- first patch
(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
=> Territory s
=> (m ~> JSM) -> Html (ParDiffT s a m) a -> ParDiffT s 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
, Territory t ) => Backend (ParDiffT t a) m a where
type VNode (ParDiffT t a) m = ParVNode a
interpret = interpret'
setup = setup'
patch = patch'
stage :: FromJSVal b => MonadJSM m => ParDiffT s a m b
stage = liftJSM $ fromJSValUnchecked =<< jsg "container"