diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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) + diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,8 +1,14 @@ # suavemente -[![Build Status](https://travis-ci.org/isovector/suavemente.svg?branch=master)](https://travis-ci.org/isovector/suavemente) | [Hackage][hackage] +[![Build Status](https://travis-ci.org/isovector/suavemente.svg?branch=master)][build] +[![Hackage](https://img.shields.io/hackage/v/suavemente.svg)][hackage] +[![Stackage LTS](https://www.stackage.org/package/suavemente/badge/lts)][stackage] +[![Stackage Nightly](https://www.stackage.org/package/suavemente/badge/nightly)][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! diff --git a/app/Main.hs b/app/Main.hs deleted file mode 100644 --- a/app/Main.hs +++ /dev/null @@ -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) - diff --git a/src/Web/Suavemente.hs b/src/Web/Suavemente.hs --- a/src/Web/Suavemente.hs +++ b/src/Web/Suavemente.hs @@ -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| - - - - |] - - ------------------------------------------------------------------------------- --- | 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| - - - - |] - - ------------------------------------------------------------------------------- --- | Create an input driven by an HTML checkbox. -checkbox :: String -> Bool -> Suave Bool -checkbox label = mkInput $ \name v -> - preEscapedString - [qc| - - - - |] - - ------------------------------------------------------------------------------- --- | Create an input driven by an HTML textbox. -textbox - :: String -- ^ label - -> String -- ^ initial value - -> Suave String -textbox label = mkInput $ \name v -> - preEscapedString - [qc| - - - - |] - - ------------------------------------------------------------------------------- --- | HTML code to inject into all 'Suave' pages. -htmlPage :: ToMarkup a => a -> Markup -htmlPage a = preEscapedString $ - [q| - |] - ++ - [qc| - -
{showMarkup a}
- - |] - - ------------------------------------------------------------------------------- --- | '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) diff --git a/src/Web/Suavemente/Core.hs b/src/Web/Suavemente/Core.hs new file mode 100644 --- /dev/null +++ b/src/Web/Suavemente/Core.hs @@ -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| + |] + ++ + [q| + + |] + ++ + [qc| +
{renderMarkup $ pp a}
+
+ |] + + +------------------------------------------------------------------------------ +-- | 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 + diff --git a/src/Web/Suavemente/Diagrams.hs b/src/Web/Suavemente/Diagrams.hs new file mode 100644 --- /dev/null +++ b/src/Web/Suavemente/Diagrams.hs @@ -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) + diff --git a/src/Web/Suavemente/Input.hs b/src/Web/Suavemente/Input.hs new file mode 100644 --- /dev/null +++ b/src/Web/Suavemente/Input.hs @@ -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||] + + +------------------------------------------------------------------------------ +-- | 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||] + +------------------------------------------------------------------------------ +-- | 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||] + +------------------------------------------------------------------------------ +-- | Create an input driven by an HTML checkbox. +checkbox :: String -> Bool -> Suave Bool +checkbox label = mkInput parseJSON $ \name v -> + preEscapedString + [qc||] + +------------------------------------------------------------------------------ +-- | Create an input driven by an HTML checkbox without table tags. +checkbox_ :: String -> Bool -> Suave Bool +checkbox_ label = mkInput parseJSON $ \name v -> + preEscapedString + [qc| + + + |] + +------------------------------------------------------------------------------ +-- | Create an input driven by an HTML textbox. +textbox + :: String -- ^ label + -> String -- ^ initial value + -> Suave String +textbox label = mkInput parseJSON $ \name v -> + preEscapedString + [qc||] + +------------------------------------------------------------------------------ +-- | 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| + + + |] + +------------------------------------------------------------------------------ +-- | 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||] + ] + + +------------------------------------------------------------------------------ +-- | 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| + + + |] + +-- | js to show/hide a class based on a checkbox +showJs :: String -> String +showJs cl = + [qc| + + |] + +-- | 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|
|] <> + x <> + preEscapedString "
") + +-- | 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) diff --git a/src/Web/Suavemente/Types.hs b/src/Web/Suavemente/Types.hs new file mode 100644 --- /dev/null +++ b/src/Web/Suavemente/Types.hs @@ -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 + } + diff --git a/suavemente.cabal b/suavemente.cabal --- a/suavemente.cabal +++ b/suavemente.cabal @@ -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 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
+ + + +
+ + + +
+ + + +
+ + + +
+ + + +
|] + , [qc||] + , [q|