Verified Commit dcf7b2ab authored by Isaac Shapira's avatar Isaac Shapira
Browse files

fuck

parents 784e52d6 e06c84d5
Pipeline #263158830 failed with stages
in 2 minutes and 40 seconds
......@@ -85,6 +85,7 @@ import Shpadoinkle (Backend (..), Continuation,
fromProps, hoist, type (~>),
writeUpdate)
import Debug.Trace (trace)
default (Text)
......@@ -140,7 +141,7 @@ 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
ParDepend :: !Dependency -> ParVNode a -> ParVNode a
ParDepend :: !Dependency -> Maybe (ParVNode a) -> ParVNode a
type ParVProps = Props JSM
......@@ -188,12 +189,12 @@ setListener i m o k = do
unsafeSetProp ("on" <> k) f o
getRaw :: ParVNode a -> Once JSM RawNode
getRaw :: ParVNode a -> Maybe (Once JSM RawNode)
getRaw = \case
ParNode mk _ _ _ -> mk
ParPotato mk -> mk
ParTextNode mk _ -> mk
ParDepend _ h -> getRaw h
ParNode mk _ _ _ -> Just mk
ParPotato mk -> Just mk
ParTextNode mk _ -> Just mk
ParDepend _ h -> getRaw =<< h
makeProp :: Monad m => (m ~> JSM) -> TVar a -> Prop (ParDiffT a m) a -> ParVProp a
......@@ -276,7 +277,7 @@ managePropertyState i obj' (Props !old) (Props !new) = void $ do
let include k v =
let k' = toJSString k
in case v of
PPotato p -> void . p . RawNode =<< toJSVal obj' -- FIXME why throw away continuation...???
PPotato p -> void . p . RawNode =<< toJSVal obj' -- throw away the stale continuation
PData j -> unsafeSetProp k' j obj'
-- new text prop, set
PText t -> do
......@@ -349,11 +350,25 @@ patch' parent old new = do
cs'' <- patchChildren raw' cs cs'
return $ ParNode raw name ps' cs''
(ParDepend dep html, ParDepend dep' _)
| dep == dep' -> pure $ ParDepend dep html
(ParDepend dep (Just html), ParDepend dep' _)
| dep == dep' -> pure $ ParDepend dep (Just html)
(ParDepend _ html, ParDepend _ html') ->
patch' parent html html'
(ParDepend dep (Just html), ParDepend dep' _) -> do
newShallowInterpreted <- liftJSM (applyVNodeComponent dep') -- interprets shallowly
-- patch next stage
newAtLeastAsVisible <- patch' parent oldDeepInterpreted newShallowInterpreted
let RawNode p = parent
case (getRaw oldDeepInterpreted, getRaw newAtLeastAsVisible) of
(Just oldRawOnce, Just newRawOnce) -> liftJSM $ do
RawNode oldRaw <- runOnce oldRawOnce
RawNode newRaw <- runOnce newRawOnce
void (p # "replaceChild" $ (oldRaw, newRaw))
_ -> error "There should be at least one evaluated top-level set of raw for new, due to patch'"
pure $ ParComponent (Just newAtLeastAsVisible) newC
(ParDepend (Dependency l _) html, ParDepend (Dependency r d) html') ->
ParDepend (Dependency (Just $ incDep l r) d) <$> patch' parent html html'
-- node definitely has changed
_ -> liftJSM $ do
......@@ -364,6 +379,13 @@ patch' parent old new = do
return new
incDep :: Maybe Int -> Maybe Int -> Int
incDep (Just l) (Just r) = max l r + 1
incDep (Just l) _ = l + 1
incDep _ (Just r) = r + 1
incDep _ _ = 1
interpret'
:: forall m a
. MonadJSM m
......@@ -389,7 +411,7 @@ interpret' toJSM (Html h') = h' mkNode mkDep mkPotato mkText
return $ ParNode raw name p cs'
mkDep :: Dependency -> ParDiffT a m (ParVNode a) -> ParDiffT a m (ParVNode a)
mkDep d pd = ParDepend d <$> pd
mkDep d _ = ParDepend d Nothing
mkPotato :: JSM RawNode -> ParDiffT a m (ParVNode a)
mkPotato = fmap ParPotato . liftJSM . newOnce
......
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE FlexibleInstances #-}
......@@ -41,15 +42,15 @@ import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),
defaultLiftBaseWith,
defaultRestoreM)
import Data.FileEmbed (embedStringFile)
import Data.Text (Text, split)
import Data.Traversable (for)
import Data.Map.Internal (Map (Bin, Tip))
import Data.Text (Text, words)
import GHCJS.DOM (currentDocumentUnchecked)
import GHCJS.DOM.Document (createElement, getBodyUnsafe)
import GHCJS.DOM.Element (setAttribute)
import GHCJS.DOM.Node (appendChild)
import Language.Javascript.JSaddle hiding (JSM, MonadJSM, liftJSM,
(#))
import Prelude hiding (id, (.))
import Prelude hiding (id, words, (.))
import UnliftIO (MonadUnliftIO (..), TVar,
UnliftIO (UnliftIO, unliftIO),
withUnliftIO)
......@@ -112,54 +113,67 @@ runSnabbdom :: TVar model -> SnabbdomT model m ~> m
runSnabbdom t (Snabbdom r) = runReaderT r t
props :: Monad m => NFData a => (m ~> JSM) -> TVar a -> [(Text, Prop (SnabbdomT a m) a)] -> JSM Object
props toJSM i xs = do
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
{-# INLINE traverseWithKey_ #-}
props :: Monad m => NFData a => (m ~> JSM) -> TVar a -> Props (SnabbdomT a m) a -> JSM Object
props toJSM i (Props 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 ->
if u == mempty then pure () else 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
flip traverseWithKey_ xs $ \k p ->
let k' = toJSString k
in case p of
PData d -> unsafeSetProp 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
| k == "className" -> forM_ (words t) $ \u ->
unsafeSetProp (toJSString u) jsTrue classesObj
| t /= "" -> do
t' <- valMakeText t
unsafeSetProp k' t' $ case k of
"style" -> attrsObj
"type" -> attrsObj
"autofocus" -> attrsObj
_ -> propsObj
| otherwise -> do
t' <- valMakeText t
unsafeSetProp 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 k' f' listenersObj
PFlag b ->
unsafeSetProp k' (toJSBool b) propsObj
p <- toJSVal propsObj
l <- toJSVal listenersObj
......@@ -178,34 +192,34 @@ instance (MonadJSM m, NFData 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 (Html h') = h'
(\name ps children -> do
cs <- sequence children
i <- ask; liftJSM $ do
o <- props toJSM i $ fromProps ps
jsg3 "vnode" name o cs >>= fromJSValUnchecked)
(const id)
(\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)
(\t -> liftJSM $ fromJSValUnchecked =<< toJSVal t)
interpret toJSM (Html h') = h' mkNode mkDep mkPotato mkText
where
mkNode name ps children = do
i <- ask; liftJSM $ do
!o <- props toJSM i ps
!cs <- toJSM . runSnabbdom i $ sequence children
SnabVNode <$> jsg3 "vnode" name o cs
mkDep = const id
mkPotato 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
SnabVNode <$> jsg2 "vnode" "div" o
mkText = liftJSM . fmap SnabVNode . valMakeText
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
patch (RawNode container) mPreviousNode newNode = liftJSM $ newNode <$ jsg2 "patchh" previousNode newNode
where previousNode = maybe container unVNode mPreviousNode
setup :: JSM () -> JSM ()
......
......@@ -44,6 +44,7 @@ library:
- exceptions
- transformers-base
- monad-control
- containers
- mtl >= 2.2.2 && < 2.3
- unliftio >= 0.2.12 && < 0.3
......
......@@ -10,6 +10,7 @@ packages: core
, marketing
, html
, router
, streaming
, widgets
, examples
......
......@@ -17,7 +17,7 @@ module Shpadoinkle.Continuation (
-- * The Continuation Type
Continuation (..)
, runContinuation
, done, pur, impur, kleisli, causes, contIso
, done, pur, impur, kleisli, causes, causedBy, merge, contIso
-- * The Class
, Continuous (..)
-- ** Hoist
......@@ -45,6 +45,7 @@ module Shpadoinkle.Continuation (
import Control.Arrow (first)
import qualified Control.Categorical.Functor as F
import Control.DeepSeq (NFData (..), force)
import Control.Monad (void)
import Control.Monad.Trans.Class (MonadTrans (..))
import Control.PseudoInverseCategory (EndoIso (..))
import Data.Maybe (fromMaybe)
......@@ -58,7 +59,6 @@ import Language.Javascript.JSaddle (MonadJSM)
import UnliftIO (MonadUnliftIO, TVar,
UnliftIO, askUnliftIO,
atomically, liftIO,
modifyTVar',
newTVarIO, readTVar,
readTVarIO, unliftIO,
writeTVar)
......@@ -84,6 +84,7 @@ import UnliftIO.Concurrent (forkIO)
-- finishes and they are all done atomically together.
data Continuation m a = Continuation (a -> a, a -> m (Continuation m a))
| Rollback (Continuation m a)
| Merge (Continuation m a)
| Pure (a -> a)
......@@ -117,6 +118,15 @@ causes :: Applicative m => m () -> Continuation m a
causes m = impur (id <$ m)
causedBy :: m (Continuation m a) -> Continuation m a
causedBy = Continuation . (id,) . const
-- | A continuation can be forced to write its changes midflight.
merge :: Continuation m a -> Continuation m a
merge = Merge
-- | 'runContinuation' takes a 'Continuation' and a state value and runs the whole Continuation
-- as if the real state was frozen at the value given to 'runContinuation'. It performs all the
-- IO actions in the stages of the Continuation and returns a pure state updating function
......@@ -134,6 +144,7 @@ runContinuation' f (Continuation (g, h)) x = do
i <- h (f x)
runContinuation' (g.f) i x
runContinuation' _ (Rollback f) x = runContinuation' id f x
runContinuation' f (Merge g) x = runContinuation' f g x
runContinuation' f (Pure g) _ = return (g.f)
......@@ -151,13 +162,15 @@ instance Continuous Continuation where
hoist :: Functor m => (forall b. m b -> n b) -> Continuation m a -> Continuation n a
hoist _ (Pure f) = Pure f
hoist f (Rollback r) = Rollback (hoist f r)
hoist f (Merge g) = Merge (hoist f g)
hoist f (Continuation (g, h)) = Continuation . (g,) $ \x -> f $ hoist f <$> h x
-- | Apply a lens inside a Continuation to change the Continuation's type.
liftC' :: Functor m => (a -> b -> b) -> (b -> a) -> Continuation m a -> Continuation m b
liftC' f g (Pure h) = Pure (\x -> f (h (g x)) x)
liftC' f g (Rollback r) = Rollback (liftC' f g r)
liftC' f g (Pure h) = Pure (\x -> f (h (g x)) x)
liftC' f g (Rollback r) = Rollback (liftC' f g r)
liftC' f g (Merge h) = Merge (liftC' f g h)
liftC' f g (Continuation (h, i)) = Continuation (\x -> f (h (g x)) x, \x -> liftC' f g <$> i (g x))
......@@ -165,6 +178,7 @@ liftC' f g (Continuation (h, i)) = Continuation (\x -> f (h (g x)) x, \x -> lift
liftCMay' :: Applicative m => (a -> b -> b) -> (b -> Maybe a) -> Continuation m a -> Continuation m b
liftCMay' f g (Pure h) = Pure $ \x -> maybe x (flip f x . h) $ g x
liftCMay' f g (Rollback r) = Rollback (liftCMay' f g r)
liftCMay' f g (Merge h) = Merge (liftCMay' f g h)
liftCMay' f g (Continuation (h, i)) =
Continuation (\x -> maybe x (flip f x . h) $ g x, maybe (pure done) (fmap (liftCMay' f g) . i) . g)
......@@ -218,8 +232,9 @@ rightC = mapC rightC'
-- | Transform a Continuation to work on 'Maybe's. If it encounters 'Nothing', then it cancels itself.
maybeC' :: Applicative m => Continuation m a -> Continuation m (Maybe a)
maybeC' (Pure f) = Pure (fmap f)
maybeC' (Rollback r) = Rollback (maybeC' r)
maybeC' (Pure f) = Pure (fmap f)
maybeC' (Rollback r) = Rollback (maybeC' r)
maybeC' (Merge f) = Merge (maybeC' f)
maybeC' (Continuation (f, g)) = Continuation . (fmap f,) $
\case
Just x -> maybeC' <$> g x
......@@ -242,8 +257,9 @@ comaybe f x = fromMaybe x . f $ Just x
-- when the input Continuation would replace the current value with 'Nothing',
-- instead the current value is retained.
comaybeC' :: Functor m => Continuation m (Maybe a) -> Continuation m a
comaybeC' (Pure f) = Pure (comaybe f)
comaybeC' (Rollback r) = Rollback (comaybeC' r)
comaybeC' (Pure f) = Pure (comaybe f)
comaybeC' (Rollback r) = Rollback (comaybeC' r)
comaybeC' (Merge f) = Merge (comaybeC' f)
comaybeC' (Continuation (f,g)) = Continuation (comaybe f, fmap comaybeC' . g . Just)
......@@ -275,12 +291,14 @@ eitherC' f g = Continuation . (id,) $ \case
Left x -> case f of
Pure h -> pure (Pure (mapLeft h))
Rollback r -> pure . Rollback $ eitherC' r done
Merge h -> pure . Merge $ eitherC' h done
Continuation (h, i) ->
(\j -> Continuation (mapLeft h, const . pure $ eitherC' j (Rollback done)))
<$> i x
Right x -> case g of
Pure h -> pure (Pure (mapRight h))
Rollback r -> pure . Rollback $ eitherC' done r
Merge h -> pure . Merge $ eitherC' done h
Continuation (h, i) ->
(\j -> Continuation (mapRight h, const . pure $ eitherC' (Rollback done) j))
<$> i x
......@@ -300,7 +318,8 @@ eitherC _ r (Right x) = mapC (eitherC' (pur id)) (r x)
contIso :: Functor m => (a -> b) -> (b -> a) -> Continuation m a -> Continuation m b
contIso f g (Continuation (h, i)) = Continuation (f.h.g, fmap (contIso f g) . i . g)
contIso f g (Rollback h) = Rollback (contIso f g h)
contIso f g (Pure h) = Pure (f.h.g)
contIso f g (Merge h) = Merge (contIso f g h)
contIso f g (Pure h) = Pure (f.h.g)
-- | @Continuation m@ is a Functor in the EndoIso category (where the objects
......@@ -313,8 +332,9 @@ instance Applicative m => F.Functor EndoIso EndoIso (Continuation m) where
-- | You can combine multiple Continuations homogeneously using the 'Monoid' typeclass
-- instance. The resulting Continuation will execute all the subcontinuations in parallel,
-- allowing them to see each other's state updates and roll back each other's updates,
-- applying all of the updates generated by all the subcontinuations atomically once
-- all of them are done.
-- applying all of the unmerged updates generated by all the subcontinuations atomically once
-- all of them are done. A merge in any one of the branches will cause all of
-- the changes that branch can see to be merged.
instance Applicative m => Semigroup (Continuation m a) where
(Continuation (f, g)) <> (Continuation (h, i)) =
Continuation (f.h, \x -> (<>) <$> g x <*> i x)
......@@ -328,6 +348,8 @@ instance Applicative m => Semigroup (Continuation m a) where
(Continuation (f,g)) <> (Pure h) = Continuation (f.h,g)
(Pure f) <> (Rollback g) = Continuation (f, const (pure (Rollback g)))
(Rollback f) <> (Pure _) = Rollback f
(Merge f) <> g = Merge (f <> g)
f <> (Merge g) = Merge (f <> g)
-- | Since combining Continuations homogeneously is an associative operation,
......@@ -342,8 +364,11 @@ writeUpdate' h model f = do
m <- f (h i)
case m of
Continuation (g,gs) -> writeUpdate' (g . h) model gs
Pure g -> atomically (modifyTVar' model (force . g . h))
Rollback gs -> writeUpdate' id model (const (return gs))
Pure g -> atomically (writeTVar model . g . h =<< readTVar model)
Merge g -> do
atomically $ writeTVar model . h =<< readTVar model
writeUpdate' id model (const (return g))
Rollback gs -> writeUpdate' id model (const (return gs))
-- | Run a Continuation on a state variable. This may update the state.
......@@ -351,8 +376,9 @@ writeUpdate' h model f = do
-- and an asynchronous, non-blocking operation for impure updates.
writeUpdate :: MonadUnliftIO m => NFData a => TVar a -> Continuation m a -> m ()
writeUpdate model = \case
Continuation (f,g) -> () <$ forkIO (writeUpdate' f model g)
Pure f -> atomically (modifyTVar' model (force . f))
Continuation (f,g) -> void . forkIO $ writeUpdate' f model g
Pure f -> atomically (writeTVar model . f =<< readTVar model)
Merge f -> writeUpdate model f
Rollback f -> writeUpdate model f
......
......@@ -345,7 +345,7 @@ h t ps cs = Html $ \a d b c -> a t (toProps ps) ((\(Html h') -> h' a d b c) <$>
-- | Memoed
depending :: (Eq a, Show a, Typeable a) => (a -> Html m c) -> (a -> Html m c)
depending f x = Html $ \a d b c -> d (Dependency x)
depending f x = Html $ \a d b c -> d (Dependency Nothing x)
$ case f x of Html h' -> h' a d b c
......@@ -438,15 +438,15 @@ injectProps ps = mapProps (<> toProps ps)
{-# INLINE injectProps #-}
data Dependency = forall a. (Eq a, Show a, Typeable a) => Dependency !a
data Dependency = forall a. (Eq a, Show a, Typeable a) => Dependency !(Maybe Int) !a
instance Eq Dependency where
Dependency l == Dependency r = cast l == Just r
Dependency li l == Dependency ri r = li == ri && cast l == Just r
instance Show Dependency where
show (Dependency x) = "Dependency (" ++ show x ++ ")"
show (Dependency i x) = "Dependency " ++ show i ++ " (" ++ show x ++ ")"
-- | The Backend class describes a backend that can render 'Html'.
......
......@@ -37,6 +37,7 @@ in
Shpadoinkle-lens
Shpadoinkle-html
Shpadoinkle-router
Shpadoinkle-streaming
Shpadoinkle-widgets
Shpadoinkle-isreal
......
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
module Main where
import Prelude hiding (div)
import Control.Concurrent (threadDelay)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Text (Text, pack)
import Shpadoinkle (Html, NFData, liftC)
import Shpadoinkle.Backend.ParDiff (runParDiff)
import Shpadoinkle.Html (button, div, getBody, onClickC,
text)
import Shpadoinkle.Run (runJSorWarp, simple)
import Shpadoinkle.Streaming (consumeStream)
import "streaming" Streaming (Of, Stream)
import Streaming.Prelude (repeatM)
default (Text)
exampleStream :: MonadIO m => Stream (Of Int) m ()
exampleStream = repeatM $ do
liftIO $ threadDelay 1000000
return 1
newtype Model = Model { streamContents :: [Int] }
deriving (Eq, Show, NFData)
view :: MonadIO m => Model -> Html m Model
view (Model ns) =
div
[]
[ text (pack (show ns))
, liftC (\c m -> m { streamContents = c }) streamContents $
button
[ onClickC (consumeStream exampleStream (return . (:))) ]
[ text "Go" ]
]
main :: IO ()
main = runJSorWarp 8080 $