{-# 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'

@
helloWorld :: 'View' context ()
helloWorld =
  'el' \"Hello World\"
@
-}
newtype View c a = View {forall c a. View c a -> Eff '[Reader c] (Html a)
html :: Eff '[Reader c] (Html a)}


instance IsString (View c ()) where
  fromString :: String -> View c ()
fromString String
s = Eff '[Reader c] (Html ()) -> View c ()
forall c a. Eff '[Reader c] (Html a) -> View c a
View (Eff '[Reader c] (Html ()) -> View c ())
-> Eff '[Reader c] (Html ()) -> View c ()
forall a b. (a -> b) -> a -> b
$ Html () -> Eff '[Reader c] (Html ())
forall a. a -> Eff '[Reader c] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html () -> Eff '[Reader c] (Html ()))
-> Html () -> Eff '[Reader c] (Html ())
forall a b. (a -> b) -> a -> b
$ Text -> Html ()
Atomic.text (String -> Text
pack String
s)


runView :: forall c a. c -> View c a -> Html a
runView :: forall c a. c -> View c a -> Html a
runView c
c (View Eff '[Reader c] (Html a)
eff) = do
  Eff '[] (Html a) -> Html a
forall a. HasCallStack => Eff '[] a -> a
runPureEff (Eff '[] (Html a) -> Html a) -> Eff '[] (Html a) -> Html a
forall a b. (a -> b) -> a -> b
$ c -> Eff '[Reader c] (Html a) -> Eff '[] (Html a)
forall r (es :: [(* -> *) -> * -> *]) a.
HasCallStack =>
r -> Eff (Reader r : es) a -> Eff es a
runReader c
c Eff '[Reader c] (Html a)
eff


instance Functor (View c) where
  fmap :: forall a b. (a -> b) -> View c a -> View c b
fmap a -> b
f (View Eff '[Reader c] (Html a)
eff) = Eff '[Reader c] (Html b) -> View c b
forall c a. Eff '[Reader c] (Html a) -> View c a
View (Eff '[Reader c] (Html b) -> View c b)
-> Eff '[Reader c] (Html b) -> View c b
forall a b. (a -> b) -> a -> b
$ do
    Html a
html <- Eff '[Reader c] (Html a)
eff
    Html b -> Eff '[Reader c] (Html b)
forall a. a -> Eff '[Reader c] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html b -> Eff '[Reader c] (Html b))
-> Html b -> Eff '[Reader c] (Html b)
forall a b. (a -> b) -> a -> b
$ (a -> b) -> Html a -> Html b
forall a b. (a -> b) -> Html a -> Html b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Html a
html
instance Applicative (View ctx) where
  pure :: forall a. a -> View ctx a
pure a
a = Eff '[Reader ctx] (Html a) -> View ctx a
forall c a. Eff '[Reader c] (Html a) -> View c a
View (Eff '[Reader ctx] (Html a) -> View ctx a)
-> Eff '[Reader ctx] (Html a) -> View ctx a
forall a b. (a -> b) -> a -> b
$ Html a -> Eff '[Reader ctx] (Html a)
forall a. a -> Eff '[Reader ctx] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html a -> Eff '[Reader ctx] (Html a))
-> Html a -> Eff '[Reader ctx] (Html a)
forall a b. (a -> b) -> a -> b
$ a -> Html a
forall a. a -> Html a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
  liftA2 :: (a -> b -> c) -> View ctx a -> View ctx b -> View ctx c
  liftA2 :: forall a b c.
(a -> b -> c) -> View ctx a -> View ctx b -> View ctx c
liftA2 a -> b -> c
abc (View Eff '[Reader ctx] (Html a)
va) (View Eff '[Reader ctx] (Html b)
vb) = Eff '[Reader ctx] (Html c) -> View ctx c
forall c a. Eff '[Reader c] (Html a) -> View c a
View (Eff '[Reader ctx] (Html c) -> View ctx c)
-> Eff '[Reader ctx] (Html c) -> View ctx c
forall a b. (a -> b) -> a -> b
$ do
    Html a
ha <- Eff '[Reader ctx] (Html a)
va
    Html b
hb <- Eff '[Reader ctx] (Html b)
vb
    Html c -> Eff '[Reader ctx] (Html c)
forall a. a -> Eff '[Reader ctx] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html c -> Eff '[Reader ctx] (Html c))
-> Html c -> Eff '[Reader ctx] (Html c)
forall a b. (a -> b) -> a -> b
$ (a -> b -> c) -> Html a -> Html b -> Html c
forall a b c. (a -> b -> c) -> Html a -> Html b -> Html c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> b -> c
abc Html a
ha Html b
hb
  View Eff '[Reader ctx] (Html a)
va *> :: forall a b. View ctx a -> View ctx b -> View ctx b
*> View Eff '[Reader ctx] (Html b)
vb = Eff '[Reader ctx] (Html b) -> View ctx b
forall c a. Eff '[Reader c] (Html a) -> View c a
View (Eff '[Reader ctx] (Html b) -> View ctx b)
-> Eff '[Reader ctx] (Html b) -> View ctx b
forall a b. (a -> b) -> a -> b
$ do
    Html a
ha <- Eff '[Reader ctx] (Html a)
va
    Html b
hb <- Eff '[Reader ctx] (Html b)
vb
    Html b -> Eff '[Reader ctx] (Html b)
forall a. a -> Eff '[Reader ctx] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html b -> Eff '[Reader ctx] (Html b))
-> Html b -> Eff '[Reader ctx] (Html b)
forall a b. (a -> b) -> a -> b
$ Html a
ha Html a -> Html b -> Html b
forall a b. Html a -> Html b -> Html b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Html b
hb
instance Monad (View ctx) where
  >> :: forall a b. View ctx a -> View ctx b -> View ctx b
(>>) = View ctx a -> View ctx b -> View ctx b
forall a b. View ctx a -> View ctx b -> View ctx b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
  (>>=) :: forall a b. View ctx a -> (a -> View ctx b) -> View ctx b
  -- TEST: appending Empty
  View Eff '[Reader ctx] (Html a)
ea >>= :: forall a b. View ctx a -> (a -> View ctx b) -> View ctx b
>>= a -> View ctx b
famb = Eff '[Reader ctx] (Html b) -> View ctx b
forall c a. Eff '[Reader c] (Html a) -> View c a
View (Eff '[Reader ctx] (Html b) -> View ctx b)
-> Eff '[Reader ctx] (Html b) -> View ctx b
forall a b. (a -> b) -> a -> b
$ do
    a
a :: a <- (.value) (Html a -> a) -> Eff '[Reader ctx] (Html a) -> Eff '[Reader ctx] a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff '[Reader ctx] (Html a)
ea
    let View Eff '[Reader ctx] (Html b)
eb :: View ctx b = a -> View ctx b
famb a
a
    Html b
hb <- Eff '[Reader ctx] (Html b)
eb
    Html b -> Eff '[Reader ctx] (Html b)
forall a. a -> Eff '[Reader ctx] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html b -> Eff '[Reader ctx] (Html b))
-> Html b -> Eff '[Reader ctx] (Html b)
forall a b. (a -> b) -> a -> b
$ Html b
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 :: forall c. View c c
context = Eff '[Reader c] (Html c) -> View c c
forall c a. Eff '[Reader c] (Html a) -> View c a
View (Eff '[Reader c] (Html c) -> View c c)
-> Eff '[Reader c] (Html c) -> View c c
forall a b. (a -> b) -> a -> b
$ do
  c
c <- forall r (es :: [(* -> *) -> * -> *]).
(HasCallStack, Reader r :> es) =>
Eff es r
ask @c
  Html c -> Eff '[Reader c] (Html c)
forall a. a -> Eff '[Reader c] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html c -> Eff '[Reader c] (Html c))
-> Html c -> Eff '[Reader c] (Html c)
forall a b. (a -> b) -> a -> b
$ c -> Html c
forall a. a -> Html a
forall (f :: * -> *) a. Applicative f => a -> f a
pure c
c


addContext :: ctx -> View ctx () -> View c ()
addContext :: forall ctx c. ctx -> View ctx () -> View c ()
addContext ctx
c (View Eff '[Reader ctx] (Html ())
eff) = Eff '[Reader c] (Html ()) -> View c ()
forall c a. Eff '[Reader c] (Html a) -> View c a
View (Eff '[Reader c] (Html ()) -> View c ())
-> Eff '[Reader c] (Html ()) -> View c ()
forall a b. (a -> b) -> a -> b
$ do
  Html () -> Eff '[Reader c] (Html ())
forall a. a -> Eff '[Reader c] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html () -> Eff '[Reader c] (Html ()))
-> Html () -> Eff '[Reader c] (Html ())
forall a b. (a -> b) -> a -> b
$ Eff '[] (Html ()) -> Html ()
forall a. HasCallStack => Eff '[] a -> a
runPureEff (Eff '[] (Html ()) -> Html ()) -> Eff '[] (Html ()) -> Html ()
forall a b. (a -> b) -> a -> b
$ ctx -> Eff '[Reader ctx] (Html ()) -> Eff '[] (Html ())
forall r (es :: [(* -> *) -> * -> *]) a.
HasCallStack =>
r -> Eff (Reader r : es) a -> Eff es a
runReader ctx
c Eff '[Reader ctx] (Html ())
eff


modifyContext
  :: forall ctx0 ctx1. (ctx0 -> ctx1) -> View ctx1 () -> View ctx0 ()
modifyContext :: forall ctx0 ctx1. (ctx0 -> ctx1) -> View ctx1 () -> View ctx0 ()
modifyContext ctx0 -> ctx1
f (View Eff '[Reader ctx1] (Html ())
eff) = Eff '[Reader ctx0] (Html ()) -> View ctx0 ()
forall c a. Eff '[Reader c] (Html a) -> View c a
View (Eff '[Reader ctx0] (Html ()) -> View ctx0 ())
-> Eff '[Reader ctx0] (Html ()) -> View ctx0 ()
forall a b. (a -> b) -> a -> b
$ do
  ctx0
ctx0 <- forall r (es :: [(* -> *) -> * -> *]).
(HasCallStack, Reader r :> es) =>
Eff es r
ask @ctx0
  Html () -> Eff '[Reader ctx0] (Html ())
forall a. a -> Eff '[Reader ctx0] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html () -> Eff '[Reader ctx0] (Html ()))
-> Html () -> Eff '[Reader ctx0] (Html ())
forall a b. (a -> b) -> a -> b
$ Eff '[] (Html ()) -> Html ()
forall a. HasCallStack => Eff '[] a -> a
runPureEff (Eff '[] (Html ()) -> Html ()) -> Eff '[] (Html ()) -> Html ()
forall a b. (a -> b) -> a -> b
$ ctx1 -> Eff '[Reader ctx1] (Html ()) -> Eff '[] (Html ())
forall r (es :: [(* -> *) -> * -> *]) a.
HasCallStack =>
r -> Eff (Reader r : es) a -> Eff es a
runReader (ctx0 -> ctx1
f ctx0
ctx0) Eff '[Reader ctx1] (Html ())
eff


-- Html ---------------------------------------------

tag :: Text -> View c () -> View c ()
tag :: forall c. Text -> View c () -> View c ()
tag = Bool -> Text -> View c () -> View c ()
forall c. Bool -> Text -> View c () -> View c ()
tag' Bool
False


tag' :: Bool -> Text -> View c () -> View c ()
tag' :: forall c. Bool -> Text -> View c () -> View c ()
tag' Bool
inline Text
n (View Eff '[Reader c] (Html ())
eff) = Eff '[Reader c] (Html ()) -> View c ()
forall c a. Eff '[Reader c] (Html a) -> View c a
View (Eff '[Reader c] (Html ()) -> View c ())
-> Eff '[Reader c] (Html ()) -> View c ()
forall a b. (a -> b) -> a -> b
$ do
  Html ()
content <- Eff '[Reader c] (Html ())
eff
  Html () -> Eff '[Reader c] (Html ())
forall a. a -> Eff '[Reader c] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html () -> Eff '[Reader c] (Html ()))
-> Html () -> Eff '[Reader c] (Html ())
forall a b. (a -> b) -> a -> b
$ Bool -> Text -> Html () -> Html ()
Atomic.tag' Bool
inline Text
n Html ()
content


text :: Text -> View c ()
text :: forall c. Text -> View c ()
text Text
t = Eff '[Reader c] (Html ()) -> View c ()
forall c a. Eff '[Reader c] (Html a) -> View c a
View (Eff '[Reader c] (Html ()) -> View c ())
-> Eff '[Reader c] (Html ()) -> View c ()
forall a b. (a -> b) -> a -> b
$ Html () -> Eff '[Reader c] (Html ())
forall a. a -> Eff '[Reader c] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html () -> Eff '[Reader c] (Html ()))
-> Html () -> Eff '[Reader c] (Html ())
forall a b. (a -> b) -> a -> b
$ Text -> Html ()
Atomic.text Text
t


none :: View c ()
none :: forall c. View c ()
none = Eff '[Reader c] (Html ()) -> View c ()
forall c a. Eff '[Reader c] (Html a) -> View c a
View (Eff '[Reader c] (Html ()) -> View c ())
-> Eff '[Reader c] (Html ()) -> View c ()
forall a b. (a -> b) -> a -> b
$ Html () -> Eff '[Reader c] (Html ())
forall a. a -> Eff '[Reader c] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Html ()
Atomic.none


raw :: Text -> View c ()
raw :: forall c. Text -> View c ()
raw Text
t = Eff '[Reader c] (Html ()) -> View c ()
forall c a. Eff '[Reader c] (Html a) -> View c a
View (Eff '[Reader c] (Html ()) -> View c ())
-> Eff '[Reader c] (Html ()) -> View c ()
forall a b. (a -> b) -> a -> b
$ Html () -> Eff '[Reader c] (Html ())
forall a. a -> Eff '[Reader c] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html () -> Eff '[Reader c] (Html ()))
-> Html () -> Eff '[Reader c] (Html ())
forall a b. (a -> b) -> a -> b
$ Text -> Html ()
Atomic.raw Text
t


-- Attributes -----------------------------------------

instance Attributable (View c a) where
  modAttributes :: (Map Text Text -> Map Text Text) -> View c a -> View c a
modAttributes Map Text Text -> Map Text Text
f (View Eff '[Reader c] (Html a)
eff) = Eff '[Reader c] (Html a) -> View c a
forall c a. Eff '[Reader c] (Html a) -> View c a
View (Eff '[Reader c] (Html a) -> View c a)
-> Eff '[Reader c] (Html a) -> View c a
forall a b. (a -> b) -> a -> b
$ do
    Html a
h <- Eff '[Reader c] (Html a)
eff
    Html a -> Eff '[Reader c] (Html a)
forall a. a -> Eff '[Reader c] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html a -> Eff '[Reader c] (Html a))
-> Html a -> Eff '[Reader c] (Html a)
forall a b. (a -> b) -> a -> b
$ (Map Text Text -> Map Text Text) -> Html a -> Html a
forall h.
Attributable h =>
(Map Text Text -> Map Text Text) -> h -> h
modAttributes Map Text Text -> Map Text Text
f Html a
h


instance Styleable (View c a) where
  modCSS :: ([Rule] -> [Rule]) -> View c a -> View c a
modCSS [Rule] -> [Rule]
f (View Eff '[Reader c] (Html a)
eff) = Eff '[Reader c] (Html a) -> View c a
forall c a. Eff '[Reader c] (Html a) -> View c a
View (Eff '[Reader c] (Html a) -> View c a)
-> Eff '[Reader c] (Html a) -> View c a
forall a b. (a -> b) -> a -> b
$ do
    Html a
h <- Eff '[Reader c] (Html a)
eff
    Html a -> Eff '[Reader c] (Html a)
forall a. a -> Eff '[Reader c] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html a -> Eff '[Reader c] (Html a))
-> Html a -> Eff '[Reader c] (Html a)
forall a b. (a -> b) -> a -> b
$ ([Rule] -> [Rule]) -> Html a -> Html a
forall h. Styleable h => ([Rule] -> [Rule]) -> h -> h
modCSS [Rule] -> [Rule]
f Html a
h