content: {-# LANGUAGE AllowAmbiguousTypes #-}
  
  module Web.Hyperbole.View.Types where
  
  import Data.Kind (Type)
  import Data.String (IsString (..))
  import Data.Text (Text, pack)
  import Effectful
  import Effectful.Reader.Static
  import Web.Atomic.Html (Html (..))
  import Web.Atomic.Html qualified as Atomic
  import Web.Atomic.Types
  
  
  -- View ------------------------------------------------------------
  
  {- | 'View's are HTML fragments with a 'context'
  
  @
  #EMBED Example/Docs/BasicPage.hs helloWorld
  @
  -}
  newtype View c a = View {html :: Eff '[Reader c] (Html a)}
  
  
  instance IsString (View c ()) where
    fromString s = View $ pure $ Atomic.text (pack s)
  
  
  runView :: forall c a. c -> View c a -> Html a
  runView c (View eff) = do
    runPureEff $ runReader c eff
  
  
  instance Functor (View c) where
    fmap f (View eff) = View $ do
      html <- eff
      pure $ fmap f html
  instance Applicative (View ctx) where
    pure a = View $ pure $ pure a
    liftA2 :: (a -> b -> c) -> View ctx a -> View ctx b -> View ctx c
    liftA2 abc (View va) (View vb) = View $ do
      ha <- va
      hb <- vb
      pure $ liftA2 abc ha hb
    View va *> View vb = View $ do
      ha <- va
      hb <- vb
      pure $ ha *> hb
  instance Monad (View ctx) where
    (>>) = (*>)
    (>>=) :: forall a b. View ctx a -> (a -> View ctx b) -> View ctx b
    -- TEST: appending Empty
    View ea >>= famb = View $ do
      a :: a <- (.value) <$> ea
      let View eb :: View ctx b = famb a
      hb <- eb
      pure $ hb
  
  
  -- Context -----------------------------------------
  
  type family ViewContext (v :: Type) where
    ViewContext (View c x) = c
    ViewContext (View c x -> View c x) = c
  
  
  -- TEST: appending Empty
  context :: forall c. View c c
  context = View $ do
    c <- ask @c
    pure $ pure c
  
  
  addContext :: ctx -> View ctx () -> View c ()
  addContext c (View eff) = View $ do
    pure $ runPureEff $ runReader c eff
  
  
  modifyContext
    :: forall ctx0 ctx1. (ctx0 -> ctx1) -> View ctx1 () -> View ctx0 ()
  modifyContext f (View eff) = View $ do
    ctx0 <- ask @ctx0
    pure $ runPureEff $ runReader (f ctx0) eff
  
  
  -- Html ---------------------------------------------
  
  tag :: Text -> View c () -> View c ()
  tag = tag' False
  
  
  tag' :: Bool -> Text -> View c () -> View c ()
  tag' inline n (View eff) = View $ do
    content <- eff
    pure $ Atomic.tag' inline n content
  
  
  text :: Text -> View c ()
  text t = View $ pure $ Atomic.text t
  
  
  none :: View c ()
  none = View $ pure Atomic.none
  
  
  raw :: Text -> View c ()
  raw t = View $ pure $ Atomic.raw t
  
  
  -- Attributes -----------------------------------------
  
  instance Attributable (View c a) where
    modAttributes f (View eff) = View $ do
      h <- eff
      pure $ modAttributes f h
  
  
  instance Styleable (View c a) where
    modCSS f (View eff) = View $ do
      h <- eff
      pure $ modCSS f h
  