{-# 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.Websocket (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.Encoding
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)

-- | Page with all the trimmings for a sharedRep Box
socketPage :: Page
socketPage :: Page
socketPage =
  Page
forall a. Monoid a => a
mempty
    Page -> (Page -> Page) -> Page
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Page Page Js Js
#jsOnLoad
    Optic A_Lens NoIx Page Page Js Js -> Js -> Page -> Page
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ [Js] -> Js
forall a. Monoid a => [a] -> a
mconcat
      [ Js
webSocket,
        Js
runScriptJs,
        Js
refreshJsbJs,
        Js
preventEnter
      ]

-- | Bootstrapped base page for a web socket.
defaultSocketPage :: Page
defaultSocketPage :: Page
defaultSocketPage =
  Page
bootstrapPage
    Page -> Page -> Page
forall a. Semigroup a => a -> a -> a
<> Page
socketPage
      Page -> (Page -> Page) -> Page
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Page Page Css Css -> Css -> Page -> Page
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set Optic A_Lens NoIx Page Page Css Css
#cssBody Css
cssColorScheme
      Page -> (Page -> Page) -> Page
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Page Page Markup Markup -> Markup -> Page -> Page
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")
                Markup -> Markup -> Markup
forall a. Semigroup a => a -> a -> a
<> ByteString -> [Attr] -> Markup -> Markup
element
                  ByteString
"div"
                  [ByteString -> ByteString -> Attr
Attr ByteString
"class" ByteString
"row"]
                  ( [Markup] -> Markup
forall a. Monoid a => [a] -> a
mconcat ([Markup] -> Markup) -> [Markup] -> Markup
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))
                      )
                        ((ByteString, ByteString) -> Markup)
-> [(ByteString, ByteString)] -> [Markup]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ByteString, ByteString)]
sections
                  )
            )
        )
  where
    sections :: [(ByteString, ByteString)]
sections =
      [ (ByteString
"input", ByteString
forall a. Monoid a => a
mempty),
        (ByteString
"output", ByteString
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]
(Int -> SocketConfig -> ShowS)
-> (SocketConfig -> [Char])
-> ([SocketConfig] -> ShowS)
-> Show SocketConfig
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SocketConfig -> ShowS
showsPrec :: Int -> SocketConfig -> ShowS
$cshow :: SocketConfig -> [Char]
show :: SocketConfig -> [Char]
$cshowList :: [SocketConfig] -> ShowS
showList :: [SocketConfig] -> ShowS
Show, SocketConfig -> SocketConfig -> Bool
(SocketConfig -> SocketConfig -> Bool)
-> (SocketConfig -> SocketConfig -> Bool) -> Eq SocketConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SocketConfig -> SocketConfig -> Bool
== :: SocketConfig -> SocketConfig -> Bool
$c/= :: SocketConfig -> SocketConfig -> Bool
/= :: SocketConfig -> SocketConfig -> Bool
Eq, (forall x. SocketConfig -> Rep SocketConfig x)
-> (forall x. Rep SocketConfig x -> SocketConfig)
-> Generic SocketConfig
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
$cfrom :: forall x. SocketConfig -> Rep SocketConfig x
from :: forall x. SocketConfig -> Rep SocketConfig x
$cto :: forall x. Rep SocketConfig x -> SocketConfig
to :: forall x. Rep SocketConfig x -> SocketConfig
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 SocketConfig -> Optic' A_Lens NoIx SocketConfig Int -> Int
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx SocketConfig Int
#port) (ScottyM () -> IO ()) -> ScottyM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Middleware -> ScottyM ()
middleware (Middleware -> ScottyM ()) -> Middleware -> ScottyM ()
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. CodeBoxConfig -> Rep CodeBoxConfig x)
-> (forall x. Rep CodeBoxConfig x -> CodeBoxConfig)
-> Generic CodeBoxConfig
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
$cfrom :: forall x. CodeBoxConfig -> Rep CodeBoxConfig x
from :: forall x. CodeBoxConfig -> Rep CodeBoxConfig x
$cto :: forall x. Rep CodeBoxConfig x -> CodeBoxConfig
to :: forall x. Rep CodeBoxConfig x -> CodeBoxConfig
Generic)

-- | official default config.
defaultCodeBoxConfig :: CodeBoxConfig
defaultCodeBoxConfig :: CodeBoxConfig
defaultCodeBoxConfig = SocketConfig
-> Page
-> Queue [Code]
-> Queue (ByteString, ByteString)
-> CodeBoxConfig
CodeBoxConfig SocketConfig
defaultSocketConfig Page
defaultSocketPage Queue [Code]
forall a. Queue a
Single Queue (ByteString, ByteString)
forall a. Queue a
Single

-- | Turn a configuration into a live (Codensity) CodeBox
codeBoxWith :: CodeBoxConfig -> CoCodeBox
codeBoxWith :: CodeBoxConfig -> CoCodeBox
codeBoxWith CodeBoxConfig
cfg =
  Queue (ByteString, ByteString)
-> Queue [Code]
-> (Box IO (ByteString, ByteString) [Code] -> IO ())
-> CoCodeBox
forall a b r.
Queue a -> Queue b -> (Box IO a b -> IO r) -> CoBox IO b a
fromActionWith
    (Optic' A_Lens NoIx CodeBoxConfig (Queue (ByteString, ByteString))
-> CodeBoxConfig -> Queue (ByteString, ByteString)
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx CodeBoxConfig (Queue (ByteString, ByteString))
#codeBoxEmitterQueue CodeBoxConfig
cfg)
    (Optic' A_Lens NoIx CodeBoxConfig (Queue [Code])
-> CodeBoxConfig -> Queue [Code]
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx CodeBoxConfig (Queue [Code])
#codeBoxCommitterQueue CodeBoxConfig
cfg)
    ( SocketConfig -> Page -> Box IO Text Text -> IO ()
serveSocketBox (Optic' A_Lens NoIx CodeBoxConfig SocketConfig
-> CodeBoxConfig -> SocketConfig
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx CodeBoxConfig SocketConfig
#codeBoxSocket CodeBoxConfig
cfg) (Optic' A_Lens NoIx CodeBoxConfig Page -> CodeBoxConfig -> Page
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx CodeBoxConfig Page
#codeBoxPage CodeBoxConfig
cfg)
        (Box IO Text Text -> IO ())
-> (Box IO (ByteString, ByteString) [Code] -> Box IO Text Text)
-> Box IO (ByteString, ByteString) [Code]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> (ByteString, ByteString))
-> ([Code] -> Text)
-> Box IO (ByteString, ByteString) [Code]
-> Box IO Text Text
forall a b c d. (a -> b) -> (c -> d) -> Box IO b c -> Box IO a d
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap (([Char] -> (ByteString, ByteString))
-> ((ByteString, ByteString) -> (ByteString, ByteString))
-> Either [Char] (ByteString, ByteString)
-> (ByteString, ByteString)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> (ByteString, ByteString)
forall a. HasCallStack => [Char] -> a
error (ByteString, ByteString) -> (ByteString, ByteString)
forall a. a -> a
id (Either [Char] (ByteString, ByteString)
 -> (ByteString, ByteString))
-> (Text -> Either [Char] (ByteString, ByteString))
-> Text
-> (ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser [Char] (ByteString, ByteString)
-> ByteString -> Either [Char] (ByteString, ByteString)
forall e a. IsString e => Parser e a -> ByteString -> Either e a
runParserEither Parser [Char] (ByteString, ByteString)
forall e. Parser e (ByteString, ByteString)
parserJ (ByteString -> Either [Char] (ByteString, ByteString))
-> (Text -> ByteString)
-> Text
-> Either [Char] (ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8) ([Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> ([Code] -> [Text]) -> [Code] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Code -> Text) -> [Code] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Text
decodeUtf8 (ByteString -> Text) -> (Code -> ByteString) -> Code -> Text
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 =
  SharedRep IO a
-> (Markup -> [Code])
-> (Either ByteString a -> [Code])
-> CodeBox
-> IO ()
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 (CodeBox -> IO ()) -> CoCodeBox -> IO ()
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) =
  SharedRep IO a
-> Committer IO Markup
-> Committer IO (Either ByteString a)
-> Emitter IO (ByteString, ByteString)
-> IO ()
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 ((Markup -> [Code]) -> Committer IO [Code] -> Committer IO Markup
forall a' a. (a' -> a) -> Committer IO a -> Committer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap Markup -> [Code]
i Committer IO [Code]
c) ((Either ByteString a -> [Code])
-> Committer IO [Code] -> Committer IO (Either ByteString a)
forall a' a. (a' -> a) -> Committer IO a -> Committer IO a'
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 ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ a -> [Char]
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 ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ a -> [Char]
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 =
  (StateT (Int, HashMap ByteString ByteString) m ()
 -> (Int, HashMap ByteString ByteString) -> m ())
-> (Int, HashMap ByteString ByteString)
-> StateT (Int, HashMap ByteString ByteString) m ()
-> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (Int, HashMap ByteString ByteString) m ()
-> (Int, HashMap ByteString ByteString) -> m ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Int
0, HashMap ByteString ByteString
forall k v. HashMap k v
HashMap.empty) (StateT (Int, HashMap ByteString ByteString) m () -> m ())
-> StateT (Int, HashMap ByteString ByteString) m () -> m ()
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) <- SharedRep m a
-> StateT (Int, HashMap ByteString ByteString) m (RepF Markup a)
forall (m :: * -> *) r a.
SharedRepF m r a
-> StateT (Int, HashMap ByteString ByteString) m (RepF r a)
unshare SharedRep m a
sr
    Bool
b <- m Bool -> StateT (Int, HashMap ByteString ByteString) m Bool
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Int, HashMap ByteString ByteString) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Bool -> StateT (Int, HashMap ByteString ByteString) m Bool)
-> m Bool -> StateT (Int, HashMap ByteString ByteString) m Bool
forall a b. (a -> b) -> a -> b
$ Committer m Markup -> Markup -> m Bool
forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer m Markup
ch Markup
h
    Bool
-> StateT (Int, HashMap ByteString ByteString) m ()
-> StateT (Int, HashMap ByteString ByteString) m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b ((HashMap ByteString ByteString
 -> (HashMap ByteString ByteString, Either ByteString a))
-> StateT (Int, HashMap ByteString ByteString) m ()
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' <- m (Maybe (ByteString, ByteString))
-> t m (Maybe (ByteString, ByteString))
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe (ByteString, ByteString))
 -> t m (Maybe (ByteString, ByteString)))
-> m (Maybe (ByteString, ByteString))
-> t m (Maybe (ByteString, ByteString))
forall a b. (a -> b) -> a -> b
$ Emitter m (ByteString, ByteString)
-> m (Maybe (ByteString, ByteString))
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 -> () -> t m ()
forall a. a -> t m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just (ByteString
k, ByteString
v) -> do
          HashMap ByteString ByteString
hmap <- (a, HashMap ByteString ByteString) -> HashMap ByteString ByteString
forall a b. (a, b) -> b
snd ((a, HashMap ByteString ByteString)
 -> HashMap ByteString ByteString)
-> t m (a, HashMap ByteString ByteString)
-> t m (HashMap ByteString ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t m (a, HashMap ByteString ByteString)
forall s (m :: * -> *). MonadState s m => m s
get
          let hmap' :: HashMap ByteString ByteString
hmap' = ByteString
-> ByteString
-> HashMap ByteString ByteString
-> HashMap ByteString ByteString
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'
          ((a, HashMap ByteString ByteString)
 -> (a, HashMap ByteString ByteString))
-> t m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((HashMap ByteString ByteString -> HashMap ByteString ByteString)
-> (a, HashMap ByteString ByteString)
-> (a, HashMap ByteString ByteString)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (HashMap ByteString ByteString
-> HashMap ByteString ByteString -> HashMap ByteString ByteString
forall a b. a -> b -> a
const HashMap ByteString ByteString
hmap''))
          Bool
b <- m Bool -> t m Bool
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Bool -> t m Bool) -> m Bool -> t m Bool
forall a b. (a -> b) -> a -> b
$ Committer m (Either ByteString a) -> Either ByteString a -> m Bool
forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer m (Either ByteString a)
c Either ByteString a
r
          Bool -> t m () -> t m ()
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
(PlayConfig -> PlayConfig -> Bool)
-> (PlayConfig -> PlayConfig -> Bool) -> Eq PlayConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PlayConfig -> PlayConfig -> Bool
== :: PlayConfig -> PlayConfig -> Bool
$c/= :: PlayConfig -> PlayConfig -> Bool
/= :: PlayConfig -> PlayConfig -> Bool
Eq, Int -> PlayConfig -> ShowS
[PlayConfig] -> ShowS
PlayConfig -> [Char]
(Int -> PlayConfig -> ShowS)
-> (PlayConfig -> [Char])
-> ([PlayConfig] -> ShowS)
-> Show PlayConfig
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PlayConfig -> ShowS
showsPrec :: Int -> PlayConfig -> ShowS
$cshow :: PlayConfig -> [Char]
show :: PlayConfig -> [Char]
$cshowList :: [PlayConfig] -> ShowS
showList :: [PlayConfig] -> ShowS
Show, (forall x. PlayConfig -> Rep PlayConfig x)
-> (forall x. Rep PlayConfig x -> PlayConfig) -> Generic PlayConfig
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
$cfrom :: forall x. PlayConfig -> Rep PlayConfig x
from :: forall x. PlayConfig -> Rep PlayConfig x
$cto :: forall x. Rep PlayConfig x -> PlayConfig
to :: forall x. Rep PlayConfig x -> PlayConfig
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
    (Bool -> Double -> Int -> PlayConfig)
-> SharedRepF IO Markup Bool
-> SharedRepF IO Markup (Double -> Int -> PlayConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> SharedRepF IO Markup Bool
repPause (Optic' A_Lens NoIx PlayConfig Bool -> PlayConfig -> Bool
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx PlayConfig Bool
#playPause PlayConfig
cfg)
    SharedRepF IO Markup (Double -> Int -> PlayConfig)
-> SharedRepF IO Markup Double
-> SharedRepF IO Markup (Int -> PlayConfig)
forall a b.
SharedRepF IO Markup (a -> b)
-> SharedRepF IO Markup a -> SharedRepF IO Markup b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Double -> SharedRepF IO Markup Double
repSpeed (Optic' A_Lens NoIx PlayConfig Double -> PlayConfig -> Double
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx PlayConfig Double
#playSpeed PlayConfig
cfg)
    SharedRepF IO Markup (Int -> PlayConfig)
-> SharedRepF IO Markup Int -> SharedRep IO PlayConfig
forall a b.
SharedRepF IO Markup (a -> b)
-> SharedRepF IO Markup a -> SharedRepF IO Markup b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> SharedRepF IO Markup Int
repFrame (Optic' A_Lens NoIx PlayConfig Int -> PlayConfig -> Int
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx PlayConfig Int
#playFrame PlayConfig
cfg)

-- | representation of the playFrame in a PlayConfig
repFrame :: Int -> SharedRep IO Int
repFrame :: Int -> SharedRepF IO Markup Int
repFrame Int
x = [Char] -> Int
forall a. Read a => [Char] -> a
read ([Char] -> Int) -> (ByteString -> [Char]) -> ByteString -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
utf8ToStr (ByteString -> Int)
-> SharedRepF IO Markup ByteString -> SharedRepF IO Markup Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString -> ByteString -> SharedRepF IO Markup ByteString
forall (m :: * -> *).
Monad m =>
Maybe ByteString -> ByteString -> SharedRep m ByteString
textbox (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"frame") ([Char] -> ByteString
strToUtf8 ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
x)

-- | representation of the playSpeed in a PlayConfig
repSpeed :: Double -> SharedRep IO Double
repSpeed :: Double -> SharedRepF IO Markup Double
repSpeed Double
x = Maybe ByteString
-> Double
-> Double
-> Double
-> Double
-> SharedRepF IO Markup Double
forall (m :: * -> *).
Monad m =>
Maybe ByteString
-> Double -> Double -> Double -> Double -> SharedRep m Double
sliderV (ByteString -> Maybe ByteString
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 -> SharedRepF IO Markup Bool
repPause Bool
initial = Maybe ByteString -> Bool -> SharedRepF IO Markup Bool
forall (m :: * -> *).
Monad m =>
Maybe ByteString -> Bool -> SharedRep m Bool
toggle_ (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"play/pause") Bool
initial

-- | representation of a Bool reset button
repReset :: SharedRep IO Bool
repReset :: SharedRepF IO Markup Bool
repReset = Maybe ByteString -> SharedRepF IO Markup Bool
forall (m :: * -> *).
Monad m =>
Maybe ByteString -> SharedRep m Bool
button (ByteString -> Maybe ByteString
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 ()
_) <- Queue (Bool, PlayConfig)
-> IO (Box IO (Bool, PlayConfig) (Bool, PlayConfig), IO ())
forall a. Queue a -> IO (Box IO a a, IO ())
toBoxM ((Bool, PlayConfig) -> Queue (Bool, PlayConfig)
forall a. a -> Queue a
Latest (Bool
False, PlayConfig
pcfg))
  IO () -> IO (Either Bool ()) -> IO ()
forall a b. IO a -> IO b -> IO ()
race_
    (SharedRep IO (Bool, PlayConfig)
-> Committer IO Markup
-> Committer IO (Either ByteString (Bool, PlayConfig))
-> Emitter IO (ByteString, ByteString)
-> IO ()
forall (m :: * -> *) a.
Monad m =>
SharedRep m a
-> Committer m Markup
-> Committer m (Either ByteString a)
-> Emitter m (ByteString, ByteString)
-> m ()
sharedStream ((,) (Bool -> PlayConfig -> (Bool, PlayConfig))
-> SharedRepF IO Markup Bool
-> SharedRepF IO Markup (PlayConfig -> (Bool, PlayConfig))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SharedRepF IO Markup Bool
repReset SharedRepF IO Markup (PlayConfig -> (Bool, PlayConfig))
-> SharedRep IO PlayConfig -> SharedRep IO (Bool, PlayConfig)
forall a b.
SharedRepF IO Markup (a -> b)
-> SharedRepF IO Markup a -> SharedRepF IO Markup b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PlayConfig -> SharedRep IO PlayConfig
repPlayConfig PlayConfig
pcfg) ((Markup -> [Code]) -> Committer IO [Code] -> Committer IO Markup
forall a' a. (a' -> a) -> Committer IO a -> Committer IO a'
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) ((Either ByteString (Bool, PlayConfig)
 -> IO (Maybe (Bool, PlayConfig)))
-> Committer IO (Bool, PlayConfig)
-> Committer IO (Either ByteString (Bool, PlayConfig))
forall (m :: * -> *) b a.
Monad m =>
(b -> m (Maybe a)) -> Committer m a -> Committer m b
witherC ((ByteString -> IO (Maybe (Bool, PlayConfig)))
-> ((Bool, PlayConfig) -> IO (Maybe (Bool, PlayConfig)))
-> Either ByteString (Bool, PlayConfig)
-> IO (Maybe (Bool, PlayConfig))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO (Maybe (Bool, PlayConfig))
-> ByteString -> IO (Maybe (Bool, PlayConfig))
forall a b. a -> b -> a
const (Maybe (Bool, PlayConfig) -> IO (Maybe (Bool, PlayConfig))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Bool, PlayConfig)
forall a. Maybe a
Nothing)) (Maybe (Bool, PlayConfig) -> IO (Maybe (Bool, PlayConfig))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Bool, PlayConfig) -> IO (Maybe (Bool, PlayConfig)))
-> ((Bool, PlayConfig) -> Maybe (Bool, PlayConfig))
-> (Bool, PlayConfig)
-> IO (Maybe (Bool, PlayConfig))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, PlayConfig) -> Maybe (Bool, PlayConfig)
forall a. a -> Maybe a
Just)) (Box IO (Bool, PlayConfig) (Bool, PlayConfig)
-> Committer IO (Bool, PlayConfig)
forall (m :: * -> *) c e. Box m c e -> Committer m c
committer Box IO (Bool, PlayConfig) (Bool, PlayConfig)
playBox)) Emitter IO (ByteString, ByteString)
e)
    (Emitter IO Bool -> IO () -> IO (Either Bool ())
forall a. Emitter IO Bool -> IO a -> IO (Either Bool a)
restart ((Bool, PlayConfig) -> Bool
forall a b. (a, b) -> a
fst ((Bool, PlayConfig) -> Bool)
-> Emitter IO (Bool, PlayConfig) -> Emitter IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Box IO (Bool, PlayConfig) (Bool, PlayConfig)
-> Emitter IO (Bool, PlayConfig)
forall (m :: * -> *) c e. Box m c e -> Emitter m e
emitter Box IO (Bool, PlayConfig) (Bool, PlayConfig)
playBox) (Committer IO [Code] -> Emitter IO [Code] -> IO ()
forall (m :: * -> *) a.
Monad m =>
Committer m a -> Emitter m a -> m ()
glue Committer IO [Code]
c (Emitter IO [Code] -> IO ())
-> Codensity IO (Emitter IO [Code]) -> IO ()
forall {k} a (m :: k -> *) (r :: k).
(a -> m r) -> Codensity m a -> m r
<$|> Emitter IO (Int, Double)
-> Emitter IO (Double, [Code]) -> Codensity IO (Emitter IO [Code])
forall a.
Emitter IO (Int, Double)
-> Emitter IO (Double, a) -> CoEmitter IO a
speedSkipEffect ((\(Bool, PlayConfig)
x -> (PlayConfig -> Int
playFrame ((Bool, PlayConfig) -> PlayConfig
forall a b. (a, b) -> b
snd (Bool, PlayConfig)
x), PlayConfig -> Double
playSpeed ((Bool, PlayConfig) -> PlayConfig
forall a b. (a, b) -> b
snd (Bool, PlayConfig)
x))) ((Bool, PlayConfig) -> (Int, Double))
-> Emitter IO (Bool, PlayConfig) -> Emitter IO (Int, Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Box IO (Bool, PlayConfig) (Bool, PlayConfig)
-> Emitter IO (Bool, PlayConfig)
forall (m :: * -> *) c e. Box m c e -> Emitter m e
emitter Box IO (Bool, PlayConfig) (Bool, PlayConfig)
playBox) (Emitter IO (Double, [Code]) -> Codensity IO (Emitter IO [Code]))
-> (Emitter IO (Double, [Code]) -> Emitter IO (Double, [Code]))
-> Emitter IO (Double, [Code])
-> Codensity IO (Emitter IO [Code])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Emitter IO Bool
-> Emitter IO (Double, [Code]) -> Emitter IO (Double, [Code])
forall a. Emitter IO Bool -> Emitter IO a -> Emitter IO a
pauser (PlayConfig -> Bool
playPause (PlayConfig -> Bool)
-> ((Bool, PlayConfig) -> PlayConfig) -> (Bool, PlayConfig) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, PlayConfig) -> PlayConfig
forall a b. (a, b) -> b
snd ((Bool, PlayConfig) -> Bool)
-> Emitter IO (Bool, PlayConfig) -> Emitter IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Box IO (Bool, PlayConfig) (Bool, PlayConfig)
-> Emitter IO (Bool, PlayConfig)
forall (m :: * -> *) c e. Box m c e -> Emitter m e
emitter Box IO (Bool, PlayConfig) (Bool, PlayConfig)
playBox) (Emitter IO (Double, [Code]) -> Codensity IO (Emitter IO [Code]))
-> CoEmitter IO (Double, [Code])
-> Codensity IO (Emitter IO [Code])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CoEmitter IO (Double, [Code])
pipe))
  () -> IO ()
forall a. a -> IO a
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 (CodeBox -> IO ()) -> CoCodeBox -> IO ()
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 <- ParserT PureMode e [Char] -> ParserT PureMode e ByteString
forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e ByteString
byteStringOf (ParserT PureMode e [Char] -> ParserT PureMode e ByteString)
-> ParserT PureMode e [Char] -> ParserT PureMode e ByteString
forall a b. (a -> b) -> a -> b
$ ParserT PureMode e Char -> ParserT PureMode e [Char]
forall a. ParserT PureMode e a -> ParserT PureMode e [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ((Char -> Bool) -> ParserT PureMode e Char
forall (st :: ZeroBitType) e. (Char -> Bool) -> ParserT st e Char
satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"'))
  ()
_ <- $(string [i|","value":"|])
  ByteString
v <- ParserT PureMode e [Char] -> ParserT PureMode e ByteString
forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e ByteString
byteStringOf (ParserT PureMode e [Char] -> ParserT PureMode e ByteString)
-> ParserT PureMode e [Char] -> ParserT PureMode e ByteString
forall a b. (a -> b) -> a -> b
$ ParserT PureMode e Char -> ParserT PureMode e [Char]
forall a. ParserT PureMode e a -> ParserT PureMode e [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ((Char -> Bool) -> ParserT PureMode e Char
forall (st :: ZeroBitType) e. (Char -> Bool) -> ParserT st e Char
satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"'))
  ()
_ <- $(string [i|"}}|])
  (ByteString, ByteString) -> Parser e (ByteString, ByteString)
forall a. a -> ParserT PureMode e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
e, ByteString
v)

-- * code hooks

-- * code messaging

-- | A simple schema for code that communicates changes to a Html page via JS code.
data Code
  = Replace ByteString ByteString
  | Append ByteString ByteString
  | Console ByteString
  | Eval ByteString
  | Val ByteString
  deriving (Code -> Code -> Bool
(Code -> Code -> Bool) -> (Code -> Code -> Bool) -> Eq Code
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Code -> Code -> Bool
== :: Code -> Code -> Bool
$c/= :: Code -> Code -> Bool
/= :: Code -> Code -> Bool
Eq, Int -> Code -> ShowS
[Code] -> ShowS
Code -> [Char]
(Int -> Code -> ShowS)
-> (Code -> [Char]) -> ([Code] -> ShowS) -> Show Code
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Code -> ShowS
showsPrec :: Int -> Code -> ShowS
$cshow :: Code -> [Char]
show :: Code -> [Char]
$cshowList :: [Code] -> ShowS
showList :: [Code] -> ShowS
Show, (forall x. Code -> Rep Code x)
-> (forall x. Rep Code x -> Code) -> Generic Code
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
$cfrom :: forall x. Code -> Rep Code x
from :: forall x. Code -> Rep Code x
$cto :: forall x. Rep Code x -> Code
to :: forall x. Rep Code x -> Code
Generic, ReadPrec [Code]
ReadPrec Code
Int -> ReadS Code
ReadS [Code]
(Int -> ReadS Code)
-> ReadS [Code] -> ReadPrec Code -> ReadPrec [Code] -> Read Code
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Code
readsPrec :: Int -> ReadS Code
$creadList :: ReadS [Code]
readList :: ReadS [Code]
$creadPrec :: ReadPrec Code
readPrec :: ReadPrec Code
$creadListPrec :: ReadPrec [Code]
readListPrec :: ReadPrec [Code]
Read)

-- | Convert 'Code' to a 'ByteString'
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

-- | write to the console
console :: ByteString -> ByteString
console :: ByteString -> ByteString
console ByteString
t = [i| console.log(#{t}) |]

-- | send arbitrary byestrings.
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();
     |]

-- | Double backslash newline and single quotes.
clean :: ByteString -> ByteString
clean :: ByteString -> ByteString
clean =
  ByteString -> [ByteString] -> ByteString
C.intercalate ByteString
"\\'"
    ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ByteString -> [ByteString]
C.split Char
'\''
    (ByteString -> [ByteString])
-> (ByteString -> ByteString) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString] -> ByteString
C.intercalate ByteString
"\\n"
    ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
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)
  })
}
|]