diff --git a/app/example.hs b/app/example.hs
deleted file mode 100644
--- a/app/example.hs
+++ /dev/null
@@ -1,246 +0,0 @@
-{-# LANGUAGE ApplicativeDo #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedLabels #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeOperators #-}
-{-# OPTIONS_GHC -Wall #-}
-
-import Prelude hiding (log, init)
-import Control.Lens hiding (Wrapped, Unwrapped)
-import Data.Attoparsec.Text (parseOnly, decimal)
-import Lucid
-import Network.Wai (rawPathInfo)
-import Network.Wai.Middleware.RequestLogger (logStdoutDev)
-import Network.Wai.Middleware.Static (addBase, noDots, staticPolicy, (>->))
-import Options.Generic
-import Web.Page
-import Web.Page.Examples
-import Web.Scotty (scotty, middleware)
-import qualified Box
-import qualified Data.Text as Text
-import Control.Monad
-import Data.Maybe
-
-testPage :: Text -> Text -> [(Text, Html ())] -> Page
-testPage title mid sections =
- bootstrapPage <>
- bridgePage &
- #htmlHeader .~ title_ "iroTestPage" &
- #htmlBody .~ divClass_ "container" (mconcat
- [ divClass_ "row" (h1_ (toHtml title))
- , divClass_ "row" (h2_ ("middleware: " <> toHtml mid))
- , divClass_ "row" $ mconcat $ (\(t,h) -> divClass_ "col" (h2_ (toHtml t) <> with div_ [id_ t] h)) <$> sections
- ])
-
--- | bridge testing without the SharedRep method
-rangeTest :: Input Int
-rangeTest =
- Input
- 3
- (Just "range example")
- "rangeid"
- (Slider
- [ style_ "max-width:15rem;"
- , min_ "0"
- , max_ "5"
- , step_ "1"
- ])
-
-textTest :: Input Text
-textTest =
- Input
- "abc"
- (Just "label")
- "textid"
- TextBox
-
-initBridgeTest :: (Int, Text)
-initBridgeTest = (rangeTest ^. #inputVal, textTest ^. #inputVal)
-
-stepBridgeTest :: Element -> (Int, Text) -> (Int,Text)
-stepBridgeTest e s =
- case step e s of
- Left _ -> s
- Right x -> x
- where
- step (Element "rangeid" v) (_, t) = either
- (Left . Text.pack)
- (\x -> Right (x,t))
- (parseOnly decimal v)
- step (Element "textid" v) (n, _) = Right (n,v)
- step e' _ = Left $ "unknown id: " <> pack (show e')
-
-sendBridgeTest :: (Show a) => Engine -> Either Text a -> IO ()
-sendBridgeTest e (Left err) = append e "log" err
-sendBridgeTest e (Right a) =
- replace e "output"
- (toText $ cardify (mempty, []) (Just "output was:")
- (toHtml (show a), []))
-
-consumeBridgeTest :: Engine -> IO (Int, Text)
-consumeBridgeTest e =
- valueConsume initBridgeTest stepBridgeTest
- ( (Box.liftC <$> Box.showStdout) <>
- pure (Box.Committer (\v -> sendBridgeTest e v >> pure True))
- ) (bridge e)
-
-midBridgeTest :: (Show a) => Html () -> (Engine -> IO a) -> Application -> Application
-midBridgeTest init eeio = start $ \ e -> do
- append e "input" (toText init)
- final <- eeio e `finally` putStrLn "midBridgeTest finalled"
- putStrLn $ "final value was: " <> show final
-
--- * SharedRep testing
-
--- | Middleware that shows the current shared values
-midShow :: (Show a) => SharedRep IO a -> Application -> Application
-midShow sr = midShared sr initShowRep (logResults (pack . show))
-
-initShowRep
- :: (Show a)
- => Engine
- -> Rep a
- -> StateT (HashMap Text Text) IO ()
-initShowRep e r =
- void $ oneRep r
- (\(Rep h fa) m -> do
- append e "input" (toText h)
- replace e "output" (pack . show $ fa m))
-
-results :: (a -> Text) -> Engine -> a -> IO ()
-results r e x = replace e "output" (r x)
-
-logResults :: (a -> Text) -> Engine -> Either Text a -> IO ()
-logResults _ e (Left err) = append e "log" (err <> "
")
-logResults r e (Right x) = results r e x
-
--- | evaluate a Fiddle, without attempting to downstream bridging
-midFiddle :: Concerns Text -> Application -> Application
-midFiddle cs = midShared (fiddle cs) initFiddleRep (\e -> logFiddle e . second snd)
-
-initFiddleRep
- :: Engine
- -> Rep a
- -> StateT (HashMap Text Text) IO ()
-initFiddleRep e r =
- void $ oneRep r
- (\(Rep h _) _ ->
- append e "input" (toText h))
-
-logFiddle :: Engine -> Either Text (Either Text (Concerns Text, Bool)) -> IO ()
-logFiddle e (Left err) = append e "log" ("map error: " <> err)
-logFiddle e (Right (Left err)) = append e "log" ("parse error: " <> err)
-logFiddle e (Right (Right (c,u))) = bool (pure ()) (sendConcerns e "output" c) u
-
--- | evaluate a Fiddle, and any downstream bridging representation
-midViaFiddle
- :: Show a
- => SharedRep IO a
- -> Application -> Application
-midViaFiddle sr =
- midShared (viaFiddle sr) (initViaFiddleRep (pack . show)) (\e -> logViaFiddle e (pack . show) . second snd)
-
-initViaFiddleRep
- :: (a -> Text)
- -> Engine
- -> Rep (Bool, Concerns Text, a)
- -> StateT (HashMap Text Text) IO ()
-initViaFiddleRep rend e r =
- void $ oneRep r
- (\(Rep h fa) m -> do
- append e "input" (toText h)
- case (snd $ fa m) of
- Left err -> append e "log" ("map error: " <> err)
- Right (_,c,a) -> do
- sendConcerns e "representation" c
- replace e "output" (rend a))
-
-logViaFiddle :: Engine -> (a -> Text) -> Either Text (Either Text (Bool, Concerns Text, a)) -> IO ()
-logViaFiddle e _ (Left err) = append e "log" ("map error: " <> err)
-logViaFiddle e _ (Right (Left err)) = append e "log" ("parse error: " <> err)
-logViaFiddle e r (Right (Right (True,c,a))) = do
- sendConcerns e "representation" c
- replace e "output" (r a)
-logViaFiddle e r (Right (Right (False,_,a))) = replace e "output" (r a)
-
-data MidType = Dev | Prod | ChooseFileExample | DataListExample | SumTypeExample | SumType2Example | Bridge | ListExample | ListRepExample | Fiddle | ViaFiddle | NoMid deriving (Eq, Read, Show, Generic)
-
-instance ParseField MidType
-instance ParseRecord MidType
-instance ParseFields MidType
-
-data Opts w = Opts
- { midtype :: w ::: MidType "type of middleware processing"
- , log :: w ::: Maybe Bool "server log to stdout"
- , logPath :: w ::: Maybe Bool "log raw path"
- } deriving (Generic)
-
-instance ParseRecord (Opts Wrapped)
-
-main :: IO ()
-main = do
- o :: Opts Unwrapped <- unwrapRecord "examples for web-page"
- let tr = fromMaybe False
- scotty 3000 $ do
- middleware $ staticPolicy (noDots >-> addBase "other")
- middleware $ staticPolicy (noDots >-> addBase "saves")
- when (tr $ log o) $
- middleware logStdoutDev
- when (tr $ logPath o) $
- middleware $ \app req res ->
- putStrLn "raw path:" >>
- print (rawPathInfo req) >> app req res
- -- Only one middleware servicing the web socket can be run at a time. Simply switching on based on paths doesn't work because socket comms comes through "/"
- -- so that the first bridge middleware consumes all the elements
- middleware $ case midtype o of
- NoMid -> id
- -- WebSocket connection to 'ws://localhost:3000/' failed: Error during WebSocket handshake: Unexpected response code: 200
- Prod -> midShow
- (maybeRep (Just "maybe") True repExamples)
- Dev -> midShow
- (repSumTypeExample 2 "default text" SumOnly)
- ChooseFileExample -> midShow
- (chooseFile (Just "ChooseFile Label") "")
- DataListExample -> midShow
- (datalist (Just "label") ["first", "2", "3"] "2" "idlist")
- SumTypeExample -> midShow
- (repSumTypeExample 2 "default text" SumOnly)
- SumType2Example -> midShow
- (repSumType2Example 2 "default text" SumOnly (SumOutside 2))
- ListExample -> midShow (listExample 5)
- ListRepExample -> midShow (listRepExample 10)
- Bridge -> midBridgeTest (toHtml rangeTest <> toHtml textTest)
- consumeBridgeTest
- Fiddle -> midFiddle fiddleExample
- ViaFiddle -> midViaFiddle
- (slider Nothing 0 10 0.01 4)
- servePageWith "/simple" (defaultPageConfig "page1") page1
- servePageWith "/mathjax" (defaultPageConfig "mathjax") pagemj
- servePageWith "/mathjaxsvg" (defaultPageConfig "mathjax") pagemjsvg
- servePageWith "/iro" (defaultPageConfig "iro")
- (testPage "iro" (pack . show $ midtype o)
- [ ("input", mempty)
- , ("representation", mempty)
- , ("output", mempty)
- ])
- servePageWith "/" (defaultPageConfig "prod")
- (testPage "prod" (pack . show $ midtype o)
- [ ("input", mempty)
- , ("output",
- (bool mempty
- (toHtml (show initBridgeTest))
- (midtype o == Bridge)))
- ])
- servePageWith "/log" (defaultPageConfig "prod")
- (testPage "prod" (pack . show $ midtype o)
- [ ("input", mempty)
- , ("output",
- (bool mempty
- (toHtml (show initBridgeTest))
- (midtype o == Bridge)))
- , ("log", mempty)
- ])
diff --git a/app/rep-example.hs b/app/rep-example.hs
new file mode 100644
--- /dev/null
+++ b/app/rep-example.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -Wall #-}
+
+import NumHask.Prelude
+import Options.Generic
+import Web.Rep
+import Web.Rep.Examples
+
+data AppType = SharedTest deriving (Eq, Read, Show, Generic)
+
+instance ParseField AppType
+
+instance ParseRecord AppType
+
+instance ParseFields AppType
+
+data Opts w
+ = Opts
+ { apptype :: w ::: AppType "type of example"
+ }
+ deriving (Generic)
+
+instance ParseRecord (Opts Wrapped)
+
+main :: IO ()
+main = do
+ o :: Opts Unwrapped <- unwrapRecord "examples for web-page"
+ case apptype o of
+ SharedTest -> defaultSharedServer (maybeRep (Just "maybe") False repExamples)
diff --git a/readme.md b/readme.md
--- a/readme.md
+++ b/readme.md
@@ -6,23 +6,20 @@
The best way to understand functionality is via running the example app:
```
-stack build --test --exec "$(stack path --local-install-root)/bin/page-example --midtype Prod" --file-watch
+stack build --test --exec "$(stack path --local-install-root)/bin/page-example --apptype SharedTest" --file-watch
```
-http://localhost:3000/
+http://localhost:9160/
reference
---
-- beam me up [scotty](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/flags.html#flag-reference)
-- [scotty-starter](https://github.com/scotty-web/scotty-starter)
+- [scotty](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/flags.html#flag-reference)
- get [bootstrap](https://getbootstrap.com/)
- [bootstrap-slider](https://seiyria.com/bootstrap-slider)
- [blaze](http://hackage.haskell.org/package/blaze-html)
- [lucid](http://hackage.haskell.org/package/lucid)
- [clay](https://www.stackage.org/clay)
-- [javascript-bridge](https://github.com/ku-fpg/javascript-bridge)
-
todo
---
diff --git a/src/Web/Page.hs b/src/Web/Page.hs
deleted file mode 100644
--- a/src/Web/Page.hs
+++ /dev/null
@@ -1,94 +0,0 @@
--- | A haskell library for representing web pages.
---
--- This library is a collection of web page abstractions, together with a reimagining of .
---
--- I wanted to expose the server delivery mechanism, switch the streaming nature of the gap between a web page and a haskell server, and concentrate on getting a clean interface between pure haskell and the world that is a web page.
---
--- See app/examples.hs and 'Web.Examples' for usage.
-module Web.Page
- ( -- * Shared Representation
- RepF (..),
- Rep,
- oneRep,
- SharedRepF (..),
- SharedRep,
- Element (..),
- runOnce,
- zeroState,
-
- -- * Web Page Components
- Page (..),
- PageConfig (..),
- defaultPageConfig,
- Concerns (..),
- suffixes,
- concernNames,
- PageConcerns (..),
- PageStructure (..),
- PageRender (..),
-
- -- * Css
- Css,
- PageCss (..),
- renderCss,
- renderPageCss,
-
- -- * JS
- JS (..),
- PageJs (..),
- onLoad,
- renderPageJs,
- parseJs,
- renderJs,
-
- -- * re-export modules
- module Web.Page.SharedReps,
- module Web.Page.Render,
- module Web.Page.Server,
- module Web.Page.Bridge,
- module Web.Page.Html,
- module Web.Page.Html.Input,
- module Web.Page.Bootstrap,
- module Web.Page.Mathjax,
- module Data.Biapplicative,
- module Data.Bifunctor,
-
- -- * re-exports
- module X,
- Value (..),
- finally,
- HashMap.HashMap,
- fromList,
- void,
- sequenceA_,
- Text,
- pack,
- unpack,
- toStrict,
- bool,
- )
-where
-
-import Control.Applicative as X
-import Control.Exception (finally)
-import Control.Monad
-import Control.Monad.Trans.State as X
-import Data.Aeson (Value (..))
-import Data.Biapplicative
-import Data.Bifunctor
-import Data.Bool
-import Data.Foldable (sequenceA_)
-import qualified Data.HashMap.Strict as HashMap
-import Data.Text (Text, pack, unpack)
-import Data.Text.Lazy (toStrict)
-import GHC.Exts (fromList)
-import Text.InterpolatedString.Perl6 as X
-import Web.Page.Bootstrap
-import Web.Page.Bridge
-import Web.Page.Html
-import Web.Page.Html.Input
-import Web.Page.Mathjax
-import Web.Page.Render
-import Web.Page.Server
-import Web.Page.SharedReps
-import Web.Page.Types
diff --git a/src/Web/Page/Bootstrap.hs b/src/Web/Page/Bootstrap.hs
deleted file mode 100644
--- a/src/Web/Page/Bootstrap.hs
+++ /dev/null
@@ -1,168 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedLabels #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -Wall #-}
-
--- | Some assets and functionality.
-module Web.Page.Bootstrap
- ( bootstrapPage,
- cardify,
- divClass_,
- accordion,
- accordionChecked,
- accordionCard,
- accordionCardChecked,
- accordion_,
- )
-where
-
-import Control.Monad.State
-import Data.Bool
-import Data.Functor.Identity
-import Data.Text (Text)
-import Lucid
-import Lucid.Base
-import Web.Page.Html
-import Web.Page.Types
-import Prelude
-
-bootstrapCss :: [Html ()]
-bootstrapCss =
- [ link_
- [ rel_ "stylesheet",
- href_ "https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/css/bootstrap.min.css",
- integrity_ "sha384-ggOyR0iXCbMQv3Xipma34MD+dH/1fQ784/j6cY/iJTQUOhcWr7x9JvoRxT2MZw1T",
- crossorigin_ "anonymous"
- ]
- ]
-
-bootstrapJs :: [Html ()]
-bootstrapJs =
- [ with
- (script_ mempty)
- [ src_ "https://code.jquery.com/jquery-3.3.1.slim.min.js",
- integrity_ "sha384-q8i/X+965DzO0rT7abK41JStQIAqVgRVzpbzo5smXKp4YfRvH+8abtTE1Pi6jizo",
- crossorigin_ "anonymous"
- ],
- with
- (script_ mempty)
- [ src_ "https://cdnjs.cloudflare.com/ajax/libs/popper.js/1.14.7/umd/popper.min.js",
- integrity_ "sha384-UO2eT0CpHqdSJQ6hJty5KVphtPhzWj9WO1clHTMGa3JDZwrnQq4sF86dIHNDz0W1",
- crossorigin_ "anonymous"
- ],
- with
- (script_ mempty)
- [ src_ "https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/js/bootstrap.min.js",
- integrity_ "sha384-JjSmVgyd0p3pXB1rRibZUAYoIIy6OrQ6VrjIEaFf/nJGzIxFDsf4x0xIM+B07jRM",
- crossorigin_ "anonymous"
- ]
- ]
-
-bootstrapMeta :: [Html ()]
-bootstrapMeta =
- [ meta_ [charset_ "utf-8"],
- meta_
- [ name_ "viewport",
- content_ "width=device-width, initial-scale=1, shrink-to-fit=no"
- ]
- ]
-
--- | A page containing all the needs for a web page.
-bootstrapPage :: Page
-bootstrapPage =
- Page
- bootstrapCss
- bootstrapJs
- mempty
- mempty
- mempty
- (mconcat bootstrapMeta)
- mempty
-
--- | wrap some Html with the bootstrap class
-cardify :: (Html (), [Attribute]) -> Maybe Text -> (Html (), [Attribute]) -> Html ()
-cardify (h, hatts) t (b, batts) =
- with div_ ([class__ "card"] <> hatts) $
- h
- <> with
- div_
- ([class__ "card-body"] <> batts)
- ( maybe mempty (with h5_ [class__ "card-title"] . toHtml) t
- <> b
- )
-
--- | wrap some html with a classed div
-divClass_ :: Text -> Html () -> Html ()
-divClass_ t = with div_ [class__ t]
-
--- | A Html object based on the bootstrap accordion card concept.
-accordionCard :: Bool -> [Attribute] -> Text -> Text -> Text -> Text -> Html () -> Html ()
-accordionCard collapse atts idp idh idb t0 b =
- with div_ ([class__ "card"] <> atts) $
- with
- div_
- [class__ "card-header", id_ idh]
- ( with
- h2_
- [class__ "mb-0"]
- (with button_ [class__ ("btn btn-link" <> bool "" " collapsed" collapse), type_ "button", data_ "toggle" "collapse", data_ "target" ("#" <> idb), makeAttribute "aria-expanded" (bool "true" "false" collapse), makeAttribute "aria-controls" idb] (toHtml t0))
- )
- <> with
- div_
- [id_ idb, class__ ("collapse" <> bool " show" "" collapse), makeAttribute "aria-labelledby" idh, data_ "parent" ("#" <> idp)]
- (with div_ [class__ "card-body"] b)
-
--- | A bootstrap accordion card attached to a checkbox.
-accordionCardChecked :: Bool -> Text -> Text -> Text -> Text -> Html () -> Html () -> Html ()
-accordionCardChecked collapse idp idh idb label bodyhtml checkhtml =
- with div_ ([class__ "card"]) $
- with
- div_
- ([class__ "card-header", id_ idh])
- ( checkhtml
- <> with
- h2_
- [class__ "mb-0"]
- (with button_ [class__ ("btn btn-link" <> bool "" " collapsed" collapse), type_ "button", data_ "toggle" "collapse", data_ "target" ("#" <> idb), makeAttribute "aria-expanded" (bool "true" "false" collapse), makeAttribute "aria-controls" idb] (toHtml label))
- )
- <> with
- div_
- [id_ idb, class__ ("collapse" <> bool " show" "" collapse), makeAttribute "aria-labelledby" idh, data_ "parent" ("#" <> idp)]
- (with div_ ([class__ "card-body"]) bodyhtml)
-
--- | create a bootstrapped accordian class
-accordion ::
- (MonadState Int m) =>
- Text ->
- -- | name prefix. This is needed because an Int doesn't seem to be a valid name.
- Maybe Text ->
- -- | card title
- [(Text, Html ())] ->
- -- | title, html tuple for each item in the accordion.
- m (Html ())
-accordion pre x hs = do
- idp' <- genNamePre pre
- with div_ [class__ "accordion", id_ idp'] <$> aCards idp'
- where
- aCards par = mconcat <$> sequence (aCard par <$> hs)
- aCard par (t, b) = do
- idh <- genNamePre pre
- idb <- genNamePre pre
- pure $ accordionCard (x /= Just t) [] par idh idb t b
-
--- | create a bootstrapped accordian class
-accordionChecked :: (MonadState Int m) => Text -> [(Text, Html (), Html ())] -> m (Html ())
-accordionChecked pre hs = do
- idp' <- genNamePre pre
- with div_ [class__ "accordion", id_ idp'] <$> aCards idp'
- where
- aCards par = mconcat <$> sequence (aCard par <$> hs)
- aCard par (l, bodyhtml, checkhtml) = do
- idh <- genNamePre pre
- idb <- genNamePre pre
- pure $ accordionCardChecked True par idh idb l bodyhtml checkhtml
-
--- | This version of accordion runs a local state for naming, and will cause name clashes if the prefix is not unique.
-accordion_ :: Text -> Maybe Text -> [(Text, Html ())] -> Html ()
-accordion_ pre x hs = runIdentity $ evalStateT (accordion pre x hs) 0
diff --git a/src/Web/Page/Bridge.hs b/src/Web/Page/Bridge.hs
deleted file mode 100644
--- a/src/Web/Page/Bridge.hs
+++ /dev/null
@@ -1,299 +0,0 @@
-{-# LANGUAGE OverloadedLabels #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# OPTIONS_GHC -Wall #-}
-{-# OPTIONS_GHC -Wredundant-constraints #-}
-
--- | A streaming bridge between a web page and haskell.
-module Web.Page.Bridge
- ( bridgePage,
- append,
- replace,
- bridge,
- sendConcerns,
- Engine,
- start,
- Application,
- valueConsume,
- sharedConsume,
- runList,
- runOnEvent,
- midShared,
- refreshJsbJs,
- runScriptJs,
- )
-where
-
-import Box
-import Box.Cont ()
-import qualified Control.Foldl as L
-import Control.Lens
-import Control.Monad.Morph
-import Control.Monad.State
-import Data.Aeson
-import Data.HashMap.Strict as HashMap
-import qualified Data.Text as Text
-import Data.Text (Text, pack)
-import Data.Text.Lazy (fromStrict)
-import GHC.Conc
-import Lucid
-import Network.JavaScript (Application, Engine, JavaScript (..), addListener, command, send, start)
-import qualified Streaming.Prelude as S
-import Text.InterpolatedString.Perl6
-import Web.Page.Html
-import Web.Page.Types
-import Prelude hiding (init)
-
--- | prevent the Enter key from triggering an event
-preventEnter :: PageJs
-preventEnter =
- PageJs $
- parseJs
- [q|
-window.addEventListener('keydown',function(e) {
- if(e.keyIdentifier=='U+000A' || e.keyIdentifier=='Enter' || e.keyCode==13) {
- if(e.target.nodeName=='INPUT' && e.target.type !== 'textarea') {
- e.preventDefault();
- return false;
- }
- }
-}, true);
-|]
-
--- | create a web socket for event data
-webSocket :: PageJs
-webSocket =
- PageJsText
- [q|
-window.jsb = {ws: new WebSocket('ws://' + location.host + '/')};
-jsb.ws.onmessage = (evt) => eval(evt.data);
-|]
-
--- | script injection js.
---
--- See https://ghinda.net/article/script-tags/ for why this might be needed.
-runScriptJs :: PageJs
-runScriptJs =
- PageJsText
- [q|
-function insertScript ($script) {
- var s = document.createElement('script')
- s.type = 'text/javascript'
- if ($script.src) {
- s.onload = callback
- s.onerror = callback
- s.src = $script.src
- } else {
- s.textContent = $script.innerText
- }
-
- // re-insert the script tag so it executes.
- document.head.appendChild(s)
-
- // clean-up
- $script.parentNode.removeChild($script)
-}
-
-function runScripts ($container) {
- // get scripts tags from a node
- var $scripts = $container.querySelectorAll('script')
- $scripts.forEach(function ($script) {
- insertScript($script)
- })
-}
-|]
-
--- | componentry to kick off a javascript-bridge enabled page
-bridgePage :: Page
-bridgePage =
- mempty
- & #jsGlobal .~ (preventEnter <> refreshJsbJs)
- & #jsOnLoad .~ webSocket
-
-sendc :: Engine -> Text -> IO ()
-sendc e = send e . command . JavaScript . fromStrict
-
--- | replace a container and run any embedded scripts
-replace :: Engine -> Text -> Text -> IO ()
-replace e d t =
- send e $
- command
- [qc|
- var $container = document.getElementById('{d}');
- $container.innerHTML = '{clean t}';
- refreshJsb();
- |]
-
--- | append to a container and run any embedded scripts
-append :: Engine -> Text -> Text -> IO ()
-append e d t =
- send e $
- command
- [qc|
- var $container = document.getElementById('{d}');
- $container.innerHTML += '{clean t}';
- refreshJsb();
- |]
-
-clean :: Text -> Text
-clean =
- Text.intercalate "\\'" . Text.split (== '\'')
- . Text.intercalate "\\n"
- . Text.lines
-
--- | send css, js and html over the bridge
-sendConcerns :: Engine -> Text -> Concerns Text -> IO ()
-sendConcerns e t (Concerns c j h) = do
- replace e t h
- append e t (toText $ style_ c)
- sendc e j
-
--- | The javascript bridge continuation.
-bridge :: Engine -> Cont_ IO Value
-bridge e = Cont_ $ \vio -> void $ addListener e vio
-
-fromJson' :: (FromJSON a) => Value -> Either Text a
-fromJson' v = case fromJSON v of
- (Success a) -> Right a
- (Error e) -> Left $ "Json conversion error: " <> Text.pack e <> " of " <> (pack . show) v
-
-valueModel :: (FromJSON a, MonadState s m) => (a -> s -> s) -> S.Stream (S.Of Value) m () -> S.Stream (S.Of (Either Text s)) m ()
-valueModel step s =
- s
- & S.map fromJson'
- & S.partitionEithers
- & hoist (S.chain (modify . step))
- & hoist (S.mapM (const get))
- & S.unseparate
- & S.maps S.sumToEither
-
--- | consume an Element using a Committer and a Value continuation
-valueConsume :: s -> (Element -> s -> s) -> Cont IO (Committer IO (Either Text s)) -> Cont_ IO Value -> IO s
-valueConsume init step comm vio = do
- (c, e) <- atomically $ ends Unbounded
- with_ vio (atomically . c)
- etcM
- init
- (Transducer (valueModel step))
- (Box <$> comm <*> (liftE <$> pure (Emitter (Just <$> e))))
-
-stepM :: MonadState s m => (s -> (s, b)) -> (a -> s -> s) -> a -> m (s, b)
-stepM sr step v = do
- hm <- get
- let (hm', b) = sr $ step v hm
- put hm'
- pure (hm', b)
-
-sharedModel :: (FromJSON a, MonadState s m) => (s -> (s, Either Text b)) -> (a -> s -> s) -> S.Stream (S.Of Value) m () -> S.Stream (S.Of (Either Text (s, Either Text b))) m ()
-sharedModel sr step s =
- s
- & S.map fromJson'
- & S.partitionEithers
- & hoist (S.mapM (stepM sr step))
- & S.unseparate
- & S.maps S.sumToEither
-
--- | consume shared values using a step function, a continuation committer, and a Value continuation.
-sharedConsume :: (s -> (s, Either Text b)) -> s -> (Element -> s -> s) -> Cont IO (Committer IO (Either Text (s, Either Text b))) -> Cont_ IO Value -> IO s
-sharedConsume sh init step comm vio = do
- (c, e) <- atomically $ ends Unbounded
- with_ vio (atomically . c)
- etcM
- init
- (Transducer (sharedModel sh step))
- (Box <$> comm <*> (liftE <$> pure (Emitter (Just <$> e))))
-
--- | run a SharedRep using an initial state, a step function that consumes the shared model, and a value continuation
-runOnEvent ::
- SharedRep IO a ->
- (Rep a -> StateT (Int, HashMap Text Text) IO ()) ->
- (Either Text (HashMap Text Text, Either Text a) -> IO ()) ->
- Cont_ IO Value ->
- IO (HashMap Text Text)
-runOnEvent sr hio eaction cv = flip evalStateT (0, HashMap.empty) $ do
- (Rep h fa) <- unrep sr
- hio (Rep h fa)
- m <- zoom _2 get
- liftIO $
- sharedConsume
- fa
- m
- (\(Element k v) s -> insert k v s)
- (pure (Committer (\v -> eaction v >> pure True)))
- cv
-
--- | create Wai Middleware for a 'SharedRep' providing an initialiser and action on events
-midShared ::
- () =>
- SharedRep IO a ->
- (Engine -> Rep a -> StateT (HashMap Text Text) IO ()) ->
- (Engine -> Either Text (HashMap Text Text, Either Text a) -> IO ()) ->
- Application ->
- Application
-midShared sr init action = start $ \e ->
- void $
- runOnEvent
- sr
- (zoom _2 . init e)
- (action e)
- (bridge e)
-
--- | process a list of Values
-runList ::
- (Monad m) =>
- SharedRep m a ->
- [Value] ->
- m [Either Text (HashMap Text Text, Either Text a)]
-runList sr vs = S.fst' <$> do
- (faStep, (_, hm)) <- flip runStateT (0, HashMap.empty) $ do
- (Rep _ fa) <- unrep sr
- pure fa
- flip evalStateT hm $
- L.purely
- S.fold
- L.list
- (sharedModel faStep (\(Element k v) s -> insert k v s) (S.each vs))
-
--- | Event hooks that may need to be reattached given dynamic content creation.
-refreshJsbJs :: PageJs
-refreshJsbJs =
- PageJsText
- [q|
-function refreshJsb () {
- $('.jsbClassEventChange').off('change');
- $('.jsbClassEventChange').on('change', (function(){
- jsb.event({ 'element': this.id, 'value': this.value});
- }));
- $('.jsbClassEventInput').off('input');
- $('.jsbClassEventInput').on('input', (function(){
- jsb.event({ 'element': this.id, 'value': this.value});
- }));
- $('.jsbClassEventButton').off('click');
- $('.jsbClassEventButton').on('click', (function(){
- jsb.event({ 'element': this.id, 'value': this.value});
- }));
- $('.jsbClassEventToggle').off('click');
- $('.jsbClassEventToggle').on('click', (function(){
- jsb.event({ 'element': this.id, 'value': ('true' !== this.getAttribute('aria-pressed')).toString()});
- }));
- $('.jsbClassEventCheckbox').off('click');
- $('.jsbClassEventCheckbox').on('click', (function(){
- jsb.event({ 'element': this.id, 'value': this.checked.toString()});
- }));
- $('.jsbClassEventChooseFile').off('input');
- $('.jsbClassEventChooseFile').on('input', (function(){
- jsb.event({ 'element': this.id, 'value': this.files[0].name});
- }));
- $('.jsbClassEventShowSum').off('change');
- $('.jsbClassEventShowSum').on('change', (function(){
- var v = this.value;
- $(this).parent('.sumtype-group').siblings('.subtype').each(function(i) {
- if (this.dataset.sumtype === v) {
- this.style.display = 'block';
- } else {
- this.style.display = 'none';
- }
- })
- }));
-};
-|]
diff --git a/src/Web/Page/Examples.hs b/src/Web/Page/Examples.hs
deleted file mode 100644
--- a/src/Web/Page/Examples.hs
+++ /dev/null
@@ -1,299 +0,0 @@
-{-# LANGUAGE ApplicativeDo #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedLabels #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# OPTIONS_GHC -Wall #-}
-
-module Web.Page.Examples
- ( page1,
- page2,
- pagemj,
- pagemjsvg,
- cfg2,
- RepExamples (..),
- repExamples,
- Shape (..),
- fromShape,
- toShape,
- SumTypeExample (..),
- repSumTypeExample,
- SumType2Example (..),
- repSumType2Example,
- listExample,
- listRepExample,
- fiddleExample,
- )
-where
-
-import qualified Clay
-import Control.Lens hiding ((.=))
-import Data.Attoparsec.Text
-import GHC.Generics
-import Lucid
-import qualified Lucid.Svg as Svg
-import Web.Page
-import Prelude
-
--- | simple page example
-page1 :: Page
-page1 =
- #htmlBody .~ button1
- $ #cssBody .~ PageCss css1
- $ #jsGlobal .~ mempty
- $ #jsOnLoad .~ click
- $ #libsCss .~ (libCss <$> cssLibs)
- $ #libsJs .~ (libJs <$> jsLibs)
- $ mempty
-
--- | page with localised libraries
-page2 :: Page
-page2 =
- #libsCss .~ (libCss <$> cssLibsLocal)
- $ #libsJs .~ (libJs <$> jsLibsLocal)
- $ page1
-
--- | simple mathjax formulae
-pagemj :: Page
-pagemj = mathjaxPage & #htmlBody .~ htmlMathjaxExample
-
-htmlMathjaxExample :: HtmlT Identity ()
-htmlMathjaxExample =
- p_ "double dollar:"
- <> p_ "$$\\sum_{i=0}^n i^2 = \\frac{(n^2+n)(2n+1)}{6}$$"
- <> p_ "single dollar for inline: $\\sum_{i=0}^n i^2 = \\frac{(n^2+n)(2n+1)}{6}$"
- <> p_ "escaped brackets for inline mathjax: \\(\\sum_{i=0}^n i^2 = \\frac{(n^2+n)(2n+1)}{6}\\)"
-
--- | simple mathjax formulae inside an svg text element
-pagemjsvg :: Page
-pagemjsvg =
- (#htmlBody .~ (with Svg.svg11_ [Svg.height_ "400", Svg.width_ "400", Svg.viewBox_ "-20 -20 300 300"]) (with Svg.g_ [class_ "mathjaxsvg"] $ with Svg.text_ [size_ "10", Svg.y_ "100", Svg.x_ "0"] "prefix: $\\sum_{i=0}^n i^2 = \\frac{(n^2+n)(2n+1)}{6}$"))
- (mathjaxSvgPage "mathjaxsvg")
-
-cfg2 :: PageConfig
-cfg2 =
- #concerns .~ Separated
- $ #pageRender .~ Pretty
- $ #structure .~ Headless
- $ #localdirs .~ ["test/static"]
- $ #filenames .~ (("other/cfg2" <>) <$> suffixes)
- $ (defaultPageConfig "")
-
-cssLibs :: [Text]
-cssLibs =
- ["http://maxcdn.bootstrapcdn.com/font-awesome/4.3.0/css/font-awesome.min.css"]
-
-cssLibsLocal :: [Text]
-cssLibsLocal = ["css/font-awesome.min.css"]
-
-jsLibs :: [Text]
-jsLibs = ["http://code.jquery.com/jquery-1.6.3.min.js"]
-
-jsLibsLocal :: [Text]
-jsLibsLocal = ["jquery-2.1.3.min.js"]
-
-css1 :: Css
-css1 = do
- Clay.fontSize (Clay.px 10)
- Clay.fontFamily ["Arial", "Helvetica"] [Clay.sansSerif]
- "#btnGo" Clay.? do
- Clay.marginTop (Clay.px 20)
- Clay.marginBottom (Clay.px 20)
- "#btnGo.on" Clay.? Clay.color Clay.green
-
--- js
-click :: PageJs
-click =
- PageJsText
- [q|
-$('#btnGo').click( function() {
- $('#btnGo').toggleClass('on');
- alert('bada bing!');
-});
-|]
-
-button1 :: Html ()
-button1 =
- with
- button_
- [id_ "btnGo", Lucid.type_ "button"]
- ("Go " <> with i_ [class__ "fa fa-play"] mempty)
-
--- | One of each sharedrep input instances.
-data RepExamples
- = RepExamples
- { repTextbox :: Text,
- repTextarea :: Text,
- repSliderI :: Int,
- repSlider :: Double,
- repCheckbox :: Bool,
- repToggle :: Bool,
- repDropdown :: Int,
- repShape :: Shape,
- repColor :: Text
- }
- deriving (Show, Eq, Generic)
-
--- | For a typed dropdown example.
-data Shape = SquareShape | CircleShape deriving (Eq, Show, Generic)
-
--- | shape parser
-toShape :: Text -> Shape
-toShape t = case t of
- "Circle" -> CircleShape
- "Square" -> SquareShape
- _ -> CircleShape
-
--- | shape printer
-fromShape :: Shape -> Text
-fromShape CircleShape = "Circle"
-fromShape SquareShape = "Square"
-
--- | one of each input SharedReps
-repExamples :: (Monad m) => SharedRep m RepExamples
-repExamples = do
- t <- textbox (Just "textbox") "sometext"
- ta <- textarea 3 (Just "textarea") "no initial value & multi-line text\\nrenders is not ok?/"
- n <- sliderI (Just "int slider") 0 5 1 3
- ds' <- slider (Just "double slider") 0 1 0.1 0.5
- c <- checkbox (Just "checkbox") True
- tog <- toggle (Just "toggle") False
- dr <- dropdown decimal (pack . show) (Just "dropdown") ((pack . show) <$> [1 .. 5 :: Int]) 3
- drt <- toShape <$> dropdown takeText id (Just "shape") (["Circle", "Square"]) (fromShape SquareShape)
- col <- colorPicker (Just "color") "#454e56"
- pure (RepExamples t ta n ds' c tog dr drt col)
-
-listExample :: (Monad m) => Int -> SharedRep m [Int]
-listExample n =
- accordionList
- (Just "accordianListify")
- "al"
- Nothing
- (\l a -> sliderI (Just l) (0 :: Int) n 1 a)
- ((\x -> "[" <> (pack . show) x <> "]") <$> [0 .. n] :: [Text])
- [0 .. n]
-
-listRepExample :: (Monad m) => Int -> SharedRep m [Int]
-listRepExample n =
- listRep
- (Just "listifyMaybe")
- "alm"
- (checkbox Nothing)
- (sliderI Nothing (0 :: Int) n 1)
- n
- 3
- [0 .. 4]
-
-fiddleExample :: Concerns Text
-fiddleExample =
- Concerns
- mempty
- mempty
- [q|
-
-|]
-
-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
diff --git a/src/Web/Page/Html.hs b/src/Web/Page/Html.hs
deleted file mode 100644
--- a/src/Web/Page/Html.hs
+++ /dev/null
@@ -1,90 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
--- | Key generators and miscellaneous html utilities.
---
--- Uses the lucid 'Lucid.Html'.
-module Web.Page.Html
- ( class__,
- toText,
- genName,
- genNamePre,
- libCss,
- libJs,
- HtmlT,
- Html,
- )
-where
-
-import Control.Monad.State
-import Data.Bool
-import Data.Text
-import qualified Data.Text.Lazy as Lazy
-import Lucid
-import Prelude
-
--- | FIXME: A horrible hack to separate class id's
-class__ :: Text -> Attribute
-class__ t = class_ (" " <> t <> " ")
-
--- | Convert html to text
-toText :: Html a -> Text
-toText = Lazy.toStrict . renderText
-
--- | name supply for html elements
-genName :: (MonadState Int m) => m Text
-genName = do
- modify (+ 1)
- (pack . show) <$> get
-
--- | sometimes a number doesn't work properly in html (or js???), and an alpha prefix seems to help
-genNamePre :: (MonadState Int m) => Text -> m Text
-genNamePre pre = (pre <>) <$> genName
-
--- | Convert a link to a css library from text to html.
---
--- >>> libCss "https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/css/bootstrap.min.css"
---
-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"
---
-libJs :: Text -> Html ()
-libJs url = with (script_ mempty) [src_ url]
-
-
--- | FIXME: `ToHtml a` is used throughout, mostly because `Show a` gives "\"text\"" for show "text", and hilarity ensues when rendering this to a web page, and I couldn't work out how to properly get around this.
---
--- Hence, these orphans.
-instance ToHtml Double where
-
- toHtml = toHtml . (pack . show)
-
- toHtmlRaw = toHtmlRaw . (pack . show)
-
-instance ToHtml Bool where
-
- toHtml = toHtml . bool ("false" :: Text) "true"
-
- toHtmlRaw = toHtmlRaw . bool ("false" :: Text) "true"
-
-instance ToHtml Int where
-
- toHtml = toHtml . (pack . show)
-
- toHtmlRaw = toHtmlRaw . (pack . show)
-
-instance ToHtml () where
-
- toHtml = const "()"
-
- toHtmlRaw = const "()"
diff --git a/src/Web/Page/Html/Input.hs b/src/Web/Page/Html/Input.hs
deleted file mode 100644
--- a/src/Web/Page/Html/Input.hs
+++ /dev/null
@@ -1,245 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedLabels #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# OPTIONS_GHC -Wall #-}
-
--- | Common web page input elements, often with bootstrap scaffolding.
-module Web.Page.Html.Input
- ( Input (..),
- InputType (..),
- )
-where
-
-import Data.Bool
-import Data.Maybe
-import Data.Text
-import GHC.Generics
-import Lucid
-import Lucid.Base
-import Web.Page.Html
-import Prelude
-
--- | something that might exist on a web page and be a front-end input to computations.
-data Input a
- = Input
- { -- | underlying value
- inputVal :: a,
- -- | label suggestion
- inputLabel :: Maybe Text,
- -- | name//key//id of the Input
- inputId :: Text,
- -- | type of html input
- inputType :: InputType
- }
- deriving (Eq, Show, Generic)
-
--- | Various types of web page inputs, encapsulating practical bootstrap class functionality
-data InputType
- = Slider [Attribute]
- | TextBox
- | TextArea Int
- | ColorPicker
- | ChooseFile
- | Dropdown [Text]
- | DropdownSum [Text]
- | Datalist [Text] Text
- | Checkbox Bool
- | Toggle Bool (Maybe Text)
- | Button
- deriving (Eq, Show, Generic)
-
-instance (ToHtml a) => ToHtml (Input a) where
-
- toHtml (Input v l i (Slider satts)) =
- with
- div_
- [class__ "form-group"]
- ( (maybe mempty (with label_ [for_ i] . toHtml) l)
- <> input_
- ( [ type_ "range",
- class__ " form-control-range custom-range jsbClassEventChange",
- id_ i,
- value_ (pack $ show $ toHtml v)
- ]
- <> satts
- )
- )
- toHtml (Input v l i TextBox) =
- with
- div_
- [class__ "form-group"]
- ( (maybe mempty (with label_ [for_ i] . toHtml) l)
- <> input_
- ( [ type_ "text",
- class__ "form-control jsbClassEventInput",
- id_ i,
- value_ (pack $ show $ toHtmlRaw v)
- ]
- )
- )
- toHtml (Input v l i (TextArea rows)) =
- with
- div_
- [class__ "form-group"]
- ( maybe mempty (with label_ [for_ i] . toHtml) l
- <> ( with
- textarea_
- [ rows_ (pack $ show rows),
- class__ "form-control jsbClassEventInput",
- id_ i
- ]
- (toHtmlRaw v)
- )
- )
- toHtml (Input v l i ColorPicker) =
- with
- div_
- [class__ "form-group"]
- ( (maybe mempty (with label_ [for_ i] . toHtml) l)
- <> input_
- ( [ type_ "color",
- class__ "form-control jsbClassEventInput",
- id_ i,
- value_ (pack $ show $ toHtml v)
- ]
- )
- )
- toHtml (Input _ l i ChooseFile) =
- with
- div_
- [class__ "form-group"]
- (maybe mempty (with label_ [for_ i] . toHtml) l)
- <> input_
- ( [ type_ "file",
- class__ "form-control-file jsbClassEventChooseFile",
- id_ i
- ]
- )
- toHtml (Input v l i (Dropdown opts)) =
- with
- div_
- [class__ "form-group"]
- ( (maybe mempty (with label_ [for_ i] . toHtml) l)
- <> ( with
- select_
- [ class__ "form-control jsbClassEventInput",
- id_ i
- ]
- opts'
- )
- )
- where
- opts' =
- mconcat $
- ( \o ->
- with
- option_
- ( bool
- []
- [selected_ "selected"]
- (toText (toHtml o) == toText (toHtml v))
- )
- (toHtml o)
- )
- <$> opts
- toHtml (Input v l i (DropdownSum opts)) =
- with
- div_
- [class__ "form-group sumtype-group"]
- ( (maybe mempty (with label_ [for_ i] . toHtml) l)
- <> ( with
- select_
- [ class__ "form-control jsbClassEventInput jsbClassEventShowSum",
- id_ i
- ]
- opts'
- )
- )
- where
- opts' =
- mconcat $
- ( \o ->
- with
- option_
- (bool [] [selected_ "selected"] (toText (toHtml o) == toText (toHtml v)))
- (toHtml o)
- )
- <$> opts
- toHtml (Input v l i (Datalist opts listId)) =
- with
- div_
- [class__ "form-group"]
- ( (maybe mempty (with label_ [for_ i] . toHtml) l)
- <> input_
- [ type_ "text",
- class__ "form-control jsbClassEventInput",
- id_ i,
- list_ listId
- -- the datalist concept in html assumes initial state is a null
- -- and doesn't present the list if it has a value alreadyx
- -- , value_ (show $ toHtml v)
- ]
- <> with
- datalist_
- [id_ listId]
- ( mconcat $
- ( \o ->
- with
- option_
- ( bool
- []
- [selected_ "selected"]
- (toText (toHtml o) == toText (toHtml v))
- )
- (toHtml o)
- )
- <$> opts
- )
- )
- -- FIXME: How can you refactor to eliminate this polymorphic wart?
- toHtml (Input _ l i (Checkbox checked)) =
- with
- div_
- [class__ "form-check"]
- ( input_
- ( [ type_ "checkbox",
- class__ "form-check-input jsbClassEventCheckbox",
- id_ i
- ]
- <> bool [] [checked_] checked
- )
- <> (maybe mempty (with label_ [for_ i, class__ "form-check-label"] . toHtml) l)
- )
- toHtml (Input _ l i (Toggle pushed lab)) =
- with
- div_
- [class__ "form-group"]
- ( (maybe mempty (with label_ [for_ i] . toHtml) l)
- <> input_
- ( [ type_ "button",
- class__ "btn btn-primary btn-sm jsbClassEventToggle",
- data_ "toggle" "button",
- id_ i,
- makeAttribute "aria-pressed" (bool "false" "true" pushed)
- ]
- <> (maybe [] (\l' -> [value_ l']) lab)
- <> bool [] [checked_] pushed
- )
- )
- toHtml (Input _ l i Button) =
- with
- div_
- [class__ "form-group"]
- ( input_
- ( [ type_ "button",
- id_ i,
- class__ "btn btn-primary btn-sm jsbClassEventButton",
- value_ (fromMaybe "button" l)
- ]
- )
- )
-
- toHtmlRaw = toHtml
-
diff --git a/src/Web/Page/Mathjax.hs b/src/Web/Page/Mathjax.hs
deleted file mode 100644
--- a/src/Web/Page/Mathjax.hs
+++ /dev/null
@@ -1,158 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedLabels #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# OPTIONS_GHC -Wall #-}
-
--- | mathjax functionality.
---
--- some assets
---
---
---
--- FIXME: Mathjax inside svg doesn't quite work, and needs to be structured around the foreign object construct.
-module Web.Page.Mathjax
- ( mathjaxPage,
- mathjax27Page,
- mathjaxSvgPage,
- mathjax27SvgPage,
- )
-where
-
-import Control.Lens
-import Data.Text (Text)
-import Lucid
-import Text.InterpolatedString.Perl6
-import Web.Page.Types
-import Prelude
-
-mathjax3Lib :: Html ()
-mathjax3Lib =
- with
- (script_ mempty)
- [ src_ "https://cdn.jsdelivr.net/npm/mathjax@3/es5/tex-mml-svg.js",
- id_ "MathJax-script",
- async_ ""
- ]
-
-mathjax27Lib :: Html ()
-mathjax27Lib =
- with
- (script_ mempty)
- [ src_ "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-MML-AM_SVG"
- ]
-
-jqueryLib :: Html ()
-jqueryLib =
- with
- (script_ mempty)
- [ src_ "https://code.jquery.com/jquery-3.3.1.slim.min.js",
- integrity_ "sha384-q8i/X+965DzO0rT7abK41JStQIAqVgRVzpbzo5smXKp4YfRvH+8abtTE1Pi6jizo",
- crossorigin_ "anonymous"
- ]
-
--- | A 'Page' that loads mathjax
-mathjaxPage :: Page
-mathjaxPage =
- mempty
- & #jsGlobal .~ PageJsText scriptMathjaxConfig
- & #libsJs
- .~ [ mathjax3Lib
- ]
-
--- | A 'Page' that loads the mathjax 2.7 js library
-mathjax27Page :: Page
-mathjax27Page =
- mempty
- & #jsOnLoad .~ PageJsText scriptMathjaxConfig
- & #libsJs
- .~ [ mathjax27Lib
- ]
-
--- | A 'Page' that tries to enable mathjax inside svg (which is tricky).
-mathjaxSvgPage :: Text -> Page
-mathjaxSvgPage cl =
- mempty
- & #jsGlobal .~ PageJsText (scriptMathjaxConfigSvg cl)
- & #libsJs
- .~ [ mathjax3Lib,
- jqueryLib
- ]
-
--- | A 'Page' that tries to enable mathjax 2.7 inside svg.
-mathjax27SvgPage :: Text -> Page
-mathjax27SvgPage cl =
- mempty
- & #jsGlobal .~ PageJsText (scriptMathjax27ConfigSvg cl)
- & #libsJs
- .~ [ mathjax27Lib,
- jqueryLib
- ]
-
-
-scriptMathjaxConfig :: Text
-scriptMathjaxConfig =
- [q|
-MathJax = {
- tex: {
- inlineMath: [ ['$','$'], ["\\(","\\)"] ]
- }
-};
-|]
-
--- | Mathjax applies within an svg element as normal, but results in an svg element inside a text element which is not allowed, hence the extra scripting.
--- http://bl.ocks.org/larsenmtl/86077bddc91c3de8d3db6a53216b2f47
-scriptMathjax27ConfigSvg :: Text -> Text
-scriptMathjax27ConfigSvg cl =
- [qq|
- setTimeout(() => \{
-
- MathJax.Hub.Config(\{
- tex2jax: \{
- inlineMath: [ ['$','$'], ["\\(","\\)"] ],
- processEscapes: true
- }
- });
-
- MathJax.Hub.Register.StartupHook("End", function() \{
- setTimeout(() => \{
- $('.{cl}').each(function()\{
- var m = $('text>span>svg');
- m.remove();
- $(this).append(m);
- });
-
- }, 1);
- });
- }, 1);
-|]
-
--- | Mathjax applies within an svg element as normal, but results in an svg element inside a text element which is not allowed, hence the extra scripting.
--- http://bl.ocks.org/larsenmtl/86077bddc91c3de8d3db6a53216b2f47
-scriptMathjaxConfigSvg :: Text -> Text
-scriptMathjaxConfigSvg cl =
- [qq|
- window.MathJax = \{
- tex: \{
- inlineMath: [ ['$','$'], ["\\(","\\)"] ]
- },
- startup: \{
- ready: () => \{
- MathJax.startup.defaultReady();
- MathJax.startup.promise.then(() => \{
- var xs = document.querySelectorAll('.{cl}');
- xs.forEach((x) =>
- \{ x.querySelectorAll('text').forEach((t) =>
- \{t.querySelectorAll('mjx-container>svg').forEach((s) =>
- \{
- Array.from(t.attributes).forEach((a) => s.setAttribute(a.name, a.value));
- x.appendChild(s);
- });
- });
- });
- });
- }
- }
- };
-|]
diff --git a/src/Web/Page/Render.hs b/src/Web/Page/Render.hs
deleted file mode 100644
--- a/src/Web/Page/Render.hs
+++ /dev/null
@@ -1,145 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedLabels #-}
-{-# LANGUAGE OverloadedStrings #-}
-
--- | Page rendering
-module Web.Page.Render
- ( renderPage,
- renderPageWith,
- renderPageHtmlWith,
- renderPageAsText,
- renderPageToFile,
- renderPageHtmlToFile,
- )
-where
-
-import Control.Applicative
-import Control.Lens
-import Control.Monad
-import Data.Foldable
-import Data.Monoid
-import Data.Text (Text)
-import qualified Data.Text as Text
-import Data.Text.IO (writeFile)
-import Lucid
-import qualified Lucid.Svg as Svg
-import Web.Page.Html
-import Web.Page.Types
-import Prelude hiding (writeFile)
-
--- | Render a Page with the default configuration into Html.
-renderPage :: Page -> Html ()
-renderPage p =
- (\(_, _, x) -> x) $ renderPageWith (defaultPageConfig "default") p
-
--- | Render a Page into Html.
-renderPageHtmlWith :: PageConfig -> Page -> Html ()
-renderPageHtmlWith pc p =
- (\(_, _, x) -> x) $ renderPageWith pc p
-
--- | Render a Page into css text, js text and html.
-renderPageWith :: PageConfig -> Page -> (Text, Text, Html ())
-renderPageWith pc p =
- case pc ^. #concerns of
- Inline -> (mempty, mempty, h)
- Separated -> (css, js, h)
- where
- h =
- case pc ^. #structure of
- HeaderBody ->
- doctype_
- <> with
- html_
- [lang_ "en"]
- ( head_
- ( mconcat
- [ meta_ [charset_ "utf-8"],
- cssInline,
- mconcat libsCss',
- p ^. #htmlHeader
- ]
- )
- <> body_
- ( mconcat
- [ p ^. #htmlBody,
- mconcat libsJs',
- jsInline
- ]
- )
- )
- Headless ->
- mconcat
- [ doctype_,
- meta_ [charset_ "utf-8"],
- mconcat libsCss',
- cssInline,
- p ^. #htmlHeader,
- p ^. #htmlBody,
- mconcat libsJs',
- jsInline
- ]
- Snippet ->
- mconcat
- [ mconcat libsCss',
- cssInline,
- p ^. #htmlHeader,
- p ^. #htmlBody,
- mconcat libsJs',
- jsInline
- ]
- Svg ->
- Svg.doctype_
- <> svg_
- ( Svg.defs_ $
- mconcat
- [ mconcat libsCss',
- cssInline,
- p ^. #htmlBody,
- mconcat libsJs',
- jsInline
- ]
- )
- css = rendercss (p ^. #cssBody)
- js = renderjs (p ^. #jsGlobal <> onLoad (p ^. #jsOnLoad))
- renderjs = renderPageJs $ pc ^. #pageRender
- rendercss = renderPageCss $ pc ^. #pageRender
- cssInline
- | pc ^. #concerns == Separated || css == mempty = mempty
- | otherwise = style_ [type_ "text/css"] css
- jsInline
- | pc ^. #concerns == Separated || js == mempty = mempty
- | otherwise = script_ mempty js
- libsCss' =
- case pc ^. #concerns of
- Inline -> p ^. #libsCss
- Separated ->
- p ^. #libsCss
- <> [libCss (Text.pack $ pc ^. #filenames . #cssConcern)]
- libsJs' =
- case pc ^. #concerns of
- Inline -> p ^. #libsJs
- Separated ->
- p ^. #libsJs
- <> [libJs (Text.pack $ pc ^. #filenames . #jsConcern)]
-
--- | Render Page concerns to files.
-renderPageToFile :: FilePath -> PageConfig -> Page -> IO ()
-renderPageToFile dir pc page =
- sequenceA_ $ liftA2 writeFile' (pc ^. #filenames) (renderPageAsText pc page)
- where
- writeFile' fp s = unless (s == mempty) (writeFile (dir <> "/" <> fp) s)
-
--- | Render a page to just a Html file.
-renderPageHtmlToFile :: FilePath -> PageConfig -> Page -> IO ()
-renderPageHtmlToFile file pc page =
- writeFile file (toText $ renderPageHtmlWith pc page)
-
--- | Render a Page as Text.
-renderPageAsText :: PageConfig -> Page -> Concerns Text
-renderPageAsText pc p =
- case pc ^. #concerns of
- Inline -> Concerns mempty mempty htmlt
- Separated -> Concerns css js htmlt
- where
- htmlt = toText h
- (css, js, h) = renderPageWith pc p
diff --git a/src/Web/Page/Server.hs b/src/Web/Page/Server.hs
deleted file mode 100644
--- a/src/Web/Page/Server.hs
+++ /dev/null
@@ -1,41 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedLabels #-}
-{-# OPTIONS_GHC -Wall #-}
-
--- | Serve pages via 'ScottyM'
-module Web.Page.Server
- ( servePageWith
- ) where
-
-import Control.Lens hiding (only)
-import Lucid (renderText)
-import Network.Wai.Middleware.Static (addBase, noDots, staticPolicy, only)
-import Prelude
-import Web.Page.Render
-import Web.Page.Types
-import Web.Scotty
-import qualified Control.Monad.State as State
-import Control.Monad
-import Data.Text (unpack)
-
--- | serve a Page via a ScottyM
-servePageWith :: RoutePattern -> PageConfig -> Page -> ScottyM ()
-servePageWith rp pc p =
- sequence_ $ servedir <> [getpage]
- where
- getpage = case pc ^. #concerns of
- Inline ->
- get rp (html $ renderText $ renderPageHtmlWith pc p)
- Separated -> let (css,js,h) = renderPageWith pc p in
- do
- middleware $ staticPolicy $ only [(cssfp,cssfp), (jsfp, jsfp)]
- get rp (do
- State.lift $ writeFile' cssfp (unpack css)
- State.lift $ writeFile' jsfp (unpack js)
- html $ renderText h)
- cssfp = pc ^. #filenames . #cssConcern
- jsfp = pc ^. #filenames . #jsConcern
- writeFile' fp s = unless (s == mempty) (writeFile fp s)
- servedir = (\x -> middleware $ staticPolicy (noDots <> addBase x)) <$> pc ^. #localdirs
-
diff --git a/src/Web/Page/SharedReps.hs b/src/Web/Page/SharedReps.hs
deleted file mode 100644
--- a/src/Web/Page/SharedReps.hs
+++ /dev/null
@@ -1,426 +0,0 @@
-{-# LANGUAGE ApplicativeDo #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedLabels #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TupleSections #-}
-{-# OPTIONS_GHC -Wall #-}
-{-# OPTIONS_GHC -Wredundant-constraints #-}
-
--- | Various SharedRep instances for common html input elements.
-module Web.Page.SharedReps
- ( repInput,
- repMessage,
- sliderI,
- slider,
- dropdown,
- datalist,
- dropdownSum,
- colorPicker,
- textbox,
- textarea,
- checkbox,
- toggle,
- button,
- chooseFile,
- maybeRep,
- fiddle,
- viaFiddle,
- accordionList,
- listMaybeRep,
- listRep,
- readTextbox,
- defaultListLabels,
- )
-where
-
-import Box.Cont ()
-import Control.Lens
-import Control.Monad
-import Control.Monad.Trans.State
-import Data.Attoparsec.Text hiding (take)
-import Data.Biapplicative
-import Data.Bool
-import qualified Data.HashMap.Strict as HashMap
-import Data.Text (Text, pack, unpack)
-import Lucid
-import Text.InterpolatedString.Perl6
-import Web.Page.Bootstrap
-import Web.Page.Html
-import Web.Page.Html.Input
-import Web.Page.Types
-import Prelude hiding (lookup)
-
--- $setup
--- >>> :set -XOverloadedStrings
-
--- | Create a sharedRep from an Input.
-repInput ::
- (Monad m, ToHtml a) =>
- -- | Parser
- Parser a ->
- -- | Printer
- (a -> Text) ->
- -- | 'Input' type
- Input a ->
- -- | initial value
- a ->
- SharedRep m a
-repInput p pr i a =
- SharedRep $ do
- name <- zoom _1 genName
- zoom _2 (modify (HashMap.insert name (pr a)))
- pure $
- Rep
- (toHtml $ #inputVal .~ a $ #inputId .~ name $ i)
- ( \s ->
- ( s,
- join
- $ maybe (Left "lookup failed") Right
- $ either (Left . (\x -> name <> ": " <> x) . pack) Right . parseOnly p <$> HashMap.lookup name s
- )
- )
-
--- | Like 'repInput', but does not put a value into the HashMap on instantiation, consumes the value when found in the HashMap, and substitutes a default on lookup failure
-repMessage :: (Monad m, ToHtml a) => Parser a -> (a -> Text) -> Input a -> a -> a -> SharedRep m a
-repMessage p _ i def a =
- SharedRep $ do
- name <- zoom _1 genName
- pure $
- Rep
- (toHtml $ #inputVal .~ a $ #inputId .~ name $ i)
- ( \s ->
- ( HashMap.delete name s,
- join
- $ maybe (Right $ Right def) Right
- $ either (Left . pack) Right . parseOnly p <$> HashMap.lookup name s
- )
- )
-
--- | double slider
---
--- For Example, a slider between 0 and 1 with a step of 0.01 and a default value of 0.3 is:
---
--- >>> :t slider (Just "label") 0 1 0.01 0.3
--- slider (Just "label") 0 1 0.01 0.3 :: Monad m => SharedRep m Double
-slider ::
- (Monad m) =>
- Maybe Text ->
- Double ->
- Double ->
- Double ->
- Double ->
- SharedRep m Double
-slider label l u s v =
- repInput
- double
- (pack . show)
- (Input v label mempty (Slider [min_ (pack $ show l), max_ (pack $ show u), step_ (pack $ show s)]))
- v
-
--- | integral slider
---
--- For Example, a slider between 0 and 1000 with a step of 10 and a default value of 300 is:
---
--- >>> :t sliderI (Just "label") 0 1000 10 300
--- sliderI (Just "label") 0 1000 10 300
--- :: (Monad m, ToHtml a, Integral a, Show a) => SharedRep m a
-sliderI ::
- (Monad m, ToHtml a, Integral a, Show a) =>
- Maybe Text ->
- a ->
- a ->
- a ->
- a ->
- SharedRep m a
-sliderI label l u s v =
- repInput
- decimal
- (pack . show)
- (Input v label mempty (Slider [min_ (pack $ show l), max_ (pack $ show u), step_ (pack $ show s)]))
- v
-
--- | textbox classique
---
--- >>> :t textbox (Just "label") "some text"
--- textbox (Just "label") "some text" :: Monad m => SharedRep m Text
-textbox :: (Monad m) => Maybe Text -> Text -> SharedRep m Text
-textbox label v =
- repInput
- takeText
- id
- (Input v label mempty TextBox)
- v
-
--- | textarea input element, specifying number of rows.
-textarea :: (Monad m) => Int -> Maybe Text -> Text -> SharedRep m Text
-textarea rows label v =
- repInput
- takeText
- id
- (Input v label mempty (TextArea rows))
- v
-
--- | Non-typed hex color input
-colorPicker :: (Monad m) => Maybe Text -> Text -> SharedRep m Text
-colorPicker label v =
- repInput
- takeText
- id
- (Input v label mempty ColorPicker)
- v
-
--- | dropdown box
-dropdown ::
- (Monad m, ToHtml a) =>
- -- | parse an a from Text
- Parser a ->
- -- | print an a to Text
- (a -> Text) ->
- -- | label suggestion
- Maybe Text ->
- -- | list of dropbox elements (as text)
- [Text] ->
- -- | initial value
- a ->
- SharedRep m a
-dropdown p pr label opts v =
- repInput
- p
- pr
- (Input v label mempty (Dropdown opts))
- v
-
--- | a datalist input
-datalist :: (Monad m) => Maybe Text -> [Text] -> Text -> Text -> SharedRep m Text
-datalist label opts v id'' =
- repInput
- takeText
- (pack . show)
- (Input v label mempty (Datalist opts id''))
- v
-
--- | A dropdown box designed to help represent a haskell sum type.
-dropdownSum ::
- (Monad m, ToHtml a) =>
- Parser a ->
- (a -> Text) ->
- Maybe Text ->
- [Text] ->
- a ->
- SharedRep m a
-dropdownSum p pr label opts v =
- repInput
- p
- pr
- (Input v label mempty (DropdownSum opts))
- v
-
--- | A checkbox input.
-checkbox :: (Monad m) => Maybe Text -> Bool -> SharedRep m Bool
-checkbox label v =
- repInput
- ((== "true") <$> takeText)
- (bool "false" "true")
- (Input v label mempty (Checkbox v))
- v
-
--- | a toggle button
-toggle :: (Monad m) => Maybe Text -> Bool -> SharedRep m Bool
-toggle label v =
- repInput
- ((== "true") <$> takeText)
- (bool "false" "true")
- (Input v label mempty (Toggle v label))
- v
-
--- | a button
-button :: (Monad m) => Maybe Text -> SharedRep m Bool
-button label =
- repMessage
- (pure True)
- (bool "false" "true")
- (Input False label mempty Button)
- False
- False
-
--- | filename input
-chooseFile :: (Monad m) => Maybe Text -> Text -> SharedRep m Text
-chooseFile label v =
- repInput
- takeText
- (pack . show)
- (Input v label mempty ChooseFile)
- v
-
-checkboxShowJs :: (Monad m) => Maybe Text -> Text -> Bool -> SharedRep m Bool
-checkboxShowJs label cl v =
- SharedRep $ do
- name <- zoom _1 genName
- zoom _2 (modify (HashMap.insert name (bool "false" "true" v)))
- pure $
- Rep
- (toHtml (Input v label name (Checkbox v)) <> scriptToggleShow name cl)
- ( \s ->
- ( s,
- join
- $ maybe (Left "HashMap.lookup failed") Right
- $ either (Left . pack) Right . parseOnly ((== "true") <$> takeText)
- <$> HashMap.lookup name s
- )
- )
-
--- | Represent a Maybe using a checkbox.
---
--- Hides the underlying content on Nothing
-maybeRep ::
- (Monad m) =>
- Maybe Text ->
- Bool ->
- SharedRep m a ->
- SharedRep m (Maybe a)
-maybeRep label st sa = SharedRep $ do
- className <- zoom _1 genName
- unrep $ bimap (hmap className) mmap (checkboxShowJs label className st) <<*>> sa
- where
- hmap cl a b =
- cardify
- (a, [])
- Nothing
- ( ( Lucid.with
- div_
- [ class__ cl,
- style_
- ("display:" <> bool "none" "block" st)
- ]
- b
- ),
- [style_ "padding-top: 0.25rem; padding-bottom: 0.25rem;"]
- )
- mmap a b = bool Nothing (Just b) a
-
--- | A (fixed-size) list represented in html as an accordion card
--- A major restriction of the library is that a 'SharedRep' does not have a Monad instance. In practice, this means that the external representation of lists cannot have a dynamic size.
-accordionList :: (Monad m) => Maybe Text -> Text -> Maybe Text -> (Text -> a -> SharedRep m a) -> [Text] -> [a] -> SharedRep m [a]
-accordionList title prefix open srf labels as = SharedRep $ do
- (Rep h fa) <-
- unrep
- $ first (accordion prefix open . zip labels)
- $ foldr
- (\a x -> bimap (:) (:) a <<*>> x)
- (pure [])
- (zipWith srf labels as)
- h' <- zoom _1 h
- pure (Rep (maybe mempty (h5_ . toHtml) title <> h') fa)
-
--- | A (fixed-sized) list of (Bool, a) tuples.
-accordionBoolList :: (Monad m) => Maybe Text -> Text -> (a -> SharedRep m a) -> (Bool -> SharedRep m Bool) -> [Text] -> [(Bool, a)] -> SharedRep m [(Bool, a)]
-accordionBoolList title prefix bodyf checkf labels xs = SharedRep $ do
- (Rep h fa) <-
- unrep
- $ first (accordionChecked prefix)
- $ first (zipWith (\l (ch, a) -> (l, a, ch)) labels)
- $ foldr
- (\a x -> bimap (:) (:) a <<*>> x)
- (pure [])
- ( ( \(ch, a) ->
- ( bimap
- (,)
- (,)
- (checkf ch)
- <<*>> bodyf a
- )
- )
- <$> xs
- )
- h' <- zoom _1 h
- pure (Rep (maybe mempty (h5_ . toHtml) title <> h') fa)
-
--- | A fixed-sized list of Maybe a\'s
-listMaybeRep :: (Monad m) => Maybe Text -> Text -> (Text -> Maybe a -> SharedRep m (Maybe a)) -> Int -> [a] -> SharedRep m [Maybe a]
-listMaybeRep t p srf n as =
- accordionList t p Nothing srf (defaultListLabels n) (take n ((Just <$> as) <> repeat Nothing))
-
--- | A SharedRep of [a]. Due to the applicative nature of the bridge, the size of lists has to be fixed on construction. listRep is a workaround for this, to enable some form of dynamic sizing.
-listRep ::
- (Monad m) =>
- Maybe Text ->
- Text ->
- -- | name prefix (should be unique)
- (Bool -> SharedRep m Bool) ->
- -- | Bool Rep
- (a -> SharedRep m a) ->
- -- | a Rep
- Int ->
- -- | maximum length of list
- a ->
- -- | default value for new rows
- [a] ->
- -- | initial values
- SharedRep m [a]
-listRep t p brf srf n defa as =
- second (mconcat . fmap (\(b, a) -> bool [] [a] b)) $
- accordionBoolList
- t
- p
- srf
- brf
- (defaultListLabels n)
- (take n (((True,) <$> as) <> repeat (False, defa)))
-
--- a sensible default for the accordion row labels for a list
-defaultListLabels :: Int -> [Text]
-defaultListLabels n = (\x -> "[" <> pack (show x) <> "]") <$> [0 .. n] :: [Text]
-
--- | Parse from a textbox
---
-readTextbox :: (Monad m, Read a, Show a) => Maybe Text -> a -> SharedRep m (Either Text a)
-readTextbox label v = parsed . unpack <$> textbox label (pack $ show v)
- where
- parsed str =
- case reads str of
- [(a, "")] -> Right a
- _ -> Left (pack str)
-
--- | Representation of web concerns (css, js & html).
-fiddle :: (Monad m) => Concerns Text -> SharedRep m (Concerns Text, Bool)
-fiddle (Concerns c j h) =
- bimap
- (\c' j' h' up -> (Lucid.with div_ [class__ "fiddle "] $ mconcat [up, h', j', c']))
- (\c' j' h' up -> (Concerns c' j' h', up))
- (textarea 10 (Just "css") c)
- <<*>> textarea 10 (Just "js") j
- <<*>> textarea 10 (Just "html") h
- <<*>> button (Just "update")
-
--- | turns a SharedRep into a fiddle
-viaFiddle ::
- (Monad m) =>
- SharedRep m a ->
- SharedRep m (Bool, Concerns Text, a)
-viaFiddle sr = SharedRep $ do
- sr'@(Rep h _) <- unrep sr
- hrep <- unrep $ textarea 10 (Just "html") (toText h)
- crep <- unrep $ textarea 10 (Just "css") mempty
- jrep <- unrep $ textarea 10 (Just "js") mempty
- u <- unrep $ button (Just "update")
- pure $
- bimap
- (\up a b c _ -> (Lucid.with div_ [class__ "fiddle "] $ mconcat [up, a, b, c]))
- (\up a b c d -> (up, Concerns a b c, d))
- u
- <<*>> crep
- <<*>> jrep
- <<*>> hrep
- <<*>> sr'
-
--- | toggle show/hide
-scriptToggleShow :: (Monad m) => Text -> Text -> HtmlT m ()
-scriptToggleShow checkName toggleClass =
- script_
- [qq|
-$('#{checkName}').on('change', (function()\{
- var vis = this.checked ? "block" : "none";
- Array.from(document.getElementsByClassName({toggleClass})).forEach(x => x.style.display = vis);
-\}));
-|]
diff --git a/src/Web/Page/Types.hs b/src/Web/Page/Types.hs
deleted file mode 100644
--- a/src/Web/Page/Types.hs
+++ /dev/null
@@ -1,421 +0,0 @@
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE OverloadedLabels #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TupleSections #-}
-{-# OPTIONS_HADDOCK hide, not-home #-}
-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
-
-module Web.Page.Types
- ( Page (..),
- PageConfig (..),
- defaultPageConfig,
- Concerns (..),
- suffixes,
- concernNames,
- PageConcerns (..),
- PageStructure (..),
- PageRender (..),
- Css,
- PageCss (..),
- renderCss,
- renderPageCss,
- JS (..),
- PageJs (..),
- onLoad,
- renderPageJs,
- parseJs,
- renderJs,
- Element (..),
- RepF (..),
- Rep,
- oneRep,
- SharedRepF (..),
- SharedRep,
- runOnce,
- zeroState,
- )
-where
-
-import qualified Clay
-import Clay (Css)
-import Control.Applicative
-import Control.Lens
-import Control.Monad.IO.Class
-import Control.Monad.Morph
-import Control.Monad.State
-import Data.Aeson
-import Data.Biapplicative
-import Data.Generics.Labels ()
-import Data.HashMap.Strict as HashMap hiding (foldr)
-import Data.Text (Text, unpack)
-import qualified Data.Text as Text
-import Data.Text.Lazy (toStrict)
-import GHC.Generics hiding (Rep)
-import Language.JavaScript.Parser
-import Language.JavaScript.Parser.AST
-import Language.JavaScript.Process.Minify
-import Lucid
-import Text.InterpolatedString.Perl6
-import Prelude
-
--- | Components of a web page.
---
--- A web page can take many forms but still have the same underlying representation. For example, CSS can be linked to in a separate file, or can be inline within html, but still be the same css and have the same expected external effect. A Page represents the practical components of what makes up a static snapshot of a web page.
-data Page
- = Page
- { -- | css library links
- libsCss :: [Html ()],
- -- | javascript library links
- libsJs :: [Html ()],
- -- | css
- cssBody :: PageCss,
- -- | javascript with global scope
- jsGlobal :: PageJs,
- -- | javascript included within the onLoad function
- jsOnLoad :: PageJs,
- -- | html within the header
- htmlHeader :: Html (),
- -- | body html
- htmlBody :: Html ()
- }
- deriving (Show, Generic)
-
-instance Semigroup Page where
- (<>) p0 p1 =
- Page
- (p0 ^. #libsCss <> p1 ^. #libsCss)
- (p0 ^. #libsJs <> p1 ^. #libsJs)
- (p0 ^. #cssBody <> p1 ^. #cssBody)
- (p0 ^. #jsGlobal <> p1 ^. #jsGlobal)
- (p0 ^. #jsOnLoad <> p1 ^. #jsOnLoad)
- (p0 ^. #htmlHeader <> p1 ^. #htmlHeader)
- (p0 ^. #htmlBody <> p1 ^. #htmlBody)
-
-instance Monoid Page where
-
- mempty = Page [] [] mempty mempty mempty mempty mempty
-
- mappend = (<>)
-
--- |
---
--- A key-value Text pair as the realistic datatype that zips across the interface between a page and haskell.
-data Element
- = Element
- { element :: Text,
- value :: Text
- }
- deriving (Eq, Show, Generic)
-
-instance ToJSON Element
-
-instance FromJSON Element where
- parseJSON = withObject "Element" $ \v ->
- Element
- <$> v .: "element"
- <*> v .: "value"
-
--- |
--- Information contained in a web page can usually be considered to be isomorphic to a map of named values - a 'HashMap'. This is especially true when considering a differential of information contained in a web page. Looking at a page from the outside, it often looks like a streaming differential of a hashmap.
---
--- RepF consists of an underlying value being represented, and, given a hashmap state, a way to produce a representation of the underlying value (or error), in another domain, together with the potential to alter the hashmap state.
-data RepF r a
- = Rep
- { rep :: r,
- make :: HashMap Text Text -> (HashMap Text Text, Either Text a)
- }
- deriving (Functor)
-
--- | the common usage, where the representation domain is Html
-type Rep a = RepF (Html ()) a
-
-instance (Semigroup r) => Semigroup (RepF r a) where
- (Rep r0 a0) <> (Rep r1 a1) =
- Rep
- (r0 <> r1)
- (\hm -> let (hm', x') = a0 hm in let (hm'', x'') = a1 hm' in (hm'', x' <> x''))
-
-instance (Monoid a, Monoid r) => Monoid (RepF r a) where
-
- mempty = Rep mempty (,Right mempty)
-
- mappend = (<>)
-
-instance Bifunctor RepF where
- bimap f g (Rep r a) = Rep (f r) (second (fmap g) . a)
-
-instance Biapplicative RepF where
-
- bipure r a = Rep r (,Right a)
-
- (Rep fr fa) <<*>> (Rep r a) =
- Rep
- (fr r)
- ( \hm ->
- let (hm', a') = a hm in let (hm'', fa') = fa hm' in (hm'', fa' <*> a')
- )
-
-instance (Monoid r) => Applicative (RepF r) where
-
- pure = bipure mempty
-
- Rep fh fm <*> Rep ah am =
- Rep
- (fh <> ah)
- ( \hm ->
- let (hm', a') = am hm in let (hm'', fa') = fm hm' in (hm'', fa' <*> a')
- )
-
--- | stateful result of one step, given a 'Rep', and a monadic action.
--- Useful for testing and for initialising a page.
-oneRep :: (Monad m, MonadIO m) => Rep a -> (Rep a -> HashMap Text Text -> m ()) -> StateT (HashMap Text Text) m (HashMap Text Text, Either Text a)
-oneRep r@(Rep _ fa) action = do
- m <- get
- let (m', a) = fa m
- put m'
- lift $ action r m'
- pure (m', a)
-
--- |
--- Driven by the architecture of the DOM, web page components are compositional, and tree-like, where components are often composed of other components, and values are thus shared across components.
---
--- This is sometimes referred to as "observable sharing". See as another library that reifies this (pun intended), and provided the initial inspiration for this implementation.
-newtype SharedRepF m r a
- = SharedRep
- { unrep :: StateT (Int, HashMap Text Text) m (RepF r a)
- }
- deriving (Functor)
-
--- | default representation type of 'Html' ()
-type SharedRep m a = SharedRepF m (Html ()) a
-
-instance (Functor m) => Bifunctor (SharedRepF m) where
- bimap f g (SharedRep s) = SharedRep $ fmap (bimap f g) s
-
-instance (Monad m) => Biapplicative (SharedRepF m) where
-
- bipure r a = SharedRep $ pure $ bipure r a
-
- (SharedRep f) <<*>> (SharedRep a) = SharedRep $ liftA2 (<<*>>) f a
-
-instance (Monad m, Monoid r) => Applicative (SharedRepF m r) where
-
- pure = bipure mempty
-
- SharedRep f <*> SharedRep a = SharedRep $ liftA2 (<*>) f a
-
--- | compute the initial state of a SharedRep (testing)
-zeroState ::
- (Monad m) =>
- SharedRep m a ->
- m (Html (), (HashMap Text Text, Either Text a))
-zeroState sr = do
- (Rep h fa, (_, m)) <- flip runStateT (0, HashMap.empty) $ unrep sr
- pure (h, fa m)
-
--- | Compute the initial state of a SharedRep and then run an action once (see tests).
-runOnce ::
- (Monad m) =>
- SharedRep m a ->
- (Html () -> HashMap Text Text -> m ()) ->
- m (HashMap Text Text, Either Text a)
-runOnce sr action = do
- (Rep h fa, (_, m)) <- flip runStateT (0, HashMap.empty) $ unrep sr
- action h m
- pure (fa m)
-
--- | A web page typically is composed of some css, javascript and html.
---
--- 'Concerns' abstracts this structural feature of a web page.
-data Concerns a
- = Concerns
- { cssConcern :: a,
- jsConcern :: a,
- htmlConcern :: a
- }
- deriving (Eq, Show, Foldable, Traversable, Generic)
-
-instance Functor Concerns where
- fmap f (Concerns c j h) = Concerns (f c) (f j) (f h)
-
-instance Applicative Concerns where
-
- pure a = Concerns a a a
-
- Concerns f g h <*> Concerns a b c = Concerns (f a) (g b) (h c)
-
--- | The common file suffixes of the three concerns.
-suffixes :: Concerns FilePath
-suffixes = Concerns ".css" ".js" ".html"
-
--- | Create filenames for each Concern element.
-concernNames :: FilePath -> FilePath -> Concerns FilePath
-concernNames dir stem =
- (\x -> dir <> stem <> x) <$> suffixes
-
--- | Is the rendering to include all 'Concerns' (typically in a html file) or be separated (tyypically into separate files and linked in the html file)?
-data PageConcerns
- = Inline
- | Separated
- deriving (Show, Eq, Generic)
-
--- | Various ways that a Html file can be structured.
-data PageStructure
- = HeaderBody
- | Headless
- | Snippet
- | Svg
- deriving (Show, Eq, Generic)
-
--- | Post-processing of page concerns
-data PageRender
- = Pretty
- | Minified
- | NoPost
- deriving (Show, Eq, Generic)
-
--- | Configuration options when rendering a 'Page'.
-data PageConfig
- = PageConfig
- { concerns :: PageConcerns,
- structure :: PageStructure,
- pageRender :: PageRender,
- filenames :: Concerns FilePath,
- localdirs :: [FilePath]
- }
- deriving (Show, Eq, Generic)
-
--- | Default configuration is inline ecma and css, separate html header and body, minified code, with the suggested filename prefix.
-defaultPageConfig :: FilePath -> PageConfig
-defaultPageConfig stem =
- PageConfig
- Inline
- HeaderBody
- Minified
- ((stem <>) <$> suffixes)
- []
-
--- | Unifies css as either a 'Clay.Css' or as Text.
-data PageCss = PageCss Clay.Css | PageCssText Text deriving (Generic)
-
-instance Show PageCss where
- show (PageCss css) = unpack . renderCss $ css
- show (PageCssText txt) = unpack txt
-
-instance Semigroup PageCss where
- (<>) (PageCss css) (PageCss css') = PageCss (css <> css')
- (<>) (PageCssText css) (PageCssText css') = PageCssText (css <> css')
- (<>) (PageCss css) (PageCssText css') =
- PageCssText (renderCss css <> css')
- (<>) (PageCssText css) (PageCss css') =
- PageCssText (css <> renderCss css')
-
-instance Monoid PageCss where
-
- mempty = PageCssText mempty
-
- mappend = (<>)
-
--- | Render 'PageCss' as text.
-renderPageCss :: PageRender -> PageCss -> Text
-renderPageCss Minified (PageCss css) = toStrict $ Clay.renderWith Clay.compact [] css
-renderPageCss _ (PageCss css) = toStrict $ Clay.render css
-renderPageCss _ (PageCssText css) = css
-
--- | Render 'Css' as text.
-renderCss :: Css -> Text
-renderCss = toStrict . Clay.render
-
--- | wrapper for `JSAST`
-newtype JS = JS {unJS :: JSAST} deriving (Show, Eq, Generic)
-
-instance Semigroup JS where
- (<>) (JS (JSAstProgram ss ann)) (JS (JSAstProgram ss' _)) =
- JS $ JSAstProgram (ss <> ss') ann
- (<>) (JS (JSAstProgram ss ann)) (JS (JSAstStatement s _)) =
- JS $ JSAstProgram (ss <> [s]) ann
- (<>) (JS (JSAstProgram ss ann)) (JS (JSAstExpression e ann')) =
- JS $ JSAstProgram (ss <> [JSExpressionStatement e (JSSemi ann')]) ann
- (<>) (JS (JSAstProgram ss ann)) (JS (JSAstLiteral e ann')) =
- JS $ JSAstProgram (ss <> [JSExpressionStatement e (JSSemi ann')]) ann
- (<>) (JS (JSAstStatement s ann)) (JS (JSAstProgram ss _)) =
- JS $ JSAstProgram (s : ss) ann
- (<>) (JS (JSAstStatement s ann)) (JS (JSAstStatement s' _)) =
- JS $ JSAstProgram [s, s'] ann
- (<>) (JS (JSAstStatement s ann)) (JS (JSAstExpression e ann')) =
- JS $ JSAstProgram [s, JSExpressionStatement e (JSSemi ann')] ann
- (<>) (JS (JSAstStatement s ann)) (JS (JSAstLiteral e ann')) =
- JS $ JSAstProgram [s, JSExpressionStatement e (JSSemi ann')] ann
- (<>) (JS (JSAstExpression e ann)) (JS (JSAstProgram ss _)) =
- JS $ JSAstProgram (JSExpressionStatement e (JSSemi ann) : ss) ann
- (<>) (JS (JSAstExpression e ann)) (JS (JSAstStatement s' _)) =
- JS $ JSAstProgram [JSExpressionStatement e (JSSemi ann), s'] ann
- (<>) (JS (JSAstExpression e ann)) (JS (JSAstExpression e' ann')) =
- JS $ JSAstProgram [JSExpressionStatement e (JSSemi ann), JSExpressionStatement e' (JSSemi ann')] ann
- (<>) (JS (JSAstExpression e ann)) (JS (JSAstLiteral e' ann')) =
- JS $ JSAstProgram [JSExpressionStatement e (JSSemi ann), JSExpressionStatement e' (JSSemi ann')] ann
- (<>) (JS (JSAstLiteral e ann)) (JS (JSAstProgram ss _)) =
- JS $ JSAstProgram (JSExpressionStatement e (JSSemi ann) : ss) ann
- (<>) (JS (JSAstLiteral e ann)) (JS (JSAstStatement s' _)) =
- JS $ JSAstProgram [JSExpressionStatement e (JSSemi ann), s'] ann
- (<>) (JS (JSAstLiteral e ann)) (JS (JSAstExpression e' ann')) =
- JS $ JSAstProgram [JSExpressionStatement e (JSSemi ann), JSExpressionStatement e' (JSSemi ann')] ann
- (<>) (JS (JSAstLiteral e ann)) (JS (JSAstLiteral e' ann')) =
- JS $ JSAstProgram [JSExpressionStatement e (JSSemi ann), JSExpressionStatement e' (JSSemi ann')] ann
-
-instance Monoid JS where
-
- mempty = JS $ JSAstProgram [] (JSAnnot (TokenPn 0 0 0) [])
-
- mappend = (<>)
-
--- | Unifies javascript as 'JSStatement' and script as 'Text'.
-data PageJs = PageJs JS | PageJsText Text deriving (Eq, Show, Generic)
-
-instance Semigroup PageJs where
- (<>) (PageJs js) (PageJs js') = PageJs (js <> js')
- (<>) (PageJsText js) (PageJsText js') = PageJsText (js <> js')
- (<>) (PageJs js) (PageJsText js') =
- PageJsText (toStrict (renderToText $ unJS js) <> js')
- (<>) (PageJsText js) (PageJs js') =
- PageJsText (js <> toStrict (renderToText $ unJS js'))
-
-instance Monoid PageJs where
-
- mempty = PageJs mempty
-
- mappend = (<>)
-
--- | Wrap js in standard DOM window loader.
-onLoad :: PageJs -> PageJs
-onLoad (PageJs js) = PageJs $ onLoadStatements [toStatement js]
-onLoad (PageJsText js) = PageJsText $ onLoadText js
-
-toStatement :: JS -> JSStatement
-toStatement (JS (JSAstProgram ss ann)) = JSStatementBlock JSNoAnnot ss JSNoAnnot (JSSemi ann)
-toStatement (JS (JSAstStatement s _)) = s
-toStatement (JS (JSAstExpression e ann')) = JSExpressionStatement e (JSSemi ann')
-toStatement (JS (JSAstLiteral e ann')) = JSExpressionStatement e (JSSemi ann')
-
-onLoadStatements :: [JSStatement] -> JS
-onLoadStatements js = JS $ JSAstProgram [JSAssignStatement (JSMemberDot (JSIdentifier JSNoAnnot "window") JSNoAnnot (JSIdentifier JSNoAnnot "onload")) (JSAssign JSNoAnnot) (JSFunctionExpression JSNoAnnot JSIdentNone JSNoAnnot JSLNil JSNoAnnot (JSBlock JSNoAnnot js JSNoAnnot)) JSSemiAuto] JSNoAnnot
-
-onLoadText :: Text -> Text
-onLoadText t = [qc| window.onload=function()\{{t}};|]
-
--- | Convert 'Text' to 'JS', throwing an error on incorrectness.
-parseJs :: Text -> JS
-parseJs = JS . readJs . Text.unpack
-
--- | Render 'JS' as 'Text'.
-renderJs :: JS -> Text
-renderJs = toStrict . renderToText . unJS
-
--- | Render 'PageJs' as 'Text'.
-renderPageJs :: PageRender -> PageJs -> Text
-renderPageJs _ (PageJsText js) = js
-renderPageJs Minified (PageJs js) = toStrict . renderToText . minifyJS . unJS $ js
-renderPageJs Pretty (PageJs js) = toStrict . renderToText . unJS $ js
diff --git a/src/Web/Rep.hs b/src/Web/Rep.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Rep.hs
@@ -0,0 +1,71 @@
+-- | A haskell library for representing web pages.
+--
+-- This library is a collection of web page abstractions, together with a reimagining of .
+--
+-- I wanted to expose the server delivery mechanism, switch the streaming nature of the gap between a web page and a haskell server, and concentrate on getting a clean interface between pure haskell and the world that is a web page.
+--
+-- See app/examples.hs and 'Web.Examples' for usage.
+module Web.Rep
+ ( -- * Shared Representation
+ RepF (..),
+ Rep,
+ oneRep,
+ SharedRepF (..),
+ SharedRep,
+ runOnce,
+ zeroState,
+ register,
+ genName,
+ genNamePre,
+
+ -- * Web Rep Components
+ Page (..),
+ PageConfig (..),
+ defaultPageConfig,
+ Concerns (..),
+ suffixes,
+ concernNames,
+ PageConcerns (..),
+ PageStructure (..),
+ PageRender (..),
+
+ -- * Css
+ Css,
+ RepCss (..),
+ renderCss,
+ renderRepCss,
+
+ -- * JS
+ JS (..),
+ RepJs (..),
+ onLoad,
+ renderRepJs,
+ parseJs,
+ renderJs,
+
+ -- * re-export modules
+ module Web.Rep.SharedReps,
+ module Web.Rep.Render,
+ module Web.Rep.Server,
+ module Web.Rep.Socket,
+ module Web.Rep.Html,
+ module Web.Rep.Html.Input,
+ module Web.Rep.Bootstrap,
+ module Web.Rep.Mathjax,
+
+ -- * re-exports
+ HashMap.HashMap,
+ )
+where
+
+import qualified Data.HashMap.Strict as HashMap
+import Web.Rep.Bootstrap
+import Web.Rep.Socket
+import Web.Rep.Html
+import Web.Rep.Html.Input
+import Web.Rep.Mathjax
+import Web.Rep.Page
+import Web.Rep.Render
+import Web.Rep.Server
+import Web.Rep.Shared
+import Web.Rep.SharedReps
diff --git a/src/Web/Rep/Bootstrap.hs b/src/Web/Rep/Bootstrap.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Rep/Bootstrap.hs
@@ -0,0 +1,165 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_GHC -Wall #-}
+
+-- | Some assets and functionality.
+module Web.Rep.Bootstrap
+ ( bootstrapPage,
+ cardify,
+ divClass_,
+ accordion,
+ accordionChecked,
+ accordionCard,
+ accordionCardChecked,
+ accordion_,
+ )
+where
+
+import Lucid
+import Lucid.Base
+import NumHask.Prelude
+import Web.Rep.Html
+import Web.Rep.Page
+import Web.Rep.Shared
+
+bootstrapCss :: [Html ()]
+bootstrapCss =
+ [ link_
+ [ rel_ "stylesheet",
+ href_ "https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/css/bootstrap.min.css",
+ integrity_ "sha384-ggOyR0iXCbMQv3Xipma34MD+dH/1fQ784/j6cY/iJTQUOhcWr7x9JvoRxT2MZw1T",
+ crossorigin_ "anonymous"
+ ]
+ ]
+
+bootstrapJs :: [Html ()]
+bootstrapJs =
+ [ with
+ (script_ mempty)
+ [ src_ "https://code.jquery.com/jquery-3.3.1.slim.min.js",
+ integrity_ "sha384-q8i/X+965DzO0rT7abK41JStQIAqVgRVzpbzo5smXKp4YfRvH+8abtTE1Pi6jizo",
+ crossorigin_ "anonymous"
+ ],
+ with
+ (script_ mempty)
+ [ src_ "https://cdnjs.cloudflare.com/ajax/libs/popper.js/1.14.7/umd/popper.min.js",
+ integrity_ "sha384-UO2eT0CpHqdSJQ6hJty5KVphtPhzWj9WO1clHTMGa3JDZwrnQq4sF86dIHNDz0W1",
+ crossorigin_ "anonymous"
+ ],
+ with
+ (script_ mempty)
+ [ src_ "https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/js/bootstrap.min.js",
+ integrity_ "sha384-JjSmVgyd0p3pXB1rRibZUAYoIIy6OrQ6VrjIEaFf/nJGzIxFDsf4x0xIM+B07jRM",
+ crossorigin_ "anonymous"
+ ]
+ ]
+
+bootstrapMeta :: [Html ()]
+bootstrapMeta =
+ [ meta_ [charset_ "utf-8"],
+ meta_
+ [ name_ "viewport",
+ content_ "width=device-width, initial-scale=1, shrink-to-fit=no"
+ ]
+ ]
+
+-- | A page containing all the needs for a web page.
+bootstrapPage :: Page
+bootstrapPage =
+ Page
+ bootstrapCss
+ bootstrapJs
+ mempty
+ mempty
+ mempty
+ (mconcat bootstrapMeta)
+ mempty
+
+-- | wrap some Html with the bootstrap class
+cardify :: (Html (), [Attribute]) -> Maybe Text -> (Html (), [Attribute]) -> Html ()
+cardify (h, hatts) t (b, batts) =
+ with div_ ([class__ "card"] <> hatts) $
+ h
+ <> with
+ div_
+ ([class__ "card-body"] <> batts)
+ ( maybe mempty (with h5_ [class__ "card-title"] . toHtml) t
+ <> b
+ )
+
+-- | wrap some html with a classed div
+divClass_ :: Text -> Html () -> Html ()
+divClass_ t = with div_ [class__ t]
+
+-- | A Html object based on the bootstrap accordion card concept.
+accordionCard :: Bool -> [Attribute] -> Text -> Text -> Text -> Text -> Html () -> Html ()
+accordionCard collapse atts idp idh idb t0 b =
+ with div_ ([class__ "card"] <> atts) $
+ with
+ div_
+ [class__ "card-header p-0", id_ idh]
+ ( with
+ h2_
+ [class__ "m-0"]
+ (with button_ [class__ ("btn btn-link" <> bool "" " collapsed" collapse), type_ "button", data_ "toggle" "collapse", data_ "target" ("#" <> idb), makeAttribute "aria-expanded" (bool "true" "false" collapse), makeAttribute "aria-controls" idb] (toHtml t0))
+ )
+ <> with
+ div_
+ [id_ idb, class__ ("collapse" <> bool " show" "" collapse), makeAttribute "aria-labelledby" idh, data_ "parent" ("#" <> idp)]
+ (with div_ [class__ "card-body"] b)
+
+-- | A bootstrap accordion card attached to a checkbox.
+accordionCardChecked :: Bool -> Text -> Text -> Text -> Text -> Html () -> Html () -> Html ()
+accordionCardChecked collapse idp idh idb label bodyhtml checkhtml =
+ with div_ [class__ "card"] $
+ with
+ div_
+ [class__ "card-header p-0", id_ idh]
+ ( checkhtml
+ <> with
+ h2_
+ [class__ "m-0"]
+ (with button_ [class__ ("btn btn-link" <> bool "" " collapsed" collapse), type_ "button", data_ "toggle" "collapse", data_ "target" ("#" <> idb), makeAttribute "aria-expanded" (bool "true" "false" collapse), makeAttribute "aria-controls" idb] (toHtml label))
+ )
+ <> with
+ div_
+ [id_ idb, class__ ("collapse" <> bool " show" "" collapse), makeAttribute "aria-labelledby" idh, data_ "parent" ("#" <> idp)]
+ (with div_ [class__ "card-body"] bodyhtml)
+
+-- | create a bootstrapped accordian class
+accordion ::
+ (MonadState Int m) =>
+ Text ->
+ -- | name prefix. This is needed because an Int doesn't seem to be a valid name.
+ Maybe Text ->
+ -- | card title
+ [(Text, Html ())] ->
+ -- | title, html tuple for each item in the accordion.
+ m (Html ())
+accordion pre x hs = do
+ idp' <- genNamePre pre
+ with div_ [class__ "accordion m-1", id_ idp'] <$> aCards idp'
+ where
+ aCards par = mconcat <$> sequence (aCard par <$> hs)
+ aCard par (t, b) = do
+ idh <- genNamePre pre
+ idb <- genNamePre pre
+ pure $ accordionCard (x /= Just t) [] par idh idb t b
+
+-- | create a bootstrapped accordian class
+accordionChecked :: (MonadState Int m) => Text -> [(Text, Html (), Html ())] -> m (Html ())
+accordionChecked pre hs = do
+ idp' <- genNamePre pre
+ with div_ [class__ "accordion m-1", id_ idp'] <$> aCards idp'
+ where
+ aCards par = mconcat <$> sequence (aCard par <$> hs)
+ aCard par (l, bodyhtml, checkhtml) = do
+ idh <- genNamePre pre
+ idb <- genNamePre pre
+ pure $ accordionCardChecked True par idh idb l bodyhtml checkhtml
+
+-- | This version of accordion runs a local state for naming, and will cause name clashes if the prefix is not unique.
+accordion_ :: Text -> Maybe Text -> [(Text, Html ())] -> Html ()
+accordion_ pre x hs = runIdentity $ evalStateT (accordion pre x hs) 0
diff --git a/src/Web/Rep/Examples.hs b/src/Web/Rep/Examples.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Rep/Examples.hs
@@ -0,0 +1,293 @@
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_GHC -Wall #-}
+
+module Web.Rep.Examples
+ ( page1,
+ page2,
+ pagemj,
+ cfg2,
+ RepExamples (..),
+ repExamples,
+ Shape (..),
+ fromShape,
+ toShape,
+ SumTypeExample (..),
+ repSumTypeExample,
+ SumType2Example (..),
+ repSumType2Example,
+ listExample,
+ listRepExample,
+ fiddleExample,
+ )
+where
+
+import qualified Clay
+import Control.Lens hiding ((.=))
+import Data.Attoparsec.Text
+import Lucid
+import NumHask.Prelude
+import Text.InterpolatedString.Perl6
+import Web.Rep
+
+-- | simple page example
+page1 :: Page
+page1 =
+ #htmlBody .~ button1
+ $ #cssBody .~ RepCss css1
+ $ #jsGlobal .~ mempty
+ $ #jsOnLoad .~ click
+ $ #libsCss .~ (libCss <$> cssLibs)
+ $ #libsJs .~ (libJs <$> jsLibs)
+ $ mempty
+
+-- | page with localised libraries
+page2 :: Page
+page2 =
+ #libsCss .~ (libCss <$> cssLibsLocal)
+ $ #libsJs .~ (libJs <$> jsLibsLocal)
+ $ page1
+
+-- | simple mathjax formulae
+pagemj :: Page
+pagemj = mathjaxPage & #htmlBody .~ htmlMathjaxExample
+
+htmlMathjaxExample :: HtmlT Identity ()
+htmlMathjaxExample =
+ p_ "double dollar:"
+ <> p_ "$$\\sum_{i=0}^n i^2 = \\frac{(n^2+n)(2n+1)}{6}$$"
+ <> p_ "single dollar for inline: $\\sum_{i=0}^n i^2 = \\frac{(n^2+n)(2n+1)}{6}$"
+ <> p_ "escaped brackets for inline mathjax: \\(\\sum_{i=0}^n i^2 = \\frac{(n^2+n)(2n+1)}{6}\\)"
+
+cfg2 :: PageConfig
+cfg2 =
+ #concerns .~ Separated
+ $ #pageRender .~ Pretty
+ $ #structure .~ Headless
+ $ #localdirs .~ ["test/static"]
+ $ #filenames .~ (("other/cfg2" <>) <$> suffixes)
+ $ defaultPageConfig ""
+
+cssLibs :: [Text]
+cssLibs =
+ ["http://maxcdn.bootstrapcdn.com/font-awesome/4.3.0/css/font-awesome.min.css"]
+
+cssLibsLocal :: [Text]
+cssLibsLocal = ["css/font-awesome.min.css"]
+
+jsLibs :: [Text]
+jsLibs = ["http://code.jquery.com/jquery-1.6.3.min.js"]
+
+jsLibsLocal :: [Text]
+jsLibsLocal = ["jquery-2.1.3.min.js"]
+
+css1 :: Css
+css1 = do
+ Clay.fontSize (Clay.px 10)
+ Clay.fontFamily ["Arial", "Helvetica"] [Clay.sansSerif]
+ "#btnGo" Clay.? do
+ Clay.marginTop (Clay.px 20)
+ Clay.marginBottom (Clay.px 20)
+ "#btnGo.on" Clay.? Clay.color Clay.green
+
+-- js
+click :: RepJs
+click =
+ RepJsText
+ [q|
+$('#btnGo').click( function() {
+ $('#btnGo').toggleClass('on');
+ alert('bada bing!');
+});
+|]
+
+button1 :: Html ()
+button1 =
+ with
+ button_
+ [id_ "btnGo", Lucid.type_ "button"]
+ ("Go " <> with i_ [class__ "fa fa-play"] mempty)
+
+-- | One of each sharedrep input instances.
+data RepExamples
+ = RepExamples
+ { repTextbox :: Text,
+ repTextarea :: Text,
+ repSliderI :: Int,
+ repSlider :: Double,
+ repCheckbox :: Bool,
+ repToggle :: Bool,
+ repDropdown :: Int,
+ repDropdownMultiple :: [Int],
+ repShape :: Shape,
+ repColor :: Text
+ }
+ deriving (Show, Eq, Generic)
+
+-- | For a typed dropdown example.
+data Shape = SquareShape | CircleShape deriving (Eq, Show, Generic)
+
+-- | shape parser
+toShape :: Text -> Shape
+toShape t = case t of
+ "Circle" -> CircleShape
+ "Square" -> SquareShape
+ _ -> CircleShape
+
+-- | shape printer
+fromShape :: Shape -> Text
+fromShape CircleShape = "Circle"
+fromShape SquareShape = "Square"
+
+-- | one of each input SharedReps
+repExamples :: (Monad m) => SharedRep m RepExamples
+repExamples = do
+ t <- textbox (Just "textbox") "sometext"
+ ta <- textarea 3 (Just "textarea") "no initial value & multi-line text\\nrenders is not ok?/"
+ n <- sliderI (Just "int slider") 0 5 1 3
+ ds' <- slider (Just "double slider") 0 1 0.1 0.5
+ c <- checkbox (Just "checkbox") True
+ tog <- toggle (Just "toggle") False
+ dr <- dropdown decimal (pack . show) (Just "dropdown") (pack . show <$> [1 .. 5 :: Int]) 3
+ drm <- dropdownMultiple decimal (pack . show) (Just "dropdown multiple") (pack . show <$> [1 .. 5 :: Int]) [2, 4]
+ drt <- toShape <$> dropdown takeText id (Just "shape") ["Circle", "Square"] (fromShape SquareShape)
+ col <- colorPicker (Just "color") "#454e56"
+ pure (RepExamples t ta n ds' c tog dr drm drt col)
+
+listExample :: (Monad m) => Int -> SharedRep m [Int]
+listExample n =
+ accordionList
+ (Just "accordianListify")
+ "al"
+ Nothing
+ (\l a -> sliderI (Just l) (0 :: Int) n 1 a)
+ ((\x -> "[" <> (pack . show) x <> "]") <$> [0 .. n] :: [Text])
+ [0 .. n]
+
+listRepExample :: (Monad m) => Int -> SharedRep m [Int]
+listRepExample n =
+ listRep
+ (Just "listifyMaybe")
+ "alm"
+ (checkbox Nothing)
+ (sliderI Nothing (0 :: Int) n 1)
+ n
+ 3
+ [0 .. 4]
+
+fiddleExample :: Concerns Text
+fiddleExample =
+ Concerns
+ mempty
+ mempty
+ [q|
+
+|]
+
+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
diff --git a/src/Web/Rep/Html.hs b/src/Web/Rep/Html.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Rep/Html.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE IncoherentInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+-- | Key generators and miscellaneous html utilities.
+--
+-- Uses the lucid 'Lucid.Html'.
+module Web.Rep.Html
+ ( class__,
+ toText,
+ libCss,
+ libJs,
+ HtmlT,
+ Html,
+ )
+where
+
+import Data.List (intersperse)
+import qualified Data.Text.Lazy as Lazy
+import Lucid
+import NumHask.Prelude
+
+-- | FIXME: A horrible hack to separate class id's
+class__ :: Text -> Attribute
+class__ t = class_ (" " <> t <> " ")
+
+-- | Convert html to text
+toText :: Html a -> Text
+toText = Lazy.toStrict . renderText
+
+-- | Convert a link to a css library from text to html.
+--
+-- >>> libCss "https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/css/bootstrap.min.css"
+--
+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"
+--
+libJs :: Text -> Html ()
+libJs url = with (script_ mempty) [src_ url]
+
+-- | FIXME: `ToHtml a` is used throughout, mostly because `Show a` gives "\"text\"" for show "text", and hilarity ensues when rendering this to a web page, and I couldn't work out how to properly get around this.
+--
+-- Hence, these orphans.
+instance ToHtml Double where
+ toHtml = toHtml . (pack . show)
+
+ toHtmlRaw = toHtmlRaw . (pack . show)
+
+instance ToHtml Bool where
+ toHtml = toHtml . bool ("false" :: Text) "true"
+
+ toHtmlRaw = toHtmlRaw . bool ("false" :: Text) "true"
+
+instance ToHtml Int where
+ toHtml = toHtml . (pack . show)
+
+ toHtmlRaw = toHtmlRaw . (pack . show)
+
+instance ToHtml () where
+ toHtml = const "()"
+
+ toHtmlRaw = const "()"
+
+-- I'm going to hell for sure.
+instance {-# INCOHERENT #-} (ToHtml a) => ToHtml [a] where
+ toHtml = mconcat . Data.List.intersperse (toHtml ("," :: Text)) . fmap toHtml
+
+ toHtmlRaw = mconcat . Data.List.intersperse (toHtmlRaw ("," :: Text)) . fmap toHtmlRaw
diff --git a/src/Web/Rep/Html/Input.hs b/src/Web/Rep/Html/Input.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Rep/Html/Input.hs
@@ -0,0 +1,273 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_GHC -Wall #-}
+
+-- | Common web page input elements, often with bootstrap scaffolding.
+module Web.Rep.Html.Input
+ ( Input (..),
+ InputType (..),
+ )
+where
+
+import Data.Text (split)
+import Lucid
+import Lucid.Base
+import NumHask.Prelude hiding (for_)
+import Web.Rep.Html
+
+-- | something that might exist on a web page and be a front-end input to computations.
+data Input a
+ = Input
+ { -- | underlying value
+ inputVal :: a,
+ -- | label suggestion
+ inputLabel :: Maybe Text,
+ -- | name//key//id of the Input
+ inputId :: Text,
+ -- | type of html input
+ inputType :: InputType
+ }
+ deriving (Eq, Show, Generic)
+
+-- | Various types of web page inputs, encapsulating practical bootstrap class functionality
+data InputType
+ = Slider [Attribute]
+ | TextBox
+ | TextBox'
+ | TextArea Int
+ | ColorPicker
+ | ChooseFile
+ | Dropdown [Text]
+ | DropdownMultiple [Text] Char
+ | DropdownSum [Text]
+ | Datalist [Text] Text
+ | Checkbox Bool
+ | Toggle Bool (Maybe Text)
+ | Button
+ deriving (Eq, Show, Generic)
+
+instance (ToHtml a) => ToHtml (Input a) where
+ toHtml (Input v l i (Slider satts)) =
+ with
+ div_
+ [class__ "form-group-sm"]
+ ( maybe mempty (with label_ [for_ i, class__ "mb-0"] . toHtml) l
+ <> input_
+ ( [ type_ "range",
+ class__ " form-control-range form-control-sm custom-range jsbClassEventChange",
+ id_ i,
+ value_ (pack $ show $ toHtml v)
+ ]
+ <> satts
+ )
+ )
+ toHtml (Input v l i TextBox) =
+ with
+ div_
+ [class__ "form-group-sm"]
+ ( maybe mempty (with label_ [for_ i, class__ "mb-0"] . toHtml) l
+ <> input_
+ [ type_ "text",
+ class__ "form-control form-control-sm jsbClassEventInput",
+ id_ i,
+ value_ (pack $ show $ toHtmlRaw v)
+ ]
+ )
+ toHtml (Input v l i TextBox') =
+ with
+ div_
+ [class__ "form-group-sm"]
+ ( maybe mempty (with label_ [for_ i, class__ "mb-0"] . toHtml) l
+ <> input_
+ [ type_ "text",
+ class__ "form-control form-control-sm jsbClassEventFocusout",
+ id_ i,
+ value_ (pack $ show $ toHtmlRaw v)
+ ]
+ )
+ toHtml (Input v l i (TextArea rows)) =
+ with
+ div_
+ [class__ "form-group-sm"]
+ ( maybe mempty (with label_ [for_ i, class__ "mb-0"] . toHtml) l
+ <> with
+ textarea_
+ [ rows_ (pack $ show rows),
+ class__ "form-control form-control-sm jsbClassEventInput",
+ id_ i
+ ]
+ (toHtmlRaw v)
+ )
+ toHtml (Input v l i ColorPicker) =
+ with
+ div_
+ [class__ "form-group-sm"]
+ ( maybe mempty (with label_ [for_ i, class__ "mb-0"] . toHtml) l
+ <> input_
+ [ type_ "color",
+ class__ "form-control form-control-sm jsbClassEventInput",
+ id_ i,
+ value_ (pack $ show $ toHtml v)
+ ]
+ )
+ toHtml (Input _ l i ChooseFile) =
+ with
+ div_
+ [class__ "form-group-sm"]
+ (maybe mempty (with label_ [for_ i, class__ "mb-0"] . toHtml) l)
+ <> input_
+ [ type_ "file",
+ class__ "form-control-file form-control-sm jsbClassEventChooseFile",
+ id_ i
+ ]
+ toHtml (Input v l i (Dropdown opts)) =
+ with
+ div_
+ [class__ "form-group-sm"]
+ ( maybe mempty (with label_ [for_ i, class__ "mb-0"] . toHtml) l
+ <> with
+ select_
+ [ class__ "form-control form-control-sm jsbClassEventInput",
+ id_ i
+ ]
+ opts'
+ )
+ where
+ opts' =
+ mconcat $
+ ( \o ->
+ with
+ option_
+ ( bool
+ []
+ [selected_ "selected"]
+ (toText (toHtml o) == toText (toHtml v))
+ )
+ (toHtml o)
+ )
+ <$> opts
+ toHtml (Input vs l i (DropdownMultiple opts sep)) =
+ with
+ div_
+ [class__ "form-group-sm"]
+ ( maybe mempty (with label_ [for_ i, class__ "mb-0"] . toHtml) l
+ <> with
+ select_
+ [ class__ "form-control form-control-sm jsbClassEventChangeMultiple",
+ multiple_ "multiple",
+ id_ i
+ ]
+ opts'
+ )
+ where
+ opts' =
+ mconcat $
+ ( \o ->
+ with
+ option_
+ ( bool
+ []
+ [selected_ "selected"]
+ (any (\v -> toText (toHtml o) == toText (toHtml v)) (split (== sep) (toText (toHtml vs))))
+ )
+ (toHtml o)
+ )
+ <$> opts
+ toHtml (Input v l i (DropdownSum opts)) =
+ with
+ div_
+ [class__ "form-group-sm sumtype-group"]
+ ( maybe mempty (with label_ [for_ i, class__ "mb-0"] . toHtml) l
+ <> with
+ select_
+ [ class__ "form-control form-control-sm jsbClassEventInput jsbClassEventShowSum",
+ id_ i
+ ]
+ opts'
+ )
+ where
+ opts' =
+ mconcat $
+ ( \o ->
+ with
+ option_
+ (bool [] [selected_ "selected"] (toText (toHtml o) == toText (toHtml v)))
+ (toHtml o)
+ )
+ <$> opts
+ toHtml (Input v l i (Datalist opts listId)) =
+ with
+ div_
+ [class__ "form-group-sm"]
+ ( maybe mempty (with label_ [for_ i, class__ "mb-0"] . toHtml) l
+ <> input_
+ [ type_ "text",
+ class__ "form-control form-control-sm jsbClassEventInput",
+ id_ i,
+ list_ listId
+ -- the datalist concept in html assumes initial state is a null
+ -- and doesn't present the list if it has a value alreadyx
+ -- , value_ (show $ toHtml v)
+ ]
+ <> with
+ datalist_
+ [id_ listId]
+ ( mconcat $
+ ( \o ->
+ with
+ option_
+ ( bool
+ []
+ [selected_ "selected"]
+ (toText (toHtml o) == toText (toHtml v))
+ )
+ (toHtml o)
+ )
+ <$> opts
+ )
+ )
+ -- FIXME: How can you refactor to eliminate this polymorphic wart?
+ toHtml (Input _ l i (Checkbox checked)) =
+ with
+ div_
+ [class__ "form-check form-check-sm"]
+ ( input_
+ ( [ type_ "checkbox",
+ class__ "form-check-input jsbClassEventCheckbox",
+ id_ i
+ ]
+ <> bool [] [checked_] checked
+ )
+ <> maybe mempty (with label_ [for_ i, class__ "form-check-label mb-0"] . toHtml) l
+ )
+ toHtml (Input _ l i (Toggle pushed lab)) =
+ with
+ div_
+ [class__ "form-group-sm"]
+ ( maybe mempty (with label_ [for_ i, class__ "mb-0"] . toHtml) l
+ <> input_
+ ( [ type_ "button",
+ class__ "btn btn-primary btn-sm jsbClassEventToggle",
+ data_ "toggle" "button",
+ id_ i,
+ makeAttribute "aria-pressed" (bool "false" "true" pushed)
+ ]
+ <> maybe [] (\l' -> [value_ l']) lab
+ <> bool [] [checked_] pushed
+ )
+ )
+ toHtml (Input _ l i Button) =
+ with
+ div_
+ [class__ "form-group-sm"]
+ ( input_
+ [ type_ "button",
+ id_ i,
+ class__ "btn btn-primary btn-sm jsbClassEventButton",
+ value_ (fromMaybe "button" l)
+ ]
+ )
+
+ toHtmlRaw = toHtml
diff --git a/src/Web/Rep/Mathjax.hs b/src/Web/Rep/Mathjax.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Rep/Mathjax.hs
@@ -0,0 +1,156 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_GHC -Wall #-}
+
+-- | mathjax functionality.
+--
+-- some assets
+--
+--
+--
+-- FIXME: Mathjax inside svg doesn't quite work, and needs to be structured around the foreign object construct.
+module Web.Rep.Mathjax
+ ( mathjaxPage,
+ mathjax27Page,
+ mathjaxSvgPage,
+ mathjax27SvgPage,
+ )
+where
+
+import Control.Lens
+import Lucid
+import NumHask.Prelude
+import Text.InterpolatedString.Perl6
+import Web.Rep.Page
+
+mathjax3Lib :: Html ()
+mathjax3Lib =
+ with
+ (script_ mempty)
+ [ src_ "https://cdn.jsdelivr.net/npm/mathjax@3/es5/tex-mml-svg.js",
+ id_ "MathJax-script",
+ async_ ""
+ ]
+
+mathjax27Lib :: Html ()
+mathjax27Lib =
+ with
+ (script_ mempty)
+ [ src_ "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-MML-AM_SVG"
+ ]
+
+jqueryLib :: Html ()
+jqueryLib =
+ with
+ (script_ mempty)
+ [ src_ "https://code.jquery.com/jquery-3.3.1.slim.min.js",
+ integrity_ "sha384-q8i/X+965DzO0rT7abK41JStQIAqVgRVzpbzo5smXKp4YfRvH+8abtTE1Pi6jizo",
+ crossorigin_ "anonymous"
+ ]
+
+-- | A 'Page' that loads mathjax
+mathjaxPage :: Page
+mathjaxPage =
+ mempty
+ & #jsGlobal .~ RepJsText scriptMathjaxConfig
+ & #libsJs
+ .~ [ mathjax3Lib
+ ]
+
+-- | A 'Page' that loads the mathjax 2.7 js library
+mathjax27Page :: Page
+mathjax27Page =
+ mempty
+ & #jsOnLoad .~ RepJsText scriptMathjaxConfig
+ & #libsJs
+ .~ [ mathjax27Lib
+ ]
+
+-- | A 'Page' that tries to enable mathjax inside svg (which is tricky).
+mathjaxSvgPage :: Text -> Page
+mathjaxSvgPage cl =
+ mempty
+ & #jsGlobal .~ RepJsText (scriptMathjaxConfigSvg cl)
+ & #libsJs
+ .~ [ mathjax3Lib,
+ jqueryLib
+ ]
+
+-- | A 'Page' that tries to enable mathjax 2.7 inside svg.
+mathjax27SvgPage :: Text -> Page
+mathjax27SvgPage cl =
+ mempty
+ & #jsGlobal .~ RepJsText (scriptMathjax27ConfigSvg cl)
+ & #libsJs
+ .~ [ mathjax27Lib,
+ jqueryLib
+ ]
+
+scriptMathjaxConfig :: Text
+scriptMathjaxConfig =
+ [q|
+MathJax = {
+ tex: {
+ inlineMath: [ ['$','$'], ["\\(","\\)"] ]
+ }
+};
+|]
+
+-- | Mathjax applies within an svg element as normal, but results in an svg element inside a text element which is not allowed, hence the extra scripting.
+-- http://bl.ocks.org/larsenmtl/86077bddc91c3de8d3db6a53216b2f47
+scriptMathjax27ConfigSvg :: Text -> Text
+scriptMathjax27ConfigSvg cl =
+ [qq|
+ setTimeout(() => \{
+
+ MathJax.Hub.Config(\{
+ tex2jax: \{
+ inlineMath: [ ['$','$'], ["\\(","\\)"] ],
+ processEscapes: true
+ }
+ });
+
+ MathJax.Hub.Register.StartupHook("End", function() \{
+ setTimeout(() => \{
+ $('.{cl}').each(function()\{
+ var m = $('text>span>svg');
+ m.remove();
+ $(this).append(m);
+ });
+
+ }, 1);
+ });
+ }, 1);
+|]
+
+-- | Mathjax applies within an svg element as normal, but results in an svg element inside a text element which is not allowed, hence the extra scripting.
+-- http://bl.ocks.org/larsenmtl/86077bddc91c3de8d3db6a53216b2f47
+scriptMathjaxConfigSvg :: Text -> Text
+scriptMathjaxConfigSvg cl =
+ [qq|
+ window.MathJax = \{
+ tex: \{
+ inlineMath: [ ['$','$'], ["\\(","\\)"] ]
+ },
+ startup: \{
+ ready: () => \{
+ MathJax.startup.defaultReady();
+ MathJax.startup.promise.then(() => \{
+ var xs = document.querySelectorAll('.{cl}');
+ xs.forEach((x) =>
+ \{ x.querySelectorAll('text').forEach((t) =>
+ \{t.querySelectorAll('mjx-container>svg').forEach((s) =>
+ \{
+ Array.from(t.attributes).forEach((a) => s.setAttribute(a.name, a.value));
+ x.appendChild(s);
+ });
+ });
+ });
+ });
+ }
+ }
+ };
+|]
diff --git a/src/Web/Rep/Page.hs b/src/Web/Rep/Page.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Rep/Page.hs
@@ -0,0 +1,278 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TupleSections #-}
+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
+{-# OPTIONS_HADDOCK hide, not-home #-}
+
+module Web.Rep.Page
+ ( -- $page
+ Page (..),
+ PageConfig (..),
+ defaultPageConfig,
+ Concerns (..),
+ suffixes,
+ concernNames,
+ PageConcerns (..),
+ PageStructure (..),
+ PageRender (..),
+
+ -- $css
+ Css,
+ RepCss (..),
+ renderCss,
+ renderRepCss,
+
+ -- $js
+ JS (..),
+ RepJs (..),
+ onLoad,
+ renderRepJs,
+ parseJs,
+ renderJs,
+ )
+where
+
+import qualified Clay
+import Clay (Css)
+import Control.Lens
+import Data.Generics.Labels ()
+import GHC.Show (show)
+import Language.JavaScript.Parser
+import Language.JavaScript.Parser.AST
+import Language.JavaScript.Process.Minify
+import Lucid
+import NumHask.Prelude hiding (show)
+import Text.InterpolatedString.Perl6
+
+-- | Components of a web page.
+--
+-- A web page can take many forms but still have the same underlying representation. For example, CSS can be linked to in a separate file, or can be inline within html, but still be the same css and have the same expected external effect. A Page represents the practical components of what makes up a static snapshot of a web page.
+data Page
+ = Page
+ { -- | css library links
+ libsCss :: [Html ()],
+ -- | javascript library links
+ libsJs :: [Html ()],
+ -- | css
+ cssBody :: RepCss,
+ -- | javascript with global scope
+ jsGlobal :: RepJs,
+ -- | javascript included within the onLoad function
+ jsOnLoad :: RepJs,
+ -- | html within the header
+ htmlHeader :: Html (),
+ -- | body html
+ htmlBody :: Html ()
+ }
+ deriving (Show, Generic)
+
+instance Semigroup Page where
+ (<>) p0 p1 =
+ Page
+ (p0 ^. #libsCss <> p1 ^. #libsCss)
+ (p0 ^. #libsJs <> p1 ^. #libsJs)
+ (p0 ^. #cssBody <> p1 ^. #cssBody)
+ (p0 ^. #jsGlobal <> p1 ^. #jsGlobal)
+ (p0 ^. #jsOnLoad <> p1 ^. #jsOnLoad)
+ (p0 ^. #htmlHeader <> p1 ^. #htmlHeader)
+ (p0 ^. #htmlBody <> p1 ^. #htmlBody)
+
+instance Monoid Page where
+ mempty = Page [] [] mempty mempty mempty mempty mempty
+
+ mappend = (<>)
+
+-- | A web page typically is composed of some css, javascript and html.
+--
+-- 'Concerns' abstracts this structural feature of a web page.
+data Concerns a
+ = Concerns
+ { cssConcern :: a,
+ jsConcern :: a,
+ htmlConcern :: a
+ }
+ deriving (Eq, Show, Foldable, Traversable, Generic)
+
+instance Functor Concerns where
+ fmap f (Concerns c j h) = Concerns (f c) (f j) (f h)
+
+instance Applicative Concerns where
+ pure a = Concerns a a a
+
+ Concerns f g h <*> Concerns a b c = Concerns (f a) (g b) (h c)
+
+-- | The common file suffixes of the three concerns.
+suffixes :: Concerns FilePath
+suffixes = Concerns ".css" ".js" ".html"
+
+-- | Create filenames for each Concern element.
+concernNames :: FilePath -> FilePath -> Concerns FilePath
+concernNames dir stem =
+ (\x -> dir <> stem <> x) <$> suffixes
+
+-- | Is the rendering to include all 'Concerns' (typically in a html file) or be separated (tyypically into separate files and linked in the html file)?
+data PageConcerns
+ = Inline
+ | Separated
+ deriving (Show, Eq, Generic)
+
+-- | Various ways that a Html file can be structured.
+data PageStructure
+ = HeaderBody
+ | Headless
+ | Snippet
+ | Svg
+ deriving (Show, Eq, Generic)
+
+-- | Post-processing of page concerns
+data PageRender
+ = Pretty
+ | Minified
+ | NoPost
+ deriving (Show, Eq, Generic)
+
+-- | Configuration options when rendering a 'Page'.
+data PageConfig
+ = PageConfig
+ { concerns :: PageConcerns,
+ structure :: PageStructure,
+ pageRender :: PageRender,
+ filenames :: Concerns FilePath,
+ localdirs :: [FilePath]
+ }
+ deriving (Show, Eq, Generic)
+
+-- | Default configuration is inline ecma and css, separate html header and body, minified code, with the suggested filename prefix.
+defaultPageConfig :: FilePath -> PageConfig
+defaultPageConfig stem =
+ PageConfig
+ Inline
+ HeaderBody
+ Minified
+ ((stem <>) <$> suffixes)
+ []
+
+-- | Unifies css as either a 'Clay.Css' or as Text.
+data RepCss = RepCss Clay.Css | RepCssText Text deriving (Generic)
+
+instance Show RepCss where
+ show (RepCss css) = unpack . renderCss $ css
+ show (RepCssText txt) = unpack txt
+
+instance Semigroup RepCss where
+ (<>) (RepCss css) (RepCss css') = RepCss (css <> css')
+ (<>) (RepCssText css) (RepCssText css') = RepCssText (css <> css')
+ (<>) (RepCss css) (RepCssText css') =
+ RepCssText (renderCss css <> css')
+ (<>) (RepCssText css) (RepCss css') =
+ RepCssText (css <> renderCss css')
+
+instance Monoid RepCss where
+ mempty = RepCssText mempty
+
+ mappend = (<>)
+
+-- | Render 'RepCss' as text.
+renderRepCss :: PageRender -> RepCss -> Text
+renderRepCss Minified (RepCss css) = toStrict $ Clay.renderWith Clay.compact [] css
+renderRepCss _ (RepCss css) = toStrict $ Clay.render css
+renderRepCss _ (RepCssText css) = css
+
+-- | Render 'Css' as text.
+renderCss :: Css -> Text
+renderCss = toStrict . Clay.render
+
+
+-- | wrapper for `JSAST`
+newtype JS = JS {unJS :: JSAST} deriving (Show, Eq, Generic)
+
+instance Semigroup JS where
+ (<>) (JS (JSAstProgram ss ann)) (JS (JSAstProgram ss' _)) =
+ JS $ JSAstProgram (ss <> ss') ann
+ (<>) (JS (JSAstProgram ss ann)) (JS (JSAstStatement s _)) =
+ JS $ JSAstProgram (ss <> [s]) ann
+ (<>) (JS (JSAstProgram ss ann)) (JS (JSAstExpression e ann')) =
+ JS $ JSAstProgram (ss <> [JSExpressionStatement e (JSSemi ann')]) ann
+ (<>) (JS (JSAstProgram ss ann)) (JS (JSAstLiteral e ann')) =
+ JS $ JSAstProgram (ss <> [JSExpressionStatement e (JSSemi ann')]) ann
+ (<>) (JS (JSAstStatement s ann)) (JS (JSAstProgram ss _)) =
+ JS $ JSAstProgram (s : ss) ann
+ (<>) (JS (JSAstStatement s ann)) (JS (JSAstStatement s' _)) =
+ JS $ JSAstProgram [s, s'] ann
+ (<>) (JS (JSAstStatement s ann)) (JS (JSAstExpression e ann')) =
+ JS $ JSAstProgram [s, JSExpressionStatement e (JSSemi ann')] ann
+ (<>) (JS (JSAstStatement s ann)) (JS (JSAstLiteral e ann')) =
+ JS $ JSAstProgram [s, JSExpressionStatement e (JSSemi ann')] ann
+ (<>) (JS (JSAstExpression e ann)) (JS (JSAstProgram ss _)) =
+ JS $ JSAstProgram (JSExpressionStatement e (JSSemi ann) : ss) ann
+ (<>) (JS (JSAstExpression e ann)) (JS (JSAstStatement s' _)) =
+ JS $ JSAstProgram [JSExpressionStatement e (JSSemi ann), s'] ann
+ (<>) (JS (JSAstExpression e ann)) (JS (JSAstExpression e' ann')) =
+ JS $ JSAstProgram [JSExpressionStatement e (JSSemi ann), JSExpressionStatement e' (JSSemi ann')] ann
+ (<>) (JS (JSAstExpression e ann)) (JS (JSAstLiteral e' ann')) =
+ JS $ JSAstProgram [JSExpressionStatement e (JSSemi ann), JSExpressionStatement e' (JSSemi ann')] ann
+ (<>) (JS (JSAstLiteral e ann)) (JS (JSAstProgram ss _)) =
+ JS $ JSAstProgram (JSExpressionStatement e (JSSemi ann) : ss) ann
+ (<>) (JS (JSAstLiteral e ann)) (JS (JSAstStatement s' _)) =
+ JS $ JSAstProgram [JSExpressionStatement e (JSSemi ann), s'] ann
+ (<>) (JS (JSAstLiteral e ann)) (JS (JSAstExpression e' ann')) =
+ JS $ JSAstProgram [JSExpressionStatement e (JSSemi ann), JSExpressionStatement e' (JSSemi ann')] ann
+ (<>) (JS (JSAstLiteral e ann)) (JS (JSAstLiteral e' ann')) =
+ JS $ JSAstProgram [JSExpressionStatement e (JSSemi ann), JSExpressionStatement e' (JSSemi ann')] ann
+
+instance Monoid JS where
+ mempty = JS $ JSAstProgram [] (JSAnnot (TokenPn 0 0 0) [])
+
+ mappend = (<>)
+
+-- | Unifies javascript as 'JSStatement' and script as 'Text'.
+data RepJs = RepJs JS | RepJsText Text deriving (Eq, Show, Generic)
+
+instance Semigroup RepJs where
+ (<>) (RepJs js) (RepJs js') = RepJs (js <> js')
+ (<>) (RepJsText js) (RepJsText js') = RepJsText (js <> js')
+ (<>) (RepJs js) (RepJsText js') =
+ RepJsText (toStrict (renderToText $ unJS js) <> js')
+ (<>) (RepJsText js) (RepJs js') =
+ RepJsText (js <> toStrict (renderToText $ unJS js'))
+
+instance Monoid RepJs where
+ mempty = RepJs mempty
+
+ mappend = (<>)
+
+-- | Wrap js in standard DOM window loader.
+onLoad :: RepJs -> RepJs
+onLoad (RepJs js) = RepJs $ onLoadStatements [toStatement js]
+onLoad (RepJsText js) = RepJsText $ onLoadText js
+
+toStatement :: JS -> JSStatement
+toStatement (JS (JSAstProgram ss ann)) = JSStatementBlock JSNoAnnot ss JSNoAnnot (JSSemi ann)
+toStatement (JS (JSAstStatement s _)) = s
+toStatement (JS (JSAstExpression e ann')) = JSExpressionStatement e (JSSemi ann')
+toStatement (JS (JSAstLiteral e ann')) = JSExpressionStatement e (JSSemi ann')
+
+onLoadStatements :: [JSStatement] -> JS
+onLoadStatements js = JS $ JSAstProgram [JSAssignStatement (JSMemberDot (JSIdentifier JSNoAnnot "window") JSNoAnnot (JSIdentifier JSNoAnnot "onload")) (JSAssign JSNoAnnot) (JSFunctionExpression JSNoAnnot JSIdentNone JSNoAnnot JSLNil JSNoAnnot (JSBlock JSNoAnnot js JSNoAnnot)) JSSemiAuto] JSNoAnnot
+
+onLoadText :: Text -> Text
+onLoadText t = [qc| window.onload=function()\{{t}};|]
+
+-- | Convert 'Text' to 'JS', throwing an error on incorrectness.
+parseJs :: Text -> JS
+parseJs = JS . readJs . unpack
+
+-- | Render 'JS' as 'Text'.
+renderJs :: JS -> Text
+renderJs = toStrict . renderToText . unJS
+
+-- | Render 'RepJs' as 'Text'.
+renderRepJs :: PageRender -> RepJs -> Text
+renderRepJs _ (RepJsText js) = js
+renderRepJs Minified (RepJs js) = toStrict . renderToText . minifyJS . unJS $ js
+renderRepJs Pretty (RepJs js) = toStrict . renderToText . unJS $ js
diff --git a/src/Web/Rep/Render.hs b/src/Web/Rep/Render.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Rep/Render.hs
@@ -0,0 +1,143 @@
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | Page rendering
+module Web.Rep.Render
+ ( renderPage,
+ renderPageWith,
+ renderPageHtmlWith,
+ renderPageAsText,
+ renderPageToFile,
+ renderPageHtmlToFile,
+ )
+where
+
+import Control.Lens
+import Lucid
+import NumHask.Prelude
+import Web.Rep.Html
+import Web.Rep.Page
+
+-- | Render a Page with the default configuration into Html.
+renderPage :: Page -> Html ()
+renderPage p =
+ (\(_, _, x) -> x) $ renderPageWith (defaultPageConfig "default") p
+
+-- | Render a Page into Html.
+renderPageHtmlWith :: PageConfig -> Page -> Html ()
+renderPageHtmlWith pc p =
+ (\(_, _, x) -> x) $ renderPageWith pc p
+
+-- | Render a Page into css text, js text and html.
+renderPageWith :: PageConfig -> Page -> (Text, Text, Html ())
+renderPageWith pc p =
+ case pc ^. #concerns of
+ Inline -> (mempty, mempty, h)
+ Separated -> (css, js, h)
+ where
+ h =
+ case pc ^. #structure of
+ HeaderBody ->
+ doctype_
+ <> with
+ html_
+ [lang_ "en"]
+ ( head_
+ ( mconcat
+ [ meta_ [charset_ "utf-8"],
+ cssInline,
+ mconcat libsCss',
+ p ^. #htmlHeader
+ ]
+ )
+ <> body_
+ ( mconcat
+ [ p ^. #htmlBody,
+ mconcat libsJs',
+ jsInline
+ ]
+ )
+ )
+ Headless ->
+ mconcat
+ [ doctype_,
+ meta_ [charset_ "utf-8"],
+ mconcat libsCss',
+ cssInline,
+ p ^. #htmlHeader,
+ p ^. #htmlBody,
+ mconcat libsJs',
+ jsInline
+ ]
+ Snippet ->
+ mconcat
+ [ mconcat libsCss',
+ cssInline,
+ p ^. #htmlHeader,
+ p ^. #htmlBody,
+ mconcat libsJs',
+ jsInline
+ ]
+ Svg ->
+ svgDocType
+ <> svg_
+ ( svgDefs $
+ mconcat
+ [ mconcat libsCss',
+ cssInline,
+ p ^. #htmlBody,
+ mconcat libsJs',
+ jsInline
+ ]
+ )
+ css = rendercss (p ^. #cssBody)
+ js = renderjs (p ^. #jsGlobal <> onLoad (p ^. #jsOnLoad))
+ renderjs = renderRepJs $ pc ^. #pageRender
+ rendercss = renderRepCss $ pc ^. #pageRender
+ cssInline
+ | pc ^. #concerns == Separated || css == mempty = mempty
+ | otherwise = style_ [type_ "text/css"] css
+ jsInline
+ | pc ^. #concerns == Separated || js == mempty = mempty
+ | otherwise = script_ mempty js
+ libsCss' =
+ case pc ^. #concerns of
+ Inline -> p ^. #libsCss
+ Separated ->
+ p ^. #libsCss
+ <> [libCss (pack $ pc ^. #filenames . #cssConcern)]
+ libsJs' =
+ case pc ^. #concerns of
+ Inline -> p ^. #libsJs
+ Separated ->
+ p ^. #libsJs
+ <> [libJs (pack $ pc ^. #filenames . #jsConcern)]
+
+-- | Render Page concerns to files.
+renderPageToFile :: FilePath -> PageConfig -> Page -> IO ()
+renderPageToFile dir pc page =
+ sequenceA_ $ liftA2 writeFile' (pc ^. #filenames) (renderPageAsText pc page)
+ where
+ writeFile' fp s = unless (s == mempty) (writeFile (dir <> "/" <> fp) s)
+
+-- | Render a page to just a Html file.
+renderPageHtmlToFile :: FilePath -> PageConfig -> Page -> IO ()
+renderPageHtmlToFile file pc page =
+ writeFile file (toText $ renderPageHtmlWith pc page)
+
+-- | Render a Page as Text.
+renderPageAsText :: PageConfig -> Page -> Concerns Text
+renderPageAsText pc p =
+ case pc ^. #concerns of
+ Inline -> Concerns mempty mempty htmlt
+ Separated -> Concerns css js htmlt
+ where
+ htmlt = toText h
+ (css, js, h) = renderPageWith pc p
+
+svgDocType :: Html ()
+svgDocType = "?xml version=\"1.0\" encoding=\"UTF-8\"?>\n Html ()
+svgDefs = term "defs"
diff --git a/src/Web/Rep/Server.hs b/src/Web/Rep/Server.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Rep/Server.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_GHC -Wall #-}
+
+-- | Serve pages via 'ScottyM'
+module Web.Rep.Server
+ ( servePageWith
+ )
+where
+
+import Control.Lens hiding (only)
+import Lucid
+import Network.Wai.Middleware.Static (addBase, noDots, only, staticPolicy)
+import NumHask.Prelude hiding (get, replace)
+import Web.Rep.Render
+import Web.Rep.Page
+import Web.Scotty
+
+-- | serve a Page via a ScottyM
+servePageWith :: RoutePattern -> PageConfig -> Page -> ScottyM ()
+servePageWith rp pc p =
+ sequence_ $ servedir <> [getpage]
+ where
+ getpage = case pc ^. #concerns of
+ Inline ->
+ get rp (html $ renderText $ renderPageHtmlWith pc p)
+ Separated ->
+ let (css, js, h) = renderPageWith pc p
+ in do
+ middleware $ staticPolicy $ only [(cssfp, cssfp), (jsfp, jsfp)]
+ get
+ rp
+ ( do
+ lift $ writeFile' cssfp css
+ lift $ writeFile' jsfp js
+ html $ renderText h
+ )
+ cssfp = pc ^. #filenames . #cssConcern
+ jsfp = pc ^. #filenames . #jsConcern
+ writeFile' fp s = unless (s == mempty) (writeFile fp s)
+ servedir = (\x -> middleware $ staticPolicy (noDots <> addBase x)) <$> pc ^. #localdirs
diff --git a/src/Web/Rep/Shared.hs b/src/Web/Rep/Shared.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Rep/Shared.hs
@@ -0,0 +1,210 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TupleSections #-}
+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
+{-# OPTIONS_HADDOCK hide, not-home #-}
+
+module Web.Rep.Shared
+ (
+ RepF (..),
+ Rep,
+ oneRep,
+ SharedRepF (..),
+ SharedRep,
+ runOnce,
+ zeroState,
+ register,
+ message,
+ genName,
+ genNamePre,
+ )
+where
+
+import Control.Lens
+import Data.Generics.Labels ()
+import qualified Data.HashMap.Strict as HashMap
+import Data.HashMap.Strict (HashMap)
+import GHC.Show (show)
+import Lucid
+import NumHask.Prelude hiding (show)
+
+-- |
+-- Information contained in a web page can usually be considered to be isomorphic to a map of named values - a 'HashMap'. This is especially true when considering a differential of information contained in a web page. Looking at a page from the outside, it often looks like a streaming differential of a hashmap.
+--
+-- RepF consists of an underlying value being represented, and, given a hashmap state, a way to produce a representation of the underlying value (or error), in another domain, together with the potential to alter the hashmap state.
+data RepF r a
+ = Rep
+ { rep :: r,
+ make :: HashMap Text Text -> (HashMap Text Text, Either Text a)
+ }
+ deriving (Functor)
+
+-- | the common usage, where the representation domain is Html
+type Rep a = RepF (Html ()) a
+
+instance (Semigroup r) => Semigroup (RepF r a) where
+ (Rep r0 a0) <> (Rep r1 a1) =
+ Rep
+ (r0 <> r1)
+ (\hm -> let (hm', x') = a0 hm in let (hm'', x'') = a1 hm' in (hm'', x' <> x''))
+
+instance (Monoid a, Monoid r) => Monoid (RepF r a) where
+ mempty = Rep mempty (,Right mempty)
+
+ mappend = (<>)
+
+instance Bifunctor RepF where
+ bimap f g (Rep r a) = Rep (f r) (second (fmap g) . a)
+
+instance Biapplicative RepF where
+ bipure r a = Rep r (,Right a)
+
+ (Rep fr fa) <<*>> (Rep r a) =
+ Rep
+ (fr r)
+ ( \hm ->
+ let (hm', a') = a hm in let (hm'', fa') = fa hm' in (hm'', fa' <*> a')
+ )
+
+instance (Monoid r) => Applicative (RepF r) where
+ pure = bipure mempty
+
+ Rep fh fm <*> Rep ah am =
+ Rep
+ (fh <> ah)
+ ( \hm ->
+ let (hm', a') = am hm in let (hm'', fa') = fm hm' in (hm'', fa' <*> a')
+ )
+
+-- | stateful result of one step, given a 'Rep', and a monadic action.
+-- Useful for testing and for initialising a page.
+oneRep :: (Monad m, MonadIO m) => Rep a -> (Rep a -> HashMap Text Text -> m ()) -> StateT (HashMap Text Text) m (HashMap Text Text, Either Text a)
+oneRep r@(Rep _ fa) action = do
+ m <- get
+ let (m', a) = fa m
+ put m'
+ lift $ action r m'
+ pure (m', a)
+
+-- |
+-- Driven by the architecture of the DOM, web page components are compositional, and tree-like, where components are often composed of other components, and values are thus shared across components.
+--
+-- This is sometimes referred to as "observable sharing". See as another library that reifies this (pun intended), and provided the initial inspiration for this implementation.
+--
+-- unshare should only be run once, which is a terrible flaw that might be fixed by linear types.
+--
+newtype SharedRepF m r a
+ = SharedRep
+ { unshare :: StateT (Int, HashMap Text Text) m (RepF r a)
+ }
+ deriving (Functor)
+
+-- | default representation type of 'Html' ()
+type SharedRep m a = SharedRepF m (Html ()) a
+
+instance (Functor m) => Bifunctor (SharedRepF m) where
+ bimap f g (SharedRep s) = SharedRep $ fmap (bimap f g) s
+
+instance (Monad m) => Biapplicative (SharedRepF m) where
+ bipure r a = SharedRep $ pure $ bipure r a
+
+ (SharedRep f) <<*>> (SharedRep a) = SharedRep $ liftA2 (<<*>>) f a
+
+instance (Monad m, Monoid r) => Applicative (SharedRepF m r) where
+ pure = bipure mempty
+
+ SharedRep f <*> SharedRep a = SharedRep $ liftA2 (<*>) f a
+
+-- | name supply for elements of a 'SharedRep'
+genName :: (MonadState Int m) => m Text
+genName = do
+ modify (+ 1)
+ pack . show <$> get
+
+-- | sometimes a number doesn't work properly in html (or js???), and an alpha prefix seems to help
+genNamePre :: (MonadState Int m) => Text -> m Text
+genNamePre p = (p <>) <$> genName
+
+-- | Create a sharedRep
+register ::
+ (Monad m) =>
+ -- | Parser
+ (Text -> Either Text a) ->
+ -- | Printer
+ (a -> Text) ->
+ -- | create initial object from name and initial value
+ (Text -> a -> r) ->
+ -- | initial value
+ a ->
+ SharedRepF m r a
+register p pr f a =
+ SharedRep $ do
+ name <- zoom _1 genName
+ zoom _2 (modify (HashMap.insert name (pr a)))
+ pure $
+ Rep
+ (f name a)
+ ( \s ->
+ ( s,
+ join
+ $ maybe (Left "lookup failed") Right
+ $ either (Left . (\x -> name <> ": " <> x)) Right . p <$>
+ HashMap.lookup name s
+ )
+ )
+
+-- | Like 'register', but does not put a value into the HashMap on instantiation, consumes the value when found in the HashMap, and substitutes a default on lookup failure
+message ::
+ (Monad m) =>
+ -- | Parser
+ (Text -> Either Text a) ->
+ -- | create initial object from name and initial value
+ (Text -> a -> r) ->
+ -- | initial value
+ a ->
+ -- | default value
+ a ->
+ SharedRepF m r a
+message p f a d =
+ SharedRep $ do
+ name <- zoom _1 genName
+ pure $
+ Rep
+ (f name a)
+ ( \s ->
+ ( HashMap.delete name s,
+ join
+ $ maybe (Right $ Right d) Right
+ $ p <$>
+ HashMap.lookup name s
+ )
+ )
+
+runSharedRep :: SharedRepF m r a -> m (RepF r a, (Int, HashMap Text Text))
+runSharedRep s = flip runStateT (0, HashMap.empty) $ unshare s
+
+-- | compute the initial state of a SharedRep (testing)
+zeroState ::
+ (Monad m) =>
+ SharedRep m a ->
+ m (Html (), (HashMap Text Text, Either Text a))
+zeroState sr = do
+ (Rep h fa, (_, m)) <- runSharedRep sr
+ pure (h, fa m)
+
+-- | Compute the initial state of a SharedRep and then run an action once (see tests).
+runOnce ::
+ (Monad m) =>
+ SharedRep m a ->
+ (Html () -> HashMap Text Text -> m ()) ->
+ m (HashMap Text Text, Either Text a)
+runOnce sr action = do
+ (Rep h fa, (_, m)) <- runSharedRep sr
+ action h m
+ pure (fa m)
+
diff --git a/src/Web/Rep/SharedReps.hs b/src/Web/Rep/SharedReps.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Rep/SharedReps.hs
@@ -0,0 +1,474 @@
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE IncoherentInstances #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_GHC -Wall #-}
+{-# OPTIONS_GHC -Wredundant-constraints #-}
+
+-- | Various SharedRep instances for common html input elements.
+module Web.Rep.SharedReps
+ ( repInput,
+ repMessage,
+ sliderI,
+ slider,
+ dropdown,
+ dropdownMultiple,
+ datalist,
+ dropdownSum,
+ colorPicker,
+ textbox,
+ textarea,
+ checkbox,
+ toggle,
+ button,
+ chooseFile,
+ maybeRep,
+ fiddle,
+ viaFiddle,
+ accordionList,
+ listMaybeRep,
+ listRep,
+ readTextbox,
+ defaultListLabels,
+ repChoice,
+ subtype,
+ selectItems,
+ repItemsSelect,
+ )
+where
+
+import Box.Cont ()
+import Control.Lens
+import Data.Attoparsec.Text hiding (take)
+import qualified Data.HashMap.Strict as HashMap
+import qualified Data.List as List
+import Data.Text (intercalate)
+import Lucid
+import NumHask.Prelude hiding (intercalate, takeWhile)
+import Text.InterpolatedString.Perl6
+import Web.Rep.Bootstrap
+import Web.Rep.Html
+import Web.Rep.Html.Input
+import Web.Rep.Shared
+import Web.Rep.Page
+import qualified Prelude as P
+import qualified Data.Attoparsec.Text as A
+
+-- $setup
+-- >>> :set -XOverloadedStrings
+
+-- | Create a sharedRep from an Input.
+repInput ::
+ (Monad m, ToHtml a) =>
+ -- | Parser
+ Parser a ->
+ -- | Printer
+ (a -> Text) ->
+ -- | 'Input' type
+ Input a ->
+ -- | initial value
+ a ->
+ SharedRep m a
+repInput p pr i a =
+ register (first pack . A.parseOnly p) pr (\n v -> toHtml $ #inputVal .~ v $ #inputId .~ n $ i) a
+
+-- | Like 'repInput', but does not put a value into the HashMap on instantiation, consumes the value when found in the HashMap, and substitutes a default on lookup failure
+repMessage :: (Monad m, ToHtml a) => Parser a -> (a -> Text) -> Input a -> a -> a -> SharedRep m a
+repMessage p _ i def a =
+ message (first pack . A.parseOnly p) (\n v -> toHtml $ #inputVal .~ v $ #inputId .~ n $ i) a def
+
+-- | double slider
+--
+-- For Example, a slider between 0 and 1 with a step of 0.01 and a default value of 0.3 is:
+--
+-- >>> :t slider (Just "label") 0 1 0.01 0.3
+-- slider (Just "label") 0 1 0.01 0.3 :: Monad m => SharedRep m Double
+slider ::
+ (Monad m) =>
+ Maybe Text ->
+ Double ->
+ Double ->
+ Double ->
+ Double ->
+ SharedRep m Double
+slider label l u s v =
+ repInput
+ double
+ (pack . show)
+ (Input v label mempty (Slider [min_ (pack $ show l), max_ (pack $ show u), step_ (pack $ show s)]))
+ v
+
+-- | integral slider
+--
+-- For Example, a slider between 0 and 1000 with a step of 10 and a default value of 300 is:
+--
+-- >>> :t sliderI (Just "label") 0 1000 10 300
+-- sliderI (Just "label") 0 1000 10 300
+-- :: (Monad m, ToHtml a, P.Integral a, Show a) => SharedRep m a
+sliderI ::
+ (Monad m, ToHtml a, P.Integral a, Show a) =>
+ Maybe Text ->
+ a ->
+ a ->
+ a ->
+ a ->
+ SharedRep m a
+sliderI label l u s v =
+ repInput
+ decimal
+ (pack . show)
+ (Input v label mempty (Slider [min_ (pack $ show l), max_ (pack $ show u), step_ (pack $ show s)]))
+ v
+
+-- | textbox classique
+--
+-- >>> :t textbox (Just "label") "some text"
+-- textbox (Just "label") "some text" :: Monad m => SharedRep m Text
+textbox :: (Monad m) => Maybe Text -> Text -> SharedRep m Text
+textbox label v =
+ repInput
+ takeText
+ id
+ (Input v label mempty TextBox)
+ v
+
+-- | textbox that only updates on focusout
+textbox' :: (Monad m) => Maybe Text -> Text -> SharedRep m Text
+textbox' label v =
+ repInput
+ takeText
+ id
+ (Input v label mempty TextBox')
+ v
+
+-- | textarea input element, specifying number of rows.
+textarea :: (Monad m) => Int -> Maybe Text -> Text -> SharedRep m Text
+textarea rows label v =
+ repInput
+ takeText
+ id
+ (Input v label mempty (TextArea rows))
+ v
+
+-- | Non-typed hex color input
+colorPicker :: (Monad m) => Maybe Text -> Text -> SharedRep m Text
+colorPicker label v =
+ repInput
+ takeText
+ id
+ (Input v label mempty ColorPicker)
+ v
+
+-- | dropdown box
+dropdown ::
+ (Monad m, ToHtml a) =>
+ -- | parse an a from Text
+ Parser a ->
+ -- | print an a to Text
+ (a -> Text) ->
+ -- | label suggestion
+ Maybe Text ->
+ -- | list of dropbox elements (as text)
+ [Text] ->
+ -- | initial value
+ a ->
+ SharedRep m a
+dropdown p pr label opts v =
+ repInput
+ p
+ pr
+ (Input v label mempty (Dropdown opts))
+ v
+
+-- | dropdown box with multiple selections
+dropdownMultiple ::
+ (Monad m, ToHtml a) =>
+ -- | parse an a from Text
+ Parser a ->
+ -- | print an a to Text
+ (a -> Text) ->
+ -- | label suggestion
+ Maybe Text ->
+ -- | list of dropbox elements (as text)
+ [Text] ->
+ -- | initial value
+ [a] ->
+ SharedRep m [a]
+dropdownMultiple p pr label opts vs =
+ repInput
+ (p `sepBy1` char ',')
+ (intercalate "," . fmap pr)
+ (Input vs label mempty (DropdownMultiple opts ','))
+ vs
+
+-- | a datalist input
+datalist :: (Monad m) => Maybe Text -> [Text] -> Text -> Text -> SharedRep m Text
+datalist label opts v id'' =
+ repInput
+ takeText
+ (pack . show)
+ (Input v label mempty (Datalist opts id''))
+ v
+
+-- | A dropdown box designed to help represent a haskell sum type.
+dropdownSum ::
+ (Monad m, ToHtml a) =>
+ Parser a ->
+ (a -> Text) ->
+ Maybe Text ->
+ [Text] ->
+ a ->
+ SharedRep m a
+dropdownSum p pr label opts v =
+ repInput
+ p
+ pr
+ (Input v label mempty (DropdownSum opts))
+ v
+
+-- | A checkbox input.
+checkbox :: (Monad m) => Maybe Text -> Bool -> SharedRep m Bool
+checkbox label v =
+ repInput
+ ((== "true") <$> takeText)
+ (bool "false" "true")
+ (Input v label mempty (Checkbox v))
+ v
+
+-- | a toggle button
+toggle :: (Monad m) => Maybe Text -> Bool -> SharedRep m Bool
+toggle label v =
+ repInput
+ ((== "true") <$> takeText)
+ (bool "false" "true")
+ (Input v label mempty (Toggle v label))
+ v
+
+-- | a button
+button :: (Monad m) => Maybe Text -> SharedRep m Bool
+button label =
+ repMessage
+ (pure True)
+ (bool "false" "true")
+ (Input False label mempty Button)
+ False
+ False
+
+-- | filename input
+chooseFile :: (Monad m) => Maybe Text -> Text -> SharedRep m Text
+chooseFile label v =
+ repInput
+ takeText
+ (pack . show)
+ (Input v label mempty ChooseFile)
+ v
+
+-- | Represent a Maybe using a checkbox.
+--
+-- Hides the underlying content on Nothing
+maybeRep ::
+ (Monad m) =>
+ Maybe Text ->
+ Bool ->
+ SharedRep m a ->
+ SharedRep m (Maybe a)
+maybeRep label st sa = SharedRep $ do
+ id' <- zoom _1 (genNamePre "maybe")
+ unshare $ bimap (hmap id') mmap (checkboxShow label id' st) <<*>> sa
+ where
+ hmap id' a b =
+ cardify
+ (a, [])
+ Nothing
+ ( Lucid.with
+ div_
+ [ id_ id',
+ style_
+ ("display:" <> bool "none" "block" st)
+ ]
+ b,
+ [style_ "padding-top: 0.25rem; padding-bottom: 0.25rem;"]
+ )
+ mmap a b = bool Nothing (Just b) a
+
+checkboxShow :: (Monad m) => Maybe Text -> Text -> Bool -> SharedRep m Bool
+checkboxShow label id' v =
+ SharedRep $ do
+ name <- zoom _1 genName
+ zoom _2 (modify (HashMap.insert name (bool "false" "true" v)))
+ pure $
+ Rep
+ (toHtml (Input v label name (Checkbox v)) <> scriptToggleShow name id')
+ ( \s ->
+ ( s,
+ join
+ $ maybe (Left "HashMap.lookup failed") Right
+ $ either (Left . pack) Right . parseOnly ((== "true") <$> takeText)
+ <$> HashMap.lookup name s
+ )
+ )
+
+-- | toggle show/hide
+scriptToggleShow :: (Monad m) => Text -> Text -> HtmlT m ()
+scriptToggleShow checkName toggleId =
+ script_
+ [qq|
+$('#{checkName}').on('change', (function()\{
+ var vis = this.checked ? "block" : "none";
+ document.getElementById("{toggleId}").style.display = vis;
+\}));
+|]
+
+-- | A (fixed-size) list represented in html as an accordion card
+-- A major restriction of the library is that a 'SharedRep' does not have a Monad instance. In practice, this means that the external representation of lists cannot have a dynamic size.
+accordionList :: (Monad m) => Maybe Text -> Text -> Maybe Text -> (Text -> a -> SharedRep m a) -> [Text] -> [a] -> SharedRep m [a]
+accordionList title prefix open srf labels as = SharedRep $ do
+ (Rep h fa) <-
+ unshare
+ $ first (accordion prefix open . zip labels)
+ $ foldr
+ (\a x -> bimap (:) (:) a <<*>> x)
+ (pure [])
+ (zipWith srf labels as)
+ h' <- zoom _1 h
+ pure (Rep (maybe mempty (h5_ . toHtml) title <> h') fa)
+
+-- | A (fixed-sized) list of (Bool, a) tuples.
+accordionBoolList :: (Monad m) => Maybe Text -> Text -> (a -> SharedRep m a) -> (Bool -> SharedRep m Bool) -> [Text] -> [(Bool, a)] -> SharedRep m [(Bool, a)]
+accordionBoolList title prefix bodyf checkf labels xs = SharedRep $ do
+ (Rep h fa) <-
+ unshare
+ $ first (accordionChecked prefix)
+ $ first (zipWith (\l (ch, a) -> (l, a, ch)) labels)
+ $ foldr
+ (\a x -> bimap (:) (:) a <<*>> x)
+ (pure [])
+ ( ( \(ch, a) ->
+ bimap
+ (,)
+ (,)
+ (checkf ch)
+ <<*>> bodyf a
+ )
+ <$> xs
+ )
+ h' <- zoom _1 h
+ pure (Rep (maybe mempty (h5_ . toHtml) title <> h') fa)
+
+-- | A fixed-sized list of Maybe a\'s
+listMaybeRep :: (Monad m) => Maybe Text -> Text -> (Text -> Maybe a -> SharedRep m (Maybe a)) -> Int -> [a] -> SharedRep m [Maybe a]
+listMaybeRep t p srf n as =
+ accordionList t p Nothing srf (defaultListLabels n) (take n ((Just <$> as) <> repeat Nothing))
+
+-- | A SharedRep of [a]. Due to the applicative nature of the bridge, the size of lists has to be fixed on construction. listRep is a workaround for this, to enable some form of dynamic sizing.
+listRep ::
+ (Monad m) =>
+ Maybe Text ->
+ Text ->
+ -- | name prefix (should be unique)
+ (Bool -> SharedRep m Bool) ->
+ -- | Bool Rep
+ (a -> SharedRep m a) ->
+ -- | a Rep
+ Int ->
+ -- | maximum length of list
+ a ->
+ -- | default value for new rows
+ [a] ->
+ -- | initial values
+ SharedRep m [a]
+listRep t p brf srf n defa as =
+ second (mconcat . fmap (\(b, a) -> bool [] [a] b)) $
+ accordionBoolList
+ t
+ p
+ srf
+ brf
+ (defaultListLabels n)
+ (take n (((True,) <$> as) <> repeat (False, defa)))
+
+-- a sensible default for the accordion row labels for a list
+defaultListLabels :: Int -> [Text]
+defaultListLabels n = (\x -> "[" <> pack (show x) <> "]") <$> [0 .. n] :: [Text]
+
+-- | Parse from a textbox
+--
+-- Uses focusout so as not to spam the reader.
+readTextbox :: (Monad m, Read a, Show a) => Maybe Text -> a -> SharedRep m (Either Text a)
+readTextbox label v = parsed . unpack <$> textbox' label (pack $ show v)
+ where
+ parsed str =
+ case reads str of
+ [(a, "")] -> Right a
+ _ -> Left (pack str)
+
+-- | Representation of web concerns (css, js & html).
+fiddle :: (Monad m) => Concerns Text -> SharedRep m (Concerns Text, Bool)
+fiddle (Concerns c j h) =
+ bimap
+ (\c' j' h' up -> Lucid.with div_ [class__ "fiddle "] $ mconcat [up, h', j', c'])
+ (\c' j' h' up -> (Concerns c' j' h', up))
+ (textarea 10 (Just "css") c)
+ <<*>> textarea 10 (Just "js") j
+ <<*>> textarea 10 (Just "html") h
+ <<*>> button (Just "update")
+
+-- | turns a SharedRep into a fiddle
+viaFiddle ::
+ (Monad m) =>
+ SharedRep m a ->
+ SharedRep m (Bool, Concerns Text, a)
+viaFiddle sr = SharedRep $ do
+ sr'@(Rep h _) <- unshare sr
+ hrep <- unshare $ textarea 10 (Just "html") (toText h)
+ crep <- unshare $ textarea 10 (Just "css") mempty
+ jrep <- unshare $ textarea 10 (Just "js") mempty
+ u <- unshare $ button (Just "update")
+ pure $
+ bimap
+ (\up a b c _ -> Lucid.with div_ [class__ "fiddle "] $ mconcat [up, a, b, c])
+ (\up a b c d -> (up, Concerns a b c, d))
+ u
+ <<*>> crep
+ <<*>> jrep
+ <<*>> hrep
+ <<*>> sr'
+
+repChoice :: (Monad m) => Int -> [(Text, SharedRep m a)] -> SharedRep m a
+repChoice initt xs =
+ bimap hmap mmap dd
+ <<*>> foldr (\x a -> bimap (:) (:) x <<*>> a) (pure []) cs
+ where
+ ts = fst <$> xs
+ cs = snd <$> xs
+ dd = dropdownSum takeText id Nothing ts t0
+ t0 = ts List.!! initt
+ hmap dd' cs' =
+ div_
+ ( dd'
+ <> mconcat (zipWith (\c t -> subtype c t0 t) cs' ts)
+ )
+ mmap dd' cs' = maybe (List.head cs') (cs' List.!!) (List.elemIndex dd' ts)
+
+-- | select test keys from a Map
+selectItems :: [Text] -> HashMap.HashMap Text a -> [(Text,a)]
+selectItems ks m =
+ HashMap.toList $
+ HashMap.filterWithKey (\k _ -> k `elem` ks) m
+
+-- | rep of multiple items list
+repItemsSelect :: Monad m => [Text] -> [Text] -> SharedRep m [Text]
+repItemsSelect init full =
+ dropdownMultiple (A.takeWhile (`notElem` ([',']::[Char]))) id (Just "items") full init
+
+subtype :: With a => a -> Text -> Text -> a
+subtype h origt t =
+ with
+ h
+ [ class__ "subtype ",
+ data_ "sumtype" t,
+ style_ ("display:" <> bool "block" "none" (origt /= t))
+ ]
diff --git a/src/Web/Rep/Socket.hs b/src/Web/Rep/Socket.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Rep/Socket.hs
@@ -0,0 +1,309 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# OPTIONS_GHC -Wall #-}
+{-# OPTIONS_GHC -Wredundant-constraints #-}
+
+-- | A socket between a web page and haskell, based on the box library.
+module Web.Rep.Socket
+ ( socketPage,
+ serveSocketBox,
+ sharedServer,
+ defaultSharedServer,
+ SocketConfig(..),
+ defaultSocketConfig,
+ defaultSocketPage,
+ defaultInputCode,
+ defaultOutputCode,
+ Code(..),
+ code,
+ )
+where
+
+import qualified Network.WebSockets as WS
+import Box
+import Box.Socket
+import Control.Lens
+import Control.Monad.Conc.Class as C
+import Data.HashMap.Strict as HashMap
+import qualified Data.Text as Text
+import NumHask.Prelude hiding (intercalate, replace)
+import Text.InterpolatedString.Perl6
+import Web.Rep.Html
+import Web.Rep.Page
+import Web.Rep.Server
+import Web.Rep.Shared
+import Web.Rep.Bootstrap
+import Web.Scotty hiding (get)
+import qualified Data.Attoparsec.Text as A
+import Network.Wai.Handler.WebSockets
+import Lucid as L
+
+socketPage :: Page
+socketPage = mempty & #jsOnLoad .~
+ mconcat
+ [ webSocket,
+ runScriptJs,
+ refreshJsbJs,
+ preventEnter
+ ]
+
+serveSocketBox :: SocketConfig -> Page -> Box IO Text Text -> IO ()
+serveSocketBox cfg p b =
+ scotty (cfg ^. #port) $ do
+ middleware $ websocketsOr WS.defaultConnectionOptions (serverApp b)
+ servePageWith "/" (defaultPageConfig "") p
+
+sharedServer :: SharedRep IO a -> SocketConfig -> Page -> (Html () -> [Code]) -> (Either Text a -> IO [Code]) -> IO ()
+sharedServer srep cfg p i o =
+ serveSocketBox cfg p <$.>
+ fromAction (backendLoop srep i o . wrangle)
+
+defaultSharedServer :: (Show a) => SharedRep IO a -> IO ()
+defaultSharedServer srep =
+ sharedServer srep defaultSocketConfig defaultSocketPage defaultInputCode defaultOutputCode
+
+defaultSocketPage :: Page
+defaultSocketPage =
+ bootstrapPage <>
+ socketPage &
+ #htmlBody
+ .~ divClass_
+ "container"
+ ( mconcat
+ [ divClass_ "row" (h1_ "web-rep testing"),
+ divClass_ "row" $ mconcat $ (\(t, h) -> divClass_ "col" (h2_ (toHtml t) <> L.with div_ [id_ t] h)) <$> sections
+ ]
+ )
+ where
+ sections =
+ [ ("input", mempty),
+ ("output", mempty)
+ ]
+
+-- I am proud of this.
+backendLoop ::
+ (MonadConc m) =>
+ SharedRep m a ->
+ -- | initial code to place html of the SharedRep
+ (Html () -> [Code]) ->
+ -- | output code
+ (Either Text a -> m [Code]) ->
+ Box m [Code] (Text, Text) -> m ()
+backendLoop sr inputCode outputCode (Box c e) = flip evalStateT (0, HashMap.empty) $ do
+ -- you only want to run unshare once for a SharedRep
+ (Rep h fa) <- unshare sr
+ b <- lift $ commit c (inputCode h)
+ o <- step' fa
+ b' <- lift $ commit c o
+ when (b && b') (go fa)
+ where
+ go fa = do
+ incoming <- lift $ emit e
+ modify (updateS incoming)
+ o <- step' fa
+ b <- lift $ commit c o
+ when b (go fa)
+ updateS Nothing s = s
+ updateS (Just (k,v)) s = second (insert k v) s
+
+ step' fa = do
+ s <- get
+ let (m', ea) = fa (snd s)
+ modify (second (const m'))
+ o <- lift $ outputCode ea
+ pure o
+
+defaultInputCode :: Html () -> [Code]
+defaultInputCode h = [Append "input" (toText h)]
+
+defaultOutputCode :: (Monad m, Show a) => Either Text a -> m [Code]
+defaultOutputCode ea =
+ pure $ case ea of
+ Left err -> [Append "debug" err]
+ Right a -> [Replace "output" (show a)]
+
+wrangle :: Monad m => Box m Text Text -> Box m [Code] (Text,Text)
+wrangle (Box c e) = Box c' e'
+ where
+ c' = listC $ contramap code c
+ e' = mapE (pure . either (const Nothing) Just) (parseE parserJ e)
+
+-- | {"event":{"element":"textid","value":"abcdees"}}
+parserJ :: A.Parser (Text,Text)
+parserJ = do
+ _ <- A.string [q|{"event":{"element":"|]
+ e <- A.takeTill (=='"')
+ _ <- A.string [q|","value":"|]
+ v <- A.takeTill (=='"')
+ _ <- A.string [q|"}}|]
+ pure (e,v)
+
+-- * code hooks
+-- * code messaging
+data Code =
+ Replace Text Text |
+ Append Text Text |
+ Console Text |
+ Eval Text |
+ Val Text
+ deriving (Eq, Show, Generic, Read)
+
+code :: Code -> Text
+code (Replace i t) = replace i t
+code (Append i t) = append i t
+code (Console t) = console t
+code (Eval t) = t
+code (Val t) = val t
+
+console :: Text -> Text
+console t = [qc| console.log({t}) |]
+
+val :: Text -> Text
+val t = [qc| jsb.ws.send({t}) |]
+
+-- | replace a container and run any embedded scripts
+replace :: Text -> Text -> Text
+replace d t =
+ [qc|
+ var $container = document.getElementById('{d}');
+ $container.innerHTML = '{clean t}';
+ runScripts($container);
+ refreshJsb();
+ |]
+
+-- | append to a container and run any embedded scripts
+append :: Text -> Text -> Text
+append d t =
+ [qc|
+ var $container = document.getElementById('{d}');
+ $container.innerHTML += '{clean t}';
+ runScripts($container);
+ refreshJsb();
+ |]
+
+clean :: Text -> Text
+clean =
+ Text.intercalate "\\'" . Text.split (== '\'')
+ . Text.intercalate "\\n"
+ . Text.lines
+
+-- * initial javascript
+-- | create a web socket for event data
+webSocket :: RepJs
+webSocket =
+ RepJsText
+ [q|
+window.jsb = {ws: new WebSocket('ws://' + location.host + '/')};
+jsb.event = function(ev) {
+ jsb.ws.send(JSON.stringify({event: ev}));
+};
+jsb.ws.onmessage = function(evt){
+ eval('(function(){' + evt.data + '})()');
+};
+|]
+
+-- * scripts
+-- | Event hooks that may need to be reattached given dynamic content creation.
+refreshJsbJs :: RepJs
+refreshJsbJs =
+ RepJsText
+ [q|
+function refreshJsb () {
+ $('.jsbClassEventInput').off('input');
+ $('.jsbClassEventInput').on('input', (function(){
+ jsb.event({ 'element': this.id, 'value': this.value});
+ }));
+ $('.jsbClassEventChange').off('change');
+ $('.jsbClassEventChange').on('change', (function(){
+ jsb.event({ 'element': this.id, 'value': this.value});
+ }));
+ $('.jsbClassEventFocusout').off('focusout');
+ $('.jsbClassEventFocusout').on('focusout', (function(){
+ jsb.event({ 'element': this.id, 'value': this.value});
+ }));
+ $('.jsbClassEventButton').off('click');
+ $('.jsbClassEventButton').on('click', (function(){
+ jsb.event({ 'element': this.id, 'value': this.value});
+ }));
+ $('.jsbClassEventToggle').off('click');
+ $('.jsbClassEventToggle').on('click', (function(){
+ jsb.event({ 'element': this.id, 'value': ('true' !== this.getAttribute('aria-pressed')).toString()});
+ }));
+ $('.jsbClassEventCheckbox').off('click');
+ $('.jsbClassEventCheckbox').on('click', (function(){
+ jsb.event({ 'element': this.id, 'value': this.checked.toString()});
+ }));
+ $('.jsbClassEventChooseFile').off('input');
+ $('.jsbClassEventChooseFile').on('input', (function(){
+ jsb.event({ 'element': this.id, 'value': this.files[0].name});
+ }));
+ $('.jsbClassEventShowSum').off('change');
+ $('.jsbClassEventShowSum').on('change', (function(){
+ var v = this.value;
+ $(this).parent('.sumtype-group').siblings('.subtype').each(function(i) {
+ if (this.dataset.sumtype === v) {
+ this.style.display = 'block';
+ } else {
+ this.style.display = 'none';
+ }
+ })
+ }));
+ $('.jsbClassEventChangeMultiple').off('change');
+ $('.jsbClassEventChangeMultiple').on('change', (function(){
+ jsb.event({ 'element': this.id, 'value': [...this.options].filter(option => option.selected).map(option => option.value).join(',')});
+ }));
+};
+|]
+
+-- | prevent the Enter key from triggering an event
+preventEnter :: RepJs
+preventEnter =
+ RepJs $
+ parseJs
+ [q|
+window.addEventListener('keydown',function(e) {
+ if(e.keyIdentifier=='U+000A' || e.keyIdentifier=='Enter' || e.keyCode==13) {
+ if(e.target.nodeName=='INPUT' && e.target.type !== 'textarea') {
+ e.preventDefault();
+ return false;
+ }
+ }
+}, true);
+|]
+
+-- | script injection js.
+--
+-- See https://ghinda.net/article/script-tags/ for why this might be needed.
+runScriptJs :: RepJs
+runScriptJs =
+ RepJsText
+ [q|
+function insertScript ($script) {
+ var s = document.createElement('script')
+ s.type = 'text/javascript'
+ if ($script.src) {
+ s.onload = callback
+ s.onerror = callback
+ s.src = $script.src
+ } else {
+ s.textContent = $script.innerText
+ }
+
+ // re-insert the script tag so it executes.
+ document.head.appendChild(s)
+
+ // clean-up
+ $script.parentNode.removeChild($script)
+}
+
+function runScripts ($container) {
+ // get scripts tags from a node
+ var $scripts = $container.querySelectorAll('script')
+ $scripts.forEach(function ($script) {
+ insertScript($script)
+ })
+}
+|]
diff --git a/stack.yaml b/stack.yaml
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,13 +1,13 @@
-resolver: lts-15.13
+resolver: nightly-2020-06-25
packages:
- '.'
extra-deps:
- - box-0.4.0
- - lucid-svg-0.7.1
- - javascript-bridge-0.2.0
- - interpolatedstring-perl6-1.0.2
- - text-format-0.3.2
+ - numhask-0.6.0
+ - box-0.5.0
+ - box-socket-0.0.1
allow-newer: true
+
+
diff --git a/test/test.hs b/test/test.hs
--- a/test/test.hs
+++ b/test/test.hs
@@ -1,16 +1,17 @@
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
module Main where
import Control.Lens
import Lucid
-import Prelude
+import NumHask.Prelude
import Test.DocTest
import Test.Tasty
import Test.Tasty.Hspec
-import Web.Page
-import Web.Page.Examples
+import Web.Rep
+import Web.Rep.Examples
import qualified Data.Text.IO as Text
generatePage :: FilePath -> FilePath -> PageConfig -> Page -> IO ()
@@ -24,7 +25,7 @@
genTest :: FilePath -> IO ()
genTest dir =
- void $ generatePages dir [("default", (defaultPageConfig "default"), page1), ("sep", cfg2, page2)]
+ void $ generatePages dir [("default", defaultPageConfig "default", page1), ("sep", cfg2, page2)]
testVsFile :: FilePath -> FilePath -> PageConfig -> Page -> IO Bool
testVsFile dir stem pc p = do
@@ -46,13 +47,13 @@
t' <- Text.readFile (dir <> names ^. #htmlConcern)
return (t, Concerns mempty mempty t')
Separated -> do
- t' <- sequenceA $ Text.readFile <$> (dir <>) <$> names
+ t' <- sequenceA $ Text.readFile . (dir <>) <$> names
return (t, t')
testsRender :: IO (SpecWith ())
testsRender =
return $
- describe "Web.Page.Render" $ do
+ describe "Web.Rep.Render" $ do
it "run genTest 'test/canned/' to refresh canned files." True
it "renderPage mempty" $
renderText (renderPage mempty) `shouldBe`
@@ -66,7 +67,7 @@
testsBootstrap :: IO (SpecWith ())
testsBootstrap =
return $
- describe "Web.Page.Bootstrap" $ do
+ describe "Web.Rep.Bootstrap" $ do
it "bootstrapPage versus canned" $
toText (renderPage bootstrapPage) `shouldBe`
""
@@ -76,82 +77,16 @@
flip evalStateT 0 .
accordion "acctest" Nothing $
(\x -> (pack (show x), "filler")) <$> [1..2::Int]) `shouldBe`
- ""
-
-testsBridge :: IO (SpecWith ())
-testsBridge =
- return $
- describe "Web.Page.Bridge" $
- it "bridgePage versus canned" $
- toText (renderPage bridgePage) `shouldBe`
- ""
-
-testbs :: [Value]
-testbs =
- [ Object (fromList [("element","1"),("value","b1")])
- , Object (fromList [("element","2"),("value","b2")])
- , Object (fromList [("element","3"),("value","b3")])
- ]
-
-testvs :: [Value]
-testvs =
- [ Object (fromList [("element","2"),("value","false")])
- , Object (fromList [("element","2"),("value","true")])
- , Object (fromList [("element","3"),("value","x")])
- , Object (fromList [("element","4"),("value","")])
- , Object (fromList [("element","5"),("value","2")])
- , Object (fromList [("element","6"),("value","0.6")])
- , Object (fromList [("element","7"),("value","false")])
- , Object (fromList [("element","8"),("value","true")])
- , Object (fromList [("element","9"),("value","5")])
- , Object (fromList [("element","10"),("value","#00b4cc")])
- ]
-
-testsRep :: IO (SpecWith ())
-testsRep =
- return $
- describe "Web.Page.Rep" $ do
- it "Rep mempty" $
- runIdentity (runList (pure (mempty :: Text)) []) `shouldBe` []
- it "mempty passes values through to hashmap" $
- runIdentity (runList (pure (mempty :: Text)) testbs) `shouldBe`
- [ Right (fromList [("1","b1")], Right "")
- , Right (fromList [("1","b1"),("2","b2")], Right "")
- , Right (fromList [("1","b1"),("2","b2"),("3","b3")], Right "")
- ]
- it "button consumes an event and the value is transitory" $
- runIdentity
- (runList
- ((,) <$> button Nothing <*> button Nothing)
- testbs) `shouldBe`
- [ Right (fromList [],Right (True,False))
- , Right (fromList [],Right (False,True))
- , Right (fromList [("3","b3")],Right (False,False))
- ]
- it "repExamples versus canned" $
- runIdentity (runOnce repExamples mempty) `shouldBe`
- (fromList [("7","3"),("1","sometext"),("4","0.5"),("2","no initial value & multi-line text\\nrenders is not ok?/"),("5","true"),("8","Square"),("3","3"),("6","false"),("9","#454e56")],Right (RepExamples {repTextbox = "sometext", repTextarea = "no initial value & multi-line text\\nrenders is not ok?/", repSliderI = 3, repSlider = 0.5, repCheckbox = True, repToggle = False, repDropdown = 3, repShape = SquareShape, repColor = "#454e56"}))
- it "listExample versus canned" $
- runIdentity (runOnce (listExample 5) mempty) `shouldBe`
- (fromList [("1","0"),("4","3"),("2","1"),("5","4"),("3","2"),("6","5")],Right [0,1,2,3,4,5])
- it "fiddleExample versus canned" $
- runIdentity (runOnce (fiddle fiddleExample) mempty) `shouldBe`
- (fromList [("1",""),("2",""),("3","\n\n")],Right (Concerns "" "" "\n\n",False))
-
- it "repExamples run through some canned events" $
- runIdentity (runList (maybeRep Nothing True repExamples) testvs) `shouldBe`
- [Right (fromList [("7","true"),("4","no initial value & multi-line text\\nrenders is not ok?/"),("2","false"),("5","3"),("8","false"),("11","#454e56"),("3","sometext"),("6","0.5"),("9","3"),("10","Square")],Right Nothing),Right (fromList [("7","true"),("4","no initial value & multi-line text\\nrenders is not ok?/"),("2","true"),("5","3"),("8","false"),("11","#454e56"),("3","sometext"),("6","0.5"),("9","3"),("10","Square")],Right (Just (RepExamples {repTextbox = "sometext", repTextarea = "no initial value & multi-line text\\nrenders is not ok?/", repSliderI = 3, repSlider = 0.5, repCheckbox = True, repToggle = False, repDropdown = 3, repShape = SquareShape, repColor = "#454e56"}))),Right (fromList [("7","true"),("4","no initial value & multi-line text\\nrenders is not ok?/"),("2","true"),("5","3"),("8","false"),("11","#454e56"),("3","x"),("6","0.5"),("9","3"),("10","Square")],Right (Just (RepExamples {repTextbox = "x", repTextarea = "no initial value & multi-line text\\nrenders is not ok?/", repSliderI = 3, repSlider = 0.5, repCheckbox = True, repToggle = False, repDropdown = 3, repShape = SquareShape, repColor = "#454e56"}))),Right (fromList [("7","true"),("4",""),("2","true"),("5","3"),("8","false"),("11","#454e56"),("3","x"),("6","0.5"),("9","3"),("10","Square")],Right (Just (RepExamples {repTextbox = "x", repTextarea = "", repSliderI = 3, repSlider = 0.5, repCheckbox = True, repToggle = False, repDropdown = 3, repShape = SquareShape, repColor = "#454e56"}))),Right (fromList [("7","true"),("4",""),("2","true"),("5","2"),("8","false"),("11","#454e56"),("3","x"),("6","0.5"),("9","3"),("10","Square")],Right (Just (RepExamples {repTextbox = "x", repTextarea = "", repSliderI = 2, repSlider = 0.5, repCheckbox = True, repToggle = False, repDropdown = 3, repShape = SquareShape, repColor = "#454e56"}))),Right (fromList [("7","true"),("4",""),("2","true"),("5","2"),("8","false"),("11","#454e56"),("3","x"),("6","0.6"),("9","3"),("10","Square")],Right (Just (RepExamples {repTextbox = "x", repTextarea = "", repSliderI = 2, repSlider = 0.6, repCheckbox = True, repToggle = False, repDropdown = 3, repShape = SquareShape, repColor = "#454e56"}))),Right (fromList [("7","false"),("4",""),("2","true"),("5","2"),("8","false"),("11","#454e56"),("3","x"),("6","0.6"),("9","3"),("10","Square")],Right (Just (RepExamples {repTextbox = "x", repTextarea = "", repSliderI = 2, repSlider = 0.6, repCheckbox = False, repToggle = False, repDropdown = 3, repShape = SquareShape, repColor = "#454e56"}))),Right (fromList [("7","false"),("4",""),("2","true"),("5","2"),("8","true"),("11","#454e56"),("3","x"),("6","0.6"),("9","3"),("10","Square")],Right (Just (RepExamples {repTextbox = "x", repTextarea = "", repSliderI = 2, repSlider = 0.6, repCheckbox = False, repToggle = True, repDropdown = 3, repShape = SquareShape, repColor = "#454e56"}))),Right (fromList [("7","false"),("4",""),("2","true"),("5","2"),("8","true"),("11","#454e56"),("3","x"),("6","0.6"),("9","5"),("10","Square")],Right (Just (RepExamples {repTextbox = "x", repTextarea = "", repSliderI = 2, repSlider = 0.6, repCheckbox = False, repToggle = True, repDropdown = 5, repShape = SquareShape, repColor = "#454e56"}))),Right (fromList [("7","false"),("4",""),("2","true"),("5","2"),("8","true"),("11","#454e56"),("3","x"),("6","0.6"),("9","5"),("10","#00b4cc")],Right (Just (RepExamples {repTextbox = "x", repTextarea = "", repSliderI = 2, repSlider = 0.6, repCheckbox = False, repToggle = True, repDropdown = 5, repShape = CircleShape, repColor = "#454e56"})))]
+ ""
-- The tests
tests :: IO TestTree
tests = testGroup "the tests" <$> sequence
- [ testSpec "Web.Page.Render" =<< testsRender
- , testSpec "Web.Page.Bootstrap" =<< testsBootstrap
- , testSpec "Web.Page.Bridge" =<< testsBridge
- , testSpec "Web.Page.Rep" =<< testsRep
+ [ testSpec "Web.Rep.Render" =<< testsRender
+ , testSpec "Web.Rep.Bootstrap" =<< testsBootstrap
]
main :: IO ()
main = do
- doctest ["src/Web/Page/SharedReps.hs"]
+ doctest ["src/Web/Rep/SharedReps.hs"]
defaultMain =<< tests
diff --git a/web-rep.cabal b/web-rep.cabal
--- a/web-rep.cabal
+++ b/web-rep.cabal
@@ -1,6 +1,6 @@
-cabal-version: 1.12
+cabal-version: 2.4
name: web-rep
-version: 0.5.0
+version: 0.6.0
synopsis: representations of a web page
category: web
description: An applicative-based, shared-data representation of a web page.
@@ -15,78 +15,111 @@
library
exposed-modules:
- Web.Page
- Web.Page.Bootstrap
- Web.Page.Bridge
- Web.Page.Examples
- Web.Page.Html
- Web.Page.Html.Input
- Web.Page.Mathjax
- Web.Page.Render
- Web.Page.SharedReps
- Web.Page.Server
- Web.Page.Types
+ Web.Rep
+ Web.Rep.Bootstrap
+ Web.Rep.Examples
+ Web.Rep.Html
+ Web.Rep.Html.Input
+ Web.Rep.Mathjax
+ Web.Rep.Page
+ Web.Rep.Render
+ Web.Rep.Server
+ Web.Rep.Shared
+ Web.Rep.SharedReps
+ Web.Rep.Socket
hs-source-dirs:
- src
+ src
build-depends:
base >= 4.12 && <5,
- aeson >= 1.4.5 && < 1.5,
attoparsec >= 0.13.2 && < 0.14,
- bifunctors >= 5.5.5 && < 5.6,
- box >= 0.1.0 && < 0.5,
+ box >= 0.5 && < 0.6,
+ box-socket >= 0.0.1 && < 0.1,
clay >= 0.13 && < 0.14,
foldl >= 1.4.5 && < 1.5,
- generic-lens >= 1.1.0 && < 1.3,
+ generic-lens >= 1.1.0 && < 3.0,
interpolatedstring-perl6 >= 1.0.2 && < 1.1,
- javascript-bridge >= 0.2.0 && < 0.3,
language-javascript >= 0.6.0 && < 0.8,
- lens >= 4.17.1 && < 4.19,
+ lens >= 4.17.1 && < 4.20,
lucid >= 2.9 && < 2.10,
- lucid-svg >= 0.7.1 && < 0.8,
- mmorph >= 1.1.3 && < 1.2,
mtl >= 2.2.2 && < 2.3,
+ numhask >= 0.6 && < 0.7,
scotty >= 0.11.5 && < 0.12,
- streaming >= 0.2.3 && < 0.3,
text >= 1.2.3 && < 1.3,
- text-format >= 0.3.2 && < 0.4,
transformers >= 0.5.6 && < 0.6,
unordered-containers >= 0.2.10 && < 0.3,
- wai-middleware-static >= 0.8.2 && < 0.9
+ websockets >= 0.12,
+ concurrency >= 1.11,
+ wai-middleware-static >= 0.8.3,
+ wai-websockets >= 3.0.1.2,
default-language: Haskell2010
+ default-extensions:
+ NegativeLiterals
+ NoImplicitPrelude
+ OverloadedStrings
+ UnicodeSyntax
+ ghc-options:
+ -Wall
+ -Wcompat
+ -Wincomplete-record-updates
+ -Wincomplete-uni-patterns
+ -Wredundant-constraints
-executable page-example
- main-is: example.hs
+executable rep-example
+ main-is: rep-example.hs
hs-source-dirs:
- app
- ghc-options: -funbox-strict-fields -fforce-recomp -threaded -rtsopts -with-rtsopts=-N
+ app
build-depends:
base >= 4.12 && <5,
- attoparsec >= 0.13.2 && < 0.14,
- box >= 0.1.0 && < 0.5,
- lens >= 4.17 && < 4.19,
- lucid >= 2.9 && < 2.10,
- optparse-generic >= 1.3.0 && < 1.4,
- scotty >= 0.11.5 && < 0.12,
- text >= 1.2.3 && < 1.3,
- wai >= 3.2.2 && < 3.3,
- wai-extra >= 3.0 && < 3.1,
- wai-middleware-static >= 0.8 && < 0.9,
- web-rep >= 0.3.0
+ numhask >= 0.6 && < 0.7,
+ optparse-generic >= 1.3,
+ web-rep,
default-language: Haskell2010
+ default-extensions:
+ NegativeLiterals
+ NoImplicitPrelude
+ OverloadedStrings
+ UnicodeSyntax
+ ghc-options:
+ -Wall
+ -Wcompat
+ -Wincomplete-record-updates
+ -Wincomplete-uni-patterns
+ -Wredundant-constraints
+ -funbox-strict-fields
+ -fforce-recomp
+ -threaded
+ -rtsopts
+ -with-rtsopts=-N
test-suite test
type: exitcode-stdio-1.0
main-is: test.hs
hs-source-dirs:
- test
- ghc-options: -Wall -O2 -threaded
+ test
build-depends:
base >= 4.12 && <5,
doctest >= 0.16 && < 1.0,
- lens >= 4.17 && < 4.19,
+ lens >= 4.17 && < 4.20,
lucid >= 2.9.11 && < 2.10,
+ numhask >= 0.6 && < 0.7,
tasty >= 1.2.3 && < 1.3,
tasty-hspec >= 1.1.5 && < 1.2,
text >= 1.2.3 && < 1.3,
web-rep
default-language: Haskell2010
+ default-extensions:
+ NegativeLiterals
+ NoImplicitPrelude
+ OverloadedStrings
+ UnicodeSyntax
+ ghc-options:
+ -Wall
+ -Wcompat
+ -Wincomplete-record-updates
+ -Wincomplete-uni-patterns
+ -Wredundant-constraints
+ -funbox-strict-fields
+ -fforce-recomp
+ -threaded
+ -rtsopts
+ -with-rtsopts=-N