{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
module Web.Rep.Socket
( socketPage,
defaultSocketPage,
SocketConfig (..),
defaultSocketConfig,
serveSocketBox,
CodeBox,
CoCodeBox,
CodeBoxConfig (..),
defaultCodeBoxConfig,
codeBox,
codeBoxWith,
serveRep,
serveRepWithBox,
replaceInput,
replaceOutput,
replaceOutput_,
sharedStream,
PlayConfig (..),
defaultPlayConfig,
repPlayConfig,
servePlayStream,
servePlayStreamWithBox,
Code (..),
code,
console,
val,
replace,
append,
clean,
webSocket,
refreshJsbJs,
preventEnter,
runScriptJs,
)
where
import Box
import Box.Socket (serverApp)
import Control.Concurrent.Async
import Control.Monad
import Control.Monad.State.Lazy
import Data.Bifunctor
import Data.ByteString (ByteString)
import Data.ByteString.Char8 qualified as C
import Data.Functor.Contravariant
import Data.HashMap.Strict as HashMap
import Data.Profunctor
import Data.String.Interpolate
import Data.Text (Text)
import Data.Text qualified as Text
import FlatParse.Basic
import GHC.Generics
import MarkupParse
import MarkupParse.FlatParse
import Network.Wai.Handler.WebSockets
import Network.WebSockets qualified as WS
import Optics.Core hiding (element)
import Web.Rep.Bootstrap
import Web.Rep.Page
import Web.Rep.Server
import Web.Rep.Shared
import Web.Rep.SharedReps
import Web.Scotty (middleware, scotty)
toText_ :: ByteString -> Text
toText_ :: ByteString -> Text
toText_ = [Char] -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
utf8ToStr
fromText_ :: Text -> ByteString
fromText_ :: Text -> ByteString
fromText_ = [Char] -> ByteString
strToUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
Text.unpack
socketPage :: Page
socketPage :: Page
socketPage =
forall a. Monoid a => a
mempty
forall a b. a -> (a -> b) -> b
& forall a. IsLabel "jsOnLoad" a => a
#jsOnLoad
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ forall a. Monoid a => [a] -> a
mconcat
[ Js
webSocket,
Js
runScriptJs,
Js
refreshJsbJs,
Js
preventEnter
]
defaultSocketPage :: Page
defaultSocketPage :: Page
defaultSocketPage =
Page
bootstrapPage
forall a. Semigroup a => a -> a -> a
<> Page
socketPage
forall a b. a -> (a -> b) -> b
& forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set
#htmlBody
( ByteString -> [Attr] -> Markup -> Markup
element
ByteString
"div"
[ByteString -> ByteString -> Attr
Attr ByteString
"class" ByteString
"container"]
( ByteString -> [Attr] -> Markup -> Markup
element
ByteString
"div"
[ByteString -> ByteString -> Attr
Attr ByteString
"class" ByteString
"row"]
(ByteString -> [Attr] -> ByteString -> Markup
elementc ByteString
"h1" [] ByteString
"web-rep testing")
forall a. Semigroup a => a -> a -> a
<> ByteString -> [Attr] -> Markup -> Markup
element
ByteString
"div"
[ByteString -> ByteString -> Attr
Attr ByteString
"class" ByteString
"row"]
( forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
( \(ByteString
t, ByteString
h) ->
ByteString -> [Attr] -> Markup -> Markup
element
ByteString
"div"
[ByteString -> ByteString -> Attr
Attr ByteString
"class" ByteString
"row"]
(ByteString -> [Attr] -> Markup -> Markup
element ByteString
"h2" [] (ByteString -> [Attr] -> ByteString -> Markup
elementc ByteString
"div" [ByteString -> ByteString -> Attr
Attr ByteString
"id" ByteString
t] ByteString
h))
)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ByteString, ByteString)]
sections
)
)
)
where
sections :: [(ByteString, ByteString)]
sections =
[ (ByteString
"input", forall a. Monoid a => a
mempty),
(ByteString
"output", forall a. Monoid a => a
mempty)
]
data SocketConfig = SocketConfig
{ SocketConfig -> Text
host :: Text,
SocketConfig -> Int
port :: Int,
SocketConfig -> Text
path :: Text
}
deriving (Int -> SocketConfig -> ShowS
[SocketConfig] -> ShowS
SocketConfig -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SocketConfig] -> ShowS
$cshowList :: [SocketConfig] -> ShowS
show :: SocketConfig -> [Char]
$cshow :: SocketConfig -> [Char]
showsPrec :: Int -> SocketConfig -> ShowS
$cshowsPrec :: Int -> SocketConfig -> ShowS
Show, SocketConfig -> SocketConfig -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SocketConfig -> SocketConfig -> Bool
$c/= :: SocketConfig -> SocketConfig -> Bool
== :: SocketConfig -> SocketConfig -> Bool
$c== :: SocketConfig -> SocketConfig -> Bool
Eq, forall x. Rep SocketConfig x -> SocketConfig
forall x. SocketConfig -> Rep SocketConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SocketConfig x -> SocketConfig
$cfrom :: forall x. SocketConfig -> Rep SocketConfig x
Generic)
defaultSocketConfig :: SocketConfig
defaultSocketConfig :: SocketConfig
defaultSocketConfig = Text -> Int -> Text -> SocketConfig
SocketConfig Text
"127.0.0.1" Int
9160 Text
"/"
serveSocketBox :: SocketConfig -> Page -> Box IO Text Text -> IO ()
serveSocketBox :: SocketConfig -> Page -> Box IO Text Text -> IO ()
serveSocketBox SocketConfig
cfg Page
p Box IO Text Text
b =
Int -> ScottyM () -> IO ()
scotty (SocketConfig
cfg forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "port" a => a
#port) forall a b. (a -> b) -> a -> b
$ do
Middleware -> ScottyM ()
middleware forall a b. (a -> b) -> a -> b
$ ConnectionOptions -> ServerApp -> Middleware
websocketsOr ConnectionOptions
WS.defaultConnectionOptions (Box IO Text Text -> ServerApp
serverApp Box IO Text Text
b)
RoutePattern -> PageConfig -> Page -> ScottyM ()
servePageWith RoutePattern
"/" ([Char] -> PageConfig
defaultPageConfig [Char]
"") Page
p
type CodeBox = Box IO [Code] (ByteString, ByteString)
type CoCodeBox = Codensity IO (Box IO [Code] (ByteString, ByteString))
data CodeBoxConfig = CodeBoxConfig
{ CodeBoxConfig -> SocketConfig
codeBoxSocket :: SocketConfig,
CodeBoxConfig -> Page
codeBoxPage :: Page,
CodeBoxConfig -> Queue [Code]
codeBoxCommitterQueue :: Queue [Code],
CodeBoxConfig -> Queue (ByteString, ByteString)
codeBoxEmitterQueue :: Queue (ByteString, ByteString)
}
deriving (forall x. Rep CodeBoxConfig x -> CodeBoxConfig
forall x. CodeBoxConfig -> Rep CodeBoxConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CodeBoxConfig x -> CodeBoxConfig
$cfrom :: forall x. CodeBoxConfig -> Rep CodeBoxConfig x
Generic)
defaultCodeBoxConfig :: CodeBoxConfig
defaultCodeBoxConfig :: CodeBoxConfig
defaultCodeBoxConfig = SocketConfig
-> Page
-> Queue [Code]
-> Queue (ByteString, ByteString)
-> CodeBoxConfig
CodeBoxConfig SocketConfig
defaultSocketConfig Page
defaultSocketPage forall a. Queue a
Single forall a. Queue a
Single
codeBoxWith :: CodeBoxConfig -> CoCodeBox
codeBoxWith :: CodeBoxConfig -> CoCodeBox
codeBoxWith CodeBoxConfig
cfg =
forall a b r.
Queue a -> Queue b -> (Box IO a b -> IO r) -> CoBox IO b a
fromActionWith
(forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "codeBoxEmitterQueue" a => a
#codeBoxEmitterQueue CodeBoxConfig
cfg)
(forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "codeBoxCommitterQueue" a => a
#codeBoxCommitterQueue CodeBoxConfig
cfg)
( SocketConfig -> Page -> Box IO Text Text -> IO ()
serveSocketBox (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "codeBoxSocket" a => a
#codeBoxSocket CodeBoxConfig
cfg) (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "codeBoxPage" a => a
#codeBoxPage CodeBoxConfig
cfg)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => [Char] -> a
error forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. IsString e => Parser e a -> ByteString -> Either e a
runParserEither forall e. Parser e (ByteString, ByteString)
parserJ forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
fromText_) (forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Text
toText_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. Code -> ByteString
code))
)
codeBox :: CoCodeBox
codeBox :: CoCodeBox
codeBox = CodeBoxConfig -> CoCodeBox
codeBoxWith CodeBoxConfig
defaultCodeBoxConfig
serveRep :: SharedRep IO a -> (Markup -> [Code]) -> (Either ByteString a -> [Code]) -> CodeBoxConfig -> IO ()
serveRep :: forall a.
SharedRep IO a
-> (Markup -> [Code])
-> (Either ByteString a -> [Code])
-> CodeBoxConfig
-> IO ()
serveRep SharedRep IO a
srep Markup -> [Code]
i Either ByteString a -> [Code]
o CodeBoxConfig
cfg =
forall a.
SharedRep IO a
-> (Markup -> [Code])
-> (Either ByteString a -> [Code])
-> CodeBox
-> IO ()
serveRepWithBox SharedRep IO a
srep Markup -> [Code]
i Either ByteString a -> [Code]
o forall {k} a (m :: k -> *) (r :: k).
(a -> m r) -> Codensity m a -> m r
<$|> CodeBoxConfig -> CoCodeBox
codeBoxWith CodeBoxConfig
cfg
serveRepWithBox :: SharedRep IO a -> (Markup -> [Code]) -> (Either ByteString a -> [Code]) -> CodeBox -> IO ()
serveRepWithBox :: forall a.
SharedRep IO a
-> (Markup -> [Code])
-> (Either ByteString a -> [Code])
-> CodeBox
-> IO ()
serveRepWithBox SharedRep IO a
srep Markup -> [Code]
i Either ByteString a -> [Code]
o (Box Committer IO [Code]
c Emitter IO (ByteString, ByteString)
e) =
forall (m :: * -> *) a.
Monad m =>
SharedRep m a
-> Committer m Markup
-> Committer m (Either ByteString a)
-> Emitter m (ByteString, ByteString)
-> m ()
sharedStream SharedRep IO a
srep (forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap Markup -> [Code]
i Committer IO [Code]
c) (forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap Either ByteString a -> [Code]
o Committer IO [Code]
c) Emitter IO (ByteString, ByteString)
e
replaceInput :: Markup -> [Code]
replaceInput :: Markup -> [Code]
replaceInput Markup
h = [ByteString -> ByteString -> Code
Replace ByteString
"input" (RenderStyle -> Standard -> Markup -> ByteString
markdown_ RenderStyle
Compact Standard
Html Markup
h)]
replaceOutput :: (Show a) => Either ByteString a -> [Code]
replaceOutput :: forall a. Show a => Either ByteString a -> [Code]
replaceOutput Either ByteString a
ea =
case Either ByteString a
ea of
Left ByteString
err -> [ByteString -> ByteString -> Code
Append ByteString
"debug" ByteString
err]
Right a
a -> [ByteString -> ByteString -> Code
Replace ByteString
"output" ([Char] -> ByteString
strToUtf8 forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show a
a)]
replaceOutput_ :: (Show a) => Either ByteString a -> [Code]
replaceOutput_ :: forall a. Show a => Either ByteString a -> [Code]
replaceOutput_ Either ByteString a
ea =
case Either ByteString a
ea of
Left ByteString
_ -> []
Right a
a -> [ByteString -> ByteString -> Code
Replace ByteString
"output" ([Char] -> ByteString
strToUtf8 forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show a
a)]
sharedStream ::
(Monad m) => SharedRep m a -> Committer m Markup -> Committer m (Either ByteString a) -> Emitter m (ByteString, ByteString) -> m ()
sharedStream :: forall (m :: * -> *) a.
Monad m =>
SharedRep m a
-> Committer m Markup
-> Committer m (Either ByteString a)
-> Emitter m (ByteString, ByteString)
-> m ()
sharedStream SharedRep m a
sr Committer m Markup
ch Committer m (Either ByteString a)
c Emitter m (ByteString, ByteString)
e =
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Int
0, forall k v. HashMap k v
HashMap.empty) forall a b. (a -> b) -> a -> b
$ do
(Rep Markup
h HashMap ByteString ByteString
-> (HashMap ByteString ByteString, Either ByteString a)
fa) <- forall (m :: * -> *) r a.
SharedRepF m r a
-> StateT (Int, HashMap ByteString ByteString) m (RepF r a)
unshare SharedRep m a
sr
Bool
b <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer m Markup
ch Markup
h
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b (forall {t :: (* -> *) -> * -> *} {a}.
(MonadTrans t,
MonadState (a, HashMap ByteString ByteString) (t m)) =>
(HashMap ByteString ByteString
-> (HashMap ByteString ByteString, Either ByteString a))
-> t m ()
go HashMap ByteString ByteString
-> (HashMap ByteString ByteString, Either ByteString a)
fa)
where
go :: (HashMap ByteString ByteString
-> (HashMap ByteString ByteString, Either ByteString a))
-> t m ()
go HashMap ByteString ByteString
-> (HashMap ByteString ByteString, Either ByteString a)
fa = do
Maybe (ByteString, ByteString)
e' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter m (ByteString, ByteString)
e
case Maybe (ByteString, ByteString)
e' of
Maybe (ByteString, ByteString)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just (ByteString
k, ByteString
v) -> do
HashMap ByteString ByteString
hmap <- forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get
let hmap' :: HashMap ByteString ByteString
hmap' = forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
insert ByteString
k ByteString
v HashMap ByteString ByteString
hmap
let (HashMap ByteString ByteString
hmap'', Either ByteString a
r) = HashMap ByteString ByteString
-> (HashMap ByteString ByteString, Either ByteString a)
fa HashMap ByteString ByteString
hmap'
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a b. a -> b -> a
const HashMap ByteString ByteString
hmap''))
Bool
b <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer m (Either ByteString a)
c Either ByteString a
r
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b ((HashMap ByteString ByteString
-> (HashMap ByteString ByteString, Either ByteString a))
-> t m ()
go HashMap ByteString ByteString
-> (HashMap ByteString ByteString, Either ByteString a)
fa)
data PlayConfig = PlayConfig
{ PlayConfig -> Bool
playPause :: Bool,
PlayConfig -> Double
playSpeed :: Double,
PlayConfig -> Int
playFrame :: Int
}
deriving (PlayConfig -> PlayConfig -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PlayConfig -> PlayConfig -> Bool
$c/= :: PlayConfig -> PlayConfig -> Bool
== :: PlayConfig -> PlayConfig -> Bool
$c== :: PlayConfig -> PlayConfig -> Bool
Eq, Int -> PlayConfig -> ShowS
[PlayConfig] -> ShowS
PlayConfig -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PlayConfig] -> ShowS
$cshowList :: [PlayConfig] -> ShowS
show :: PlayConfig -> [Char]
$cshow :: PlayConfig -> [Char]
showsPrec :: Int -> PlayConfig -> ShowS
$cshowsPrec :: Int -> PlayConfig -> ShowS
Show, forall x. Rep PlayConfig x -> PlayConfig
forall x. PlayConfig -> Rep PlayConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PlayConfig x -> PlayConfig
$cfrom :: forall x. PlayConfig -> Rep PlayConfig x
Generic)
defaultPlayConfig :: PlayConfig
defaultPlayConfig :: PlayConfig
defaultPlayConfig = Bool -> Double -> Int -> PlayConfig
PlayConfig Bool
True Double
1 Int
0
repPlayConfig :: PlayConfig -> SharedRep IO PlayConfig
repPlayConfig :: PlayConfig -> SharedRep IO PlayConfig
repPlayConfig PlayConfig
cfg =
Bool -> Double -> Int -> PlayConfig
PlayConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> SharedRep IO Bool
repPause (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "playPause" a => a
#playPause PlayConfig
cfg)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Double -> SharedRep IO Double
repSpeed (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "playSpeed" a => a
#playSpeed PlayConfig
cfg)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> SharedRep IO Int
repFrame (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "playFrame" a => a
#playFrame PlayConfig
cfg)
repFrame :: Int -> SharedRep IO Int
repFrame :: Int -> SharedRep IO Int
repFrame Int
x = forall a. Read a => [Char] -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
utf8ToStr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Monad m =>
Maybe ByteString -> ByteString -> SharedRep m ByteString
textbox (forall a. a -> Maybe a
Just ByteString
"frame") ([Char] -> ByteString
strToUtf8 forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Int
x)
repSpeed :: Double -> SharedRep IO Double
repSpeed :: Double -> SharedRep IO Double
repSpeed Double
x = forall (m :: * -> *).
Monad m =>
Maybe ByteString
-> Double -> Double -> Double -> Double -> SharedRep m Double
sliderV (forall a. a -> Maybe a
Just ByteString
"speed") Double
0.5 Double
100 Double
0.5 Double
x
repPause :: Bool -> SharedRep IO Bool
repPause :: Bool -> SharedRep IO Bool
repPause Bool
initial = forall (m :: * -> *).
Monad m =>
Maybe ByteString -> Bool -> SharedRep m Bool
toggle_ (forall a. a -> Maybe a
Just ByteString
"play/pause") Bool
initial
repReset :: SharedRep IO Bool
repReset :: SharedRep IO Bool
repReset = forall (m :: * -> *).
Monad m =>
Maybe ByteString -> SharedRep m Bool
button (forall a. a -> Maybe a
Just ByteString
"reset")
servePlayStreamWithBox :: PlayConfig -> CoEmitter IO (Gap, [Code]) -> CodeBox -> IO ()
servePlayStreamWithBox :: PlayConfig -> CoEmitter IO (Double, [Code]) -> CodeBox -> IO ()
servePlayStreamWithBox PlayConfig
pcfg CoEmitter IO (Double, [Code])
pipe (Box Committer IO [Code]
c Emitter IO (ByteString, ByteString)
e) = do
(Box IO (Bool, PlayConfig) (Bool, PlayConfig)
playBox, IO ()
_) <- forall a. Queue a -> IO (Box IO a a, IO ())
toBoxM (forall a. a -> Queue a
Latest (Bool
False, PlayConfig
pcfg))
forall a b. IO a -> IO b -> IO ()
race_
(forall (m :: * -> *) a.
Monad m =>
SharedRep m a
-> Committer m Markup
-> Committer m (Either ByteString a)
-> Emitter m (ByteString, ByteString)
-> m ()
sharedStream ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SharedRep IO Bool
repReset forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PlayConfig -> SharedRep IO PlayConfig
repPlayConfig PlayConfig
pcfg) (forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (\Markup
h -> [ByteString -> ByteString -> Code
Replace ByteString
"input" (RenderStyle -> Standard -> Markup -> ByteString
markdown_ RenderStyle
Compact Standard
Html Markup
h)]) Committer IO [Code]
c) (forall (m :: * -> *) b a.
Monad m =>
(b -> m (Maybe a)) -> Committer m a -> Committer m b
witherC (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just)) (forall (m :: * -> *) c e. Box m c e -> Committer m c
committer Box IO (Bool, PlayConfig) (Bool, PlayConfig)
playBox)) Emitter IO (ByteString, ByteString)
e)
(forall a. Emitter IO Bool -> IO a -> IO (Either Bool a)
restart (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) c e. Box m c e -> Emitter m e
emitter Box IO (Bool, PlayConfig) (Bool, PlayConfig)
playBox) (forall (m :: * -> *) a.
Monad m =>
Committer m a -> Emitter m a -> m ()
glue Committer IO [Code]
c forall {k} a (m :: k -> *) (r :: k).
(a -> m r) -> Codensity m a -> m r
<$|> forall a.
Emitter IO (Int, Double)
-> Emitter IO (Double, a) -> CoEmitter IO a
speedSkipEffect ((\(Bool, PlayConfig)
x -> (PlayConfig -> Int
playFrame (forall a b. (a, b) -> b
snd (Bool, PlayConfig)
x), PlayConfig -> Double
playSpeed (forall a b. (a, b) -> b
snd (Bool, PlayConfig)
x))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) c e. Box m c e -> Emitter m e
emitter Box IO (Bool, PlayConfig) (Bool, PlayConfig)
playBox) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Emitter IO Bool -> Emitter IO a -> Emitter IO a
pauser (PlayConfig -> Bool
playPause forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) c e. Box m c e -> Emitter m e
emitter Box IO (Bool, PlayConfig) (Bool, PlayConfig)
playBox) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CoEmitter IO (Double, [Code])
pipe))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
servePlayStream :: PlayConfig -> CodeBoxConfig -> CoEmitter IO (Gap, [Code]) -> IO ()
servePlayStream :: PlayConfig
-> CodeBoxConfig -> CoEmitter IO (Double, [Code]) -> IO ()
servePlayStream PlayConfig
pcfg CodeBoxConfig
cbcfg CoEmitter IO (Double, [Code])
s = PlayConfig -> CoEmitter IO (Double, [Code]) -> CodeBox -> IO ()
servePlayStreamWithBox PlayConfig
pcfg CoEmitter IO (Double, [Code])
s forall {k} a (m :: k -> *) (r :: k).
(a -> m r) -> Codensity m a -> m r
<$|> CodeBoxConfig -> CoCodeBox
codeBoxWith CodeBoxConfig
cbcfg
parserJ :: Parser e (ByteString, ByteString)
parserJ :: forall e. Parser e (ByteString, ByteString)
parserJ = do
()
_ <- $(string [i|{"event":{"element":"|])
ByteString
e <- forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e ByteString
byteStringOf forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (forall (st :: ZeroBitType) e. (Char -> Bool) -> ParserT st e Char
satisfy (forall a. Eq a => a -> a -> Bool
/= Char
'"'))
()
_ <- $(string [i|","value":"|])
ByteString
v <- forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e ByteString
byteStringOf forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (forall (st :: ZeroBitType) e. (Char -> Bool) -> ParserT st e Char
satisfy (forall a. Eq a => a -> a -> Bool
/= Char
'"'))
()
_ <- $(string [i|"}}|])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
e, ByteString
v)
data Code
= Replace ByteString ByteString
| Append ByteString ByteString
| Console ByteString
| Eval ByteString
| Val ByteString
deriving (Code -> Code -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Code -> Code -> Bool
$c/= :: Code -> Code -> Bool
== :: Code -> Code -> Bool
$c== :: Code -> Code -> Bool
Eq, Int -> Code -> ShowS
[Code] -> ShowS
Code -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Code] -> ShowS
$cshowList :: [Code] -> ShowS
show :: Code -> [Char]
$cshow :: Code -> [Char]
showsPrec :: Int -> Code -> ShowS
$cshowsPrec :: Int -> Code -> ShowS
Show, forall x. Rep Code x -> Code
forall x. Code -> Rep Code x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Code x -> Code
$cfrom :: forall x. Code -> Rep Code x
Generic, ReadPrec [Code]
ReadPrec Code
Int -> ReadS Code
ReadS [Code]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Code]
$creadListPrec :: ReadPrec [Code]
readPrec :: ReadPrec Code
$creadPrec :: ReadPrec Code
readList :: ReadS [Code]
$creadList :: ReadS [Code]
readsPrec :: Int -> ReadS Code
$creadsPrec :: Int -> ReadS Code
Read)
code :: Code -> ByteString
code :: Code -> ByteString
code (Replace ByteString
i ByteString
t) = ByteString -> ByteString -> ByteString
replace ByteString
i ByteString
t
code (Append ByteString
i ByteString
t) = ByteString -> ByteString -> ByteString
append ByteString
i ByteString
t
code (Console ByteString
t) = ByteString -> ByteString
console ByteString
t
code (Eval ByteString
t) = ByteString
t
code (Val ByteString
t) = ByteString -> ByteString
val ByteString
t
console :: ByteString -> ByteString
console :: ByteString -> ByteString
console ByteString
t = [i| console.log(#{t}) |]
val :: ByteString -> ByteString
val :: ByteString -> ByteString
val ByteString
t = [i| jsb.ws.send(#{t}) |]
replace :: ByteString -> ByteString -> ByteString
replace :: ByteString -> ByteString -> ByteString
replace ByteString
d ByteString
t =
[i|
var $container = document.getElementById('#{d}');
$container.innerHTML = '#{clean t}';
runScripts($container);
refreshJsb();
|]
append :: ByteString -> ByteString -> ByteString
append :: ByteString -> ByteString -> ByteString
append ByteString
d ByteString
t =
[i|
var $container = document.getElementById('#{d}');
$container.innerHTML += '#{clean t}';
runScripts($container);
refreshJsb();
|]
clean :: ByteString -> ByteString
clean :: ByteString -> ByteString
clean =
ByteString -> [ByteString] -> ByteString
C.intercalate ByteString
"\\'"
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ByteString -> [ByteString]
C.split Char
'\''
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString] -> ByteString
C.intercalate ByteString
"\\n"
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
C.lines
webSocket :: Js
webSocket :: Js
webSocket =
ByteString -> Js
Js
[i|
window.jsb = {ws: new WebSocket('ws://' + location.host + '/')};
jsb.event = function(ev) {
jsb.ws.send(JSON.stringify({event: ev}));
};
jsb.ws.onmessage = function(evt){
eval('(function(){' + evt.data + '})()');
};
|]
refreshJsbJs :: Js
refreshJsbJs :: Js
refreshJsbJs =
ByteString -> Js
Js
[i|
function refreshJsb () {
$('.jsbClassEventInput').off('input');
$('.jsbClassEventInput').on('input', (function(){
jsb.event({ 'element': this.id, 'value': this.value});
}));
$('.jsbClassEventChange').off('change');
$('.jsbClassEventChange').on('change', (function(){
jsb.event({ 'element': this.id, 'value': this.value});
}));
$('.jsbClassEventFocusout').off('focusout');
$('.jsbClassEventFocusout').on('focusout', (function(){
jsb.event({ 'element': this.id, 'value': this.value});
}));
$('.jsbClassEventButton').off('click');
$('.jsbClassEventButton').on('click', (function(){
jsb.event({ 'element': this.id, 'value': this.value});
}));
$('.jsbClassEventToggle').off('click');
$('.jsbClassEventToggle').on('click', (function(){
jsb.event({ 'element': this.id, 'value': ('true' !== this.getAttribute('aria-pressed')).toString()});
}));
$('.jsbClassEventCheckbox').off('click');
$('.jsbClassEventCheckbox').on('click', (function(){
jsb.event({ 'element': this.id, 'value': this.checked.toString()});
}));
$('.jsbClassEventChooseFile').off('input');
$('.jsbClassEventChooseFile').on('input', (function(){
jsb.event({ 'element': this.id, 'value': this.files[0].name});
}));
$('.jsbClassEventShowSum').off('change');
$('.jsbClassEventShowSum').on('change', (function(){
var v = this.value;
$(this).parent('.sumtype-group').siblings('.subtype').each(function(i) {
if (this.dataset.sumtype === v) {
this.style.display = 'block';
} else {
this.style.display = 'none';
}
})
}));
$('.jsbClassEventChangeMultiple').off('change');
$('.jsbClassEventChangeMultiple').on('change', (function(){
jsb.event({ 'element': this.id, 'value': [...this.options].filter(option => option.selected).map(option => option.value).join(',')});
}));
};
|]
preventEnter :: Js
preventEnter :: Js
preventEnter =
ByteString -> Js
Js
[i|
window.addEventListener('keydown',function(e) {
if(e.keyIdentifier=='U+000A' || e.keyIdentifier=='Enter' || e.keyCode==13) {
if(e.target.nodeName=='INPUT' && e.target.type !== 'textarea') {
e.preventDefault();
return false;
}
}
}, true);
|]
runScriptJs :: Js
runScriptJs :: Js
runScriptJs =
ByteString -> Js
Js
[i|
function insertScript ($script) {
var s = document.createElement('script')
s.type = 'text/javascript'
if ($script.src) {
s.onload = callback
s.onerror = callback
s.src = $script.src
} else {
s.textContent = $script.innerText
}
// re-insert the script tag so it executes.
document.head.appendChild(s)
// clean-up
$script.parentNode.removeChild($script)
}
function runScripts ($container) {
// get scripts tags from a node
var $scripts = $container.querySelectorAll('script')
$scripts.forEach(function ($script) {
insertScript($script)
})
}
|]