{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE StrictData #-}
{-# OPTIONS_GHC -Wall #-}

-- | A socket between a web page and haskell, based on the box library.
module Web.Rep.Socket
  ( socketPage,
    serveSocketBox,
    sharedServer,
    defaultSharedServer,
    SocketConfig (..),
    defaultSocketConfig,
    defaultSocketPage,
    defaultInputCode,
    defaultOutputCode,
    Code (..),
    code,
    wrangle,
  )
where

import Box
import Box.Socket
import Control.Monad
import Control.Monad.Conc.Class as C
import Control.Monad.State.Lazy
import qualified Data.Attoparsec.Text as A
import Data.Bifunctor
import Data.Functor.Contravariant
import Data.HashMap.Strict as HashMap
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.Scotty hiding (get)

socketPage :: Page
socketPage :: Page
socketPage =
  Page
forall a. Monoid a => a
mempty Page -> (Page -> Page) -> Page
forall a b. a -> (a -> b) -> b
& IsLabel "jsOnLoad" (Optic A_Lens NoIx Page Page RepJs RepJs)
Optic A_Lens NoIx Page Page RepJs RepJs
#jsOnLoad
    Optic A_Lens NoIx Page Page RepJs RepJs -> RepJs -> Page -> Page
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ [RepJs] -> RepJs
forall a. Monoid a => [a] -> a
mconcat
      [ RepJs
webSocket,
        RepJs
runScriptJs,
        RepJs
refreshJsbJs,
        RepJs
preventEnter
      ]

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 =
  Port -> ScottyM () -> IO ()
scotty (SocketConfig
cfg SocketConfig -> Optic' A_Lens NoIx SocketConfig Port -> Port
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "port" (Optic' A_Lens NoIx SocketConfig Port)
Optic' A_Lens NoIx SocketConfig Port
#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
forall (m :: * -> *).
(MonadConc m, MonadIO m) =>
Box m Text Text -> PendingConnection -> m ()
serverApp Box IO Text Text
b)
    RoutePattern -> PageConfig -> Page -> ScottyM ()
servePageWith RoutePattern
"/" (FilePath -> PageConfig
defaultPageConfig FilePath
"") Page
p

sharedServer :: SharedRep IO a -> SocketConfig -> Page -> (Html () -> [Code]) -> (Either Text a -> IO [Code]) -> IO ()
sharedServer :: SharedRep IO a
-> SocketConfig
-> Page
-> (Html () -> [Code])
-> (Either Text a -> IO [Code])
-> IO ()
sharedServer SharedRep IO a
srep SocketConfig
cfg Page
p Html () -> [Code]
i Either Text a -> IO [Code]
o =
  SocketConfig -> Page -> Box IO Text Text -> IO ()
serveSocketBox SocketConfig
cfg Page
p
    (Box IO Text Text -> IO ())
-> Codensity IO (Box IO Text Text) -> IO ()
forall a (m :: * -> *) r. (a -> m r) -> Codensity m a -> m r
<$|> (Box IO Text Text -> IO ()) -> Codensity IO (Box IO Text Text)
forall (m :: * -> *) a b r.
MonadConc m =>
(Box m a b -> m r) -> CoBox m b a
fromAction (SharedRep IO a
-> (Html () -> [Code])
-> (Either Text a -> IO [Code])
-> Box IO [Code] (Text, Text)
-> IO ()
forall (m :: * -> *) a.
MonadConc m =>
SharedRep m a
-> (Html () -> [Code])
-> (Either Text a -> m [Code])
-> Box m [Code] (Text, Text)
-> m ()
backendLoop SharedRep IO a
srep Html () -> [Code]
i Either Text a -> IO [Code]
o (Box IO [Code] (Text, Text) -> IO ())
-> (Box IO Text Text -> Box IO [Code] (Text, Text))
-> Box IO Text Text
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Box IO Text Text -> Box IO [Code] (Text, Text)
forall (m :: * -> *).
Monad m =>
Box m Text Text -> Box m [Code] (Text, Text)
wrangle)

defaultSharedServer :: (Show a) => SharedRep IO a -> IO ()
defaultSharedServer :: SharedRep IO a -> IO ()
defaultSharedServer SharedRep IO a
srep =
  SharedRep IO a
-> SocketConfig
-> Page
-> (Html () -> [Code])
-> (Either Text a -> IO [Code])
-> IO ()
forall a.
SharedRep IO a
-> SocketConfig
-> Page
-> (Html () -> [Code])
-> (Either Text a -> IO [Code])
-> IO ()
sharedServer SharedRep IO a
srep SocketConfig
defaultSocketConfig Page
defaultSocketPage Html () -> [Code]
defaultInputCode Either Text a -> IO [Code]
forall (m :: * -> *) a.
(Monad m, Show a) =>
Either Text a -> m [Code]
defaultOutputCode

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
& IsLabel
  "htmlBody" (Optic A_Lens NoIx Page Page (Html ()) (Html ()))
Optic A_Lens NoIx Page Page (Html ()) (Html ())
#htmlBody
    Optic A_Lens NoIx Page Page (Html ()) (Html ())
-> Html () -> Page -> Page
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"
      ( [Html ()] -> Html ()
forall a. Monoid a => [a] -> a
mconcat
          [ Text -> Html () -> Html ()
divClass_ Text
"row" (Html () -> Html ()
forall arg result. Term arg result => arg -> result
h1_ Html ()
"web-rep testing"),
            Text -> Html () -> Html ()
divClass_ Text
"row" (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ [Html ()] -> Html ()
forall a. Monoid a => [a] -> a
mconcat ([Html ()] -> Html ()) -> [Html ()] -> Html ()
forall a b. (a -> b) -> a -> b
$ (\(Text
t, Html ()
h) -> Text -> Html () -> Html ()
divClass_ Text
"col" (Html () -> Html ()
forall arg result. Term arg result => arg -> result
h2_ (Text -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
t) Html () -> Html () -> Html ()
forall a. Semigroup a => a -> a -> a
<> (Html () -> Html ()) -> [Attribute] -> Html () -> Html ()
forall a. With a => a -> [Attribute] -> a
L.with Html () -> Html ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
id_ Text
t] Html ()
h)) ((Text, Html ()) -> Html ()) -> [(Text, Html ())] -> [Html ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Html ())]
sections
          ]
      )
  where
    sections :: [(Text, Html ())]
sections =
      [ (Text
"input", Html ()
forall a. Monoid a => a
mempty),
        (Text
"output", Html ()
forall a. Monoid a => a
mempty)
      ]

-- I am proud of this.
backendLoop ::
  (MonadConc m) =>
  SharedRep m a ->
  -- | initial code to place html of the SharedRep
  (Html () -> [Code]) ->
  -- | output code
  (Either Text a -> m [Code]) ->
  Box m [Code] (Text, Text) ->
  m ()
backendLoop :: SharedRep m a
-> (Html () -> [Code])
-> (Either Text a -> m [Code])
-> Box m [Code] (Text, Text)
-> m ()
backendLoop SharedRep m a
sr Html () -> [Code]
inputCode Either Text a -> m [Code]
outputCode (Box Committer m [Code]
c Emitter m (Text, Text)
e) = (StateT (Port, HashMap Text Text) m ()
 -> (Port, HashMap Text Text) -> m ())
-> (Port, HashMap Text Text)
-> StateT (Port, HashMap Text Text) m ()
-> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (Port, HashMap Text Text) m ()
-> (Port, HashMap Text Text) -> m ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Port
0, HashMap Text Text
forall k v. HashMap k v
HashMap.empty) (StateT (Port, HashMap Text Text) m () -> m ())
-> StateT (Port, HashMap Text Text) m () -> m ()
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) <- SharedRep m a
-> StateT (Port, HashMap Text Text) m (RepF (Html ()) a)
forall (m :: * -> *) r a.
SharedRepF m r a -> StateT (Port, HashMap Text Text) m (RepF r a)
unshare SharedRep m a
sr
  Bool
b <- m Bool -> StateT (Port, HashMap Text Text) m Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Bool -> StateT (Port, HashMap Text Text) m Bool)
-> m Bool -> StateT (Port, HashMap Text Text) m Bool
forall a b. (a -> b) -> a -> b
$ Committer m [Code] -> [Code] -> m Bool
forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer m [Code]
c (Html () -> [Code]
inputCode Html ()
h)
  [Code]
o <- (HashMap Text Text -> (HashMap Text Text, Either Text a))
-> StateT (Port, HashMap Text Text) m [Code]
forall a t (t :: (* -> *) -> * -> *).
(MonadState (a, t) (t m), MonadTrans t) =>
(t -> (t, Either Text a)) -> t m [Code]
step' HashMap Text Text -> (HashMap Text Text, Either Text a)
fa
  Bool
b' <- m Bool -> StateT (Port, HashMap Text Text) m Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Bool -> StateT (Port, HashMap Text Text) m Bool)
-> m Bool -> StateT (Port, HashMap Text Text) m Bool
forall a b. (a -> b) -> a -> b
$ Committer m [Code] -> [Code] -> m Bool
forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer m [Code]
c [Code]
o
  Bool
-> StateT (Port, HashMap Text Text) m ()
-> StateT (Port, HashMap Text Text) m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
b Bool -> Bool -> Bool
&& Bool
b') ((HashMap Text Text -> (HashMap Text Text, Either Text a))
-> StateT (Port, HashMap Text Text) m ()
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)
incoming <- m (Maybe (Text, Text)) -> t m (Maybe (Text, Text))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe (Text, Text)) -> t m (Maybe (Text, Text)))
-> m (Maybe (Text, Text)) -> t m (Maybe (Text, Text))
forall a b. (a -> b) -> a -> b
$ Emitter m (Text, Text) -> m (Maybe (Text, Text))
forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter m (Text, Text)
e
      ((a, HashMap Text Text) -> (a, HashMap Text Text)) -> t m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Maybe (Text, Text)
-> (a, HashMap Text Text) -> (a, HashMap Text Text)
forall (p :: * -> * -> *) k v a.
(Bifunctor p, Hashable k) =>
Maybe (k, v) -> p a (HashMap k v) -> p a (HashMap k v)
updateS Maybe (Text, Text)
incoming)
      [Code]
o <- (HashMap Text Text -> (HashMap Text Text, Either Text a))
-> t m [Code]
forall a t (t :: (* -> *) -> * -> *).
(MonadState (a, t) (t m), MonadTrans t) =>
(t -> (t, Either Text a)) -> t m [Code]
step' HashMap Text Text -> (HashMap Text Text, Either Text a)
fa
      Bool
b <- m Bool -> t m Bool
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 [Code] -> [Code] -> m Bool
forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer m [Code]
c [Code]
o
      Bool -> t m () -> t m ()
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)
    updateS :: Maybe (k, v) -> p a (HashMap k v) -> p a (HashMap k v)
updateS Maybe (k, v)
Nothing p a (HashMap k v)
s = p a (HashMap k v)
s
    updateS (Just (k
k, v
v)) p a (HashMap k v)
s = (HashMap k v -> HashMap k v)
-> p a (HashMap k v) -> p a (HashMap k v)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (k -> v -> HashMap k v -> HashMap k v
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
insert k
k v
v) p a (HashMap k v)
s

    step' :: (t -> (t, Either Text a)) -> t m [Code]
step' t -> (t, Either Text a)
fa = do
      (a, t)
s <- t m (a, t)
forall s (m :: * -> *). MonadState s m => m s
get
      let (t
m', Either Text a
ea) = t -> (t, Either Text a)
fa ((a, t) -> t
forall a b. (a, b) -> b
snd (a, t)
s)
      ((a, t) -> (a, t)) -> t m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((t -> t) -> (a, t) -> (a, t)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (t -> t -> t
forall a b. a -> b -> a
const t
m'))
      m [Code] -> t m [Code]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [Code] -> t m [Code]) -> m [Code] -> t m [Code]
forall a b. (a -> b) -> a -> b
$ Either Text a -> m [Code]
outputCode Either Text a
ea

defaultInputCode :: Html () -> [Code]
defaultInputCode :: Html () -> [Code]
defaultInputCode Html ()
h = [Text -> Text -> Code
Append Text
"input" (Html () -> Text
forall a. Html a -> Text
toText Html ()
h)]

defaultOutputCode :: (Monad m, Show a) => Either Text a -> m [Code]
defaultOutputCode :: Either Text a -> m [Code]
defaultOutputCode Either Text a
ea =
  [Code] -> m [Code]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Code] -> m [Code]) -> [Code] -> m [Code]
forall a b. (a -> b) -> a -> b
$ 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" (FilePath -> Text
pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ a -> FilePath
forall a. Show a => a -> FilePath
show a
a)]

wrangle :: Monad m => Box m Text Text -> Box m [Code] (Text, Text)
wrangle :: Box m Text Text -> Box m [Code] (Text, Text)
wrangle (Box Committer m Text
c Emitter m Text
e) = Committer m [Code]
-> Emitter m (Text, Text) -> Box m [Code] (Text, Text)
forall (m :: * -> *) c e. Committer m c -> Emitter m e -> Box m c e
Box Committer m [Code]
c' Emitter m (Text, Text)
e'
  where
    c' :: Committer m [Code]
c' = Committer m Code -> Committer m [Code]
forall (m :: * -> *) a. Monad m => Committer m a -> Committer m [a]
listC (Committer m Code -> Committer m [Code])
-> Committer m Code -> Committer m [Code]
forall a b. (a -> b) -> a -> b
$ (Code -> Text) -> Committer m Text -> Committer m Code
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap Code -> Text
code Committer m Text
c
    e' :: Emitter m (Text, Text)
e' = (Either Text (Text, Text) -> m (Maybe (Text, Text)))
-> Emitter m (Either Text (Text, Text)) -> Emitter m (Text, Text)
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> Emitter m a -> Emitter m b
witherE (Maybe (Text, Text) -> m (Maybe (Text, Text))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Text, Text) -> m (Maybe (Text, Text)))
-> (Either Text (Text, Text) -> Maybe (Text, Text))
-> Either Text (Text, Text)
-> m (Maybe (Text, Text))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Maybe (Text, Text))
-> ((Text, Text) -> Maybe (Text, Text))
-> Either Text (Text, Text)
-> Maybe (Text, Text)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe (Text, Text) -> Text -> Maybe (Text, Text)
forall a b. a -> b -> a
const Maybe (Text, Text)
forall a. Maybe a
Nothing) (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just) (Parser (Text, Text)
-> Emitter m Text -> Emitter m (Either Text (Text, Text))
forall (m :: * -> *) a.
Functor m =>
Parser a -> Emitter m Text -> Emitter m (Either Text a)
parseE Parser (Text, Text)
parserJ Emitter m Text
e)

-- | attoparsec parse emitter which returns the original text on failure
parseE :: (Functor m) => A.Parser a -> Emitter m Text -> Emitter m (Either Text a)
parseE :: Parser a -> Emitter m Text -> Emitter m (Either Text a)
parseE Parser a
parser Emitter m Text
e = (\Text
t -> (FilePath -> Either Text a)
-> (a -> Either Text a) -> Either FilePath a -> Either Text a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either Text a -> FilePath -> Either Text a
forall a b. a -> b -> a
const (Either Text a -> FilePath -> Either Text a)
-> Either Text a -> FilePath -> Either Text a
forall a b. (a -> b) -> a -> b
$ Text -> Either Text a
forall a b. a -> Either a b
Left Text
t) a -> Either Text a
forall a b. b -> Either a b
Right (Parser a -> Text -> Either FilePath a
forall a. Parser a -> Text -> Either FilePath a
A.parseOnly Parser a
parser Text
t)) (Text -> Either Text a)
-> Emitter m Text -> Emitter m (Either Text a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Emitter m Text
e

-- | {"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 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"')
  Text
_ <- Text -> Parser Text
A.string [q|","value":"|]
  Text
v <- (Char -> Bool) -> Parser Text
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"')
  Text
_ <- Text -> Parser Text
A.string [q|"}}|]
  (Text, Text) -> Parser (Text, Text)
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
(Code -> Code -> Bool) -> (Code -> Code -> Bool) -> Eq Code
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, Port -> Code -> ShowS
[Code] -> ShowS
Code -> FilePath
(Port -> Code -> ShowS)
-> (Code -> FilePath) -> ([Code] -> ShowS) -> Show Code
forall a.
(Port -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Code] -> ShowS
$cshowList :: [Code] -> ShowS
show :: Code -> FilePath
$cshow :: Code -> FilePath
showsPrec :: Port -> Code -> ShowS
$cshowsPrec :: Port -> 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
$cto :: forall x. Rep Code x -> Code
$cfrom :: forall x. Code -> Rep Code x
Generic, ReadPrec [Code]
ReadPrec Code
Port -> ReadS Code
ReadS [Code]
(Port -> ReadS Code)
-> ReadS [Code] -> ReadPrec Code -> ReadPrec [Code] -> Read Code
forall a.
(Port -> 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 :: Port -> ReadS Code
$creadsPrec :: Port -> 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
"\\'" ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
Text.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'')
    (Text -> [Text]) -> (Text -> Text) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
Text.intercalate Text
"\\n"
    ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
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 (JS -> RepJs) -> JS -> 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)
  })
}
|]