{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}

-- | A socket between a web page and haskell, based on the box library.
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

-- | Page with all the trimmings for a sharedRep Box
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)
      ]

-- | Socket configuration
--
-- >>> defaultSocketConfig
-- SocketConfig {host = "127.0.0.1", port = 9160, path = "/"}
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)

-- | official default
defaultSocketConfig :: SocketConfig
defaultSocketConfig :: SocketConfig
defaultSocketConfig = Text -> Int -> Text -> SocketConfig
SocketConfig Text
"127.0.0.1" Int
9160 Text
"/"

-- | bidirectional websocket serving a 'Box'
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

-- | A common Box pattern. [Code] is typically committed to the websocket and key-value elements, representing changes to the shared objects that are in the Dom are emitted.
type CodeBox = Box IO [Code] (ByteString, ByteString)

-- | Codensity CodeBox
type CoCodeBox = Codensity IO (Box IO [Code] (ByteString, ByteString))

-- | Configuration for a CodeBox serving.
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)

-- | official default config.
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

-- | Turn a configuration into a live (Codensity) CodeBox
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))
    )

-- | Turn the default configuration into a live (Codensity) CodeBox
codeBox :: CoCodeBox
codeBox :: CoCodeBox
codeBox = CodeBoxConfig -> CoCodeBox
codeBoxWith CodeBoxConfig
defaultCodeBoxConfig

-- | serve a SharedRep
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

-- | non-codensity sharedRep server.
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

-- | Convert HTML representation to Code, replacing the input section of a page.
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)]

-- | Convert (typically parsed representation) to Code, replacing the output section of a page, and appending errors.
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)]

-- | Convert (typically parsed representation) to Code, replacing the output section of a page, and throwing away errors.
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)]

-- | Stream a SharedRep
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
    -- you only want to run unshare once for a SharedRep
    (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)

-- * Play

-- | Configuration to control a (re)play of an emitter with a Gap (timing) element.
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)

-- | Start on pause at normal speed and at frame 0.
defaultPlayConfig :: PlayConfig
defaultPlayConfig :: PlayConfig
defaultPlayConfig = Bool -> Double -> Int -> PlayConfig
PlayConfig Bool
True Double
1 Int
0

-- | representation of a PlayConfig
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)

-- | representation of the playFrame in a PlayConfig
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)

-- | representation of the playSpeed in a PlayConfig
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

-- | representation of the playPause toggle in a PlayConfig
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

-- | representation of a Bool reset button
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")

-- | Serve an emitter controlled by a PlayConfig representation, with an explicit CodeBox.
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 ()

-- | Serve an emitter controlled by a PlayConfig representation.
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

-- * low-level JS conversions

-- | {"event":{"element":"textid","value":"abcdees"}}
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)

-- * code hooks

-- * code messaging

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 a container and run any embedded scripts
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 to a container and run any embedded scripts
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

-- * initial javascript

-- | create a web socket for event data
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 + '})()');
};
|]

-- * scripts

-- | Event hooks that may need to be reattached given dynamic content creation.
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(',')});
  }));
};
|]

-- | prevent the Enter key from triggering an event
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);
|]

-- | script injection js.
--
-- See https://ghinda.net/article/script-tags/ for why this might be needed.
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)
  })
}
|]