suavemente 0.1.0.0 → 0.2.0.0
raw patch · 9 files changed
+540/−337 lines, 9 filesdep +aesondep +colourdep +containersdep −suavemente
Dependencies added: aeson, colour, containers, text
Dependencies removed: suavemente
Files
- ChangeLog.md +7/−0
- README.md +10/−10
- app/Main.hs +0/−25
- src/Web/Suavemente.hs +10/−266
- src/Web/Suavemente/Core.hs +183/−0
- src/Web/Suavemente/Diagrams.hs +18/−0
- src/Web/Suavemente/Input.hs +224/−0
- src/Web/Suavemente/Types.hs +73/−0
- suavemente.cabal +15/−36
ChangeLog.md view
@@ -5,3 +5,10 @@ First release! ## Unreleased changes++- New inputs: `dropdown` and `enumDropdown`+- Add a proper JSON message stream+- Remove `ToMarkup` constraint from `suavemente`+- Added support for multiple endpoints via `suavementely`+- Added a color picker element (thanks to @tonyday567)+
README.md view
@@ -1,8 +1,14 @@ # suavemente -[](https://travis-ci.org/isovector/suavemente) | [Hackage][hackage]+[][build]+[][hackage]+[][stackage]+[][nightly] +[build]: https://travis-ci.org/isovector/suavemente [hackage]: https://hackage.haskell.org/package/suavemente+[stackage]: http://stackage.org/lts/package/suavemente+[nightly]: http://stackage.org/nightly/package/suavemente ## Dedication @@ -31,10 +37,11 @@ import Diagrams.Backend.SVG import Diagrams.Prelude hiding (rad) import Web.Suavemente+import Web.Suavemente.Diagrams main :: IO ()-main = suavemente $ do+main = suavemente sendDiagram $ do rad <- slider "Radius" 1 10 5 r <- realSlider "Red" 0 1 0.05 1 g <- realSlider "Green" 0 1 0.05 1@@ -50,12 +57,5 @@ :: Diagram B) ``` --## To Do--The "protocol" is disgusting---it just tries to `read` the incoming websocket-data. A better approach would be to hook it up via `FromJSON`, but it's-nontrivial to get JSON out of a web form and I cbf.--Pull requests are welcome!+Hit `localhost:8080` to see it in action!
− app/Main.hs
@@ -1,25 +0,0 @@-{-# LANGUAGE ApplicativeDo #-}--module Main where--import Diagrams.Backend.SVG-import Diagrams.Prelude hiding (rad)-import Web.Suavemente---main :: IO ()-main = suavemente $ do- rad <- slider "Radius" 1 10 5- r <- realSlider "Red" 0 1 0.05 1- g <- realSlider "Green" 0 1 0.05 1- b <- realSlider "Blue" 0 1 0.05 1- x <- slider "X" 0 20 10- y <- slider "Y" 0 20 10-- pure (- circle rad- # fc (sRGB r g b)- # translate (r2 (x, y))- # rectEnvelope (p2 (0, 0)) (r2 (20, 20))- :: Diagram B)-
src/Web/Suavemente.hs view
@@ -1,32 +1,19 @@-{-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE ExtendedDefaultRules #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}- module Web.Suavemente ( -- * Primary Stuff Suave ()+ , SomeSuave (..) , Input () , suavemente+ , suavementely -- * Inputs , textbox , checkbox , slider , realSlider+ , dropdown+ , enumDropdown+ , colorPicker -- * Making New Inputs , mkInput@@ -39,252 +26,9 @@ , q ) where -import Control.Applicative (liftA2)-import Control.Concurrent.STM.TVar (TVar, newTVar, readTVar, writeTVar)-import Control.Lens hiding ((#))-import Control.Monad.IO.Class (liftIO)-import Control.Monad.STM (STM, atomically)-import Control.Monad.State (StateT (..), evalStateT)-import Control.Monad.State.Class (MonadState (..), modify)-import Control.Monad.Trans.Class (lift)-import Data.Bifunctor (second)-import Data.Bool (bool)-import qualified Data.ByteString.Char8 as B-import Data.Char (toUpper)-import Data.Data.Lens (upon)-import Data.Proxy (Proxy (..))-import Diagrams.Backend.SVG (B, SVG (..), Options (..))-import qualified Diagrams.Prelude as D-import Graphics.Svg.Core (renderBS)-import Network.Wai.Handler.Warp (run)-import Network.WebSockets (Connection, receiveData, sendTextData)-import Servant (Get, Handler, (:<|>)(..), (:>), serve)-import Servant.API.WebSocket (WebSocket)-import Servant.HTML.Blaze (HTML)-import qualified Streaming as S-import qualified Streaming.Prelude as S-import Text.Blaze (preEscapedString, Markup, ToMarkup (..), unsafeLazyByteString )-import Text.Blaze.Renderer.String (renderMarkup)-import Text.InterpolatedString.Perl6 (qc, q)------------------------------------------------------------------------------------ | An applicative functor capable of getting input from an HTML page.-newtype Suave a = Suave- { suavely :: StateT Int STM (Input a)- } deriving Functor--instance Applicative Suave where- pure = Suave . pure . pure- Suave f <*> Suave a = Suave $ liftA2 (<*>) f a------------------------------------------------------------------------------------ | An applicative functor can introduce new markup, and hook it up to the--- event stream.-data Input a = Input- { -- | The markup of the input.- _iHtml :: Markup-- -- | A means of handling the event stream. The stream is of (name, value)- -- pairs. An 'Input' is responsible for stripping its own events out of- -- this stream.- --- -- The 'IO ()' action is to publish a change notification to the downstream- -- computations.- , _iFold :: IO ()- -> S.Stream (S.Of (String, String)) IO ()- -> S.Stream (S.Of (String, String)) IO ()-- -- | The current value of the 'Input'.- , _iValue :: STM a- } deriving Functor--instance Applicative Input where- pure = Input mempty (const . const $ pure ()) . pure- Input fh ff fv <*> Input ah af av =- Input (fh <> ah)- (liftA2 (.) ff af)- (fv <*> av)------------------------------------------------------------------------------------ | Run a 'Suave' computation by spinning up its webpage at @localhost:8080@.-suavemente :: ToMarkup a => Suave a -> IO ()-suavemente w = do- Input html f a <- atomically $ evalStateT (suavely w) 0- a0 <- atomically a- run 8080- . serve (Proxy @API)- $ pure (htmlPage a0 <> html) :<|> socketHandler a f------------------------------------------------------------------------------------ | Constructor for building 'Suave' inputs that are backed by HTML elements.-mkInput- :: Read a- => (String -> a -> Markup) -- ^ Function to construct the HTML element. The first parameter is what should be used for the element's 'id' attribute.- -> a -- ^ The input's initial value.- -> Suave a-mkInput f a = Suave $ do- name <- genName- tvar <- lift $ newTVar a- pure $ Input (f name a) (getEvents tvar name) (readTVar tvar)------------------------------------------------------------------------------------ | Construct an '_iFold' field for 'Input's.-getEvents- :: Read a- => TVar a -- ^ The underlying 'TVar' to publish changes to.- -> String -- ^ The name of the HTML input.- -> IO () -- ^ Publish a change notification.- -> S.Stream (S.Of (String, String)) IO ()- -> S.Stream (S.Of (String, String)) IO ()-getEvents t n update- = S.mapMaybeM (- \a@(i, z) ->- case i == n of- True -> do- liftIO . atomically . writeTVar t . read $ z & upon head %~ toUpper- update- pure Nothing- False -> pure $ Just a- )------------------------------------------------------------------------------------ | Get a 'String' representation of a markup-able type. Useful for--- constructing elements via quasiquotation.-showMarkup :: ToMarkup a => a -> String-showMarkup = renderMarkup . toMarkup------------------------------------------------------------------------------------ | Create an input driven by an HTML slider.-slider- :: (ToMarkup a, Num a, Read a)- => String -- ^ label- -> a -- ^ min- -> a -- ^ max- -> a -- ^ initial value- -> Suave a-slider label l u = mkInput $ \name v ->- preEscapedString- [qc|<tr><td>- <label for="{name}">{label}</label>- </td><td>- <input id="{name}" oninput="onChangeFunc(event)" type="range" min="{showMarkup l}" max="{showMarkup u}" value="{showMarkup v}" autocomplete="off">- </td></tr>|]------------------------------------------------------------------------------------ | Create an input driven by an HTML slider, whose domain is the real--- numbers.-realSlider- :: (ToMarkup a, Num a, Real a, Read a)- => String -- ^ label- -> a -- ^ min- -> a -- ^ max- -> a -- ^ step- -> a -- ^ initial value- -> Suave a-realSlider label l u s = mkInput $ \name v ->- preEscapedString- [qc|<tr><td>- <label for="{name}">{label}</label>- </td><td>- <input id="{name}" oninput="onChangeFunc(event)" type="range" min="{showMarkup l}" max="{showMarkup u}" step="{showMarkup s}" value="{showMarkup v}" autocomplete="off">- </td></tr>|]------------------------------------------------------------------------------------ | Create an input driven by an HTML checkbox.-checkbox :: String -> Bool -> Suave Bool-checkbox label = mkInput $ \name v ->- preEscapedString- [qc|<tr><td>- <label for="{name}">{label}</label>- </td><td>- <input id="{name}" oninput="onChangeBoolFunc(event)" type="checkbox" {bool ("" :: String) "checked='checked'" v} autocomplete="off">- </td></tr>|]------------------------------------------------------------------------------------ | Create an input driven by an HTML textbox.-textbox- :: String -- ^ label- -> String -- ^ initial value- -> Suave String-textbox label = mkInput $ \name v ->- preEscapedString- [qc|<tr><td>- <label for="{name}">{label}</label>- </td><td>- <input id="{name}" oninput="onChangeStrFunc(event)" type="text" value="{v}" autocomplete="off">- </td></tr>|]------------------------------------------------------------------------------------ | HTML code to inject into all 'Suave' pages.-htmlPage :: ToMarkup a => a -> Markup-htmlPage a = preEscapedString $- [q|- <style>- </style>|]- ++- [qc|- <script>- let ws = new WebSocket("ws://localhost:8080/suavemente");- ws.onmessage = (e) => document.getElementById("result").innerHTML = e.data;- let onChangeFunc = (e) => ws.send(e.target.id + " " + e.target.value)- let onChangeStrFunc = (e) => ws.send(e.target.id + " \"" + e.target.value + "\"")- let onChangeBoolFunc = (e) => ws.send(e.target.id + " " + e.target.checked)- </script>- <div id="result">{showMarkup a}</div>- <table>- |]------------------------------------------------------------------------------------ | 'Handler' endpoint for responding to 'Suave''s websockets.-socketHandler- :: ToMarkup a- => STM a- -> (IO () -> S.Stream (S.Of (String, String)) IO () -> S.Stream (S.Of (String, String)) IO ())- -> Connection- -> Handler ()-socketHandler v f c- = liftIO- . S.effects- . f (sendTextData c . B.pack . showMarkup =<< atomically v)- . S.mapM (liftA2 (>>) print pure)- . S.map (second (drop 1) . span (/= ' '))- . S.repeatM- . fmap B.unpack- $ receiveData c------------------------------------------------------------------------------------ | Generate a new name for an HTML element.-genName :: MonadState Int m => m String-genName = do- s <- get- modify (+1)- pure $ show s------------------------------------------------------------------------------------ | The API for 'Suave' pages.-type API = Get '[HTML] Markup- :<|> "suavemente" :> WebSocket------------------------------------------------------------------------------------ | Orphan instance allowing us to draw 'D.Diagram's.-instance ToMarkup (D.QDiagram B D.V2 Double D.Any) where- toMarkup = unsafeLazyByteString- . renderBS- . D.renderDia SVG- (SVGOptions (D.mkWidth 250) Nothing "" [] True)+import Web.Suavemente.Types+import Web.Suavemente.Core+import Web.Suavemente.Input+import Text.Blaze (Markup, ToMarkup (..))+import Text.InterpolatedString.Perl6 (qc, q)
+ src/Web/Suavemente/Core.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Web.Suavemente.Core where++import Control.Applicative (liftA2)+import Control.Concurrent.STM.TVar (TVar, writeTVar)+import Control.Monad.Except (throwError)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.STM (atomically)+import Control.Monad.State (evalStateT)+import Data.Aeson (Value, decode, Result (..))+import Data.Aeson.Types (Parser, parse)+import qualified Data.ByteString.Char8 as B+import qualified Data.Map.Strict as M+import Data.Proxy (Proxy (..))+import Network.Wai.Handler.Warp (run)+import Network.WebSockets (Connection, receiveData, sendTextData)+import Servant (Get, Handler, Capture, (:<|>)(..), (:>), serve, err404)+import Servant.API.WebSocket (WebSocket)+import Servant.HTML.Blaze (HTML)+import qualified Streaming as S+import qualified Streaming.Prelude as S+import Text.Blaze (preEscapedString, Markup, ToMarkup (..))+import Text.Blaze.Renderer.String (renderMarkup)+import Text.InterpolatedString.Perl6 (qc, q)+import Web.Suavemente.Types+++------------------------------------------------------------------------------+-- | Get a 'String' representation of a markup-able type. Useful for+-- constructing elements via quasiquotation.+showMarkup :: ToMarkup a => a -> String+showMarkup = renderMarkup . toMarkup+++------------------------------------------------------------------------------+-- | EXPLODE IF PARSING FAILS+fromResult :: Result a -> a+fromResult (Success a) = a+fromResult (Error s) = error s+++------------------------------------------------------------------------------+-- | Construct an '_iFold' field for 'Input's.+getEvents+ :: (Value -> Parser a)+ -> TVar a -- ^ The underlying 'TVar' to publish changes to.+ -> String -- ^ The name of the HTML input.+ -> IO () -- ^ Publish a change notification.+ -> S.Stream (S.Of ChangeEvent) IO ()+ -> S.Stream (S.Of ChangeEvent) IO ()+getEvents p t n update+ = S.mapMaybeM (+ \a@(ChangeEvent i z) ->+ case i == n of+ True -> do+ liftIO . atomically . writeTVar t . fromResult $ parse p z+ update+ pure Nothing+ False -> pure $ Just a+ )+++------------------------------------------------------------------------------+-- | HTML code to inject into all 'Suave' pages.+htmlPage :: (a -> Markup) -> String -> a -> Markup+htmlPage pp res a = preEscapedString $+ [q|+ <style>+ </style>|]+ +++ [q|+ <script>+ // from https://code.lengstorf.com/get-form-values-as-json/+ const isCheckbox = e => e.type === 'checkbox';+ const isMultiSelect = e => e.options && e.multiple;+ const getSelectValues = options => [].reduce.call(options, (values, option) => {+ return option.selected ? values.concat(option.value) : values;+ }, []);+++ let ws = new WebSocket("ws://localhost:8080/|] ++ res ++ [q|/ws");++ const keepAlive = () => {+ ws.send(JSON.stringify({}));+ setTimeout(keepAlive, 1000);+ };++ ws.onopen = e => keepAlive();+ ws.onmessage = e => document.getElementById("result").innerHTML = e.data;++ const onChangeFunc = e => {+ let element = e.target;+ let result = null;+ if (isCheckbox(element)) {+ result = element.checked;+ } else if (isMultiSelect(element)) {+ result = getSelectValues(element);+ } else if (element.type === 'range') {+ result = parseFloat(element.value);+ } else {+ result = element.value;+ }++ if (result !== null) {+ ws.send(JSON.stringify({ "element": element.id, "payload": result }));+ }+ }+ </script>+ |]+ +++ [qc|+ <div id="result">{renderMarkup $ pp a}</div>+ <table>+ |]+++------------------------------------------------------------------------------+-- | The API for 'Suave' pages.+type API = Get '[HTML] Markup+ :<|> "" :> "ws" :> WebSocket+++------------------------------------------------------------------------------+-- | The API for 'Suavely' pages.+type API2 = Capture "resource" String :> Get '[HTML] Markup+ :<|> Capture "resource" String :> "ws" :> WebSocket+++------------------------------------------------------------------------------+-- | Run a 'Suave' computation by spinning up its webpage at @localhost:8080@.+suavemente :: (a -> Markup) -> Suave a -> IO ()+suavemente pp w = do+ let ws = M.singleton "" $ SomeSuave pp w+ run 8080+ . serve (Proxy @API)+ $ htmlHandler ws "" :<|> socketHandler ws ""+++------------------------------------------------------------------------------+-- | Run a 'Suave' computation by spinning up its webpage at @localhost:8080@.+suavementely :: M.Map String SomeSuave -> IO ()+suavementely w = do+ run 8080+ . serve (Proxy @API2)+ $ htmlHandler w :<|> socketHandler w+++------------------------------------------------------------------------------+-- | 'Handler' endpoint for responding to 'Suave''s websockets.+socketHandler+ :: M.Map String SomeSuave+ -> String+ -> Connection+ -> Handler ()+socketHandler ws s c =+ case M.lookup s ws of+ Nothing -> throwError err404+ Just (SomeSuave pp w) -> liftIO $ do+ Input _ f a <- atomically $ evalStateT (suavely w) 0+ S.effects+ . f (sendTextData c . B.pack . renderMarkup . pp =<< atomically a)+ . S.mapM (liftA2 (>>) print pure)+ . S.mapMaybe id+ . S.repeatM+ . fmap decode+ $ receiveData c+++------------------------------------------------------------------------------+-- | Serve the static HTML.+htmlHandler :: M.Map String SomeSuave -> String -> Handler Markup+htmlHandler ws res =+ case M.lookup res ws of+ Nothing -> throwError err404+ Just (SomeSuave pp w) -> liftIO $ do+ Input html _ a <- atomically $ evalStateT (suavely w) 0+ a0 <- atomically a+ pure $ htmlPage pp res a0 <> html+
+ src/Web/Suavemente/Diagrams.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++module Web.Suavemente.Diagrams where++import Diagrams.Backend.SVG+import qualified Diagrams.Prelude as D+import Graphics.Svg.Core (renderBS)+import Text.Blaze (Markup, unsafeLazyByteString)+++sendDiagram :: Double -> D.Diagram B -> Markup+sendDiagram w+ = unsafeLazyByteString+ . renderBS+ . D.renderDia SVG+ (SVGOptions (D.mkWidth w) Nothing "" [] True)+
+ src/Web/Suavemente/Input.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -Wall #-}++module Web.Suavemente.Input where++import Control.Arrow ((&&&))+import Control.Concurrent.STM.TVar (newTVar, readTVar)+import Control.Monad.State.Class (MonadState (..), modify)+import Control.Monad.Trans.Class (lift)+import Data.Aeson (FromJSON (..), Value, withText)+import Data.Aeson.Types (Parser)+import Data.Bool (bool)+import Data.Colour.SRGB (Colour, sRGB24show, sRGB24read)+import Data.Text (unpack)+import Text.Blaze (preEscapedString, Markup, ToMarkup (..))+import Text.InterpolatedString.Perl6 (qc, q)+import Web.Suavemente.Core+import Web.Suavemente.Types++------------------------------------------------------------------------------+-- | Generate a new name for an HTML element.+genName :: MonadState Int m => m String+genName = do+ s <- get+ modify (+1)+ pure $ show s+++------------------------------------------------------------------------------+-- | Constructor for building 'Suave' inputs that are backed by HTML elements.+mkInput+ :: (Value -> Parser a)+ -> (String -> a -> Markup) -- ^ Function to construct the HTML element. The first parameter is what should be used for the element's 'id' attribute.+ -> a -- ^ The input's initial value.+ -> Suave a+mkInput p f a = Suave $ do+ name <- genName+ tvar <- lift $ newTVar a+ pure $ Input (f name a) (getEvents p tvar name) (readTVar tvar)+++------------------------------------------------------------------------------+-- | Create an input driven by an HTML slider.+slider+ :: (ToMarkup a, Num a, FromJSON a)+ => String -- ^ label+ -> a -- ^ min+ -> a -- ^ max+ -> a -- ^ initial value+ -> Suave a+slider label l u = mkInput parseJSON $ \name v ->+ preEscapedString+ [qc|<tr><td>+ <label for="{name}">{label}</label>+ </td><td>+ <input id="{name}" oninput="onChangeFunc(event)" type="range" min="{showMarkup l}" max="{showMarkup u}" value="{showMarkup v}" autocomplete="off">+ </td></tr>|]+++------------------------------------------------------------------------------+-- | Create an input driven by an HTML slider, whose domain is the real+-- numbers.+realSlider+ :: (ToMarkup a, Num a, Real a, FromJSON a)+ => String -- ^ label+ -> a -- ^ min+ -> a -- ^ max+ -> a -- ^ step+ -> a -- ^ initial value+ -> Suave a+realSlider label l u s = mkInput parseJSON $ \name v ->+ preEscapedString+ [qc|<tr><td>+ <label for="{name}">{label}</label>+ </td><td>+ <input id="{name}" oninput="onChangeFunc(event)" type="range" min="{showMarkup l}" max="{showMarkup u}" step="{showMarkup s}" value="{showMarkup v}" autocomplete="off">+ </td></tr>|]++------------------------------------------------------------------------------+-- | Create an input driven by the HTML input, type=color.+colorPicker+ :: (Ord a, Floating a, RealFrac a)+ => String -- ^ label+ -> Colour a -- ^ initial value+ -> Suave (Colour a)+colorPicker label =+ mkInput+ (withText "hex colour representation" (pure . sRGB24read . unpack)) $+ \name v ->+ preEscapedString+ [qc|<tr><td>+ <label for="{name}">{label}</label>+ </td><td>+ <input id="{name}" oninput="onChangeFunc(event)" type="color" value="{sRGB24show v}">+ </td></tr>|]++------------------------------------------------------------------------------+-- | Create an input driven by an HTML checkbox.+checkbox :: String -> Bool -> Suave Bool+checkbox label = mkInput parseJSON $ \name v ->+ preEscapedString+ [qc|<tr><td>+ <label for="{name}">{label}</label>+ </td><td>+ <input id="{name}" onchange="onChangeFunc(event)" type="checkbox" {bool ("" :: String) "checked='checked'" v} autocomplete="off">+ </td></tr>|]++------------------------------------------------------------------------------+-- | Create an input driven by an HTML checkbox without table tags.+checkbox_ :: String -> Bool -> Suave Bool+checkbox_ label = mkInput parseJSON $ \name v ->+ preEscapedString+ [qc|+ <label for="{name}">{label}</label>+ <input id="{name}" onchange="onChangeFunc(event)" type="checkbox" {bool ("" :: String) "checked='checked'" v} autocomplete="off">+ |]++------------------------------------------------------------------------------+-- | Create an input driven by an HTML textbox.+textbox+ :: String -- ^ label+ -> String -- ^ initial value+ -> Suave String+textbox label = mkInput parseJSON $ \name v ->+ preEscapedString+ [qc|<tr><td>+ <label for="{name}">{label}</label>+ </td><td>+ <input id="{name}" oninput="onChangeFunc(event)" type="text" value="{v}" autocomplete="off">+ </td></tr>|]++------------------------------------------------------------------------------+-- | Create an input driven by an HTML textbox without table tags.+textbox_+ :: String -- ^ label+ -> String -- ^ initial value+ -> Suave String+textbox_ label = mkInput parseJSON $ \name v ->+ preEscapedString+ [qc|+ <label for="{name}">{label}</label>+ <input id="{name}" oninput="onChangeFunc(event)" type="text" value="{v}" autocomplete="off">+ |]++------------------------------------------------------------------------------+-- | Create an input driven by an HTML select.+dropdown+ :: (FromJSON a, ToMarkup a, Eq a)+ => String -- ^ label+ -> [(String, a)]+ -> a+ -> Suave a+dropdown label opts = mkInput parseJSON $ \name d -> preEscapedString $+ mconcat $+ [ [qc|<tr><td><label for="{name}">{label}</label></td><td>|]+ , [qc|<select id="{name}" onchange="onChangeFunc(event)" autocomplete="off">|]+ ] +++ fmap+ (\(oname, oval) -> [qc|<option {if oval == d then "selected" else ""} value="{showMarkup oval}" >{oname}</option>|])+ opts+ +++ [ [q|</select>|]+ , [q|</td></tr>|]+ ]+++------------------------------------------------------------------------------+-- | Create an input for enums driven by an HTML select.+enumDropdown+ :: (FromJSON a, ToMarkup a, Enum a, Bounded a, Eq a)+ => String -- ^ label+ -> a+ -> Suave a+enumDropdown label =+ dropdown label $ fmap (showMarkup &&& id) [minBound .. maxBound]++------------------------------------------------------------------------------+-- | A checkbox that turns off a class display+checkboxShow :: String -> String -> Bool -> Suave Bool+checkboxShow label cl =+ mkInput parseJSON $ \name v ->+ preEscapedString (showJs cl) <>+ preEscapedString [qc|+ <label for="{name}">{label}</label>+ <input id="{name}" onchange="showJs('{cl}','{name}');onChangeFunc(event)" type="checkbox" {bool ("" :: String) "checked='checked'" v} autocomplete="off">+ |]++-- | js to show/hide a class based on a checkbox+showJs :: String -> String+showJs cl =+ [qc|+ <script>+ function showJs (cl, box) \{+ var vis = (document.getElementById(box).checked) ? "block" : "none";+ Array.from(document.getElementsByClassName("{cl}")).forEach(x => x.style.display = vis);+ };+ </script>+ |]++-- | Modify the markup of a Suave+markupF :: (Markup -> Markup) -> Suave a -> Suave a+markupF f (Suave sa) = Suave $ do+ Input markup s v <- sa+ pure $ Input (f markup) s v++-- | Wrap in a div+div' :: String -> String -> Suave a -> Suave a+div' cl st = markupF (\x ->+ preEscapedString [qc|<div class="{cl}" style="{st}">|] <>+ x <>+ preEscapedString "</div>")++-- | show/hide style string+display :: Bool -> String+display b = "display:" ++ bool "none" "block" b++-- | A checkbox that toggles visibility of another input (Suave a)+toggleInput :: String -> Bool -> String -> Suave a -> Suave (Bool, a)+toggleInput label start cl sa = do+ a <- div' cl (display start) sa+ c <- checkboxShow label cl start+ pure (c,a)
+ src/Web/Suavemente/Types.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}++module Web.Suavemente.Types where++import Control.Applicative (liftA2)+import Control.Monad.STM (STM)+import Control.Monad.State (StateT (..))+import Data.Aeson (FromJSON (..), Value (), genericParseJSON, Options (..), defaultOptions, camelTo2)+import GHC.Generics (Generic)+import qualified Streaming as S+import Text.Blaze (Markup, ToMarkup (..))+++------------------------------------------------------------------------------+-- | An applicative functor capable of getting input from an HTML page.+newtype Suave a = Suave+ { suavely :: StateT Int STM (Input a)+ } deriving Functor++instance Applicative Suave where+ pure = Suave . pure . pure+ Suave f <*> Suave a = Suave $ liftA2 (<*>) f a+++------------------------------------------------------------------------------+-- | An existentialized 'Suave'.+data SomeSuave where+ SomeSuave :: (a -> Markup) -> Suave a -> SomeSuave+++------------------------------------------------------------------------------+-- | An applicative functor can introduce new markup, and hook it up to the+-- event stream.+data Input a = Input+ { -- | The markup of the input.+ _iHtml :: Markup++ -- | A means of handling the event stream. The stream is of (name, value)+ -- pairs. An 'Input' is responsible for stripping its own events out of+ -- this stream.+ --+ -- The 'IO ()' action is to publish a change notification to the downstream+ -- computations.+ , _iFold :: IO ()+ -> S.Stream (S.Of ChangeEvent) IO ()+ -> S.Stream (S.Of ChangeEvent) IO ()++ -- | The current value of the 'Input'.+ , _iValue :: STM a+ } deriving Functor++instance Applicative Input where+ pure = Input mempty (const . const $ pure ()) . pure+ Input fh ff fv <*> Input ah af av =+ Input (fh <> ah)+ (liftA2 (.) ff af)+ (fv <*> av)+++------------------------------------------------------------------------------+-- | Change messages that come from the JS side.+data ChangeEvent = ChangeEvent+ { ceElement :: String+ , cePayload :: Value+ } deriving (Eq, Show, Generic)++instance FromJSON ChangeEvent where+ parseJSON = genericParseJSON $ defaultOptions+ { fieldLabelModifier = camelTo2 '_' . drop 2+ }+
suavemente.cabal view
@@ -1,11 +1,13 @@--- This file has been generated from package.yaml by hpack version 0.28.2.+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2. -- -- see: https://github.com/sol/hpack ----- hash: af625e3a3e5f5b67110256419c1fa138bf982ee015faf95cda8b75c3edd41ae8+-- hash: 58885356c7a367e7423d748d060b0d908641dfd106b68ab9d533e97a495f22b5 name: suavemente-version: 0.1.0.0+version: 0.2.0.0 synopsis: An applicative functor that seamlessly talks to HTML inputs. description: Please see the README on GitHub at <https://github.com/isovector/suavemente#readme> category: Web@@ -17,10 +19,9 @@ license: BSD3 license-file: LICENSE build-type: Simple-cabal-version: >= 1.10 extra-source-files:- ChangeLog.md README.md+ ChangeLog.md source-repository head type: git@@ -29,14 +30,21 @@ library exposed-modules: Web.Suavemente+ Web.Suavemente.Core+ Web.Suavemente.Diagrams+ Web.Suavemente.Input+ Web.Suavemente.Types other-modules: Paths_suavemente hs-source-dirs: src build-depends:- base >=4.7 && <5+ aeson+ , base >=4.7 && <5 , blaze-markup , bytestring+ , colour+ , containers , diagrams-core , diagrams-lib , diagrams-svg@@ -50,36 +58,7 @@ , stm , streaming , svg-builder- , transformers- , warp- , websockets- default-language: Haskell2010--executable suavemente-exe- main-is: Main.hs- other-modules:- Paths_suavemente- hs-source-dirs:- app- ghc-options: -threaded -rtsopts -with-rtsopts=-N- build-depends:- base >=4.7 && <5- , blaze-markup- , bytestring- , diagrams-core- , diagrams-lib- , diagrams-svg- , interpolatedstring-perl6- , lens- , mtl- , servant- , servant-blaze- , servant-server- , servant-websockets- , stm- , streaming- , suavemente- , svg-builder+ , text , transformers , warp , websockets