web-rep 0.7.2 → 0.14.1.0
raw patch · 22 files changed
Files
- ChangeLog.md +43/−0
- LICENSE +30/−0
- LICENSE.md +0/−21
- Setup.hs +0/−2
- app/rep-example.hs +121/−22
- readme.md +49/−17
- src/Web/Rep.hs +12/−16
- src/Web/Rep/Bootstrap.hs +127/−95
- src/Web/Rep/Examples.hs +84/−223
- src/Web/Rep/Html.hs +20/−61
- src/Web/Rep/Html/Input.hs +311/−235
- src/Web/Rep/Internal/FlatParse.hs +332/−0
- src/Web/Rep/Mathjax.hs +0/−156
- src/Web/Rep/Page.hs +56/−189
- src/Web/Rep/Render.hs +62/−82
- src/Web/Rep/Server.hs +13/−14
- src/Web/Rep/Shared.hs +43/−51
- src/Web/Rep/SharedReps.hs +216/−185
- src/Web/Rep/Socket.hs +294/−236
- stack.yaml +0/−17
- test/test.hs +0/−92
- web-rep.cabal +100/−106
+ ChangeLog.md view
@@ -0,0 +1,43 @@+0.14.1+======++* Dependency maintenance: relaxed scotty < 1, transformers < 0.7+* Doctests: removed non-deterministic exception test due to GHC HasCallStack changes+* Updated tested-with to GHC 9.10.2, 9.12.3, 9.14.1++0.14+===++* Added Web.Rep.Internal.FlatParse (due to markup-parse-2.0 changes)++0.13+===+* added sharedPage+* modified to use modern bootstrap methods+++0.12.1+===+* Changed the order of Page elements, so that inline css over-rides libraries.+* Added cssColorScheme to API++0.12+===+* markupInput replaces inputToHtml as per markup-parse+* ToByteString introduced+* upgrade to box-socket-0.5++0.11+===+* Removed clay, lucid as dependencies+* refactored to markup-parse as markup representation.++0.10.2+===++* GHC 9.6.2 upgrade++0.8.0+===++* Removed numhask dependencies
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Tony Day++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Tony Day nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
− LICENSE.md
@@ -1,21 +0,0 @@-The MIT License (MIT)--Copyright (c) 2015 Tony Day <tonyday567@gmail.com>--Permission is hereby granted, free of charge, to any person obtaining a copy-of this software and associated documentation files (the "Software"), to deal-in the Software without restriction, including without limitation the rights-to use, copy, modify, merge, publish, distribute, sublicense, and/or sell-copies of the Software, and to permit persons to whom the Software is-furnished to do so, subject to the following conditions:--The above copyright notice and this permission notice shall be included in-all copies or substantial portions of the Software.--THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR-IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,-FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE-AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER-LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,-OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN-THE SOFTWARE.
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
app/rep-example.hs view
@@ -1,37 +1,136 @@ {-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}-{-# OPTIONS_GHC -Wall #-} -import NumHask.Prelude-import Options.Generic+import Box+import Control.Monad+import Data.Bifunctor+import MarkupParse hiding (Parser)+import Optics.Core hiding (element)+import Options.Applicative import Web.Rep import Web.Rep.Examples+import Prelude -data AppType = SharedTest deriving (Eq, Read, Show, Generic)+data AppType+ = SharedTest+ | PlayTest+ | RestartTest+ | ClosureBug+ deriving (Eq, Show) -instance ParseField AppType+newtype Options = Options+ { optionAppType :: AppType+ }+ deriving (Eq, Show) -instance ParseRecord AppType+parseAppType :: Parser AppType+parseAppType =+ flag' SharedTest (long "shared" <> help "shared test")+ <|> flag' PlayTest (long "play" <> help "play functionality test")+ <|> flag' RestartTest (long "restart" <> help "console restart test")+ <|> flag' ClosureBug (long "closure" <> help "documents the closure bug")+ <|> pure SharedTest -instance ParseFields AppType+options :: Parser Options+options =+ Options+ <$> parseAppType -data Opts w- = Opts- { apptype :: w ::: AppType <?> "type of example"- }- deriving (Generic)+opts :: ParserInfo Options+opts =+ info+ (options <**> helper)+ (fullDesc <> progDesc "web-rep testing" <> header "web-rep") -instance ParseRecord (Opts Wrapped)+-- | A simple count stream+countStream :: Int -> Double -> CoEmitter IO (Gap, [Code])+countStream n speed = fmap (second ((: []) . Replace "output" . strToUtf8 . show)) <$> qList (zip (0 : repeat (1 / speed)) [0 .. n]) main :: IO () main = do- o :: Opts Unwrapped <- unwrapRecord "examples for web-page"- case apptype o of- SharedTest -> defaultSharedServer (maybeRep (Just "maybe") False repExamples)+ o <- execParser opts+ let a = optionAppType o+ case a of+ SharedTest -> sharedTest+ PlayTest -> playTest+ RestartTest -> void restartTest+ ClosureBug -> void closureBug++sharedTest :: IO ()+sharedTest =+ serveRep+ (maybeRep (Just "maybe") False repExamples)+ replaceInput+ replaceOutput+ (defaultCodeBoxConfig & set #codeBoxPage sharedPage)++sharedPage :: Page+sharedPage =+ defaultSocketPage+ & set+ #htmlBody+ ( element+ "div"+ [Attr "class" "container"]+ ( element+ "div"+ [Attr "class" "row"]+ (elementc "h1" [] "shared test")+ <> element+ "div"+ [Attr "class" "row"]+ (element "div" [Attr "class" "col-6", Attr "id" "input"] mempty <> element "div" [Attr "class" "col-6", Attr "id" "output"] mempty)+ )+ )++playTest :: IO ()+playTest = servePlayStream (PlayConfig True 10 0) (defaultCodeBoxConfig & #codeBoxPage .~ playPage) (countStream 100 1)++playPage :: Page+playPage =+ 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)++resetE :: Int -> Int -> CoEmitter IO Bool+resetE n m = qList (replicate (n - 1) False <> [True] <> replicate m False)++-- | documenting the issue with left floating compositions in the usage of <$|>+closureBug :: IO (Either Bool ())+closureBug = do+ putStrLn "restart ((== \"q\") <$> fromStdin) (glue showStdout . gapEffect <$|> countStream 10 2)"+ putStrLn "type 'q' to restart"+ restart ((== "q") <$> fromStdin) (glue showStdout . gapEffect <$|> countStream 10 2)+ putStrLn "buggy version"+ putStrLn "restart ((== \"q\") <$> fromStdin) . glue showStdout . gapEffect <$|> countStream 20 1"+ restart ((== "q") <$> fromStdin) . glue showStdout . gapEffect <$|> countStream 10 2
readme.md view
@@ -1,27 +1,59 @@-[web-rep](https://github.com/tonyday567/web-rep) [](https://travis-ci.org/tonyday567/web-rep)-=== +# web-rep++[](https://hackage.haskell.org/package/web-rep) [](https://github.com/tonyday567/web-rep/actions/workflows/haskell-ci.yml)+ Various functions and representations for a web page. The best way to understand functionality is via running the example app: -```-stack build --test --exec "$(stack path --local-install-root)/bin/page-example --apptype SharedTest" --file-watch-```+ cabal install+ web-rep-example --shared -http://localhost:9160/+… and then tune in to: -reference----+<http://localhost:9160/> -- [scotty](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/flags.html#flag-reference)-- get [bootstrap](https://getbootstrap.com/)-- [bootstrap-slider](https://seiyria.com/bootstrap-slider)-- [blaze](http://hackage.haskell.org/package/blaze-html)-- [lucid](http://hackage.haskell.org/package/lucid)-- [clay](https://www.stackage.org/clay) -todo----+# library reference -https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/eval#Do_not_ever_use_eval!+- [scotty](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/flags.html#flag-reference)+- [bootstrap](https://getbootstrap.com/)+- [bootstrap-slider](https://seiyria.com/bootstrap-slider)+++# Development++ (setq haskell-process-args-cabal-repl '("web-rep:exe:web-rep-example"))++<table border="2" cellspacing="0" cellpadding="6" rules="groups" frame="hsides">+++<colgroup>+<col class="org-left" />+</colgroup>+<tbody>+<tr>+<td class="org-left">web-rep:exe:web-rep-example</td>+</tr>+</tbody>+</table>++ :r+ :set -Wno-type-defaults+ :set -Wno-name-shadowing+ :set -XOverloadedStrings+ :set -XOverloadedLabels+ :set -XDataKinds+ import Prelude+ import Box+ import Web.Rep+ import Optics.Core+ import FlatParse.Basic+ import MarkupParse+ putStrLn "ok"++ Ok, 11 modules loaded.+ ghci+ ok+
src/Web/Rep.hs view
@@ -1,9 +1,11 @@--- | A haskell library for representing web pages.+-- | A haskell library for representing: ----- This library is a collection of web page abstractions, together with a reimagining of <http://hackage.haskell.org/package/suavemente suavemente>.+-- - web pages, as (composable) collections of Html, Css and JS text. ----- I wanted to expose the server delivery mechanism, switch the streaming nature of the gap between a web page and a haskell server, and concentrate on getting a clean interface between pure haskell and the world that is a web page.+-- - things that have a tied together represention in Haskell and in the DOM, where things can have shared sub-components. --+-- - websocket & server communication protocols.+-- -- See app/examples.hs and 'Web.Examples' for usage. module Web.Rep ( -- * Shared Representation@@ -27,21 +29,16 @@ concernNames, PageConcerns (..), PageStructure (..),- PageRender (..),+ RenderStyle (..), -- * Css- Css,- RepCss (..),+ Css (..), renderCss,- renderRepCss,+ cssColorScheme, -- * JS- JS (..),- RepJs (..),+ Js (..), onLoad,- renderRepJs,- parseJs,- renderJs, -- * re-export modules module Web.Rep.SharedReps,@@ -51,21 +48,20 @@ module Web.Rep.Html, module Web.Rep.Html.Input, module Web.Rep.Bootstrap,- module Web.Rep.Mathjax, -- * re-exports HashMap.HashMap, ) where -import qualified Data.HashMap.Strict as HashMap+import Data.HashMap.Strict qualified as HashMap+import MarkupParse (RenderStyle (..)) import Web.Rep.Bootstrap-import Web.Rep.Socket import Web.Rep.Html import Web.Rep.Html.Input-import Web.Rep.Mathjax import Web.Rep.Page import Web.Rep.Render import Web.Rep.Server import Web.Rep.Shared import Web.Rep.SharedReps+import Web.Rep.Socket
src/Web/Rep/Bootstrap.hs view
@@ -1,14 +1,14 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-} -- | Some <https://getbootstrap.com/ bootstrap> assets and functionality. module Web.Rep.Bootstrap- ( bootstrapPage,+ ( bootstrapCss,+ bootstrapJs,+ bootstrapMeta,+ bootstrapPage, cardify,- divClass_, accordion, accordionChecked, accordionCard,@@ -17,53 +17,55 @@ ) where -import Lucid-import Lucid.Base-import NumHask.Prelude-import Web.Rep.Html+import Control.Monad.State.Lazy+import Data.Bool+import Data.ByteString (ByteString)+import Data.Functor.Identity+import MarkupParse import Web.Rep.Page import Web.Rep.Shared -bootstrapCss :: [Html ()]+-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Web.Rep+-- >>> import MarkupParse++-- | bootstrap css link+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"- ]- ]+ 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 ()]+-- | bootstrap JS link+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" ]- ] -bootstrapMeta :: [Html ()]+-- | bootstrap meta element.+bootstrapMeta :: Markup bootstrapMeta =- [ meta_ [charset_ "utf-8"],- meta_- [ name_ "viewport",- content_ "width=device-width, initial-scale=1, shrink-to-fit=no"+ element_ "meta" [Attr "charset" "utf-8"]+ <> element_+ "meta"+ [ Attr "name" "viewport",+ Attr "content" "width=device-width, initial-scale=1, shrink-to-fit=no" ]- ] -- | A page containing all the <https://getbootstrap.com/ bootstrap> needs for a web page. bootstrapPage :: Page@@ -74,92 +76,122 @@ mempty mempty mempty- (mconcat bootstrapMeta)+ bootstrapMeta mempty -- | wrap some Html with the bootstrap <https://getbootstrap.com/docs/4.3/components/card/ card> class-cardify :: (Html (), [Attribute]) -> Maybe Text -> (Html (), [Attribute]) -> Html ()+cardify :: (Markup, [Attr]) -> Maybe ByteString -> (Markup, [Attr]) -> Markup cardify (h, hatts) t (b, batts) =- with div_ ([class__ "card"] <> hatts) $+ element "div" ([Attr "class" "card"] <> hatts) $ h- <> with- div_- ([class__ "card-body"] <> batts)- ( maybe mempty (with h5_ [class__ "card-title"] . toHtml) t- <> b- )---- | wrap some html with a classed div-divClass_ :: Text -> Html () -> Html ()-divClass_ t = with div_ [class__ t]+ <> element+ "div"+ ([Attr "class" "card-body"] <> batts)+ (maybe mempty (elementc "h5" [Attr "class" "card-title"]) t <> b) -- | 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 <$> sequence (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 <$> sequence (aCard par <$> hs)+ aCards par = mapM (aCard par) hs aCard par (l, bodyhtml, checkhtml) = do idh <- genNamePre pre idb <- genNamePre pre pure $ accordionCardChecked True par idh idb l bodyhtml checkhtml -- | This version of accordion runs a local state for naming, and will cause name clashes if the prefix is not unique.-accordion_ :: Text -> Maybe Text -> [(Text, Html ())] -> Html ()+accordion_ :: ByteString -> Maybe ByteString -> [(ByteString, Markup)] -> Markup accordion_ pre x hs = runIdentity $ evalStateT (accordion pre x hs) 0
src/Web/Rep/Examples.hs view
@@ -1,146 +1,138 @@ {-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-} +-- | Some simple usage examples to get started with the library.+--+-- The most important example is 'repExamples' which forms the basis of the app example. module Web.Rep.Examples ( page1, page2,- pagemj, cfg2, RepExamples (..), repExamples, Shape (..), fromShape, toShape,- SumTypeExample (..),- repSumTypeExample,- SumType2Example (..),- repSumType2Example,- listExample,- listRepExample,- fiddleExample, ) where -import qualified Clay-import Control.Lens hiding ((.=))-import Data.Attoparsec.Text-import Lucid-import NumHask.Prelude-import Text.InterpolatedString.Perl6+import Data.ByteString (ByteString)+import FlatParse.Basic (takeRest)+import GHC.Generics+import MarkupParse+import Optics.Core hiding (element) import Web.Rep+import Web.Rep.Internal.FlatParse -- | simple page example page1 :: Page page1 =- #htmlBody .~ button1- $ #cssBody .~ RepCss css1- $ #jsGlobal .~ mempty- $ #jsOnLoad .~ click- $ #libsCss .~ (libCss <$> cssLibs)- $ #libsJs .~ (libJs <$> jsLibs)- $ mempty+ #htmlBody .~ button1 $+ #cssBody .~ css1 $+ #jsGlobal .~ mempty $+ #jsOnLoad .~ click $+ #libsCss .~ mconcat (libCss <$> cssLibs) $+ #libsJs .~ mconcat (libJs <$> jsLibs) $+ mempty -- | page with localised libraries page2 :: Page page2 =- #libsCss .~ (libCss <$> cssLibsLocal)- $ #libsJs .~ (libJs <$> jsLibsLocal)- $ page1---- | simple mathjax formulae-pagemj :: Page-pagemj = mathjaxPage & #htmlBody .~ htmlMathjaxExample--htmlMathjaxExample :: HtmlT Identity ()-htmlMathjaxExample =- p_ "double dollar:"- <> p_ "$$\\sum_{i=0}^n i^2 = \\frac{(n^2+n)(2n+1)}{6}$$"- <> p_ "single dollar for inline: $\\sum_{i=0}^n i^2 = \\frac{(n^2+n)(2n+1)}{6}$"- <> p_ "escaped brackets for inline mathjax: \\(\\sum_{i=0}^n i^2 = \\frac{(n^2+n)(2n+1)}{6}\\)"+ #libsCss .~ mconcat (libCss <$> cssLibsLocal) $+ #libsJs .~ mconcat (libJs <$> jsLibsLocal) $+ page1 +-- | Page with separated css and js. cfg2 :: PageConfig cfg2 =- #concerns .~ Separated- $ #pageRender .~ Pretty- $ #structure .~ Headless- $ #localdirs .~ ["test/static"]- $ #filenames .~ (("other/cfg2" <>) <$> suffixes)- $ defaultPageConfig ""+ #concerns .~ Separated $+ #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+ "{\n\+ \ font-size : 10px;\n\+ \ font-family : \"Arial\",\"Helvetica\", sans-serif;\n\+ \}\n\+ \\n\+ \#btnGo\n\+ \{\n\+ \ margin-top : 20px;\n\+ \ margin-bottom : 20px;\n\+ \}\n\+ \\n\+ \#btnGo.on\n\+ \{\n\+ \ color : #008000;\n\+ \}" -- js-click :: RepJs+click :: Js click =- RepJsText- [q|-$('#btnGo').click( function() {- $('#btnGo').toggleClass('on');- alert('bada bing!');-});-|]+ Js+ "$('#btnGo').click( function() {\n\+ \ $('#btnGo').toggleClass('on');\n\+ \ alert('bada bing!');\n\+ \});" -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,- repSliderI :: Int,- repSlider :: Double,- repCheckbox :: Bool,- repToggle :: Bool,- repDropdown :: Int,- repDropdownMultiple :: [Int],- repShape :: Shape,- repColor :: Text- }+data RepExamples = RepExamples+ { repTextbox :: ByteString,+ repTextarea :: ByteString,+ repSliderI :: Int,+ repSlider :: Double,+ repSliderVI :: Int,+ repSliderV :: Double,+ repCheckbox :: Bool,+ repToggle :: Bool,+ repDropdown :: Int,+ repDropdownMultiple :: [Int],+ repShape :: Shape,+ repColor :: ByteString+ } deriving (Show, Eq, Generic) -- | For a typed dropdown example. 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" @@ -148,146 +140,15 @@ repExamples :: (Monad m) => SharedRep m RepExamples repExamples = do t <- textbox (Just "textbox") "sometext"- ta <- textarea 3 (Just "textarea") "no initial value & multi-line text\\nrenders is not ok?/"+ ta <- textarea 3 (Just "textarea") "no initial value & multi-line text" n <- sliderI (Just "int slider") 0 5 1 3 ds' <- slider (Just "double slider") 0 1 0.1 0.5+ nV <- sliderVI (Just "int slider") 0 5 1 3+ dsV' <- sliderV (Just "double slider") 0 1 0.1 0.5 c <- checkbox (Just "checkbox") True tog <- toggle (Just "toggle") False- dr <- dropdown decimal (pack . show) (Just "dropdown") (pack . show <$> [1 .. 5 :: Int]) 3- drm <- dropdownMultiple decimal (pack . show) (Just "dropdown multiple") (pack . show <$> [1 .. 5 :: Int]) [2, 4]- drt <- toShape <$> dropdown takeText id (Just "shape") ["Circle", "Square"] (fromShape SquareShape)+ 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' c tog dr drm drt col)--listExample :: (Monad m) => Int -> SharedRep m [Int]-listExample n =- accordionList- (Just "accordianListify")- "al"- Nothing- (\l a -> sliderI (Just l) (0 :: Int) n 1 a)- ((\x -> "[" <> (pack . show) x <> "]") <$> [0 .. n] :: [Text])- [0 .. n]--listRepExample :: (Monad m) => Int -> SharedRep m [Int]-listRepExample n =- listRep- (Just "listifyMaybe")- "alm"- (checkbox Nothing)- (sliderI Nothing (0 :: Int) n 1)- n- 3- [0 .. 4]--fiddleExample :: Concerns Text-fiddleExample =- Concerns- mempty- mempty- [q|-<div class=" form-group-sm "><label for="1">fiddle example</label><input max="10.0" value="3.0" oninput="jsb.event({ 'element': this.id, 'value': this.value});" step="1.0" min="0.0" id="1" type="range" class=" custom-range form-control-range "></div>-|]--data SumTypeExample = SumInt Int | SumOnly | SumText Text deriving (Eq, Show, Generic)--sumTypeText :: SumTypeExample -> Text-sumTypeText (SumInt _) = "SumInt"-sumTypeText SumOnly = "SumOnly"-sumTypeText (SumText _) = "SumText"--repSumTypeExample :: (Monad m) => Int -> Text -> SumTypeExample -> SharedRep m SumTypeExample-repSumTypeExample defi deft defst =- bimap hmap mmap repst <<*>> repi <<*>> rept- where- repi = sliderI Nothing 0 20 1 defInt- rept = textbox Nothing defText- repst =- dropdownSum- takeText- id- (Just "SumTypeExample")- ["SumInt", "SumOnly", "SumText"]- (sumTypeText defst)- hmap repst' repi' rept' =- div_- ( repst'- <> with- repi'- [ class__ "subtype ",- data_ "sumtype" "SumInt",- style_- ( "display:"- <> bool "block" "none" (sumTypeText defst /= "SumInt")- )- ]- <> with- rept'- [ class__ "subtype ",- data_ "sumtype" "SumText",- style_- ("display:" <> bool "block" "none" (sumTypeText defst /= "SumText"))- ]- )- mmap repst' repi' rept' =- case repst' of- "SumInt" -> SumInt repi'- "SumOnly" -> SumOnly- "SumText" -> SumText rept'- _ -> SumOnly- defInt = case defst of- SumInt i -> i- _ -> defi- defText = case defst of- SumText t -> t- _ -> 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'- _ -> SumOutside repoi'- defInt = case defst of- SumInt i -> i- _ -> defi+ pure (RepExamples t ta n ds' nV dsV' c tog dr drm drt col)
src/Web/Rep/Html.hs view
@@ -1,78 +1,37 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# 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.List (intersperse)-import qualified Data.Text.Lazy as Lazy-import Lucid-import NumHask.Prelude---- | FIXME: A horrible hack to separate class id's-class__ :: Text -> Attribute-class__ t = class_ (" " <> t <> " ")+import Data.ByteString (ByteString)+import MarkupParse --- | Convert html to text-toText :: Html a -> Text-toText = Lazy.toStrict . renderText+-- $setup+--+-- >>> import Web.Rep.Html+-- >>> import MarkupParse+-- >>> :set -XOverloadedStrings -- | Convert a link to a css library from text to html. ----- >>> libCss "https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/css/bootstrap.min.css"--- <link href="https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/css/bootstrap.min.css" rel="stylesheet">-libCss :: Text -> Html ()+-- >>> markdown_ Compact Html $ libCss "https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/css/bootstrap.min.css"+-- "<link rel=\"stylesheet\" href=\"https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/css/bootstrap.min.css\">"+libCss :: ByteString -> Markup libCss url =- link_- [ rel_ "stylesheet",- href_ url+ element_+ "link"+ [ Attr "rel" "stylesheet",+ Attr "href" url ] -- | Convert a link to a js library from text to html. ----- >>> libJs "https://code.jquery.com/jquery-3.3.1.slim.min.js"--- <script src="https://code.jquery.com/jquery-3.3.1.slim.min.js"></script>-libJs :: Text -> Html ()-libJs url = with (script_ mempty) [src_ url]---- | FIXME: `ToHtml a` is used throughout, mostly because `Show a` gives "\"text\"" for show "text", and hilarity ensues when rendering this to a web page, and I couldn't work out how to properly get around this.------ Hence, these orphans.-instance ToHtml Double where- toHtml = toHtml . (pack . show)-- toHtmlRaw = toHtmlRaw . (pack . show)--instance ToHtml Bool where- toHtml = toHtml . bool ("false" :: Text) "true"-- toHtmlRaw = toHtmlRaw . bool ("false" :: Text) "true"--instance ToHtml Int where- toHtml = toHtml . (pack . show)-- toHtmlRaw = toHtmlRaw . (pack . show)--instance ToHtml () where- toHtml = const "()"-- toHtmlRaw = const "()"---- I'm going to hell for sure.-instance {-# INCOHERENT #-} (ToHtml a) => ToHtml [a] where- toHtml = mconcat . Data.List.intersperse (toHtml ("," :: Text)) . fmap toHtml-- toHtmlRaw = mconcat . Data.List.intersperse (toHtmlRaw ("," :: Text)) . fmap toHtmlRaw+-- >>> markdown_ Compact Html $ libJs "https://code.jquery.com/jquery-3.3.1.slim.min.js"+-- "<script src=\"https://code.jquery.com/jquery-3.3.1.slim.min.js\"></script>"+libJs :: ByteString -> Markup+libJs url = element_ "script" [Attr "src" url]
src/Web/Rep/Html/Input.hs view
@@ -1,273 +1,349 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# OPTIONS_GHC -Wall #-} -- | Common web page input elements, often with bootstrap scaffolding. module Web.Rep.Html.Input ( Input (..), InputType (..),+ markupInput,+ ToByteString (..), ) where -import Data.Text (split)-import Lucid-import Lucid.Base-import NumHask.Prelude hiding (for_)-import Web.Rep.Html+import Data.Bool+import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as C+import Data.Maybe+import Data.Text (Text)+import Data.Text.Encoding+import GHC.Generics+import MarkupParse +-- | Conversion to a 'ByteString'+class ToByteString a where+ -- | Convert a value to a strict ByteString+ toByteString :: a -> ByteString+ default toByteString :: (Show a) => a -> ByteString+ toByteString = strToUtf8 . show++instance ToByteString ByteString where+ toByteString = id++instance ToByteString Text where+ toByteString = encodeUtf8++instance ToByteString Int++instance ToByteString Integer++instance ToByteString Double++instance ToByteString Float++instance ToByteString Bool++instance (ToByteString a) => ToByteString [a] where+ toByteString xs = "[" <> C.intercalate "," (fmap toByteString xs) <> "]"+ -- | 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,- -- | name//key//id of the Input- inputId :: Text,- -- | type of html input- inputType :: InputType- }+data Input a = Input+ { -- | underlying value+ inputVal :: a,+ -- | label suggestion+ inputLabel :: Maybe ByteString,+ -- | name//key//id of the Input+ inputId :: ByteString,+ -- | type of html input+ inputType :: InputType+ } deriving (Eq, Show, Generic) -- | Various types of web page inputs, encapsulating practical bootstrap class functionality data InputType- = Slider [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 | 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 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+label :: AttrValue -> Maybe ByteString -> Markup+label i l = maybe mempty (elementc "label" [Attr "for" i, Attr "class" "col-sm col-form-label"]) l++-- | Convert an 'Input' to 'Markup' via a specific printer.+markupInput :: (a -> ByteString) -> Input a -> Markup+markupInput pr (Input v l i (Slider satts)) =+ element+ "div"+ [Attr "class" "row"]+ ( label i l+ <> element_+ "input"+ ( [ Attr "type" "range",+ Attr "class" "col-sm jsbClassEventChange",+ Attr "id" i,+ Attr "value" (pr v) ]- (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)+ <> satts+ )+ )+markupInput pr (Input v l i (SliderV satts)) =+ element+ "div"+ [Attr "class" "row", Attr "style" "align-items: center;"]+ ( label i l+ <> element_+ "input"+ ( [ Attr "type" "range",+ Attr "class" "col-sm jsbClassEventChange",+ Attr "id" i,+ Attr "value" (pr v),+ Attr "oninput" ("$('#sliderv" <> i <> "').html($(this).val())") ]- )- 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+ <> satts+ )+ <> elementc "span" [Attr "id" ("sliderv" <> i), Attr "class" "col-sm"] (pr v)+ )+markupInput pr (Input v l i TextBox) =+ element+ "div"+ [Attr "class" "form-floating"]+ ( element_+ "input"+ [ Attr "type" "text",+ Attr "class" "form-control jsbClassEventInput",+ Attr "id" i,+ Attr "value" (pr 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'+ <> label i l+ )+markupInput pr (Input v l i TextBox') =+ element+ "div"+ [Attr "class" "form-floating"]+ ( element_+ "input"+ [ Attr "type" "text",+ Attr "class" "form-control jsbClassEventFocusout",+ Attr "id" i,+ Attr "value" (pr v)+ ]+ <> label i l+ )+markupInput pr (Input v l i (TextArea rows)) =+ element+ "div"+ [Attr "class" "form-floating"]+ ( elementc+ "textarea"+ [ Attr "rows" (toByteString rows),+ Attr "class" "form-control jsbClassEventInput",+ Attr "id" i+ ]+ (pr v)+ <> label i l+ )+markupInput pr (Input v l i ColorPicker) =+ element+ "div"+ [Attr "class" "row"]+ ( label i l+ <> element_+ "input"+ [ Attr "type" "color",+ Attr "class" "form-control jsbClassEventInput",+ Attr "id" i,+ Attr "value" (pr v)+ ]+ )+markupInput _ (Input _ l i ChooseFile) =+ element+ "div"+ [Attr "class" "row"]+ ( label i l+ <> element_+ "input"+ [ Attr "type" "file",+ Attr "class" "form-control-file jsbClassEventChooseFile",+ Attr "id" i+ ]+ )+markupInput pr (Input v l i (Dropdown opts)) =+ element+ "div"+ [Attr "class" "row"]+ ( label i l+ <> element+ "select"+ [ Attr "class" "form-control jsbClassEventInput",+ Attr "id" i+ ]+ (mconcat opts')+ )+ where+ opts' =+ ( \o ->+ elementc+ "option"+ ( bool+ []+ [Attr "selected" "selected"]+ (o == pr v)+ )+ o )- 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- ]- opts'+ <$> opts+markupInput pr (Input vs l i (DropdownMultiple opts sep)) =+ element+ "div"+ [Attr "class" "row"]+ ( label i l+ <> element+ "select"+ [ Attr "class" "form-control 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 (pr vs)))+ )+ o )- 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)- )- <$> 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'+ <$> opts+markupInput pr (Input v l i (DropdownSum opts)) =+ element+ "div"+ [Attr "class" "row sumtype-group"]+ ( label i l+ <> element+ "select"+ [ Attr "class" "form-control jsbClassEventInput jsbClassEventShowSum",+ Attr "id" i+ ]+ (mconcat opts')+ )+ where+ opts' =+ ( \o ->+ elementc+ "option"+ (bool [] [Attr "selected" "selected"] (o == pr 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+markupInput pr (Input v l i (Datalist opts listId)) =+ element+ "div"+ [Attr "class" "row"]+ ( label i l+ <> element_+ "input"+ [ Attr "type" "text",+ Attr "class" "form-control 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 already+ -- , 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 == pr v) )- (toHtml o)+ o ) <$> opts- )- )- -- FIXME: How can you refactor to eliminate this polymorphic wart?- 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_ "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)+ )+markupInput _ (Input _ l i (Checkbox checked)) =+ element+ "div"+ [Attr "class" "form-check"]+ ( element+ "input"+ ( [ Attr "type" "checkbox",+ Attr "class" "form-check-input jsbClassEventCheckbox",+ Attr "id" i ]- )+ <> bool [] [Attr "checked" ""] checked+ )+ (maybe mempty (elementc "label" [Attr "for" i, Attr "class" "form-check-label"]) l)+ )+markupInput _ (Input _ l i (Toggle pushed)) =+ 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']) l+ <> bool [] [Attr "checked" ""] pushed+ )+ )+markupInput _ (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)+ ]+ ) - toHtmlRaw = toHtml+{-+markupInput _ (Input _ l i (Toggle pushed)) =+ maybe mempty (elementc "label" [Attr "for" i, Attr "class" "btn btn-primary"]) l+ <> element_+ "input"+ ( [ Attr "type" "checkbox",+ Attr "class" "btn-check jsbClassEventToggle",+ Attr "autocomplete" "off",+ Attr "id" i+ ]+ <> bool [] [Attr "checked" ""] pushed+ )+markupInput _ (Input _ l i Button) =+ elementc+ "button"+ [ Attr "type" "button",+ Attr "id" i,+ Attr "class" "btn btn-primary jsbClassEventButton"+ ]+ (fromMaybe "button" l)+-}
+ src/Web/Rep/Internal/FlatParse.hs view
@@ -0,0 +1,332 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- | flatparse parsing helpers+--+-- This module is exposed only for testing via doctest-parallel and is not intended to form part of the stable API.+module Web.Rep.Internal.FlatParse+ ( -- * Parsing+ runParserMaybe,+ runParserEither,+ runParser_,++ -- * Flatparse re-exports+ runParser,+ Parser,+ Result (..),++ -- * Parsers+ isWhitespace,+ ws_,+ ws,+ wss,+ nota,+ isa,+ sq,+ dq,+ wrappedDq,+ wrappedSq,+ wrappedQ,+ wrappedQNoGuard,+ eq,+ sep,+ bracketed,+ bracketedSB,+ wrapped,+ digit,+ digits,+ int,+ double,+ minus,+ signed,+ byteStringOf',+ comma,+ )+where++import Data.Bool+import Data.ByteString (ByteString)+import Data.Char hiding (isDigit)+import FlatParse.Basic hiding (cut, take)+import GHC.Exts+import Prelude hiding (replicate)++-- $setup+-- >>> :set -XTemplateHaskell+-- >>> :set -XOverloadedStrings+-- >>> import Web.Rep.Internal.FlatParse+-- >>> import FlatParse.Basic++-- | Run a Parser, throwing away leftovers. Nothing on 'Fail' or 'Err'.+--+-- >>> runParserMaybe ws "x"+-- Nothing+--+-- >>> runParserMaybe ws " x"+-- Just ' '+runParserMaybe :: Parser e a -> ByteString -> Maybe a+runParserMaybe p b = case runParser p b of+ OK r _ -> Just r+ Fail -> Nothing+ Err _ -> Nothing++-- | Run a Parser, throwing away leftovers. Returns Left on 'Fail' or 'Err'.+--+-- >>> runParserEither ws " x"+-- Right ' '+runParserEither :: (IsString e) => Parser e a -> ByteString -> Either e a+runParserEither p bs = case runParser p bs of+ Err e -> Left e+ OK a _ -> Right a+ Fail -> Left "uncaught parse error"++-- | Run parser, discards leftovers & throws an error on failure.+--+-- >>> runParser_ ws " "+-- ' '+runParser_ :: Parser String a -> ByteString -> a+runParser_ p bs = case runParser p bs of+ Err e -> error e+ OK a "" -> a+ OK _ _ -> error "leftovers"+ Fail -> error "uncaught parse error"++-- | Consume whitespace.+--+-- >>> runParser ws_ " \nx"+-- OK () "x"+--+-- >>> runParser ws_ "x"+-- OK () "x"+ws_ :: Parser e ()+ws_ =+ $( switch+ [|+ case _ of+ " " -> ws_+ "\n" -> ws_+ "\t" -> ws_+ "\r" -> ws_+ "\f" -> ws_+ _ -> pure ()+ |]+ )+{-# INLINE ws_ #-}++-- | \\n \\t \\f \\r and space+isWhitespace :: Char -> Bool+isWhitespace ' ' = True -- \x20 space+isWhitespace '\x0a' = True -- \n linefeed+isWhitespace '\x09' = True -- \t tab+isWhitespace '\x0c' = True -- \f formfeed+isWhitespace '\x0d' = True -- \r carriage return+isWhitespace _ = False+{-# INLINE isWhitespace #-}++-- | single whitespace+--+-- >>> runParser ws " \nx"+-- OK ' ' "\nx"+ws :: Parser e Char+ws = satisfy isWhitespace++-- | multiple whitespace+--+-- >>> runParser wss " \nx"+-- OK " \n" "x"+--+-- >>> runParser wss "x"+-- Fail+wss :: Parser e ByteString+wss = byteStringOf $ some ws++-- | Single quote+--+-- >>> runParserMaybe sq "'"+-- Just ()+sq :: ParserT st e ()+sq = $(char '\'')++-- | Double quote+--+-- >>> runParserMaybe dq "\""+-- Just ()+dq :: ParserT st e ()+dq = $(char '"')++-- | Parse whilst not a specific character+--+-- >>> runParser (nota 'x') "abcxyz"+-- OK "abc" "xyz"+nota :: Char -> Parser e ByteString+nota c = withSpan (skipMany (satisfy (/= c))) (\() s -> unsafeSpanToByteString s)+{-# INLINE nota #-}++-- | Parse whilst satisfying a predicate.+--+-- >>> runParser (isa (=='x')) "xxxabc"+-- OK "xxx" "abc"+isa :: (Char -> Bool) -> Parser e ByteString+isa p = withSpan (skipMany (satisfy p)) (\() s -> unsafeSpanToByteString s)+{-# INLINE isa #-}++-- | 'byteStringOf' but using withSpan internally. Doesn't seems faster...+byteStringOf' :: Parser e a -> Parser e ByteString+byteStringOf' p = withSpan p (\_ s -> unsafeSpanToByteString s)+{-# INLINE byteStringOf' #-}++-- | A single-quoted string.+wrappedSq :: Parser b ByteString+wrappedSq = $(char '\'') *> nota '\'' <* $(char '\'')+{-# INLINE wrappedSq #-}++-- | A double-quoted string.+wrappedDq :: Parser b ByteString+wrappedDq = $(char '"') *> nota '"' <* $(char '"')+{-# INLINE wrappedDq #-}++-- | A single-quoted or double-quoted string.+--+-- >>> runParserMaybe wrappedQ "\"quoted\""+-- Just "quoted"+--+-- >>> runParserMaybe wrappedQ "'quoted'"+-- Just "quoted"+wrappedQ :: Parser e ByteString+wrappedQ =+ wrappedDq+ <|> wrappedSq+{-# INLINE wrappedQ #-}++-- | A single-quoted or double-quoted wrapped parser.+--+-- >>> runParser (wrappedQNoGuard (many $ satisfy (/= '"'))) "\"name\""+-- OK "name" ""+--+-- Will consume quotes if the underlying parser does.+--+-- >>> runParser (wrappedQNoGuard (many anyChar)) "\"name\""+-- Fail+wrappedQNoGuard :: Parser e a -> Parser e a+wrappedQNoGuard p = wrapped dq p <|> wrapped sq p++-- | xml production [25]+--+-- >>> runParserMaybe eq " = "+-- Just ()+--+-- >>> runParserMaybe eq "="+-- Just ()+eq :: Parser e ()+eq = ws_ *> $(char '=') <* ws_+{-# INLINE eq #-}++-- | Some with a separator.+--+-- >>> runParser (sep ws (many (satisfy (/= ' ')))) "a b c"+-- OK ["a","b","c"] ""+sep :: Parser e s -> Parser e a -> Parser e [a]+sep s p = (:) <$> p <*> many (s *> p)++-- | Parser bracketed by two other parsers.+--+-- >>> runParser (bracketed ($(char '[')) ($(char ']')) (many (satisfy (/= ']')))) "[bracketed]"+-- OK "bracketed" ""+bracketed :: Parser e b -> Parser e b -> Parser e a -> Parser e a+bracketed o c p = o *> p <* c+{-# INLINE bracketed #-}++-- | Parser bracketed by square brackets.+--+-- >>> runParser bracketedSB "[bracketed]"+-- OK "bracketed" ""+bracketedSB :: Parser e [Char]+bracketedSB = bracketed $(char '[') $(char ']') (many (satisfy (/= ']')))++-- | Parser wrapped by another parser.+--+-- >>> runParser (wrapped ($(char '"')) (many (satisfy (/= '"')))) "\"wrapped\""+-- OK "wrapped" ""+wrapped :: Parser e () -> Parser e a -> Parser e a+wrapped x p = bracketed x x p+{-# INLINE wrapped #-}++-- | A single digit+--+-- >>> runParserMaybe digit "5"+-- Just 5+digit :: Parser e Int+digit = (\c -> ord c - ord '0') <$> satisfyAscii isDigit++-- | An (unsigned) 'Int' parser+--+-- >>> runParserMaybe int "567"+-- Just 567+int :: Parser e Int+int = do+ (place, n) <- chainr (\n (!place, !acc) -> (place * 10, acc + place * n)) digit (pure (1, 0))+ case place of+ 1 -> empty+ _ -> pure n++digits :: Parser e (Int, Int)+digits = do+ (place, n) <- chainr (\n (!place, !acc) -> (place * 10, acc + place * n)) digit (pure (1, 0))+ case place of+ 1 -> empty+ _ -> pure (place, n)++-- | A 'Double' parser. uiua does not parse .1 as a double.+--+-- >>> runParser double "1.234x"+-- OK 1.234 "x"+--+-- >>> runParser double "."+-- Fail+--+-- >>> runParser double "123"+-- OK 123.0 ""+--+-- >>> runParser double ".123"+-- Fail+--+-- >>> runParser double "123."+-- OK 123.0 "."+double :: Parser e Double+double = do+ (placel, nl) <- digits+ withOption+ ($(char '.') *> digits)+ ( \(placer, nr) ->+ case placel of+ 1 -> empty+ _ -> pure $ fromIntegral nl + fromIntegral nr / fromIntegral placer+ )+ ( case placel of+ 1 -> empty+ _ -> pure $ fromIntegral nl+ )++minus :: Parser e ()+minus = $(char '-') <|> byteString "¯"++-- | Parser for a signed prefix to a number. Unlike uiua, this parses '-' as a negative number prefix.+--+-- >>> runParser (signed double) "-1.234x"+-- OK (-1.234) "x"+--+-- >>> runParser (signed double) "¯1.234x"+-- OK (-1.234) "x"+signed :: (Num b) => Parser e b -> Parser e b+signed p = do+ m <- optional minus+ case m of+ Nothing -> p+ Just () -> negate <$> p++-- | Comma parser+--+-- >>> runParserMaybe comma ","+-- Just ()+comma :: Parser e ()+comma = $(char ',')
− src/Web/Rep/Mathjax.hs
@@ -1,156 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# OPTIONS_GHC -Wall #-}---- | mathjax functionality.------ some <https://docs.mathjax.org/en/latest/web/start.html mathjax> assets------ <https://math.meta.stackexchange.com/questions/5020/mathjax-basic-tutorial-and-quick-reference mathjax cheatsheet>------ FIXME: Mathjax inside svg doesn't quite work, and needs to be structured around the foreign object construct.-module Web.Rep.Mathjax- ( mathjaxPage,- mathjax27Page,- mathjaxSvgPage,- mathjax27SvgPage,- )-where--import Control.Lens-import Lucid-import NumHask.Prelude-import Text.InterpolatedString.Perl6-import Web.Rep.Page--mathjax3Lib :: Html ()-mathjax3Lib =- with- (script_ mempty)- [ src_ "https://cdn.jsdelivr.net/npm/mathjax@3/es5/tex-mml-svg.js",- id_ "MathJax-script",- async_ ""- ]--mathjax27Lib :: Html ()-mathjax27Lib =- with- (script_ mempty)- [ src_ "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-MML-AM_SVG"- ]--jqueryLib :: Html ()-jqueryLib =- with- (script_ mempty)- [ src_ "https://code.jquery.com/jquery-3.3.1.slim.min.js",- integrity_ "sha384-q8i/X+965DzO0rT7abK41JStQIAqVgRVzpbzo5smXKp4YfRvH+8abtTE1Pi6jizo",- crossorigin_ "anonymous"- ]---- | A 'Page' that loads mathjax-mathjaxPage :: Page-mathjaxPage =- mempty- & #jsGlobal .~ RepJsText scriptMathjaxConfig- & #libsJs- .~ [ mathjax3Lib- ]---- | A 'Page' that loads the mathjax 2.7 js library-mathjax27Page :: Page-mathjax27Page =- mempty- & #jsOnLoad .~ RepJsText scriptMathjaxConfig- & #libsJs- .~ [ mathjax27Lib- ]---- | A 'Page' that tries to enable mathjax inside svg (which is tricky).-mathjaxSvgPage :: Text -> Page-mathjaxSvgPage cl =- mempty- & #jsGlobal .~ RepJsText (scriptMathjaxConfigSvg cl)- & #libsJs- .~ [ mathjax3Lib,- jqueryLib- ]---- | A 'Page' that tries to enable mathjax 2.7 inside svg.-mathjax27SvgPage :: Text -> Page-mathjax27SvgPage cl =- mempty- & #jsGlobal .~ RepJsText (scriptMathjax27ConfigSvg cl)- & #libsJs- .~ [ mathjax27Lib,- jqueryLib- ]--scriptMathjaxConfig :: Text-scriptMathjaxConfig =- [q|-MathJax = {- tex: {- inlineMath: [ ['$','$'], ["\\(","\\)"] ]- }-};-|]---- | Mathjax applies within an svg element as normal, but results in an svg element inside a text element which is not allowed, hence the extra scripting.--- http://bl.ocks.org/larsenmtl/86077bddc91c3de8d3db6a53216b2f47-scriptMathjax27ConfigSvg :: Text -> Text-scriptMathjax27ConfigSvg cl =- [qq|- setTimeout(() => \{-- MathJax.Hub.Config(\{- tex2jax: \{- inlineMath: [ ['$','$'], ["\\(","\\)"] ],- processEscapes: true- }- });-- MathJax.Hub.Register.StartupHook("End", function() \{- setTimeout(() => \{- $('.{cl}').each(function()\{- var m = $('text>span>svg');- m.remove();- $(this).append(m);- });-- }, 1);- });- }, 1);-|]---- | Mathjax applies within an svg element as normal, but results in an svg element inside a text element which is not allowed, hence the extra scripting.--- http://bl.ocks.org/larsenmtl/86077bddc91c3de8d3db6a53216b2f47-scriptMathjaxConfigSvg :: Text -> Text-scriptMathjaxConfigSvg cl =- [qq|- window.MathJax = \{- tex: \{- inlineMath: [ ['$','$'], ["\\(","\\)"] ]- },- startup: \{- ready: () => \{- MathJax.startup.defaultReady();- MathJax.startup.promise.then(() => \{- var xs = document.querySelectorAll('.{cl}');- xs.forEach((x) =>- \{ x.querySelectorAll('text').forEach((t) =>- \{t.querySelectorAll('mjx-container>svg').forEach((s) =>- \{- Array.from(t.attributes).forEach((a) => s.setAttribute(a.name, a.value));- x.appendChild(s);- });- });- });- });- }- }- };-|]
src/Web/Rep/Page.hs view
@@ -1,17 +1,10 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}-{-# OPTIONS_HADDOCK hide, not-home #-} +-- | Representations of a web page, covering Html, CSS & JS artifacts. module Web.Rep.Page- ( -- $page- Page (..),+ ( Page (..), PageConfig (..), defaultPageConfig, Concerns (..),@@ -19,56 +12,39 @@ concernNames, PageConcerns (..), PageStructure (..),- PageRender (..),-- -- $css- Css,- RepCss (..),+ Css (..), renderCss,- renderRepCss,-- -- $js- JS (..),- RepJs (..),+ cssColorScheme,+ Js (..), onLoad,- renderRepJs,- parseJs,- renderJs,- )+ ) where -import qualified Clay-import Clay (Css)-import Control.Lens-import Data.Generics.Labels ()-import GHC.Show (show)-import Language.JavaScript.Parser-import Language.JavaScript.Parser.AST-import Language.JavaScript.Process.Minify-import Lucid-import NumHask.Prelude hiding (show)-import Text.InterpolatedString.Perl6+import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as C+import GHC.Generics+import MarkupParse+import Optics.Core -- | 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 ()],- -- | javascript library links- libsJs :: [Html ()],- -- | css- cssBody :: RepCss,- -- | javascript with global scope- jsGlobal :: RepJs,- -- | javascript included within the onLoad function- jsOnLoad :: RepJs,- -- | html within the header- htmlHeader :: Html (),- -- | body html- htmlBody :: Html ()- }+data Page = Page+ { -- | css library links+ libsCss :: Markup,+ -- | javascript library links+ libsJs :: Markup,+ -- | css+ cssBody :: Css,+ -- | javascript with global scope+ jsGlobal :: Js,+ -- | javascript included within the onLoad function+ jsOnLoad :: Js,+ -- | html within the header+ htmlHeader :: Markup,+ -- | body html+ htmlBody :: Markup+ } deriving (Show, Generic) instance Semigroup Page where@@ -83,19 +59,18 @@ (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 = (<>) -- | A web page typically is composed of some css, javascript and html. -- -- 'Concerns' abstracts this structural feature of a web page.-data Concerns a- = Concerns- { cssConcern :: a,- jsConcern :: a,- htmlConcern :: a- }+data Concerns a = Concerns+ { cssConcern :: a,+ jsConcern :: a,+ htmlConcern :: a+ } deriving (Eq, Show, Foldable, Traversable, Generic) instance Functor Concerns where@@ -126,25 +101,16 @@ = 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,- filenames :: Concerns FilePath,- localdirs :: [FilePath]- }+data PageConfig = PageConfig+ { concerns :: PageConcerns,+ structure :: PageStructure,+ renderStyle :: RenderStyle,+ filenames :: Concerns FilePath,+ localdirs :: [FilePath]+ } deriving (Show, Eq, Generic) -- | Default configuration is inline ecma and css, separate html header and body, minified code, with the suggested filename prefix.@@ -153,126 +119,27 @@ 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}};|]+renderCss :: RenderStyle -> Css -> ByteString+renderCss Compact = C.filter (\c -> c /= ' ' && c /= '\n') . cssByteString+renderCss _ = cssByteString --- | Convert 'Text' to 'JS', throwing an error on incorrectness.-parseJs :: Text -> JS-parseJs = JS . readJs . unpack+-- | Css snippet for reponsiveness to preferred color-scheme.+cssColorScheme :: Css+cssColorScheme =+ Css+ "{\n color-scheme: light dark;\n}\n{\n body {\n background-color: rgb(92%, 92%, 92%);\n color: rgb(5%, 5%, 5%);\n }\n}\n@media (prefers-color-scheme:dark) {\n body {\n background-color: rgb(5%, 5%, 5%);\n color: rgb(92%, 92%, 92%);\n }\n}" --- | 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+-- | Add the windows.onload assignment+onLoad :: Js -> Js+onLoad (Js t) = Js (" window.onload=function(){" <> t <> "};")
src/Web/Rep/Render.hs view
@@ -1,36 +1,38 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NoImplicitPrelude #-} -- | Page rendering module Web.Rep.Render ( renderPage, renderPageWith, renderPageHtmlWith,- renderPageAsText,+ renderPageAsByteString, renderPageToFile, renderPageHtmlToFile, ) where -import Control.Lens-import Lucid-import NumHask.Prelude+import Control.Monad+import Data.ByteString (ByteString)+import Data.ByteString qualified as B+import Data.Foldable+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)@@ -39,105 +41,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"])+ <> libsCss'+ <> cssInline+ <> 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+ cssInline+ <> libsCss'+ <> 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) (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 (toText $ renderPageHtmlWith pc page)+ B.writeFile file (markdown_ (view #renderStyle pc) Html $ renderPageHtmlWith pc page) -- | Render a Page as Text.-renderPageAsText :: PageConfig -> Page -> Concerns Text-renderPageAsText pc p =+renderPageAsByteString :: PageConfig -> Page -> Concerns ByteString+renderPageAsByteString pc p = case pc ^. #concerns of- Inline -> Concerns mempty mempty htmlt- Separated -> Concerns css js htmlt+ Inline -> Concerns mempty mempty (markdown_ (view #renderStyle pc) Html h)+ Separated -> Concerns css js (markdown_ (view #renderStyle pc) Html h) where- htmlt = toText h (css, js, h) = renderPageWith pc p--svgDocType :: Html ()-svgDocType = "?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<!DOCTYPE svg PUBLIC \"-//W3C//DTD SVG 1.1//EN\"\n \"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd\""--svgDefs :: Html () -> Html ()-svgDefs = term "defs"
src/Web/Rep/Server.hs view
@@ -1,21 +1,20 @@-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# OPTIONS_GHC -Wall #-} -- | Serve pages via 'ScottyM' module Web.Rep.Server- ( servePageWith+ ( servePageWith, ) where -import Control.Lens hiding (only)-import Lucid+import Control.Monad+import Control.Monad.Trans.Class+import Data.ByteString qualified as B+import Data.Text.Lazy (pack)+import MarkupParse import Network.Wai.Middleware.Static (addBase, noDots, only, staticPolicy)-import NumHask.Prelude hiding (get, replace)-import Web.Rep.Render+import Optics.Core hiding (only) import Web.Rep.Page+import Web.Rep.Render import Web.Scotty -- | serve a Page via a ScottyM@@ -25,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@@ -35,9 +34,9 @@ ( do lift $ writeFile' cssfp css lift $ writeFile' jsfp js- html $ renderText h+ html $ pack $ utf8ToStr $ markdown_ Compact Html h )- cssfp = pc ^. #filenames . #cssConcern- jsfp = pc ^. #filenames . #jsConcern- writeFile' fp s = unless (s == mempty) (writeFile fp s)+ cssfp = pc ^. #filenames % #cssConcern+ jsfp = pc ^. #filenames % #jsConcern+ writeFile' fp s = unless (s == mempty) (B.writeFile fp s) servedir = (\x -> middleware $ staticPolicy (noDots <> addBase x)) <$> pc ^. #localdirs
@@ -1,14 +1,8 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}-{-# OPTIONS_HADDOCK hide, not-home #-} +-- | A shared-element representation of web page communication. module Web.Rep.Shared- (- RepF (..),+ ( RepF (..), Rep, oneRep, SharedRepF (..),@@ -22,27 +16,28 @@ ) where -import Control.Lens-import Data.Generics.Labels ()-import qualified Data.HashMap.Strict as HashMap+import Control.Monad+import Control.Monad.State.Lazy+import Data.Biapplicative+import Data.ByteString (ByteString) import Data.HashMap.Strict (HashMap)-import GHC.Show (show)-import Lucid-import NumHask.Prelude hiding (show)+import Data.HashMap.Strict qualified as HashMap+import MarkupParse+import Optics.Core+import Optics.Zoom -- | -- Information contained in a web page can usually be considered to be isomorphic to a map of named values - a 'HashMap'. This is especially true when considering a differential of information contained in a web page. Looking at a page from the outside, it often looks like a streaming differential of a hashmap. -- -- 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)- }+data RepF r a = Rep+ { rep :: r,+ 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) =@@ -51,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 = (<>)@@ -80,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, MonadIO 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@@ -94,15 +90,13 @@ -- This is sometimes referred to as "observable sharing". See <http://hackage.haskell.org/package/data-reify data-reify> as another library that reifies this (pun intended), and provided the initial inspiration for this implementation. -- -- 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)- }+newtype SharedRepF m r a = SharedRep+ { 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@@ -118,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@@ -148,10 +142,11 @@ (f name a) ( \s -> ( s,- join- $ maybe (Left "lookup failed") Right- $ either (Left . (\x -> name <> ": " <> x)) Right . p <$>- HashMap.lookup name s+ join $+ maybe+ (Left "lookup failed")+ (Right . either (Left . (\x -> name <> ": " <> x)) Right . p)+ (HashMap.lookup name s) ) ) @@ -159,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@@ -169,27 +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,- join- $ maybe (Right $ Right d) Right- $ p <$>- HashMap.lookup name s+ ( HashMap.delete n s,+ join $+ 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)@@ -198,10 +191,9 @@ 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 pure (fa m)-
@@ -1,12 +1,8 @@ {-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# OPTIONS_GHC -Wall #-}-{-# OPTIONS_GHC -Wredundant-constraints #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_GHC -Wno-x-partial #-} -- | Various SharedRep instances for common html input elements. module Web.Rep.SharedReps@@ -14,6 +10,8 @@ repMessage, sliderI, slider,+ sliderV,+ sliderVI, dropdown, dropdownMultiple, datalist,@@ -23,15 +21,15 @@ textarea, checkbox, toggle,+ toggle_, button, chooseFile, maybeRep,- fiddle,- viaFiddle, accordionList, listMaybeRep, listRep, readTextbox,+ readTextbox_, defaultListLabels, repChoice, subtype,@@ -40,55 +38,56 @@ ) where -import Box.Cont ()-import Control.Lens-import Data.Attoparsec.Text hiding (take)-import qualified Data.HashMap.Strict as HashMap-import qualified Data.List as List-import Data.Text (intercalate)-import Lucid-import NumHask.Prelude hiding (intercalate, takeWhile)-import Text.InterpolatedString.Perl6+import Box.Codensity ()+import Control.Monad+import Control.Monad.State.Lazy+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.Maybe+import FlatParse.Basic hiding (take)+import MarkupParse+import Optics.Core hiding (element)+import Optics.Zoom import Web.Rep.Bootstrap-import Web.Rep.Html import Web.Rep.Html.Input+import Web.Rep.Internal.FlatParse import Web.Rep.Shared-import Web.Rep.Page-import qualified Prelude as P-import qualified Data.Attoparsec.Text as A+import Prelude as P -- $setup -- >>> :set -XOverloadedStrings -- | Create a sharedRep from an Input. repInput ::- (Monad m, ToHtml a) =>+ (Monad m) => -- | 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 a =- register (first pack . A.parseOnly p) pr (\n v -> toHtml $ #inputVal .~ v $ #inputId .~ n $ i) a+repInput p pr i = register p pr (\n v -> markupInput pr $ #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 p _ i def a =- message (first pack . A.parseOnly p) (\n v -> toHtml $ #inputVal .~ v $ #inputId .~ n $ i) a def+repMessage :: (Monad m) => (ByteString -> Either ByteString a) -> (a -> ByteString) -> Input a -> a -> a -> SharedRep m a+repMessage p pr i def a =+ message p (\n v -> markupInput pr $ #inputVal .~ v $ #inputId .~ n $ i) a def -- | double slider -- -- For Example, a slider between 0 and 1 with a step of 0.01 and a default value of 0.3 is: ----- >>> :t slider (Just "label") 0 1 0.01 0.3+-- > :t slider (Just "label") 0 1 0.01 0.3 -- slider (Just "label") 0 1 0.01 0.3 :: Monad m => SharedRep m Double slider :: (Monad m) =>- Maybe Text ->+ Maybe ByteString -> Double -> Double -> Double ->@@ -96,21 +95,42 @@ 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+--+-- For Example, a slider between 0 and 1 with a step of 0.01 and a default value of 0.3 is:+--+-- > :t slider (Just "label") 0 1 0.01 0.3+-- slider (Just "label") 0 1 0.01 0.3 :: Monad m => SharedRep m Double+sliderV ::+ (Monad m) =>+ Maybe ByteString ->+ Double ->+ Double ->+ Double ->+ Double ->+ SharedRep m Double+sliderV label l u s v =+ repInput+ (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 -- -- For Example, a slider between 0 and 1000 with a step of 10 and a default value of 300 is: ----- >>> :t sliderI (Just "label") 0 1000 10 300+-- > :t sliderI (Just "label") 0 1000 10 300 -- 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, ToByteString a) =>+ Maybe ByteString -> a -> a -> a ->@@ -118,61 +138,77 @@ 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))+ toByteString+ (Input v label mempty (Slider [Attr "min" (toByteString l), Attr "max" (toByteString u), Attr "step" (toByteString s)])) v +-- | integral slider with shown value+sliderVI ::+ (Monad m, P.Integral a, ToByteString a) =>+ Maybe ByteString ->+ a ->+ a ->+ a ->+ a ->+ SharedRep m a+sliderVI label l u s v =+ repInput+ (runParserEither (fromIntegral <$> int))+ toByteString+ (Input v label mempty (SliderV [Attr "min" (toByteString l), Attr "max" (toByteString u), Attr "step" (toByteString 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+-- > :t textbox (Just "label") "some 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) =>+ -- | 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@@ -185,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) =>+ -- | 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) =>+ (ByteString -> Either ByteString a) ->+ (a -> ByteString) ->+ Maybe ByteString ->+ [ByteString] -> a -> SharedRep m a dropdownSum p pr label opts v =@@ -230,39 +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))+ (Input v label mempty (Toggle v)) v +-- | a toggle button, with no label+toggle_ :: (Monad m) => Maybe ByteString -> Bool -> SharedRep m Bool+toggle_ label v =+ repInput+ (runParserEither ((== "true") <$> takeRest))+ (bool "false" "true")+ (Input v label mempty (Toggle v))+ 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 @@ -271,7 +316,7 @@ -- Hides the underlying content on Nothing maybeRep :: (Monad m) =>- Maybe Text ->+ Maybe ByteString -> Bool -> SharedRep m a -> SharedRep m (Maybe a)@@ -283,91 +328,93 @@ 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')+ (markupInput (strToUtf8 . show) (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)- <$> HashMap.lookup name s+ join $+ maybe+ (Left "HashMap.lookup failed")+ (Right . 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()\{- var vis = this.checked ? "block" : "none";- document.getElementById("{toggleId}").style.display = vis;-\}));-|]+ elementc+ "script"+ []+ ( "$('#"+ <> checkName+ <> "').on('change', (function(){"+ <> " var vis = this.checked ? \"block\" : \"none\";"+ <> " 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- $ first (accordion prefix open . zip labels)- $ foldr- (\a x -> bimap (:) (:) a <<*>> x)- (pure [])- (zipWith srf labels as)+ unshare $+ first (accordion prefix open . zip labels) $+ foldr+ (\a x -> bimap (:) (:) a <<*>> x)+ (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- $ first (accordionChecked prefix)- $ first (zipWith (\l (ch, a) -> (l, a, ch)) labels)- $ foldr- (\a x -> bimap (:) (:) a <<*>> x)- (pure [])- ( ( \(ch, a) ->- bimap- (,)- (,)- (checkf ch)- <<*>> bodyf a- )- <$> xs+ unshare $+ first+ ( accordionChecked prefix+ . zipWith (\l (ch, a) -> (l, a, ch)) labels )+ ( foldr+ ((\a x -> bimap (:) (:) a <<*>> x) . (\(ch, a) -> bimap (,) (,) (checkf ch) <<*>> bodyf a))+ (pure [])+ 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@@ -390,85 +437,69 @@ (defaultListLabels n) (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]+-- | A sensible default for the accordion row labels for a list+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, ToByteString a) => Maybe ByteString -> a -> SharedRep m (Either ByteString a)+readTextbox label v = parsed . utf8ToStr <$> textbox' label (toByteString v) where parsed str = case reads str of [(a, "")] -> Right a- _ -> 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")+ _badRead -> Left (strToUtf8 str) --- | 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'+-- | Parse from a textbox+--+-- Uses focusout so as not to spam the reader.+readTextbox_ :: (Monad m, Read a, ToByteString a) => Maybe ByteString -> a -> SharedRep m a+readTextbox_ label v = parsed . utf8ToStr <$> textbox' label (toByteString v)+ where+ parsed str =+ case reads str of+ [(a, "")] -> a+ _badRead -> error "bad read" -repChoice :: (Monad m) => Int -> [(Text, SharedRep m a)] -> SharedRep m a+-- | Dropdown representation of a multi-element list.+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 (\c t -> subtype c t0 t) 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 init full =- dropdownMultiple (A.takeWhile (`notElem` ([',']::[Char]))) id (Just "items") full init+repItemsSelect :: (Monad m) => [ByteString] -> [ByteString] -> SharedRep m [ByteString]+repItemsSelect initial full =+ 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 Html class.+subtype :: ByteString -> ByteString -> [Attr]+subtype origt t =+ [ Attr "class" "subtype ",+ Attr "data_sumtype" t,+ Attr "style" ("display:" <> bool "block" "none" (origt /= t))+ ]++addSubtype :: ByteString -> ByteString -> Markup -> Markup+addSubtype origt t (Markup trees) =+ Markup $+ fmap (fmap (\toke -> fromMaybe toke $ addAttrs (subtype origt t) toke)) trees
src/Web/Rep/Socket.hs view
@@ -1,310 +1,368 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# OPTIONS_GHC -Wall #-}-{-# OPTIONS_GHC -Wredundant-constraints #-}+{-# 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,- serveSocketBox,- sharedServer,- defaultSharedServer,- SocketConfig(..),- defaultSocketConfig, defaultSocketPage,- defaultInputCode,- defaultOutputCode,- Code(..),+ SocketConfig (..),+ defaultSocketConfig,+ serveSocketBox,+ CodeBox,+ CoCodeBox,+ CodeBoxConfig (..),+ defaultCodeBoxConfig,+ codeBox,+ codeBoxWith,+ serveRep,+ serveRepWithBox,+ replaceInput,+ replaceOutput,+ replaceOutput_,+ sharedStream,+ PlayConfig (..),+ defaultPlayConfig,+ repPlayConfig,+ servePlayStream,+ servePlayStreamWithBox,+ Code (..), code,- wrangle,+ console,+ val,+ replace,+ append,+ clean,+ webSocket,+ refreshJsbJs,+ preventEnter,+ runScriptJs, ) where -import qualified Network.WebSockets as WS import Box-import Box.Socket-import Control.Lens-import Control.Monad.Conc.Class as C+import Box.Websocket (serverApp)+import Control.Category ((>>>))+import Control.Concurrent.Async+import Control.Monad+import Control.Monad.State.Lazy+import Data.Bifunctor+import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as C+import Data.Functor.Contravariant import Data.HashMap.Strict as HashMap-import qualified Data.Text as Text-import NumHask.Prelude hiding (intercalate, replace)-import Text.InterpolatedString.Perl6-import Web.Rep.Html+import Data.Profunctor+import Data.Text (Text)+import Data.Text.Encoding+import FlatParse.Basic+import GHC.Generics+import MarkupParse+import Network.Wai.Handler.WebSockets+import Network.WebSockets qualified as WS+import Optics.Core hiding (element)+import Web.Rep.Bootstrap import Web.Rep.Page import Web.Rep.Server import Web.Rep.Shared-import Web.Rep.Bootstrap-import Web.Scotty hiding (get)-import qualified Data.Attoparsec.Text as A-import Network.Wai.Handler.WebSockets-import Lucid as L+import Web.Rep.SharedReps+import Web.Scotty (middleware, scotty) +-- | Page with all the trimmings for a sharedRep Box socketPage :: Page-socketPage = mempty & #jsOnLoad .~- mconcat- [ webSocket,- runScriptJs,- refreshJsbJs,- preventEnter- ]+socketPage =+ mempty+ & #jsOnLoad+ .~ mconcat+ [ webSocket,+ runScriptJs,+ refreshJsbJs,+ preventEnter+ ] +-- | Bootstrapped base page for a web socket.+defaultSocketPage :: Page+defaultSocketPage =+ bootstrapPage+ <> socketPage+ & set #cssBody cssColorScheme+ & 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),+ ("output", mempty)+ ]++-- | Socket configuration+--+-- >>> defaultSocketConfig+-- SocketConfig {host = "127.0.0.1", port = 9160, path = "/"}+data SocketConfig = SocketConfig+ { host :: Text,+ port :: Int,+ path :: Text+ }+ deriving (Show, Eq, Generic)++-- | official default+defaultSocketConfig :: SocketConfig+defaultSocketConfig = SocketConfig "127.0.0.1" 9160 "/"++-- | bidirectional websocket serving a 'Box' serveSocketBox :: SocketConfig -> Page -> Box IO Text Text -> IO () serveSocketBox cfg p b = scotty (cfg ^. #port) $ do middleware $ websocketsOr WS.defaultConnectionOptions (serverApp b) servePageWith "/" (defaultPageConfig "") p -sharedServer :: SharedRep IO a -> SocketConfig -> Page -> (Html () -> [Code]) -> (Either Text a -> IO [Code]) -> IO ()-sharedServer srep cfg p i o =- serveSocketBox cfg p <$.>- fromAction (backendLoop srep i o . wrangle)+-- | A common Box pattern. [Code] is typically committed to the websocket and key-value elements, representing changes to the shared objects that are in the Dom are emitted.+type CodeBox = Box IO [Code] (ByteString, ByteString) -defaultSharedServer :: (Show a) => SharedRep IO a -> IO ()-defaultSharedServer srep =- sharedServer srep defaultSocketConfig defaultSocketPage defaultInputCode defaultOutputCode+-- | Codensity CodeBox+type CoCodeBox = Codensity IO (Box IO [Code] (ByteString, ByteString)) -defaultSocketPage :: Page-defaultSocketPage =- bootstrapPage <>- socketPage &- #htmlBody- .~ divClass_- "container"- ( mconcat- [ divClass_ "row" (h1_ "web-rep testing"),- divClass_ "row" $ mconcat $ (\(t, h) -> divClass_ "col" (h2_ (toHtml t) <> L.with div_ [id_ t] h)) <$> sections- ]- )- where- sections = - [ ("input", mempty),- ("output", mempty)- ]+-- | Configuration for a CodeBox serving.+data CodeBoxConfig = CodeBoxConfig+ { codeBoxSocket :: SocketConfig,+ codeBoxPage :: Page,+ codeBoxCommitterQueue :: Queue [Code],+ codeBoxEmitterQueue :: Queue (ByteString, ByteString)+ }+ deriving (Generic) --- I am proud of this.-backendLoop ::- (MonadConc m) =>- SharedRep m a ->- -- | initial code to place html of the SharedRep- (Html () -> [Code]) ->- -- | output code- (Either Text a -> m [Code]) ->- Box m [Code] (Text, Text) -> m ()-backendLoop sr inputCode outputCode (Box c e) = flip evalStateT (0, HashMap.empty) $ do- -- you only want to run unshare once for a SharedRep- (Rep h fa) <- unshare sr- b <- lift $ commit c (inputCode h)- o <- step' fa- b' <- lift $ commit c o- when (b && b') (go fa)+-- | official default config.+defaultCodeBoxConfig :: CodeBoxConfig+defaultCodeBoxConfig = CodeBoxConfig defaultSocketConfig defaultSocketPage Single Single++-- | Turn a configuration into a live (Codensity) CodeBox+codeBoxWith :: CodeBoxConfig -> CoCodeBox+codeBoxWith cfg =+ fromActionWith+ (view #codeBoxEmitterQueue cfg)+ (view #codeBoxCommitterQueue cfg)+ ( serveSocketBox (view #codeBoxSocket cfg) (view #codeBoxPage cfg)+ . dimap (either (C.unpack >>> error) id . runParserEither parserJ . encodeUtf8) (mconcat . fmap (decodeUtf8 . code))+ )++-- | Turn the default configuration into a live (Codensity) CodeBox+codeBox :: CoCodeBox+codeBox = codeBoxWith defaultCodeBoxConfig++-- | serve a SharedRep+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 -> (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 :: 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 ByteString a -> [Code]+replaceOutput ea =+ case ea of+ Left err -> [Append "debug" err]+ 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 ByteString a -> [Code]+replaceOutput_ ea =+ case ea of+ Left _ -> []+ Right a -> [Replace "output" (strToUtf8 $ show a)]++-- | Stream a SharedRep+sharedStream ::+ (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+ (Rep h fa) <- unshare sr+ b <- lift $ commit ch h+ when b (go fa) where go fa = do- incoming <- lift $ emit e- modify (updateS incoming)- o <- step' fa- b <- lift $ commit c o- when b (go fa)- updateS Nothing s = s- updateS (Just (k,v)) s = second (insert k v) s+ e' <- lift $ emit e+ case e' of+ Nothing -> pure ()+ Just (k, v) -> do+ hmap <- snd <$> get+ let hmap' = insert k v hmap+ let (hmap'', r) = fa hmap'+ modify (second (const hmap''))+ b <- lift $ commit c r+ when b (go fa) - step' fa = do- s <- get- let (m', ea) = fa (snd s)- modify (second (const m'))- o <- lift $ outputCode ea- pure o+-- * Play -defaultInputCode :: Html () -> [Code]-defaultInputCode h = [Append "input" (toText h)]+-- | Configuration to control a (re)play of an emitter with a Gap (timing) element.+data PlayConfig = PlayConfig+ { playPause :: Bool,+ playSpeed :: Double,+ playFrame :: Int+ }+ deriving (Eq, Show, Generic) -defaultOutputCode :: (Monad m, Show a) => Either Text a -> m [Code]-defaultOutputCode ea =- pure $ case ea of- Left err -> [Append "debug" err]- Right a -> [Replace "output" (show a)]+-- | Start on pause at normal speed and at frame 0.+defaultPlayConfig :: PlayConfig+defaultPlayConfig = PlayConfig True 1 0 -wrangle :: Monad m => Box m Text Text -> Box m [Code] (Text,Text)-wrangle (Box c e) = Box c' e'- where- c' = listC $ contramap code c- e' = mapE (pure . either (const Nothing) Just) (parseE parserJ e)+-- | representation of a PlayConfig+repPlayConfig :: PlayConfig -> SharedRep IO PlayConfig+repPlayConfig cfg =+ PlayConfig+ <$> repPause (view #playPause cfg)+ <*> repSpeed (view #playSpeed cfg)+ <*> repFrame (view #playFrame cfg) +-- | representation of the playFrame in a PlayConfig+repFrame :: Int -> SharedRep IO Int+repFrame x = read . utf8ToStr <$> textbox (Just "frame") (strToUtf8 $ show x)++-- | representation of the playSpeed in a PlayConfig+repSpeed :: Double -> SharedRep IO Double+repSpeed x = sliderV (Just "speed") 0.5 100 0.5 x++-- | representation of the playPause toggle in a PlayConfig+repPause :: Bool -> SharedRep IO Bool+repPause initial = toggle_ (Just "play/pause") initial++-- | representation of a Bool reset button+repReset :: SharedRep IO Bool+repReset = button (Just "reset")++-- | Serve an emitter controlled by a PlayConfig representation, with an explicit CodeBox.+servePlayStreamWithBox :: PlayConfig -> CoEmitter IO (Gap, [Code]) -> CodeBox -> IO ()+servePlayStreamWithBox pcfg pipe (Box c e) = do+ (playBox, _) <- toBoxM (Latest (False, pcfg))+ race_+ (sharedStream ((,) <$> repReset <*> repPlayConfig pcfg) (contramap (\h -> [Replace "input" (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 ()++-- | Serve an emitter controlled by a PlayConfig representation.+servePlayStream :: PlayConfig -> CodeBoxConfig -> CoEmitter IO (Gap, [Code]) -> IO ()+servePlayStream pcfg cbcfg s = servePlayStreamWithBox pcfg s <$|> codeBoxWith cbcfg++-- * low-level JS conversions+ -- | {"event":{"element":"textid","value":"abcdees"}}-parserJ :: A.Parser (Text,Text)+parserJ :: Parser e (ByteString, ByteString) parserJ = do- _ <- A.string [q|{"event":{"element":"|]- e <- A.takeTill (=='"')- _ <- A.string [q|","value":"|]- v <- A.takeTill (=='"')- _ <- A.string [q|"}}|]- pure (e,v)+ _ <- $(string "{\"event\":{\"element\":\"")+ e <- byteStringOf $ some (satisfy (/= '"'))+ _ <- $(string "\",\"value\":\"")+ v <- byteStringOf $ some (satisfy (/= '"'))+ _ <- $(string "\"}}")+ pure (e, v) -- * code hooks+ -- * code messaging-data Code =- Replace Text Text |- Append Text Text |- Console Text |- Eval Text |- Val Text++-- | A simple schema for code that communicates changes to a Html page via JS code.+data Code+ = Replace ByteString ByteString+ | Append ByteString ByteString+ | Console ByteString+ | Eval ByteString+ | Val ByteString deriving (Eq, Show, Generic, Read) -code :: Code -> Text+-- | Convert 'Code' to a 'ByteString'+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}) |]+-- | write to the console+console :: ByteString -> ByteString+console t = " console.log(" <> t <> ") " -val :: Text -> Text-val t = [qc| jsb.ws.send({t}) |]+-- | send arbitrary byestrings.+val :: ByteString -> ByteString+val t = " 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}';- runScripts($container);- refreshJsb();- |]+ "\n var $container = document.getElementById('" <> d <> "');\n $container.innerHTML = '" <> clean t <> "';\n runScripts($container);\n refreshJsb();\n " -- | 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}';- runScripts($container);- refreshJsb();- |]+ "\n var $container = document.getElementById('" <> d <> "');\n $container.innerHTML += '" <> clean t <> "';\n runScripts($container);\n refreshJsb();\n " -clean :: Text -> Text+-- | Double backslash newline and single quotes.+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|-window.jsb = {ws: new WebSocket('ws://' + location.host + '/')};-jsb.event = function(ev) {- jsb.ws.send(JSON.stringify({event: ev}));-};-jsb.ws.onmessage = function(evt){ - eval('(function(){' + evt.data + '})()');-};-|]+ Js+ "\nwindow.jsb = {ws: new WebSocket('ws://' + location.host + '/')};\njsb.event = function(ev) {\n jsb.ws.send(JSON.stringify({event: ev}));\n};\njsb.ws.onmessage = function(evt){ \n eval('(function(){' + evt.data + '})()'); \n};\n" -- * scripts+ -- | Event hooks that may need to be reattached given dynamic content creation.-refreshJsbJs :: RepJs+refreshJsbJs :: Js refreshJsbJs =- RepJsText- [q|-function refreshJsb () {- $('.jsbClassEventInput').off('input');- $('.jsbClassEventInput').on('input', (function(){- jsb.event({ 'element': this.id, 'value': this.value});- }));- $('.jsbClassEventChange').off('change');- $('.jsbClassEventChange').on('change', (function(){- jsb.event({ 'element': this.id, 'value': this.value});- }));- $('.jsbClassEventFocusout').off('focusout');- $('.jsbClassEventFocusout').on('focusout', (function(){- jsb.event({ 'element': this.id, 'value': this.value});- }));- $('.jsbClassEventButton').off('click');- $('.jsbClassEventButton').on('click', (function(){- jsb.event({ 'element': this.id, 'value': this.value});- }));- $('.jsbClassEventToggle').off('click');- $('.jsbClassEventToggle').on('click', (function(){- jsb.event({ 'element': this.id, 'value': ('true' !== this.getAttribute('aria-pressed')).toString()});- }));- $('.jsbClassEventCheckbox').off('click');- $('.jsbClassEventCheckbox').on('click', (function(){- jsb.event({ 'element': this.id, 'value': this.checked.toString()});- }));- $('.jsbClassEventChooseFile').off('input');- $('.jsbClassEventChooseFile').on('input', (function(){- jsb.event({ 'element': this.id, 'value': this.files[0].name});- }));- $('.jsbClassEventShowSum').off('change');- $('.jsbClassEventShowSum').on('change', (function(){- var v = this.value;- $(this).parent('.sumtype-group').siblings('.subtype').each(function(i) {- if (this.dataset.sumtype === v) {- this.style.display = 'block';- } else {- this.style.display = 'none';- }- })- }));- $('.jsbClassEventChangeMultiple').off('change');- $('.jsbClassEventChangeMultiple').on('change', (function(){- jsb.event({ 'element': this.id, 'value': [...this.options].filter(option => option.selected).map(option => option.value).join(',')});- }));-};-|]+ Js+ "\nfunction refreshJsb () {\n $('.jsbClassEventInput').off('input');\n $('.jsbClassEventInput').on('input', (function(){\n jsb.event({ 'element': this.id, 'value': this.value});\n }));\n $('.jsbClassEventChange').off('change');\n $('.jsbClassEventChange').on('change', (function(){\n jsb.event({ 'element': this.id, 'value': this.value});\n }));\n $('.jsbClassEventFocusout').off('focusout');\n $('.jsbClassEventFocusout').on('focusout', (function(){\n jsb.event({ 'element': this.id, 'value': this.value});\n }));\n $('.jsbClassEventButton').off('click');\n $('.jsbClassEventButton').on('click', (function(){\n jsb.event({ 'element': this.id, 'value': this.value});\n }));\n $('.jsbClassEventToggle').off('click');\n $('.jsbClassEventToggle').on('click', (function(){\n jsb.event({ 'element': this.id, 'value': ('true' !== this.getAttribute('aria-pressed')).toString()});\n }));\n $('.jsbClassEventCheckbox').off('click');\n $('.jsbClassEventCheckbox').on('click', (function(){\n jsb.event({ 'element': this.id, 'value': this.checked.toString()});\n }));\n $('.jsbClassEventChooseFile').off('input');\n $('.jsbClassEventChooseFile').on('input', (function(){\n jsb.event({ 'element': this.id, 'value': this.files[0].name});\n }));\n $('.jsbClassEventShowSum').off('change');\n $('.jsbClassEventShowSum').on('change', (function(){\n var v = this.value;\n $(this).parent('.sumtype-group').siblings('.subtype').each(function(i) {\n if (this.dataset.sumtype === v) {\n this.style.display = 'block';\n } else {\n this.style.display = 'none';\n }\n })\n }));\n $('.jsbClassEventChangeMultiple').off('change');\n $('.jsbClassEventChangeMultiple').on('change', (function(){\n jsb.event({ 'element': this.id, 'value': [...this.options].filter(option => option.selected).map(option => option.value).join(',')});\n }));\n};\n" -- | prevent the Enter key from triggering an event-preventEnter :: RepJs+preventEnter :: Js preventEnter =- RepJs $- parseJs- [q|-window.addEventListener('keydown',function(e) {- if(e.keyIdentifier=='U+000A' || e.keyIdentifier=='Enter' || e.keyCode==13) {- if(e.target.nodeName=='INPUT' && e.target.type !== 'textarea') {- e.preventDefault();- return false;- }- }-}, true);-|]+ Js+ "\nwindow.addEventListener('keydown',function(e) {\n if(e.keyIdentifier=='U+000A' || e.keyIdentifier=='Enter' || e.keyCode==13) {\n if(e.target.nodeName=='INPUT' && e.target.type !== 'textarea') {\n e.preventDefault();\n return false;\n }\n }\n}, true);\n" -- | script injection js. -- -- See https://ghinda.net/article/script-tags/ for why this might be needed.-runScriptJs :: RepJs+runScriptJs :: Js runScriptJs =- RepJsText- [q|-function insertScript ($script) {- var s = document.createElement('script')- s.type = 'text/javascript'- if ($script.src) {- s.onload = callback- s.onerror = callback- s.src = $script.src- } else {- s.textContent = $script.innerText- }-- // re-insert the script tag so it executes.- document.head.appendChild(s)-- // clean-up- $script.parentNode.removeChild($script)-}+ Js+ "\nfunction insertScript ($script) {\n var s = document.createElement('script')\n s.type = 'text/javascript'\n if ($script.src) {\n s.onload = callback\n s.onerror = callback\n s.src = $script.src\n } else {\n s.textContent = $script.innerText\n }\n\n // re-insert the script tag so it executes.\n document.head.appendChild(s)\n\n // clean-up\n $script.parentNode.removeChild($script)\n}\n\nfunction runScripts ($container) {\n // get scripts tags from a node\n var $scripts = $container.querySelectorAll('script')\n $scripts.forEach(function ($script) {\n insertScript($script)\n })\n}\n" -function runScripts ($container) {- // get scripts tags from a node- var $scripts = $container.querySelectorAll('script')- $scripts.forEach(function ($script) {- insertScript($script)- })-}-|]+-- | Run a Parser, throwing away leftovers. Returns Left on 'Fail' or 'Err'.+runParserEither :: Parser ByteString a -> ByteString -> Either ByteString a+runParserEither p bs = case runParser p bs of+ Err e -> Left e+ OK a _ -> Right a+ Fail -> Left "uncaught parse error"
− stack.yaml
@@ -1,17 +0,0 @@-resolver: nightly-2020-11-19--packages:- - '.'--extra-deps:- - numhask-0.7.0.0- - protolude-0.3.0- - random-1.2.0- - splitmix-0.1.0.3- - numhask-space-0.7.0.0- - box-0.6.2- - box-socket-0.1.2--allow-newer: true--
− test/test.hs
@@ -1,92 +0,0 @@-{-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Main where--import Control.Lens-import Lucid-import NumHask.Prelude-import Test.DocTest-import Test.Tasty-import Test.Tasty.Hspec-import Web.Rep-import Web.Rep.Examples-import qualified Data.Text.IO as Text--generatePage :: FilePath -> FilePath -> PageConfig -> Page -> IO ()-generatePage dir stem pc =- renderPageToFile dir (#filenames .~ concernNames "" stem $ pc) --generatePages ::- Traversable t => FilePath -> t (FilePath, PageConfig, Page) -> IO ()-generatePages dir xs =- sequenceA_ $ (\(fp, pc, p) -> generatePage dir fp pc p) <$> xs--genTest :: FilePath -> IO ()-genTest dir =- void $ generatePages dir [("default", defaultPageConfig "default", page1), ("sep", cfg2, page2)]--testVsFile :: FilePath -> FilePath -> PageConfig -> Page -> IO Bool-testVsFile dir stem pc p = do- (t,t') <- textVsFile dir stem pc p- pure (t==t')--textVsFile- :: FilePath- -> FilePath- -> PageConfig- -> Page- -> IO (Concerns Text, Concerns Text)-textVsFile dir stem pc p = do- let names = concernNames "" stem- let pc' = #filenames .~ names $ pc- let t = renderPageAsText pc' p- case pc ^. #concerns of- Inline -> do- t' <- Text.readFile (dir <> names ^. #htmlConcern)- return (t, Concerns mempty mempty t')- Separated -> do- t' <- sequenceA $ Text.readFile . (dir <>) <$> names- return (t, t')--testsRender :: IO (SpecWith ())-testsRender =- return $- describe "Web.Rep.Render" $ do- it "run genTest 'test/canned/' to refresh canned files." True- it "renderPage mempty" $- renderText (renderPage mempty) `shouldBe`- "<!DOCTYPE HTML><html lang=\"en\"><head><meta charset=\"utf-8\"></head><body><script>window.onload=function(){}</script></body></html>"- let dir = "test/canned/"- it "renderPageToFile, renderPage (compared with default canned file)" $- testVsFile dir "default" (defaultPageConfig "default") page1 `shouldReturn` True- it "the various PageConfig's" $- testVsFile dir "sep" cfg2 page2 `shouldReturn` True--testsBootstrap :: IO (SpecWith ())-testsBootstrap =- return $- describe "Web.Rep.Bootstrap" $ do- it "bootstrapPage versus canned" $- toText (renderPage bootstrapPage) `shouldBe`- "<!DOCTYPE HTML><html lang=\"en\"><head><meta charset=\"utf-8\"><link crossorigin=\"anonymous\" href=\"https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/css/bootstrap.min.css\" integrity=\"sha384-ggOyR0iXCbMQv3Xipma34MD+dH/1fQ784/j6cY/iJTQUOhcWr7x9JvoRxT2MZw1T\" rel=\"stylesheet\"><meta charset=\"utf-8\"><meta content=\"width=device-width, initial-scale=1, shrink-to-fit=no\" name=\"viewport\"></head><body><script crossorigin=\"anonymous\" integrity=\"sha384-q8i/X+965DzO0rT7abK41JStQIAqVgRVzpbzo5smXKp4YfRvH+8abtTE1Pi6jizo\" src=\"https://code.jquery.com/jquery-3.3.1.slim.min.js\"></script><script crossorigin=\"anonymous\" integrity=\"sha384-UO2eT0CpHqdSJQ6hJty5KVphtPhzWj9WO1clHTMGa3JDZwrnQq4sF86dIHNDz0W1\" src=\"https://cdnjs.cloudflare.com/ajax/libs/popper.js/1.14.7/umd/popper.min.js\"></script><script crossorigin=\"anonymous\" integrity=\"sha384-JjSmVgyd0p3pXB1rRibZUAYoIIy6OrQ6VrjIEaFf/nJGzIxFDsf4x0xIM+B07jRM\" src=\"https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/js/bootstrap.min.js\"></script><script>window.onload=function(){}</script></body></html>"- it "accordion versus canned" $- ( toText .- runIdentity .- flip evalStateT 0 .- accordion "acctest" Nothing $- (\x -> (pack (show x), "filler")) <$> [1..2::Int]) `shouldBe`- "<div id=\"acctest1\" class=\" accordion m-1 \"><div class=\" card \"><div id=\"acctest2\" class=\" card-header p-0 \"><h2 class=\" m-0 \"><button data-toggle=\"collapse\" data-target=\"#acctest3\" aria-controls=\"acctest3\" type=\"button\" class=\" btn btn-link collapsed \" aria-expanded=\"false\">1</button></h2></div><div data-parent=\"#acctest1\" id=\"acctest3\" aria-labelledby=\"acctest2\" class=\" collapse \"><div class=\" card-body \">filler</div></div></div><div class=\" card \"><div id=\"acctest4\" class=\" card-header p-0 \"><h2 class=\" m-0 \"><button data-toggle=\"collapse\" data-target=\"#acctest5\" aria-controls=\"acctest5\" type=\"button\" class=\" btn btn-link collapsed \" aria-expanded=\"false\">2</button></h2></div><div data-parent=\"#acctest1\" id=\"acctest5\" aria-labelledby=\"acctest4\" class=\" collapse \"><div class=\" card-body \">filler</div></div></div></div>"---- The tests-tests :: IO TestTree-tests = testGroup "the tests" <$> sequence- [ testSpec "Web.Rep.Render" =<< testsRender- , testSpec "Web.Rep.Bootstrap" =<< testsBootstrap- ]--main :: IO ()-main = do- doctest ["src/Web/Rep/SharedReps.hs"]- defaultMain =<< tests
web-rep.cabal view
@@ -1,125 +1,119 @@-cabal-version: 2.4-name: web-rep-version: 0.7.2-synopsis: representations of a web page+cabal-version: 3.0+name: web-rep+version: 0.14.1.0+license: BSD-3-Clause+license-file: LICENSE+copyright: Tony Day (c) 2015 category: web-description: An applicative-based, shared-data representation of a web page. -bug-reports: https://github.com/tonyday567/web-page/issues-maintainer: Tony Day <tonyday567@gmail.com>-license: MIT-license-file: LICENSE.md-build-type: Simple-extra-source-files:- stack.yaml- readme.md+author: Tony Day+maintainer: Tony Day <tonyday567@gmail.com>+homepage: https://github.com/tonyday567/numhask#readme+bug-reports: https://github.com/tonyday567/web-page/issues+synopsis: representations of a web page+description:+ An applicative-based, shared-data representation of a web page. +build-type: Simple+tested-with:+ ghc ==9.10.2+ ghc ==9.12.3+ ghc ==9.14.1++extra-doc-files:+ ChangeLog.md+ readme.md++source-repository head+ 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+ -Widentities+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wpartial-fields+ -Wredundant-constraints++common ghc2024-additions+ default-extensions:+ DataKinds+ DerivingStrategies+ DisambiguateRecordFields+ ExplicitNamespaces+ GADTs+ LambdaCase+ MonoLocalBinds+ RoleAnnotations++common ghc2024-stanza+ if impl(ghc >=9.10)+ default-language:+ GHC2024+ else+ import: ghc2024-additions+ default-language:+ GHC2021+ library+ import: ghc-options-stanza+ import: ghc2024-stanza+ hs-source-dirs: src+ build-depends:+ async >=2.2.4 && <2.3,+ base >=4.14 && <5,+ bifunctors >=5.5.11 && <5.7,+ box >=0.9 && <0.10,+ box-socket >=0.5 && <0.6,+ bytestring >=0.11.3 && <0.13,+ flatparse >=0.3.5 && <0.6,+ markup-parse >=0.2 && <0.3,+ 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 && <1,+ text >=1.2 && <2.2,+ transformers >=0.5.6 && <0.7,+ unordered-containers >=0.2 && <0.3,+ wai-middleware-static >=0.9 && <0.10,+ wai-websockets >=3.0.1.2 && <3.1,+ websockets >=0.12 && <0.14,+ exposed-modules: Web.Rep Web.Rep.Bootstrap Web.Rep.Examples Web.Rep.Html Web.Rep.Html.Input- Web.Rep.Mathjax+ Web.Rep.Internal.FlatParse Web.Rep.Page Web.Rep.Render Web.Rep.Server Web.Rep.Shared Web.Rep.SharedReps Web.Rep.Socket- hs-source-dirs:- src- build-depends:- attoparsec >= 0.13.2 && < 0.14,- base >= 4.12 && <5,- box >= 0.6 && < 0.7,- box-socket >= 0.0.2 && < 0.2,- clay >= 0.13 && < 0.14,- concurrency >= 1.11,- generic-lens >= 1.1.0 && < 3.0,- interpolatedstring-perl6 >= 1.0.2 && < 1.1,- language-javascript >= 0.6.0 && < 0.8,- lens >= 4.17.1 && < 4.20,- lucid >= 2.9 && < 2.10,- mtl >= 2.2.2 && < 2.3,- network-simple >= 0.4.5 && < 0.4.6,- numhask >= 0.7 && < 0.8,- scotty >= 0.11.5 && < 0.13,- text >= 1.2.3 && < 1.3,- transformers >= 0.5.6 && < 0.6,- unordered-containers >= 0.2.10 && < 0.3,- wai-middleware-static >= 0.8.3,- wai-websockets >= 3.0.1.2,- websockets >= 0.12,- default-language: Haskell2010- default-extensions:- NegativeLiterals- NoImplicitPrelude- OverloadedStrings- UnicodeSyntax- ghc-options:- -Wall- -Wcompat- -Wincomplete-record-updates- -Wincomplete-uni-patterns- -Wredundant-constraints -executable rep-example+executable web-rep-example+ import: ghc-options-exe-stanza+ import: ghc-options-stanza+ import: ghc2024-stanza main-is: rep-example.hs- hs-source-dirs:- app+ hs-source-dirs: app build-depends:- base >= 4.12 && <5,- numhask >= 0.7 && < 0.8,- optparse-generic >= 1.3,+ base >=4.14 && <5,+ box >=0.9 && <0.10,+ markup-parse >=0.2 && <0.3,+ optics-core >=0.4 && <0.5,+ optparse-applicative >=0.17 && <0.20, web-rep,- default-language: Haskell2010- default-extensions:- NegativeLiterals- NoImplicitPrelude- OverloadedStrings- UnicodeSyntax- ghc-options:- -Wall- -Wcompat- -Wincomplete-record-updates- -Wincomplete-uni-patterns- -Wredundant-constraints- -funbox-strict-fields- -fforce-recomp- -threaded- -rtsopts- -with-rtsopts=-N--test-suite test- type: exitcode-stdio-1.0- main-is: test.hs- hs-source-dirs:- test- build-depends:- base >= 4.12 && <5,- doctest >= 0.16 && < 1.0,- lens >= 4.17 && < 4.20,- lucid >= 2.9.11 && < 2.10,- numhask >= 0.7 && < 0.8,- tasty >= 1.2.3 && < 1.3,- tasty-hspec >= 1.1.5 && < 1.2,- text >= 1.2.3 && < 1.3,- web-rep- default-language: Haskell2010- default-extensions:- NegativeLiterals- NoImplicitPrelude- OverloadedStrings- UnicodeSyntax- ghc-options:- -Wall- -Wcompat- -Wincomplete-record-updates- -Wincomplete-uni-patterns- -Wredundant-constraints- -funbox-strict-fields- -fforce-recomp- -threaded- -rtsopts- -with-rtsopts=-N