diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple - -main = defaultMain diff --git a/app/rep-example.hs b/app/rep-example.hs --- a/app/rep-example.hs +++ b/app/rep-example.hs @@ -1,35 +1,113 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} +{-# HLINT ignore "Eta reduce" #-} +{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} -import Options.Generic +{-# HLINT ignore "Use newtype instead of data" #-} + +import Box +import Control.Monad +import Data.Bifunctor +import Data.Text (pack) +import qualified Lucid as L +import Optics.Core +import Options.Applicative import Web.Rep import Web.Rep.Examples import Prelude -data AppType = SharedTest deriving (Eq, Read, Show, Generic) +data AppType + = SharedTest + | PlayTest + | RestartTest + | ClosureBug + deriving (Eq, Show) -instance ParseField AppType +data Options = Options + { optionAppType :: AppType + } + deriving (Eq, Show) -instance ParseRecord AppType +parseAppType :: Parser AppType +parseAppType = + flag' SharedTest (long "shared" <> help "shared test") + <|> flag' PlayTest (long "play" <> help "play functionality test") + <|> flag' RestartTest (long "restart" <> help "console restart test") + <|> flag' ClosureBug (long "closure" <> help "documents the closure bug") + <|> pure SharedTest -instance ParseFields AppType +options :: Parser Options +options = + Options + <$> parseAppType -newtype Opts w = Opts - { apptype :: w ::: AppType "type of example" - } - deriving (Generic) +opts :: ParserInfo Options +opts = + info + (options <**> helper) + (fullDesc <> progDesc "web-rep testing" <> header "web-rep") -instance ParseRecord (Opts Wrapped) +-- | A simple count stream +countStream :: Int -> Double -> CoEmitter IO (Gap, [Code]) +countStream n speed = fmap (second ((: []) . Replace "output" . pack . show)) <$> qList (zip (0 : repeat (1 / speed)) [0 .. n]) main :: IO () main = do - o :: Opts Unwrapped <- unwrapRecord "examples for web-page" - case apptype o of - SharedTest -> defaultSharedServer (maybeRep (Just "maybe") False repExamples) + o <- execParser opts + let a = optionAppType o + case a of + SharedTest -> sharedTest + PlayTest -> playTest + RestartTest -> void restartTest + ClosureBug -> void closureBug + +sharedTest :: IO () +sharedTest = + serveRep + (maybeRep (Just "maybe") False repExamples) + replaceInput + replaceOutput + defaultCodeBoxConfig + +playTest :: IO () +playTest = servePlayStream (PlayConfig True 10 0) (defaultCodeBoxConfig & #codeBoxPage .~ playPage) (countStream 100 1) + +playPage :: Page +playPage = + defaultSocketPage Boot5 + & #htmlBody + .~ divClass_ + "container" + ( mconcat + [ divClass_ "row" (L.h1_ "Replay Simulation"), + divClass_ "row" . mconcat $ + (\(t, h) -> divClass_ "col" (L.with L.div_ [L.id_ t] h)) + <$> [ ("input", mempty), + ("output", mempty) + ] + ] + ) + +restartTest :: IO (Either Bool ()) +restartTest = restart <$> (gapEffect . fmap (1,) <$> resetE 5 10) <*|> pure (glue showStdout . gapEffect <$|> countStream 100 1) + +resetE :: Int -> Int -> CoEmitter IO Bool +resetE n m = qList (replicate (n - 1) False <> [True] <> replicate m False) + +-- | documenting the issue with left floating compositions in the usage of <$|> +closureBug :: IO (Either Bool ()) +closureBug = do + putStrLn "restart ((== \"q\") <$> fromStdin) (glue showStdout . gapEffect <$|> countStream 10 2)" + putStrLn "type 'q' to restart" + restart ((== "q") <$> fromStdin) (glue showStdout . gapEffect <$|> countStream 10 2) + putStrLn "buggy version" + putStrLn "restart ((== \"q\") <$> fromStdin) . glue showStdout . gapEffect <$|> countStream 20 1" + restart ((== "q") <$> fromStdin) . glue showStdout . gapEffect <$|> countStream 10 2 diff --git a/src/Web/Rep/Bootstrap.hs b/src/Web/Rep/Bootstrap.hs --- a/src/Web/Rep/Bootstrap.hs +++ b/src/Web/Rep/Bootstrap.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-} @@ -5,7 +6,9 @@ -- | Some assets and functionality. module Web.Rep.Bootstrap - ( bootstrapPage, + ( BootstrapVersion (..), + bootstrapPage, + bootstrap5Page, cardify, divClass_, accordion, @@ -20,12 +23,15 @@ import Data.Bool import Data.Functor.Identity import Data.Text (Text) +import GHC.Generics import Lucid import Lucid.Base import Web.Rep.Html import Web.Rep.Page import Web.Rep.Shared +data BootstrapVersion = Boot4 | Boot5 deriving (Eq, Show, Generic) + bootstrapCss :: [Html ()] bootstrapCss = [ link_ @@ -36,6 +42,17 @@ ] ] +-- | +bootstrap5Css :: [Html ()] +bootstrap5Css = + [ link_ + [ rel_ "stylesheet", + href_ "https://cdn.jsdelivr.net/npm/bootstrap@5.0.2/dist/css/bootstrap.min.css", + integrity_ "sha384-EVSTQN3/azprG1Anm3QDgpJLIm9Nao0Yz1ztcQTwFspd3yD65VohhpuuCOmLASjC", + crossorigin_ "anonymous" + ] + ] + bootstrapJs :: [Html ()] bootstrapJs = [ with @@ -58,6 +75,23 @@ ] ] +-- | +bootstrap5Js :: [Html ()] +bootstrap5Js = + [ with + (script_ mempty) + [ src_ "https://cdn.jsdelivr.net/npm/bootstrap@5.0.2/dist/js/bootstrap.bundle.min.js", + integrity_ "sha384-MrcW6ZMFYlzcLA8Nl+NtUVF0sA7MsXsP1UyJoMp4YLEuNSfAP+JcXn/tWtIaxVXM", + crossorigin_ "anonymous" + ], + with + (script_ mempty) + [ src_ "https://code.jquery.com/jquery-3.3.1.slim.min.js", + integrity_ "sha384-q8i/X+965DzO0rT7abK41JStQIAqVgRVzpbzo5smXKp4YfRvH+8abtTE1Pi6jizo", + crossorigin_ "anonymous" + ] + ] + bootstrapMeta :: [Html ()] bootstrapMeta = [ meta_ [charset_ "utf-8"], @@ -79,6 +113,18 @@ (mconcat bootstrapMeta) mempty +-- | A page containing all the needs for a web page. +bootstrap5Page :: Page +bootstrap5Page = + Page + bootstrap5Css + bootstrap5Js + mempty + mempty + mempty + (mconcat bootstrapMeta) + mempty + -- | wrap some Html with the bootstrap class cardify :: (Html (), [Attribute]) -> Maybe Text -> (Html (), [Attribute]) -> Html () cardify (h, hatts) t (b, batts) = @@ -144,7 +190,7 @@ idp' <- genNamePre pre with div_ [class__ "accordion m-1", id_ idp'] <$> aCards idp' where - aCards par = mconcat <$> sequence (aCard par <$> hs) + aCards par = mconcat <$> mapM (aCard par) hs aCard par (t, b) = do idh <- genNamePre pre idb <- genNamePre pre @@ -156,7 +202,7 @@ idp' <- genNamePre pre with div_ [class__ "accordion m-1", id_ idp'] <$> aCards idp' where - aCards par = mconcat <$> sequence (aCard par <$> hs) + aCards par = mconcat <$> mapM (aCard par) hs aCard par (l, bodyhtml, checkhtml) = do idh <- genNamePre pre idb <- genNamePre pre diff --git a/src/Web/Rep/Examples.hs b/src/Web/Rep/Examples.hs --- a/src/Web/Rep/Examples.hs +++ b/src/Web/Rep/Examples.hs @@ -110,6 +110,8 @@ repTextarea :: Text, repSliderI :: Int, repSlider :: Double, + repSliderVI :: Int, + repSliderV :: Double, repCheckbox :: Bool, repToggle :: Bool, repDropdown :: Int, @@ -141,13 +143,15 @@ ta <- textarea 3 (Just "textarea") "no initial value & multi-line text\\nrenders is not ok?/" n <- sliderI (Just "int slider") 0 5 1 3 ds' <- slider (Just "double slider") 0 1 0.1 0.5 + nV <- sliderVI (Just "int slider") 0 5 1 3 + dsV' <- sliderV (Just "double slider") 0 1 0.1 0.5 c <- checkbox (Just "checkbox") True tog <- toggle (Just "toggle") False dr <- dropdown decimal (pack . show) (Just "dropdown") (pack . show <$> [1 .. 5 :: Int]) 3 drm <- dropdownMultiple decimal (pack . show) (Just "dropdown multiple") (pack . show <$> [1 .. 5 :: Int]) [2, 4] drt <- toShape <$> dropdown takeText id (Just "shape") ["Circle", "Square"] (fromShape SquareShape) col <- colorPicker (Just "color") "#454e56" - pure (RepExamples t ta n ds' c tog dr drm drt col) + pure (RepExamples t ta n ds' nV dsV' c tog dr drm drt col) listExample :: (Monad m) => Int -> SharedRep m [Int] listExample n = diff --git a/src/Web/Rep/Html/Input.hs b/src/Web/Rep/Html/Input.hs --- a/src/Web/Rep/Html/Input.hs +++ b/src/Web/Rep/Html/Input.hs @@ -34,6 +34,7 @@ -- | Various types of web page inputs, encapsulating practical bootstrap class functionality data InputType = Slider [Attribute] + | SliderV [Attribute] | TextBox | TextBox' | TextArea Int @@ -63,6 +64,22 @@ <> satts ) ) + toHtml (Input v l i (SliderV satts)) = + with + div_ + [class__ "form-group-sm"] + ( maybe mempty (with label_ [for_ i, class__ "mb-0"] . toHtml) l + <> input_ + ( [ type_ "range", + class__ " form-control-range form-control-sm custom-range jsbClassEventChange", + id_ i, + value_ (pack $ show $ toHtml v), + oninput_ ("$('#sliderv" <> i <> "').html($(this).val())") + ] + <> satts + ) + <> span_ [id_ ("sliderv" <> i)] (toHtml v) + ) toHtml (Input v l i TextBox) = with div_ @@ -250,7 +267,7 @@ <> input_ ( [ type_ "button", class__ "btn btn-primary btn-sm jsbClassEventToggle", - data_ "toggle" "button", + data_ "bs-toggle" "button", id_ i, makeAttribute "aria-pressed" (bool "false" "true" pushed) ] diff --git a/src/Web/Rep/Shared.hs b/src/Web/Rep/Shared.hs --- a/src/Web/Rep/Shared.hs +++ b/src/Web/Rep/Shared.hs @@ -148,9 +148,10 @@ ( \s -> ( s, join $ - maybe (Left "lookup failed") Right $ - either (Left . (\x -> name <> ": " <> x)) Right . p - <$> HashMap.lookup name s + maybe + (Left "lookup failed") + (Right . either (Left . (\x -> name <> ": " <> x)) Right . p) + (HashMap.lookup name s) ) ) @@ -175,9 +176,7 @@ ( \s -> ( HashMap.delete name s, join $ - maybe (Right $ Right d) Right $ - p - <$> HashMap.lookup name s + maybe (Right $ Right d) (Right . p) (HashMap.lookup name s) ) ) diff --git a/src/Web/Rep/SharedReps.hs b/src/Web/Rep/SharedReps.hs --- a/src/Web/Rep/SharedReps.hs +++ b/src/Web/Rep/SharedReps.hs @@ -13,6 +13,8 @@ repMessage, sliderI, slider, + sliderV, + sliderVI, dropdown, dropdownMultiple, datalist, @@ -22,6 +24,7 @@ textarea, checkbox, toggle, + toggle_, button, chooseFile, maybeRep, @@ -103,6 +106,27 @@ (Input v label mempty (Slider [min_ (pack $ show l), max_ (pack $ show u), step_ (pack $ show s)])) v +-- | double slider with shown value +-- +-- For Example, a slider between 0 and 1 with a step of 0.01 and a default value of 0.3 is: +-- +-- > :t slider (Just "label") 0 1 0.01 0.3 +-- slider (Just "label") 0 1 0.01 0.3 :: Monad m => SharedRep m Double +sliderV :: + (Monad m) => + Maybe Text -> + Double -> + Double -> + Double -> + Double -> + SharedRep m Double +sliderV label l u s v = + repInput + double + (pack . show) + (Input v label mempty (SliderV [min_ (pack $ show l), max_ (pack $ show u), step_ (pack $ show s)])) + v + -- | integral slider -- -- For Example, a slider between 0 and 1000 with a step of 10 and a default value of 300 is: @@ -125,6 +149,22 @@ (Input v label mempty (Slider [min_ (pack $ show l), max_ (pack $ show u), step_ (pack $ show s)])) v +-- | integral slider with shown value +sliderVI :: + (Monad m, ToHtml a, P.Integral a, Show a) => + Maybe Text -> + a -> + a -> + a -> + a -> + SharedRep m a +sliderVI label l u s v = + repInput + decimal + (pack . show) + (Input v label mempty (SliderV [min_ (pack $ show l), max_ (pack $ show u), step_ (pack $ show s)])) + v + -- | textbox classique -- -- > :t textbox (Just "label") "some text" @@ -249,6 +289,15 @@ (Input v label mempty (Toggle v label)) v +-- | a toggle button, with no label +toggle_ :: (Monad m) => Maybe Text -> Bool -> SharedRep m Bool +toggle_ label v = + repInput + ((== "true") <$> takeText) + (bool "false" "true") + (Input v Nothing mempty (Toggle v label)) + v + -- | a button button :: (Monad m) => Maybe Text -> SharedRep m Bool button label = @@ -307,9 +356,10 @@ ( \s -> ( s, join $ - maybe (Left "HashMap.lookup failed") Right $ - either (Left . pack) Right . parseOnly ((== "true") <$> takeText) - <$> HashMap.lookup name s + maybe + (Left "HashMap.lookup failed") + (Right . either (Left . pack) Right . parseOnly ((== "true") <$> takeText)) + (HashMap.lookup name s) ) ) diff --git a/src/Web/Rep/Socket.hs b/src/Web/Rep/Socket.hs --- a/src/Web/Rep/Socket.hs +++ b/src/Web/Rep/Socket.hs @@ -5,33 +5,26 @@ {-# 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, - serveSocketBox, - sharedServer, - defaultSharedServer, - SocketConfig (..), - defaultSocketConfig, - defaultSocketPage, - defaultInputCode, - defaultOutputCode, - Code (..), - code, - wrangle, - ) -where +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 +import Box.Socket (serverApp) +import Control.Concurrent.Async 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.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 @@ -45,103 +38,197 @@ import Web.Rep.Page import Web.Rep.Server import Web.Rep.Shared -import Web.Scotty hiding (get) +import Web.Rep.SharedReps +import Web.Scotty (middleware, scotty) +-- | Page with all the trimmings for a sharedRep Box socketPage :: Page socketPage = - mempty & #jsOnLoad - .~ mconcat - [ webSocket, - runScriptJs, - refreshJsbJs, - preventEnter + mempty + & #jsOnLoad + .~ mconcat + [ webSocket, + runScriptJs, + refreshJsbJs, + preventEnter + ] + +defaultSocketPage :: BootstrapVersion -> Page +defaultSocketPage v = + bool bootstrap5Page bootstrapPage (v == Boot4) + <> socketPage + & #htmlBody + .~ divClass_ + "container" + ( mconcat + [ divClass_ "row" (h1_ "web-rep testing"), + divClass_ "row" $ mconcat $ (\(t, h) -> divClass_ "col" (h2_ (toHtml t) <> L.with div_ [id_ t] h)) <$> sections + ] + ) + where + sections = + [ ("input", mempty), + ("output", mempty) ] +-- | Socket configuration +-- +-- >>> defaultSocketConfig +-- SocketConfig {host = "127.0.0.1", port = 9160, path = "/"} +data SocketConfig = SocketConfig + { host :: Text, + port :: Int, + path :: Text + } + deriving (Show, Eq, Generic) + +-- | official default +defaultSocketConfig :: SocketConfig +defaultSocketConfig = SocketConfig "127.0.0.1" 9160 "/" + +-- | bidirectional websocket serving a 'Box' serveSocketBox :: SocketConfig -> Page -> Box IO Text Text -> IO () serveSocketBox cfg p b = scotty (cfg ^. #port) $ do middleware $ websocketsOr WS.defaultConnectionOptions (serverApp b) servePageWith "/" (defaultPageConfig "") p -sharedServer :: SharedRep IO a -> SocketConfig -> Page -> (Html () -> [Code]) -> (Either Text a -> IO [Code]) -> IO () -sharedServer srep cfg p i o = - serveSocketBox cfg p - <$|> fromAction (backendLoop srep i o . wrangle) +-- | 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) -defaultSharedServer :: (Show a) => SharedRep IO a -> IO () -defaultSharedServer srep = - sharedServer srep defaultSocketConfig defaultSocketPage defaultInputCode defaultOutputCode +-- | Codensity CodeBox +type CoCodeBox = Codensity IO (Box IO [Code] (Text, Text)) -defaultSocketPage :: Page -defaultSocketPage = - bootstrapPage - <> socketPage - & #htmlBody - .~ divClass_ - "container" - ( mconcat - [ divClass_ "row" (h1_ "web-rep testing"), - divClass_ "row" $ mconcat $ (\(t, h) -> divClass_ "col" (h2_ (toHtml t) <> L.with div_ [id_ t] h)) <$> sections - ] - ) - where - sections = - [ ("input", mempty), - ("output", mempty) - ] +-- | Configuration for a CodeBox serving. +data CodeBoxConfig = CodeBoxConfig + { codeBoxSocket :: SocketConfig, + codeBoxPage :: Page, + codeBoxCommitterQueue :: Queue [Code], + codeBoxEmitterQueue :: Queue (Text, Text) + } + deriving (Generic) --- 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 sr inputCode outputCode (Box c e) = flip evalStateT (0, HashMap.empty) $ do - -- you only want to run unshare once for a SharedRep - (Rep h fa) <- unshare sr - b <- lift $ commit c (inputCode h) - o <- step' fa - b' <- lift $ commit c o - when (b && b') (go fa) - where - go fa = do - incoming <- lift $ emit e - modify (updateS incoming) - o <- step' fa - b <- lift $ commit c o - when b (go fa) - updateS Nothing s = s - updateS (Just (k, v)) s = second (insert k v) s +-- | official default config. +defaultCodeBoxConfig :: CodeBoxConfig +defaultCodeBoxConfig = CodeBoxConfig defaultSocketConfig (defaultSocketPage Boot5) Single Single - step' fa = do - s <- get - let (m', ea) = fa (snd s) - modify (second (const m')) - lift $ outputCode ea +-- | Turn a configuration into a live (Codensity) CodeBox +codeBoxWith :: CodeBoxConfig -> CoCodeBox +codeBoxWith cfg = + fromActionWith + (view #codeBoxEmitterQueue cfg) + (view #codeBoxCommitterQueue cfg) + ( serveSocketBox (view #codeBoxSocket cfg) (view #codeBoxPage cfg) + . dimap (either undefined id . A.parseOnly parserJ) (mconcat . fmap code) + ) -defaultInputCode :: Html () -> [Code] -defaultInputCode h = [Append "input" (toText h)] +-- | Turn the default configuration into a live (Codensity) CodeBox +codeBox :: CoCodeBox +codeBox = codeBoxWith defaultCodeBoxConfig -defaultOutputCode :: (Monad m, Show a) => Either Text a -> m [Code] -defaultOutputCode ea = - pure $ case ea of +-- | serve a SharedRep +serveRep :: SharedRep IO a -> (Html () -> [Code]) -> (Either Text a -> [Code]) -> CodeBoxConfig -> IO () +serveRep srep i o cfg = + serveRepWithBox srep i o <$|> codeBoxWith cfg + +-- | non-codensity sharedRep server. +serveRepWithBox :: SharedRep IO a -> (Html () -> [Code]) -> (Either Text a -> [Code]) -> CodeBox -> IO () +serveRepWithBox srep i o (Box c e) = + sharedStream srep (contramap i c) (contramap o c) e + +-- | Convert HTML representation to Code, replacing the input section of a page. +replaceInput :: Html () -> [Code] +replaceInput h = [Replace "input" (toText 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 ea = + case ea of Left err -> [Append "debug" err] Right a -> [Replace "output" (pack $ show a)] -wrangle :: Monad m => Box m Text Text -> Box m [Code] (Text, Text) -wrangle (Box c e) = Box c' e' +-- | 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_ ea = + case ea of + Left _ -> [] + Right a -> [Replace "output" (pack $ show a)] + +-- | Stream a SharedRep +sharedStream :: + Monad m => SharedRep m a -> Committer m (Html ()) -> Committer m (Either Text a) -> Emitter m (Text, Text) -> m () +sharedStream sr ch c e = + flip evalStateT (0, HashMap.empty) $ do + -- you only want to run unshare once for a SharedRep + (Rep h fa) <- unshare sr + b <- lift $ commit ch h + when b (go fa) where - c' = listC $ contramap code c - e' = witherE (pure . either (const Nothing) Just) (parseE parserJ e) + go fa = do + e' <- lift $ emit e + case e' of + Nothing -> pure () + Just (k, v) -> do + hmap <- snd <$> get + let hmap' = insert k v hmap + let (hmap'', r) = fa hmap' + modify (second (const hmap'')) + b <- lift $ commit c r + when b (go fa) --- | 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 e = (\t -> either (const $ Left t) Right (A.parseOnly parser t)) <$> e +-- * Play +-- | Configuration to control a (re)play of an emitter with a Gap (timing) element. +data PlayConfig = PlayConfig + { playPause :: Bool, + playSpeed :: Double, + playFrame :: Int + } + deriving (Eq, Show, Generic) + +-- | Start on pause at normal speed and at frame 0. +defaultPlayConfig :: PlayConfig +defaultPlayConfig = PlayConfig True 1 0 + +-- | representation of a PlayConfig +repPlayConfig :: PlayConfig -> SharedRep IO PlayConfig +repPlayConfig cfg = + PlayConfig + <$> repPause (view #playPause cfg) + <*> repSpeed (view #playSpeed cfg) + <*> repFrame (view #playFrame cfg) + +-- | representation of the playFrame in a PlayConfig +repFrame :: Int -> SharedRep IO Int +repFrame x = read . Text.unpack <$> textbox (Just "frame") (pack $ show x) + +-- | representation of the playSpeed in a PlayConfig +repSpeed :: Double -> SharedRep IO Double +repSpeed x = sliderV (Just "speed") 0.5 100 0.5 x + +-- | representation of the playPause toggle in a PlayConfig +repPause :: Bool -> SharedRep IO Bool +repPause initial = toggle_ (Just "play/pause") initial + +-- | representation of a Bool reset button +repReset :: SharedRep IO Bool +repReset = button (Just "reset") + +-- | Serve an emitter controlled by a PlayConfig representation, with an explicit CodeBox. +servePlayStreamWithBox :: PlayConfig -> CoEmitter IO (Gap, [Code]) -> CodeBox -> IO () +servePlayStreamWithBox pcfg pipe (Box c e) = do + (playBox, _) <- toBoxM (Latest (False, pcfg)) + race_ + (sharedStream ((,) <$> repReset <*> repPlayConfig pcfg) (contramap (\h -> [Replace "input" (toText h)]) c) (witherC (either (const (pure Nothing)) (pure . Just)) (committer playBox)) e) + (restart (fst <$> emitter playBox) (glue c <$|> speedSkipEffect ((\x -> (playFrame (snd x), playSpeed (snd x))) <$> emitter playBox) =<< pauser (playPause . snd <$> emitter playBox) <$> pipe)) + pure () + +-- | Serve an emitter controlled by a PlayConfig representation. +servePlayStream :: PlayConfig -> CodeBoxConfig -> CoEmitter IO (Gap, [Code]) -> IO () +servePlayStream pcfg cbcfg s = servePlayStreamWithBox pcfg s <$|> codeBoxWith cbcfg + +-- * low-level JS conversions + -- | {"event":{"element":"textid","value":"abcdees"}} parserJ :: A.Parser (Text, Text) parserJ = do @@ -199,7 +286,8 @@ clean :: Text -> Text clean = - Text.intercalate "\\'" . Text.split (== '\'') + Text.intercalate "\\'" + . Text.split (== '\'') . Text.intercalate "\\n" . Text.lines diff --git a/web-rep.cabal b/web-rep.cabal --- a/web-rep.cabal +++ b/web-rep.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: web-rep -version: 0.9.0 +version: 0.10.0 synopsis: representations of a web page category: web description: @@ -37,16 +37,16 @@ , attoparsec ^>=0.14 , base >=4.12 && <5 , bifunctors ^>=5.5.11 - , box ^>=0.8 - , box-socket ^>=0.3 + , box >=0.9 + , box-socket ^>=0.4 , clay ^>=0.13 - , concurrency ^>=1.11 , interpolatedstring-perl6 ^>=1.0 , language-javascript >=0.6.0 && <0.8 , lucid ^>=2.9 , mtl ^>=2.2.2 , optics-core ^>=0.4 , optics-extra ^>=0.4 + , profunctors , scotty >=0.11.5 && <0.13 , text ^>=1.2.3 , transformers ^>=0.5.6 @@ -54,6 +54,7 @@ , wai-middleware-static ^>=0.9 , wai-websockets ^>=3.0.1.2 , websockets ^>=0.12 + , async default-language: Haskell2010 default-extensions: @@ -67,8 +68,12 @@ hs-source-dirs: app build-depends: , base >=4.12 && <5 - , optparse-generic >=1.3 + , optparse-applicative , web-rep + , box + , text + , lucid + , optics-core default-language: Haskell2010 default-extensions: @@ -77,3 +82,4 @@ -Wincomplete-uni-patterns -Wredundant-constraints -funbox-strict-fields -fforce-recomp -threaded -rtsopts -with-rtsopts=-N -fwrite-ide-info -hiedir=.hie +