web-rep 0.10.2.0 → 0.11.0.0
raw patch · 16 files changed
+1026/−1262 lines, 16 filesdep +bytestringdep +flatparsedep +markup-parsedep −attoparsecdep −claydep −interpolatedstring-perl6dep ~basedep ~box-socketdep ~optics-core
Dependencies added: bytestring, flatparse, markup-parse, string-interpolate
Dependencies removed: attoparsec, clay, interpolatedstring-perl6, language-javascript, lucid
Dependency ranges changed: base, box-socket, optics-core, optics-extra, profunctors, text, unordered-containers
Files
- ChangeLog.md +6/−1
- LICENSE +30/−0
- LICENSE.md +0/−21
- app/rep-example.hs +32/−17
- src/Web/Rep.hs +4/−9
- src/Web/Rep/Bootstrap.hs +119/−133
- src/Web/Rep/Examples.hs +57/−161
- src/Web/Rep/Html.hs +18/−60
- src/Web/Rep/Html/Input.hs +246/−239
- src/Web/Rep/Page.hs +25/−150
- src/Web/Rep/Render.hs +60/−81
- src/Web/Rep/Server.hs +8/−7
- src/Web/Rep/Shared.hs +24/−23
- src/Web/Rep/SharedReps.hs +125/−152
- src/Web/Rep/Socket.hs +135/−77
- web-rep.cabal +137/−131
ChangeLog.md view
@@ -1,7 +1,12 @@+0.11+===+* Removed clay, lucid as dependencies+* refactored to markup-parse as markup representation.+ 0.10.2 === -GHC 9.6.2 upgrade+* GHC 9.6.2 upgrade 0.8.0 ===
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Tony Day++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Tony Day nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
− LICENSE.md
@@ -1,21 +0,0 @@-The MIT License (MIT)--Copyright (c) 2015 Tony Day <tonyday567@gmail.com>--Permission is hereby granted, free of charge, to any person obtaining a copy-of this software and associated documentation files (the "Software"), to deal-in the Software without restriction, including without limitation the rights-to use, copy, modify, merge, publish, distribute, sublicense, and/or sell-copies of the Software, and to permit persons to whom the Software is-furnished to do so, subject to the following conditions:--The above copyright notice and this permission notice shall be included in-all copies or substantial portions of the Software.--THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR-IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,-FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE-AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER-LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,-OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN-THE SOFTWARE.
app/rep-example.hs view
@@ -6,9 +6,8 @@ import Box import Control.Monad import Data.Bifunctor-import Data.Text (pack)-import Lucid qualified as L-import Optics.Core+import MarkupParse+import Optics.Core hiding (element) import Options.Applicative import Web.Rep import Web.Rep.Examples@@ -47,7 +46,7 @@ -- | 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])+countStream n speed = fmap (second ((: []) . Replace "output" . strToUtf8 . show)) <$> qList (zip (0 : repeat (1 / speed)) [0 .. n]) main :: IO () main = do@@ -72,19 +71,35 @@ 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)- ]- ]- )+ defaultSocketPage+ & set+ #htmlBody+ ( element+ "div"+ [Attr "class" "container"]+ ( element+ "div"+ [Attr "class" "row"]+ (elementc "h1" [] "replay simulation")+ <> element+ "div"+ [Attr "class" "row"]+ ( mconcat $+ ( \(t, h) ->+ element+ "div"+ [Attr "class" "row"]+ (element "h2" [] (elementc "div" [Attr "id" t] h))+ )+ <$> sections+ )+ )+ )+ where+ sections =+ [ ("input", mempty),+ ("output", mempty)+ ] restartTest :: IO (Either Bool ()) restartTest = restart <$> (gapEffect . fmap (1,) <$> resetE 5 10) <*|> pure (glue showStdout . gapEffect <$|> countStream 100 1)
src/Web/Rep.hs view
@@ -27,21 +27,15 @@ concernNames, PageConcerns (..), PageStructure (..),- PageRender (..),+ RenderStyle (..), -- * Css- Css,- RepCss (..),+ Css (..), renderCss,- renderRepCss, -- * JS- JS (..),- RepJs (..),+ Js (..), onLoad,- renderRepJs,- parseJs,- renderJs, -- * re-export modules module Web.Rep.SharedReps,@@ -58,6 +52,7 @@ where import Data.HashMap.Strict qualified as HashMap+import MarkupParse (RenderStyle (..)) import Web.Rep.Bootstrap import Web.Rep.Html import Web.Rep.Html.Input
src/Web/Rep/Bootstrap.hs view
@@ -1,12 +1,14 @@+{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-} -- | Some <https://getbootstrap.com/ bootstrap> assets and functionality. module Web.Rep.Bootstrap- ( BootstrapVersion (..),+ ( bootstrapCss,+ bootstrapJs,+ bootstrapMeta, bootstrapPage,- bootstrap5Page, cardify,- divClass_, accordion, accordionChecked, accordionCard,@@ -17,85 +19,50 @@ import Control.Monad.State.Lazy import Data.Bool+import Data.ByteString (ByteString) import Data.Functor.Identity-import Data.Text (Text)-import GHC.Generics-import Lucid-import Lucid.Base-import Web.Rep.Html+import MarkupParse import Web.Rep.Page import Web.Rep.Shared -data BootstrapVersion = Boot4 | Boot5 deriving (Eq, Show, Generic)+-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Web.Rep+-- >>> import MarkupParse -bootstrapCss :: [Html ()]+bootstrapCss :: Markup bootstrapCss =- [ link_- [ rel_ "stylesheet",- href_ "https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/css/bootstrap.min.css",- integrity_ "sha384-ggOyR0iXCbMQv3Xipma34MD+dH/1fQ784/j6cY/iJTQUOhcWr7x9JvoRxT2MZw1T",- crossorigin_ "anonymous"- ]- ]---- | <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"- ]- ]+ element_+ "link"+ [ Attr "rel" "stylesheet",+ Attr "href" "https://cdn.jsdelivr.net/npm/bootstrap@5.0.2/dist/css/bootstrap.min.css",+ Attr "integrity" "sha384-EVSTQN3/azprG1Anm3QDgpJLIm9Nao0Yz1ztcQTwFspd3yD65VohhpuuCOmLASjC",+ Attr "crossorigin" "anonymous"+ ] -bootstrapJs :: [Html ()]+bootstrapJs :: Markup bootstrapJs =- [ with- (script_ mempty)- [ src_ "https://code.jquery.com/jquery-3.3.1.slim.min.js",- integrity_ "sha384-q8i/X+965DzO0rT7abK41JStQIAqVgRVzpbzo5smXKp4YfRvH+8abtTE1Pi6jizo",- crossorigin_ "anonymous"- ],- with- (script_ mempty)- [ src_ "https://cdnjs.cloudflare.com/ajax/libs/popper.js/1.14.7/umd/popper.min.js",- integrity_ "sha384-UO2eT0CpHqdSJQ6hJty5KVphtPhzWj9WO1clHTMGa3JDZwrnQq4sF86dIHNDz0W1",- crossorigin_ "anonymous"- ],- with- (script_ mempty)- [ src_ "https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/js/bootstrap.min.js",- integrity_ "sha384-JjSmVgyd0p3pXB1rRibZUAYoIIy6OrQ6VrjIEaFf/nJGzIxFDsf4x0xIM+B07jRM",- crossorigin_ "anonymous"+ element_+ "script"+ [ Attr "src" "https://cdn.jsdelivr.net/npm/bootstrap@5.0.2/dist/js/bootstrap.bundle.min.js",+ Attr "integrity" "sha384-MrcW6ZMFYlzcLA8Nl+NtUVF0sA7MsXsP1UyJoMp4YLEuNSfAP+JcXn/tWtIaxVXM",+ Attr "crossorigin" "anonymous"+ ]+ <> element_+ "script"+ [ Attr "src" "https://code.jquery.com/jquery-3.3.1.slim.min.js",+ Attr "integrity" "sha384-q8i/X+965DzO0rT7abK41JStQIAqVgRVzpbzo5smXKp4YfRvH+8abtTE1Pi6jizo",+ Attr "crossorigin" "anonymous" ]- ] --- | <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 :: Markup bootstrapMeta =- [ meta_ [charset_ "utf-8"],- meta_- [ name_ "viewport",- content_ "width=device-width, initial-scale=1, shrink-to-fit=no"+ element_ "meta" [Attr "charset" "utf-8"]+ <> element_+ "meta"+ [ Attr "name" "viewport",+ Attr "content" "width=device-width, initial-scale=1, shrink-to-fit=no" ]- ] -- | A page containing all the <https://getbootstrap.com/ bootstrap> needs for a web page. bootstrapPage :: Page@@ -106,104 +73,123 @@ mempty mempty mempty- (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)+ 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 :: (Markup, [Attr]) -> Maybe ByteString -> (Markup, [Attr]) -> Markup cardify (h, hatts) t (b, batts) =- with div_ ([class__ "card"] <> hatts) $+ element "div" ([Attr "class" "card"] <> hatts) $ h- <> with- div_- ([class__ "card-body"] <> batts)- ( maybe mempty (with h5_ [class__ "card-title"] . toHtml) t- <> b+ <> element+ "div"+ ([Attr "class" "card-body"] <> batts)+ ( maybe mempty (elementc "h5" [Attr "class" "card-title"]) t <> b ) --- | wrap some html with a classed div-divClass_ :: Text -> Html () -> Html ()-divClass_ t = with div_ [class__ t]- -- | A Html object based on the bootstrap accordion card concept.-accordionCard :: Bool -> [Attribute] -> Text -> Text -> Text -> Text -> Html () -> Html ()+accordionCard :: Bool -> [Attr] -> ByteString -> ByteString -> ByteString -> ByteString -> Markup -> Markup accordionCard collapse atts idp idh idb t0 b =- with div_ ([class__ "card"] <> atts) $- with- div_- [class__ "card-header p-0", id_ idh]- ( with- h2_- [class__ "m-0"]- (with button_ [class__ ("btn btn-link" <> bool "" " collapsed" collapse), type_ "button", data_ "toggle" "collapse", data_ "target" ("#" <> idb), makeAttribute "aria-expanded" (bool "true" "false" collapse), makeAttribute "aria-controls" idb] (toHtml t0))- )- <> with- div_- [id_ idb, class__ ("collapse" <> bool " show" "" collapse), makeAttribute "aria-labelledby" idh, data_ "parent" ("#" <> idp)]- (with div_ [class__ "card-body"] b)+ element+ "div"+ ([Attr "class" "card"] <> atts)+ ( element+ "div"+ [Attr "class" "card-header p-0", Attr "id" idh]+ ( element+ "h2"+ [Attr "class" "m-0"]+ ( elementc+ "button"+ [ Attr "class" ("btn btn-link" <> bool "" " collapsed" collapse),+ Attr "type" "button",+ Attr "data-toggle" "collapse",+ Attr "data-target" ("#" <> idb),+ Attr "aria-expanded" (bool "true" "false" collapse),+ Attr "aria-controls" idb+ ]+ t0+ )+ <> element+ "div"+ [ Attr "id" "idb",+ Attr "class" ("collapse" <> bool " show" "" collapse),+ Attr "aria-labelledby" idh,+ Attr "data-parent" ("#" <> idp)+ ]+ (element "div" [Attr "class" "card-body"] b)+ )+ ) -- | A bootstrap accordion card attached to a checkbox.-accordionCardChecked :: Bool -> Text -> Text -> Text -> Text -> Html () -> Html () -> Html ()+accordionCardChecked :: Bool -> ByteString -> ByteString -> ByteString -> ByteString -> Markup -> Markup -> Markup accordionCardChecked collapse idp idh idb label bodyhtml checkhtml =- with div_ [class__ "card"] $- with- div_- [class__ "card-header p-0", id_ idh]- ( checkhtml- <> with- h2_- [class__ "m-0"]- (with button_ [class__ ("btn btn-link" <> bool "" " collapsed" collapse), type_ "button", data_ "toggle" "collapse", data_ "target" ("#" <> idb), makeAttribute "aria-expanded" (bool "true" "false" collapse), makeAttribute "aria-controls" idb] (toHtml label))- )- <> with- div_- [id_ idb, class__ ("collapse" <> bool " show" "" collapse), makeAttribute "aria-labelledby" idh, data_ "parent" ("#" <> idp)]- (with div_ [class__ "card-body"] bodyhtml)+ element+ "div"+ [Attr "class" "card"]+ ( element+ "div"+ [ Attr "class" "card-header p-0",+ Attr "id" idh+ ]+ ( checkhtml+ <> element+ "h2"+ [Attr "class" "m-0"]+ ( elementc+ "button"+ [ Attr "class" ("btn btn-link" <> bool "" " collapsed" collapse),+ Attr "type" "button",+ Attr "data-toggle" "collapse",+ Attr "data-target" ("#" <> idb),+ Attr "aria-expanded" (bool "true" "false" collapse),+ Attr "aria-controls" idb+ ]+ label+ )+ )+ <> element+ "div"+ [ Attr "id" "idb",+ Attr "class" ("collapse" <> bool " show" "" collapse),+ Attr "aria-labelledby" idh,+ Attr "data-parent" ("#" <> idp)+ ]+ (element "div" [Attr "class" "card-body"] bodyhtml)+ ) -- | create a bootstrapped accordian class accordion :: (MonadState Int m) =>- Text ->+ ByteString -> -- | name prefix. This is needed because an Int doesn't seem to be a valid name.- Maybe Text ->+ Maybe ByteString -> -- | card title- [(Text, Html ())] ->+ [(ByteString, Markup)] -> -- | title, html tuple for each item in the accordion.- m (Html ())+ m Markup accordion pre x hs = do idp' <- genNamePre pre- with div_ [class__ "accordion m-1", id_ idp'] <$> aCards idp'+ element "div" [Attr "class" "accordion m-1", Attr "id" idp'] <$> (mconcat <$> aCards idp') where- aCards par = mconcat <$> mapM (aCard par) hs+ aCards par = mapM (aCard par) hs aCard par (t, b) = do idh <- genNamePre pre idb <- genNamePre pre pure $ accordionCard (x /= Just t) [] par idh idb t b -- | create a bootstrapped accordian class-accordionChecked :: (MonadState Int m) => Text -> [(Text, Html (), Html ())] -> m (Html ())+accordionChecked :: (MonadState Int m) => ByteString -> [(ByteString, Markup, Markup)] -> m Markup accordionChecked pre hs = do idp' <- genNamePre pre- with div_ [class__ "accordion m-1", id_ idp'] <$> aCards idp'+ element "div" [Attr "class" "accordion m-1", Attr "id" idp'] <$> (mconcat <$> aCards idp') where- aCards par = mconcat <$> mapM (aCard par) hs+ aCards par = mapM (aCard par) hs aCard par (l, bodyhtml, checkhtml) = do idh <- genNamePre pre idb <- genNamePre pre pure $ accordionCardChecked True par idh idb l bodyhtml checkhtml -- | This version of accordion runs a local state for naming, and will cause name clashes if the prefix is not unique.-accordion_ :: Text -> Maybe Text -> [(Text, Html ())] -> Html ()+accordion_ :: ByteString -> Maybe ByteString -> [(ByteString, Markup)] -> Markup accordion_ pre x hs = runIdentity $ evalStateT (accordion pre x hs) 0
src/Web/Rep/Examples.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-} module Web.Rep.Examples ( page1,@@ -12,98 +13,105 @@ Shape (..), fromShape, toShape,- SumTypeExample (..),- repSumTypeExample,- SumType2Example (..),- repSumType2Example, listExample, listRepExample,- fiddleExample, ) where -import Clay qualified-import Data.Attoparsec.Text-import Data.Biapplicative-import Data.Bool-import Data.Text (Text, pack)+import Data.ByteString (ByteString)+import Data.String.Interpolate+import FlatParse.Basic (takeRest) import GHC.Generics-import Lucid-import Optics.Core-import Text.InterpolatedString.Perl6+import MarkupParse+import MarkupParse.FlatParse+import Optics.Core hiding (element) import Web.Rep -- | simple page example page1 :: Page page1 = #htmlBody .~ button1 $- #cssBody .~ RepCss css1 $+ #cssBody .~ css1 $ #jsGlobal .~ mempty $ #jsOnLoad .~ click $- #libsCss .~ (libCss <$> cssLibs) $- #libsJs .~ (libJs <$> jsLibs) $+ #libsCss .~ mconcat (libCss <$> cssLibs) $+ #libsJs .~ mconcat (libJs <$> jsLibs) $ mempty -- | page with localised libraries page2 :: Page page2 =- #libsCss .~ (libCss <$> cssLibsLocal) $- #libsJs .~ (libJs <$> jsLibsLocal) $+ #libsCss .~ mconcat (libCss <$> cssLibsLocal) $+ #libsJs .~ mconcat (libJs <$> jsLibsLocal) $ page1 cfg2 :: PageConfig cfg2 = #concerns .~ Separated $- #pageRender .~ Pretty $+ #renderStyle .~ Indented 4 $ #structure .~ Headless $ #localdirs .~ ["test/static"] $ #filenames .~ (("other/cfg2" <>) <$> suffixes) $ defaultPageConfig "" -cssLibs :: [Text]+cssLibs :: [ByteString] cssLibs = ["http://maxcdn.bootstrapcdn.com/font-awesome/4.3.0/css/font-awesome.min.css"] -cssLibsLocal :: [Text]+cssLibsLocal :: [ByteString] cssLibsLocal = ["css/font-awesome.min.css"] -jsLibs :: [Text]+jsLibs :: [ByteString] jsLibs = ["http://code.jquery.com/jquery-1.6.3.min.js"] -jsLibsLocal :: [Text]+jsLibsLocal :: [ByteString] jsLibsLocal = ["jquery-2.1.3.min.js"] css1 :: Css-css1 = do- Clay.fontSize (Clay.px 10)- Clay.fontFamily ["Arial", "Helvetica"] [Clay.sansSerif]- "#btnGo" Clay.? do- Clay.marginTop (Clay.px 20)- Clay.marginBottom (Clay.px 20)- "#btnGo.on" Clay.? Clay.color Clay.green+css1 =+ Css+ [i|+{+ font-size : 10px;+ font-family : "Arial","Helvetica", sans-serif;+} +\#btnGo+{+ margin-top : 20px;+ margin-bottom : 20px;+}++\#btnGo.on+{+ color : \#008000;+}+|]+ -- js-click :: RepJs+click :: Js click =- RepJsText- [q|-$('#btnGo').click( function() {- $('#btnGo').toggleClass('on');+ Js+ [i|+$('\#btnGo').click( function() {+ $('\#btnGo').toggleClass('on'); alert('bada bing!'); }); |] -button1 :: Html ()+button1 :: Markup button1 =- with- button_- [id_ "btnGo", Lucid.type_ "button"]- ("Go " <> with i_ [class__ "fa fa-play"] mempty)+ element+ "button"+ [ Attr "id" "btnGo",+ Attr "type" "button"+ ]+ (content "Go" <> element_ "i" [Attr "class" "fa fa-play"]) -- | One of each sharedrep input instances. data RepExamples = RepExamples- { repTextbox :: Text,- repTextarea :: Text,+ { repTextbox :: ByteString,+ repTextarea :: ByteString, repSliderI :: Int, repSlider :: Double, repSliderVI :: Int,@@ -113,7 +121,7 @@ repDropdown :: Int, repDropdownMultiple :: [Int], repShape :: Shape,- repColor :: Text+ repColor :: ByteString } deriving (Show, Eq, Generic) @@ -121,14 +129,14 @@ data Shape = SquareShape | CircleShape deriving (Eq, Show, Generic) -- | shape parser-toShape :: Text -> Shape+toShape :: ByteString -> Shape toShape t = case t of "Circle" -> CircleShape "Square" -> SquareShape _ -> CircleShape -- | shape printer-fromShape :: Shape -> Text+fromShape :: Shape -> ByteString fromShape CircleShape = "Circle" fromShape SquareShape = "Square" @@ -143,9 +151,9 @@ 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)+ dr <- dropdown (runParserEither int) (strToUtf8 . show) (Just "dropdown") (strToUtf8 . show <$> [1 .. 5 :: Int]) 3+ drm <- dropdownMultiple int (strToUtf8 . show) (Just "dropdown multiple") (strToUtf8 . show <$> [1 .. 5 :: Int]) [2, 4]+ drt <- toShape <$> dropdown (runParserEither takeRest) id (Just "shape") ["Circle", "Square"] (fromShape SquareShape) col <- colorPicker (Just "color") "#454e56" pure (RepExamples t ta n ds' nV dsV' c tog dr drm drt col) @@ -156,7 +164,7 @@ "al" Nothing (\l a -> sliderI (Just l) (0 :: Int) n 1 a)- ((\x -> "[" <> (pack . show) x <> "]") <$> [0 .. n] :: [Text])+ ((\x -> "[" <> (strToUtf8 . show) x <> "]") <$> [0 .. n] :: [ByteString]) [0 .. n] listRepExample :: (Monad m) => Int -> SharedRep m [Int]@@ -169,115 +177,3 @@ n 3 [0 .. 4]--fiddleExample :: Concerns Text-fiddleExample =- Concerns- mempty- mempty- [q|-<div class=" form-group-sm "><label for="1">fiddle example</label><input max="10.0" value="3.0" oninput="jsb.event({ 'element': this.id, 'value': this.value});" step="1.0" min="0.0" id="1" type="range" class=" custom-range form-control-range "></div>-|]--data SumTypeExample = SumInt Int | SumOnly | SumText Text deriving (Eq, Show, Generic)--sumTypeText :: SumTypeExample -> Text-sumTypeText (SumInt _) = "SumInt"-sumTypeText SumOnly = "SumOnly"-sumTypeText (SumText _) = "SumText"--repSumTypeExample :: (Monad m) => Int -> Text -> SumTypeExample -> SharedRep m SumTypeExample-repSumTypeExample defi deft defst =- bimap hmap mmap repst <<*>> repi <<*>> rept- where- repi = sliderI Nothing 0 20 1 defInt- rept = textbox Nothing defText- repst =- dropdownSum- takeText- id- (Just "SumTypeExample")- ["SumInt", "SumOnly", "SumText"]- (sumTypeText defst)- hmap repst' repi' rept' =- div_- ( repst'- <> with- repi'- [ class__ "subtype ",- data_ "sumtype" "SumInt",- style_- ( "display:"- <> bool "block" "none" (sumTypeText defst /= "SumInt")- )- ]- <> with- rept'- [ class__ "subtype ",- data_ "sumtype" "SumText",- style_- ("display:" <> bool "block" "none" (sumTypeText defst /= "SumText"))- ]- )- mmap repst' repi' rept' =- case repst' of- "SumInt" -> SumInt repi'- "SumOnly" -> SumOnly- "SumText" -> SumText rept'- _ -> SumOnly- defInt = case defst of- SumInt i -> i- _NotSumInt -> defi- defText = case defst of- SumText t -> t- _NotSumText -> deft--data SumType2Example = SumOutside Int | SumInside SumTypeExample deriving (Eq, Show, Generic)--sumType2Text :: SumType2Example -> Text-sumType2Text (SumOutside _) = "SumOutside"-sumType2Text (SumInside _) = "SumInside"--repSumType2Example :: (Monad m) => Int -> Text -> SumTypeExample -> SumType2Example -> SharedRep m SumType2Example-repSumType2Example defi deft defst defst2 =- bimap hmap mmap repst2 <<*>> repst <<*>> repoi- where- repoi = sliderI Nothing 0 20 1 defInt- repst = repSumTypeExample defi deft SumOnly- repst2 =- dropdownSum- takeText- id- (Just "SumType2Example")- ["SumOutside", "SumInside"]- (sumType2Text defst2)- hmap repst2' repst' repoi' =- div_- ( repst2'- <> with- repst'- [ class__ "subtype ",- data_ "sumtype" "SumInside",- style_- ( "display:"- <> bool "block" "none" (sumType2Text defst2 /= "SumInside")- )- ]- <> with- repoi'- [ class__ "subtype ",- data_ "sumtype" "SumOutside",- style_- ( "display:"- <> bool "block" "none" (sumType2Text defst2 /= "SumOutside")- )- ]- )- mmap repst2' repst' repoi' =- case repst2' of- "SumOutside" -> SumOutside repoi'- "SumInside" -> SumInside repst'- _WeirdSpelling -> SumOutside repoi'- defInt = case defst of- SumInt i -> i- _NotSumInt -> defi
src/Web/Rep/Html.hs view
@@ -1,79 +1,37 @@+{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-} -- | Key generators and miscellaneous html utilities.------ Uses the lucid 'Lucid.Html'. module Web.Rep.Html- ( class__,- toText,- libCss,+ ( libCss, libJs,- HtmlT,- Html, ) where -import Data.Bool-import Data.List (intersperse)-import Data.Text (Text, pack)-import Data.Text.Lazy qualified as Lazy-import Lucid+import Data.ByteString (ByteString)+import MarkupParse -- $setup+--+-- >>> import Web.Rep.Html+-- >>> import MarkupParse -- >>> :set -XOverloadedStrings --- | FIXME: A horrible hack to separate class id's-class__ :: Text -> Attribute-class__ t = class_ (" " <> t <> " ")---- | Convert html to text-toText :: Html a -> Text-toText = Lazy.toStrict . renderText- -- | Convert a link to a css library from text to html. ----- >>> libCss "https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/css/bootstrap.min.css"--- <link rel="stylesheet" href="https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/css/bootstrap.min.css">-libCss :: Text -> Html ()+-- >>> markdown_ Compact Html $ libCss "https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/css/bootstrap.min.css"+-- "<link rel=\"stylesheet\" href=\"https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/css/bootstrap.min.css\">"+libCss :: ByteString -> Markup libCss url =- link_- [ rel_ "stylesheet",- href_ url+ element_+ "link"+ [ Attr "rel" "stylesheet",+ Attr "href" url ] -- | Convert a link to a js library from text to html. ----- >>> libJs "https://code.jquery.com/jquery-3.3.1.slim.min.js"--- <script src="https://code.jquery.com/jquery-3.3.1.slim.min.js"></script>-libJs :: Text -> Html ()-libJs url = with (script_ mempty) [src_ url]---- | FIXME: `ToHtml a` is used throughout, mostly because `Show a` gives "\"text\"" for show "text", and hilarity ensues when rendering this to a web page, and I couldn't work out how to properly get around this.------ Hence, these orphans.-instance ToHtml Double where- toHtml = toHtml . (pack . show)-- toHtmlRaw = toHtmlRaw . (pack . show)--instance ToHtml Bool where- toHtml = toHtml . bool ("false" :: Text) "true"-- toHtmlRaw = toHtmlRaw . bool ("false" :: Text) "true"--instance ToHtml Int where- toHtml = toHtml . (pack . show)-- toHtmlRaw = toHtmlRaw . (pack . show)--instance ToHtml () where- toHtml = const "()"-- toHtmlRaw = const "()"---- I'm going to hell for sure.-instance {-# INCOHERENT #-} (ToHtml a) => ToHtml [a] where- toHtml = mconcat . Data.List.intersperse (toHtml ("," :: Text)) . fmap toHtml-- toHtmlRaw = mconcat . Data.List.intersperse (toHtmlRaw ("," :: Text)) . fmap toHtmlRaw+-- >>> markdown_ Compact Html $ libJs "https://code.jquery.com/jquery-3.3.1.slim.min.js"+-- "<script src=\"https://code.jquery.com/jquery-3.3.1.slim.min.js\"></script>"+libJs :: ByteString -> Markup+libJs url = element_ "script" [Attr "src" url]
src/Web/Rep/Html/Input.hs view
@@ -4,25 +4,25 @@ module Web.Rep.Html.Input ( Input (..), InputType (..),+ inputToHtml, ) where import Data.Bool+import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as C import Data.Maybe-import Data.Text (Text, pack, split) import GHC.Generics-import Lucid-import Lucid.Base-import Web.Rep.Html+import MarkupParse -- | something that might exist on a web page and be a front-end input to computations. data Input a = Input { -- | underlying value inputVal :: a, -- | label suggestion- inputLabel :: Maybe Text,+ inputLabel :: Maybe ByteString, -- | name//key//id of the Input- inputId :: Text,+ inputId :: ByteString, -- | type of html input inputType :: InputType }@@ -30,257 +30,264 @@ -- | Various types of web page inputs, encapsulating practical bootstrap class functionality data InputType- = Slider [Attribute]- | SliderV [Attribute]+ = Slider [Attr]+ | SliderV [Attr] | TextBox | TextBox' | TextArea Int | ColorPicker | ChooseFile- | Dropdown [Text]- | DropdownMultiple [Text] Char- | DropdownSum [Text]- | Datalist [Text] Text+ | Dropdown [ByteString]+ | DropdownMultiple [ByteString] Char+ | DropdownSum [ByteString]+ | Datalist [ByteString] ByteString | Checkbox Bool- | Toggle Bool (Maybe Text)+ | Toggle Bool (Maybe ByteString) | Button deriving (Eq, Show, Generic) -instance (ToHtml a) => ToHtml (Input a) where- toHtml (Input v l i (Slider 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)- ]- <> 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_- [class__ "form-group-sm"]- ( maybe mempty (with label_ [for_ i, class__ "mb-0"] . toHtml) l- <> input_- [ type_ "text",- class__ "form-control form-control-sm jsbClassEventInput",- id_ i,- value_ (pack $ show $ toHtmlRaw v)- ]- )- toHtml (Input v l i TextBox') =- with- div_- [class__ "form-group-sm"]- ( maybe mempty (with label_ [for_ i, class__ "mb-0"] . toHtml) l- <> input_- [ type_ "text",- class__ "form-control form-control-sm jsbClassEventFocusout",- id_ i,- value_ (pack $ show $ toHtmlRaw v)- ]- )- toHtml (Input v l i (TextArea rows)) =- with- div_- [class__ "form-group-sm"]- ( maybe mempty (with label_ [for_ i, class__ "mb-0"] . toHtml) l- <> with- textarea_- [ rows_ (pack $ show rows),- class__ "form-control form-control-sm jsbClassEventInput",- id_ i- ]- (toHtmlRaw v)- )- toHtml (Input v l i ColorPicker) =- with- div_- [class__ "form-group-sm"]- ( maybe mempty (with label_ [for_ i, class__ "mb-0"] . toHtml) l- <> input_- [ type_ "color",- class__ "form-control form-control-sm jsbClassEventInput",- id_ i,- value_ (pack $ show $ toHtml v)- ]- )- toHtml (Input _ l i ChooseFile) =- with- div_- [class__ "form-group-sm"]- (maybe mempty (with label_ [for_ i, class__ "mb-0"] . toHtml) l)- <> input_- [ type_ "file",- class__ "form-control-file form-control-sm jsbClassEventChooseFile",- id_ i+inputToHtml :: (Show a) => Input a -> Markup+inputToHtml (Input v l i (Slider satts)) =+ element+ "div"+ [Attr "class" "form-group-sm"]+ (maybe mempty (elementc "label" [Attr "for" i, Attr "class" "mb-0"]) l)+ <> element_+ "input"+ ( [ Attr "type" "range",+ Attr "class" " form-control-range form-control-sm custom-range jsbClassEventChange",+ Attr "id" i,+ Attr "value" (strToUtf8 $ show v) ]- toHtml (Input v l i (Dropdown opts)) =- with- div_- [class__ "form-group-sm"]- ( maybe mempty (with label_ [for_ i, class__ "mb-0"] . toHtml) l- <> with- select_- [ class__ "form-control form-control-sm jsbClassEventInput",- id_ i- ]- opts'+ <> satts )- where- opts' =- mconcat $- ( \o ->- with- option_- ( bool- []- [selected_ "selected"]- (toText (toHtml o) == toText (toHtml v))- )- (toHtml o)- )- <$> opts- toHtml (Input vs l i (DropdownMultiple opts sep)) =- with- div_- [class__ "form-group-sm"]- ( maybe mempty (with label_ [for_ i, class__ "mb-0"] . toHtml) l- <> with- select_- [ class__ "form-control form-control-sm jsbClassEventChangeMultiple",- multiple_ "multiple",- id_ i+inputToHtml (Input v l i (SliderV satts)) =+ element+ "div"+ [Attr "class" "form-group-sm"]+ ( maybe mempty (elementc "label" [Attr "for" i, Attr "class" "mb-0"]) l+ <> element_+ "input"+ ( [ Attr "type" "range",+ Attr "class" " form-control-range form-control-sm custom-range jsbClassEventChange",+ Attr "id" i,+ Attr "value" (strToUtf8 $ show v),+ Attr "oninput" ("$('#sliderv" <> i <> "').html($(this).val())") ]- opts'- )- where- opts' =- mconcat $- ( \o ->- with- option_- ( bool- []- [selected_ "selected"]- (any (\v -> toText (toHtml o) == toText (toHtml v)) (Data.Text.split (== sep) (toText (toHtml vs))))- )- (toHtml o)+ <> satts )- <$> opts- toHtml (Input v l i (DropdownSum opts)) =- with- div_- [class__ "form-group-sm sumtype-group"]- ( maybe mempty (with label_ [for_ i, class__ "mb-0"] . toHtml) l- <> with- select_- [ class__ "form-control form-control-sm jsbClassEventInput jsbClassEventShowSum",- id_ i- ]- opts'+ )+ <> elementc "span" [Attr "id" ("sliderv" <> i)] (strToUtf8 $ show v)+inputToHtml (Input v l i TextBox) =+ element+ "div"+ [Attr "class" "form-group-sm"]+ ( maybe mempty (elementc "label" [Attr "for" i, Attr "class" "mb-0"]) l+ <> element_+ "input"+ [ Attr "type" "text",+ Attr "class" "form-control form-control-sm jsbClassEventInput",+ Attr "id" i,+ Attr "value" (strToUtf8 $ show v)+ ]+ )+inputToHtml (Input v l i TextBox') =+ element+ "div"+ [Attr "class" "form-group-sm"]+ ( maybe mempty (elementc "label" [Attr "for" i, Attr "class" "mb-0"]) l+ <> element_+ "input"+ [ Attr "type" "text",+ Attr "class" "form-control form-control-sm jsbClassEventFocusout",+ Attr "id" i,+ Attr "value" (strToUtf8 $ show v)+ ]+ )+inputToHtml (Input v l i (TextArea rows)) =+ element+ "div"+ [Attr "class" "form-group-sm"]+ ( maybe mempty (elementc "label" [Attr "for" i, Attr "class" "mb-0"]) l+ <> elementc+ "textarea"+ [ Attr "rows" (strToUtf8 $ show rows),+ Attr "class" "form-control form-control-sm jsbClassEventInput",+ Attr "id" i+ ]+ (strToUtf8 $ show v)+ )+inputToHtml (Input v l i ColorPicker) =+ element+ "div"+ [Attr "class" "form-group-sm"]+ ( maybe mempty (elementc "label" [Attr "for" i, Attr "class" "mb-0"]) l+ <> element_+ "input"+ [ Attr "type" "color",+ Attr "class" "form-control form-control-sm jsbClassEventInput",+ Attr "id" i,+ Attr "value" (strToUtf8 $ show v)+ ]+ )+inputToHtml (Input _ l i ChooseFile) =+ element+ "div"+ [Attr "class" "form-group-sm"]+ ( maybe mempty (elementc "label" [Attr "for" i, Attr "class" "mb-0"]) l+ <> element_+ "input"+ [ Attr "type" "file",+ Attr "class" "form-control-file form-control-sm jsbClassEventChooseFile",+ Attr "id" i+ ]+ )+inputToHtml (Input v l i (Dropdown opts)) =+ element+ "div"+ [Attr "class" "form-group-sm"]+ ( maybe mempty (elementc "label" [Attr "for" i, Attr "class" "mb-0"]) l+ <> element+ "select"+ [ Attr "class" "form-control form-control-sm jsbClassEventInput",+ Attr "id" i+ ]+ (mconcat opts')+ )+ where+ opts' =+ ( \o ->+ elementc+ "option"+ ( bool+ []+ [Attr "selected" "selected"]+ (o == strToUtf8 (show v))+ )+ o )- where- opts' =- mconcat $- ( \o ->- with- option_- (bool [] [selected_ "selected"] (toText (toHtml o) == toText (toHtml v)))- (toHtml o)- )- <$> opts- toHtml (Input v l i (Datalist opts listId)) =- with- div_- [class__ "form-group-sm"]- ( maybe mempty (with label_ [for_ i, class__ "mb-0"] . toHtml) l- <> input_- [ type_ "text",- class__ "form-control form-control-sm jsbClassEventInput",- id_ i,- list_ listId- -- the datalist concept in html assumes initial state is a null- -- and doesn't present the list if it has a value alreadyx- -- , value_ (show $ toHtml v)- ]- <> with- datalist_- [id_ listId]- ( mconcat $- ( \o ->- with- option_+ <$> opts+inputToHtml (Input vs l i (DropdownMultiple opts sep)) =+ element+ "div"+ [Attr "class" "form-group-sm"]+ ( maybe mempty (elementc "label" [Attr "for" i, Attr "class" "mb-0"]) l+ <> element+ "select"+ [ Attr "class" "form-control form-control-sm jsbClassEventChangeMultiple",+ Attr "multiple" "multiple",+ Attr "id" i+ ]+ (mconcat opts')+ )+ where+ opts' =+ ( \o ->+ elementc+ "option"+ ( bool+ []+ [Attr "selected" "selected"]+ (any (\v -> o == strToUtf8 (show v)) (C.split sep (strToUtf8 $ show vs)))+ )+ o+ )+ <$> opts+inputToHtml (Input v l i (DropdownSum opts)) =+ element+ "div"+ [Attr "class" "form-group-sm sumtype-group"]+ ( maybe mempty (elementc "label" [Attr "for" i, Attr "class" "mb-0"]) l+ <> element+ "select"+ [ Attr "class" "form-control form-control-sm jsbClassEventInput jsbClassEventShowSum",+ Attr "id" i+ ]+ (mconcat opts')+ )+ where+ opts' =+ ( \o ->+ elementc+ "option"+ (bool [] [Attr "selected" "selected"] (o == strToUtf8 (show v)))+ o+ )+ <$> opts+inputToHtml (Input v l i (Datalist opts listId)) =+ element+ "div"+ [Attr "class" "form-group-sm"]+ ( maybe mempty (elementc "label" [Attr "for" i, Attr "class" "mb-0"]) l+ <> element_+ "input"+ [ Attr "type" "text",+ Attr "class" "form-control form-control-sm jsbClassEventInput",+ Attr "id" i,+ Attr "list" listId+ -- the datalist concept in html assumes initial state is a null+ -- and doesn't present the list if it has a value alreadyx+ -- , value_ (show $ toHtml v)+ ]+ <> element+ "datalist"+ [Attr "id" listId]+ ( mconcat+ ( ( \o ->+ elementc+ "option" ( bool []- [selected_ "selected"]- (toText (toHtml o) == toText (toHtml v))+ [Attr "selected" "selected"]+ (o == strToUtf8 (show v)) )- (toHtml o)+ o ) <$> opts- )- )- toHtml (Input _ l i (Checkbox checked)) =- with- div_- [class__ "form-check form-check-sm"]- ( input_- ( [ type_ "checkbox",- class__ "form-check-input jsbClassEventCheckbox",- id_ i- ]- <> bool [] [checked_] checked+ ) )- <> maybe mempty (with label_ [for_ i, class__ "form-check-label mb-0"] . toHtml) l- )- toHtml (Input _ l i (Toggle pushed lab)) =- with- div_- [class__ "form-group-sm"]- ( maybe mempty (with label_ [for_ i, class__ "mb-0"] . toHtml) l- <> input_- ( [ type_ "button",- class__ "btn btn-primary btn-sm jsbClassEventToggle",- data_ "bs-toggle" "button",- id_ i,- makeAttribute "aria-pressed" (bool "false" "true" pushed)- ]- <> maybe [] (\l' -> [value_ l']) lab- <> bool [] [checked_] pushed- )- )- toHtml (Input _ l i Button) =- with- div_- [class__ "form-group-sm"]- ( input_- [ type_ "button",- id_ i,- class__ "btn btn-primary btn-sm jsbClassEventButton",- value_ (fromMaybe "button" l)+ )+inputToHtml (Input _ l i (Checkbox checked)) =+ element+ "div"+ [Attr "class" "form-check form-check-sm"]+ ( element+ "input"+ ( [ Attr "type" "checkbox",+ Attr "class" "form-check-input jsbClassEventCheckbox",+ Attr "id" i ]- )-- toHtmlRaw = toHtml+ <> bool [] [Attr "checked" ""] checked+ )+ ( maybe mempty (elementc "label" [Attr "for" i, Attr "class" "form-label-check mb-0"]) l+ )+ )+inputToHtml (Input _ l i (Toggle pushed lab)) =+ element+ "div"+ [Attr "class" "form-group-sm"]+ ( maybe mempty (elementc "label" [Attr "for" i, Attr "class" "mb-0"]) l+ <> element_+ "input"+ ( [ Attr "type" "button",+ Attr "class" "btn btn-primary btn-sm jsbClassEventToggle",+ Attr "data-bs-toggle" "button",+ Attr "id" i,+ Attr "aria-pressed" (bool "false" "true" pushed)+ ]+ <> maybe [] (\l' -> [Attr "value" l']) lab+ <> bool [] [Attr "checked" ""] pushed+ )+ )+inputToHtml (Input _ l i Button) =+ element+ "div"+ [Attr "class" "form-group-sm"]+ ( element_+ "input"+ [ Attr "type" "button",+ Attr "id" i,+ Attr "class" "btn btn-primary btn-sm jsbClassEventButton",+ Attr "value" (fromMaybe "button" l)+ ]+ )
src/Web/Rep/Page.hs view
@@ -13,52 +13,40 @@ concernNames, PageConcerns (..), PageStructure (..),- PageRender (..), -- $css- Css,- RepCss (..),+ Css (..), renderCss,- renderRepCss, -- $js- JS (..),- RepJs (..),+ Js (..), onLoad,- renderRepJs,- parseJs,- renderJs, ) where -import Clay (Css)-import Clay qualified-import Data.Text (Text, unpack)-import Data.Text.Lazy (toStrict)+import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as C+import Data.String.Interpolate import GHC.Generics-import Language.JavaScript.Parser-import Language.JavaScript.Parser.AST-import Language.JavaScript.Process.Minify-import Lucid+import MarkupParse import Optics.Core-import Text.InterpolatedString.Perl6 -- | Components of a web page. -- -- A web page can take many forms but still have the same underlying representation. For example, CSS can be linked to in a separate file, or can be inline within html, but still be the same css and have the same expected external effect. A Page represents the practical components of what makes up a static snapshot of a web page. data Page = Page { -- | css library links- libsCss :: [Html ()],+ libsCss :: Markup, -- | javascript library links- libsJs :: [Html ()],+ libsJs :: Markup, -- | css- cssBody :: RepCss,+ cssBody :: Css, -- | javascript with global scope- jsGlobal :: RepJs,+ jsGlobal :: Js, -- | javascript included within the onLoad function- jsOnLoad :: RepJs,+ jsOnLoad :: Js, -- | html within the header- htmlHeader :: Html (),+ htmlHeader :: Markup, -- | body html- htmlBody :: Html ()+ htmlBody :: Markup } deriving (Show, Generic) @@ -74,7 +62,7 @@ (p0 ^. #htmlBody <> p1 ^. #htmlBody) instance Monoid Page where- mempty = Page [] [] mempty mempty mempty mempty mempty+ mempty = Page mempty mempty mempty mempty mempty mempty mempty mappend = (<>) @@ -116,21 +104,13 @@ = HeaderBody | Headless | Snippet- | Svg deriving (Show, Eq, Generic) --- | Post-processing of page concerns-data PageRender- = Pretty- | Minified- | NoPost- deriving (Show, Eq, Generic)- -- | Configuration options when rendering a 'Page'. data PageConfig = PageConfig { concerns :: PageConcerns, structure :: PageStructure,- pageRender :: PageRender,+ renderStyle :: RenderStyle, filenames :: Concerns FilePath, localdirs :: [FilePath] }@@ -142,125 +122,20 @@ PageConfig Inline HeaderBody- Minified+ Compact ((stem <>) <$> suffixes) [] --- | Unifies css as either a 'Clay.Css' or as Text.-data RepCss = RepCss Clay.Css | RepCssText Text deriving (Generic)--instance Show RepCss where- show (RepCss css) = unpack . renderCss $ css- show (RepCssText txt) = unpack txt--instance Semigroup RepCss where- (<>) (RepCss css) (RepCss css') = RepCss (css <> css')- (<>) (RepCssText css) (RepCssText css') = RepCssText (css <> css')- (<>) (RepCss css) (RepCssText css') =- RepCssText (renderCss css <> css')- (<>) (RepCssText css) (RepCss css') =- RepCssText (css <> renderCss css')--instance Monoid RepCss where- mempty = RepCssText mempty-- mappend = (<>)---- | Render 'RepCss' as text.-renderRepCss :: PageRender -> RepCss -> Text-renderRepCss Minified (RepCss css) = toStrict $ Clay.renderWith Clay.compact [] css-renderRepCss _ (RepCss css) = toStrict $ Clay.render css-renderRepCss _ (RepCssText css) = css+-- | css as a string.+newtype Css = Css {cssByteString :: ByteString} deriving (Show, Eq, Generic, Semigroup, Monoid) -- | Render 'Css' as text.-renderCss :: Css -> Text-renderCss = toStrict . Clay.render---- | wrapper for `JSAST`-newtype JS = JS {unJS :: JSAST} deriving (Show, Eq, Generic)--instance Semigroup JS where- (<>) (JS (JSAstProgram ss ann)) (JS (JSAstProgram ss' _)) =- JS $ JSAstProgram (ss <> ss') ann- (<>) (JS (JSAstProgram ss ann)) (JS (JSAstStatement s _)) =- JS $ JSAstProgram (ss <> [s]) ann- (<>) (JS (JSAstProgram ss ann)) (JS (JSAstExpression e ann')) =- JS $ JSAstProgram (ss <> [JSExpressionStatement e (JSSemi ann')]) ann- (<>) (JS (JSAstProgram ss ann)) (JS (JSAstLiteral e ann')) =- JS $ JSAstProgram (ss <> [JSExpressionStatement e (JSSemi ann')]) ann- (<>) (JS (JSAstStatement s ann)) (JS (JSAstProgram ss _)) =- JS $ JSAstProgram (s : ss) ann- (<>) (JS (JSAstStatement s ann)) (JS (JSAstStatement s' _)) =- JS $ JSAstProgram [s, s'] ann- (<>) (JS (JSAstStatement s ann)) (JS (JSAstExpression e ann')) =- JS $ JSAstProgram [s, JSExpressionStatement e (JSSemi ann')] ann- (<>) (JS (JSAstStatement s ann)) (JS (JSAstLiteral e ann')) =- JS $ JSAstProgram [s, JSExpressionStatement e (JSSemi ann')] ann- (<>) (JS (JSAstExpression e ann)) (JS (JSAstProgram ss _)) =- JS $ JSAstProgram (JSExpressionStatement e (JSSemi ann) : ss) ann- (<>) (JS (JSAstExpression e ann)) (JS (JSAstStatement s' _)) =- JS $ JSAstProgram [JSExpressionStatement e (JSSemi ann), s'] ann- (<>) (JS (JSAstExpression e ann)) (JS (JSAstExpression e' ann')) =- JS $ JSAstProgram [JSExpressionStatement e (JSSemi ann), JSExpressionStatement e' (JSSemi ann')] ann- (<>) (JS (JSAstExpression e ann)) (JS (JSAstLiteral e' ann')) =- JS $ JSAstProgram [JSExpressionStatement e (JSSemi ann), JSExpressionStatement e' (JSSemi ann')] ann- (<>) (JS (JSAstLiteral e ann)) (JS (JSAstProgram ss _)) =- JS $ JSAstProgram (JSExpressionStatement e (JSSemi ann) : ss) ann- (<>) (JS (JSAstLiteral e ann)) (JS (JSAstStatement s' _)) =- JS $ JSAstProgram [JSExpressionStatement e (JSSemi ann), s'] ann- (<>) (JS (JSAstLiteral e ann)) (JS (JSAstExpression e' ann')) =- JS $ JSAstProgram [JSExpressionStatement e (JSSemi ann), JSExpressionStatement e' (JSSemi ann')] ann- (<>) (JS (JSAstLiteral e ann)) (JS (JSAstLiteral e' ann')) =- JS $ JSAstProgram [JSExpressionStatement e (JSSemi ann), JSExpressionStatement e' (JSSemi ann')] ann--instance Monoid JS where- mempty = JS $ JSAstProgram [] (JSAnnot (TokenPn 0 0 0) [])-- mappend = (<>)---- | Unifies javascript as 'JSStatement' and script as 'Text'.-data RepJs = RepJs JS | RepJsText Text deriving (Eq, Show, Generic)--instance Semigroup RepJs where- (<>) (RepJs js) (RepJs js') = RepJs (js <> js')- (<>) (RepJsText js) (RepJsText js') = RepJsText (js <> js')- (<>) (RepJs js) (RepJsText js') =- RepJsText (toStrict (renderToText $ unJS js) <> js')- (<>) (RepJsText js) (RepJs js') =- RepJsText (js <> toStrict (renderToText $ unJS js'))--instance Monoid RepJs where- mempty = RepJs mempty-- mappend = (<>)---- | Wrap js in standard DOM window loader.-onLoad :: RepJs -> RepJs-onLoad (RepJs js) = RepJs $ onLoadStatements [toStatement js]-onLoad (RepJsText js) = RepJsText $ onLoadText js--toStatement :: JS -> JSStatement-toStatement (JS (JSAstProgram ss ann)) = JSStatementBlock JSNoAnnot ss JSNoAnnot (JSSemi ann)-toStatement (JS (JSAstStatement s _)) = s-toStatement (JS (JSAstExpression e ann')) = JSExpressionStatement e (JSSemi ann')-toStatement (JS (JSAstLiteral e ann')) = JSExpressionStatement e (JSSemi ann')--onLoadStatements :: [JSStatement] -> JS-onLoadStatements js = JS $ JSAstProgram [JSAssignStatement (JSMemberDot (JSIdentifier JSNoAnnot "window") JSNoAnnot (JSIdentifier JSNoAnnot "onload")) (JSAssign JSNoAnnot) (JSFunctionExpression JSNoAnnot JSIdentNone JSNoAnnot JSLNil JSNoAnnot (JSBlock JSNoAnnot js JSNoAnnot)) JSSemiAuto] JSNoAnnot--onLoadText :: Text -> Text-onLoadText t = [qc| window.onload=function()\{{t}};|]---- | Convert 'Text' to 'JS', throwing an error on incorrectness.-parseJs :: Text -> JS-parseJs = JS . readJs . unpack+renderCss :: RenderStyle -> Css -> ByteString+renderCss Compact = C.filter (\c -> c /= ' ' && c /= '\n') . cssByteString+renderCss _ = cssByteString --- | Render 'JS' as 'Text'.-renderJs :: JS -> Text-renderJs = toStrict . renderToText . unJS+-- | Javascript as string+newtype Js = Js {jsByteString :: ByteString} deriving (Eq, Show, Generic, Semigroup, Monoid) --- | Render 'RepJs' as 'Text'.-renderRepJs :: PageRender -> RepJs -> Text-renderRepJs _ (RepJsText js) = js-renderRepJs Minified (RepJs js) = toStrict . renderToText . minifyJS . unJS $ js-renderRepJs Pretty (RepJs js) = toStrict . renderToText . unJS $ js+onLoad :: Js -> Js+onLoad (Js t) = Js [i| window.onload=function(){#{t}};|]
src/Web/Rep/Render.hs view
@@ -6,7 +6,7 @@ ( renderPage, renderPageWith, renderPageHtmlWith,- renderPageAsText,+ renderPageAsByteString, renderPageToFile, renderPageHtmlToFile, )@@ -14,25 +14,26 @@ import Control.Applicative import Control.Monad+import Data.ByteString (ByteString)+import Data.ByteString qualified as B import Data.Foldable-import Data.Text (Text, pack, unpack)-import Lucid-import Optics.Core+import MarkupParse+import Optics.Core hiding (element) import Web.Rep.Html import Web.Rep.Page -- | Render a Page with the default configuration into Html.-renderPage :: Page -> Html ()+renderPage :: Page -> Markup renderPage p = (\(_, _, x) -> x) $ renderPageWith (defaultPageConfig "default") p -- | Render a Page into Html.-renderPageHtmlWith :: PageConfig -> Page -> Html ()+renderPageHtmlWith :: PageConfig -> Page -> Markup renderPageHtmlWith pc p = (\(_, _, x) -> x) $ renderPageWith pc p -- | Render a Page into css text, js text and html.-renderPageWith :: PageConfig -> Page -> (Text, Text, Html ())+renderPageWith :: PageConfig -> Page -> (ByteString, ByteString, Markup) renderPageWith pc p = case pc ^. #concerns of Inline -> (mempty, mempty, h)@@ -41,105 +42,83 @@ h = case pc ^. #structure of HeaderBody ->- doctype_- <> with- html_- [lang_ "en"]- ( head_- ( mconcat- [ meta_ [charset_ "utf-8"],- cssInline,- mconcat libsCss',- p ^. #htmlHeader- ]- )- <> body_- ( mconcat- [ p ^. #htmlBody,- mconcat libsJs',- jsInline- ]- )+ doctypeHtml+ <> element+ "html"+ [Attr "lang" "en"]+ ( element+ "head"+ []+ (element_ "meta" [Attr "charset" "utf-8"])+ <> cssInline+ <> libsCss'+ <> view #htmlHeader p )+ <> element+ "body"+ []+ ( view #htmlBody p+ <> libsJs'+ <> jsInline+ ) Headless ->- mconcat- [ doctype_,- meta_ [charset_ "utf-8"],- mconcat libsCss',- cssInline,- p ^. #htmlHeader,- p ^. #htmlBody,- mconcat libsJs',- jsInline- ]+ doctypeHtml+ <> element_ "meta" [Attr "charset" "utf-8"]+ <> libsCss'+ <> cssInline+ <> view #htmlHeader p+ <> p ^. #htmlBody+ <> libsJs'+ <> jsInline Snippet ->- mconcat- [ mconcat libsCss',- cssInline,- p ^. #htmlHeader,- p ^. #htmlBody,- mconcat libsJs',- jsInline- ]- Svg ->- svgDocType- <> svg_- ( svgDefs $- mconcat- [ mconcat libsCss',- cssInline,- p ^. #htmlBody,- mconcat libsJs',- jsInline- ]- )- css = rendercss (p ^. #cssBody)- js = renderjs (p ^. #jsGlobal <> onLoad (p ^. #jsOnLoad))- renderjs = renderRepJs $ pc ^. #pageRender- rendercss = renderRepCss $ pc ^. #pageRender+ libsCss'+ <> cssInline+ <> view #htmlHeader p+ <> view #htmlBody p+ <> libsJs'+ <> jsInline++ css :: ByteString+ css = renderCss (view #renderStyle pc) (p ^. #cssBody)++ js :: ByteString+ js = jsByteString (p ^. #jsGlobal <> onLoad (p ^. #jsOnLoad)) cssInline | pc ^. #concerns == Separated || css == mempty = mempty- | otherwise = style_ [type_ "text/css"] css+ | otherwise = elementc "style" [Attr "type" "text/css"] css jsInline | pc ^. #concerns == Separated || js == mempty = mempty- | otherwise = script_ mempty js+ | otherwise = elementc "script" [] js libsCss' = case pc ^. #concerns of- Inline -> p ^. #libsCss+ Inline -> view #libsCss p Separated ->- p ^. #libsCss- <> [libCss (pack $ pc ^. #filenames % #cssConcern)]+ view #libsCss p+ <> libCss (strToUtf8 $ pc ^. #filenames % #cssConcern) libsJs' = case pc ^. #concerns of Inline -> p ^. #libsJs Separated ->- p ^. #libsJs- <> [libJs (pack $ pc ^. #filenames % #jsConcern)]+ view #libsJs p+ <> libJs (strToUtf8 $ pc ^. #filenames % #jsConcern) -- | Render Page concerns to files. renderPageToFile :: FilePath -> PageConfig -> Page -> IO () renderPageToFile dir pc page =- sequenceA_ $ liftA2 writeFile' (pc ^. #filenames) (fmap unpack (renderPageAsText pc page))+ sequenceA_ $ liftA2 writeFile' (pc ^. #filenames) (renderPageAsByteString pc page) where- writeFile' fp s = unless (s == mempty) (writeFile (dir <> "/" <> fp) s)+ writeFile' fp s = unless (s == mempty) (B.writeFile (dir <> "/" <> fp) s) -- | Render a page to just a Html file. renderPageHtmlToFile :: FilePath -> PageConfig -> Page -> IO () renderPageHtmlToFile file pc page =- writeFile file (unpack $ toText $ renderPageHtmlWith pc page)+ B.writeFile file (markdown_ (view #renderStyle pc) Html $ renderPageHtmlWith pc page) -- | Render a Page as Text.-renderPageAsText :: PageConfig -> Page -> Concerns Text-renderPageAsText pc p =+renderPageAsByteString :: PageConfig -> Page -> Concerns ByteString+renderPageAsByteString pc p = case pc ^. #concerns of- Inline -> Concerns mempty mempty htmlt- Separated -> Concerns css js htmlt+ Inline -> Concerns mempty mempty (markdown_ (view #renderStyle pc) Html h)+ Separated -> Concerns css js (markdown_ (view #renderStyle pc) Html h) where- htmlt = toText h (css, js, h) = renderPageWith pc p--svgDocType :: Html ()-svgDocType = "?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<!DOCTYPE svg PUBLIC \"-//W3C//DTD SVG 1.1//EN\"\n \"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd\""--svgDefs :: Html () -> Html ()-svgDefs = term "defs"
src/Web/Rep/Server.hs view
@@ -8,8 +8,9 @@ import Control.Monad import Control.Monad.Trans.Class-import Data.Text (unpack)-import Lucid+import Data.ByteString qualified as B+import Data.Text.Lazy (pack)+import MarkupParse import Network.Wai.Middleware.Static (addBase, noDots, only, staticPolicy) import Optics.Core hiding (only) import Web.Rep.Page@@ -23,7 +24,7 @@ where getpage = case pc ^. #concerns of Inline ->- get rp (html $ renderText $ renderPageHtmlWith pc p)+ get rp (html $ pack $ utf8ToStr $ markdown_ Compact Html $ renderPageHtmlWith pc p) Separated -> let (css, js, h) = renderPageWith pc p in do@@ -31,11 +32,11 @@ get rp ( do- lift $ writeFile' cssfp (unpack css)- lift $ writeFile' jsfp (unpack js)- html $ renderText h+ lift $ writeFile' cssfp css+ lift $ writeFile' jsfp js+ html $ pack $ utf8ToStr $ markdown_ Compact Html h ) cssfp = pc ^. #filenames % #cssConcern jsfp = pc ^. #filenames % #jsConcern- writeFile' fp s = unless (s == mempty) (writeFile fp s)+ writeFile' fp s = unless (s == mempty) (B.writeFile fp s) servedir = (\x -> middleware $ staticPolicy (noDots <> addBase x)) <$> pc ^. #localdirs
@@ -19,10 +19,10 @@ import Control.Monad import Control.Monad.State.Lazy import Data.Biapplicative+import Data.ByteString (ByteString) import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HashMap-import Data.Text (Text, pack)-import Lucid+import MarkupParse import Optics.Core import Optics.Zoom @@ -32,12 +32,12 @@ -- RepF consists of an underlying value being represented, and, given a hashmap state, a way to produce a representation of the underlying value (or error), in another domain, together with the potential to alter the hashmap state. data RepF r a = Rep { rep :: r,- make :: HashMap Text Text -> (HashMap Text Text, Either Text a)+ make :: HashMap ByteString ByteString -> (HashMap ByteString ByteString, Either ByteString a) } deriving (Functor) -- | the common usage, where the representation domain is Html-type Rep a = RepF (Html ()) a+type Rep a = RepF Markup a instance (Semigroup r) => Semigroup (RepF r a) where (Rep r0 a0) <> (Rep r1 a1) =@@ -46,6 +46,7 @@ (\hm -> let (hm', x') = a0 hm in let (hm'', x'') = a1 hm' in (hm'', x' <> x'')) instance (Monoid a, Monoid r) => Monoid (RepF r a) where+ mempty :: RepF r a mempty = Rep mempty (,Right mempty) mappend = (<>)@@ -75,7 +76,7 @@ -- | stateful result of one step, given a 'Rep', and a monadic action. -- Useful for testing and for initialising a page.-oneRep :: (Monad m) => Rep a -> (Rep a -> HashMap Text Text -> m ()) -> StateT (HashMap Text Text) m (HashMap Text Text, Either Text a)+oneRep :: (Monad m) => Rep a -> (Rep a -> HashMap ByteString ByteString -> m ()) -> StateT (HashMap ByteString ByteString) m (HashMap ByteString ByteString, Either ByteString a) oneRep r@(Rep _ fa) action = do m <- get let (m', a) = fa m@@ -90,12 +91,12 @@ -- -- unshare should only be run once, which is a terrible flaw that might be fixed by linear types. newtype SharedRepF m r a = SharedRep- { unshare :: StateT (Int, HashMap Text Text) m (RepF r a)+ { unshare :: StateT (Int, HashMap ByteString ByteString) m (RepF r a) } deriving (Functor) -- | default representation type of 'Html' ()-type SharedRep m a = SharedRepF m (Html ()) a+type SharedRep m a = SharedRepF m Markup a instance (Functor m) => Bifunctor (SharedRepF m) where bimap f g (SharedRep s) = SharedRep $ fmap (bimap f g) s@@ -111,24 +112,24 @@ SharedRep f <*> SharedRep a = SharedRep $ liftA2 (<*>) f a -- | name supply for elements of a 'SharedRep'-genName :: (MonadState Int m) => m Text+genName :: (MonadState Int m) => m ByteString genName = do modify (+ 1)- pack . show <$> get+ strToUtf8 . show <$> get -- | sometimes a number doesn't work properly in html (or js???), and an alpha prefix seems to help-genNamePre :: (MonadState Int m) => Text -> m Text+genNamePre :: (MonadState Int m) => ByteString -> m ByteString genNamePre p = (p <>) <$> genName -- | Create a sharedRep register :: (Monad m) => -- | Parser- (Text -> Either Text a) ->+ (ByteString -> Either ByteString a) -> -- | Printer- (a -> Text) ->+ (a -> ByteString) -> -- | create initial object from name and initial value- (Text -> a -> r) ->+ (ByteString -> a -> r) -> -- | initial value a -> SharedRepF m r a@@ -153,9 +154,9 @@ message :: (Monad m) => -- | Parser- (Text -> Either Text a) ->+ (ByteString -> Either ByteString a) -> -- | create initial object from name and initial value- (Text -> a -> r) ->+ (ByteString -> a -> r) -> -- | initial value a -> -- | default value@@ -163,25 +164,25 @@ SharedRepF m r a message p f a d = SharedRep $ do- name <- zoom _1 genName+ n <- zoom _1 genName pure $ Rep- (f name a)+ (f n a) ( \s ->- ( HashMap.delete name s,+ ( HashMap.delete n s, join $- maybe (Right $ Right d) (Right . p) (HashMap.lookup name s)+ maybe (Right $ Right d) (Right . p) (HashMap.lookup n s) ) ) -runSharedRep :: SharedRepF m r a -> m (RepF r a, (Int, HashMap Text Text))+runSharedRep :: SharedRepF m r a -> m (RepF r a, (Int, HashMap ByteString ByteString)) runSharedRep s = flip runStateT (0, HashMap.empty) $ unshare s -- | compute the initial state of a SharedRep (testing) zeroState :: (Monad m) => SharedRep m a ->- m (Html (), (HashMap Text Text, Either Text a))+ m (Markup, (HashMap ByteString ByteString, Either ByteString a)) zeroState sr = do (Rep h fa, (_, m)) <- runSharedRep sr pure (h, fa m)@@ -190,8 +191,8 @@ runOnce :: (Monad m) => SharedRep m a ->- (Html () -> HashMap Text Text -> m ()) ->- m (HashMap Text Text, Either Text a)+ (Markup -> HashMap ByteString ByteString -> m ()) ->+ m (HashMap ByteString ByteString, Either ByteString a) runOnce sr action = do (Rep h fa, (_, m)) <- runSharedRep sr action h m
@@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-} -- | Various SharedRep instances for common html input elements. module Web.Rep.SharedReps@@ -24,8 +25,6 @@ button, chooseFile, maybeRep,- fiddle,- viaFiddle, accordionList, listMaybeRep, listRep,@@ -41,21 +40,20 @@ import Box.Codensity () import Control.Monad import Control.Monad.State.Lazy-import Data.Attoparsec.Text hiding (take)-import Data.Attoparsec.Text qualified as A import Data.Biapplicative import Data.Bool+import Data.ByteString (ByteString, intercalate) import Data.HashMap.Strict qualified as HashMap import Data.List qualified as List-import Data.Text (Text, intercalate, pack, unpack)-import Lucid-import Optics.Core+import Data.Maybe+import Data.String.Interpolate+import FlatParse.Basic hiding (take)+import MarkupParse+import MarkupParse.FlatParse+import Optics.Core hiding (element) import Optics.Zoom-import Text.InterpolatedString.Perl6 import Web.Rep.Bootstrap-import Web.Rep.Html import Web.Rep.Html.Input-import Web.Rep.Page import Web.Rep.Shared import Prelude as P @@ -64,22 +62,22 @@ -- | Create a sharedRep from an Input. repInput ::- (Monad m, ToHtml a) =>+ (Monad m, Show a) => -- | Parser- Parser a ->+ (ByteString -> Either ByteString a) -> -- | Printer- (a -> Text) ->+ (a -> ByteString) -> -- | 'Input' type Input a -> -- | initial value a -> SharedRep m a-repInput p pr i = register (first pack . A.parseOnly p) pr (\n v -> toHtml $ #inputVal .~ v $ #inputId .~ n $ i)+repInput p pr i = register p pr (\n v -> inputToHtml $ #inputVal .~ v $ #inputId .~ n $ i) -- | Like 'repInput', but does not put a value into the HashMap on instantiation, consumes the value when found in the HashMap, and substitutes a default on lookup failure-repMessage :: (Monad m, ToHtml a) => Parser a -> (a -> Text) -> Input a -> a -> a -> SharedRep m a+repMessage :: (Monad m, Show a) => (ByteString -> Either ByteString a) -> (a -> ByteString) -> Input a -> a -> a -> SharedRep m a repMessage p _ i def a =- message (first pack . A.parseOnly p) (\n v -> toHtml $ #inputVal .~ v $ #inputId .~ n $ i) a def+ message p (\n v -> inputToHtml $ #inputVal .~ v $ #inputId .~ n $ i) a def -- | double slider --@@ -89,7 +87,7 @@ -- slider (Just "label") 0 1 0.01 0.3 :: Monad m => SharedRep m Double slider :: (Monad m) =>- Maybe Text ->+ Maybe ByteString -> Double -> Double -> Double ->@@ -97,9 +95,9 @@ SharedRep m Double slider label l u s v = repInput- double- (pack . show)- (Input v label mempty (Slider [min_ (pack $ show l), max_ (pack $ show u), step_ (pack $ show s)]))+ (runParserEither double)+ (strToUtf8 . show)+ (Input v label mempty (Slider [Attr "min" (strToUtf8 $ show l), Attr "max" (strToUtf8 $ show u), Attr "step" (strToUtf8 $ show s)])) v -- | double slider with shown value@@ -110,7 +108,7 @@ -- slider (Just "label") 0 1 0.01 0.3 :: Monad m => SharedRep m Double sliderV :: (Monad m) =>- Maybe Text ->+ Maybe ByteString -> Double -> Double -> Double ->@@ -118,9 +116,9 @@ 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)]))+ (runParserEither double)+ (strToUtf8 . show)+ (Input v label mempty (SliderV [Attr "min" (strToUtf8 $ show l), Attr "max" (strToUtf8 $ show u), Attr "step" (strToUtf8 $ show s)])) v -- | integral slider@@ -131,8 +129,8 @@ -- sliderI (Just "label") 0 1000 10 300 -- :: (Monad m, ToHtml a, P.Integral a, Show a) => SharedRep m a sliderI ::- (Monad m, ToHtml a, P.Integral a, Show a) =>- Maybe Text ->+ (Monad m, P.Integral a, Show a) =>+ Maybe ByteString -> a -> a -> a ->@@ -140,15 +138,15 @@ SharedRep m a sliderI label l u s v = repInput- decimal- (pack . show)- (Input v label mempty (Slider [min_ (pack $ show l), max_ (pack $ show u), step_ (pack $ show s)]))+ (runParserEither (fromIntegral <$> int))+ (strToUtf8 . show)+ (Input v label mempty (Slider [Attr "min" (strToUtf8 $ show l), Attr "max" (strToUtf8 $ show u), Attr "step" (strToUtf8 $ show s)])) v -- | integral slider with shown value sliderVI ::- (Monad m, ToHtml a, P.Integral a, Show a) =>- Maybe Text ->+ (Monad m, P.Integral a, Show a) =>+ Maybe ByteString -> a -> a -> a ->@@ -156,61 +154,61 @@ 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)]))+ (runParserEither (fromIntegral <$> int))+ (strToUtf8 . show)+ (Input v label mempty (SliderV [Attr "min" (strToUtf8 $ show l), Attr "max" (strToUtf8 $ show u), Attr "step" (strToUtf8 $ show s)])) v -- | textbox classique -- -- > :t textbox (Just "label") "some text"--- textbox (Just "label") "some text" :: Monad m => SharedRep m Text-textbox :: (Monad m) => Maybe Text -> Text -> SharedRep m Text+-- textbox (Just "label") "some text" :: Monad m => SharedRep m ByteString+textbox :: (Monad m) => Maybe ByteString -> ByteString -> SharedRep m ByteString textbox label v = repInput- takeText+ (runParserEither takeRest) id (Input v label mempty TextBox) v -- | textbox that only updates on focusout-textbox' :: (Monad m) => Maybe Text -> Text -> SharedRep m Text+textbox' :: (Monad m) => Maybe ByteString -> ByteString -> SharedRep m ByteString textbox' label v = repInput- takeText+ (runParserEither takeRest) id (Input v label mempty TextBox') v -- | textarea input element, specifying number of rows.-textarea :: (Monad m) => Int -> Maybe Text -> Text -> SharedRep m Text+textarea :: (Monad m) => Int -> Maybe ByteString -> ByteString -> SharedRep m ByteString textarea rows label v = repInput- takeText+ (runParserEither takeRest) id (Input v label mempty (TextArea rows)) v -- | Non-typed hex color input-colorPicker :: (Monad m) => Maybe Text -> Text -> SharedRep m Text+colorPicker :: (Monad m) => Maybe ByteString -> ByteString -> SharedRep m ByteString colorPicker label v = repInput- takeText+ (runParserEither takeRest) id (Input v label mempty ColorPicker) v -- | dropdown box dropdown ::- (Monad m, ToHtml a) =>- -- | parse an a from Text- Parser a ->- -- | print an a to Text- (a -> Text) ->+ (Monad m, Show a) =>+ -- | parse an a from ByteString+ (ByteString -> Either ByteString a) ->+ -- | print an a to ByteString+ (a -> ByteString) -> -- | label suggestion- Maybe Text ->+ Maybe ByteString -> -- | list of dropbox elements (as text)- [Text] ->+ [ByteString] -> -- | initial value a -> SharedRep m a@@ -223,41 +221,41 @@ -- | dropdown box with multiple selections dropdownMultiple ::- (Monad m, ToHtml a) =>- -- | parse an a from Text- Parser a ->- -- | print an a to Text- (a -> Text) ->+ (Monad m, Show a) =>+ -- | parse an a from ByteString+ Parser ByteString a ->+ -- | print an a to ByteString+ (a -> ByteString) -> -- | label suggestion- Maybe Text ->+ Maybe ByteString -> -- | list of dropbox elements (as text)- [Text] ->+ [ByteString] -> -- | initial value [a] -> SharedRep m [a] dropdownMultiple p pr label opts vs = repInput- (p `sepBy1` char ',')+ (runParserEither (sep comma p)) (intercalate "," . fmap pr) (Input vs label mempty (DropdownMultiple opts ',')) vs -- | a datalist input-datalist :: (Monad m) => Maybe Text -> [Text] -> Text -> Text -> SharedRep m Text+datalist :: (Monad m) => Maybe ByteString -> [ByteString] -> ByteString -> ByteString -> SharedRep m ByteString datalist label opts v id'' = repInput- takeText- (pack . show)+ (runParserEither takeRest)+ (strToUtf8 . show) (Input v label mempty (Datalist opts id'')) v -- | A dropdown box designed to help represent a haskell sum type. dropdownSum ::- (Monad m, ToHtml a) =>- Parser a ->- (a -> Text) ->- Maybe Text ->- [Text] ->+ (Monad m, Show a) =>+ (ByteString -> Either ByteString a) ->+ (a -> ByteString) ->+ Maybe ByteString ->+ [ByteString] -> a -> SharedRep m a dropdownSum p pr label opts v =@@ -268,48 +266,48 @@ v -- | A checkbox input.-checkbox :: (Monad m) => Maybe Text -> Bool -> SharedRep m Bool+checkbox :: (Monad m) => Maybe ByteString -> Bool -> SharedRep m Bool checkbox label v = repInput- ((== "true") <$> takeText)+ (runParserEither ((== "true") <$> takeRest)) (bool "false" "true") (Input v label mempty (Checkbox v)) v -- | a toggle button-toggle :: (Monad m) => Maybe Text -> Bool -> SharedRep m Bool+toggle :: (Monad m) => Maybe ByteString -> Bool -> SharedRep m Bool toggle label v = repInput- ((== "true") <$> takeText)+ (runParserEither ((== "true") <$> takeRest)) (bool "false" "true") (Input v label mempty (Toggle v label)) v -- | a toggle button, with no label-toggle_ :: (Monad m) => Maybe Text -> Bool -> SharedRep m Bool+toggle_ :: (Monad m) => Maybe ByteString -> Bool -> SharedRep m Bool toggle_ label v = repInput- ((== "true") <$> takeText)+ (runParserEither ((== "true") <$> takeRest)) (bool "false" "true") (Input v Nothing mempty (Toggle v label)) v -- | a button-button :: (Monad m) => Maybe Text -> SharedRep m Bool+button :: (Monad m) => Maybe ByteString -> SharedRep m Bool button label = repMessage- (pure True)+ (const (Right True)) (bool "false" "true") (Input False label mempty Button) False False -- | filename input-chooseFile :: (Monad m) => Maybe Text -> Text -> SharedRep m Text+chooseFile :: (Monad m) => Maybe ByteString -> ByteString -> SharedRep m ByteString chooseFile label v = repInput- takeText- (pack . show)+ (runParserEither takeRest)+ (strToUtf8 . show) (Input v label mempty ChooseFile) v @@ -318,7 +316,7 @@ -- Hides the underlying content on Nothing maybeRep :: (Monad m) =>- Maybe Text ->+ Maybe ByteString -> Bool -> SharedRep m a -> SharedRep m (Maybe a)@@ -330,49 +328,52 @@ cardify (a, []) Nothing- ( Lucid.with- div_- [ id_ id',- style_+ ( element+ "div"+ [ Attr "id" id',+ Attr+ "style" ("display:" <> bool "none" "block" st) ] b,- [style_ "padding-top: 0.25rem; padding-bottom: 0.25rem;"]+ [Attr "style" "padding-top: 0.25rem; padding-bottom: 0.25rem;"] ) mmap a b = bool Nothing (Just b) a -checkboxShow :: (Monad m) => Maybe Text -> Text -> Bool -> SharedRep m Bool+checkboxShow :: (Monad m) => Maybe ByteString -> ByteString -> Bool -> SharedRep m Bool checkboxShow label id' v = SharedRep $ do name <- zoom _1 genName zoom _2 (modify (HashMap.insert name (bool "false" "true" v))) pure $ Rep- (toHtml (Input v label name (Checkbox v)) <> scriptToggleShow name id')+ (inputToHtml (Input v label name (Checkbox v)) <> scriptToggleShow name id') ( \s -> ( s, join $ maybe (Left "HashMap.lookup failed")- (Right . either (Left . pack) Right . parseOnly ((== "true") <$> takeText))+ (Right . first strToUtf8 . runParserEither ((== "true") <$> takeRest)) (HashMap.lookup name s) ) ) -- | toggle show/hide-scriptToggleShow :: (Monad m) => Text -> Text -> HtmlT m ()+scriptToggleShow :: ByteString -> ByteString -> Markup scriptToggleShow checkName toggleId =- script_- [qq|-$('#{checkName}').on('change', (function()\{+ elementc+ "script"+ []+ [i|+$('\##{checkName}').on('change', (function(){ var vis = this.checked ? "block" : "none";- document.getElementById("{toggleId}").style.display = vis;-\}));+ document.getElementById("#{toggleId}").style.display = vis;+})); |] -- | A (fixed-size) list represented in html as an accordion card -- A major restriction of the library is that a 'SharedRep' does not have a Monad instance. In practice, this means that the external representation of lists cannot have a dynamic size.-accordionList :: (Monad m) => Maybe Text -> Text -> Maybe Text -> (Text -> a -> SharedRep m a) -> [Text] -> [a] -> SharedRep m [a]+accordionList :: (Monad m) => Maybe ByteString -> ByteString -> Maybe ByteString -> (ByteString -> a -> SharedRep m a) -> [ByteString] -> [a] -> SharedRep m [a] accordionList title prefix open srf labels as = SharedRep $ do (Rep h fa) <- unshare $@@ -382,10 +383,10 @@ (pure []) (zipWith srf labels as) h' <- zoom _1 h- pure (Rep (maybe mempty (h5_ . toHtml) title <> h') fa)+ pure (Rep (maybe mempty (elementc "h5" []) title <> h') fa) -- | A (fixed-sized) list of (Bool, a) tuples.-accordionBoolList :: (Monad m) => Maybe Text -> Text -> (a -> SharedRep m a) -> (Bool -> SharedRep m Bool) -> [Text] -> [(Bool, a)] -> SharedRep m [(Bool, a)]+accordionBoolList :: (Monad m) => Maybe ByteString -> ByteString -> (a -> SharedRep m a) -> (Bool -> SharedRep m Bool) -> [ByteString] -> [(Bool, a)] -> SharedRep m [(Bool, a)] accordionBoolList title prefix bodyf checkf labels xs = SharedRep $ do (Rep h fa) <- unshare $@@ -399,18 +400,18 @@ ((\(ch, a) -> bimap (,) (,) (checkf ch) <<*>> bodyf a) <$> xs) ) h' <- zoom _1 h- pure (Rep (maybe mempty (h5_ . toHtml) title <> h') fa)+ pure (Rep (maybe mempty (elementc "h5" []) title <> h') fa) -- | A fixed-sized list of Maybe a\'s-listMaybeRep :: (Monad m) => Maybe Text -> Text -> (Text -> Maybe a -> SharedRep m (Maybe a)) -> Int -> [a] -> SharedRep m [Maybe a]+listMaybeRep :: (Monad m) => Maybe ByteString -> ByteString -> (ByteString -> Maybe a -> SharedRep m (Maybe a)) -> Int -> [a] -> SharedRep m [Maybe a] listMaybeRep t p srf n as = accordionList t p Nothing srf (defaultListLabels n) (take n ((Just <$> as) <> repeat Nothing)) -- | A SharedRep of [a]. Due to the applicative nature of the bridge, the size of lists has to be fixed on construction. listRep is a workaround for this, to enable some form of dynamic sizing. listRep :: (Monad m) =>- Maybe Text ->- Text ->+ Maybe ByteString ->+ ByteString -> -- | name prefix (should be unique) (Bool -> SharedRep m Bool) -> -- | Bool Rep@@ -434,84 +435,56 @@ (take n (((True,) <$> as) <> repeat (False, defa))) -- a sensible default for the accordion row labels for a list-defaultListLabels :: Int -> [Text]-defaultListLabels n = (\x -> "[" <> pack (show x) <> "]") <$> [0 .. n] :: [Text]+defaultListLabels :: Int -> [ByteString]+defaultListLabels n = (\x -> "[" <> strToUtf8 (show x) <> "]") <$> [0 .. n] :: [ByteString] -- | Parse from a textbox -- -- Uses focusout so as not to spam the reader.-readTextbox :: (Monad m, Read a, Show a) => Maybe Text -> a -> SharedRep m (Either Text a)-readTextbox label v = parsed . unpack <$> textbox' label (pack $ show v)+readTextbox :: (Monad m, Read a, Show a) => Maybe ByteString -> a -> SharedRep m (Either ByteString a)+readTextbox label v = parsed . utf8ToStr <$> textbox' label (strToUtf8 $ show v) where parsed str = case reads str of [(a, "")] -> Right a- _badRead -> Left (pack str)---- | Representation of web concerns (css, js & html).-fiddle :: (Monad m) => Concerns Text -> SharedRep m (Concerns Text, Bool)-fiddle (Concerns c j h) =- bimap- (\c' j' h' up -> Lucid.with div_ [class__ "fiddle "] $ mconcat [up, h', j', c'])- (\c' j' h' up -> (Concerns c' j' h', up))- (textarea 10 (Just "css") c)- <<*>> textarea 10 (Just "js") j- <<*>> textarea 10 (Just "html") h- <<*>> button (Just "update")---- | turns a SharedRep into a fiddle-viaFiddle ::- (Monad m) =>- SharedRep m a ->- SharedRep m (Bool, Concerns Text, a)-viaFiddle sr = SharedRep $ do- sr'@(Rep h _) <- unshare sr- hrep <- unshare $ textarea 10 (Just "html") (toText h)- crep <- unshare $ textarea 10 (Just "css") mempty- jrep <- unshare $ textarea 10 (Just "js") mempty- u <- unshare $ button (Just "update")- pure $- bimap- (\up a b c _ -> Lucid.with div_ [class__ "fiddle "] $ mconcat [up, a, b, c])- (\up a b c d -> (up, Concerns a b c, d))- u- <<*>> crep- <<*>> jrep- <<*>> hrep- <<*>> sr'+ _badRead -> Left (strToUtf8 str) -repChoice :: (Monad m) => Int -> [(Text, SharedRep m a)] -> SharedRep m a+repChoice :: (Monad m) => Int -> [(ByteString, SharedRep m a)] -> SharedRep m a repChoice initt xs = bimap hmap mmap dd <<*>> foldr (\x a -> bimap (:) (:) x <<*>> a) (pure []) cs where ts = fst <$> xs cs = snd <$> xs- dd = dropdownSum takeText id Nothing ts t0+ dd = dropdownSum (runParserEither takeRest) id Nothing ts t0 t0 = ts List.!! initt hmap dd' cs' =- div_- ( dd'- <> mconcat (zipWith (`subtype` t0) cs' ts)+ element+ "div"+ []+ ( dd' <> mconcat (zipWith (addSubtype t0) ts cs') ) mmap dd' cs' = maybe (List.head cs') (cs' List.!!) (List.elemIndex dd' ts) -- | select test keys from a Map-selectItems :: [Text] -> HashMap.HashMap Text a -> [(Text, a)]+selectItems :: [ByteString] -> HashMap.HashMap ByteString a -> [(ByteString, a)] selectItems ks m = HashMap.toList $ HashMap.filterWithKey (\k _ -> k `elem` ks) m -- | rep of multiple items list-repItemsSelect :: (Monad m) => [Text] -> [Text] -> SharedRep m [Text]+repItemsSelect :: (Monad m) => [ByteString] -> [ByteString] -> SharedRep m [ByteString] repItemsSelect initial full =- dropdownMultiple (A.takeWhile (`notElem` ([','] :: [Char]))) id (Just "items") full initial+ dropdownMultiple (strToUtf8 <$> some (satisfy (`notElem` ([','] :: [Char])))) id (Just "items") full initial -subtype :: (With a) => a -> Text -> Text -> a-subtype h origt t =- with- h- [ class__ "subtype ",- data_ "sumtype" t,- style_ ("display:" <> bool "block" "none" (origt /= t))- ]+subtype :: ByteString -> ByteString -> [Attr]+subtype origt t =+ [ Attr "class" "subtype ",+ Attr "data_sumtype" t,+ Attr "style" ("display:" <> bool "block" "none" (origt /= t))+ ]++addSubtype :: ByteString -> ByteString -> Markup -> Markup+addSubtype origt t (Markup trees) =+ Markup $+ fmap (fmap (\toke -> fromMaybe toke $ addAttrs (subtype origt t) toke)) trees
src/Web/Rep/Socket.hs view
@@ -1,37 +1,81 @@ {-# 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, parserJ, Code (..), code, console, val, replace, append, clean, webSocket, refreshJsbJs, preventEnter, runScriptJs) 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,+ Code (..),+ code,+ console,+ val,+ replace,+ append,+ clean,+ webSocket,+ refreshJsbJs,+ preventEnter,+ runScriptJs,+ )+where import Box import Box.Socket (serverApp) import Control.Concurrent.Async import Control.Monad import Control.Monad.State.Lazy-import Data.Attoparsec.Text qualified as A import Data.Bifunctor-import Data.Bool+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.Text (Text, pack)+import Data.String.Interpolate+import Data.Text (Text) import Data.Text qualified as Text+import FlatParse.Basic import GHC.Generics-import Lucid as L+import MarkupParse+import MarkupParse.FlatParse import Network.Wai.Handler.WebSockets import Network.WebSockets qualified as WS-import Optics.Core-import Text.InterpolatedString.Perl6+import Optics.Core hiding (element) import Web.Rep.Bootstrap-import Web.Rep.Html import Web.Rep.Page import Web.Rep.Server import Web.Rep.Shared import Web.Rep.SharedReps import Web.Scotty (middleware, scotty) +toText_ :: ByteString -> Text+toText_ = Text.pack . utf8ToStr++fromText_ :: Text -> ByteString+fromText_ = strToUtf8 . Text.unpack+ -- | Page with all the trimmings for a sharedRep Box socketPage :: Page socketPage =@@ -44,18 +88,33 @@ preventEnter ] -defaultSocketPage :: BootstrapVersion -> Page-defaultSocketPage v =- bool bootstrap5Page bootstrapPage (v == Boot4)+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- ]- )+ & set+ #htmlBody+ ( element+ "div"+ [Attr "class" "container"]+ ( element+ "div"+ [Attr "class" "row"]+ (elementc "h1" [] "web-rep testing")+ <> element+ "div"+ [Attr "class" "row"]+ ( mconcat $+ ( \(t, h) ->+ element+ "div"+ [Attr "class" "row"]+ (element "h2" [] (elementc "div" [Attr "id" t] h))+ )+ <$> sections+ )+ )+ ) where sections = [ ("input", mempty),@@ -85,23 +144,23 @@ servePageWith "/" (defaultPageConfig "") p -- | A common Box pattern. [Code] is typically committed to the websocket and key-value elements, representing changes to the shared objects that are in the Dom are emitted.-type CodeBox = Box IO [Code] (Text, Text)+type CodeBox = Box IO [Code] (ByteString, ByteString) -- | Codensity CodeBox-type CoCodeBox = Codensity IO (Box IO [Code] (Text, Text))+type CoCodeBox = Codensity IO (Box IO [Code] (ByteString, ByteString)) -- | Configuration for a CodeBox serving. data CodeBoxConfig = CodeBoxConfig { codeBoxSocket :: SocketConfig, codeBoxPage :: Page, codeBoxCommitterQueue :: Queue [Code],- codeBoxEmitterQueue :: Queue (Text, Text)+ codeBoxEmitterQueue :: Queue (ByteString, ByteString) } deriving (Generic) -- | official default config. defaultCodeBoxConfig :: CodeBoxConfig-defaultCodeBoxConfig = CodeBoxConfig defaultSocketConfig (defaultSocketPage Boot5) Single Single+defaultCodeBoxConfig = CodeBoxConfig defaultSocketConfig defaultSocketPage Single Single -- | Turn a configuration into a live (Codensity) CodeBox codeBoxWith :: CodeBoxConfig -> CoCodeBox@@ -110,7 +169,7 @@ (view #codeBoxEmitterQueue cfg) (view #codeBoxCommitterQueue cfg) ( serveSocketBox (view #codeBoxSocket cfg) (view #codeBoxPage cfg)- . dimap (either undefined id . A.parseOnly parserJ) (mconcat . fmap code)+ . dimap (either error id . runParserEither parserJ . fromText_) (mconcat . fmap (toText_ . code)) ) -- | Turn the default configuration into a live (Codensity) CodeBox@@ -118,36 +177,36 @@ codeBox = codeBoxWith defaultCodeBoxConfig -- | serve a SharedRep-serveRep :: SharedRep IO a -> (Html () -> [Code]) -> (Either Text a -> [Code]) -> CodeBoxConfig -> IO ()+serveRep :: SharedRep IO a -> (Markup -> [Code]) -> (Either ByteString 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 :: SharedRep IO a -> (Markup -> [Code]) -> (Either ByteString 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)]+replaceInput :: Markup -> [Code]+replaceInput h = [Replace "input" (markdown_ Compact Html h)] -- | Convert (typically parsed representation) to Code, replacing the output section of a page, and appending errors.-replaceOutput :: (Show a) => Either Text a -> [Code]+replaceOutput :: (Show a) => Either ByteString a -> [Code] replaceOutput ea = case ea of Left err -> [Append "debug" err]- Right a -> [Replace "output" (pack $ show a)]+ Right a -> [Replace "output" (strToUtf8 $ show a)] -- | Convert (typically parsed representation) to Code, replacing the output section of a page, and throwing away errors.-replaceOutput_ :: (Show a) => Either Text a -> [Code]+replaceOutput_ :: (Show a) => Either ByteString a -> [Code] replaceOutput_ ea = case ea of Left _ -> []- Right a -> [Replace "output" (pack $ show a)]+ Right a -> [Replace "output" (strToUtf8 $ show a)] -- | Stream a SharedRep sharedStream ::- (Monad m) => SharedRep m a -> Committer m (Html ()) -> Committer m (Either Text a) -> Emitter m (Text, Text) -> m ()+ (Monad m) => SharedRep m a -> Committer m Markup -> Committer m (Either ByteString a) -> Emitter m (ByteString, ByteString) -> m () sharedStream sr ch c e = flip evalStateT (0, HashMap.empty) $ do -- you only want to run unshare once for a SharedRep@@ -191,7 +250,7 @@ -- | representation of the playFrame in a PlayConfig repFrame :: Int -> SharedRep IO Int-repFrame x = read . Text.unpack <$> textbox (Just "frame") (pack $ show x)+repFrame x = read . utf8ToStr <$> textbox (Just "frame") (strToUtf8 $ show x) -- | representation of the playSpeed in a PlayConfig repSpeed :: Double -> SharedRep IO Double@@ -210,7 +269,7 @@ 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)+ (sharedStream ((,) <$> repReset <*> repPlayConfig pcfg) (contramap (\h -> [Replace "input" (markdown_ Compact Html 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 () @@ -221,13 +280,13 @@ -- * low-level JS conversions -- | {"event":{"element":"textid","value":"abcdees"}}-parserJ :: A.Parser (Text, Text)+parserJ :: Parser e (ByteString, ByteString) parserJ = do- _ <- A.string [q|{"event":{"element":"|]- e <- A.takeTill (== '"')- _ <- A.string [q|","value":"|]- v <- A.takeTill (== '"')- _ <- A.string [q|"}}|]+ _ <- $(string [i|{"event":{"element":"|])+ e <- byteStringOf $ some (satisfy (/= '"'))+ _ <- $(string [i|","value":"|])+ v <- byteStringOf $ some (satisfy (/= '"'))+ _ <- $(string [i|"}}|]) pure (e, v) -- * code hooks@@ -235,60 +294,60 @@ -- * code messaging data Code- = Replace Text Text- | Append Text Text- | Console Text- | Eval Text- | Val Text+ = Replace ByteString ByteString+ | Append ByteString ByteString+ | Console ByteString+ | Eval ByteString+ | Val ByteString deriving (Eq, Show, Generic, Read) -code :: Code -> Text+code :: Code -> ByteString code (Replace i t) = replace i t code (Append i t) = append i t code (Console t) = console t code (Eval t) = t code (Val t) = val t -console :: Text -> Text-console t = [qc| console.log({t}) |]+console :: ByteString -> ByteString+console t = [i| console.log(#{t}) |] -val :: Text -> Text-val t = [qc| jsb.ws.send({t}) |]+val :: ByteString -> ByteString+val t = [i| jsb.ws.send(#{t}) |] -- | replace a container and run any embedded scripts-replace :: Text -> Text -> Text+replace :: ByteString -> ByteString -> ByteString replace d t =- [qc|- var $container = document.getElementById('{d}');- $container.innerHTML = '{clean t}';+ [i|+ 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 :: ByteString -> ByteString -> ByteString append d t =- [qc|- var $container = document.getElementById('{d}');- $container.innerHTML += '{clean t}';+ [i|+ var $container = document.getElementById('#{d}');+ $container.innerHTML += '#{clean t}'; runScripts($container); refreshJsb(); |] -clean :: Text -> Text+clean :: ByteString -> ByteString clean =- Text.intercalate "\\'"- . Text.split (== '\'')- . Text.intercalate "\\n"- . Text.lines+ C.intercalate "\\'"+ . C.split '\''+ . C.intercalate "\\n"+ . C.lines -- * initial javascript -- | create a web socket for event data-webSocket :: RepJs+webSocket :: Js webSocket =- RepJsText- [q|+ Js+ [i| window.jsb = {ws: new WebSocket('ws://' + location.host + '/')}; jsb.event = function(ev) { jsb.ws.send(JSON.stringify({event: ev}));@@ -301,10 +360,10 @@ -- * scripts -- | Event hooks that may need to be reattached given dynamic content creation.-refreshJsbJs :: RepJs+refreshJsbJs :: Js refreshJsbJs =- RepJsText- [q|+ Js+ [i| function refreshJsb () { $('.jsbClassEventInput').off('input'); $('.jsbClassEventInput').on('input', (function(){@@ -353,11 +412,10 @@ |] -- | prevent the Enter key from triggering an event-preventEnter :: RepJs+preventEnter :: Js preventEnter =- RepJs $- parseJs- [q|+ 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') {@@ -371,10 +429,10 @@ -- | script injection js. -- -- See https://ghinda.net/article/script-tags/ for why this might be needed.-runScriptJs :: RepJs+runScriptJs :: Js runScriptJs =- RepJsText- [q|+ Js+ [i| function insertScript ($script) { var s = document.createElement('script') s.type = 'text/javascript'
web-rep.cabal view
@@ -1,142 +1,148 @@-cabal-version: 3.0-name: web-rep-version: 0.10.2.0-synopsis: representations of a web page-category: web+cabal-version: 3.0+name: web-rep+version: 0.11.0.0+license: BSD-3-Clause+license-file: LICENSE+copyright: Tony Day (c) 2015+category: web+author: Tony Day+maintainer: Tony Day <tonyday567@gmail.com>+homepage: https://github.com/tonyday567/numhask#readme+bug-reports: https://github.com/tonyday567/web-page/issues+synopsis: representations of a web page description:- An applicative-based, shared-data representation of a web page. + An applicative-based, shared-data representation of a web page. -bug-reports: https://github.com/tonyday567/web-page/issues-maintainer: Tony Day <tonyday567@gmail.com>-license: MIT-license-file: LICENSE.md-build-type: Simple+build-type: Simple+tested-with: GHC == 8.10.7 || ==9.2.8 || ==9.4.5 || ==9.6.2 extra-doc-files: ChangeLog.md-tested-with: GHC == 8.10.7 || ==9.2.8 || ==9.4.5 || ==9.6.2 source-repository head- type: git- location: https://github.com/tonyday567/web-rep-common ghc2021-stanza- if impl(ghc >=9.2)- default-language:- GHC2021- if impl(ghc <9.2)- default-language:- Haskell2010- default-extensions:- BangPatterns- BinaryLiterals- ConstrainedClassMethods- ConstraintKinds- DeriveDataTypeable- DeriveFoldable- DeriveFunctor- DeriveGeneric- DeriveLift- DeriveTraversable- DoAndIfThenElse- EmptyCase- EmptyDataDecls- EmptyDataDeriving- ExistentialQuantification- ExplicitForAll- FlexibleContexts- FlexibleInstances- ForeignFunctionInterface- GADTSyntax- GeneralisedNewtypeDeriving- HexFloatLiterals- ImplicitPrelude- InstanceSigs- KindSignatures- MonomorphismRestriction- MultiParamTypeClasses- NamedFieldPuns- NamedWildCards- NumericUnderscores- PatternGuards- PolyKinds- PostfixOperators- RankNTypes- RelaxedPolyRec- ScopedTypeVariables- StandaloneDeriving- StarIsType- TraditionalRecordSyntax- TupleSections- TypeApplications- TypeOperators- TypeSynonymInstances- if impl(ghc <9.2) && impl(ghc >=8.10)- default-extensions:- ImportQualifiedPost- StandaloneKindSignatures+ type: git+ location: https://github.com/tonyday567/web-rep +common ghc-options-exe-stanza+ ghc-options:+ -fforce-recomp+ -funbox-strict-fields+ -rtsopts+ -threaded+ -with-rtsopts=-N+ common ghc-options-stanza- ghc-options:- -Wall- -Wcompat- -Wincomplete-record-updates- -Wincomplete-uni-patterns- -Wredundant-constraints- -Widentities- -Wpartial-fields+ ghc-options:+ -Wall+ -Wcompat+ -Widentities+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wpartial-fields+ -Wredundant-constraints -library- import: ghc2021-stanza- import: ghc-options-stanza- exposed-modules:- Web.Rep- Web.Rep.Bootstrap- Web.Rep.Examples- Web.Rep.Html- Web.Rep.Html.Input- Web.Rep.Page- Web.Rep.Render- Web.Rep.Server- Web.Rep.Shared- Web.Rep.SharedReps- Web.Rep.Socket+common ghc2021-stanza+ if impl ( ghc >= 9.2 )+ default-language: GHC2021 - hs-source-dirs: src- build-depends:- , attoparsec ^>=0.14- , base >=4.12 && <5- , bifunctors >=5.5.11 && <5.7- , box >=0.9 && < 0.10- , box-socket ^>=0.4- , clay >=0.13 && <0.15- , interpolatedstring-perl6 ^>=1.0- , language-javascript >=0.6.0 && <0.8- , lucid >=2.9 && <2.12- , mtl >=2.2.2 && <2.4- , optics-core ^>=0.4- , optics-extra ^>=0.4- , profunctors ^>=5.6.2- , scotty >=0.11.5 && <0.13- , text >=1.2.3 && <2.1- , transformers >=0.5.6 && <0.6.2- , unordered-containers ^>=0.2.10- , wai-middleware-static ^>=0.9- , wai-websockets ^>=3.0.1.2- , websockets ^>=0.12- , async ^>=2.2.4+ if impl ( ghc < 9.2 )+ default-language: Haskell2010+ default-extensions:+ BangPatterns+ BinaryLiterals+ ConstrainedClassMethods+ ConstraintKinds+ DeriveDataTypeable+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveLift+ DeriveTraversable+ DoAndIfThenElse+ EmptyCase+ EmptyDataDecls+ EmptyDataDeriving+ ExistentialQuantification+ ExplicitForAll+ FlexibleContexts+ FlexibleInstances+ ForeignFunctionInterface+ GADTSyntax+ GeneralisedNewtypeDeriving+ HexFloatLiterals+ ImplicitPrelude+ InstanceSigs+ KindSignatures+ MonomorphismRestriction+ MultiParamTypeClasses+ NamedFieldPuns+ NamedWildCards+ NumericUnderscores+ PatternGuards+ PolyKinds+ PostfixOperators+ RankNTypes+ RelaxedPolyRec+ ScopedTypeVariables+ StandaloneDeriving+ StarIsType+ TraditionalRecordSyntax+ TupleSections+ TypeApplications+ TypeOperators+ TypeSynonymInstances -executable web-rep-example- import: ghc2021-stanza- import: ghc-options-stanza- main-is: rep-example.hs- hs-source-dirs: app- build-depends:- , base >=4.12 && <5- , optparse-applicative >=0.17 && <0.19- , web-rep- , box >=0.9 && < 0.10- , text >=1.2.3 && <2.1- , lucid >=2.9 && <2.12- , optics-core ^>=0.4+ if impl ( ghc < 9.2 ) && impl ( ghc >= 8.10 )+ default-extensions:+ ImportQualifiedPost+ StandaloneKindSignatures - ghc-options:- -funbox-strict-fields -fforce-recomp -threaded -rtsopts- -with-rtsopts=-N+library+ import: ghc-options-stanza+ import: ghc2021-stanza+ hs-source-dirs: src+ build-depends:+ , async ^>=2.2.4+ , base >=4.7 && <5+ , bifunctors >=5.5.11 && <5.7+ , box >=0.9 && <0.10+ , box-socket >=0.4 && <0.5+ , bytestring >=0.11.3 && <0.13+ , flatparse >=0.3.5 && <0.6+ , markup-parse >=0.1.0.1 && <0.2+ , mtl >=2.2.2 && <2.4+ , optics-core >=0.4 && <0.5+ , optics-extra >=0.4 && <0.5+ , profunctors >=5.6.2 && <5.7+ , scotty >=0.11.5 && <0.13+ , string-interpolate >=0.3 && <0.4+ , text >=1.2 && <2.1+ , transformers >=0.5.6 && <0.6.2+ , unordered-containers >=0.2 && <0.3+ , wai-middleware-static ^>=0.9+ , wai-websockets ^>=3.0.1.2+ , websockets ^>=0.12+ exposed-modules:+ Web.Rep+ Web.Rep.Bootstrap+ Web.Rep.Examples+ Web.Rep.Html+ Web.Rep.Html.Input+ Web.Rep.Page+ Web.Rep.Render+ Web.Rep.Server+ Web.Rep.Shared+ Web.Rep.SharedReps+ Web.Rep.Socket++executable web-rep-example+ import: ghc-options-exe-stanza+ import: ghc-options-stanza+ import: ghc2021-stanza+ main-is: rep-example.hs+ hs-source-dirs: app+ build-depends:+ , base >=4.7 && <5+ , box >=0.9 && <0.10+ , markup-parse >=0.1 && <0.2+ , optics-core >=0.4 && <0.5+ , optparse-applicative >=0.17 && <0.19+ , web-rep