web-rep 0.5.0 → 0.6.0
raw patch · 29 files changed
+2627/−2764 lines, 29 filesdep +box-socketdep +concurrencydep +numhaskdep −aesondep −bifunctorsdep −javascript-bridgedep ~boxdep ~generic-lensdep ~lensnew-component:exe:rep-example
Dependencies added: box-socket, concurrency, numhask, wai-websockets, websockets
Dependencies removed: aeson, bifunctors, javascript-bridge, lucid-svg, mmorph, streaming, text-format, wai, wai-extra
Dependency ranges changed: box, generic-lens, lens, optparse-generic, wai-middleware-static, web-rep
Files
- app/example.hs +0/−246
- app/rep-example.hs +37/−0
- readme.md +3/−6
- src/Web/Page.hs +0/−94
- src/Web/Page/Bootstrap.hs +0/−168
- src/Web/Page/Bridge.hs +0/−299
- src/Web/Page/Examples.hs +0/−299
- src/Web/Page/Html.hs +0/−90
- src/Web/Page/Html/Input.hs +0/−245
- src/Web/Page/Mathjax.hs +0/−158
- src/Web/Page/Render.hs +0/−145
- src/Web/Page/Server.hs +0/−41
- src/Web/Page/SharedReps.hs +0/−426
- src/Web/Page/Types.hs +0/−421
- src/Web/Rep.hs +71/−0
- src/Web/Rep/Bootstrap.hs +165/−0
- src/Web/Rep/Examples.hs +293/−0
- src/Web/Rep/Html.hs +78/−0
- src/Web/Rep/Html/Input.hs +273/−0
- src/Web/Rep/Mathjax.hs +156/−0
- src/Web/Rep/Page.hs +278/−0
- src/Web/Rep/Render.hs +143/−0
- src/Web/Rep/Server.hs +43/−0
- src/Web/Rep/Shared.hs +210/−0
- src/Web/Rep/SharedReps.hs +474/−0
- src/Web/Rep/Socket.hs +309/−0
- stack.yaml +6/−6
- test/test.hs +12/−77
- web-rep.cabal +76/−43
− app/example.hs
@@ -1,246 +0,0 @@-{-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}-{-# OPTIONS_GHC -Wall #-}--import Prelude hiding (log, init)-import Control.Lens hiding (Wrapped, Unwrapped)-import Data.Attoparsec.Text (parseOnly, decimal)-import Lucid-import Network.Wai (rawPathInfo)-import Network.Wai.Middleware.RequestLogger (logStdoutDev)-import Network.Wai.Middleware.Static (addBase, noDots, staticPolicy, (>->))-import Options.Generic-import Web.Page-import Web.Page.Examples-import Web.Scotty (scotty, middleware)-import qualified Box-import qualified Data.Text as Text-import Control.Monad-import Data.Maybe--testPage :: Text -> Text -> [(Text, Html ())] -> Page-testPage title mid sections =- bootstrapPage <>- bridgePage &- #htmlHeader .~ title_ "iroTestPage" &- #htmlBody .~ divClass_ "container" (mconcat- [ divClass_ "row" (h1_ (toHtml title))- , divClass_ "row" (h2_ ("middleware: " <> toHtml mid))- , divClass_ "row" $ mconcat $ (\(t,h) -> divClass_ "col" (h2_ (toHtml t) <> with div_ [id_ t] h)) <$> sections- ])---- | bridge testing without the SharedRep method-rangeTest :: Input Int-rangeTest =- Input- 3- (Just "range example")- "rangeid"- (Slider- [ style_ "max-width:15rem;"- , min_ "0"- , max_ "5"- , step_ "1"- ])--textTest :: Input Text-textTest =- Input- "abc"- (Just "label")- "textid"- TextBox--initBridgeTest :: (Int, Text)-initBridgeTest = (rangeTest ^. #inputVal, textTest ^. #inputVal)--stepBridgeTest :: Element -> (Int, Text) -> (Int,Text)-stepBridgeTest e s =- case step e s of- Left _ -> s- Right x -> x- where- step (Element "rangeid" v) (_, t) = either- (Left . Text.pack)- (\x -> Right (x,t))- (parseOnly decimal v)- step (Element "textid" v) (n, _) = Right (n,v)- step e' _ = Left $ "unknown id: " <> pack (show e')--sendBridgeTest :: (Show a) => Engine -> Either Text a -> IO ()-sendBridgeTest e (Left err) = append e "log" err-sendBridgeTest e (Right a) =- replace e "output"- (toText $ cardify (mempty, []) (Just "output was:")- (toHtml (show a), []))--consumeBridgeTest :: Engine -> IO (Int, Text)-consumeBridgeTest e =- valueConsume initBridgeTest stepBridgeTest- ( (Box.liftC <$> Box.showStdout) <>- pure (Box.Committer (\v -> sendBridgeTest e v >> pure True))- ) (bridge e)--midBridgeTest :: (Show a) => Html () -> (Engine -> IO a) -> Application -> Application-midBridgeTest init eeio = start $ \ e -> do- append e "input" (toText init)- final <- eeio e `finally` putStrLn "midBridgeTest finalled"- putStrLn $ "final value was: " <> show final---- * SharedRep testing---- | Middleware that shows the current shared values-midShow :: (Show a) => SharedRep IO a -> Application -> Application-midShow sr = midShared sr initShowRep (logResults (pack . show))--initShowRep- :: (Show a)- => Engine- -> Rep a- -> StateT (HashMap Text Text) IO ()-initShowRep e r =- void $ oneRep r- (\(Rep h fa) m -> do- append e "input" (toText h)- replace e "output" (pack . show $ fa m))--results :: (a -> Text) -> Engine -> a -> IO ()-results r e x = replace e "output" (r x)--logResults :: (a -> Text) -> Engine -> Either Text a -> IO ()-logResults _ e (Left err) = append e "log" (err <> "<br>")-logResults r e (Right x) = results r e x---- | evaluate a Fiddle, without attempting to downstream bridging-midFiddle :: Concerns Text -> Application -> Application-midFiddle cs = midShared (fiddle cs) initFiddleRep (\e -> logFiddle e . second snd)--initFiddleRep- :: Engine- -> Rep a- -> StateT (HashMap Text Text) IO ()-initFiddleRep e r =- void $ oneRep r- (\(Rep h _) _ ->- append e "input" (toText h))--logFiddle :: Engine -> Either Text (Either Text (Concerns Text, Bool)) -> IO ()-logFiddle e (Left err) = append e "log" ("map error: " <> err)-logFiddle e (Right (Left err)) = append e "log" ("parse error: " <> err)-logFiddle e (Right (Right (c,u))) = bool (pure ()) (sendConcerns e "output" c) u---- | evaluate a Fiddle, and any downstream bridging representation-midViaFiddle- :: Show a- => SharedRep IO a- -> Application -> Application-midViaFiddle sr =- midShared (viaFiddle sr) (initViaFiddleRep (pack . show)) (\e -> logViaFiddle e (pack . show) . second snd)--initViaFiddleRep- :: (a -> Text)- -> Engine- -> Rep (Bool, Concerns Text, a)- -> StateT (HashMap Text Text) IO ()-initViaFiddleRep rend e r =- void $ oneRep r- (\(Rep h fa) m -> do- append e "input" (toText h)- case (snd $ fa m) of- Left err -> append e "log" ("map error: " <> err)- Right (_,c,a) -> do- sendConcerns e "representation" c- replace e "output" (rend a))--logViaFiddle :: Engine -> (a -> Text) -> Either Text (Either Text (Bool, Concerns Text, a)) -> IO ()-logViaFiddle e _ (Left err) = append e "log" ("map error: " <> err)-logViaFiddle e _ (Right (Left err)) = append e "log" ("parse error: " <> err)-logViaFiddle e r (Right (Right (True,c,a))) = do- sendConcerns e "representation" c- replace e "output" (r a)-logViaFiddle e r (Right (Right (False,_,a))) = replace e "output" (r a)--data MidType = Dev | Prod | ChooseFileExample | DataListExample | SumTypeExample | SumType2Example | Bridge | ListExample | ListRepExample | Fiddle | ViaFiddle | NoMid deriving (Eq, Read, Show, Generic)--instance ParseField MidType-instance ParseRecord MidType-instance ParseFields MidType--data Opts w = Opts- { midtype :: w ::: MidType <?> "type of middleware processing"- , log :: w ::: Maybe Bool <?> "server log to stdout"- , logPath :: w ::: Maybe Bool <?> "log raw path"- } deriving (Generic)--instance ParseRecord (Opts Wrapped)--main :: IO ()-main = do- o :: Opts Unwrapped <- unwrapRecord "examples for web-page"- let tr = fromMaybe False- scotty 3000 $ do- middleware $ staticPolicy (noDots >-> addBase "other")- middleware $ staticPolicy (noDots >-> addBase "saves")- when (tr $ log o) $- middleware logStdoutDev- when (tr $ logPath o) $- middleware $ \app req res ->- putStrLn "raw path:" >>- print (rawPathInfo req) >> app req res- -- Only one middleware servicing the web socket can be run at a time. Simply switching on based on paths doesn't work because socket comms comes through "/"- -- so that the first bridge middleware consumes all the elements- middleware $ case midtype o of- NoMid -> id- -- WebSocket connection to 'ws://localhost:3000/' failed: Error during WebSocket handshake: Unexpected response code: 200- Prod -> midShow - (maybeRep (Just "maybe") True repExamples)- Dev -> midShow- (repSumTypeExample 2 "default text" SumOnly)- ChooseFileExample -> midShow- (chooseFile (Just "ChooseFile Label") "")- DataListExample -> midShow- (datalist (Just "label") ["first", "2", "3"] "2" "idlist")- SumTypeExample -> midShow- (repSumTypeExample 2 "default text" SumOnly)- SumType2Example -> midShow- (repSumType2Example 2 "default text" SumOnly (SumOutside 2))- ListExample -> midShow (listExample 5)- ListRepExample -> midShow (listRepExample 10)- Bridge -> midBridgeTest (toHtml rangeTest <> toHtml textTest)- consumeBridgeTest- Fiddle -> midFiddle fiddleExample- 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)- , ("representation", mempty)- , ("output", mempty)- ])- servePageWith "/" (defaultPageConfig "prod")- (testPage "prod" (pack . show $ midtype o)- [ ("input", mempty)- , ("output",- (bool mempty- (toHtml (show initBridgeTest))- (midtype o == Bridge)))- ])- servePageWith "/log" (defaultPageConfig "prod")- (testPage "prod" (pack . show $ midtype o)- [ ("input", mempty)- , ("output",- (bool mempty- (toHtml (show initBridgeTest))- (midtype o == Bridge)))- , ("log", mempty)- ])
+ app/rep-example.hs view
@@ -0,0 +1,37 @@+{-# 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 Web.Rep+import Web.Rep.Examples++data AppType = SharedTest deriving (Eq, Read, Show, Generic)++instance ParseField AppType++instance ParseRecord AppType++instance ParseFields AppType++data Opts w+ = Opts+ { apptype :: w ::: AppType <?> "type of example"+ }+ deriving (Generic)++instance ParseRecord (Opts Wrapped)++main :: IO ()+main = do+ o :: Opts Unwrapped <- unwrapRecord "examples for web-page"+ case apptype o of+ SharedTest -> defaultSharedServer (maybeRep (Just "maybe") False repExamples)
readme.md view
@@ -6,23 +6,20 @@ 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 --test --exec "$(stack path --local-install-root)/bin/page-example --apptype SharedTest" --file-watch ``` -http://localhost:3000/+http://localhost:9160/ reference --- -- beam me up [scotty](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/flags.html#flag-reference)-- [scotty-starter](https://github.com/scotty-web/scotty-starter)+- [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)-- [javascript-bridge](https://github.com/ku-fpg/javascript-bridge)- todo ---
− src/Web/Page.hs
@@ -1,94 +0,0 @@--- | 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,-- -- * Web Page Components- Page (..),- PageConfig (..),- defaultPageConfig,- Concerns (..),- suffixes,- concernNames,- PageConcerns (..),- PageStructure (..),- PageRender (..),-- -- * Css- Css,- PageCss (..),- renderCss,- renderPageCss,-- -- * 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,- module Data.Biapplicative,- module Data.Bifunctor,-- -- * re-exports- module X,- Value (..),- finally,- HashMap.HashMap,- fromList,- void,- sequenceA_,- Text,- pack,- unpack,- toStrict,- bool,- )-where--import Control.Applicative as X-import Control.Exception (finally)-import Control.Monad-import Control.Monad.Trans.State as X-import Data.Aeson (Value (..))-import Data.Biapplicative-import Data.Bifunctor-import Data.Bool-import Data.Foldable (sequenceA_)-import qualified Data.HashMap.Strict as HashMap-import Data.Text (Text, pack, unpack)-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
@@ -1,168 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wall #-}---- | 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 Web.Page.Html-import Web.Page.Types-import Prelude--bootstrapCss :: [Html ()]-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"- ]- ]--bootstrapJs :: [Html ()]-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"- ]- ]--bootstrapMeta :: [Html ()]-bootstrapMeta =- [ meta_ [charset_ "utf-8"],- meta_- [ name_ "viewport",- 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-bootstrapPage =- Page- bootstrapCss- bootstrapJs- mempty- mempty- mempty- (mconcat bootstrapMeta)- mempty---- | wrap some Html with the bootstrap <https://getbootstrap.com/docs/4.3/components/card/ card> class-cardify :: (Html (), [Attribute]) -> Maybe Text -> (Html (), [Attribute]) -> Html ()-cardify (h, hatts) t (b, batts) =- with div_ ([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]---- | 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) $- with- div_- [class__ "card-header", id_ idh]- ( with- h2_- [class__ "mb-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)---- | 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"]) $- with- div_- ([class__ "card-header", id_ idh])- ( checkhtml- <> with- h2_- [class__ "mb-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)---- | create a bootstrapped accordian class-accordion ::- (MonadState Int m) =>- Text ->- -- | name prefix. This is needed because an Int doesn't seem to be a valid name.- Maybe Text ->- -- | card title- [(Text, Html ())] ->- -- | title, html tuple for each item in the accordion.- m (Html ())-accordion pre x hs = do- idp' <- genNamePre pre- with div_ [class__ "accordion", id_ idp'] <$> aCards idp'- where- aCards par = mconcat <$> sequence (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 pre hs = do- idp' <- genNamePre pre- with div_ [class__ "accordion", id_ idp'] <$> aCards idp'- where- aCards par = mconcat <$> sequence (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_ pre x hs = runIdentity $ evalStateT (accordion pre x hs) 0
− src/Web/Page/Bridge.hs
@@ -1,299 +0,0 @@-{-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# OPTIONS_GHC -Wall #-}-{-# OPTIONS_GHC -Wredundant-constraints #-}---- | A streaming bridge between a web page and haskell.-module Web.Page.Bridge- ( bridgePage,- append,- replace,- bridge,- sendConcerns,- Engine,- start,- Application,- valueConsume,- sharedConsume,- runList,- runOnEvent,- midShared,- refreshJsbJs,- runScriptJs,- )-where--import Box-import Box.Cont ()-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-import Text.InterpolatedString.Perl6-import Web.Page.Html-import Web.Page.Types-import Prelude hiding (init)---- | prevent the Enter key from triggering an event-preventEnter :: PageJs-preventEnter =- PageJs $- 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);-|]---- | create a web socket for event data-webSocket :: PageJs-webSocket =- PageJsText- [q|-window.jsb = {ws: new WebSocket('ws://' + location.host + '/')};-jsb.ws.onmessage = (evt) => eval(evt.data);-|]---- | script injection js.------ See https://ghinda.net/article/script-tags/ for why this might be needed.-runScriptJs :: PageJs-runScriptJs =- PageJsText- [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)-}--function runScripts ($container) {- // get scripts tags from a node- var $scripts = $container.querySelectorAll('script')- $scripts.forEach(function ($script) {- insertScript($script)- })-}-|]---- | componentry to kick off a javascript-bridge enabled page-bridgePage :: Page-bridgePage =- mempty- & #jsGlobal .~ (preventEnter <> refreshJsbJs)- & #jsOnLoad .~ webSocket--sendc :: Engine -> Text -> IO ()-sendc e = send e . command . JavaScript . fromStrict---- | replace a container and run any embedded scripts-replace :: Engine -> Text -> Text -> IO ()-replace e d t =- send e $- command- [qc|- var $container = document.getElementById('{d}');- $container.innerHTML = '{clean t}';- refreshJsb();- |]---- | append to a container and run any embedded scripts-append :: Engine -> Text -> Text -> IO ()-append e d t =- send e $- command- [qc|- var $container = document.getElementById('{d}');- $container.innerHTML += '{clean t}';- refreshJsb();- |]--clean :: Text -> Text-clean =- Text.intercalate "\\'" . Text.split (== '\'')- . Text.intercalate "\\n"- . Text.lines---- | send css, js and html over the bridge-sendConcerns :: Engine -> Text -> Concerns Text -> IO ()-sendConcerns e t (Concerns c j h) = do- replace e t h- append e t (toText $ style_ c)- sendc e j---- | The javascript bridge continuation.-bridge :: Engine -> Cont_ IO Value-bridge e = Cont_ $ \vio -> void $ addListener e vio--fromJson' :: (FromJSON a) => Value -> Either Text a-fromJson' v = case fromJSON v of- (Success a) -> Right a- (Error e) -> Left $ "Json conversion error: " <> Text.pack e <> " of " <> (pack . show) v--valueModel :: (FromJSON a, MonadState s m) => (a -> s -> s) -> S.Stream (S.Of Value) m () -> S.Stream (S.Of (Either Text s)) m ()-valueModel step s =- s- & S.map fromJson'- & S.partitionEithers- & hoist (S.chain (modify . step))- & hoist (S.mapM (const get))- & S.unseparate- & S.maps S.sumToEither---- | consume an Element using a Committer and a Value continuation-valueConsume :: s -> (Element -> s -> s) -> Cont IO (Committer IO (Either Text s)) -> Cont_ IO Value -> IO s-valueConsume init step comm vio = do- (c, e) <- atomically $ ends Unbounded- with_ vio (atomically . c)- etcM- init- (Transducer (valueModel step))- (Box <$> comm <*> (liftE <$> pure (Emitter (Just <$> e))))--stepM :: MonadState s m => (s -> (s, b)) -> (a -> s -> s) -> a -> m (s, b)-stepM sr step v = do- hm <- get- let (hm', b) = sr $ step v hm- put hm'- pure (hm', b)--sharedModel :: (FromJSON a, MonadState s m) => (s -> (s, Either Text b)) -> (a -> s -> s) -> S.Stream (S.Of Value) m () -> S.Stream (S.Of (Either Text (s, Either Text b))) m ()-sharedModel sr step s =- s- & S.map fromJson'- & S.partitionEithers- & hoist (S.mapM (stepM sr step))- & S.unseparate- & S.maps S.sumToEither---- | consume shared values using a step function, a continuation committer, and a Value continuation.-sharedConsume :: (s -> (s, Either Text b)) -> s -> (Element -> s -> s) -> Cont IO (Committer IO (Either Text (s, Either Text b))) -> Cont_ IO Value -> IO s-sharedConsume sh init step comm vio = do- (c, e) <- atomically $ ends Unbounded- with_ vio (atomically . c)- etcM- init- (Transducer (sharedModel sh step))- (Box <$> comm <*> (liftE <$> pure (Emitter (Just <$> e))))---- | run a SharedRep using an initial state, a step function that consumes the shared model, and a value continuation-runOnEvent ::- SharedRep IO a ->- (Rep a -> StateT (Int, HashMap Text Text) IO ()) ->- (Either Text (HashMap Text Text, Either Text a) -> IO ()) ->- Cont_ IO Value ->- IO (HashMap Text Text)-runOnEvent sr hio eaction cv = flip evalStateT (0, HashMap.empty) $ do- (Rep h fa) <- unrep sr- hio (Rep h fa)- m <- zoom _2 get- liftIO $- sharedConsume- fa- m- (\(Element k v) s -> insert k v s)- (pure (Committer (\v -> eaction v >> pure True)))- cv---- | create Wai Middleware for a 'SharedRep' providing an initialiser and action on events-midShared ::- () =>- SharedRep IO a ->- (Engine -> Rep a -> StateT (HashMap Text Text) IO ()) ->- (Engine -> Either Text (HashMap Text Text, Either Text a) -> IO ()) ->- Application ->- Application-midShared sr init action = start $ \e ->- void $- runOnEvent- sr- (zoom _2 . init e)- (action e)- (bridge e)---- | process a list of Values-runList ::- (Monad m) =>- SharedRep m a ->- [Value] ->- m [Either Text (HashMap Text Text, Either Text a)]-runList sr vs = S.fst' <$> do- (faStep, (_, hm)) <- flip runStateT (0, HashMap.empty) $ do- (Rep _ fa) <- unrep sr- pure fa- flip evalStateT hm $- L.purely- S.fold- L.list- (sharedModel faStep (\(Element k v) s -> insert k v s) (S.each vs))---- | Event hooks that may need to be reattached given dynamic content creation.-refreshJsbJs :: PageJs-refreshJsbJs =- PageJsText- [q|-function refreshJsb () {- $('.jsbClassEventChange').off('change');- $('.jsbClassEventChange').on('change', (function(){- jsb.event({ 'element': this.id, 'value': this.value});- }));- $('.jsbClassEventInput').off('input');- $('.jsbClassEventInput').on('input', (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';- }- })- }));-};-|]
− src/Web/Page/Examples.hs
@@ -1,299 +0,0 @@-{-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# OPTIONS_GHC -Wall #-}--module Web.Page.Examples- ( 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 qualified Lucid.Svg as Svg-import Web.Page-import Prelude---- | simple page example-page1 :: Page-page1 =- #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---- | 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}\\)"---- | 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", Svg.y_ "100", Svg.x_ "0"] "prefix: $\\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 "")--cssLibs :: [Text]-cssLibs =- ["http://maxcdn.bootstrapcdn.com/font-awesome/4.3.0/css/font-awesome.min.css"]--cssLibsLocal :: [Text]-cssLibsLocal = ["css/font-awesome.min.css"]--jsLibs :: [Text]-jsLibs = ["http://code.jquery.com/jquery-1.6.3.min.js"]--jsLibsLocal :: [Text]-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---- js-click :: PageJs-click =- PageJsText- [q|-$('#btnGo').click( function() {- $('#btnGo').toggleClass('on');- alert('bada bing!');-});-|]--button1 :: Html ()-button1 =- with- button_- [id_ "btnGo", Lucid.type_ "button"]- ("Go " <> with i_ [class__ "fa fa-play"] mempty)---- | 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 :: Text- }- 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"- ta <- textarea 3 (Just "textarea") "no initial value & multi-line text\\nrenders is not ok?/"- n <- sliderI (Just "int slider") 0 5 1 3- ds' <- slider (Just "double slider") 0 1 0.1 0.5- c <- checkbox (Just "checkbox") True- tog <- toggle (Just "toggle") False- 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") "#454e56"- pure (RepExamples t ta n ds' c tog dr 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
− src/Web/Page/Html.hs
@@ -1,90 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}---- | Key generators and miscellaneous html utilities.------ Uses the lucid 'Lucid.Html'.-module Web.Page.Html- ( class__,- toText,- genName,- genNamePre,- libCss,- libJs,- HtmlT,- Html,- )-where--import Control.Monad.State-import Data.Bool-import Data.Text-import qualified Data.Text.Lazy as Lazy-import Lucid-import Prelude---- | FIXME: A horrible hack to separate class id's-class__ :: Text -> Attribute-class__ t = class_ (" " <> t <> " ")---- | Convert html to text-toText :: Html a -> Text-toText = Lazy.toStrict . renderText---- | name supply for html elements-genName :: (MonadState Int m) => m Text-genName = do- modify (+ 1)- (pack . 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 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- ]---- | 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 "()"
− src/Web/Page/Html/Input.hs
@@ -1,245 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# OPTIONS_GHC -Wall #-}---- | Common web page input elements, often with bootstrap scaffolding.-module Web.Page.Html.Input- ( Input (..),- InputType (..),- )-where--import Data.Bool-import Data.Maybe-import Data.Text-import GHC.Generics-import Lucid-import Lucid.Base-import Web.Page.Html-import Prelude---- | 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- }- deriving (Eq, Show, Generic)---- | 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 jsbClassEventChange",- id_ i,- value_ (pack $ show $ toHtml v)- ]- <> satts- )- )- 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 jsbClassEventInput",- id_ i,- value_ (pack $ show $ toHtmlRaw v)- ]- )- )- 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 jsbClassEventInput",- id_ i- ]- (toHtmlRaw v)- )- )- 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 jsbClassEventInput",- id_ i,- value_ (pack $ show $ toHtml v)- ]- )- )- 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 jsbClassEventChooseFile",- id_ 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 jsbClassEventInput",- id_ i- ]- opts'- )- )- where- 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 jsbClassEventInput jsbClassEventShowSum",- id_ i- ]- opts'- )- )- 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"]- ( (maybe mempty (with label_ [for_ i] . toHtml) l)- <> input_- [ type_ "text",- class__ "form-control 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_- ( bool- []- [selected_ "selected"]- (toText (toHtml o) == toText (toHtml v))- )- (toHtml o)- )- <$> opts- )- )- -- 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 jsbClassEventCheckbox",- id_ i- ]- <> bool [] [checked_] checked- )- <> (maybe mempty (with label_ [for_ i, class__ "form-check-label"] . toHtml) l)- )- 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 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"]- ( input_- ( [ type_ "button",- id_ i,- class__ "btn btn-primary btn-sm jsbClassEventButton",- value_ (fromMaybe "button" l)- ]- )- )-- toHtmlRaw = toHtml-
− src/Web/Page/Mathjax.hs
@@ -1,158 +0,0 @@-{-# 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- & #jsGlobal .~ 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 = {- 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/Page/Render.hs
@@ -1,145 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE OverloadedStrings #-}---- | Page rendering-module Web.Page.Render- ( 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 Lucid-import qualified Lucid.Svg as Svg-import Web.Page.Html-import Web.Page.Types-import Prelude hiding (writeFile)---- | Render a Page with the default configuration into Html.-renderPage :: Page -> Html ()-renderPage p =- (\(_, _, x) -> x) $ renderPageWith (defaultPageConfig "default") p---- | Render a Page into Html.-renderPageHtmlWith :: PageConfig -> Page -> Html ()-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 pc p =- case pc ^. #concerns of- Inline -> (mempty, mempty, h)- Separated -> (css, js, h)- where- 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- ]- )- )- Headless ->- mconcat- [ 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- ]- Svg ->- 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- rendercss = renderPageCss $ pc ^. #pageRender- cssInline- | pc ^. #concerns == Separated || css == mempty = mempty- | otherwise = style_ [type_ "text/css"] css- jsInline- | pc ^. #concerns == Separated || js == mempty = mempty- | otherwise = script_ mempty js- libsCss' =- case pc ^. #concerns of- Inline -> p ^. #libsCss- Separated ->- 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)]---- | Render Page concerns to files.-renderPageToFile :: FilePath -> PageConfig -> Page -> IO ()-renderPageToFile dir pc page =- sequenceA_ $ liftA2 writeFile' (pc ^. #filenames) (renderPageAsText pc page)- where- writeFile' fp s = unless (s == mempty) (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)---- | Render a Page as Text.-renderPageAsText :: PageConfig -> Page -> Concerns Text-renderPageAsText pc p =- case pc ^. #concerns of- Inline -> Concerns mempty mempty htmlt- Separated -> Concerns css js htmlt- where- htmlt = toText h- (css, js, h) = renderPageWith pc p
− src/Web/Page/Server.hs
@@ -1,41 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedLabels #-}-{-# OPTIONS_GHC -Wall #-}---- | Serve pages via 'ScottyM'-module Web.Page.Server- ( servePageWith- ) where--import Control.Lens hiding (only)-import Lucid (renderText)-import Network.Wai.Middleware.Static (addBase, noDots, staticPolicy, only)-import Prelude-import Web.Page.Render-import Web.Page.Types-import Web.Scotty-import qualified Control.Monad.State as State-import Control.Monad-import Data.Text (unpack)---- | serve a Page via a ScottyM-servePageWith :: RoutePattern -> PageConfig -> Page -> ScottyM ()-servePageWith rp pc p =- sequence_ $ servedir <> [getpage]- where- getpage = case pc ^. #concerns of- Inline ->- get rp (html $ renderText $ renderPageHtmlWith pc p)- Separated -> let (css,js,h) = renderPageWith pc p in- do- middleware $ staticPolicy $ only [(cssfp,cssfp), (jsfp, jsfp)]- get rp (do- State.lift $ writeFile' cssfp (unpack css)- State.lift $ writeFile' jsfp (unpack js)- html $ renderText h)- cssfp = pc ^. #filenames . #cssConcern- jsfp = pc ^. #filenames . #jsConcern- writeFile' fp s = unless (s == mempty) (writeFile fp s)- servedir = (\x -> middleware $ staticPolicy (noDots <> addBase x)) <$> pc ^. #localdirs-
@@ -1,426 +0,0 @@-{-# LANGUAGE ApplicativeDo #-}-{-# 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,- sliderI,- slider,- dropdown,- datalist,- dropdownSum,- colorPicker,- textbox,- textarea,- checkbox,- toggle,- button,- chooseFile,- maybeRep,- fiddle,- viaFiddle,- accordionList,- listMaybeRep,- listRep,- readTextbox,- defaultListLabels,- )-where--import Box.Cont ()-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, unpack)-import Lucid-import Text.InterpolatedString.Perl6-import Web.Page.Bootstrap-import Web.Page.Html-import Web.Page.Html.Input-import Web.Page.Types-import Prelude hiding (lookup)---- $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- zoom _2 (modify (HashMap.insert name (pr a)))- pure $- Rep- (toHtml $ #inputVal .~ a $ #inputId .~ name $ i)- ( \s ->- ( s,- join- $ maybe (Left "lookup failed") Right- $ either (Left . (\x -> name <> ": " <> x) . pack) Right . parseOnly p <$> HashMap.lookup name s- )- )---- | 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- name <- zoom _1 genName- pure $- Rep- (toHtml $ #inputVal .~ a $ #inputId .~ name $ i)- ( \s ->- ( HashMap.delete name s,- join- $ maybe (Right $ Right def) Right- $ either (Left . pack) Right . parseOnly p <$> HashMap.lookup name s- )- )---- | 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 ->- Double ->- Double ->- Double ->- Double ->- 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)]))- 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 ->- a ->- a ->- a ->- a ->- 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)]))- 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- takeText- 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 rows label v =- repInput- takeText- id- (Input v label mempty (TextArea rows))- v---- | Non-typed hex color input-colorPicker :: (Monad m) => Maybe Text -> Text -> SharedRep m Text-colorPicker label v =- repInput- takeText- 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) ->- -- | label suggestion- Maybe Text ->- -- | list of dropbox elements (as text)- [Text] ->- -- | initial value- a ->- SharedRep m a-dropdown p pr label opts v =- repInput- p- pr- (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- takeText- (pack . 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] ->- a ->- SharedRep m a-dropdownSum p pr label opts v =- repInput- p- pr- (Input v label mempty (DropdownSum opts))- v---- | A checkbox input.-checkbox :: (Monad m) => Maybe Text -> Bool -> SharedRep m Bool-checkbox label v =- repInput- ((== "true") <$> takeText)- (bool "false" "true")- (Input v label mempty (Checkbox v))- v---- | a toggle button-toggle :: (Monad m) => Maybe Text -> Bool -> SharedRep m Bool-toggle label v =- repInput- ((== "true") <$> takeText)- (bool "false" "true")- (Input v label mempty (Toggle v label))- v---- | a button-button :: (Monad m) => Maybe Text -> SharedRep m Bool-button label =- repMessage- (pure True)- (bool "false" "true")- (Input False label mempty Button)- False- False---- | filename input-chooseFile :: (Monad m) => Maybe Text -> Text -> SharedRep m Text-chooseFile label v =- repInput- takeText- (pack . show)- (Input v label mempty ChooseFile)- v--checkboxShowJs :: (Monad m) => Maybe Text -> Text -> Bool -> SharedRep m Bool-checkboxShowJs label cl 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 cl)- ( \s ->- ( s,- join- $ maybe (Left "HashMap.lookup failed") Right- $ either (Left . pack) Right . parseOnly ((== "true") <$> takeText)- <$> HashMap.lookup name s- )- )---- | Represent a Maybe using a checkbox.------ Hides the underlying content on Nothing-maybeRep ::- (Monad m) =>- Maybe Text ->- Bool ->- SharedRep m a ->- SharedRep m (Maybe a)-maybeRep label st sa = SharedRep $ do- className <- zoom _1 genName- unrep $ bimap (hmap className) mmap (checkboxShowJs label className st) <<*>> sa- where- hmap cl a b =- cardify- (a, [])- Nothing- ( ( Lucid.with- div_- [ class__ cl,- style_- ("display:" <> bool "none" "block" st)- ]- b- ),- [style_ "padding-top: 0.25rem; padding-bottom: 0.25rem;"]- )- mmap a b = bool Nothing (Just b) a---- | 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) <-- unrep- $ 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)---- | 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) <-- unrep- $ 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- )- h' <- zoom _1 h- pure (Rep (maybe mempty (h5_ . toHtml) 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 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 ->- -- | name prefix (should be unique)- (Bool -> SharedRep m Bool) ->- -- | Bool Rep- (a -> SharedRep m a) ->- -- | a Rep- Int ->- -- | maximum length of list- a ->- -- | default value for new rows- [a] ->- -- | initial values- SharedRep m [a]-listRep t p brf srf n defa as =- second (mconcat . fmap (\(b, a) -> bool [] [a] b)) $- accordionBoolList- t- p- srf- brf- (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]---- | Parse from a textbox----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)- 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")---- | 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 _) <- unrep sr- hrep <- unrep $ textarea 10 (Just "html") (toText h)- crep <- unrep $ textarea 10 (Just "css") mempty- jrep <- unrep $ textarea 10 (Just "js") mempty- u <- unrep $ 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'---- | 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
@@ -1,421 +0,0 @@-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TupleSections #-}-{-# OPTIONS_HADDOCK hide, not-home #-}-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}--module Web.Page.Types- ( Page (..),- PageConfig (..),- defaultPageConfig,- Concerns (..),- suffixes,- concernNames,- PageConcerns (..),- PageStructure (..),- PageRender (..),- Css,- PageCss (..),- renderCss,- renderPageCss,- JS (..),- PageJs (..),- onLoad,- renderPageJs,- parseJs,- renderJs,- Element (..),- RepF (..),- Rep,- oneRep,- SharedRepF (..),- SharedRep,- runOnce,- zeroState,- )-where--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.Generics.Labels ()-import Data.HashMap.Strict as HashMap hiding (foldr)-import Data.Text (Text, unpack)-import qualified Data.Text as Text-import Data.Text.Lazy (toStrict)-import GHC.Generics hiding (Rep)-import Language.JavaScript.Parser-import Language.JavaScript.Parser.AST-import Language.JavaScript.Process.Minify-import Lucid-import Text.InterpolatedString.Perl6-import Prelude---- | 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 :: PageCss,- -- | javascript with global scope- jsGlobal :: PageJs,- -- | javascript included within the onLoad function- jsOnLoad :: PageJs,- -- | html within the header- htmlHeader :: Html (),- -- | body html- htmlBody :: Html ()- }- deriving (Show, Generic)--instance Semigroup Page where- (<>) p0 p1 =- Page- (p0 ^. #libsCss <> p1 ^. #libsCss)- (p0 ^. #libsJs <> p1 ^. #libsJs)- (p0 ^. #cssBody <> p1 ^. #cssBody)- (p0 ^. #jsGlobal <> p1 ^. #jsGlobal)- (p0 ^. #jsOnLoad <> p1 ^. #jsOnLoad)- (p0 ^. #htmlHeader <> p1 ^. #htmlHeader)- (p0 ^. #htmlBody <> p1 ^. #htmlBody)--instance Monoid Page where-- mempty = Page [] [] mempty mempty mempty mempty mempty-- mappend = (<>)---- |------ 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,- jsConcern :: a,- htmlConcern :: a- }- deriving (Eq, Show, Foldable, Traversable, Generic)--instance Functor Concerns where- fmap f (Concerns c j h) = Concerns (f c) (f j) (f h)--instance Applicative Concerns where-- pure a = Concerns a a a-- Concerns f g h <*> Concerns a b c = Concerns (f a) (g b) (h c)---- | The common file suffixes of the three concerns.-suffixes :: Concerns FilePath-suffixes = Concerns ".css" ".js" ".html"---- | 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' (typically in a html file) or be separated (tyypically into separate files and linked in the html file)?-data PageConcerns- = Inline- | Separated- deriving (Show, Eq, Generic)---- | Various ways that a Html file can be structured.-data PageStructure- = 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]- }- 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- Inline- HeaderBody- Minified- ((stem <>) <$> suffixes)- []---- | Unifies css as either a 'Clay.Css' or as Text.-data PageCss = PageCss Clay.Css | PageCssText Text deriving (Generic)--instance Show PageCss where- show (PageCss css) = unpack . renderCss $ css- show (PageCssText txt) = unpack txt--instance Semigroup PageCss where- (<>) (PageCss css) (PageCss css') = PageCss (css <> css')- (<>) (PageCssText css) (PageCssText css') = PageCssText (css <> css')- (<>) (PageCss css) (PageCssText css') =- PageCssText (renderCss css <> css')- (<>) (PageCssText css) (PageCss css') =- PageCssText (css <> renderCss css')--instance Monoid PageCss where-- mempty = PageCssText mempty-- mappend = (<>)---- | 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.-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 PageJs = PageJs JS | PageJsText Text deriving (Eq, Show, Generic)--instance Semigroup PageJs where- (<>) (PageJs js) (PageJs js') = PageJs (js <> js')- (<>) (PageJsText js) (PageJsText js') = PageJsText (js <> js')- (<>) (PageJs js) (PageJsText js') =- PageJsText (toStrict (renderToText $ unJS js) <> js')- (<>) (PageJsText js) (PageJs js') =- PageJsText (js <> toStrict (renderToText $ unJS js'))--instance Monoid PageJs where-- mempty = PageJs mempty-- mappend = (<>)---- | Wrap js in standard DOM window loader.-onLoad :: PageJs -> PageJs-onLoad (PageJs js) = PageJs $ onLoadStatements [toStatement js]-onLoad (PageJsText js) = PageJsText $ onLoadText js--toStatement :: JS -> JSStatement-toStatement (JS (JSAstProgram ss ann)) = JSStatementBlock JSNoAnnot ss JSNoAnnot (JSSemi ann)-toStatement (JS (JSAstStatement s _)) = s-toStatement (JS (JSAstExpression e ann')) = JSExpressionStatement e (JSSemi ann')-toStatement (JS (JSAstLiteral e ann')) = JSExpressionStatement e (JSSemi ann')--onLoadStatements :: [JSStatement] -> JS-onLoadStatements js = JS $ JSAstProgram [JSAssignStatement (JSMemberDot (JSIdentifier JSNoAnnot "window") JSNoAnnot (JSIdentifier JSNoAnnot "onload")) (JSAssign JSNoAnnot) (JSFunctionExpression JSNoAnnot JSIdentNone JSNoAnnot JSLNil JSNoAnnot (JSBlock JSNoAnnot js JSNoAnnot)) JSSemiAuto] JSNoAnnot--onLoadText :: Text -> Text-onLoadText t = [qc| window.onload=function()\{{t}};|]---- | Convert 'Text' to 'JS', throwing an error on incorrectness.-parseJs :: Text -> JS-parseJs = JS . readJs . Text.unpack---- | Render 'JS' as 'Text'.-renderJs :: JS -> Text-renderJs = toStrict . renderToText . unJS---- | 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
+ src/Web/Rep.hs view
@@ -0,0 +1,71 @@+-- | 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.Rep+ ( -- * Shared Representation+ RepF (..),+ Rep,+ oneRep,+ SharedRepF (..),+ SharedRep,+ runOnce,+ zeroState,+ register,+ genName,+ genNamePre,++ -- * Web Rep Components+ Page (..),+ PageConfig (..),+ defaultPageConfig,+ Concerns (..),+ suffixes,+ concernNames,+ PageConcerns (..),+ PageStructure (..),+ PageRender (..),++ -- * Css+ Css,+ RepCss (..),+ renderCss,+ renderRepCss,++ -- * JS+ JS (..),+ RepJs (..),+ onLoad,+ renderRepJs,+ parseJs,+ renderJs,++ -- * re-export modules+ module Web.Rep.SharedReps,+ module Web.Rep.Render,+ module Web.Rep.Server,+ module Web.Rep.Socket,+ 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 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
+ src/Web/Rep/Bootstrap.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wall #-}++-- | Some <https://getbootstrap.com/ bootstrap> assets and functionality.+module Web.Rep.Bootstrap+ ( bootstrapPage,+ cardify,+ divClass_,+ accordion,+ accordionChecked,+ accordionCard,+ accordionCardChecked,+ accordion_,+ )+where++import Lucid+import Lucid.Base+import NumHask.Prelude+import Web.Rep.Html+import Web.Rep.Page+import Web.Rep.Shared++bootstrapCss :: [Html ()]+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"+ ]+ ]++bootstrapJs :: [Html ()]+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"+ ]+ ]++bootstrapMeta :: [Html ()]+bootstrapMeta =+ [ meta_ [charset_ "utf-8"],+ meta_+ [ name_ "viewport",+ 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+bootstrapPage =+ Page+ bootstrapCss+ bootstrapJs+ mempty+ mempty+ mempty+ (mconcat bootstrapMeta)+ mempty++-- | wrap some Html with the bootstrap <https://getbootstrap.com/docs/4.3/components/card/ card> class+cardify :: (Html (), [Attribute]) -> Maybe Text -> (Html (), [Attribute]) -> Html ()+cardify (h, hatts) t (b, batts) =+ with div_ ([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]++-- | 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) $+ 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)++-- | 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"] $+ 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)++-- | create a bootstrapped accordian class+accordion ::+ (MonadState Int m) =>+ Text ->+ -- | name prefix. This is needed because an Int doesn't seem to be a valid name.+ Maybe Text ->+ -- | card title+ [(Text, Html ())] ->+ -- | title, html tuple for each item in the accordion.+ m (Html ())+accordion pre x hs = do+ idp' <- genNamePre pre+ with div_ [class__ "accordion m-1", id_ idp'] <$> aCards idp'+ where+ aCards par = mconcat <$> sequence (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 pre hs = do+ idp' <- genNamePre pre+ with div_ [class__ "accordion m-1", id_ idp'] <$> aCards idp'+ where+ aCards par = mconcat <$> sequence (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_ pre x hs = runIdentity $ evalStateT (accordion pre x hs) 0
+ src/Web/Rep/Examples.hs view
@@ -0,0 +1,293 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wall #-}++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 Web.Rep++-- | simple page example+page1 :: Page+page1 =+ #htmlBody .~ button1+ $ #cssBody .~ RepCss 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++-- | 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}\\)"++cfg2 :: PageConfig+cfg2 =+ #concerns .~ Separated+ $ #pageRender .~ Pretty+ $ #structure .~ Headless+ $ #localdirs .~ ["test/static"]+ $ #filenames .~ (("other/cfg2" <>) <$> suffixes)+ $ defaultPageConfig ""++cssLibs :: [Text]+cssLibs =+ ["http://maxcdn.bootstrapcdn.com/font-awesome/4.3.0/css/font-awesome.min.css"]++cssLibsLocal :: [Text]+cssLibsLocal = ["css/font-awesome.min.css"]++jsLibs :: [Text]+jsLibs = ["http://code.jquery.com/jquery-1.6.3.min.js"]++jsLibsLocal :: [Text]+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++-- js+click :: RepJs+click =+ RepJsText+ [q|+$('#btnGo').click( function() {+ $('#btnGo').toggleClass('on');+ alert('bada bing!');+});+|]++button1 :: Html ()+button1 =+ with+ button_+ [id_ "btnGo", Lucid.type_ "button"]+ ("Go " <> with i_ [class__ "fa fa-play"] mempty)++-- | 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+ }+ 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"+ ta <- textarea 3 (Just "textarea") "no initial value & multi-line text\\nrenders is not ok?/"+ n <- sliderI (Just "int slider") 0 5 1 3+ ds' <- slider (Just "double slider") 0 1 0.1 0.5+ c <- checkbox (Just "checkbox") True+ tog <- toggle (Just "toggle") False+ dr <- dropdown decimal (pack . show) (Just "dropdown") (pack . show <$> [1 .. 5 :: Int]) 3+ drm <- dropdownMultiple decimal (pack . show) (Just "dropdown multiple") (pack . show <$> [1 .. 5 :: Int]) [2, 4]+ drt <- toShape <$> dropdown takeText id (Just "shape") ["Circle", "Square"] (fromShape SquareShape)+ col <- colorPicker (Just "color") "#454e56"+ pure (RepExamples t ta n ds' c tog dr drm drt col)++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
+ src/Web/Rep/Html.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE IncoherentInstances #-}+{-# 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,+ 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 <> " ")++-- | Convert html to text+toText :: Html a -> Text+toText = Lazy.toStrict . renderText++-- | Convert a link to a css library from text to html.+--+-- >>> libCss "https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/css/bootstrap.min.css"+-- <link 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+ ]++-- | 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
+ src/Web/Rep/Html/Input.hs view
@@ -0,0 +1,273 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wall #-}++-- | Common web page input elements, often with bootstrap scaffolding.+module Web.Rep.Html.Input+ ( Input (..),+ InputType (..),+ )+where++import Data.Text (split)+import Lucid+import Lucid.Base+import NumHask.Prelude hiding (for_)+import Web.Rep.Html++-- | 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+ }+ deriving (Eq, Show, Generic)++-- | Various types of web page inputs, encapsulating practical bootstrap class functionality+data InputType+ = Slider [Attribute]+ | TextBox+ | TextBox'+ | TextArea Int+ | ColorPicker+ | ChooseFile+ | Dropdown [Text]+ | DropdownMultiple [Text] Char+ | 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-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+ ]+ (toHtmlRaw v)+ )+ toHtml (Input v l i ColorPicker) =+ with+ div_+ [class__ "form-group-sm"]+ ( maybe mempty (with label_ [for_ i, class__ "mb-0"] . toHtml) l+ <> input_+ [ type_ "color",+ class__ "form-control form-control-sm jsbClassEventInput",+ id_ i,+ value_ (pack $ show $ toHtml v)+ ]+ )+ toHtml (Input _ l i ChooseFile) =+ with+ div_+ [class__ "form-group-sm"]+ (maybe mempty (with label_ [for_ i, class__ "mb-0"] . toHtml) l)+ <> input_+ [ type_ "file",+ class__ "form-control-file form-control-sm jsbClassEventChooseFile",+ id_ i+ ]+ 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'+ )+ 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'+ )+ where+ opts' =+ mconcat $+ ( \o ->+ with+ option_+ ( bool+ []+ [selected_ "selected"]+ (any (\v -> toText (toHtml o) == toText (toHtml v)) (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'+ )+ 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_+ ( bool+ []+ [selected_ "selected"]+ (toText (toHtml o) == toText (toHtml v))+ )+ (toHtml 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)+ ]+ )++ toHtmlRaw = toHtml
+ src/Web/Rep/Mathjax.hs view
@@ -0,0 +1,156 @@+{-# 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
@@ -0,0 +1,278 @@+{-# 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 #-}++module Web.Rep.Page+ ( -- $page+ Page (..),+ PageConfig (..),+ defaultPageConfig,+ Concerns (..),+ suffixes,+ concernNames,+ PageConcerns (..),+ PageStructure (..),+ PageRender (..),++ -- $css+ Css,+ RepCss (..),+ renderCss,+ renderRepCss,++ -- $js+ JS (..),+ RepJs (..),+ 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++-- | 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 ()+ }+ deriving (Show, Generic)++instance Semigroup Page where+ (<>) p0 p1 =+ Page+ (p0 ^. #libsCss <> p1 ^. #libsCss)+ (p0 ^. #libsJs <> p1 ^. #libsJs)+ (p0 ^. #cssBody <> p1 ^. #cssBody)+ (p0 ^. #jsGlobal <> p1 ^. #jsGlobal)+ (p0 ^. #jsOnLoad <> p1 ^. #jsOnLoad)+ (p0 ^. #htmlHeader <> p1 ^. #htmlHeader)+ (p0 ^. #htmlBody <> p1 ^. #htmlBody)++instance Monoid Page where+ mempty = Page [] [] 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+ }+ deriving (Eq, Show, Foldable, Traversable, Generic)++instance Functor Concerns where+ fmap f (Concerns c j h) = Concerns (f c) (f j) (f h)++instance Applicative Concerns where+ pure a = Concerns a a a++ Concerns f g h <*> Concerns a b c = Concerns (f a) (g b) (h c)++-- | The common file suffixes of the three concerns.+suffixes :: Concerns FilePath+suffixes = Concerns ".css" ".js" ".html"++-- | 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' (typically in a html file) or be separated (tyypically into separate files and linked in the html file)?+data PageConcerns+ = Inline+ | Separated+ deriving (Show, Eq, Generic)++-- | Various ways that a Html file can be structured.+data PageStructure+ = 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]+ }+ 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+ Inline+ HeaderBody+ Minified+ ((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++-- | Render 'Css' as text.+renderCss :: Css -> Text+renderCss = toStrict . Clay.render+++-- | wrapper for `JSAST`+newtype JS = JS {unJS :: JSAST} deriving (Show, Eq, Generic)++instance Semigroup JS where+ (<>) (JS (JSAstProgram ss ann)) (JS (JSAstProgram ss' _)) =+ JS $ JSAstProgram (ss <> ss') ann+ (<>) (JS (JSAstProgram ss ann)) (JS (JSAstStatement s _)) =+ JS $ JSAstProgram (ss <> [s]) ann+ (<>) (JS (JSAstProgram ss ann)) (JS (JSAstExpression e ann')) =+ JS $ JSAstProgram (ss <> [JSExpressionStatement e (JSSemi ann')]) ann+ (<>) (JS (JSAstProgram ss ann)) (JS (JSAstLiteral e ann')) =+ JS $ JSAstProgram (ss <> [JSExpressionStatement e (JSSemi ann')]) ann+ (<>) (JS (JSAstStatement s ann)) (JS (JSAstProgram ss _)) =+ JS $ JSAstProgram (s : ss) ann+ (<>) (JS (JSAstStatement s ann)) (JS (JSAstStatement s' _)) =+ JS $ JSAstProgram [s, s'] ann+ (<>) (JS (JSAstStatement s ann)) (JS (JSAstExpression e ann')) =+ JS $ JSAstProgram [s, JSExpressionStatement e (JSSemi ann')] ann+ (<>) (JS (JSAstStatement s ann)) (JS (JSAstLiteral e ann')) =+ JS $ JSAstProgram [s, JSExpressionStatement e (JSSemi ann')] ann+ (<>) (JS (JSAstExpression e ann)) (JS (JSAstProgram ss _)) =+ JS $ JSAstProgram (JSExpressionStatement e (JSSemi ann) : ss) ann+ (<>) (JS (JSAstExpression e ann)) (JS (JSAstStatement s' _)) =+ JS $ JSAstProgram [JSExpressionStatement e (JSSemi ann), s'] ann+ (<>) (JS (JSAstExpression e ann)) (JS (JSAstExpression e' ann')) =+ JS $ JSAstProgram [JSExpressionStatement e (JSSemi ann), JSExpressionStatement e' (JSSemi ann')] ann+ (<>) (JS (JSAstExpression e ann)) (JS (JSAstLiteral e' ann')) =+ JS $ JSAstProgram [JSExpressionStatement e (JSSemi ann), JSExpressionStatement e' (JSSemi ann')] ann+ (<>) (JS (JSAstLiteral e ann)) (JS (JSAstProgram ss _)) =+ JS $ JSAstProgram (JSExpressionStatement e (JSSemi ann) : ss) ann+ (<>) (JS (JSAstLiteral e ann)) (JS (JSAstStatement s' _)) =+ JS $ JSAstProgram [JSExpressionStatement e (JSSemi ann), s'] ann+ (<>) (JS (JSAstLiteral e ann)) (JS (JSAstExpression e' ann')) =+ JS $ JSAstProgram [JSExpressionStatement e (JSSemi ann), JSExpressionStatement e' (JSSemi ann')] ann+ (<>) (JS (JSAstLiteral e ann)) (JS (JSAstLiteral e' ann')) =+ JS $ JSAstProgram [JSExpressionStatement e (JSSemi ann), JSExpressionStatement e' (JSSemi ann')] ann++instance Monoid JS where+ mempty = JS $ JSAstProgram [] (JSAnnot (TokenPn 0 0 0) [])++ mappend = (<>)++-- | Unifies javascript as 'JSStatement' and script as 'Text'.+data RepJs = RepJs JS | RepJsText Text deriving (Eq, Show, Generic)++instance Semigroup RepJs where+ (<>) (RepJs js) (RepJs js') = RepJs (js <> js')+ (<>) (RepJsText js) (RepJsText js') = RepJsText (js <> js')+ (<>) (RepJs js) (RepJsText js') =+ RepJsText (toStrict (renderToText $ unJS js) <> js')+ (<>) (RepJsText js) (RepJs js') =+ RepJsText (js <> toStrict (renderToText $ unJS js'))++instance Monoid RepJs where+ mempty = RepJs mempty++ mappend = (<>)++-- | Wrap js in standard DOM window loader.+onLoad :: RepJs -> RepJs+onLoad (RepJs js) = RepJs $ onLoadStatements [toStatement js]+onLoad (RepJsText js) = RepJsText $ onLoadText js++toStatement :: JS -> JSStatement+toStatement (JS (JSAstProgram ss ann)) = JSStatementBlock JSNoAnnot ss JSNoAnnot (JSSemi ann)+toStatement (JS (JSAstStatement s _)) = s+toStatement (JS (JSAstExpression e ann')) = JSExpressionStatement e (JSSemi ann')+toStatement (JS (JSAstLiteral e ann')) = JSExpressionStatement e (JSSemi ann')++onLoadStatements :: [JSStatement] -> JS+onLoadStatements js = JS $ JSAstProgram [JSAssignStatement (JSMemberDot (JSIdentifier JSNoAnnot "window") JSNoAnnot (JSIdentifier JSNoAnnot "onload")) (JSAssign JSNoAnnot) (JSFunctionExpression JSNoAnnot JSIdentNone JSNoAnnot JSLNil JSNoAnnot (JSBlock JSNoAnnot js JSNoAnnot)) JSSemiAuto] JSNoAnnot++onLoadText :: Text -> Text+onLoadText t = [qc| window.onload=function()\{{t}};|]++-- | Convert 'Text' to 'JS', throwing an error on incorrectness.+parseJs :: Text -> JS+parseJs = JS . readJs . unpack++-- | Render 'JS' as 'Text'.+renderJs :: JS -> Text+renderJs = toStrict . renderToText . unJS++-- | 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
+ src/Web/Rep/Render.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | Page rendering+module Web.Rep.Render+ ( renderPage,+ renderPageWith,+ renderPageHtmlWith,+ renderPageAsText,+ renderPageToFile,+ renderPageHtmlToFile,+ )+where++import Control.Lens+import Lucid+import NumHask.Prelude+import Web.Rep.Html+import Web.Rep.Page++-- | Render a Page with the default configuration into Html.+renderPage :: Page -> Html ()+renderPage p =+ (\(_, _, x) -> x) $ renderPageWith (defaultPageConfig "default") p++-- | Render a Page into Html.+renderPageHtmlWith :: PageConfig -> Page -> Html ()+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 pc p =+ case pc ^. #concerns of+ Inline -> (mempty, mempty, h)+ Separated -> (css, js, h)+ where+ 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+ ]+ )+ )+ Headless ->+ mconcat+ [ 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+ ]+ 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+ | pc ^. #concerns == Separated || css == mempty = mempty+ | otherwise = style_ [type_ "text/css"] css+ jsInline+ | pc ^. #concerns == Separated || js == mempty = mempty+ | otherwise = script_ mempty js+ libsCss' =+ case pc ^. #concerns of+ Inline -> p ^. #libsCss+ Separated ->+ p ^. #libsCss+ <> [libCss (pack $ pc ^. #filenames . #cssConcern)]+ libsJs' =+ case pc ^. #concerns of+ Inline -> p ^. #libsJs+ Separated ->+ p ^. #libsJs+ <> [libJs (pack $ 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)+ where+ writeFile' fp s = unless (s == mempty) (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)++-- | Render a Page as Text.+renderPageAsText :: PageConfig -> Page -> Concerns Text+renderPageAsText pc p =+ case pc ^. #concerns of+ Inline -> Concerns mempty mempty htmlt+ Separated -> Concerns css js htmlt+ 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
@@ -0,0 +1,43 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wall #-}++-- | Serve pages via 'ScottyM'+module Web.Rep.Server+ ( servePageWith+ )+where++import Control.Lens hiding (only)+import Lucid+import Network.Wai.Middleware.Static (addBase, noDots, only, staticPolicy)+import NumHask.Prelude hiding (get, replace)+import Web.Rep.Render+import Web.Rep.Page+import Web.Scotty++-- | serve a Page via a ScottyM+servePageWith :: RoutePattern -> PageConfig -> Page -> ScottyM ()+servePageWith rp pc p =+ sequence_ $ servedir <> [getpage]+ where+ getpage = case pc ^. #concerns of+ Inline ->+ get rp (html $ renderText $ renderPageHtmlWith pc p)+ Separated ->+ let (css, js, h) = renderPageWith pc p+ in do+ middleware $ staticPolicy $ only [(cssfp, cssfp), (jsfp, jsfp)]+ get+ rp+ ( do+ lift $ writeFile' cssfp css+ lift $ writeFile' jsfp js+ html $ renderText h+ )+ cssfp = pc ^. #filenames . #cssConcern+ jsfp = pc ^. #filenames . #jsConcern+ writeFile' fp s = unless (s == mempty) (writeFile fp s)+ servedir = (\x -> middleware $ staticPolicy (noDots <> addBase x)) <$> pc ^. #localdirs
@@ -0,0 +1,210 @@+{-# 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 #-}++module Web.Rep.Shared+ (+ RepF (..),+ Rep,+ oneRep,+ SharedRepF (..),+ SharedRep,+ runOnce,+ zeroState,+ register,+ message,+ genName,+ genNamePre,+ )+where++import Control.Lens+import Data.Generics.Labels ()+import qualified Data.HashMap.Strict as HashMap+import Data.HashMap.Strict (HashMap)+import GHC.Show (show)+import Lucid+import NumHask.Prelude hiding (show)++-- |+-- 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.+--+-- 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)+ }+ 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++-- | name supply for elements of a 'SharedRep'+genName :: (MonadState Int m) => m Text+genName = do+ modify (+ 1)+ pack . 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 p = (p <>) <$> genName++-- | Create a sharedRep+register ::+ (Monad m) =>+ -- | Parser+ (Text -> Either Text a) ->+ -- | Printer+ (a -> Text) ->+ -- | create initial object from name and initial value+ (Text -> a -> r) ->+ -- | initial value+ a ->+ SharedRepF m r a+register p pr f a =+ SharedRep $ do+ name <- zoom _1 genName+ zoom _2 (modify (HashMap.insert name (pr a)))+ pure $+ Rep+ (f name a)+ ( \s ->+ ( s,+ join+ $ maybe (Left "lookup failed") Right+ $ either (Left . (\x -> name <> ": " <> x)) Right . p <$>+ HashMap.lookup name s+ )+ )++-- | Like 'register', 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+message ::+ (Monad m) =>+ -- | Parser+ (Text -> Either Text a) ->+ -- | create initial object from name and initial value+ (Text -> a -> r) ->+ -- | initial value+ a ->+ -- | default value+ a ->+ SharedRepF m r a+message p f a d =+ SharedRep $ do+ name <- zoom _1 genName+ pure $+ Rep+ (f name a)+ ( \s ->+ ( HashMap.delete name s,+ join+ $ maybe (Right $ Right d) Right+ $ p <$>+ HashMap.lookup name s+ )+ )++runSharedRep :: SharedRepF m r a -> m (RepF r a, (Int, HashMap Text Text))+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))+zeroState sr = do+ (Rep h fa, (_, m)) <- runSharedRep 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)) <- runSharedRep sr+ action h m+ pure (fa m)+
@@ -0,0 +1,474 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wredundant-constraints #-}++-- | Various SharedRep instances for common html input elements.+module Web.Rep.SharedReps+ ( repInput,+ repMessage,+ sliderI,+ slider,+ dropdown,+ dropdownMultiple,+ datalist,+ dropdownSum,+ colorPicker,+ textbox,+ textarea,+ checkbox,+ toggle,+ button,+ chooseFile,+ maybeRep,+ fiddle,+ viaFiddle,+ accordionList,+ listMaybeRep,+ listRep,+ readTextbox,+ defaultListLabels,+ repChoice,+ subtype,+ selectItems,+ repItemsSelect,+ )+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 Web.Rep.Bootstrap+import Web.Rep.Html+import Web.Rep.Html.Input+import Web.Rep.Shared+import Web.Rep.Page+import qualified Prelude as P+import qualified Data.Attoparsec.Text as 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 =+ register (first pack . A.parseOnly p) pr (\n v -> toHtml $ #inputVal .~ v $ #inputId .~ n $ i) a++-- | 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++-- | 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 ->+ Double ->+ Double ->+ Double ->+ Double ->+ 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)]))+ 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, P.Integral a, Show a) => SharedRep m a+sliderI ::+ (Monad m, ToHtml a, P.Integral a, Show a) =>+ Maybe Text ->+ a ->+ a ->+ a ->+ a ->+ 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)]))+ 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+ takeText+ id+ (Input v label mempty TextBox)+ v++-- | textbox that only updates on focusout+textbox' :: (Monad m) => Maybe Text -> Text -> SharedRep m Text+textbox' label v =+ repInput+ takeText+ 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 rows label v =+ repInput+ takeText+ id+ (Input v label mempty (TextArea rows))+ v++-- | Non-typed hex color input+colorPicker :: (Monad m) => Maybe Text -> Text -> SharedRep m Text+colorPicker label v =+ repInput+ takeText+ 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) ->+ -- | label suggestion+ Maybe Text ->+ -- | list of dropbox elements (as text)+ [Text] ->+ -- | initial value+ a ->+ SharedRep m a+dropdown p pr label opts v =+ repInput+ p+ pr+ (Input v label mempty (Dropdown opts))+ v++-- | dropdown box with multiple selections+dropdownMultiple ::+ (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]+dropdownMultiple p pr label opts vs =+ repInput+ (p `sepBy1` char ',')+ (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 label opts v id'' =+ repInput+ takeText+ (pack . 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] ->+ a ->+ SharedRep m a+dropdownSum p pr label opts v =+ repInput+ p+ pr+ (Input v label mempty (DropdownSum opts))+ v++-- | A checkbox input.+checkbox :: (Monad m) => Maybe Text -> Bool -> SharedRep m Bool+checkbox label v =+ repInput+ ((== "true") <$> takeText)+ (bool "false" "true")+ (Input v label mempty (Checkbox v))+ v++-- | a toggle button+toggle :: (Monad m) => Maybe Text -> Bool -> SharedRep m Bool+toggle label v =+ repInput+ ((== "true") <$> takeText)+ (bool "false" "true")+ (Input v label mempty (Toggle v label))+ v++-- | a button+button :: (Monad m) => Maybe Text -> SharedRep m Bool+button label =+ repMessage+ (pure True)+ (bool "false" "true")+ (Input False label mempty Button)+ False+ False++-- | filename input+chooseFile :: (Monad m) => Maybe Text -> Text -> SharedRep m Text+chooseFile label v =+ repInput+ takeText+ (pack . show)+ (Input v label mempty ChooseFile)+ v++-- | Represent a Maybe using a checkbox.+--+-- Hides the underlying content on Nothing+maybeRep ::+ (Monad m) =>+ Maybe Text ->+ Bool ->+ SharedRep m a ->+ SharedRep m (Maybe a)+maybeRep label st sa = SharedRep $ do+ id' <- zoom _1 (genNamePre "maybe")+ unshare $ bimap (hmap id') mmap (checkboxShow label id' st) <<*>> sa+ where+ hmap id' a b =+ cardify+ (a, [])+ Nothing+ ( Lucid.with+ div_+ [ id_ id',+ style_+ ("display:" <> bool "none" "block" st)+ ]+ b,+ [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 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')+ ( \s ->+ ( s,+ join+ $ maybe (Left "HashMap.lookup failed") Right+ $ either (Left . pack) Right . parseOnly ((== "true") <$> takeText)+ <$> HashMap.lookup name s+ )+ )++-- | toggle show/hide+scriptToggleShow :: (Monad m) => Text -> Text -> HtmlT m ()+scriptToggleShow checkName toggleId =+ script_+ [qq|+$('#{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 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)+ h' <- zoom _1 h+ pure (Rep (maybe mempty (h5_ . toHtml) 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 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+ )+ h' <- zoom _1 h+ pure (Rep (maybe mempty (h5_ . toHtml) 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 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 ->+ -- | name prefix (should be unique)+ (Bool -> SharedRep m Bool) ->+ -- | Bool Rep+ (a -> SharedRep m a) ->+ -- | a Rep+ Int ->+ -- | maximum length of list+ a ->+ -- | default value for new rows+ [a] ->+ -- | initial values+ SharedRep m [a]+listRep t p brf srf n defa as =+ second (mconcat . fmap (\(b, a) -> bool [] [a] b)) $+ accordionBoolList+ t+ p+ srf+ brf+ (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]++-- | 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)+ 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")++-- | 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'++repChoice :: (Monad m) => Int -> [(Text, 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+ t0 = ts List.!! initt+ hmap dd' cs' =+ div_+ ( dd'+ <> mconcat (zipWith (\c t -> subtype c t0 t) cs' ts)+ )+ 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 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++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))+ ]
+ src/Web/Rep/Socket.hs view
@@ -0,0 +1,309 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wredundant-constraints #-}++-- | A socket between a web page and haskell, based on the box library.+module Web.Rep.Socket+ ( socketPage,+ serveSocketBox,+ sharedServer,+ defaultSharedServer,+ SocketConfig(..),+ defaultSocketConfig,+ defaultSocketPage,+ defaultInputCode,+ defaultOutputCode,+ Code(..),+ code,+ )+where++import qualified Network.WebSockets as WS+import Box+import Box.Socket+import Control.Lens+import Control.Monad.Conc.Class as C+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 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++socketPage :: Page+socketPage = mempty & #jsOnLoad .~+ mconcat+ [ webSocket,+ runScriptJs,+ refreshJsbJs,+ preventEnter+ ]++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)++defaultSharedServer :: (Show a) => SharedRep IO a -> IO ()+defaultSharedServer srep =+ sharedServer srep defaultSocketConfig defaultSocketPage defaultInputCode defaultOutputCode++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)+ ]++-- I am proud of this.+backendLoop ::+ (MonadConc m) =>+ SharedRep m a ->+ -- | initial code to place html of the SharedRep+ (Html () -> [Code]) ->+ -- | output code+ (Either Text a -> m [Code]) ->+ Box m [Code] (Text, Text) -> m ()+backendLoop sr inputCode outputCode (Box c e) = flip evalStateT (0, HashMap.empty) $ do+ -- you only want to run unshare once for a SharedRep+ (Rep h fa) <- unshare sr+ b <- lift $ commit c (inputCode h)+ o <- step' fa+ b' <- lift $ commit c o+ when (b && b') (go fa)+ where+ go fa = do+ incoming <- lift $ emit e+ modify (updateS incoming)+ o <- step' fa+ b <- lift $ commit c o+ when b (go fa)+ updateS Nothing s = s+ updateS (Just (k,v)) s = second (insert k v) s++ step' fa = do+ s <- get+ let (m', ea) = fa (snd s)+ modify (second (const m'))+ o <- lift $ outputCode ea+ pure o++defaultInputCode :: Html () -> [Code]+defaultInputCode h = [Append "input" (toText h)]++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)]++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)++-- | {"event":{"element":"textid","value":"abcdees"}}+parserJ :: A.Parser (Text,Text)+parserJ = do+ _ <- A.string [q|{"event":{"element":"|]+ e <- A.takeTill (=='"')+ _ <- A.string [q|","value":"|]+ v <- A.takeTill (=='"')+ _ <- A.string [q|"}}|]+ pure (e,v)++-- * code hooks+-- * code messaging+data Code =+ Replace Text Text |+ Append Text Text |+ Console Text |+ Eval Text |+ Val Text+ deriving (Eq, Show, Generic, Read)++code :: Code -> Text+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}) |]++val :: Text -> Text+val t = [qc| jsb.ws.send({t}) |]++-- | replace a container and run any embedded scripts+replace :: Text -> Text -> Text+replace d t =+ [qc|+ var $container = document.getElementById('{d}');+ $container.innerHTML = '{clean t}';+ runScripts($container);+ refreshJsb();+ |]++-- | append to a container and run any embedded scripts+append :: Text -> Text -> Text+append d t =+ [qc|+ var $container = document.getElementById('{d}');+ $container.innerHTML += '{clean t}';+ runScripts($container);+ refreshJsb();+ |]++clean :: Text -> Text+clean =+ Text.intercalate "\\'" . Text.split (== '\'')+ . Text.intercalate "\\n"+ . Text.lines++-- * initial javascript+-- | create a web socket for event data+webSocket :: RepJs+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 + '})()');+};+|]++-- * scripts+-- | Event hooks that may need to be reattached given dynamic content creation.+refreshJsbJs :: RepJs+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(',')});+ }));+};+|]++-- | prevent the Enter key from triggering an event+preventEnter :: RepJs+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);+|]++-- | script injection js.+--+-- See https://ghinda.net/article/script-tags/ for why this might be needed.+runScriptJs :: RepJs+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)+}++function runScripts ($container) {+ // get scripts tags from a node+ var $scripts = $container.querySelectorAll('script')+ $scripts.forEach(function ($script) {+ insertScript($script)+ })+}+|]
stack.yaml view
@@ -1,13 +1,13 @@-resolver: lts-15.13+resolver: nightly-2020-06-25 packages: - '.' extra-deps:- - box-0.4.0- - lucid-svg-0.7.1- - javascript-bridge-0.2.0- - interpolatedstring-perl6-1.0.2- - text-format-0.3.2+ - numhask-0.6.0+ - box-0.5.0+ - box-socket-0.0.1 allow-newer: true++
test/test.hs view
@@ -1,16 +1,17 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-} module Main where import Control.Lens import Lucid-import Prelude+import NumHask.Prelude import Test.DocTest import Test.Tasty import Test.Tasty.Hspec-import Web.Page-import Web.Page.Examples+import Web.Rep+import Web.Rep.Examples import qualified Data.Text.IO as Text generatePage :: FilePath -> FilePath -> PageConfig -> Page -> IO ()@@ -24,7 +25,7 @@ genTest :: FilePath -> IO () genTest dir =- void $ generatePages dir [("default", (defaultPageConfig "default"), page1), ("sep", cfg2, page2)]+ void $ generatePages dir [("default", defaultPageConfig "default", page1), ("sep", cfg2, page2)] testVsFile :: FilePath -> FilePath -> PageConfig -> Page -> IO Bool testVsFile dir stem pc p = do@@ -46,13 +47,13 @@ t' <- Text.readFile (dir <> names ^. #htmlConcern) return (t, Concerns mempty mempty t') Separated -> do- t' <- sequenceA $ Text.readFile <$> (dir <>) <$> names+ t' <- sequenceA $ Text.readFile . (dir <>) <$> names return (t, t') testsRender :: IO (SpecWith ()) testsRender = return $- describe "Web.Page.Render" $ do+ describe "Web.Rep.Render" $ do it "run genTest 'test/canned/' to refresh canned files." True it "renderPage mempty" $ renderText (renderPage mempty) `shouldBe`@@ -66,7 +67,7 @@ testsBootstrap :: IO (SpecWith ()) testsBootstrap = return $- describe "Web.Page.Bootstrap" $ do+ 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>"@@ -76,82 +77,16 @@ flip evalStateT 0 . accordion "acctest" Nothing $ (\x -> (pack (show x), "filler")) <$> [1..2::Int]) `shouldBe`- "<div id=\"acctest1\" class=\" accordion \"><div class=\" card \"><div id=\"acctest2\" class=\" card-header \"><h2 class=\" mb-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 \"><h2 class=\" mb-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>"--testsBridge :: IO (SpecWith ())-testsBridge =- return $- describe "Web.Page.Bridge" $- it "bridgePage versus canned" $- toText (renderPage bridgePage) `shouldBe`- "<!DOCTYPE HTML><html lang=\"en\"><head><meta charset=\"utf-8\"></head><body><script>\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\nfunction refreshJsb () {\n $('.jsbClassEventChange').off('change');\n $('.jsbClassEventChange').on('change', (function(){\n jsb.event({ 'element': this.id, 'value': this.value});\n }));\n $('.jsbClassEventInput').off('input');\n $('.jsbClassEventInput').on('input', (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};\n window.onload=function(){\nwindow.jsb = {ws: new WebSocket('ws://' + location.host + '/')};\njsb.ws.onmessage = (evt) => eval(evt.data);\n};</script></body></html>"--testbs :: [Value]-testbs =- [ Object (fromList [("element","1"),("value","b1")])- , Object (fromList [("element","2"),("value","b2")])- , Object (fromList [("element","3"),("value","b3")])- ]--testvs :: [Value]-testvs =- [ Object (fromList [("element","2"),("value","false")])- , Object (fromList [("element","2"),("value","true")])- , Object (fromList [("element","3"),("value","x")])- , Object (fromList [("element","4"),("value","")])- , Object (fromList [("element","5"),("value","2")])- , Object (fromList [("element","6"),("value","0.6")])- , Object (fromList [("element","7"),("value","false")])- , Object (fromList [("element","8"),("value","true")])- , Object (fromList [("element","9"),("value","5")])- , Object (fromList [("element","10"),("value","#00b4cc")])- ]--testsRep :: IO (SpecWith ())-testsRep =- return $- describe "Web.Page.Rep" $ do- it "Rep mempty" $- runIdentity (runList (pure (mempty :: Text)) []) `shouldBe` []- it "mempty passes values through to hashmap" $- runIdentity (runList (pure (mempty :: Text)) testbs) `shouldBe`- [ Right (fromList [("1","b1")], Right "")- , Right (fromList [("1","b1"),("2","b2")], Right "")- , Right (fromList [("1","b1"),("2","b2"),("3","b3")], Right "")- ]- it "button consumes an event and the value is transitory" $- runIdentity- (runList- ((,) <$> button Nothing <*> button Nothing)- testbs) `shouldBe`- [ Right (fromList [],Right (True,False))- , Right (fromList [],Right (False,True))- , Right (fromList [("3","b3")],Right (False,False))- ]- it "repExamples versus canned" $- runIdentity (runOnce repExamples mempty) `shouldBe`- (fromList [("7","3"),("1","sometext"),("4","0.5"),("2","no initial value & multi-line text\\nrenders is not ok?/"),("5","true"),("8","Square"),("3","3"),("6","false"),("9","#454e56")],Right (RepExamples {repTextbox = "sometext", repTextarea = "no initial value & multi-line text\\nrenders is not ok?/", repSliderI = 3, repSlider = 0.5, repCheckbox = True, repToggle = False, repDropdown = 3, repShape = SquareShape, repColor = "#454e56"}))- it "listExample versus canned" $- runIdentity (runOnce (listExample 5) mempty) `shouldBe`- (fromList [("1","0"),("4","3"),("2","1"),("5","4"),("3","2"),("6","5")],Right [0,1,2,3,4,5])- it "fiddleExample versus canned" $- runIdentity (runOnce (fiddle fiddleExample) mempty) `shouldBe`- (fromList [("1",""),("2",""),("3","\n<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>\n")],Right (Concerns "" "" "\n<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>\n",False))-- it "repExamples run through some canned events" $- runIdentity (runList (maybeRep Nothing True repExamples) testvs) `shouldBe`- [Right (fromList [("7","true"),("4","no initial value & multi-line text\\nrenders is not ok?/"),("2","false"),("5","3"),("8","false"),("11","#454e56"),("3","sometext"),("6","0.5"),("9","3"),("10","Square")],Right Nothing),Right (fromList [("7","true"),("4","no initial value & multi-line text\\nrenders is not ok?/"),("2","true"),("5","3"),("8","false"),("11","#454e56"),("3","sometext"),("6","0.5"),("9","3"),("10","Square")],Right (Just (RepExamples {repTextbox = "sometext", repTextarea = "no initial value & multi-line text\\nrenders is not ok?/", repSliderI = 3, repSlider = 0.5, repCheckbox = True, repToggle = False, repDropdown = 3, repShape = SquareShape, repColor = "#454e56"}))),Right (fromList [("7","true"),("4","no initial value & multi-line text\\nrenders is not ok?/"),("2","true"),("5","3"),("8","false"),("11","#454e56"),("3","x"),("6","0.5"),("9","3"),("10","Square")],Right (Just (RepExamples {repTextbox = "x", repTextarea = "no initial value & multi-line text\\nrenders is not ok?/", repSliderI = 3, repSlider = 0.5, repCheckbox = True, repToggle = False, repDropdown = 3, repShape = SquareShape, repColor = "#454e56"}))),Right (fromList [("7","true"),("4",""),("2","true"),("5","3"),("8","false"),("11","#454e56"),("3","x"),("6","0.5"),("9","3"),("10","Square")],Right (Just (RepExamples {repTextbox = "x", repTextarea = "", repSliderI = 3, repSlider = 0.5, repCheckbox = True, repToggle = False, repDropdown = 3, repShape = SquareShape, repColor = "#454e56"}))),Right (fromList [("7","true"),("4",""),("2","true"),("5","2"),("8","false"),("11","#454e56"),("3","x"),("6","0.5"),("9","3"),("10","Square")],Right (Just (RepExamples {repTextbox = "x", repTextarea = "", repSliderI = 2, repSlider = 0.5, repCheckbox = True, repToggle = False, repDropdown = 3, repShape = SquareShape, repColor = "#454e56"}))),Right (fromList [("7","true"),("4",""),("2","true"),("5","2"),("8","false"),("11","#454e56"),("3","x"),("6","0.6"),("9","3"),("10","Square")],Right (Just (RepExamples {repTextbox = "x", repTextarea = "", repSliderI = 2, repSlider = 0.6, repCheckbox = True, repToggle = False, repDropdown = 3, repShape = SquareShape, repColor = "#454e56"}))),Right (fromList [("7","false"),("4",""),("2","true"),("5","2"),("8","false"),("11","#454e56"),("3","x"),("6","0.6"),("9","3"),("10","Square")],Right (Just (RepExamples {repTextbox = "x", repTextarea = "", repSliderI = 2, repSlider = 0.6, repCheckbox = False, repToggle = False, repDropdown = 3, repShape = SquareShape, repColor = "#454e56"}))),Right (fromList [("7","false"),("4",""),("2","true"),("5","2"),("8","true"),("11","#454e56"),("3","x"),("6","0.6"),("9","3"),("10","Square")],Right (Just (RepExamples {repTextbox = "x", repTextarea = "", repSliderI = 2, repSlider = 0.6, repCheckbox = False, repToggle = True, repDropdown = 3, repShape = SquareShape, repColor = "#454e56"}))),Right (fromList [("7","false"),("4",""),("2","true"),("5","2"),("8","true"),("11","#454e56"),("3","x"),("6","0.6"),("9","5"),("10","Square")],Right (Just (RepExamples {repTextbox = "x", repTextarea = "", repSliderI = 2, repSlider = 0.6, repCheckbox = False, repToggle = True, repDropdown = 5, repShape = SquareShape, repColor = "#454e56"}))),Right (fromList [("7","false"),("4",""),("2","true"),("5","2"),("8","true"),("11","#454e56"),("3","x"),("6","0.6"),("9","5"),("10","#00b4cc")],Right (Just (RepExamples {repTextbox = "x", repTextarea = "", repSliderI = 2, repSlider = 0.6, repCheckbox = False, repToggle = True, repDropdown = 5, repShape = CircleShape, repColor = "#454e56"})))]+ "<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.Page.Render" =<< testsRender- , testSpec "Web.Page.Bootstrap" =<< testsBootstrap- , testSpec "Web.Page.Bridge" =<< testsBridge- , testSpec "Web.Page.Rep" =<< testsRep+ [ testSpec "Web.Rep.Render" =<< testsRender+ , testSpec "Web.Rep.Bootstrap" =<< testsBootstrap ] main :: IO () main = do- doctest ["src/Web/Page/SharedReps.hs"]+ doctest ["src/Web/Rep/SharedReps.hs"] defaultMain =<< tests
web-rep.cabal view
@@ -1,6 +1,6 @@-cabal-version: 1.12+cabal-version: 2.4 name: web-rep-version: 0.5.0+version: 0.6.0 synopsis: representations of a web page category: web description: An applicative-based, shared-data representation of a web page. @@ -15,78 +15,111 @@ library exposed-modules:- Web.Page- Web.Page.Bootstrap- Web.Page.Bridge- Web.Page.Examples- Web.Page.Html- Web.Page.Html.Input- Web.Page.Mathjax- Web.Page.Render- Web.Page.SharedReps- Web.Page.Server- Web.Page.Types+ Web.Rep+ Web.Rep.Bootstrap+ Web.Rep.Examples+ Web.Rep.Html+ Web.Rep.Html.Input+ Web.Rep.Mathjax+ Web.Rep.Page+ Web.Rep.Render+ Web.Rep.Server+ Web.Rep.Shared+ Web.Rep.SharedReps+ Web.Rep.Socket hs-source-dirs:- src+ src build-depends: base >= 4.12 && <5,- aeson >= 1.4.5 && < 1.5, attoparsec >= 0.13.2 && < 0.14,- bifunctors >= 5.5.5 && < 5.6,- box >= 0.1.0 && < 0.5,+ box >= 0.5 && < 0.6,+ box-socket >= 0.0.1 && < 0.1, clay >= 0.13 && < 0.14, foldl >= 1.4.5 && < 1.5,- generic-lens >= 1.1.0 && < 1.3,+ generic-lens >= 1.1.0 && < 3.0, 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,+ lens >= 4.17.1 && < 4.20, lucid >= 2.9 && < 2.10,- lucid-svg >= 0.7.1 && < 0.8,- mmorph >= 1.1.3 && < 1.2, mtl >= 2.2.2 && < 2.3,+ numhask >= 0.6 && < 0.7, 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-middleware-static >= 0.8.2 && < 0.9+ websockets >= 0.12,+ concurrency >= 1.11,+ wai-middleware-static >= 0.8.3,+ wai-websockets >= 3.0.1.2, default-language: Haskell2010+ default-extensions:+ NegativeLiterals+ NoImplicitPrelude+ OverloadedStrings+ UnicodeSyntax+ ghc-options:+ -Wall+ -Wcompat+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wredundant-constraints -executable page-example- main-is: example.hs+executable rep-example+ main-is: rep-example.hs hs-source-dirs:- app- ghc-options: -funbox-strict-fields -fforce-recomp -threaded -rtsopts -with-rtsopts=-N+ app build-depends: base >= 4.12 && <5,- attoparsec >= 0.13.2 && < 0.14,- box >= 0.1.0 && < 0.5,- 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+ numhask >= 0.6 && < 0.7,+ optparse-generic >= 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 test-suite test type: exitcode-stdio-1.0 main-is: test.hs hs-source-dirs:- test- ghc-options: -Wall -O2 -threaded+ test build-depends: base >= 4.12 && <5, doctest >= 0.16 && < 1.0,- lens >= 4.17 && < 4.19,+ lens >= 4.17 && < 4.20, lucid >= 2.9.11 && < 2.10,+ numhask >= 0.6 && < 0.7, 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