web-rep 0.9.0 → 0.10.0
raw patch · 9 files changed
+414/−129 lines, 9 filesdep +asyncdep +optparse-applicativedep +profunctorsdep −concurrencydep −optparse-genericdep ~boxdep ~box-socketdep ~lucidsetup-changed
Dependencies added: async, optparse-applicative, profunctors
Dependencies removed: concurrency, optparse-generic
Dependency ranges changed: box, box-socket, lucid, optics-core, text
Files
- Setup.hs +0/−3
- app/rep-example.hs +93/−15
- src/Web/Rep/Bootstrap.hs +49/−3
- src/Web/Rep/Examples.hs +5/−1
- src/Web/Rep/Html/Input.hs +18/−1
- src/Web/Rep/Shared.hs +5/−6
- src/Web/Rep/SharedReps.hs +53/−3
- src/Web/Rep/Socket.hs +180/−92
- web-rep.cabal +11/−5
− Setup.hs
@@ -1,3 +0,0 @@-import Distribution.Simple--main = defaultMain
app/rep-example.hs view
@@ -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
src/Web/Rep/Bootstrap.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-}@@ -5,7 +6,9 @@ -- | Some <https://getbootstrap.com/ bootstrap> 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 @@ ] ] +-- | <link href="https://cdn.jsdelivr.net/npm/bootstrap@5.0.2/dist/css/bootstrap.min.css" rel="stylesheet" integrity="sha384-EVSTQN3/azprG1Anm3QDgpJLIm9Nao0Yz1ztcQTwFspd3yD65VohhpuuCOmLASjC" crossorigin="anonymous">+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 @@ ] ] +-- | <script src="https://cdn.jsdelivr.net/npm/bootstrap@5.0.2/dist/js/bootstrap.bundle.min.js" integrity="sha384-MrcW6ZMFYlzcLA8Nl+NtUVF0sA7MsXsP1UyJoMp4YLEuNSfAP+JcXn/tWtIaxVXM" crossorigin="anonymous"></script>+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 <https://getbootstrap.com/ bootstrap> needs for a web page.+bootstrap5Page :: Page+bootstrap5Page =+ Page+ bootstrap5Css+ bootstrap5Js+ mempty+ mempty+ mempty+ (mconcat bootstrapMeta)+ mempty+ -- | wrap some Html with the bootstrap <https://getbootstrap.com/docs/4.3/components/card/ card> 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
src/Web/Rep/Examples.hs view
@@ -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 =
src/Web/Rep/Html/Input.hs view
@@ -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) ]
@@ -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) ) )
@@ -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) ) )
src/Web/Rep/Socket.hs view
@@ -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
web-rep.cabal view
@@ -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+