Verified Commit 70b839ad authored by Isaac Shapira's avatar Isaac Shapira
Browse files

hell

parent 2b0a6e81
Pipeline #263732577 failed with stages
in 24 seconds
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE FlexibleInstances #-}
......@@ -41,24 +42,21 @@ 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 GHCJS.Foreign.Export
import GHCJS.Types (jsval)
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)
import UnliftIO.Concurrent (forkIO)
import Shpadoinkle
import qualified Shpadoinkle.Console as Console
default (Text)
......@@ -115,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
......@@ -181,39 +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)
(\dep html -> do
exp' <- liftJSM $ export dep
let jsv :: JSVal = jsval exp'
Console.log @ToJSVal jsv
html
)
(\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,7 +44,7 @@ library:
- exceptions
- transformers-base
- monad-control
- ghcjs-base
- 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
......
......@@ -510,16 +510,25 @@ shpadoinkle toJSM toM initial model view stage = do
j :: b m ~> JSM
j = toJSM . toM model
sview = view
{-# SCC sview #-}
sinterpret = interpret
{-# SCC sinterpret #-}
spatch = patch
{-# SCC spatch #-}
go :: RawNode -> VNode b m -> a -> JSM (VNode b m)
go c n a = j $ do
!m <- interpret toJSM $ view a
patch c (Just n) m
!m <- sinterpret toJSM $ sview a
spatch c (Just n) m
setup @b @m @a $ do
(c,n) <- j $ do
c <- stage
n <- interpret toJSM $ view initial
_ <- patch c Nothing n
n <- sinterpret toJSM $ sview initial
_ <- spatch c Nothing n
return (c,n)
_ <- shouldUpdate (go c) n model
return ()
......
......@@ -6,10 +6,12 @@
, extra ? (_: b: b)
, optimize ? true
, system ? builtins.currentSystem
, enableLibraryProfiling ? false
, enableExecutableProfiling ? false
}:
let
pkgs = import ./nix/pkgs.nix { inherit compiler isJS system chan; };
pkgs = import ./nix/pkgs.nix { inherit compiler isJS system chan enableLibraryProfiling enableExecutableProfiling; };
util = import ./nix/util.nix { inherit pkgs compiler isJS; };
in
with pkgs; with lib;
......@@ -37,6 +39,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 $
simple runParDiff (Model []) view getBody
......@@ -290,6 +290,19 @@ executables:
- Shpadoinkle-backend-pardiff
- Shpadoinkle-lens
streaming:
main: Streaming.hs
other-modules: []
source-dirs: .
dependencies:
- streaming
- text
- Shpadoinkle
- Shpadoinkle-streaming
- Shpadoinkle-html
- Shpadoinkle-backend-pardiff
git: https://gitlab.com/fresheyeball/Shpadoinkle.git
......@@ -16,3 +16,4 @@ p widgets
p examples
p tests
p isreal
p streaming
......@@ -160,6 +160,7 @@ in {
Shpadoinkle-marketing = call "Shpadoinkle-marketing" ../marketing;
Shpadoinkle-html = call "Shpadoinkle-html" ../html;
Shpadoinkle-router = call "Shpadoinkle-router" ../router;
Shpadoinkle-streaming = call "Shpadoinkle-streaming" ../streaming;
Shpadoinkle-widgets = addTest (call "Shpadoinkle-widgets" ../widgets) hpkgs;
Shpadoinkle-tests = super.haskell.packages.${compiler}.callCabal2nix "tests" (gitignore ../tests) {};
......
{ chan, compiler, isJS }:
{ chan, compiler, isJS, enableLibraryProfiling, enableExecutableProfiling }:
with (import ./base-pkgs.nix { inherit chan; } {}).lib;
foldl' composeExtensions (_: _: {})
[
(import ./overlay-reflex.nix { inherit compiler isJS; })
(import ./overlay-reflex.nix { inherit compiler isJS enableLibraryProfiling; })
(import ./overlay-shpadoinkle.nix { inherit compiler isJS; })
]
......@@ -2,10 +2,12 @@
, isJS ? false
, system ? "x86_64-linux"
, chan ? (import ./chan.nix)
, enableLibraryProfiling ? false
, enableExecutableProfiling ? false
}:
import ./base-pkgs.nix { inherit chan; } {
inherit system;
overlays = [
(import ./overlay.nix { inherit chan compiler isJS; })
(import ./overlay.nix { inherit chan compiler isJS enableLibraryProfiling enableExecutableProfiling; })
];
}
Shpadoinkle Streaming aka S11 Streaming
Copyright © 2021 Morgan Thomas
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the