{-# 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 (..))
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
data SomeSuave where
SomeSuave :: (a -> Markup) -> Suave a -> SomeSuave
data Input a = Input
{
_iHtml :: Markup
, _iFold :: IO ()
-> S.Stream (S.Of ChangeEvent) IO ()
-> S.Stream (S.Of ChangeEvent) IO ()
, _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)
data ChangeEvent = ChangeEvent
{ ceElement :: String
, cePayload :: Value
} deriving (Eq, Show, Generic)
instance FromJSON ChangeEvent where
parseJSON = genericParseJSON $ defaultOptions
{ fieldLabelModifier = camelTo2 '_' . drop 2
}