web-rep 0.1.3 → 0.2.0
raw patch · 18 files changed
+1159/−1042 lines, 18 filesdep −protolude
Dependencies removed: protolude
Files
- app/example.hs +34/−34
- readme.md +32/−0
- src/Web/Page.hs +20/−21
- src/Web/Page/Bootstrap.hs +111/−74
- src/Web/Page/Bridge.hs +159/−64
- src/Web/Page/Css.hs +0/−68
- src/Web/Page/Examples.hs +13/−14
- src/Web/Page/Html.hs +23/−21
- src/Web/Page/Html/Input.hs +9/−5
- src/Web/Page/Js.hs +0/−111
- src/Web/Page/Render.hs +15/−99
- src/Web/Page/Rep.hs +0/−249
- src/Web/Page/Rep/Input.hs +0/−184
- src/Web/Page/Server.hs +8/−5
- src/Web/Page/SharedReps.hs +354/−0
- src/Web/Page/Types.hs +367/−74
- test/test.hs +9/−9
- web-rep.cabal +5/−10
app/example.hs view
@@ -3,37 +3,38 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wall #-} -import Control.Category (id)+import Prelude hiding (log, init) import Control.Lens hiding (Wrapped, Unwrapped)-import Data.Attoparsec.Text-import Lucid hiding (b_)-import Network.Wai-import Network.Wai.Middleware.RequestLogger+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 Protolude hiding (replace, Rep, log) import Web.Page import Web.Page.Examples-import Web.Scotty+import Web.Scotty (scotty, middleware) import qualified Box import qualified Data.Text as Text+import Data.Text (pack, Text)+import Control.Monad+import Data.Maybe 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+ #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@@ -72,14 +73,14 @@ (\x -> Right (x,t)) (parseOnly decimal v) step (Element "textid" v) (n, _) = Right (n,v)- step e' _ = Left $ "unknown id: " <> show e'+ 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 :: Text), []))+ (toHtml (show a), [])) consumeBridgeTest :: Engine -> IO (Int, Text) consumeBridgeTest e =@@ -90,15 +91,15 @@ 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+ 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 show)+midShow sr = midShared sr initShowRep (logResults (pack . show)) initShowRep :: (Show a)@@ -108,8 +109,8 @@ initShowRep e r = void $ oneRep r (\(Rep h fa) m -> do- appendWithScript e "input" (toText h)- replace e "output" (show (fa m)))+ 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)@@ -129,7 +130,7 @@ initFiddleRep e r = void $ oneRep r (\(Rep h _) _ ->- appendWithScript e "input" (toText 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)@@ -137,13 +138,12 @@ 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)+ midShared (viaFiddle sr) (initViaFiddleRep (pack . show)) (\e -> logViaFiddle e (pack . show) . second snd) initViaFiddleRep :: (a -> Text)@@ -153,7 +153,7 @@ initViaFiddleRep rend e r = void $ oneRep r (\(Rep h fa) m -> do- appendWithScript e "input" (toText h)+ append e "input" (toText h) case (snd $ fa m) of Left err -> append e "log" ("map error: " <> err) Right (_,c,a) -> do@@ -168,7 +168,7 @@ 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)+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@@ -193,7 +193,7 @@ middleware logStdoutDev when (tr $ logPath o) $ middleware $ \app req res ->- putStrLn ("raw path:" :: Text) >>+ 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@@ -212,25 +212,25 @@ (repSumTypeExample 2 "default text" SumOnly) SumType2Example -> midShow (repSumType2Example 2 "default text" SumOnly (SumOutside 2))- Listify -> midShow (listifyExample 5)- ListifyMaybe -> midShow (listifyMaybeExample 10)+ 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- servePageWith "/iro" defaultPageConfig- (testPage "iro" (show $ midtype o)+ servePageWith "/simple" (defaultPageConfig "page1") page1+ servePageWith "/iro" (defaultPageConfig "iro")+ (testPage "iro" (pack . show $ midtype o) [ ("input", mempty) , ("representation", mempty) , ("output", mempty) ])- servePageWith "/" defaultPageConfig- (testPage "prod" (show $ midtype o)+ servePageWith "/" (defaultPageConfig "prod")+ (testPage "prod" (pack . show $ midtype o) [ ("input", mempty) , ("output", (bool mempty- (toHtml (show initBridgeTest :: Text))+ (toHtml (show initBridgeTest)) (midtype o == Bridge))) ])
+ readme.md view
@@ -0,0 +1,32 @@+[web-rep](https://github.com/tonyday567/web-rep) [](https://travis-ci.org/tonyday567/web-rep)+===++Various functions and representations for a web page.+++recipes+---++```+stack build --test --exec "$(stack path --local-install-root)/bin/page-example --midtype Prod" --file-watch+stack build web-rep:test:test --file-watch --ghc-options -freverse-errors+```++reference+---++- 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)+- 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+---++https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/eval#Do_not_ever_use_eval!+
src/Web/Page.hs view
@@ -1,42 +1,41 @@++-- | haskell for web page representations+ module Web.Page- ( renderJs- , renderCss- , renderHtml- , module X+ ( module X , Value(..) , finally , PixelRGB8(..) , HashMap.HashMap(..) , fromList+ , void+ , sequenceA_+ , Text+ , pack+ , unpack+ , bool ) where -import Protolude hiding (Selector)-import Web.Page.Css as X-import Web.Page.Js as X+import Web.Page.SharedReps as X import Web.Page.Render as X import Web.Page.Server as X import Web.Page.Types as X import Web.Page.Bridge as X-import Web.Page.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.Monad.Trans.State as X+import Data.Bifunctor as X+import Control.Applicative as X+import Data.Biapplicative as X import Control.Exception (finally)-+import Data.Text.Lazy (toStrict) import GHC.Exts (fromList) import qualified Data.HashMap.Strict as HashMap-import 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+import Control.Monad+import Data.Foldable (sequenceA_)+import Data.Text (Text, pack, unpack)+import Data.Bool
src/Web/Page/Bootstrap.hs view
@@ -4,125 +4,162 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wall #-} +-- | some <https://getbootstrap.com/ bootstrap> assets module Web.Page.Bootstrap- ( bootstrapPage- , cardify- , b_- , accordion- , accordionChecked- , accordionCardChecked- , accordion_- ) where+ ( bootstrapPage,+ cardify,+ divClass_,+ accordion,+ accordionChecked,+ accordionCardChecked,+ accordion_,+ )+where -import Lucid hiding (b_)+import Lucid import Lucid.Base-import Protolude+import Prelude import Web.Page.Html import Web.Page.Types+import Data.Text (Text)+import Control.Monad.State+import Data.Bool+import Data.Functor.Identity 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"- ]]+ [ 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"- ]+ [ 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"]+ [ 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+ bootstrapCss+ bootstrapJs+ mempty+ mempty+ mempty+ (mconcat bootstrapMeta)+ mempty --- | wrap some Html with the bootstrap card class+-- | 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)+ 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]+divClass_ :: Text -> Html () -> Html ()+divClass_ 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)+ 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)+ 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 -> Maybe Text -> [(Text, Html ())] -> m (Html ())+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+ 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+ 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 view
@@ -1,4 +1,3 @@-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}@@ -6,36 +5,48 @@ {-# OPTIONS_GHC -Wredundant-constraints #-} module Web.Page.Bridge- ( bridgePage- , sendc- , append- , replace- , appendWithScript- , replaceWithScript- , bridge- , sendConcerns- , Engine- , start- , Application- , midShared- ) where+ ( bridgePage,+ append,+ replace,+ bridge,+ sendConcerns,+ Engine,+ start,+ Application,+ valueConsume,+ sharedConsume,+ runList,+ runOnEvent,+ midShared,+ )+where -import Box.Cont+import Box+import Box.Cont ()+import qualified Control.Foldl as L import Control.Lens-import Data.Aeson (Value)+import Control.Monad.Morph+import Data.Aeson import Data.HashMap.Strict as HashMap+import qualified Data.Text as Text import Lucid-import Network.JavaScript (Engine, start, send, command, addListener, JavaScript(..), Application)-import Protolude hiding (replace, Rep)+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.Js-import Web.Page.Rep import Web.Page.Types-import qualified Data.Text as Text+import Prelude hiding (init)+import Data.Text (Text, pack)+import Data.Text.Lazy (fromStrict)+import Control.Monad.State+import GHC.Conc +-- | prevent the Enter key from triggering an event preventEnter :: PageJs-preventEnter = PageJs $ fromText [q|+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') {@@ -46,16 +57,22 @@ }, true); |] +-- | create a web socket for event data webSocket :: PageJs-webSocket = PageJsText [q|+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/+-- | script injection js.+--+-- See https://ghinda.net/article/script-tags/ for why this is needed. runScriptJs :: PageJs-runScriptJs = PageJsText [q|-+runScriptJs =+ PageJsText+ [q| function insertScript ($script) { var s = document.createElement('script') s.type = 'text/javascript'@@ -83,75 +100,153 @@ } |] +-- | componentry to kick off a javascript-bridge enabled page bridgePage :: Page bridgePage =- mempty &- #jsGlobal .~ (preventEnter <> runScriptJs) &- #jsOnLoad .~ webSocket+ mempty+ & #jsGlobal .~ (preventEnter <> runScriptJs)+ & #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|+replace e d t =+ send e $+ command+ [qc| var $container = document.getElementById('{d}') $container.innerHTML = '{clean t}' runScripts($container) |] +-- | append to a container and run any embedded scripts append :: Engine -> Text -> Text -> IO ()-append e d t = send e $ command- [qc|+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)- |]+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- replaceWithScript e t h+ 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 -clean :: Text -> Text-clean =- Text.intercalate "\\'" . Text.split (=='\'') .- Text.intercalate "\\n" . Text.lines+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 --- | create Wai Middleware for a SharedRep providing an initialiser and action on events+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+ Application ->+ Application midShared sr init action = start $ \e ->- void $ runOnEvent- sr- (zoom _2 . init e)- (action e)- (bridge 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))
− src/Web/Page/Css.hs
@@ -1,68 +0,0 @@-{-# 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
@@ -20,19 +20,18 @@ , repSumTypeExample , SumType2Example(..) , repSumType2Example- , listifyExample- , listifyMaybeExample+ , listExample+ , listRepExample , fiddleExample ) where -import Control.Category (id) import Control.Lens hiding ((.=)) import Data.Attoparsec.Text-import Data.Biapplicative import Lucid-import Protolude hiding ((<<*>>))+import Prelude import Web.Page import qualified Clay+import GHC.Generics -- | simple page examples page1 :: Page@@ -58,7 +57,7 @@ #structure .~ Headless $ #localdirs .~ ["test/static"] $ #filenames .~ (("other/cfg2" <>) <$> suffixes) $- defaultPageConfig+ (defaultPageConfig "") cssLibs :: [Text] cssLibs =@@ -131,7 +130,7 @@ ds' <- slider (Just "double slider") 0 1 0.1 0.5 c <- checkbox (Just "checkbox") True tog <- toggle (Just "toggle") False- dr <- dropdown decimal show (Just "dropdown") (show <$> [1..5::Int]) 3+ dr <- dropdown decimal (pack . show) (Just "dropdown") ((pack . show) <$> [1..5::Int]) 3 drt <- toShape <$> dropdown takeText id (Just "shape") (["Circle", "Square"]) (fromShape SquareShape) col <- colorPicker (Just "color") (PixelRGB8 56 128 200) pure (RepExamples t ta n ds' c tog dr drt col)@@ -139,14 +138,14 @@ -- 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]+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] -listifyMaybeExample :: (Monad m) => Int -> SharedRep m [Int]-listifyMaybeExample n =- listifyMaybe' (Just "listifyMaybe") "alm" (checkbox Nothing)+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
src/Web/Page/Html.hs view
@@ -16,17 +16,21 @@ import Data.Text import Lucid-import Protolude hiding ((%))+import Prelude import qualified Data.Text.Lazy as Lazy import Codec.Picture.Types (PixelRGB8(..)) import Data.Attoparsec.Text import Numeric import Data.Text.Format import Data.Text.Lazy.Builder (toLazyText)+import Control.Monad.State+import Data.Bool +-- | 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 @@ -34,21 +38,28 @@ genName :: (MonadState Int m) => m Text genName = do modify (+1)- show <$> get+ (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] +-- | convert from #xxxxxx to 'PixelRGB8' fromHex :: Parser PixelRGB8 fromHex = (\((r,g),b) ->@@ -57,36 +68,27 @@ (`divMod` 256) <$> (string "#" *> hexadecimal) +-- | convert from 'PixelRGB8' to #xxxxxx toHex :: PixelRGB8 -> Text toHex (PixelRGB8 r g b) = "#"- <> justifyRight 2 '0' (toStrict $ toLazyText $ hex r)- <> justifyRight 2 '0' (toStrict $ toLazyText $ hex g)- <> justifyRight 2 '0' (toStrict $ toLazyText $ hex b)+ <> justifyRight 2 '0' (Lazy.toStrict $ toLazyText $ hex r)+ <> justifyRight 2 '0' (Lazy.toStrict $ toLazyText $ hex g)+ <> justifyRight 2 '0' (Lazy.toStrict $ toLazyText $ hex b) --- `ToHtml a` is used throughout because `Show a` gives "\"text\"" for show "text", and hilarity ensues when rendering to the web page.--- hence orphans+-- FIXME: `ToHtml a` is used throughout, mostly because `Show a` gives "\"text\"" for show "text", and hilarity ensues when rendering this to a web page, and I couldn't work out how to properly get aro0und this.+-- 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---}+ 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 . (show :: Int -> Text)- toHtmlRaw = toHtmlRaw . (show :: Int -> Text)+ toHtml = toHtml . (pack . show)+ toHtmlRaw = toHtmlRaw . (pack . show) instance ToHtml PixelRGB8 where toHtml = toHtml . toHex
src/Web/Page/Html/Input.hs view
@@ -14,9 +14,12 @@ import Data.Text import Lucid import Lucid.Base-import Protolude hiding (for_)+import Prelude import Text.InterpolatedString.Perl6 import Web.Page.Html+import GHC.Generics+import Data.Bool+import Data.Maybe -- | something that might exist on a web page and be a front-end input to computations. data Input a =@@ -50,7 +53,7 @@ ([ type_ "range" , class__ " form-control-range custom-range" , id_ i- , value_ (show $ toHtml v)+ , value_ (pack $ show $ toHtml v) ] <> satts) <> scriptJsbEvent i "change") toHtml (Input v l i TextBox) =@@ -60,14 +63,14 @@ ([ type_ "text" , class__ "form-control" , id_ i- , value_ (show $ toHtml v)+ , value_ (pack $ show $ toHtml v) ]) <> scriptJsbEvent i "input") toHtml (Input v l i (TextArea rows)) = with div_ [class__ "form-group"] (maybe mempty (with label_ [for_ i] . toHtml) l <> (with textarea_- [ rows_ (show rows)+ [ rows_ (pack $ show rows) , class__ "form-control" , id_ i ] (toHtmlRaw v)@@ -80,7 +83,7 @@ ([ type_ "color" , class__ "form-control" , id_ i- , value_ (show $ toHtml v)+ , value_ (pack $ show $ toHtml v) ]) <> scriptJsbEvent i "input") toHtml (Input _ l i ChooseFile) =@@ -223,6 +226,7 @@ \})); |] +-- | toggle show/hide scriptToggleShow :: (Monad m) => Text -> Text -> HtmlT m () scriptToggleShow checkName toggleClass = script_ [qq| $('#{checkName}').on('change', (function()\{
− src/Web/Page/Js.hs
@@ -1,111 +0,0 @@-{-# 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
@@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLabels #-} +-- | Page rendering module Web.Page.Render ( renderPage , renderPageWith@@ -9,7 +10,6 @@ , renderPageAsText , renderPageToFile , renderPageHtmlToFile- , renderPageTextWith ) where import Control.Applicative@@ -26,17 +26,19 @@ 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+import Data.Foldable +-- | Render a Page with the default configuration into Html. renderPage :: Page -> Html () renderPage p =- (\(_, _, x) -> x) $ renderPageWith defaultPageConfig 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@@ -93,8 +95,9 @@ , jsInline ]) css = rendercss (p ^. #cssBody)- js = renderjs (p ^. #jsGlobal <> Js.onLoad (p ^. #jsOnLoad))- (renderjs, rendercss) = renderers $ pc ^. #pageRender+ 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@@ -106,24 +109,27 @@ Inline -> p ^. #libsCss Separated -> p ^. #libsCss <>- [libCss (Text.pack $ pc ^. #filenames . #css)]+ [libCss (Text.pack $ pc ^. #filenames . #cssConcern)] libsJs' = case pc ^. #concerns of Inline -> p ^. #libsJs Separated -> p ^. #libsJs <>- [libJs (Text.pack $ pc ^. #filenames . #js)]+ [libJs (Text.pack $ pc ^. #filenames . #jsConcern)] +-- | Render Page concerns to files. renderPageToFile :: FilePath -> PageConfig -> Page -> IO () renderPageToFile dir pc page =- void $ sequenceA $ liftA2 writeFile' (pc ^. #filenames) (renderPageAsText 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@@ -132,94 +138,4 @@ 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
@@ -1,249 +0,0 @@-{-# 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
@@ -1,184 +0,0 @@-{-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wall #-}-{-# OPTIONS_GHC -Wredundant-constraints #-}--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) => 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) => 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) =>- 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) =>- 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
@@ -10,12 +10,15 @@ import Control.Lens hiding (only) import Lucid (renderText) import Network.Wai.Middleware.Static (addBase, noDots, staticPolicy, only)-import Protolude hiding (get)+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]@@ -27,11 +30,11 @@ do middleware $ staticPolicy $ only [(cssfp,cssfp), (jsfp, jsfp)] get rp (do- State.lift $ writeFile' cssfp css- State.lift $ writeFile' jsfp js+ State.lift $ writeFile' cssfp (unpack css)+ State.lift $ writeFile' jsfp (unpack js) html $ renderText h)- cssfp = pc ^. #filenames . #css- jsfp = pc ^. #filenames . #js+ 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,354 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wredundant-constraints #-}++module Web.Page.SharedReps+ ( repInput,+ repMessage,+ sliderI,+ slider,+ dropdown,+ datalist,+ dropdownSum,+ colorPicker,+ textbox,+ textarea,+ checkbox,+ toggle,+ button,+ chooseFile,+ maybeRep,+ fiddle,+ viaFiddle,+ accordionList,+ listMaybeRep,+ listRep,+ defaultListLabels,+ )+where++import Box.Cont ()+import Codec.Picture.Types (PixelRGB8 (..))+import Control.Lens+import Data.Attoparsec.Text hiding (take)+import qualified Data.HashMap.Strict as HashMap+import Data.Text (Text, pack)+import Lucid+import Prelude hiding (lookup)+import Web.Page.Bootstrap+import Web.Page.Html+import Web.Page.Html.Input+import Web.Page.Types+import Data.Biapplicative+import Control.Monad.Trans.State+import Control.Monad+import Data.Bool++-- | create a sharedRep from an Input+repInput :: (Monad m, ToHtml 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 (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+ )+ )++-- | 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+ )+ )++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++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 :: (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) =>+ 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+ (pack . show)+ (Input v label mempty (Datalist opts id''))+ v++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++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+ (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 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++-- | a (fixed-size) list represented in html as an accordion card+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)))++defaultListLabels :: Int -> [Text]+defaultListLabels n = (\x -> "[" <> pack (show x) <> "]") <$> [0 .. n] :: [Text]++-- | 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/Types.hs view
@@ -3,115 +3,408 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TupleSections #-} module Web.Page.Types- ( Page(Page)- , PageText(PageText)- , PageConfig(PageConfig)- , defaultPageConfig- , Concern(..)- , Concerns(Concerns)- , suffixes- , concernNames- , PageConcerns(..)- , PageStructure(..)- , PageRender(..)- ) where+ ( 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.Lens-import Data.Generics.Labels()+import Control.Monad.Morph+import Data.Aeson+import Data.Biapplicative+import Data.Bifunctor (Bifunctor (..))+import Data.Generics.Labels ()+import Data.HashMap.Strict as HashMap hiding (foldr) import Data.Semigroup ((<>))+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 Protolude hiding ((<>))-import qualified Web.Page.Css as Css-import qualified Web.Page.Js as Js+import Text.InterpolatedString.Perl6+import Prelude+import Control.Monad.State+import Control.Monad.IO.Class+import Control.Applicative -data Page =- Page- { libsCss :: [Html ()]- , libsJs :: [Html ()]- , cssBody :: Css.PageCss- , jsGlobal :: Js.PageJs- , jsOnLoad :: Js.PageJs- , htmlHeader :: Html ()- , htmlBody :: Html ()- } deriving (Show, Generic)+-- | Components of a web page.+--+-- A web page typically can take many forms but still be the same web page. For example, css can be linked to in a separate file, or can be inline within html, but still be the same css. This type represents the practical components of what makes up a web page.+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)+ (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)+ mempty = Page [] [] mempty mempty mempty mempty mempty -data Concern = Css | Js | Html deriving (Show, Eq, Generic)+ mappend = (<>) -data Concerns a =- Concerns- { css :: a- , js :: a- , html :: a- } deriving (Eq, Show, Foldable, Traversable, Generic)+-- | A web page typically is composed of css, javascript and html+--+-- 'Concerns' abstracts this compositional 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+ (\x -> dir <> stem <> x) <$> suffixes -data PageConcerns =- Inline |- Separated+-- | Is the rendering to include all Concerns or be separated?+data PageConcerns+ = Inline+ | Separated deriving (Show, Eq, Generic) -data PageStructure =- HeaderBody |- Headless |- Snippet |- Svg+-- | Various ways that a Html file can be structured.+data PageStructure+ = HeaderBody+ | Headless+ | Snippet+ | Svg deriving (Show, Eq, Generic) -data PageRender =- Pretty |- Minified+-- | Post-processing of page concerns+data PageRender+ = Pretty+ | Minified+ | NoPost deriving (Show, Eq, Generic) -data PageConfig =+-- | Configuration of the rendering of a web page+data PageConfig+ = PageConfig+ { concerns :: PageConcerns,+ structure :: PageStructure,+ pageRender :: PageRender,+ filenames :: Concerns FilePath,+ localdirs :: [FilePath]+ }+ deriving (Show, Eq, Generic)++defaultPageConfig :: FilePath -> PageConfig+defaultPageConfig stem = PageConfig- { concerns :: PageConcerns- , structure :: PageStructure- , pageRender :: PageRender- , filenames :: Concerns FilePath- , localdirs :: [FilePath]- } deriving (Show, Eq, Generic)+ Inline+ HeaderBody+ Minified+ ((stem <>) <$> suffixes)+ [] -defaultPageConfig :: PageConfig-defaultPageConfig = PageConfig Inline HeaderBody Minified- (("default"<>) <$> suffixes) []+-- | unifies css as a Clay.Css and css 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++-- javascript types++-- | 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 = (<>)++-- | unify JSStatement javascript and text-rendered script+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+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++-- | Abstracted message event element+data Element+ = Element+ { element :: Text,+ value :: Text+ }+ deriving (Eq, Show, Generic)++instance ToJSON Element++instance FromJSON Element where+ parseJSON = withObject "Element" $ \v ->+ Element+ <$> v .: "element"+ <*> v .: "value"++data RepF r a+ = Rep+ { rep :: r,+ make :: HashMap Text Text -> (HashMap Text Text, Either Text a)+ }+ deriving (Functor)++type Rep a = RepF (Html ()) a++instance (Semigroup r) => Semigroup (RepF r a) where+ (Rep r0 a0) <> (Rep r1 a1) =+ Rep+ (r0 <> r1)+ (\hm -> let (hm', x') = a0 hm in let (hm'', x'') = a1 hm' in (hm'', x' <> x''))++instance (Monoid a, Monoid r) => Monoid (RepF r a) where++ mempty = Rep mempty (,Right mempty)++ mappend = (<>)++instance Bifunctor RepF where+ bimap f g (Rep r a) = Rep (f r) (second (fmap g) . a)++instance Biapplicative RepF where++ bipure r a = Rep r (,Right a)++ (Rep fr fa) <<*>> (Rep r a) =+ Rep+ (fr r)+ ( \hm ->+ let (hm', a') = a hm in let (hm'', fa') = fa hm' in (hm'', fa' <*> a')+ )++instance (Monoid r) => Applicative (RepF r) where++ pure = bipure mempty++ Rep fh fm <*> Rep ah am =+ Rep+ (fh <> ah)+ ( \hm ->+ let (hm', a') = am hm in let (hm'', fa') = fm hm' in (hm'', fa' <*> a')+ )++oneRep :: (Monad m, MonadIO m) => Rep a -> (Rep a -> HashMap Text Text -> m ()) -> StateT (HashMap Text Text) m (HashMap Text Text, Either Text a)+oneRep r@(Rep _ fa) action = do+ m <- get+ let (m', a) = fa m+ put m'+ lift $ action r m'+ pure (m', a)++newtype SharedRepF m r a+ = SharedRep+ { unrep :: StateT (Int, HashMap Text Text) m (RepF r a)+ }+ deriving (Functor)++type SharedRep m a = SharedRepF m (Html ()) a++instance (Functor m) => Bifunctor (SharedRepF m) where+ bimap f g (SharedRep s) = SharedRep $ fmap (bimap f g) s++instance (Monad m) => Biapplicative (SharedRepF m) where++ bipure r a = SharedRep $ pure $ bipure r a++ (SharedRep f) <<*>> (SharedRep a) = SharedRep $ liftA2 (<<*>>) f a++instance (Monad m, Monoid r) => Applicative (SharedRepF m r) where++ pure = bipure mempty++ SharedRep f <*> SharedRep a = SharedRep $ liftA2 (<*>) f a++-- | compute the initial state of a SharedRep (testing)+zeroState ::+ (Monad m) =>+ SharedRep m a ->+ m (Html (), (HashMap Text Text, Either Text a))+zeroState sr = do+ (Rep h fa, (_, m)) <- flip runStateT (0, HashMap.empty) $ unrep sr+ pure (h, fa m)++-- | compute the initial state of a SharedRep and then run a single action (testing)+runOnce ::+ (Monad m) =>+ SharedRep m a ->+ (Html () -> HashMap Text Text -> m ()) ->+ m (HashMap Text Text, Either Text a)+runOnce sr action = do+ (Rep h fa, (_, m)) <- flip runStateT (0, HashMap.empty) $ unrep sr+ action h m+ pure (fa m)+-- renderHtml :: Html a -> Text+-- renderHtml = toText
test/test.hs view
@@ -5,7 +5,7 @@ import Control.Lens import Lucid-import Protolude+import Prelude import Test.Tasty import Test.Tasty.Hspec import Web.Page@@ -19,11 +19,11 @@ generatePages :: Traversable t => FilePath -> t (FilePath, PageConfig, Page) -> IO () generatePages dir xs =- void $ sequenceA $ (\(fp, pc, p) -> generatePage dir fp pc p) <$> xs+ sequenceA_ $ (\(fp, pc, p) -> generatePage dir fp pc p) <$> xs genTest :: FilePath -> IO () genTest dir =- void $ generatePages dir [("default", defaultPageConfig, 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@@ -42,7 +42,7 @@ let t = renderPageAsText pc' p case pc ^. #concerns of Inline -> do- t' <- Text.readFile (dir <> names ^. #html)+ t' <- Text.readFile (dir <> names ^. #htmlConcern) return (t, Concerns mempty mempty t') Separated -> do t' <- sequenceA $ Text.readFile <$> (dir <>) <$> names@@ -58,7 +58,7 @@ "<!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+ testVsFile dir "default" (defaultPageConfig "default") page1 `shouldReturn` True it "the various PageConfig's" $ testVsFile dir "sep" cfg2 page2 `shouldReturn` True @@ -74,7 +74,7 @@ runIdentity . flip evalStateT 0 . accordion "acctest" Nothing $- (\x -> (Protolude.show x, "filler")) <$> [1..2::Int]) `shouldBe`+ (\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 ())@@ -83,7 +83,7 @@ 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>"+ "<!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 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 =@@ -130,8 +130,8 @@ 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`+ 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`
web-rep.cabal view
@@ -1,9 +1,9 @@ cabal-version: 1.12 name: web-rep-version: 0.1.3-synopsis: representations of a web pag+version: 0.2.0+synopsis: representations of a web page category: web-description: See readme.md for verbage (if any)+description: An applicative-based, shared-data representation of a web page. bug-reports: https://github.com/tonyday567/web-page/issues maintainer: Tony Day <tonyday567@gmail.com> license: MIT@@ -11,20 +11,18 @@ build-type: Simple extra-source-files: stack.yaml+ readme.md 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.SharedReps Web.Page.Server Web.Page.Types hs-source-dirs:@@ -47,7 +45,6 @@ , lucid-svg , mmorph , mtl- , protolude , scotty , streaming , text@@ -69,7 +66,6 @@ , lens , lucid , optparse-generic- , protolude , scotty , text , wai@@ -88,7 +84,6 @@ base >= 4.12 && <5 , lens , lucid- , protolude , tasty , tasty-hspec , text