{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Shpadoinkle.Core (
Html(..), Prop(..)
, dataProp, flagProp, textProp, listenerProp, bakedProp
, listenRaw, listen, listenM, listenM_, listenC, listener
, h, baked, text
, props, children, name, textContent
, hoistHtml, hoistProp
, cataH, cataProp
, mapProps, mapChildren, injectProps, eitherH
, RawNode(..), RawEvent(..)
, Backend (..)
, type (~>)
, shpadoinkle
, JSM, MonadJSM, askJSM, runJSM, MonadUnliftIO(..), UnliftIO(..), liftJSM
, module UnliftIO.STM
) where
import Control.Arrow (second)
import qualified Control.Categorical.Functor as F
import Control.Category ((.))
import Control.PseudoInverseCategory (EndoIso (..),
HasHaskFunctors (fmapA),
PIArrow (piendo, piiso, pisecond),
PseudoInverseCategory (piinverse),
ToHask (piapply))
import Data.Functor.Identity (Identity (Identity, runIdentity))
import Data.Kind (Type)
import Data.List (foldl')
import Data.Map (alter, toList)
import Data.String (IsString (..))
import Data.Text (Text, pack)
import GHCJS.DOM.Types (JSM, MonadJSM, liftJSM)
import Language.Javascript.JSaddle (FromJSVal (..), JSVal,
ToJSVal (..), askJSM, runJSM)
import Prelude hiding ((.))
import UnliftIO (MonadUnliftIO (..),
UnliftIO (..))
import UnliftIO.STM (STM, TVar, atomically,
modifyTVar, newTVarIO, readTVar,
readTVarIO, retrySTM, writeTVar)
import Shpadoinkle.Continuation (Continuation, Continuous (..),
causes, eitherC, hoist, impur,
pur, shouldUpdate)
data Html :: (Type -> Type) -> Type -> Type where
Node :: Text -> [(Text, Prop m a)] -> [Html m a] -> Html m a
Potato :: JSM RawNode -> Html m a
TextNode :: Text -> Html m a
data Prop :: (Type -> Type) -> Type -> Type where
PData :: JSVal -> Prop m a
PText :: Text -> Prop m a
PFlag :: Bool -> Prop m a
PPotato :: (RawNode -> JSM (STM (Continuation m a))) -> Prop m a
PListener :: (RawNode -> RawEvent -> JSM (Continuation m a)) -> Prop m a
nubProps :: Monad m => Html m a -> Html m a
nubProps = mapPropsRecursive $ toList . foldl' f mempty
where
f acc (t,p) = alter (Just . g t p) t acc
g k new old = case (new, old) of
(PText t, Just (PText t')) | k == "className" -> PText $ t <> " " <> t'
(PListener l, Just (PListener l')) -> PListener $
\raw evt -> mappend <$> l raw evt <*> l' raw evt
_ -> new
mapPropsRecursive :: ([(Text, Prop m a)] -> [(Text, Prop m a)]) -> Html m a -> Html m a
mapPropsRecursive f = \case
Node t ps cs -> Node t (f ps) (mapPropsRecursive f <$> cs)
x -> x
listenM :: Monad m => Text -> m (a -> a) -> (Text, Prop m a)
listenM k = listenC k . impur
listenM_ :: Monad m => Text -> m () -> (Text, Prop m a)
listenM_ k = listenC k . causes
type Props' m a = [(Text, Prop m a)]
hoistHtml :: Functor m => Functor n => (m ~> n) -> Html m a -> Html n a
hoistHtml f = \case
Node t ps cs -> Node t (fmap (hoistProp f) <$> ps) (hoistHtml f <$> cs)
Potato p -> Potato p
TextNode t -> TextNode t
{-# INLINE hoistHtml #-}
hoistProp :: Functor m => (m ~> n) -> Prop m a -> Prop n a
hoistProp f = \case
PListener g -> PListener $ \x -> fmap (hoist f) . g x
PData t -> PData t
PText t -> PText t
PFlag t -> PFlag t
PPotato p -> PPotato $ fmap (fmap (hoist f)) . p
{-# INLINE hoistProp #-}
instance IsString (Html m a) where
fromString = TextNode . pack
{-# INLINE fromString #-}
instance IsString (Prop m a) where
fromString = PText . pack
{-# INLINE fromString #-}
instance Monad m => F.Functor EndoIso EndoIso (Html m) where
map (EndoIso f g i) = EndoIso (mapC . piapply $ map' (piendo f))
(mapC . piapply $ map' (piiso g i))
(mapC . piapply $ map' (piiso i g))
where map' :: EndoIso a b -> EndoIso (Continuation m a) (Continuation m b)
map' = F.map
{-# INLINE map #-}
instance Monad m => F.Functor EndoIso EndoIso (Prop m) where
map :: forall a b. EndoIso a b -> EndoIso (Prop m a) (Prop m b)
map f = EndoIso id mapFwd mapBack
where f' :: EndoIso (Continuation m a) (Continuation m b)
f' = F.map f
mapFwd :: Prop m a -> Prop m b
mapFwd (PData t) = PData t
mapFwd (PText t) = PText t
mapFwd (PFlag t) = PFlag t
mapFwd (PListener g) = PListener $ \r e -> piapply f' <$> g r e
mapFwd (PPotato p) = PPotato $ fmap (fmap (piapply f')) . p
mapBack :: Prop m b -> Prop m a
mapBack (PData t) = PData t
mapBack (PText t) = PText t
mapBack (PFlag t) = PFlag t
mapBack (PListener g) = PListener $ \r e -> piapply (piinverse f') <$> g r e
mapBack (PPotato b) = PPotato $ fmap (fmap (piapply (piinverse f'))) . b
{-# INLINE map #-}
instance Continuous Html where
mapC f (Node t ps es) = Node t (unMapProps . mapC f $ MapProps ps) (mapC f <$> es)
mapC _ (Potato p) = Potato p
mapC _ (TextNode t) = TextNode t
{-# INLINE mapC #-}
newtype MapProps m a = MapProps { unMapProps :: Props' m a }
instance Monad m => F.Functor EndoIso EndoIso (MapProps m) where
map f = piiso MapProps unMapProps . fmapA (pisecond (F.map f)) . piiso unMapProps MapProps
{-# INLINE map #-}
instance Continuous MapProps where
mapC f = MapProps . fmap (second (mapC f)) . unMapProps
{-# INLINE mapC #-}
instance Continuous Prop where
mapC _ (PData t) = PData t
mapC _ (PText t) = PText t
mapC _ (PFlag b) = PFlag b
mapC f (PListener g) = PListener $ \r -> fmap f . g r
mapC f (PPotato b) = PPotato $ fmap (fmap f) . b
{-# INLINE mapC #-}
dataProp :: JSVal -> Prop m a
dataProp = PData
{-# INLINE dataProp #-}
textProp :: Text -> Prop m a
textProp = PText
{-# INLINE textProp #-}
flagProp :: Bool -> Prop m a
flagProp = PFlag
{-# INLINE flagProp #-}
listenerProp :: (RawNode -> RawEvent -> JSM (Continuation m a)) -> Prop m a
listenerProp = PListener
{-# INLINE listenerProp #-}
bakedProp :: (RawNode -> JSM (STM (Continuation m a))) -> Prop m a
bakedProp = PPotato
{-# INLINE bakedProp #-}
cataProp
:: (JSVal -> b)
-> (Text -> b)
-> (Bool -> b)
-> ((RawNode -> RawEvent -> JSM (Continuation m a)) -> b)
-> ((RawNode -> JSM (STM (Continuation m a))) -> b)
-> Prop m a
-> b
cataProp d t f l p = \case
PData x -> d x
PText x -> t x
PFlag x -> f x
PListener x -> l x
PPotato x -> p x
h :: Text -> [(Text, Prop m a)] -> [Html m a] -> Html m a
h = Node
{-# INLINE h #-}
baked :: JSM RawNode -> Html m a
baked = Potato
{-# INLINE baked #-}
text :: Text -> Html m a
text = TextNode
{-# INLINE text #-}
props :: Applicative f => ([(Text, Prop m a)] -> f [(Text, Prop m a)]) -> Html m a -> f (Html m a)
props inj = \case
Node t ps cs -> (\ps' -> Node t ps' cs) <$> inj ps
t -> pure t
{-# INLINE props #-}
children :: Applicative f => ([Html m a] -> f [Html m a]) -> Html m a -> f (Html m a)
children inj = \case
Node t ps cs -> Node t ps <$> inj cs
t -> pure t
{-# INLINE children #-}
name :: Applicative f => (Text -> f Text) -> Html m a -> f (Html m a)
name inj = \case
Node t ps cs -> (\t' -> Node t' ps cs) <$> inj t
t -> pure t
{-# INLINE name #-}
textContent :: Applicative f => (Text -> f Text) -> Html m a -> f (Html m a)
textContent inj = \case
TextNode t -> TextNode <$> inj t
n -> pure n
{-# INLINE textContent #-}
eitherH :: Monad m => (a -> Html m a) -> (b -> Html m b) -> Either a b -> Html m (Either a b)
eitherH = eitherC
{-# INLINE eitherH #-}
cataH :: (Text -> [(Text, Prop m a)] -> [b] -> b)
-> (JSM RawNode -> b)
-> (Text -> b)
-> Html m a -> b
cataH f g h' = \case
Node t ps cs -> f t ps (cataH f g h' <$> cs)
Potato p -> g p
TextNode t -> h' t
type m ~> n = forall a. m a -> n a
newtype RawNode = RawNode { unRawNode :: JSVal }
instance ToJSVal RawNode where toJSVal = return . unRawNode
instance FromJSVal RawNode where fromJSVal = return . Just . RawNode
newtype RawEvent = RawEvent { unRawEvent :: JSVal }
instance ToJSVal RawEvent where toJSVal = return . unRawEvent
instance FromJSVal RawEvent where fromJSVal = return . Just . RawEvent
instance {-# OVERLAPPING #-} IsString [(Text, Prop m a)] where
fromString = pure . ("className", ) . textProp . pack
{-# INLINE fromString #-}
listener :: Continuation m a -> Prop m a
listener = listenerProp . const . const . return
{-# INLINE listener #-}
listenRaw :: Text -> (RawNode -> RawEvent -> JSM (Continuation m a)) -> (Text, Prop m a)
listenRaw k = (,) k . listenerProp
{-# INLINE listenRaw #-}
listenC :: Text -> Continuation m a -> (Text, Prop m a)
listenC k = listenRaw k . const . const . return
{-# INLINE listenC #-}
listen :: Text -> (a -> a) -> (Text, Prop m a)
listen k = listenC k . pur
{-# INLINE listen #-}
mapProps :: ([(Text, Prop m a)] -> [(Text, Prop m a)]) -> Html m a -> Html m a
mapProps f = runIdentity . props (Identity . f)
{-# INLINE mapProps #-}
mapChildren :: ([Html m a] -> [Html m a]) -> Html m a -> Html m a
mapChildren f = runIdentity . children (Identity . f)
{-# INLINE mapChildren #-}
injectProps :: [(Text, Prop m a)] -> Html m a -> Html m a
injectProps ps = mapProps (++ ps)
{-# INLINE injectProps #-}
class Backend b m a | b m -> a where
type VNode b m
interpret
:: (m ~> JSM)
-> Html (b m) a
-> b m (VNode b m)
patch
:: RawNode
-> Maybe (VNode b m)
-> VNode b m
-> b m (VNode b m)
setup :: JSM () -> JSM ()
shpadoinkle
:: forall b m a
. Backend b m a => Monad (b m) => Eq a
=> (m ~> JSM)
-> (TVar a -> b m ~> m)
-> a
-> TVar a
-> (a -> Html (b m) a)
-> b m RawNode
-> JSM ()
shpadoinkle toJSM toM initial model view stage = do
let
j :: b m ~> JSM
j = toJSM . toM model
go :: RawNode -> VNode b m -> a -> JSM (VNode b m)
go c n a = j $ do
!m <- interpret toJSM . nubProps $ view a
patch c (Just n) m
setup @b @m @a $ do
(c,n) <- j $ do
c <- stage
n <- interpret toJSM . nubProps $ view initial
_ <- patch c Nothing n
return (c,n)
_ <- shouldUpdate (go c) n model
return ()