content: {-# 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
      }
  
  