diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 === diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/LICENSE.md b/LICENSE.md deleted file mode 100644 --- a/LICENSE.md +++ /dev/null @@ -1,21 +0,0 @@ -The MIT License (MIT) - -Copyright (c) 2015 Tony Day - -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. diff --git a/app/rep-example.hs b/app/rep-example.hs --- a/app/rep-example.hs +++ b/app/rep-example.hs @@ -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) diff --git a/src/Web/Rep.hs b/src/Web/Rep.hs --- a/src/Web/Rep.hs +++ b/src/Web/Rep.hs @@ -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 diff --git a/src/Web/Rep/Bootstrap.hs b/src/Web/Rep/Bootstrap.hs --- a/src/Web/Rep/Bootstrap.hs +++ b/src/Web/Rep/Bootstrap.hs @@ -1,12 +1,14 @@ +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} -- | Some 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" - ] - ] - --- | -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" ] - ] --- | -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 needs for a web page. bootstrapPage :: Page @@ -106,104 +73,123 @@ mempty mempty mempty - (mconcat bootstrapMeta) - mempty - --- | A page containing all the needs for a web page. -bootstrap5Page :: Page -bootstrap5Page = - Page - bootstrap5Css - bootstrap5Js - mempty - mempty - mempty - (mconcat bootstrapMeta) + bootstrapMeta mempty -- | wrap some Html with the bootstrap 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 diff --git a/src/Web/Rep/Examples.hs b/src/Web/Rep/Examples.hs --- a/src/Web/Rep/Examples.hs +++ b/src/Web/Rep/Examples.hs @@ -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| -
-|] - -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 diff --git a/src/Web/Rep/Html.hs b/src/Web/Rep/Html.hs --- a/src/Web/Rep/Html.hs +++ b/src/Web/Rep/Html.hs @@ -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" --- -libCss :: Text -> Html () +-- >>> markdown_ Compact Html $ libCss "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" --- -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" +-- "" +libJs :: ByteString -> Markup +libJs url = element_ "script" [Attr "src" url] diff --git a/src/Web/Rep/Html/Input.hs b/src/Web/Rep/Html/Input.hs --- a/src/Web/Rep/Html/Input.hs +++ b/src/Web/Rep/Html/Input.hs @@ -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) + ] + ) diff --git a/src/Web/Rep/Page.hs b/src/Web/Rep/Page.hs --- a/src/Web/Rep/Page.hs +++ b/src/Web/Rep/Page.hs @@ -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}};|] diff --git a/src/Web/Rep/Render.hs b/src/Web/Rep/Render.hs --- a/src/Web/Rep/Render.hs +++ b/src/Web/Rep/Render.hs @@ -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 Html () -svgDefs = term "defs" diff --git a/src/Web/Rep/Server.hs b/src/Web/Rep/Server.hs --- a/src/Web/Rep/Server.hs +++ b/src/Web/Rep/Server.hs @@ -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 diff --git a/src/Web/Rep/Shared.hs b/src/Web/Rep/Shared.hs --- a/src/Web/Rep/Shared.hs +++ b/src/Web/Rep/Shared.hs @@ -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 diff --git a/src/Web/Rep/SharedReps.hs b/src/Web/Rep/SharedReps.hs --- a/src/Web/Rep/SharedReps.hs +++ b/src/Web/Rep/SharedReps.hs @@ -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 diff --git a/src/Web/Rep/Socket.hs b/src/Web/Rep/Socket.hs --- a/src/Web/Rep/Socket.hs +++ b/src/Web/Rep/Socket.hs @@ -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' diff --git a/web-rep.cabal b/web-rep.cabal --- a/web-rep.cabal +++ b/web-rep.cabal @@ -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 +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 -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