{-# 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 () , Input () , suavemente -- * Inputs , textbox , checkbox , slider , realSlider -- * Making New Inputs , mkInput , showMarkup -- * Reexports , Markup , ToMarkup (..) , qc , 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|