{-# 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
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)
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. 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.
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.
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
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 :: [(* -> *) -> * -> *]). (Reader r :> es) => Eff es r
ask
addContext :: context -> View context () -> View c ()
addContext :: forall context c. context -> View context () -> View c ()
addContext context
ctx View context ()
vw = do
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 :: [(* -> *) -> * -> *]).
(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 :: [(* -> *) -> * -> *]).
(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{$sel:contents:ViewState :: [Content]
contents = [Content] -> [Content]
f ViewState
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 :: [(* -> *) -> * -> *]).
(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{$sel:css:ViewState :: CSS
css = CSS -> CSS
f ViewState
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])
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{$sel:children:Element :: [Content]
children = Element
e.children [Content] -> [Content] -> [Content]
forall a. Semigroup a => a -> a -> a
<> [Content]
cs}
tag :: Text -> Mod -> View c () -> View c ()
tag :: forall c. Text -> Mod -> View c () -> View c ()
tag Text
nm Mod
f View c ()
ct = do
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 Mod -> Mod
forall a b. (a -> b) -> a -> b
$ [Class] -> Map Text Text -> Attributes
Attributes [] []
let elm :: Element
elm = Text -> Attributes -> [Content] -> Element
Element Text
nm 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
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{$sel:other:Attributes :: Map Text Text
other = Map Text Text
atts}