{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedLists #-}

module Web.View.View where

import Data.Map qualified as M
import Data.String (IsString (..))
import Data.Text (Text, pack)
import Effectful
import Effectful.Reader.Static
import Effectful.State.Static.Local as ES
import Web.View.Types


-- * Views


{- | Views are HTML fragments that carry all 'CSS' used by any child element.

> view :: View c ()
> view = col (pad 10 . gap 10) $ do
>   el bold "Hello"
>   el_ "World"

They can also have a context which can be used to create type-safe or context-aware elements. See 'Web.View.Element.table' for an example
-}
newtype View context a = View {forall context a.
View context a -> Eff '[Reader context, State ViewState] a
viewState :: Eff [Reader context, State ViewState] a}
  deriving newtype ((forall a b. (a -> b) -> View context a -> View context b)
-> (forall a b. a -> View context b -> View context a)
-> Functor (View context)
forall a b. a -> View context b -> View context a
forall a b. (a -> b) -> View context a -> View context b
forall context a b. a -> View context b -> View context a
forall context a b. (a -> b) -> View context a -> View context b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall context a b. (a -> b) -> View context a -> View context b
fmap :: forall a b. (a -> b) -> View context a -> View context b
$c<$ :: forall context a b. a -> View context b -> View context a
<$ :: forall a b. a -> View context b -> View context a
Functor, Functor (View context)
Functor (View context) =>
(forall a. a -> View context a)
-> (forall a b.
    View context (a -> b) -> View context a -> View context b)
-> (forall a b c.
    (a -> b -> c)
    -> View context a -> View context b -> View context c)
-> (forall a b. View context a -> View context b -> View context b)
-> (forall a b. View context a -> View context b -> View context a)
-> Applicative (View context)
forall context. Functor (View context)
forall a. a -> View context a
forall context a. a -> View context a
forall a b. View context a -> View context b -> View context a
forall a b. View context a -> View context b -> View context b
forall a b.
View context (a -> b) -> View context a -> View context b
forall context a b.
View context a -> View context b -> View context a
forall context a b.
View context a -> View context b -> View context b
forall context a b.
View context (a -> b) -> View context a -> View context b
forall a b c.
(a -> b -> c) -> View context a -> View context b -> View context c
forall context a b c.
(a -> b -> c) -> View context a -> View context b -> View context c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall context a. a -> View context a
pure :: forall a. a -> View context a
$c<*> :: forall context a b.
View context (a -> b) -> View context a -> View context b
<*> :: forall a b.
View context (a -> b) -> View context a -> View context b
$cliftA2 :: forall context a b c.
(a -> b -> c) -> View context a -> View context b -> View context c
liftA2 :: forall a b c.
(a -> b -> c) -> View context a -> View context b -> View context c
$c*> :: forall context a b.
View context a -> View context b -> View context b
*> :: forall a b. View context a -> View context b -> View context b
$c<* :: forall context a b.
View context a -> View context b -> View context a
<* :: forall a b. View context a -> View context b -> View context a
Applicative, Applicative (View context)
Applicative (View context) =>
(forall a b.
 View context a -> (a -> View context b) -> View context b)
-> (forall a b. View context a -> View context b -> View context b)
-> (forall a. a -> View context a)
-> Monad (View context)
forall context. Applicative (View context)
forall a. a -> View context a
forall context a. a -> View context a
forall a b. View context a -> View context b -> View context b
forall a b.
View context a -> (a -> View context b) -> View context b
forall context a b.
View context a -> View context b -> View context b
forall context a b.
View context a -> (a -> View context b) -> View context b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall context a b.
View context a -> (a -> View context b) -> View context b
>>= :: forall a b.
View context a -> (a -> View context b) -> View context b
$c>> :: forall context a b.
View context a -> View context b -> View context b
>> :: forall a b. View context a -> View context b -> View context b
$creturn :: forall context a. a -> View context a
return :: forall a. a -> View context a
Monad)


instance IsString (View context ()) where
  fromString :: String -> View context ()
fromString String
s = ([Content] -> [Content]) -> View context ()
forall context. ([Content] -> [Content]) -> View context ()
viewModContents ([Content] -> [Content] -> [Content]
forall a b. a -> b -> a
const [Text -> Content
Text (String -> Text
pack String
s)])


data ViewState = ViewState
  { ViewState -> [Content]
contents :: [Content]
  , ViewState -> CSS
css :: CSS
  }


instance Semigroup ViewState where
  ViewState
va <> :: ViewState -> ViewState -> ViewState
<> ViewState
vb = [Content] -> CSS -> ViewState
ViewState (ViewState
va.contents [Content] -> [Content] -> [Content]
forall a. Semigroup a => a -> a -> a
<> ViewState
vb.contents) (ViewState
va.css CSS -> CSS -> CSS
forall a. Semigroup a => a -> a -> a
<> ViewState
vb.css)


-- | Extract the 'ViewState' from a 'View'
runView :: context -> View context () -> ViewState
runView :: forall context. context -> View context () -> ViewState
runView context
ctx (View Eff '[Reader context, State ViewState] ()
ef) =
  Eff '[] ViewState -> ViewState
forall a. HasCallStack => Eff '[] a -> a
runPureEff (Eff '[] ViewState -> ViewState)
-> (Eff '[Reader context, State ViewState] () -> Eff '[] ViewState)
-> Eff '[Reader context, State ViewState] ()
-> ViewState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ViewState -> Eff '[State ViewState] () -> Eff '[] ViewState
forall s (es :: [(* -> *) -> * -> *]) a.
HasCallStack =>
s -> Eff (State s : es) a -> Eff es s
execState ([Content] -> CSS -> ViewState
ViewState [] []) (Eff '[State ViewState] () -> Eff '[] ViewState)
-> (Eff '[Reader context, State ViewState] ()
    -> Eff '[State ViewState] ())
-> Eff '[Reader context, State ViewState] ()
-> Eff '[] ViewState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. context
-> Eff '[Reader context, State ViewState] ()
-> Eff '[State ViewState] ()
forall r (es :: [(* -> *) -> * -> *]) a.
HasCallStack =>
r -> Eff (Reader r : es) a -> Eff es a
runReader context
ctx (Eff '[Reader context, State ViewState] () -> ViewState)
-> Eff '[Reader context, State ViewState] () -> ViewState
forall a b. (a -> b) -> a -> b
$ Eff '[Reader context, State ViewState] ()
ef


-- | Get the current context
context :: View context context
context :: forall context. View context context
context = Eff '[Reader context, State ViewState] context
-> View context context
forall context a.
Eff '[Reader context, State ViewState] a -> View context a
View Eff '[Reader context, State ViewState] context
forall r (es :: [(* -> *) -> * -> *]).
(HasCallStack, Reader r :> es) =>
Eff es r
ask


-- | Run a view with a specific `context` in a parent 'View' with a different context. This can be used to create type safe view functions, like 'Web.View.Element.table'
addContext :: context -> View context () -> View c ()
addContext :: forall context c. context -> View context () -> View c ()
addContext context
ctx View context ()
vw = do
  -- runs the sub-view in a different context, saving its state
  -- we need to MERGE it
  let st :: ViewState
st = context -> View context () -> ViewState
forall context. context -> View context () -> ViewState
runView context
ctx View context ()
vw
  Eff '[Reader c, State ViewState] () -> View c ()
forall context a.
Eff '[Reader context, State ViewState] a -> View context a
View (Eff '[Reader c, State ViewState] () -> View c ())
-> Eff '[Reader c, State ViewState] () -> View c ()
forall a b. (a -> b) -> a -> b
$ (ViewState -> ViewState) -> Eff '[Reader c, State ViewState] ()
forall s (es :: [(* -> *) -> * -> *]).
(HasCallStack, State s :> es) =>
(s -> s) -> Eff es ()
ES.modify ((ViewState -> ViewState) -> Eff '[Reader c, State ViewState] ())
-> (ViewState -> ViewState) -> Eff '[Reader c, State ViewState] ()
forall a b. (a -> b) -> a -> b
$ \ViewState
s -> ViewState
s ViewState -> ViewState -> ViewState
forall a. Semigroup a => a -> a -> a
<> ViewState
st


viewModContents :: ([Content] -> [Content]) -> View context ()
viewModContents :: forall context. ([Content] -> [Content]) -> View context ()
viewModContents [Content] -> [Content]
f = Eff '[Reader context, State ViewState] () -> View context ()
forall context a.
Eff '[Reader context, State ViewState] a -> View context a
View (Eff '[Reader context, State ViewState] () -> View context ())
-> Eff '[Reader context, State ViewState] () -> View context ()
forall a b. (a -> b) -> a -> b
$ do
  (ViewState -> ViewState)
-> Eff '[Reader context, State ViewState] ()
forall s (es :: [(* -> *) -> * -> *]).
(HasCallStack, State s :> es) =>
(s -> s) -> Eff es ()
ES.modify ((ViewState -> ViewState)
 -> Eff '[Reader context, State ViewState] ())
-> (ViewState -> ViewState)
-> Eff '[Reader context, State ViewState] ()
forall a b. (a -> b) -> a -> b
$ \ViewState
s -> ViewState
s{contents = f s.contents}


viewModCss :: (CSS -> CSS) -> View context ()
viewModCss :: forall context. (CSS -> CSS) -> View context ()
viewModCss CSS -> CSS
f = Eff '[Reader context, State ViewState] () -> View context ()
forall context a.
Eff '[Reader context, State ViewState] a -> View context a
View (Eff '[Reader context, State ViewState] () -> View context ())
-> Eff '[Reader context, State ViewState] () -> View context ()
forall a b. (a -> b) -> a -> b
$ do
  (ViewState -> ViewState)
-> Eff '[Reader context, State ViewState] ()
forall s (es :: [(* -> *) -> * -> *]).
(HasCallStack, State s :> es) =>
(s -> s) -> Eff es ()
ES.modify ((ViewState -> ViewState)
 -> Eff '[Reader context, State ViewState] ())
-> (ViewState -> ViewState)
-> Eff '[Reader context, State ViewState] ()
forall a b. (a -> b) -> a -> b
$ \ViewState
s -> ViewState
s{css = f s.css}


viewAddClasses :: [Class] -> View c ()
viewAddClasses :: forall c. [Class] -> View c ()
viewAddClasses [Class]
clss = do
  (CSS -> CSS) -> View c ()
forall context. (CSS -> CSS) -> View context ()
viewModCss ((CSS -> CSS) -> View c ()) -> (CSS -> CSS) -> View c ()
forall a b. (a -> b) -> a -> b
$ \CSS
cm -> (Class -> CSS -> CSS) -> CSS -> [Class] -> CSS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Class -> CSS -> CSS
addClsDef CSS
cm [Class]
clss
 where
  addClsDef :: Class -> CSS -> CSS
  addClsDef :: Class -> CSS -> CSS
addClsDef Class
c = Selector -> Class -> CSS -> CSS
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Class
c.selector Class
c


viewAddContent :: Content -> View c ()
viewAddContent :: forall c. Content -> View c ()
viewAddContent Content
ct =
  ([Content] -> [Content]) -> View c ()
forall context. ([Content] -> [Content]) -> View context ()
viewModContents ([Content] -> [Content] -> [Content]
forall a. Semigroup a => a -> a -> a
<> [Item [Content]
Content
ct])


-- | Inserts contents into the first child element
viewInsertContents :: [Content] -> View c ()
viewInsertContents :: forall c. [Content] -> View c ()
viewInsertContents [Content]
cs = ([Content] -> [Content]) -> View c ()
forall context. ([Content] -> [Content]) -> View context ()
viewModContents [Content] -> [Content]
insert
 where
  insert :: [Content] -> [Content]
insert [Node Element
e] = [Element -> Content
Node (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$ Element -> Element
insertEl Element
e]
  insert [Content]
cnt = [Content]
cnt [Content] -> [Content] -> [Content]
forall a. Semigroup a => a -> a -> a
<> [Content]
cs
  insertEl :: Element -> Element
insertEl Element
e = Element
e{children = e.children <> cs}


-- * Creating new Elements


{- | Create a new element constructor with the given tag name

> aside :: Mod -> View c () -> View c ()
> aside = tag "aside"
-}
tag :: Text -> Mod -> View c () -> View c ()
tag :: forall c. Text -> Mod -> View c () -> View c ()
tag Text
n = (Attributes -> [Content] -> Element)
-> Mod -> View c () -> View c ()
forall c.
(Attributes -> [Content] -> Element)
-> Mod -> View c () -> View c ()
tag' (Text -> Attributes -> [Content] -> Element
element Text
n)


{- | Create a new element constructor with a custom element
 -
> span :: Mod -> View c () -> View c ()
> span = tag' (Element True) "span"
-}
tag' :: (Attributes -> [Content] -> Element) -> Mod -> View c () -> View c ()
tag' :: forall c.
(Attributes -> [Content] -> Element)
-> Mod -> View c () -> View c ()
tag' Attributes -> [Content] -> Element
mkElem Mod
f View c ()
ct = do
  -- Applies the modifier and merges children into parent
  c
ctx <- View c c
forall context. View context context
context
  let st :: ViewState
st = c -> View c () -> ViewState
forall context. context -> View context () -> ViewState
runView c
ctx View c ()
ct
  let ats :: Attributes
ats = Mod
f Attributes
forall a. Monoid a => a
mempty
  let elm :: Element
elm = Attributes -> [Content] -> Element
mkElem Attributes
ats ViewState
st.contents
  Content -> View c ()
forall c. Content -> View c ()
viewAddContent (Content -> View c ()) -> Content -> View c ()
forall a b. (a -> b) -> a -> b
$ Element -> Content
Node Element
elm
  [Class] -> View c ()
forall c. [Class] -> View c ()
viewAddClasses ([Class] -> View c ()) -> [Class] -> View c ()
forall a b. (a -> b) -> a -> b
$ CSS -> [Class]
forall k a. Map k a -> [a]
M.elems ViewState
st.css
  [Class] -> View c ()
forall c. [Class] -> View c ()
viewAddClasses Element
elm.attributes.classes


{- | Set an attribute, replacing existing value

> hlink :: Text -> View c () -> View c ()
> hlink url content = tag "a" (att "href" url) content
-}
att :: Name -> AttValue -> Mod
att :: Text -> Text -> Mod
att Text
n Text
v Attributes
attributes =
  let atts :: Map Text Text
atts = Text -> Text -> Map Text Text -> Map Text Text
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
n Text
v Attributes
attributes.other
   in Attributes
attributes{other = atts}