web-rep (empty) → 0.1.1
raw patch · 19 files changed
+2410/−0 lines, 19 filesdep +JuicyPixelsdep +aesondep +attoparsecsetup-changed
Dependencies added: JuicyPixels, aeson, attoparsec, base, bifunctors, box, clay, foldl, formatting, generic-lens, interpolatedstring-perl6, javascript-bridge, language-javascript, lens, lucid, lucid-svg, mmorph, mtl, optparse-generic, protolude, scotty, streaming, tasty, tasty-hspec, text, transformers, unordered-containers, wai, wai-extra, wai-middleware-static, web-rep
Files
- LICENSE.md +21/−0
- Setup.hs +2/−0
- app/example.hs +236/−0
- src/Web/Page.hs +42/−0
- src/Web/Page/Bootstrap.hs +128/−0
- src/Web/Page/Bridge.hs +157/−0
- src/Web/Page/Css.hs +68/−0
- src/Web/Page/Examples.hs +246/−0
- src/Web/Page/Html.hs +94/−0
- src/Web/Page/Html/Input.hs +232/−0
- src/Web/Page/Js.hs +111/−0
- src/Web/Page/Render.hs +225/−0
- src/Web/Page/Rep.hs +249/−0
- src/Web/Page/Rep/Input.hs +183/−0
- src/Web/Page/Server.hs +37/−0
- src/Web/Page/Types.hs +117/−0
- stack.yaml +11/−0
- test/test.hs +155/−0
- web-rep.cabal +96/−0
+ LICENSE.md view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2015 Tony Day <tonyday567@gmail.com>++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/example.hs view
@@ -0,0 +1,236 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wall #-}++import Control.Category (id)+import Control.Lens hiding (Wrapped, Unwrapped)+import Data.Attoparsec.Text+import Lucid hiding (b_)+import Network.Wai+import Network.Wai.Middleware.RequestLogger+import Network.Wai.Middleware.Static (addBase, noDots, staticPolicy, (>->))+import Options.Generic+import Protolude hiding (replace, Rep, log)+import Web.Page+import Web.Page.Examples+import Web.Scotty+import qualified Box+import qualified Data.Text as Text++testPage :: Text -> Text -> [(Text, Html ())] -> Page+testPage title mid sections =+ bootstrapPage <>+ bridgePage &+ #htmlHeader .~ title_ "iroTestPage" &+ #htmlBody .~ b_ "container" (mconcat+ [ b_ "row" (h1_ (toHtml title))+ , b_ "row" (h2_ ("middleware: " <> toHtml mid))+ , b_ "row" $ mconcat $ (\(t,h) -> b_ "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: " <> 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 :: Text), []))++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+ appendWithScript e "input" (toText init)+ final <- eeio e `finally` putStrLn ("midBridgeTest finalled" :: Text)+ putStrLn $ ("final value was: " :: Text) <> 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 show)++initShowRep+ :: (Show a)+ => Engine+ -> Rep a+ -> StateT (HashMap Text Text) IO ()+initShowRep e r =+ void $ oneRep r+ (\(Rep h fa) m -> do+ appendWithScript e "input" (toText h)+ replace e "output" (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 _) _ ->+ appendWithScript 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 show) (\e -> logViaFiddle e 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+ appendWithScript 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 | Listify | ListifyMaybe | 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:" :: Text) >>+ 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))+ Listify -> midShow (listifyExample 5)+ ListifyMaybe -> midShow (listifyMaybeExample 10)+ Bridge -> midBridgeTest (toHtml rangeTest <> toHtml textTest)+ consumeBridgeTest+ Fiddle -> midFiddle fiddleExample+ ViaFiddle -> midViaFiddle+ (slider Nothing 0 10 0.01 4)+ servePageWith "/simple" defaultPageConfig page1+ servePageWith "/iro" defaultPageConfig+ (testPage "iro" (show $ midtype o)+ [ ("input", mempty)+ , ("representation", mempty)+ , ("output", mempty)+ ])+ servePageWith "/" defaultPageConfig+ (testPage "prod" (show $ midtype o)+ [ ("input", mempty)+ , ("output",+ (bool mempty+ (toHtml (show initBridgeTest :: Text))+ (midtype o == Bridge)))+ ])
+ src/Web/Page.hs view
@@ -0,0 +1,42 @@+module Web.Page+ ( renderJs+ , renderCss+ , renderHtml+ , module X+ , Value(..)+ , finally+ , PixelRGB8(..)+ , HashMap.HashMap(..)+ , fromList+ ) where++import Protolude hiding (Selector)+import Web.Page.Css as X+import Web.Page.Js as X+import Web.Page.Render as X+import Web.Page.Server as X+import Web.Page.Types as X+import Web.Page.Bridge as X+import Web.Page.Rep as X+import Web.Page.Rep.Input as X+import Web.Page.Html as X+import Web.Page.Html.Input as X+import Web.Page.Bootstrap as X+import Text.InterpolatedString.Perl6 as X+import Control.Exception (finally)++import GHC.Exts (fromList)+import qualified Data.HashMap.Strict as HashMap+import qualified Web.Page.Css as Css (render)+import qualified Web.Page.Js as Js+import Data.Aeson (Value(..))+import Codec.Picture.Types (PixelRGB8(..))++renderJs :: JS -> Text+renderJs = toStrict . Js.renderToText . Js.unJS++renderCss :: Css -> Text+renderCss = toStrict . Css.render++renderHtml :: Html a -> Text+renderHtml = toText
+ src/Web/Page/Bootstrap.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}++module Web.Page.Bootstrap+ ( bootstrapPage+ , cardify+ , b_+ , accordion+ , accordionChecked+ , accordionCardChecked+ , accordion_+ ) where++import Lucid hiding (b_)+import Lucid.Base+import Protolude+import Web.Page.Html+import Web.Page.Types++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"]+ ]++bootstrapPage :: Page+bootstrapPage =+ Page+ bootstrapCss+ bootstrapJs+ mempty+ mempty+ mempty+ (mconcat bootstrapMeta)+ mempty++-- | wrap some Html with the bootstrap 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+b_ :: Text -> Html () -> Html ()+b_ t = with div_ [class__ t]++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)++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, Monad m) => Text -> Maybe Text -> [(Text, Html ())] -> 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, Monad 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++accordion_ :: Text -> Maybe Text -> [(Text, Html ())] -> Html ()+accordion_ pre x hs = runIdentity $ evalStateT (accordion pre x hs) 0+
+ src/Web/Page/Bridge.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -Wall #-}++module Web.Page.Bridge+ ( bridgePage+ , sendc+ , append+ , replace+ , appendWithScript+ , replaceWithScript+ , bridge+ , sendConcerns+ , Engine+ , start+ , Application+ , midShared+ ) where++import Box.Cont+import Control.Lens+import Data.Aeson (Value)+import Data.HashMap.Strict as HashMap+import Lucid+import Network.JavaScript (Engine, start, send, command, addListener, JavaScript(..), Application)+import Protolude hiding (replace, Rep)+import Text.InterpolatedString.Perl6+import Web.Page.Html+import Web.Page.Js+import Web.Page.Rep+import Web.Page.Types+import qualified Data.Text as Text++preventEnter :: PageJs+preventEnter = PageJs $ fromText [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);+|]++webSocket :: PageJs+webSocket = PageJsText [q|+window.jsb = {ws: new WebSocket('ws://' + location.host + '/')};+jsb.ws.onmessage = (evt) => eval(evt.data);+|]++-- see https://ghinda.net/article/script-tags/+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)+ })+}+|]++bridgePage :: Page+bridgePage =+ mempty &+ #jsGlobal .~ (preventEnter <> runScriptJs) &+ #jsOnLoad .~ webSocket++sendc :: Engine -> Text -> IO ()+sendc e = send e . command . JavaScript . fromStrict++replace :: Engine -> Text -> Text -> IO ()+replace e d t = send e $ command+ [qc|+ var $container = document.getElementById('{d}')+ $container.innerHTML = '{clean t}'+ runScripts($container)+ |]++append :: Engine -> Text -> Text -> IO ()+append e d t = send e $ command+ [qc|+ var $container = document.getElementById('{d}')+ $container.innerHTML += '{clean t}'+ runScripts($container)+ |]++replaceWithScript :: Engine -> Text -> Text -> IO ()+replaceWithScript e d t = send e $ command+ [qc|+ var $container = document.getElementById('{d}')+ $container.innerHTML = '{clean t}'+ runScripts($container)+ |]++appendWithScript :: Engine -> Text -> Text -> IO ()+appendWithScript e d t = send e $ command+ [qc|+ var $container = document.getElementById('{d}')+ $container.innerHTML += '{clean t}'+ runScripts($container)+ |]++sendConcerns :: Engine -> Text -> Concerns Text -> IO ()+sendConcerns e t (Concerns c j h) = do+ replaceWithScript e t h+ append e t (toText $ style_ c)+ sendc e j++bridge :: Engine -> Cont_ IO Value+bridge e = Cont_ $ \vio -> void $ addListener e vio++clean :: Text -> Text+clean =+ Text.intercalate "\\'" . Text.split (=='\'') .+ Text.intercalate "\\n" . Text.lines+++-- | create Wai Middleware for a SharedRep providing an initialiser and action on events+midShared ::+ (Show a) =>+ 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)++++
+ src/Web/Page/Css.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module Web.Page.Css+ ( fill+ , stroke+ , strokeWidth+ , crispEdges+ , optimizeSpeed+ , geometricPrecision+ , shapeRendering+ , Css+ , render+ , renderWith+ , compact+ , PageCss(..)+ ) where++import Clay hiding (optimizeSpeed, geometricPrecision, PlayState)+import Clay.Stylesheet (key)+import Data.Text+import Data.Text.Lazy (unpack)+import Protolude+import qualified GHC.Show++instance Show Css where+ show = Data.Text.Lazy.unpack . render++instance Eq Css where+ (==) a' b' = (Protolude.show a' :: Text) == Protolude.show b'++data PageCss = PageCss Css | PageCssText Text deriving (Eq, Show, Generic)++instance Semigroup PageCss where+ (<>) (PageCss css) (PageCss css') = PageCss (css <> css')+ (<>) (PageCssText css) (PageCssText css') = PageCssText (css <> css')+ (<>) (PageCss css) (PageCssText css') =+ PageCssText (show css <> css')+ (<>) (PageCssText css) (PageCss css') =+ PageCssText (css <> show css')++instance Monoid PageCss where+ mempty = PageCssText mempty+ mappend = (<>)++-- a few SVG css+fill :: Color -> Css+fill = key "fill"++stroke :: Color -> Css+stroke = key "stroke"++strokeWidth :: Size Position -> Css+strokeWidth = key "stroke-width"++newtype ShapeRendering = ShapeRendering Value+ deriving (Inherit, Auto, Val)++crispEdges, optimizeSpeed, geometricPrecision :: ShapeRendering+crispEdges = ShapeRendering "crispEdges"+optimizeSpeed = ShapeRendering "optimizeSpeed"+geometricPrecision = ShapeRendering "geometricPrecision"++shapeRendering :: ShapeRendering -> Css+shapeRendering = key "shape-rendering"
+ src/Web/Page/Examples.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -Wall #-}++module Web.Page.Examples+ ( page1+ , page2+ , cfg2+ , RepExamples(..)+ , repExamples+ , Shape(..)+ , fromShape+ , toShape+ , SumTypeExample(..)+ , repSumTypeExample+ , SumType2Example(..)+ , repSumType2Example+ , listifyExample+ , listifyMaybeExample+ , fiddleExample+ ) where++import Control.Category (id)+import Control.Lens hiding ((.=))+import Data.Attoparsec.Text+import Data.Biapplicative+import Lucid+import Protolude hiding ((<<*>>))+import Web.Page+import qualified Clay++-- | simple page examples+page1 :: Page+page1 =+ #htmlBody .~ button1 $+ #cssBody .~ PageCss css1 $+ #jsGlobal .~ mempty $+ #jsOnLoad .~ click $+ #libsCss .~ (libCss <$> cssLibs) $+ #libsJs .~ (libJs <$> jsLibs) $+ mempty++page2 :: Page+page2 =+ #libsCss .~ (libCss <$> cssLibsLocal) $+ #libsJs .~ (libJs <$> jsLibsLocal) $+ page1++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)++data RepExamples =+ RepExamples+ { repTextbox :: Text+ , repTextarea :: Text+ , repSliderI :: Int+ , repSlider :: Double+ , repCheckbox :: Bool+ , repToggle :: Bool+ , repDropdown :: Int+ , repShape :: Shape+ , repColor :: PixelRGB8+ } deriving (Show, Eq, Generic)++data Shape = SquareShape | CircleShape deriving (Eq, Show, Generic)++toShape :: Text -> Shape+toShape t = case t of+ "Circle" -> CircleShape+ "Square" -> SquareShape+ _ -> CircleShape++fromShape :: Shape -> Text+fromShape CircleShape = "Circle"+fromShape SquareShape = "Square"++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 show (Just "dropdown") (show <$> [1..5::Int]) 3+ drt <- toShape <$> dropdown takeText id (Just "shape") (["Circle", "Square"]) (fromShape SquareShape)+ col <- colorPicker (Just "color") (PixelRGB8 56 128 200)+ pure (RepExamples t ta n ds' c tog dr drt col)++-- encodeFile "saves/rep2.json" $ RepExamples "text1" "text2" 1 1.0 True True 2 (PixelRGB8 0 100 0)+-- decodeFileStrict "saves/rep2.json" :: IO (Maybe RepExamples)++listifyExample :: (Monad m) => Int -> SharedRep m [Int]+listifyExample n =+ accordionListify (Just "accordianListify") "al" Nothing+ (\l a -> sliderI (Just l) (0::Int) n 1 a) ((\x -> "[" <> show x <> "]") <$> [0..n] :: [Text]) [0..n]++listifyMaybeExample :: (Monad m) => Int -> SharedRep m [Int]+listifyMaybeExample n =+ listifyMaybe' (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 view
@@ -0,0 +1,94 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module Web.Page.Html+ ( class__+ , toText+ , genName+ , genNamePre+ , libCss+ , libJs+ , fromHex+ , toHex+ , Html+ ) where++import Data.Text+import Lucid+import Protolude hiding ((%))+import qualified Data.Text.Lazy as Lazy+-- import qualified GHC.Show+import Codec.Picture.Types (PixelRGB8(..))+import Data.Attoparsec.Text+import Numeric+import Formatting hiding (string)++class__ :: Text -> Attribute+class__ t = class_ (" " <> t <> " ")++toText :: Html a -> Text+toText = Lazy.toStrict . renderText++-- | name supply for html elements+genName :: (MonadState Int m, Monad m) => m Text+genName = do+ modify (+1)+ show <$> get++-- | sometimes a number doesn't work properly in html (or js???), and an alpha prefix seems to help+genNamePre :: (MonadState Int m, Monad m) => Text -> m Text+genNamePre pre = (pre <>) <$> genName++libCss :: Text -> Html ()+libCss url = link_+ [ rel_ "stylesheet"+ , href_ url+ ]++libJs :: Text -> Html ()+libJs url = with (script_ mempty) [src_ url]++fromHex :: Parser PixelRGB8+fromHex =+ (\((r,g),b) ->+ PixelRGB8 (fromIntegral r) (fromIntegral g) (fromIntegral b)) .+ (\(f,b) -> (f `divMod` (256 :: Int), b)) .+ (`divMod` 256) <$>+ (string "#" *> hexadecimal)++toHex :: PixelRGB8 -> Text+toHex (PixelRGB8 r g b) = sformat ("#" % ((left 2 '0') %. hex) % ((left 2 '0') %. hex) % ((left 2 '0') %. hex)) r g b++-- `ToHtml a` is used throughout because `Show a` gives "\"text\"" for show "text", and hilarity ensues when rendering to the web page.+-- hence orphans+instance ToHtml Double where+ toHtml = toHtml . (show :: Double -> Text)+ toHtmlRaw = toHtmlRaw . (show :: Double -> Text)++{-+instance (RealFrac a, Floating a) => ToHtml (Colour a) where+ toHtml = toHtml . sRGB24show+ toHtmlRaw = toHtmlRaw . sRGB24show++instance (RealFrac a, Floating a) => Show (Colour a) where+ show = sRGB24show++-}++instance ToHtml Bool where+ toHtml = toHtml . bool ("false" :: Text) "true"+ toHtmlRaw = toHtmlRaw . bool ("false" :: Text) "true"++instance ToHtml Int where+ toHtml = toHtml . (show :: Int -> Text)+ toHtmlRaw = toHtmlRaw . (show :: Int -> Text)++instance ToHtml PixelRGB8 where+ toHtml = toHtml . toHex+ toHtmlRaw = toHtmlRaw . toHex++instance ToHtml () where+ toHtml = const "()"+ toHtmlRaw = const "()"+
+ src/Web/Page/Html/Input.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -Wall #-}++module Web.Page.Html.Input+ ( Input(Input)+ , InputType(..)+ , scriptToggleShow+ ) where++import Data.Text+import Lucid+import Lucid.Base+import Protolude hiding (for_)+import Text.InterpolatedString.Perl6+import Web.Page.Html++-- | something that might exist on a web page and be a front-end input to computations.+data Input a =+ Input+ { inputVal :: a+ , inputLabel :: Maybe Text+ , inputId :: Text+ , inputType :: InputType+ } deriving (Eq, Show, Generic)++-- | various types of Inputs, that encapsulate practical bootstrap class functionality+data InputType =+ Slider [Attribute] |+ TextBox |+ TextArea Int |+ ColorPicker |+ ChooseFile |+ Dropdown [Text] |+ DropdownSum [Text] |+ Datalist [Text] Text |+ Checkbox Bool |+ Toggle Bool (Maybe Text) |+ Button+ deriving (Eq, Show, Generic)++instance (ToHtml a) => ToHtml (Input a) where+ toHtml (Input v l i (Slider satts)) =+ with div_ [class__ "form-group"]+ ((maybe mempty (with label_ [for_ i] . toHtml) l) <>+ input_+ ([ type_ "range"+ , class__ " form-control-range custom-range"+ , id_ i+ , value_ (show $ toHtml v)+ ] <> satts) <>+ scriptJsbEvent i "change")+ toHtml (Input v l i TextBox) =+ with div_ [class__ "form-group"]+ ((maybe mempty (with label_ [for_ i] . toHtml) l) <>+ input_+ ([ type_ "text"+ , class__ "form-control"+ , id_ i+ , value_ (show $ toHtml v)+ ]) <>+ scriptJsbEvent i "input")+ toHtml (Input v l i (TextArea rows)) =+ with div_ [class__ "form-group"]+ (maybe mempty (with label_ [for_ i] . toHtml) l <>+ (with textarea_+ [ rows_ (show rows)+ , class__ "form-control"+ , id_ i+ ] (toHtmlRaw v)+ ) <>+ scriptJsbEvent i "input")+ toHtml (Input v l i ColorPicker) =+ with div_ [class__ "form-group"]+ ((maybe mempty (with label_ [for_ i] . toHtml) l) <>+ input_+ ([ type_ "color"+ , class__ "form-control"+ , id_ i+ , value_ (show $ toHtml v)+ ]) <>+ scriptJsbEvent i "input")+ toHtml (Input _ l i ChooseFile) =+ with div_ [class__ "form-group"]+ (maybe mempty (with label_ [for_ i] . toHtml) l) <>+ input_+ ([ type_ "file"+ , class__ "form-control-file"+ , id_ i+ ]) <>+ scriptJsbChooseFile i+ toHtml (Input v l i (Dropdown opts)) =+ with div_ [class__ "form-group"]+ ((maybe mempty (with label_ [for_ i] . toHtml) l) <>+ (with select_+ [ class__ "form-control"+ , id_ i+ ] opts') <>+ scriptJsbEvent i "input")+ 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"+ , id_ i+ ] opts') <>+ scriptShowSum i <>+ scriptJsbEvent i "input")+ where+ opts' = mconcat $+ (\o -> with option_+ (bool [] [selected_ "selected"] (toText (toHtml o) == toText (toHtml v)))+ (toHtml o)) <$> opts+ toHtml (Input v l i (Datalist opts listId)) =+ with div_ [class__ "form-group"]+ ((maybe mempty (with label_ [for_ i] . toHtml) l) <>+ input_+ [ type_ "text"+ , class__ "form-control"+ , id_ i+ , list_ listId+ -- the datalist concept in html assumes initial state is a null+ -- and doesn't present the list if it has a value alreadyx+ -- , value_ (show $ toHtml v)+ ] <>+ with datalist_ [id_ listId] (mconcat $ (\o ->+ with option_ (bool [] [selected_ "selected"]+ (toText (toHtml o) == toText (toHtml v)))+ (toHtml o)) <$> opts) <>+ scriptJsbEvent i "input")+ -- FIXME: How can you refactor to eliminate this polymorphic wart?+ toHtml (Input _ l i (Checkbox checked)) =+ with div_ [class__ "form-check"]+ (input_+ ([ type_ "checkbox"+ , class__ "form-check-input"+ , id_ i+ ] <>+ bool [] [checked_] checked) <>+ (maybe mempty (with label_ [for_ i, class__ "form-check-label"] . toHtml) l) <>+ scriptJsbCheckbox i)+ toHtml (Input _ l i (Toggle pushed lab)) =+ with div_ [class__ "form-group"]+ (( maybe mempty (with label_ [for_ i] . toHtml) l) <>+ input_+ ([ type_ "button"+ , class__ "btn btn-primary btn-sm"+ , data_ "toggle" "button"+ , id_ i+ , makeAttribute "aria-pressed" (bool "false" "true" pushed)+ ] <>+ (maybe [] (\l' -> [value_ l']) lab) <>+ bool [] [checked_] pushed) <>+ scriptJsbToggle i)+ toHtml (Input _ l i Button) =+ with div_ [class__ "form-group"]+ (input_+ ( [ type_ "button"+ , id_ i+ , class__ "btn btn-primary btn-sm"+ , value_ (fromMaybe "button" l)+ ]) <>+ scriptJsbButton i)++ toHtmlRaw = toHtml++-- scripts attached to Inputs+-- https://eager.io/blog/everything-I-know-about-the-script-tag/++scriptJsbEvent :: (Monad m) => Text -> Text -> HtmlT m ()+scriptJsbEvent name event = script_ [qq|+$('#{name}').on('{event}', (function()\{+ jsb.event(\{ 'element': this.id, 'value': this.value\});+\}));+|]++scriptJsbButton :: (Monad m) => Text -> HtmlT m ()+scriptJsbButton name = script_ [qq|+$('#{name}').on('click', (function()\{+ jsb.event(\{ 'element': this.id, 'value': this.value\});+\}));+|]++scriptJsbToggle :: (Monad m) => Text -> HtmlT m ()+scriptJsbToggle name = script_ [qq|+$('#{name}').on('click', (function()\{+ jsb.event(\{ 'element': this.id, 'value': (\"true\" !== this.getAttribute(\"aria-pressed\")).toString()\});+\}));+|]++scriptJsbCheckbox :: (Monad m) => Text -> HtmlT m ()+scriptJsbCheckbox name = script_ [qq|+$('#{name}').on('click', (function()\{+ jsb.event(\{ 'element': this.id, 'value': this.checked.toString()\});+\}));+|]++scriptJsbChooseFile :: (Monad m) => Text -> HtmlT m ()+scriptJsbChooseFile name = script_ [qq|+$('#{name}').on('input', (function()\{+ jsb.event(\{ 'element': this.id, 'value': this.files[0].name\});+\}));+|]++scriptShowSum :: (Monad m) => Text -> HtmlT m ()+scriptShowSum name = script_ [qq|+$('#{name}').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';+ \}\})+ \}));+|]++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/Js.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE QuasiQuotes #-}++module Web.Page.Js+ ( JS(..)+ , JSStatement(..)+ , PageJs(..)+ , minifyJS+ , onLoad+ , onLoadStatements+ , toStatements+ , toStatement+ , renderToStatement+ , renderToText+ , readJs+ , fromText+ ) where++import Language.JavaScript.Parser+import Language.JavaScript.Parser.AST+import Language.JavaScript.Process.Minify+import Protolude hiding ((<>))+import qualified Data.Text as Text+import Data.Semigroup ((<>))+import Text.InterpolatedString.Perl6++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 = (<>)++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 = (<>)++toStatements :: JS -> [JSStatement]+toStatements (JS (JSAstProgram ss _)) = ss+toStatements (JS (JSAstStatement s _)) = [s]+toStatements (JS (JSAstExpression e ann')) = [JSExpressionStatement e (JSSemi ann')]+toStatements (JS (JSAstLiteral e ann')) = [JSExpressionStatement e (JSSemi ann')]++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')++renderToStatement :: Text -> JSStatement+renderToStatement t = toStatement $ JS $ readJs $ Text.unpack t++-- | standard window loader+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}};|]++onLoad :: PageJs -> PageJs+onLoad (PageJs js) = PageJs $ onLoadStatements [toStatement js]+onLoad (PageJsText js) = PageJsText $ onLoadText js++fromText :: Text -> JS+fromText = JS . readJs . Text.unpack
+ src/Web/Page/Render.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLabels #-}++module Web.Page.Render+ ( renderPage+ , renderPageWith+ , renderPageHtmlWith+ , renderPageAsText+ , renderPageToFile+ , renderPageHtmlToFile+ , renderPageTextWith+ ) where++import Control.Applicative+import Control.Lens+import Control.Monad+import Data.Monoid+import Data.Text (Text)+import Data.Text.IO (writeFile)+import Data.Text.Lazy (fromStrict, toStrict)+import Data.Traversable+import Lucid+import Prelude hiding (writeFile)+import Web.Page.Html+import Web.Page.Types+import qualified Data.Text as Text+import qualified Lucid.Svg as Svg+import qualified Web.Page.Css as Css+import qualified Web.Page.Js as Js++renderPage :: Page -> Html ()+renderPage p =+ (\(_, _, x) -> x) $ renderPageWith defaultPageConfig p++renderPageHtmlWith :: PageConfig -> Page -> Html ()+renderPageHtmlWith pc p =+ (\(_, _, x) -> x) $ renderPageWith pc p++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 <> Js.onLoad (p ^. #jsOnLoad))+ (renderjs, rendercss) = renderers $ 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 . #css)]+ libsJs' =+ case pc ^. #concerns of+ Inline -> p ^. #libsJs+ Separated ->+ p ^. #libsJs <>+ [libJs (Text.pack $ pc ^. #filenames . #js)]++renderPageToFile :: FilePath -> PageConfig -> Page -> IO ()+renderPageToFile dir pc page =+ void $ sequenceA $ liftA2 writeFile' (pc ^. #filenames) (renderPageAsText pc page)+ where+ writeFile' fp s = unless (s == mempty) (writeFile (dir <> "/" <> fp) s)++renderPageHtmlToFile :: FilePath -> PageConfig -> Page -> IO ()+renderPageHtmlToFile file pc page =+ writeFile file (toText $ renderPageHtmlWith pc page)++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++rendererJs :: PageRender -> Js.PageJs -> Text+rendererJs _ (Js.PageJsText js) = js+rendererJs Minified (Js.PageJs js) = toStrict . Js.renderToText . Js.minifyJS . Js.unJS $ js+rendererJs Pretty (Js.PageJs js) = toStrict . Js.renderToText . Js.unJS $ js++rendererCss :: PageRender -> Css.PageCss -> Text+rendererCss Minified (Css.PageCss css) = toStrict $ Css.renderWith Css.compact [] css+rendererCss Pretty (Css.PageCss css) = toStrict $ Css.render css+rendererCss _ (Css.PageCssText css) = css++renderers :: PageRender -> (Js.PageJs -> Text, Css.PageCss -> Text)+renderers p = (rendererJs p, rendererCss p)++renderPageTextWith :: PageConfig -> PageText -> (Text, Text, Html ())+renderPageTextWith 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"]+ , toHtmlRaw cssInline+ , mconcat (toHtmlRaw <$> libsCss')+ , toHtmlRaw $ p ^. #htmlHeaderText+ ]) <>+ body_+ (mconcat+ [ toHtmlRaw $ p ^. #htmlBodyText+ , mconcat (toHtmlRaw <$> libsJs')+ , toHtmlRaw jsInline+ ]))+ Headless ->+ mconcat+ [ doctype_+ , meta_ [charset_ "utf-8"]+ , mconcat (toHtmlRaw <$> libsCss')+ , toHtmlRaw cssInline+ , toHtmlRaw $ p ^. #htmlHeaderText+ , toHtmlRaw $ p ^. #htmlBodyText+ , mconcat (toHtmlRaw <$> libsJs')+ , toHtmlRaw jsInline+ ]+ Snippet ->+ mconcat+ [ mconcat (toHtmlRaw <$> libsCss')+ , toHtmlRaw cssInline+ , toHtmlRaw $ p ^. #htmlHeaderText+ , toHtmlRaw $ p ^. #htmlBodyText+ , mconcat (toHtmlRaw <$> libsJs')+ , toHtmlRaw jsInline+ ]+ Svg ->+ Svg.doctype_ <>+ svg_+ (Svg.defs_ $+ mconcat+ [ mconcat (toHtmlRaw <$> libsCss')+ , toHtmlRaw cssInline+ , toHtmlRaw $ p ^. #htmlBodyText+ , mconcat (toHtmlRaw <$> libsJs')+ , toHtmlRaw jsInline+ ])+ css = p ^. #cssBodyText+ js = rendererJs Pretty (Js.PageJsText $ p ^. #jsGlobalText) <>+ rendererJs Pretty (Js.onLoad (Js.PageJsText $ p ^. #jsOnLoadText))+ cssInline+ | pc ^. #concerns == Separated || css == mempty = mempty+ | otherwise = renderText $ style_ [type_ "text/css"] css+ jsInline+ | pc ^. #concerns == Separated || js == mempty = mempty+ | otherwise = renderText $ script_ mempty js+ libsCss' =+ case pc ^. #concerns of+ Inline -> fromStrict <$> p ^. #libsCssText+ Separated ->+ (fromStrict <$> p ^. #libsCssText) <>+ [renderText $ libCss (Text.pack $ pc ^. #filenames . #css)]+ libsJs' =+ case pc ^. #concerns of+ Inline -> fromStrict <$> p ^. #libsJsText+ Separated ->+ (fromStrict <$> p ^. #libsJsText) <>+ [renderText $ libJs (Text.pack $ pc ^. #filenames . #js)]+
+ src/Web/Page/Rep.hs view
@@ -0,0 +1,249 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -Wall #-}++module Web.Page.Rep+ ( Element(..)+ , RepF(..)+ , Rep+ , oneRep+ , SharedRepF(..)+ , SharedRep+ , runOnce+ , zeroState+ , listify+ , accordionListify+ , accordionListifyMaybe+ , listifyDefault+ , listifyMaybe+ , listifyMaybe'+ , defaultListifyLabels+ , valueModel+ , valueConsume+ , sharedModel+ , sharedConsume+ , runList+ , runOnEvent+ ) where++import Box+import Box.Cont ()+import Control.Lens+import Control.Monad.Morph+import Data.Aeson+import Data.Biapplicative+import Data.Bifunctor (Bifunctor(..))+import Data.HashMap.Strict hiding (foldr)+import Data.Text (pack, Text)+import Lucid+import Protolude hiding ((<<*>>), Rep, empty)+import Web.Page.Bootstrap+import qualified Control.Foldl as L+import qualified Streaming.Prelude as S++-- | Abstracted message event elements+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"++fromJson' :: (FromJSON a) => Value -> Either Text a+fromJson' v = case fromJSON v of+ (Success a) -> Right a+ (Error e) -> Left $ "Json conversion error: " <> pack e <> " of " <> show v++data RepF r a = Rep+ { rep :: r+ , make :: HashMap Text Text -> (HashMap Text Text, Either Text a)+ } deriving (Functor)++type Rep a = RepF (Html ()) a++instance (Semigroup r) => Semigroup (RepF r a) where+ (Rep r0 a0) <> (Rep r1 a1) =+ Rep+ (r0 <> r1)+ (\hm -> let (hm', x') = a0 hm in let (hm'', x'') = a1 hm' in (hm'', x' <> x''))++instance (Monoid a, Monoid r) => Monoid (RepF r a) where+ mempty = Rep mempty (,Right mempty)+ mappend = (<>)++instance Bifunctor RepF where+ bimap f g (Rep r a) = Rep (f r) (second (fmap g) . a)++instance Biapplicative RepF where+ bipure r a = Rep r (, Right a)+ (Rep fr fa) <<*>> (Rep r a) = Rep (fr r)+ (\hm ->+ let (hm', a') = a hm in let (hm'', fa') = fa hm' in (hm'', fa' <*> a'))++instance (Monoid r) => Applicative (RepF r) where+ pure = bipure mempty+ Rep fh fm <*> Rep ah am =+ Rep (fh <> ah) (\hm ->+ let (hm', a') = am hm in let (hm'', fa') = fm hm' in (hm'', fa' <*> a'))++oneRep :: (Monad m, MonadIO m) => Rep a -> (Rep a -> HashMap Text Text -> m ()) -> StateT (HashMap Text Text) m (HashMap Text Text, Either Text a)+oneRep r@(Rep _ fa) action = do+ m <- get+ let (m',a) = fa m+ put m'+ lift $ action r m'+ pure (m',a)++newtype SharedRepF m r a = SharedRep+ { unrep :: StateT (Int, HashMap Text Text) m (RepF r a)+ } deriving Functor++type SharedRep m a = SharedRepF m (Html ()) a ++instance (Functor m) => Bifunctor (SharedRepF m) where+ bimap f g (SharedRep s) = SharedRep $ fmap (bimap f g) s++instance (Monad m) => Biapplicative (SharedRepF m) where+ bipure r a = SharedRep $ pure $ bipure r a+ (SharedRep f) <<*>> (SharedRep a) = SharedRep $ liftA2 (<<*>>) f a++instance (Monad m, Monoid r) => Applicative (SharedRepF m r) where+ pure = bipure mempty+ SharedRep f <*> SharedRep a = SharedRep $ liftA2 (<*>) f a++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, empty) $ unrep sr+ action h m+ pure (fa m)++zeroState+ :: (Monad m)+ => SharedRep m a+ -> m (Html (), (HashMap Text Text, Either Text a))+zeroState sr = do+ (Rep h fa, (_, m)) <- flip runStateT (0, empty) $ unrep sr+ pure (h, fa m)++listify :: (Monad m) => (Text -> a -> SharedRep m a) -> [Text] -> [a] -> SharedRep m [a]+listify sr labels as = foldr (\a x -> (:) <$> a <*> x) (pure []) (zipWith sr labels as)++accordionListify :: (Monad m) => Maybe Text -> Text -> Maybe Text -> (Text -> a -> SharedRep m a) -> [Text] -> [a] -> SharedRep m [a]+accordionListify 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)++accordionListifyMaybe :: (Monad m) => Maybe Text -> Text -> (a -> SharedRep m a) -> (Bool -> SharedRep m Bool) -> [Text] -> [(Bool, a)] -> SharedRep m [(Bool,a)]+accordionListifyMaybe 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)++listifyDefault :: (Monad m) => Maybe Text -> Text -> (Text -> a -> SharedRep m a) -> [a] -> SharedRep m [a]+listifyDefault t p srf as = accordionListify t p Nothing srf (defaultListifyLabels (length as)) as++listifyMaybe :: (Monad m) => Maybe Text -> Text -> (Text -> Maybe a -> SharedRep m (Maybe a)) -> Int -> [a] -> SharedRep m [Maybe a]+listifyMaybe t p srf n as = accordionListify t p Nothing srf (defaultListifyLabels n) (take n ((Just <$> as) <> repeat Nothing)) ++listifyMaybe' :: (Monad m) => Maybe Text -> Text -> (Bool -> SharedRep m Bool) -> (a -> SharedRep m a) -> Int -> a -> [a] -> SharedRep m [a]+listifyMaybe' t p brf srf n defa as = second (mconcat . fmap (\(b,a) -> bool [] [a] b)) $ accordionListifyMaybe t p srf brf (defaultListifyLabels n) (take n (((True,) <$> as) <> repeat (False, defa)))++defaultListifyLabels :: Int -> [Text]+defaultListifyLabels n = (\x -> "[" <> show x <> "]") <$> [0..n] :: [Text]++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++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, 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))++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))))++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, 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
+ src/Web/Page/Rep/Input.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}++module Web.Page.Rep.Input+ ( repInput+ , repMessage+ , sliderI+ , slider+ , dropdown+ , datalist+ , dropdownSum+ , colorPicker+ , textbox+ , textarea+ , checkbox+ , toggle+ , button+ , chooseFile+ , maybeRep+ , fiddle+ , viaFiddle+ ) where++import Codec.Picture.Types (PixelRGB8(..))+import Control.Category (id)+import Control.Lens+import Data.Attoparsec.Text+import Data.Biapplicative+import Data.Bifunctor (Bifunctor(..))+import Data.HashMap.Strict+import Data.Text (pack, Text)+import Lucid+import Protolude hiding ((<<*>>), Rep)+import Web.Page.Bootstrap+import Web.Page.Html+import Web.Page.Html.Input+import Web.Page.Types+import Web.Page.Rep+import Box.Cont ()++-- | create a sharedRep from an Input+repInput :: (Monad m, ToHtml a, Show a) => Parser a -> (a -> Text) -> Input a -> a -> SharedRep m a+repInput p pr i a =+ SharedRep $ do+ name <- zoom _1 genName+ zoom _2 (modify (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 <$> lookup name s))++-- | 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, Show 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 ->+ (delete name s, join $+ maybe (Right $ Right def) Right $+ either (Left . pack) Right . parseOnly p <$> lookup name s))++slider :: (Monad m) => Maybe Text -> Double -> Double -> Double -> Double ->+ SharedRep m Double+slider label l u s v = repInput double show+ (Input v label mempty (Slider [min_ (pack $ show l), max_ (pack $ show u), step_ (pack $ show s)])) v++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 show + (Input v label mempty (Slider [min_ (pack $ show l), max_ (pack $ show u), step_ (pack $ show s)])) v++textbox :: (Monad m) => Maybe Text -> Text -> SharedRep m Text+textbox label v = repInput takeText id+ (Input v label mempty TextBox) v++textarea :: (Monad m) => Int -> Maybe Text -> Text -> SharedRep m Text+textarea rows label v = repInput takeText id+ (Input v label mempty (TextArea rows)) v++colorPicker :: (Monad m) => Maybe Text -> PixelRGB8 -> SharedRep m PixelRGB8+colorPicker label v = repInput fromHex toHex+ (Input v label mempty ColorPicker) v++dropdown :: (Monad m, ToHtml a, Show a) =>+ Parser a -> (a -> Text) -> Maybe Text -> [Text] -> a -> SharedRep m a+dropdown p pr label opts v = repInput p pr + (Input v label mempty (Dropdown opts)) v++datalist :: (Monad m) => Maybe Text -> [Text] -> Text -> Text -> SharedRep m Text+datalist label opts v id'' = repInput takeText show+ (Input v label mempty (Datalist opts id'')) v++dropdownSum :: (Monad m, ToHtml a, Show 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++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++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++button :: (Monad m) => Maybe Text -> SharedRep m Bool+button label = repMessage (pure True) (bool "false" "true")+ (Input False label mempty Button) False False++chooseFile :: (Monad m) => Maybe Text -> Text -> SharedRep m Text+chooseFile label v = repInput takeText 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 (insert name (bool "false" "true" v)))+ pure $+ Rep+ (toHtml (Input v label name (Checkbox v)) <> scriptToggleShow name cl)+ (\s ->+ (s, join $+ maybe (Left "lookup failed") Right $+ either (Left . pack) Right . parseOnly ((=="true") <$> takeText) <$>+ lookup name s))++-- | represent a Maybe type using a checkbox hiding 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++-- | 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'
+ src/Web/Page/Server.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedLabels #-}+{-# OPTIONS_GHC -Wall #-}++module Web.Page.Server+ ( servePageWith+ ) where++import Control.Lens hiding (only)+import Lucid (renderText)+import Network.Wai.Middleware.Static (addBase, noDots, staticPolicy, only)+import Protolude hiding (get)+import Web.Page.Render+import Web.Page.Types+import Web.Scotty+import qualified Control.Monad.State as State++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 css+ State.lift $ writeFile' jsfp js+ html $ renderText h)+ cssfp = pc ^. #filenames . #css+ jsfp = pc ^. #filenames . #js+ writeFile' fp s = unless (s == mempty) (writeFile fp s)+ servedir = (\x -> middleware $ staticPolicy (noDots <> addBase x)) <$> pc ^. #localdirs+
+ src/Web/Page/Types.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}++module Web.Page.Types+ ( Page(Page)+ , PageText(PageText)+ , PageConfig(PageConfig)+ , defaultPageConfig+ , Concern(..)+ , Concerns(Concerns)+ , suffixes+ , concernNames+ , PageConcerns(..)+ , PageStructure(..)+ , PageRender(..)+ ) where++import Control.Lens+import Data.Generics.Labels()+import Data.Semigroup ((<>))+import Lucid+import Protolude hiding ((<>))+import qualified Web.Page.Css as Css+import qualified Web.Page.Js as Js++data Page =+ Page+ { libsCss :: [Html ()]+ , libsJs :: [Html ()]+ , cssBody :: Css.PageCss+ , jsGlobal :: Js.PageJs+ , jsOnLoad :: Js.PageJs+ , htmlHeader :: 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 = (<>)++data PageText =+ PageText+ { libsCssText :: [Text]+ , libsJsText :: [Text]+ , cssBodyText :: Text+ , jsGlobalText :: Text+ , jsOnLoadText :: Text+ , htmlHeaderText :: Text+ , htmlBodyText :: Text+ } deriving (Show, Generic)++data Concern = Css | Js | Html deriving (Show, Eq, Generic)++data Concerns a =+ Concerns+ { css :: a+ , js :: a+ , html :: 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)++suffixes :: Concerns FilePath+suffixes = Concerns ".css" ".js" ".html"++concernNames :: FilePath -> FilePath -> Concerns FilePath+concernNames dir stem =+ (\x->dir<>stem<>x) <$> suffixes++data PageConcerns =+ Inline |+ Separated+ deriving (Show, Eq, Generic)++data PageStructure =+ HeaderBody |+ Headless |+ Snippet |+ Svg+ deriving (Show, Eq, Generic)++data PageRender =+ Pretty |+ Minified+ deriving (Show, Eq, Generic)++data PageConfig =+ PageConfig+ { concerns :: PageConcerns+ , structure :: PageStructure+ , pageRender :: PageRender+ , filenames :: Concerns FilePath+ , localdirs :: [FilePath]+ } deriving (Show, Eq, Generic)++defaultPageConfig :: PageConfig+defaultPageConfig = PageConfig Inline HeaderBody Minified+ (("default"<>) <$> suffixes) []
+ stack.yaml view
@@ -0,0 +1,11 @@+resolver: lts-14.11++packages:+- '.'++extra-deps:+ - lucid-svg-0.7.1+ - box-0.0.1.4+ - javascript-bridge-0.2.0++allow-newer: true
+ test/test.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Lens+import Lucid+import Protolude+import Test.Tasty+import Test.Tasty.Hspec+import Web.Page+import Web.Page.Examples+import qualified Data.Text.IO as Text++generatePage :: FilePath -> FilePath -> PageConfig -> Page -> IO ()+generatePage dir stem pc =+ renderPageToFile dir (#filenames .~ concernNames "" stem $ pc) ++generatePages ::+ Traversable t => FilePath -> t (FilePath, PageConfig, Page) -> IO ()+generatePages dir xs =+ void $ sequenceA $ (\(fp, pc, p) -> generatePage dir fp pc p) <$> xs++genTest :: FilePath -> IO ()+genTest dir =+ void $ generatePages dir [("default", defaultPageConfig, page1), ("sep", cfg2, page2)]++testVsFile :: FilePath -> FilePath -> PageConfig -> Page -> IO Bool+testVsFile dir stem pc p = do+ (t,t') <- textVsFile dir stem pc p+ pure (t==t')++textVsFile+ :: FilePath+ -> FilePath+ -> PageConfig+ -> Page+ -> IO (Concerns Text, Concerns Text)+textVsFile dir stem pc p = do+ let names = concernNames "" stem+ let pc' = #filenames .~ names $ pc+ let t = renderPageAsText pc' p+ case pc ^. #concerns of+ Inline -> do+ t' <- Text.readFile (dir <> names ^. #html)+ return (t, Concerns mempty mempty t')+ Separated -> do+ t' <- sequenceA $ Text.readFile <$> (dir <>) <$> names+ return (t, t')++testsRender :: IO (SpecWith ())+testsRender =+ return $+ describe "Web.Page.Render" $ do+ it "run genTest 'test/canned/' to refresh canned files." True+ it "renderPage mempty" $+ renderText (renderPage mempty) `shouldBe`+ "<!DOCTYPE HTML><html lang=\"en\"><head><meta charset=\"utf-8\"></head><body><script>window.onload=function(){}</script></body></html>"+ let dir = "test/canned/"+ it "renderPageToFile, renderPage (compared with default canned file)" $+ testVsFile dir "default" defaultPageConfig page1 `shouldReturn` True+ it "the various PageConfig's" $+ testVsFile dir "sep" cfg2 page2 `shouldReturn` True++testsBootstrap :: IO (SpecWith ())+testsBootstrap =+ return $+ describe "Web.Page.Bootstrap" $ do+ it "bootstrapPage versus canned" $+ toText (renderPage bootstrapPage) `shouldBe`+ "<!DOCTYPE HTML><html lang=\"en\"><head><meta charset=\"utf-8\"><link crossorigin=\"anonymous\" href=\"https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/css/bootstrap.min.css\" integrity=\"sha384-ggOyR0iXCbMQv3Xipma34MD+dH/1fQ784/j6cY/iJTQUOhcWr7x9JvoRxT2MZw1T\" rel=\"stylesheet\"><meta charset=\"utf-8\"><meta content=\"width=device-width, initial-scale=1, shrink-to-fit=no\" name=\"viewport\"></head><body><script crossorigin=\"anonymous\" integrity=\"sha384-q8i/X+965DzO0rT7abK41JStQIAqVgRVzpbzo5smXKp4YfRvH+8abtTE1Pi6jizo\" src=\"https://code.jquery.com/jquery-3.3.1.slim.min.js\"></script><script crossorigin=\"anonymous\" integrity=\"sha384-UO2eT0CpHqdSJQ6hJty5KVphtPhzWj9WO1clHTMGa3JDZwrnQq4sF86dIHNDz0W1\" src=\"https://cdnjs.cloudflare.com/ajax/libs/popper.js/1.14.7/umd/popper.min.js\"></script><script crossorigin=\"anonymous\" integrity=\"sha384-JjSmVgyd0p3pXB1rRibZUAYoIIy6OrQ6VrjIEaFf/nJGzIxFDsf4x0xIM+B07jRM\" src=\"https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/js/bootstrap.min.js\"></script><script>window.onload=function(){}</script></body></html>"+ it "accordion versus canned" $+ ( toText .+ runIdentity .+ flip evalStateT 0 .+ accordion "acctest" Nothing $+ (\x -> (Protolude.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\n\nfunction insertScript ($script) {\n var s = document.createElement('script')\n s.type = 'text/javascript'\n if ($script.src) {\n s.onload = callback\n s.onerror = callback\n s.src = $script.src\n } else {\n s.textContent = $script.innerText\n }\n\n // re-insert the script tag so it executes.\n document.head.appendChild(s)\n\n // clean-up\n $script.parentNode.removeChild($script)\n}\n\nfunction runScripts ($container) {\n // get scripts tags from a node\n var $scripts = $container.querySelectorAll('script')\n $scripts.forEach(function ($script) {\n insertScript($script)\n })\n}\n 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","#3880c8")],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 = PixelRGB8 56 128 200}))+ it "listifyExamples versus canned" $+ runIdentity (runOnce (listifyExample 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","#3880c8"),("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","#3880c8"),("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 = PixelRGB8 56 128 200}))),Right (fromList [("7","true"),("4","no initial value & multi-line text\\nrenders is not ok?/"),("2","true"),("5","3"),("8","false"),("11","#3880c8"),("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 = PixelRGB8 56 128 200}))),Right (fromList [("7","true"),("4",""),("2","true"),("5","3"),("8","false"),("11","#3880c8"),("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 = PixelRGB8 56 128 200}))),Right (fromList [("7","true"),("4",""),("2","true"),("5","2"),("8","false"),("11","#3880c8"),("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 = PixelRGB8 56 128 200}))),Right (fromList [("7","true"),("4",""),("2","true"),("5","2"),("8","false"),("11","#3880c8"),("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 = PixelRGB8 56 128 200}))),Right (fromList [("7","false"),("4",""),("2","true"),("5","2"),("8","false"),("11","#3880c8"),("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 = PixelRGB8 56 128 200}))),Right (fromList [("7","false"),("4",""),("2","true"),("5","2"),("8","true"),("11","#3880c8"),("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 = PixelRGB8 56 128 200}))),Right (fromList [("7","false"),("4",""),("2","true"),("5","2"),("8","true"),("11","#3880c8"),("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 = PixelRGB8 56 128 200}))),Right (fromList [("7","false"),("4",""),("2","true"),("5","2"),("8","true"),("11","#3880c8"),("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 = PixelRGB8 56 128 200})))]+++-- 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+ ]++main :: IO ()+main = defaultMain =<< tests
+ web-rep.cabal view
@@ -0,0 +1,96 @@+cabal-version: 1.12+name: web-rep+version: 0.1.1+synopsis: representations of a web pag+category: web+description: See readme.md for verbage (if any)+bug-reports: https://github.com/tonyday567/web-page/issues+maintainer: Tony Day <tonyday567@gmail.com>+license: MIT+license-file: LICENSE.md+build-type: Simple+extra-source-files:+ stack.yaml++library+ exposed-modules:+ Web.Page+ Web.Page.Bootstrap+ Web.Page.Bridge+ Web.Page.Css+ Web.Page.Examples+ Web.Page.Html+ Web.Page.Html.Input+ Web.Page.Js+ Web.Page.Render+ Web.Page.Rep+ Web.Page.Rep.Input+ Web.Page.Server+ Web.Page.Types+ hs-source-dirs:+ src+ build-depends:+ JuicyPixels+ , aeson+ , attoparsec+ , base >= 4.12 && <5+ , bifunctors+ , box+ , clay+ , foldl+ , formatting+ , generic-lens+ , interpolatedstring-perl6+ , javascript-bridge+ , language-javascript+ , lens+ , lucid+ , lucid-svg+ , mmorph+ , mtl+ , protolude+ , scotty+ , streaming+ , text+ , transformers+ , unordered-containers+ , wai-middleware-static+ default-language: Haskell2010++executable page-example+ main-is: example.hs+ hs-source-dirs:+ app+ ghc-options: -funbox-strict-fields -fforce-recomp -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ attoparsec+ , base >= 4.12 && <5+ , box+ , lens+ , lucid+ , optparse-generic+ , protolude+ , scotty+ , text+ , wai+ , wai-extra+ , wai-middleware-static+ , web-rep+ default-language: Haskell2010++test-suite test+ type: exitcode-stdio-1.0+ main-is: test.hs+ hs-source-dirs:+ test+ ghc-options: -Wall -O2 -threaded+ build-depends:+ base >= 4.12 && <5+ , lens+ , lucid+ , protolude+ , tasty+ , tasty-hspec+ , text+ , web-rep+ default-language: Haskell2010