web-rep 0.2.0 → 0.3.0
raw patch · 16 files changed
+1039/−585 lines, 16 filesdep +doctestdep ~JuicyPixelsdep ~aesondep ~attoparsec
Dependencies added: doctest
Dependency ranges changed: JuicyPixels, aeson, attoparsec, bifunctors, box, clay, foldl, generic-lens, interpolatedstring-perl6, javascript-bridge, language-javascript, lens, lucid, lucid-svg, mmorph, mtl, optparse-generic, scotty, streaming, tasty, tasty-hspec, text, text-format, transformers, unordered-containers, wai, wai-extra, wai-middleware-static, web-rep
Files
- app/example.hs +2/−0
- readme.md +1/−5
- src/Web/Page.hs +85/−33
- src/Web/Page/Bootstrap.hs +9/−6
- src/Web/Page/Bridge.hs +5/−4
- src/Web/Page/Examples.hs +154/−95
- src/Web/Page/Html.hs +53/−34
- src/Web/Page/Html/Input.hs +239/−155
- src/Web/Page/Mathjax.hs +151/−0
- src/Web/Page/Render.hs +62/−56
- src/Web/Page/Server.hs +1/−0
- src/Web/Page/SharedReps.hs +76/−14
- src/Web/Page/Types.hs +148/−136
- stack.yaml +0/−2
- test/test.hs +4/−1
- web-rep.cabal +49/−44
app/example.hs view
@@ -220,6 +220,8 @@ ViaFiddle -> midViaFiddle (slider Nothing 0 10 0.01 4) servePageWith "/simple" (defaultPageConfig "page1") page1+ servePageWith "/mathjax" (defaultPageConfig "mathjax") pagemj+ servePageWith "/mathjaxsvg" (defaultPageConfig "mathjax") pagemjsvg servePageWith "/iro" (defaultPageConfig "iro") (testPage "iro" (pack . show $ midtype o) [ ("input", mempty)
readme.md view
@@ -3,13 +3,10 @@ Various functions and representations for a web page. --recipes----+The best way to understand functionality is via running the example app: ``` stack build --test --exec "$(stack path --local-install-root)/bin/page-example --midtype Prod" --file-watch-stack build web-rep:test:test --file-watch --ghc-options -freverse-errors ``` reference@@ -29,4 +26,3 @@ --- https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/eval#Do_not_ever_use_eval!-
src/Web/Page.hs view
@@ -1,41 +1,93 @@+-- | A haskell library for representing web pages.+--+-- This library is a collection of web page abstractions, together with a reimagining of <http://hackage.haskell.org/package/suavemente suavemente>.+--+-- 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.+--+-- See app/examples.hs and 'Web.Examples' for usage.+module Web.Page+ ( -- * Shared Representation+ RepF (..),+ Rep,+ oneRep,+ SharedRepF (..),+ SharedRep,+ Element (..),+ runOnce,+ zeroState, --- | haskell for web page representations+ -- * Web Page Components+ Page (..),+ PageConfig (..),+ defaultPageConfig,+ Concerns (..),+ suffixes,+ concernNames,+ PageConcerns (..),+ PageStructure (..),+ PageRender (..), -module Web.Page- ( module X- , Value(..)- , finally- , PixelRGB8(..)- , HashMap.HashMap(..)- , fromList- , void- , sequenceA_- , Text- , pack- , unpack- , bool- ) where+ -- * Css+ Css (..),+ PageCss (..),+ renderCss,+ renderPageCss, -import Web.Page.SharedReps as X-import Web.Page.Render as X-import Web.Page.Server as X-import Web.Page.Types as X-import Web.Page.Bridge as X-import Web.Page.Html as X-import Web.Page.Html.Input as X-import Web.Page.Bootstrap as X-import Text.InterpolatedString.Perl6 as X-import Control.Monad.Trans.State as X-import Data.Bifunctor as X+ -- * JS+ JS (..),+ PageJs (..),+ onLoad,+ renderPageJs,+ parseJs,+ renderJs,++ -- * re-export modules+ module Web.Page.SharedReps,+ module Web.Page.Render,+ module Web.Page.Server,+ module Web.Page.Bridge,+ module Web.Page.Html,+ module Web.Page.Html.Input,+ module Web.Page.Bootstrap,+ module Web.Page.Mathjax,++ -- * re-exports+ module X,+ Value (..),+ finally,+ PixelRGB8 (..),+ HashMap.HashMap (..),+ fromList,+ void,+ sequenceA_,+ Text,+ pack,+ unpack,+ bool,+ )+where++import Codec.Picture.Types (PixelRGB8 (..)) import Control.Applicative as X-import Data.Biapplicative as X import Control.Exception (finally)-import Data.Text.Lazy (toStrict)-import GHC.Exts (fromList)-import qualified Data.HashMap.Strict as HashMap-import Data.Aeson (Value(..))-import Codec.Picture.Types (PixelRGB8(..)) import Control.Monad+import Control.Monad.Trans.State as X+import Data.Aeson (Value (..))+import Data.Biapplicative as X+import Data.Bifunctor as X+import Data.Bool import Data.Foldable (sequenceA_)+import qualified Data.HashMap.Strict as HashMap import Data.Text (Text, pack, unpack)-import Data.Bool+import Data.Text.Lazy (toStrict)+import GHC.Exts (fromList)+import Text.InterpolatedString.Perl6 as X+import Web.Page.Bootstrap+import Web.Page.Bridge+import Web.Page.Html+import Web.Page.Html.Input+import Web.Page.Mathjax+import Web.Page.Render+import Web.Page.Server+import Web.Page.SharedReps+import Web.Page.Types
src/Web/Page/Bootstrap.hs view
@@ -4,27 +4,28 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wall #-} --- | some <https://getbootstrap.com/ bootstrap> assets+-- | Some <https://getbootstrap.com/ bootstrap> assets and functionality. module Web.Page.Bootstrap ( bootstrapPage, cardify, divClass_, accordion, accordionChecked,+ accordionCard, accordionCardChecked, accordion_, ) where +import Control.Monad.State+import Data.Bool+import Data.Functor.Identity+import Data.Text (Text) import Lucid import Lucid.Base-import Prelude import Web.Page.Html import Web.Page.Types-import Data.Text (Text)-import Control.Monad.State-import Data.Bool-import Data.Functor.Identity+import Prelude bootstrapCss :: [Html ()] bootstrapCss =@@ -95,6 +96,7 @@ divClass_ :: Text -> Html () -> Html () divClass_ t = with div_ [class__ t] +-- | A Html object based on the bootstrap accordion card concept. accordionCard :: Bool -> [Attribute] -> Text -> Text -> Text -> Text -> Html () -> Html () accordionCard collapse atts idp idh idb t0 b = with div_ ([class__ "card"] <> atts) $@@ -111,6 +113,7 @@ [id_ idb, class__ ("collapse" <> bool " show" "" collapse), makeAttribute "aria-labelledby" idh, data_ "parent" ("#" <> idp)] (with div_ [class__ "card-body"] b) +-- | A bootstrap accordion card attached to a checkbox. accordionCardChecked :: Bool -> Text -> Text -> Text -> Text -> Html () -> Html () -> Html () accordionCardChecked collapse idp idh idb label bodyhtml checkhtml = with div_ ([class__ "card"]) $
src/Web/Page/Bridge.hs view
@@ -4,6 +4,7 @@ {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -Wredundant-constraints #-} +-- | A streaming bridge between a web page and haskell. module Web.Page.Bridge ( bridgePage, append,@@ -26,9 +27,13 @@ import qualified Control.Foldl as L import Control.Lens import Control.Monad.Morph+import Control.Monad.State import Data.Aeson import Data.HashMap.Strict as HashMap import qualified Data.Text as Text+import Data.Text (Text, pack)+import Data.Text.Lazy (fromStrict)+import GHC.Conc import Lucid import Network.JavaScript (Application, Engine, JavaScript (..), addListener, command, send, start) import qualified Streaming.Prelude as S@@ -36,10 +41,6 @@ import Web.Page.Html import Web.Page.Types import Prelude hiding (init)-import Data.Text (Text, pack)-import Data.Text.Lazy (fromStrict)-import Control.Monad.State-import GHC.Conc -- | prevent the Enter key from triggering an event preventEnter :: PageJs
src/Web/Page/Examples.hs view
@@ -8,56 +8,80 @@ {-# OPTIONS_GHC -Wall #-} module Web.Page.Examples- ( page1- , page2- , cfg2- , RepExamples(..)- , repExamples- , Shape(..)- , fromShape- , toShape- , SumTypeExample(..)- , repSumTypeExample- , SumType2Example(..)- , repSumType2Example- , listExample- , listRepExample- , fiddleExample- ) where+ ( page1,+ page2,+ pagemj,+ pagemjsvg,+ 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 GHC.Generics import Lucid-import Prelude+import qualified Lucid.Svg as Svg import Web.Page-import qualified Clay-import GHC.Generics+import Prelude --- | simple page examples+-- | simple page example page1 :: Page page1 =- #htmlBody .~ button1 $- #cssBody .~ PageCss css1 $- #jsGlobal .~ mempty $- #jsOnLoad .~ click $- #libsCss .~ (libCss <$> cssLibs) $- #libsJs .~ (libJs <$> jsLibs) $- mempty+ #htmlBody .~ button1+ $ #cssBody .~ PageCss css1+ $ #jsGlobal .~ mempty+ $ #jsOnLoad .~ click+ $ #libsCss .~ (libCss <$> cssLibs)+ $ #libsJs .~ (libJs <$> jsLibs)+ $ mempty +-- | page with localised libraries page2 :: Page page2 =- #libsCss .~ (libCss <$> cssLibsLocal) $- #libsJs .~ (libJs <$> jsLibsLocal) $- page1+ #libsCss .~ (libCss <$> cssLibsLocal)+ $ #libsJs .~ (libJs <$> jsLibsLocal)+ $ page1 +htmlMathjaxExample :: HtmlT Identity ()+htmlMathjaxExample =+ p_ "double dollar:"+ <> p_ "$$\\sum_{i=0}^n i^2 = \\frac{(n^2+n)(2n+1)}{6}$$"+ <> p_ "single dollar:"+ <> p_ "$\\sum_{i=0}^n i^2 = \\frac{(n^2+n)(2n+1)}{6}$"++-- | simple mathjax formulae+pagemj :: Page+pagemj =+ #htmlBody .~ htmlMathjaxExample $+ mathjaxPage++-- | simple mathjax formulae inside an svg text element+pagemjsvg :: Page+pagemjsvg =+ (#htmlBody .~ (with Svg.svg11_ [Svg.height_ "400", Svg.width_ "400", Svg.viewBox_ "-20 -20 300 300"]) (with Svg.g_ [class_ "mathjaxsvg"] $ with Svg.text_ [size_ "10"] "inside text element (inside svg):\\(\\sum_{i=0}^n i^2 = \\frac{(n^2+n)(2n+1)}{6}\\)") <> p_ "outside svg:" <> p_ "\\(\\sum_{i=0}^n i^2 = \\frac{(n^2+n)(2n+1)}{6}\\)")+ (mathjaxSvgPage "mathjaxsvg")+ cfg2 :: PageConfig cfg2 =- #concerns .~ Separated $- #pageRender .~ Pretty $- #structure .~ Headless $- #localdirs .~ ["test/static"] $- #filenames .~ (("other/cfg2" <>) <$> suffixes) $- (defaultPageConfig "")+ #concerns .~ Separated+ $ #pageRender .~ Pretty+ $ #structure .~ Headless+ $ #localdirs .~ ["test/static"]+ $ #filenames .~ (("other/cfg2" <>) <$> suffixes)+ $ (defaultPageConfig "") cssLibs :: [Text] cssLibs =@@ -83,7 +107,9 @@ -- js click :: PageJs-click = PageJsText [q|+click =+ PageJsText+ [q| $('#btnGo').click( function() { $('#btnGo').toggleClass('on'); alert('bada bing!');@@ -97,31 +123,37 @@ [id_ "btnGo", Lucid.type_ "button"] ("Go " <> with i_ [class__ "fa fa-play"] mempty) -data RepExamples =- RepExamples- { repTextbox :: Text- , repTextarea :: Text- , repSliderI :: Int- , repSlider :: Double- , repCheckbox :: Bool- , repToggle :: Bool- , repDropdown :: Int- , repShape :: Shape- , repColor :: PixelRGB8- } deriving (Show, Eq, Generic)+-- | One of each sharedrep input instances.+data RepExamples+ = RepExamples+ { repTextbox :: Text,+ repTextarea :: Text,+ repSliderI :: Int,+ repSlider :: Double,+ repCheckbox :: Bool,+ repToggle :: Bool,+ repDropdown :: Int,+ repShape :: Shape,+ repColor :: PixelRGB8+ }+ deriving (Show, Eq, Generic) +-- | For a typed dropdown example. data Shape = SquareShape | CircleShape deriving (Eq, Show, Generic) +-- | shape parser toShape :: Text -> Shape toShape t = case t of "Circle" -> CircleShape "Square" -> SquareShape _ -> CircleShape +-- | shape printer fromShape :: Shape -> Text fromShape CircleShape = "Circle" fromShape SquareShape = "Square" +-- | one of each input SharedReps repExamples :: (Monad m) => SharedRep m RepExamples repExamples = do t <- textbox (Just "textbox") "sometext"@@ -130,7 +162,7 @@ ds' <- slider (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+ dr <- dropdown decimal (pack . show) (Just "dropdown") ((pack . show) <$> [1 .. 5 :: Int]) 3 drt <- toShape <$> dropdown takeText id (Just "shape") (["Circle", "Square"]) (fromShape SquareShape) col <- colorPicker (Just "color") (PixelRGB8 56 128 200) pure (RepExamples t ta n ds' c tog dr drt col)@@ -140,17 +172,31 @@ 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]+ 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]+ listRep+ (Just "listifyMaybe")+ "alm"+ (checkbox Nothing)+ (sliderI Nothing (0 :: Int) n 1)+ n+ 3+ [0 .. 4] fiddleExample :: Concerns Text-fiddleExample = Concerns mempty mempty- [q|+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> |] @@ -167,33 +213,39 @@ where repi = sliderI Nothing 0 20 1 defInt rept = textbox Nothing defText- repst = dropdownSum takeText id (Just "SumTypeExample")- ["SumInt", "SumOnly", "SumText"]- (sumTypeText defst)+ 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"))- ])-+ ( 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@@ -213,33 +265,40 @@ where repoi = sliderI Nothing 0 20 1 defInt repst = repSumTypeExample defi deft SumOnly- repst2 = dropdownSum takeText id (Just "SumType2Example")- ["SumOutside", "SumInside"]- (sumType2Text defst2)+ 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"))- ])-+ ( 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
src/Web/Page/Html.hs view
@@ -2,29 +2,34 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +-- | Key generators and miscellaneous html utilities.+--+-- Uses the lucid 'Lucid.Html'. module Web.Page.Html- ( class__- , toText- , genName- , genNamePre- , libCss- , libJs- , fromHex- , toHex- , Html- ) where+ ( class__,+ toText,+ genName,+ genNamePre,+ libCss,+ libJs,+ fromHex,+ toHex,+ HtmlT,+ Html,+ )+where -import Data.Text-import Lucid-import Prelude-import qualified Data.Text.Lazy as Lazy-import Codec.Picture.Types (PixelRGB8(..))+import Codec.Picture.Types (PixelRGB8 (..))+import Control.Monad.State import Data.Attoparsec.Text-import Numeric+import Data.Bool+import Data.Text import Data.Text.Format+import qualified Data.Text.Lazy as Lazy import Data.Text.Lazy.Builder (toLazyText)-import Control.Monad.State-import Data.Bool+import Lucid+import Numeric+import Prelude -- | FIXME: A horrible hack to separate class id's class__ :: Text -> Attribute@@ -37,7 +42,7 @@ -- | name supply for html elements genName :: (MonadState Int m) => m Text genName = do- modify (+1)+ modify (+ 1) (pack . show) <$> get -- | sometimes a number doesn't work properly in html (or js???), and an alpha prefix seems to help@@ -45,15 +50,18 @@ genNamePre pre = (pre <>) <$> genName -- | 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 ()-libCss url = link_- [ rel_ "stylesheet"- , href_ url- ]+libCss url =+ link_+ [ rel_ "stylesheet",+ 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 ()@@ -62,39 +70,50 @@ -- | convert from #xxxxxx to 'PixelRGB8' fromHex :: Parser PixelRGB8 fromHex =- (\((r,g),b) ->- PixelRGB8 (fromIntegral r) (fromIntegral g) (fromIntegral b)) .- (\(f,b) -> (f `divMod` (256 :: Int), b)) .- (`divMod` 256) <$>- (string "#" *> hexadecimal)+ ( \((r, g), b) ->+ PixelRGB8 (fromIntegral r) (fromIntegral g) (fromIntegral b)+ )+ . (\(f, b) -> (f `divMod` (256 :: Int), b))+ . (`divMod` 256)+ <$> (string "#" *> hexadecimal) -- | convert from 'PixelRGB8' to #xxxxxx toHex :: PixelRGB8 -> Text toHex (PixelRGB8 r g b) = "#"- <> justifyRight 2 '0' (Lazy.toStrict $ toLazyText $ hex r)- <> justifyRight 2 '0' (Lazy.toStrict $ toLazyText $ hex g)- <> justifyRight 2 '0' (Lazy.toStrict $ toLazyText $ hex b)+ <> justifyRight 2 '0' (Lazy.toStrict $ toLazyText $ hex r)+ <> justifyRight 2 '0' (Lazy.toStrict $ toLazyText $ hex g)+ <> justifyRight 2 '0' (Lazy.toStrict $ toLazyText $ hex b) --- 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 aro0und this.--- Hence orphans.+-- | 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 PixelRGB8 where+ toHtml = toHtml . toHex+ toHtmlRaw = toHtmlRaw . toHex instance ToHtml () where+ toHtml = const "()"- toHtmlRaw = const "()" + toHtmlRaw = const "()"
src/Web/Page/Html/Input.hs view
@@ -5,173 +5,254 @@ {-# LANGUAGE QuasiQuotes #-} {-# OPTIONS_GHC -Wall #-} +-- | Common web page input elements, often with bootstrap scaffolding. module Web.Page.Html.Input- ( Input(Input)- , InputType(..)- , scriptToggleShow- ) where+ ( Input (..),+ InputType (..),+ )+where +import Data.Bool+import Data.Maybe import Data.Text+import GHC.Generics import Lucid import Lucid.Base-import Prelude import Text.InterpolatedString.Perl6 import Web.Page.Html-import GHC.Generics-import Data.Bool-import Data.Maybe+import Prelude -- | something that might exist on a web page and be a front-end input to computations.-data Input a =- Input- { inputVal :: a- , inputLabel :: Maybe Text- , inputId :: Text- , inputType :: InputType- } deriving (Eq, Show, Generic)+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+ }+ deriving (Eq, Show, Generic) --- | various types of Inputs, that encapsulate practical bootstrap class functionality-data InputType =- Slider [Attribute] |- TextBox |- TextArea Int |- ColorPicker |- ChooseFile |- Dropdown [Text] |- DropdownSum [Text] |- Datalist [Text] Text |- Checkbox Bool |- Toggle Bool (Maybe Text) |- Button+-- | Various types of web page inputs, encapsulating practical bootstrap class functionality+data InputType+ = Slider [Attribute]+ | TextBox+ | TextArea Int+ | ColorPicker+ | ChooseFile+ | Dropdown [Text]+ | DropdownSum [Text]+ | Datalist [Text] Text+ | Checkbox Bool+ | Toggle Bool (Maybe Text)+ | Button deriving (Eq, Show, Generic) instance (ToHtml a) => ToHtml (Input a) where+ toHtml (Input v l i (Slider satts)) =- with div_ [class__ "form-group"]- ((maybe mempty (with label_ [for_ i] . toHtml) l) <>- input_- ([ type_ "range"- , class__ " form-control-range custom-range"- , id_ i- , value_ (pack $ show $ toHtml v)- ] <> satts) <>- scriptJsbEvent i "change")+ with+ div_+ [class__ "form-group"]+ ( (maybe mempty (with label_ [for_ i] . toHtml) l)+ <> input_+ ( [ type_ "range",+ class__ " form-control-range custom-range",+ id_ i,+ value_ (pack $ show $ toHtml v)+ ]+ <> satts+ )+ <> scriptJsbEvent i "change"+ ) toHtml (Input v l i TextBox) =- with div_ [class__ "form-group"]- ((maybe mempty (with label_ [for_ i] . toHtml) l) <>- input_- ([ type_ "text"- , class__ "form-control"- , id_ i- , value_ (pack $ show $ toHtml v)- ]) <>- scriptJsbEvent i "input")+ with+ div_+ [class__ "form-group"]+ ( (maybe mempty (with label_ [for_ i] . toHtml) l)+ <> input_+ ( [ type_ "text",+ class__ "form-control",+ id_ i,+ value_ (pack $ show $ toHtml v)+ ]+ )+ <> scriptJsbEvent i "input"+ ) toHtml (Input v l i (TextArea rows)) =- with div_ [class__ "form-group"]- (maybe mempty (with label_ [for_ i] . toHtml) l <>- (with textarea_- [ rows_ (pack $ show rows)- , class__ "form-control"- , id_ i- ] (toHtmlRaw v)- ) <>- scriptJsbEvent i "input")+ with+ div_+ [class__ "form-group"]+ ( maybe mempty (with label_ [for_ i] . toHtml) l+ <> ( with+ textarea_+ [ rows_ (pack $ show rows),+ class__ "form-control",+ id_ i+ ]+ (toHtmlRaw v)+ )+ <> scriptJsbEvent i "input"+ ) toHtml (Input v l i ColorPicker) =- with div_ [class__ "form-group"]- ((maybe mempty (with label_ [for_ i] . toHtml) l) <>- input_- ([ type_ "color"- , class__ "form-control"- , id_ i- , value_ (pack $ show $ toHtml v)- ]) <>- scriptJsbEvent i "input")+ with+ div_+ [class__ "form-group"]+ ( (maybe mempty (with label_ [for_ i] . toHtml) l)+ <> input_+ ( [ type_ "color",+ class__ "form-control",+ id_ i,+ value_ (pack $ show $ toHtml v)+ ]+ )+ <> scriptJsbEvent i "input"+ ) toHtml (Input _ l i ChooseFile) =- with div_ [class__ "form-group"]- (maybe mempty (with label_ [for_ i] . toHtml) l) <>- input_- ([ type_ "file"- , class__ "form-control-file"- , id_ i- ]) <>- scriptJsbChooseFile i+ with+ div_+ [class__ "form-group"]+ (maybe mempty (with label_ [for_ i] . toHtml) l)+ <> input_+ ( [ type_ "file",+ class__ "form-control-file",+ id_ i+ ]+ )+ <> scriptJsbChooseFile i toHtml (Input v l i (Dropdown opts)) =- with div_ [class__ "form-group"]- ((maybe mempty (with label_ [for_ i] . toHtml) l) <>- (with select_- [ class__ "form-control"- , id_ i- ] opts') <>- scriptJsbEvent i "input")+ with+ div_+ [class__ "form-group"]+ ( (maybe mempty (with label_ [for_ i] . toHtml) l)+ <> ( with+ select_+ [ class__ "form-control",+ id_ i+ ]+ opts'+ )+ <> scriptJsbEvent i "input"+ ) where- opts' = mconcat $- (\o -> with option_ (bool [] [selected_ "selected"]- (toText (toHtml o) == toText (toHtml v)))- (toHtml o)) <$> opts+ opts' =+ mconcat $+ ( \o ->+ with+ option_+ ( bool+ []+ [selected_ "selected"]+ (toText (toHtml o) == toText (toHtml v))+ )+ (toHtml o)+ )+ <$> opts toHtml (Input v l i (DropdownSum opts)) =- with div_ [class__ "form-group sumtype-group"]- ((maybe mempty (with label_ [for_ i] . toHtml) l) <>- (with select_- [ class__ "form-control"- , id_ i- ] opts') <>- scriptShowSum i <>- scriptJsbEvent i "input")+ with+ div_+ [class__ "form-group sumtype-group"]+ ( (maybe mempty (with label_ [for_ i] . toHtml) l)+ <> ( with+ select_+ [ class__ "form-control",+ id_ i+ ]+ opts'+ )+ <> scriptShowSum i+ <> scriptJsbEvent i "input"+ ) where- opts' = mconcat $- (\o -> with option_- (bool [] [selected_ "selected"] (toText (toHtml o) == toText (toHtml v)))- (toHtml o)) <$> opts+ 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"]- ((maybe mempty (with label_ [for_ i] . toHtml) l) <>- input_- [ type_ "text"- , class__ "form-control"- , 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_ (bool [] [selected_ "selected"]- (toText (toHtml o) == toText (toHtml v)))- (toHtml o)) <$> opts) <>- scriptJsbEvent i "input")+ with+ div_+ [class__ "form-group"]+ ( (maybe mempty (with label_ [for_ i] . toHtml) l)+ <> input_+ [ type_ "text",+ class__ "form-control",+ 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_+ ( bool+ []+ [selected_ "selected"]+ (toText (toHtml o) == toText (toHtml v))+ )+ (toHtml o)+ )+ <$> opts+ )+ <> scriptJsbEvent i "input"+ ) -- FIXME: How can you refactor to eliminate this polymorphic wart? toHtml (Input _ l i (Checkbox checked)) =- with div_ [class__ "form-check"]- (input_- ([ type_ "checkbox"- , class__ "form-check-input"- , id_ i- ] <>- bool [] [checked_] checked) <>- (maybe mempty (with label_ [for_ i, class__ "form-check-label"] . toHtml) l) <>- scriptJsbCheckbox i)+ with+ div_+ [class__ "form-check"]+ ( input_+ ( [ type_ "checkbox",+ class__ "form-check-input",+ id_ i+ ]+ <> bool [] [checked_] checked+ )+ <> (maybe mempty (with label_ [for_ i, class__ "form-check-label"] . toHtml) l)+ <> scriptJsbCheckbox i+ ) toHtml (Input _ l i (Toggle pushed lab)) =- with div_ [class__ "form-group"]- (( maybe mempty (with label_ [for_ i] . toHtml) l) <>- input_- ([ type_ "button"- , class__ "btn btn-primary btn-sm"- , data_ "toggle" "button"- , id_ i- , makeAttribute "aria-pressed" (bool "false" "true" pushed)- ] <>- (maybe [] (\l' -> [value_ l']) lab) <>- bool [] [checked_] pushed) <>- scriptJsbToggle i)+ with+ div_+ [class__ "form-group"]+ ( (maybe mempty (with label_ [for_ i] . toHtml) l)+ <> input_+ ( [ type_ "button",+ class__ "btn btn-primary btn-sm",+ data_ "toggle" "button",+ id_ i,+ makeAttribute "aria-pressed" (bool "false" "true" pushed)+ ]+ <> (maybe [] (\l' -> [value_ l']) lab)+ <> bool [] [checked_] pushed+ )+ <> scriptJsbToggle i+ ) toHtml (Input _ l i Button) =- with div_ [class__ "form-group"]- (input_- ( [ type_ "button"- , id_ i- , class__ "btn btn-primary btn-sm"- , value_ (fromMaybe "button" l)- ]) <>- scriptJsbButton i)+ with+ div_+ [class__ "form-group"]+ ( input_+ ( [ type_ "button",+ id_ i,+ class__ "btn btn-primary btn-sm",+ value_ (fromMaybe "button" l)+ ]+ )+ <> scriptJsbButton i+ ) toHtmlRaw = toHtml @@ -179,42 +260,54 @@ -- https://eager.io/blog/everything-I-know-about-the-script-tag/ scriptJsbEvent :: (Monad m) => Text -> Text -> HtmlT m ()-scriptJsbEvent name event = script_ [qq|+scriptJsbEvent name event =+ script_+ [qq| $('#{name}').on('{event}', (function()\{ jsb.event(\{ 'element': this.id, 'value': this.value\}); \})); |] scriptJsbButton :: (Monad m) => Text -> HtmlT m ()-scriptJsbButton name = script_ [qq|+scriptJsbButton name =+ script_+ [qq| $('#{name}').on('click', (function()\{ jsb.event(\{ 'element': this.id, 'value': this.value\}); \})); |] scriptJsbToggle :: (Monad m) => Text -> HtmlT m ()-scriptJsbToggle name = script_ [qq|+scriptJsbToggle name =+ script_+ [qq| $('#{name}').on('click', (function()\{ jsb.event(\{ 'element': this.id, 'value': (\"true\" !== this.getAttribute(\"aria-pressed\")).toString()\}); \})); |] scriptJsbCheckbox :: (Monad m) => Text -> HtmlT m ()-scriptJsbCheckbox name = script_ [qq|+scriptJsbCheckbox name =+ script_+ [qq| $('#{name}').on('click', (function()\{ jsb.event(\{ 'element': this.id, 'value': this.checked.toString()\}); \})); |] scriptJsbChooseFile :: (Monad m) => Text -> HtmlT m ()-scriptJsbChooseFile name = script_ [qq|+scriptJsbChooseFile name =+ script_+ [qq| $('#{name}').on('input', (function()\{ jsb.event(\{ 'element': this.id, 'value': this.files[0].name\}); \})); |] scriptShowSum :: (Monad m) => Text -> HtmlT m ()-scriptShowSum name = script_ [qq|+scriptShowSum name =+ script_+ [qq| $('#{name}').on('change', (function()\{ var v = this.value; $(this).parent('.sumtype-group').siblings('.subtype').each(function(i) \{@@ -224,13 +317,4 @@ this.style.display = 'none'; \}\}) \}));-|]---- | toggle show/hide-scriptToggleShow :: (Monad m) => Text -> Text -> HtmlT m ()-scriptToggleShow checkName toggleClass = script_ [qq|-$('#{checkName}').on('change', (function()\{- var vis = this.checked ? "block" : "none";- Array.from(document.getElementsByClassName({toggleClass})).forEach(x => x.style.display = vis);-\})); |]
+ src/Web/Page/Mathjax.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# 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.Page.Mathjax+ ( mathjaxPage,+ mathjax27Page,+ mathjaxSvgPage,+ mathjax27SvgPage,+ )+where++import Control.Lens+import Data.Text (Text)+import Lucid+import Text.InterpolatedString.Perl6+import Web.Page.Types+import Prelude++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+ & #jsOnLoad .~ PageJsText scriptMathjaxConfig+ & #libsJs+ .~ [ mathjax3Lib+ ]++-- | A 'Page' that loads the mathjax 2.7 js library+mathjax27Page :: Page+mathjax27Page =+ mempty+ & #jsOnLoad .~ PageJsText scriptMathjaxConfig+ & #libsJs+ .~ [ mathjax27Lib+ ]++-- | A 'Page' that tries to enable mathjax inside svg (which is tricky).+mathjaxSvgPage :: Text -> Page+mathjaxSvgPage cl =+ mempty+ & #jsGlobal .~ PageJsText (scriptMathjaxConfigSvg cl)+ & #libsJs+ .~ [ mathjax3Lib,+ jqueryLib+ ]++-- | A 'Page' that tries to enable mathjax 2.7 inside svg.+mathjax27SvgPage :: Text -> Page+mathjax27SvgPage cl =+ mempty+ & #jsGlobal .~ PageJsText (scriptMathjax27ConfigSvg cl)+ & #libsJs+ .~ [ mathjax27Lib,+ jqueryLib+ ]++scriptMathjaxConfig :: Text+scriptMathjaxConfig =+ [q|+{+MathJax.Hub.Config({+ tex2jax: {+ inlineMath: [ ['$','$'], ["\\(","\\)"] ],+ processEscapes: true+ }+ });+};+|]++-- | 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 = \{+ startup: \{+ ready: () => \{+ MathJax.startup.defaultReady();+ MathJax.startup.promise.then(() => \{+ $('.{cl}').each(function()\{+ var m = $('text>mjx-container>svg');+ m.remove();+ $(this).append(m);+ });+ });+ }+ }+ };+|]
src/Web/Page/Render.hs view
@@ -1,32 +1,33 @@ {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-} -- | Page rendering module Web.Page.Render- ( renderPage- , renderPageWith- , renderPageHtmlWith- , renderPageAsText- , renderPageToFile- , renderPageHtmlToFile- ) where+ ( renderPage,+ renderPageWith,+ renderPageHtmlWith,+ renderPageAsText,+ renderPageToFile,+ renderPageHtmlToFile,+ )+where import Control.Applicative import Control.Lens import Control.Monad+import Data.Foldable import Data.Monoid import Data.Text (Text)+import qualified Data.Text as Text import Data.Text.IO (writeFile) import Data.Text.Lazy (fromStrict, toStrict) import Data.Traversable import Lucid-import Prelude hiding (writeFile)+import qualified Lucid.Svg as Svg import Web.Page.Html import Web.Page.Types-import qualified Data.Text as Text-import qualified Lucid.Svg as Svg-import Data.Foldable+import Prelude hiding (writeFile) -- | Render a Page with the default configuration into Html. renderPage :: Page -> Html ()@@ -48,52 +49,58 @@ 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- ]))+ doctype_+ <> with+ html_+ [lang_ "en"]+ ( head_+ ( mconcat+ [ meta_ [charset_ "utf-8"],+ cssInline,+ mconcat libsCss',+ p ^. #htmlHeader+ ]+ )+ <> body_+ ( mconcat+ [ p ^. #htmlBody,+ mconcat libsJs',+ jsInline+ ]+ )+ ) Headless -> mconcat- [ doctype_- , meta_ [charset_ "utf-8"]- , mconcat libsCss'- , cssInline- , p ^. #htmlHeader- , p ^. #htmlBody- , mconcat libsJs'- , jsInline+ [ doctype_,+ meta_ [charset_ "utf-8"],+ mconcat libsCss',+ cssInline,+ p ^. #htmlHeader,+ p ^. #htmlBody,+ mconcat libsJs',+ jsInline ] Snippet -> mconcat- [ mconcat libsCss'- , cssInline- , p ^. #htmlHeader- , p ^. #htmlBody- , mconcat libsJs'- , jsInline+ [ mconcat libsCss',+ cssInline,+ p ^. #htmlHeader,+ p ^. #htmlBody,+ mconcat libsJs',+ jsInline ] Svg ->- Svg.doctype_ <>- svg_- (Svg.defs_ $- mconcat- [ mconcat libsCss'- , cssInline- , p ^. #htmlBody- , mconcat libsJs'- , jsInline- ])+ Svg.doctype_+ <> svg_+ ( Svg.defs_ $+ mconcat+ [ mconcat libsCss',+ cssInline,+ p ^. #htmlBody,+ mconcat libsJs',+ jsInline+ ]+ ) css = rendercss (p ^. #cssBody) js = renderjs (p ^. #jsGlobal <> onLoad (p ^. #jsOnLoad)) renderjs = renderPageJs $ pc ^. #pageRender@@ -108,14 +115,14 @@ case pc ^. #concerns of Inline -> p ^. #libsCss Separated ->- p ^. #libsCss <>- [libCss (Text.pack $ pc ^. #filenames . #cssConcern)]+ p ^. #libsCss+ <> [libCss (Text.pack $ pc ^. #filenames . #cssConcern)] libsJs' = case pc ^. #concerns of Inline -> p ^. #libsJs Separated ->- p ^. #libsJs <>- [libJs (Text.pack $ pc ^. #filenames . #jsConcern)]+ p ^. #libsJs+ <> [libJs (Text.pack $ pc ^. #filenames . #jsConcern)] -- | Render Page concerns to files. renderPageToFile :: FilePath -> PageConfig -> Page -> IO ()@@ -138,4 +145,3 @@ where htmlt = toText h (css, js, h) = renderPageWith pc p-
src/Web/Page/Server.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedLabels #-} {-# OPTIONS_GHC -Wall #-} +-- | Serve pages via 'ScottyM' module Web.Page.Server ( servePageWith ) where
@@ -2,10 +2,12 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -Wredundant-constraints #-} +-- | Various SharedRep instances for common html input elements. module Web.Page.SharedReps ( repInput, repMessage,@@ -34,22 +36,36 @@ import Box.Cont () import Codec.Picture.Types (PixelRGB8 (..)) import Control.Lens+import Control.Monad+import Control.Monad.Trans.State import Data.Attoparsec.Text hiding (take)+import Data.Biapplicative+import Data.Bool import qualified Data.HashMap.Strict as HashMap import Data.Text (Text, pack) import Lucid-import Prelude hiding (lookup)+import Text.InterpolatedString.Perl6 import Web.Page.Bootstrap import Web.Page.Html import Web.Page.Html.Input import Web.Page.Types-import Data.Biapplicative-import Control.Monad.Trans.State-import Control.Monad-import Data.Bool+import Prelude hiding (lookup) --- | create a sharedRep from an Input-repInput :: (Monad m, ToHtml a) => Parser a -> (a -> Text) -> Input a -> a -> SharedRep m a+-- $setup+-- >>> :set -XOverloadedStrings++-- | Create a sharedRep from an Input.+repInput ::+ (Monad m, ToHtml a) =>+ -- | Parser+ Parser a ->+ -- | Printer+ (a -> Text) ->+ -- | 'Input' type+ Input a ->+ -- | initial value+ a ->+ SharedRep m a repInput p pr i a = SharedRep $ do name <- zoom _1 genName@@ -65,7 +81,7 @@ ) ) --- | 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+-- | 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 = SharedRep $ do@@ -81,6 +97,12 @@ ) ) +-- | 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+-- slider (Just "label") 0 1 0.01 0.3 :: Monad m => SharedRep m Double slider :: (Monad m) => Maybe Text ->@@ -96,6 +118,13 @@ (Input v label mempty (Slider [min_ (pack $ show l), max_ (pack $ show u), step_ (pack $ show s)])) v +-- | integral slider+--+-- For Example, a slider between 0 and 1000 with a step of 10 and a default value of 300 is:+--+-- >>> :t sliderI (Just "label") 0 1000 10 300+-- sliderI (Just "label") 0 1000 10 300+-- :: (Monad m, ToHtml a, Integral a, Show a) => SharedRep m a sliderI :: (Monad m, ToHtml a, Integral a, Show a) => Maybe Text ->@@ -111,6 +140,10 @@ (Input v label mempty (Slider [min_ (pack $ show l), max_ (pack $ show u), step_ (pack $ show s)])) v +-- | textbox classique+--+-- >>> :t textbox (Just "label") "some text"+-- textbox (Just "label") "some text" :: Monad m => SharedRep m Text textbox :: (Monad m) => Maybe Text -> Text -> SharedRep m Text textbox label v = repInput@@ -119,6 +152,7 @@ (Input v label mempty TextBox) v +-- | textarea input element, specifying number of rows. textarea :: (Monad m) => Int -> Maybe Text -> Text -> SharedRep m Text textarea rows label v = repInput@@ -127,6 +161,7 @@ (Input v label mempty (TextArea rows)) v +-- | color input colorPicker :: (Monad m) => Maybe Text -> PixelRGB8 -> SharedRep m PixelRGB8 colorPicker label v = repInput@@ -135,12 +170,18 @@ (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) ->+ -- | label suggestion Maybe Text ->+ -- | list of dropbox elements (as text) [Text] ->+ -- | initial value a -> SharedRep m a dropdown p pr label opts v =@@ -150,6 +191,7 @@ (Input v label mempty (Dropdown opts)) v +-- | a datalist input datalist :: (Monad m) => Maybe Text -> [Text] -> Text -> Text -> SharedRep m Text datalist label opts v id'' = repInput@@ -158,6 +200,7 @@ (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 ->@@ -173,6 +216,7 @@ (Input v label mempty (DropdownSum opts)) v +-- | A checkbox input. checkbox :: (Monad m) => Maybe Text -> Bool -> SharedRep m Bool checkbox label v = repInput@@ -181,6 +225,7 @@ (Input v label mempty (Checkbox v)) v +-- | a toggle button toggle :: (Monad m) => Maybe Text -> Bool -> SharedRep m Bool toggle label v = repInput@@ -189,6 +234,7 @@ (Input v label mempty (Toggle v label)) v +-- | a button button :: (Monad m) => Maybe Text -> SharedRep m Bool button label = repMessage@@ -198,6 +244,7 @@ False False +-- | filename input chooseFile :: (Monad m) => Maybe Text -> Text -> SharedRep m Text chooseFile label v = repInput@@ -223,7 +270,9 @@ ) ) --- | represent a Maybe type using a checkbox hiding the underlying content on Nothing+-- | Represent a Maybe using a checkbox.+--+-- Hides the underlying content on Nothing maybeRep :: (Monad m) => Maybe Text ->@@ -250,7 +299,8 @@ ) mmap a b = bool Nothing (Just b) a --- | a (fixed-size) list represented in html as an accordion card+-- | 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 title prefix open srf labels as = SharedRep $ do (Rep h fa) <-@@ -263,7 +313,7 @@ h' <- zoom _1 h pure (Rep (maybe mempty (h5_ . toHtml) title <> h') fa) --- | a (fixed-sized) list of (Bool, a) tuples.+-- | 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 title prefix bodyf checkf labels xs = SharedRep $ do (Rep h fa) <-@@ -286,12 +336,12 @@ h' <- zoom _1 h pure (Rep (maybe mempty (h5_ . toHtml) title <> h') fa) --- | a fixed-sized list of Maybe a\'s+-- | 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 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.+-- | 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 ->@@ -318,10 +368,11 @@ (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] --- | representation of web concerns (css, js & html)+-- | Representation of web concerns (css, js & html). fiddle :: (Monad m) => Concerns Text -> SharedRep m (Concerns Text, Bool) fiddle (Concerns c j h) = bimap@@ -352,3 +403,14 @@ <<*>> jrep <<*>> hrep <<*>> sr'++-- | toggle show/hide+scriptToggleShow :: (Monad m) => Text -> Text -> HtmlT m ()+scriptToggleShow checkName toggleClass =+ script_+ [qq|+$('#{checkName}').on('change', (function()\{+ var vis = this.checked ? "block" : "none";+ Array.from(document.getElementsByClassName({toggleClass})).forEach(x => x.style.display = vis);+\}));+|]
src/Web/Page/Types.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TupleSections #-}+{-# OPTIONS_HADDOCK hide, not-home #-} module Web.Page.Types ( Page (..),@@ -39,8 +40,11 @@ import qualified Clay import Clay (Css (..))+import Control.Applicative import Control.Lens+import Control.Monad.IO.Class import Control.Monad.Morph+import Control.Monad.State import Data.Aeson import Data.Biapplicative import Data.Bifunctor (Bifunctor (..))@@ -57,13 +61,10 @@ import Lucid import Text.InterpolatedString.Perl6 import Prelude-import Control.Monad.State-import Control.Monad.IO.Class-import Control.Applicative -- | Components of a web page. ----- A web page typically can take many forms but still be the same web page. For example, css can be linked to in a separate file, or can be inline within html, but still be the same css. This type represents the practical components of what makes up 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@@ -100,9 +101,136 @@ mappend = (<>) --- | A web page typically is composed of css, javascript and html+-- | ----- 'Concerns' abstracts this compositional feature of a web page.+-- A key-value Text pair as the realistic datatype that zips across the interface between a page and haskell.+data Element+ = Element+ { element :: Text,+ value :: Text+ }+ deriving (Eq, Show, Generic)++instance ToJSON Element++instance FromJSON Element where+ parseJSON = withObject "Element" $ \v ->+ Element+ <$> v .: "element"+ <*> v .: "value"++-- |+-- 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)+ }+ deriving (Functor)++-- | the common usage, where the representation domain is Html+type Rep a = RepF (Html ()) a++instance (Semigroup r) => Semigroup (RepF r a) where+ (Rep r0 a0) <> (Rep r1 a1) =+ Rep+ (r0 <> r1)+ (\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 = Rep mempty (,Right mempty)++ mappend = (<>)++instance Bifunctor RepF where+ bimap f g (Rep r a) = Rep (f r) (second (fmap g) . a)++instance Biapplicative RepF where++ bipure r a = Rep r (,Right a)++ (Rep fr fa) <<*>> (Rep r a) =+ Rep+ (fr r)+ ( \hm ->+ let (hm', a') = a hm in let (hm'', fa') = fa hm' in (hm'', fa' <*> a')+ )++instance (Monoid r) => Applicative (RepF r) where++ pure = bipure mempty++ Rep fh fm <*> Rep ah am =+ Rep+ (fh <> ah)+ ( \hm ->+ let (hm', a') = am hm in let (hm'', fa') = fm hm' in (hm'', fa' <*> a')+ )++-- | 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 r@(Rep _ fa) action = do+ m <- get+ let (m', a) = fa m+ put m'+ lift $ action r m'+ pure (m', a)++-- |+-- Driven by the architecture of the DOM, web page components are compositional, and tree-like, where components are often composed of other components, and values are thus shared across components.+--+-- 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.+newtype SharedRepF m r a+ = SharedRep+ { unrep :: StateT (Int, HashMap Text Text) m (RepF r a)+ }+ deriving (Functor)++-- | default representation type of 'Html' ()+type SharedRep m a = SharedRepF m (Html ()) a++instance (Functor m) => Bifunctor (SharedRepF m) where+ bimap f g (SharedRep s) = SharedRep $ fmap (bimap f g) s++instance (Monad m) => Biapplicative (SharedRepF m) where++ bipure r a = SharedRep $ pure $ bipure r a++ (SharedRep f) <<*>> (SharedRep a) = SharedRep $ liftA2 (<<*>>) f a++instance (Monad m, Monoid r) => Applicative (SharedRepF m r) where++ pure = bipure mempty++ SharedRep f <*> SharedRep a = SharedRep $ liftA2 (<*>) f a++-- | compute the initial state of a SharedRep (testing)+zeroState ::+ (Monad m) =>+ SharedRep m a ->+ m (Html (), (HashMap Text Text, Either Text a))+zeroState sr = do+ (Rep h fa, (_, m)) <- flip runStateT (0, HashMap.empty) $ unrep sr+ pure (h, fa m)++-- | Compute the initial state of a SharedRep and then run an action once (see tests).+runOnce ::+ (Monad m) =>+ SharedRep m a ->+ (Html () -> HashMap Text Text -> m ()) ->+ m (HashMap Text Text, Either Text a)+runOnce sr action = do+ (Rep h fa, (_, m)) <- flip runStateT (0, HashMap.empty) $ unrep sr+ action h m+ pure (fa m)++-- | 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,@@ -120,16 +248,16 @@ Concerns f g h <*> Concerns a b c = Concerns (f a) (g b) (h c) --- | the common file suffixes of the three concerns+-- | The common file suffixes of the three concerns. suffixes :: Concerns FilePath suffixes = Concerns ".css" ".js" ".html" --- | create filenames for each Concern element.+-- | Create filenames for each Concern element. concernNames :: FilePath -> FilePath -> Concerns FilePath concernNames dir stem = (\x -> dir <> stem <> x) <$> suffixes --- | Is the rendering to include all Concerns or be separated?+-- | Is the rendering to include all 'Concerns' (typically in a html file) or be separated (tyypically into separate files and linked in the html file)? data PageConcerns = Inline | Separated@@ -150,7 +278,7 @@ | NoPost deriving (Show, Eq, Generic) --- | Configuration of the rendering of a web page+-- | Configuration options when rendering a 'Page'. data PageConfig = PageConfig { concerns :: PageConcerns,@@ -161,6 +289,7 @@ } deriving (Show, Eq, Generic) +-- | Default configuration is inline ecma and css, separate html header and body, minified code, with the suggested filename prefix. defaultPageConfig :: FilePath -> PageConfig defaultPageConfig stem = PageConfig@@ -170,7 +299,7 @@ ((stem <>) <$> suffixes) [] --- | unifies css as a Clay.Css and css as Text+-- | Unifies css as either a 'Clay.Css' or as Text. data PageCss = PageCss Clay.Css | PageCssText Text deriving (Generic) instance Show PageCss where@@ -191,19 +320,17 @@ mappend = (<>) --- | render PageCss as text+-- | Render 'PageCss' as text. renderPageCss :: PageRender -> PageCss -> Text renderPageCss Minified (PageCss css) = toStrict $ Clay.renderWith Clay.compact [] css renderPageCss _ (PageCss css) = toStrict $ Clay.render css renderPageCss _ (PageCssText css) = css --- | render Css as text+-- | Render 'Css' as text. renderCss :: Css -> Text renderCss = toStrict . Clay.render --- javascript types---- | wrapper for JSAST+-- | wrapper for `JSAST` newtype JS = JS {unJS :: JSAST} deriving (Show, Eq, Generic) instance Semigroup JS where@@ -246,7 +373,7 @@ mappend = (<>) --- | unify JSStatement javascript and text-rendered script+-- | Unifies javascript as 'JSStatement' and script as 'Text'. data PageJs = PageJs JS | PageJsText Text deriving (Eq, Show, Generic) instance Semigroup PageJs where@@ -263,7 +390,7 @@ mappend = (<>) --- | wrap js in standard DOM window loader+-- | Wrap js in standard DOM window loader. onLoad :: PageJs -> PageJs onLoad (PageJs js) = PageJs $ onLoadStatements [toStatement js] onLoad (PageJsText js) = PageJsText $ onLoadText js@@ -280,131 +407,16 @@ onLoadText :: Text -> Text onLoadText t = [qc| window.onload=function()\{{t}};|] --- | convert text to JS+-- | Convert 'Text' to 'JS', throwing an error on incorrectness. parseJs :: Text -> JS parseJs = JS . readJs . Text.unpack --- | render JS as text+-- | Render 'JS' as 'Text'. renderJs :: JS -> Text renderJs = toStrict . renderToText . unJS --- | render PageJs as text+-- | Render 'PageJs' as 'Text'. renderPageJs :: PageRender -> PageJs -> Text renderPageJs _ (PageJsText js) = js renderPageJs Minified (PageJs js) = toStrict . renderToText . minifyJS . unJS $ js renderPageJs Pretty (PageJs js) = toStrict . renderToText . unJS $ js---- | Abstracted message event element-data Element- = Element- { element :: Text,- value :: Text- }- deriving (Eq, Show, Generic)--instance ToJSON Element--instance FromJSON Element where- parseJSON = withObject "Element" $ \v ->- Element- <$> v .: "element"- <*> v .: "value"--data RepF r a- = Rep- { rep :: r,- make :: HashMap Text Text -> (HashMap Text Text, Either Text a)- }- deriving (Functor)--type Rep a = RepF (Html ()) a--instance (Semigroup r) => Semigroup (RepF r a) where- (Rep r0 a0) <> (Rep r1 a1) =- Rep- (r0 <> r1)- (\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 = Rep mempty (,Right mempty)-- mappend = (<>)--instance Bifunctor RepF where- bimap f g (Rep r a) = Rep (f r) (second (fmap g) . a)--instance Biapplicative RepF where-- bipure r a = Rep r (,Right a)-- (Rep fr fa) <<*>> (Rep r a) =- Rep- (fr r)- ( \hm ->- let (hm', a') = a hm in let (hm'', fa') = fa hm' in (hm'', fa' <*> a')- )--instance (Monoid r) => Applicative (RepF r) where-- pure = bipure mempty-- Rep fh fm <*> Rep ah am =- Rep- (fh <> ah)- ( \hm ->- let (hm', a') = am hm in let (hm'', fa') = fm hm' in (hm'', fa' <*> a')- )--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 r@(Rep _ fa) action = do- m <- get- let (m', a) = fa m- put m'- lift $ action r m'- pure (m', a)--newtype SharedRepF m r a- = SharedRep- { unrep :: StateT (Int, HashMap Text Text) m (RepF r a)- }- deriving (Functor)--type SharedRep m a = SharedRepF m (Html ()) a--instance (Functor m) => Bifunctor (SharedRepF m) where- bimap f g (SharedRep s) = SharedRep $ fmap (bimap f g) s--instance (Monad m) => Biapplicative (SharedRepF m) where-- bipure r a = SharedRep $ pure $ bipure r a-- (SharedRep f) <<*>> (SharedRep a) = SharedRep $ liftA2 (<<*>>) f a--instance (Monad m, Monoid r) => Applicative (SharedRepF m r) where-- pure = bipure mempty-- SharedRep f <*> SharedRep a = SharedRep $ liftA2 (<*>) f a---- | compute the initial state of a SharedRep (testing)-zeroState ::- (Monad m) =>- SharedRep m a ->- m (Html (), (HashMap Text Text, Either Text a))-zeroState sr = do- (Rep h fa, (_, m)) <- flip runStateT (0, HashMap.empty) $ unrep sr- pure (h, fa m)---- | compute the initial state of a SharedRep and then run a single action (testing)-runOnce ::- (Monad m) =>- SharedRep m a ->- (Html () -> HashMap Text Text -> m ()) ->- m (HashMap Text Text, Either Text a)-runOnce sr action = do- (Rep h fa, (_, m)) <- flip runStateT (0, HashMap.empty) $ unrep sr- action h m- pure (fa m)--- renderHtml :: Html a -> Text--- renderHtml = toText
stack.yaml view
@@ -7,5 +7,3 @@ - lucid-svg-0.7.1 - box-0.1.0 - javascript-bridge-0.2.0--allow-newer: true
test/test.hs view
@@ -6,6 +6,7 @@ import Control.Lens import Lucid import Prelude+import Test.DocTest import Test.Tasty import Test.Tasty.Hspec import Web.Page@@ -152,4 +153,6 @@ ] main :: IO ()-main = defaultMain =<< tests+main = do+ doctest ["src/Web/Page/SharedReps.hs"]+ defaultMain =<< tests
web-rep.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.12 name: web-rep-version: 0.2.0+version: 0.3.0 synopsis: representations of a web page category: web description: An applicative-based, shared-data representation of a web page. @@ -21,6 +21,7 @@ Web.Page.Examples Web.Page.Html Web.Page.Html.Input+ Web.Page.Mathjax Web.Page.Render Web.Page.SharedReps Web.Page.Server@@ -28,30 +29,33 @@ hs-source-dirs: src build-depends:- JuicyPixels- , aeson- , attoparsec- , base >= 4.12 && <5- , bifunctors- , box- , clay- , foldl- , generic-lens- , interpolatedstring-perl6- , javascript-bridge- , language-javascript- , lens- , lucid- , lucid-svg- , mmorph- , mtl- , scotty- , streaming- , text- , text-format- , transformers- , unordered-containers- , wai-middleware-static+ base >= 4.12 && <5,+ JuicyPixels >= 3.3.4 && < 3.4,+ aeson >= 1.4.5 && < 1.5,+ attoparsec >= 0.13.2 && < 0.14,+ bifunctors >= 5.5.5 && < 5.6,+ box >= 0.1.0 && < 0.2,+ clay >= 0.13 && < 0.14,+ foldl >= 1.4.5 && < 1.5,+ generic-lens >= 1.1.0 && < 1.3,+ interpolatedstring-perl6 >= 1.0.2 && < 1.1,+ javascript-bridge >= 0.2.0 && < 0.3,+ language-javascript >= 0.6.0 && < 0.8,+ lens >= 4.17.1 && < 4.19,+ lucid >= 2.9 && < 2.10,+ lucid-svg >= 0.7.1 && < 0.8,+ mmorph >= 1.1.3 && < 1.2,+ mtl >= 2.2.2 && < 2.3,+ optparse-generic >= 1.3 && < 1.4,+ scotty >= 0.11.5 && < 0.12,+ streaming >= 0.2.3 && < 0.3,+ text >= 1.2.3 && < 1.3,+ text-format >= 0.3.2 && < 0.4,+ transformers >= 0.5.6 && < 0.6,+ unordered-containers >= 0.2.10 && < 0.3,+ wai >= 3.2.2 && < 3.3,+ wai-extra >= 3.0 && < 3.1,+ wai-middleware-static >= 0.8.2 && < 0.9 default-language: Haskell2010 executable page-example@@ -60,18 +64,18 @@ app ghc-options: -funbox-strict-fields -fforce-recomp -threaded -rtsopts -with-rtsopts=-N build-depends:- attoparsec- , base >= 4.12 && <5- , box- , lens- , lucid- , optparse-generic- , scotty- , text- , wai- , wai-extra- , wai-middleware-static- , web-rep+ base >= 4.12 && <5,+ attoparsec >= 0.13.2 && < 0.14,+ box >= 0.1.0 && < 0.2,+ lens >= 4.17 && < 4.19,+ lucid >= 2.9 && < 2.10,+ optparse-generic >= 1.3.0 && < 1.4,+ scotty >= 0.11.5 && < 0.12,+ text >= 1.2.3 && < 1.3,+ wai >= 3.2.2 && < 3.3,+ wai-extra >= 3.0 && < 3.1,+ wai-middleware-static >= 0.8 && < 0.9,+ web-rep >= 0.3.0 default-language: Haskell2010 test-suite test@@ -81,11 +85,12 @@ test ghc-options: -Wall -O2 -threaded build-depends:- base >= 4.12 && <5- , lens- , lucid- , tasty- , tasty-hspec- , text- , web-rep+ base >= 4.12 && <5,+ doctest >= 0.16 && < 1.0,+ lens >= 4.17 && < 4.19,+ lucid >= 2.9.11 && < 2.10,+ tasty >= 1.2.3 && < 1.3,+ tasty-hspec >= 1.1.5 && < 1.2,+ text >= 1.2.3 && < 1.3,+ web-rep >= 0.3.0 default-language: Haskell2010