{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE StrictData #-}
{-# OPTIONS_GHC -Wall #-}
{-# HLINT ignore "Eta reduce" #-}
{-# OPTIONS_GHC -Wno-type-defaults #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Redundant <$>" #-}

-- | 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, parserJ, 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 qualified Data.Attoparsec.Text as A
import Data.Bifunctor
import Data.Bool
import Data.Functor.Contravariant
import Data.HashMap.Strict as HashMap
import Data.Profunctor
import Data.Text (Text, pack)
import qualified Data.Text as Text
import GHC.Generics
import Lucid as L
import Network.Wai.Handler.WebSockets
import qualified Network.WebSockets as WS
import Optics.Core
import Text.InterpolatedString.Perl6
import Web.Rep.Bootstrap
import Web.Rep.Html
import Web.Rep.Page
import Web.Rep.Server
import Web.Rep.Shared
import Web.Rep.SharedReps
import Web.Scotty (middleware, scotty)

-- | 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
        [ RepJs
webSocket,
          RepJs
runScriptJs,
          RepJs
refreshJsbJs,
          RepJs
preventEnter
        ]

defaultSocketPage :: BootstrapVersion -> Page
defaultSocketPage :: BootstrapVersion -> Page
defaultSocketPage BootstrapVersion
v =
  forall a. a -> a -> Bool -> a
bool Page
bootstrap5Page Page
bootstrapPage (BootstrapVersion
v forall a. Eq a => a -> a -> Bool
== BootstrapVersion
Boot4)
    forall a. Semigroup a => a -> a -> a
<> Page
socketPage
    forall a b. a -> (a -> b) -> b
& forall a. IsLabel "htmlBody" a => a
#htmlBody
      forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ Text -> Html () -> Html ()
divClass_
        Text
"container"
        ( forall a. Monoid a => [a] -> a
mconcat
            [ Text -> Html () -> Html ()
divClass_ Text
"row" (forall arg result. Term arg result => arg -> result
h1_ Html ()
"web-rep testing"),
              Text -> Html () -> Html ()
divClass_ Text
"row" forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ (\(Text
t, Html ()
h) -> Text -> Html () -> Html ()
divClass_ Text
"col" (forall arg result. Term arg result => arg -> result
h2_ (forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
t) forall a. Semigroup a => a -> a -> a
<> forall a. With a => a -> [Attribute] -> a
L.with forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
id_ Text
t] Html ()
h)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Html ())]
sections
            ]
        )
  where
    sections :: [(Text, Html ())]
sections =
      [ (Text
"input", forall a. Monoid a => a
mempty),
        (Text
"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 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SocketConfig] -> ShowS
$cshowList :: [SocketConfig] -> ShowS
show :: SocketConfig -> String
$cshow :: SocketConfig -> String
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
"/" (String -> PageConfig
defaultPageConfig String
"") 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] (Text, Text)

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

-- | Configuration for a CodeBox serving.
data CodeBoxConfig = CodeBoxConfig
  { CodeBoxConfig -> SocketConfig
codeBoxSocket :: SocketConfig,
    CodeBoxConfig -> Page
codeBoxPage :: Page,
    CodeBoxConfig -> Queue [Code]
codeBoxCommitterQueue :: Queue [Code],
    CodeBoxConfig -> Queue (Text, Text)
codeBoxEmitterQueue :: Queue (Text, Text)
  }
  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 (Text, Text) -> CodeBoxConfig
CodeBoxConfig SocketConfig
defaultSocketConfig (BootstrapVersion -> Page
defaultSocketPage BootstrapVersion
Boot5) 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 => a
undefined forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parser a -> Text -> Either String a
A.parseOnly Parser (Text, Text)
parserJ) (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 Code -> Text
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 -> (Html () -> [Code]) -> (Either Text a -> [Code]) -> CodeBoxConfig -> IO ()
serveRep :: forall a.
SharedRep IO a
-> (Html () -> [Code])
-> (Either Text a -> [Code])
-> CodeBoxConfig
-> IO ()
serveRep SharedRep IO a
srep Html () -> [Code]
i Either Text a -> [Code]
o CodeBoxConfig
cfg =
  forall a.
SharedRep IO a
-> (Html () -> [Code])
-> (Either Text a -> [Code])
-> CodeBox
-> IO ()
serveRepWithBox SharedRep IO a
srep Html () -> [Code]
i Either Text a -> [Code]
o forall a (m :: * -> *) r. (a -> m r) -> Codensity m a -> m r
<$|> CodeBoxConfig -> CoCodeBox
codeBoxWith CodeBoxConfig
cfg

-- | non-codensity sharedRep server.
serveRepWithBox :: SharedRep IO a -> (Html () -> [Code]) -> (Either Text a -> [Code]) -> CodeBox -> IO ()
serveRepWithBox :: forall a.
SharedRep IO a
-> (Html () -> [Code])
-> (Either Text a -> [Code])
-> CodeBox
-> IO ()
serveRepWithBox SharedRep IO a
srep Html () -> [Code]
i Either Text a -> [Code]
o (Box Committer IO [Code]
c Emitter IO (Text, Text)
e) =
  forall (m :: * -> *) a.
Monad m =>
SharedRep m a
-> Committer m (Html ())
-> Committer m (Either Text a)
-> Emitter m (Text, Text)
-> m ()
sharedStream SharedRep IO a
srep (forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap Html () -> [Code]
i Committer IO [Code]
c) (forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap Either Text a -> [Code]
o Committer IO [Code]
c) Emitter IO (Text, Text)
e

-- | Convert HTML representation to Code, replacing the input section of a page.
replaceInput :: Html () -> [Code]
replaceInput :: Html () -> [Code]
replaceInput Html ()
h = [Text -> Text -> Code
Replace Text
"input" (forall a. Html a -> Text
toText Html ()
h)]

-- | Convert (typically parsed representation) to Code, replacing the output section of a page, and appending errors.
replaceOutput :: (Show a) => Either Text a -> [Code]
replaceOutput :: forall a. Show a => Either Text a -> [Code]
replaceOutput Either Text a
ea =
  case Either Text a
ea of
    Left Text
err -> [Text -> Text -> Code
Append Text
"debug" Text
err]
    Right a
a -> [Text -> Text -> Code
Replace Text
"output" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show a
a)]

-- | Convert (typically parsed representation) to Code, replacing the output section of a page, and throwing away errors.
replaceOutput_ :: (Show a) => Either Text a -> [Code]
replaceOutput_ :: forall a. Show a => Either Text a -> [Code]
replaceOutput_ Either Text a
ea =
  case Either Text a
ea of
    Left Text
_ -> []
    Right a
a -> [Text -> Text -> Code
Replace Text
"output" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show a
a)]

-- | Stream a SharedRep
sharedStream ::
  (Monad m) => SharedRep m a -> Committer m (Html ()) -> Committer m (Either Text a) -> Emitter m (Text, Text) -> m ()
sharedStream :: forall (m :: * -> *) a.
Monad m =>
SharedRep m a
-> Committer m (Html ())
-> Committer m (Either Text a)
-> Emitter m (Text, Text)
-> m ()
sharedStream SharedRep m a
sr Committer m (Html ())
ch Committer m (Either Text a)
c Emitter m (Text, Text)
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 Html ()
h HashMap Text Text -> (HashMap Text Text, Either Text a)
fa) <- forall (m :: * -> *) r a.
SharedRepF m r a -> StateT (Int, HashMap Text Text) 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 (Html ())
ch Html ()
h
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b (forall {t :: (* -> *) -> * -> *} {a}.
(MonadTrans t, MonadState (a, HashMap Text Text) (t m)) =>
(HashMap Text Text -> (HashMap Text Text, Either Text a)) -> t m ()
go HashMap Text Text -> (HashMap Text Text, Either Text a)
fa)
  where
    go :: (HashMap Text Text -> (HashMap Text Text, Either Text a)) -> t m ()
go HashMap Text Text -> (HashMap Text Text, Either Text a)
fa = do
      Maybe (Text, Text)
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 (Text, Text)
e
      case Maybe (Text, Text)
e' of
        Maybe (Text, Text)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just (Text
k, Text
v) -> do
          HashMap Text Text
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 Text Text
hmap' = forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
insert Text
k Text
v HashMap Text Text
hmap
          let (HashMap Text Text
hmap'', Either Text a
r) = HashMap Text Text -> (HashMap Text Text, Either Text a)
fa HashMap Text Text
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 Text Text
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 Text a)
c Either Text a
r
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b ((HashMap Text Text -> (HashMap Text Text, Either Text a)) -> t m ()
go HashMap Text Text -> (HashMap Text Text, Either Text 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 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PlayConfig] -> ShowS
$cshowList :: [PlayConfig] -> ShowS
show :: PlayConfig -> String
$cshow :: PlayConfig -> String
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 => String -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Monad m =>
Maybe Text -> Text -> SharedRep m Text
textbox (forall a. a -> Maybe a
Just Text
"frame") (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
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 Text
-> Double -> Double -> Double -> Double -> SharedRep m Double
sliderV (forall a. a -> Maybe a
Just Text
"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 Text -> Bool -> SharedRep m Bool
toggle_ (forall a. a -> Maybe a
Just Text
"play/pause") Bool
initial

-- | representation of a Bool reset button
repReset :: SharedRep IO Bool
repReset :: SharedRep IO Bool
repReset = forall (m :: * -> *). Monad m => Maybe Text -> SharedRep m Bool
button (forall a. a -> Maybe a
Just Text
"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 (Text, Text)
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 (Html ())
-> Committer m (Either Text a)
-> Emitter m (Text, Text)
-> 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 (\Html ()
h -> [Text -> Text -> Code
Replace Text
"input" (forall a. Html a -> Text
toText Html ()
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 (Text, Text)
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 a (m :: * -> *) r. (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 (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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 a (m :: * -> *) r. (a -> m r) -> Codensity m a -> m r
<$|> CodeBoxConfig -> CoCodeBox
codeBoxWith CodeBoxConfig
cbcfg

-- * low-level JS conversions

-- | {"event":{"element":"textid","value":"abcdees"}}
parserJ :: A.Parser (Text, Text)
parserJ :: Parser (Text, Text)
parserJ = do
  Text
_ <- Text -> Parser Text
A.string [q|{"event":{"element":"|]
  Text
e <- (Char -> Bool) -> Parser Text
A.takeTill (forall a. Eq a => a -> a -> Bool
== Char
'"')
  Text
_ <- Text -> Parser Text
A.string [q|","value":"|]
  Text
v <- (Char -> Bool) -> Parser Text
A.takeTill (forall a. Eq a => a -> a -> Bool
== Char
'"')
  Text
_ <- Text -> Parser Text
A.string [q|"}}|]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
e, Text
v)

-- * code hooks

-- * code messaging

data Code
  = Replace Text Text
  | Append Text Text
  | Console Text
  | Eval Text
  | Val Text
  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 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Code] -> ShowS
$cshowList :: [Code] -> ShowS
show :: Code -> String
$cshow :: Code -> String
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 -> Text
code :: Code -> Text
code (Replace Text
i Text
t) = Text -> Text -> Text
replace Text
i Text
t
code (Append Text
i Text
t) = Text -> Text -> Text
append Text
i Text
t
code (Console Text
t) = Text -> Text
console Text
t
code (Eval Text
t) = Text
t
code (Val Text
t) = Text -> Text
val Text
t

console :: Text -> Text
console :: Text -> Text
console Text
t = [qc| console.log({t}) |]

val :: Text -> Text
val :: Text -> Text
val Text
t = [qc| jsb.ws.send({t}) |]

-- | replace a container and run any embedded scripts
replace :: Text -> Text -> Text
replace :: Text -> Text -> Text
replace Text
d Text
t =
  [qc|
     var $container = document.getElementById('{d}');
     $container.innerHTML = '{clean t}';
     runScripts($container);
     refreshJsb();
     |]

-- | append to a container and run any embedded scripts
append :: Text -> Text -> Text
append :: Text -> Text -> Text
append Text
d Text
t =
  [qc|
     var $container = document.getElementById('{d}');
     $container.innerHTML += '{clean t}';
     runScripts($container);
     refreshJsb();
     |]

clean :: Text -> Text
clean :: Text -> Text
clean =
  Text -> [Text] -> Text
Text.intercalate Text
"\\'"
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
Text.split (forall a. Eq a => a -> a -> Bool
== Char
'\'')
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
Text.intercalate Text
"\\n"
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
Text.lines

-- * initial javascript

-- | create a web socket for event data
webSocket :: RepJs
webSocket :: RepJs
webSocket =
  Text -> RepJs
RepJsText
    [q|
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 :: RepJs
refreshJsbJs :: RepJs
refreshJsbJs =
  Text -> RepJs
RepJsText
    [q|
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 :: RepJs
preventEnter :: RepJs
preventEnter =
  JS -> RepJs
RepJs forall a b. (a -> b) -> a -> b
$
    Text -> JS
parseJs
      [q|
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 :: RepJs
runScriptJs :: RepJs
runScriptJs =
  Text -> RepJs
RepJsText
    [q|
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)
  })
}
|]