etienne/etienne-moqueur
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge pull request 'newComponents' (#1) from newComponents into main

Browse source 
Reviewed-on: #1
This commit is contained in:
Etienne Werly 2023-06-18 19:47:03 +01:00
commit f6a38efa1c
20 changed files with 131 additions and 102 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
app/Main.hs
View file

@ -8,9 +8,9 @@ import Data.String
import Hakyll
import Text.Blaze.Html5 ( Html )
import Components
import Core.Compilers
import Core.Components
import Core.Render ( toCss )
import Core.Render
import Kit.Templates.Index ( indexTemplate )
import Kit.Templates.Post ( postTemplate )
@ -19,7 +19,7 @@ allTemplates :: [Component Html]
allTemplates = [postTemplate, indexTemplate]
allCss :: String
allCss = toCss . mconcat $ allTemplates
allCss = show . getCss . mconcat $ allTemplates
css :: Compiler (Item String)
css = makeItem allCss

3
etienne-moqueur.cabal
View file

@ -17,11 +17,12 @@ extra-source-files:
library
exposed-modules:
Components
Core.Colors
Core.Compilers
Core.Components
Core.Render
Core.Routers
Core.Writer
Css.Default
Info
Kit.Atoms.BreakpointQueries

56
src/Components.hs Normal file
View file

@ -0,0 +1,56 @@
module Components
( Prop(..)
, prop
, Component(..)
, new
, (<.>)
, getHtml
, getCss
) where
import Clay ( Css
, compact
, renderWith
)
import Core.Writer
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Text.Lazy ( unpack )
import Text.Blaze.Html.Renderer.String
import Text.Blaze.Html5 ( Html )
-- |Props are data on top of a component's html. They are aggregated when components are combined. The choice of structures for Prop ensures that there is no duplicate at compile time (e.g. the css of a button used 5 times is only rendered once.)
data Prop = Prop
{ cssMap :: Map.Map String Css
}
instance Semigroup Prop where
p1 <> p2 = Prop (Map.union (cssMap p1) (cssMap p2))
instance Monoid Prop where
mempty = Prop Map.empty
-- |Construct a Prop with a name, css.
prop :: String -> Css -> Prop
prop name css = Prop (Map.singleton name css)
type Component = Writer Prop
-- |Get a Component's Html
getHtml :: Component Html -> Html
getHtml = fst . runWriter
---- |Return a Component's Css as a String
--toCss :: Component a -> String
--toCss =
-- unpack
-- . renderWith compact []
-- . mconcat
-- . map snd
-- . Map.toList
-- . cssMap
-- . snd
-- . runWriter
-- |Get a Component's Css
getCss :: Component a -> Css
getCss = mconcat . map snd . Map.toList . cssMap . snd . runWriter

34
src/Core/Components.hs
View file

@ -1,34 +0,0 @@
module Core.Components
( Html
, Component(..)
, new
, (<.>)
) where
import Clay ( Css(..)
, compact
, renderWith
)
import Control.Monad.State.Lazy
import qualified Data.Map as Map
import Text.Blaze.Html.Renderer.String
import Text.Blaze.Html5 ( Html(..) )
type CssMap = Map.Map String Css
type Component = State CssMap
instance Semigroup a => Semigroup (Component a) where
parent <> child = (<>) <$> parent <*> child
instance Monoid a => Monoid (Component a) where
mempty = new "mempty" mempty mempty
new :: String -> Css -> a -> Component a
new name css html = do
cssMap <- get
put (Map.insert name css cssMap)
return html
(<.>) :: Applicative f => f (b -> c) -> f (a -> b) -> f (a -> c)
(<.>) = (<*>) . ((.) <$>)

38
src/Core/Render.hs
View file

@ -1,36 +1,12 @@
module Core.Render
( putHtml
, toCss
, putCss
) where
module Core.Render where
import Clay ( Css
, compact
, renderWith
)
import Control.Monad.State.Lazy
import Core.Components
import qualified Data.Map as Map
import Clay
import Data.Text.Lazy ( unpack )
import Text.Blaze.Html.Renderer.String
import Text.Blaze.Html5 ( Html )
import Text.Blaze.Html5
-- |render a Component's Html
putHtml :: Component Html -> IO ()
putHtml c = putStr . renderHtml . evalState c $ Map.empty
instance Show Css where
show = unpack . renderWith compact []
-- |Return a Component's Css as a String
toCss :: Component a -> String
toCss = unpack . toCssText
where
toCssText c =
renderWith compact []
. mconcat
. map snd
. Map.toList
. execState c
$ Map.empty
-- |render a Component's Css
putCss :: Component a -> IO ()
putCss = putStr . toCss
instance Show Html where
show = renderHtml

20
src/Core/Writer.hs Normal file
View file

@ -0,0 +1,20 @@
module Core.Writer
( Writer
, runWriter
, new
, (<.>)
) where
import Control.Monad.Writer.Lazy
instance (Monoid p, Semigroup a) => Semigroup (Writer p a) where
parent <> child = (<>) <$> parent <*> child
instance (Monoid p, Monoid a) => Monoid (Writer p a) where
mempty = new mempty mempty
new :: Monoid p => p -> a -> Writer p a
new = flip $ curry writer
(<.>) :: Applicative f => f (b -> c) -> f (a -> b) -> f (a -> c)
(<.>) = (<*>) . ((.) <$>)

4
src/Kit/Atoms/Button.hs
View file

@ -3,7 +3,7 @@ module Kit.Atoms.Button
) where
import Clay as C
import Core.Components
import Components
import Routes
import Text.Blaze.Html5 as H
@ -14,4 +14,4 @@ css = C.button ? do
fontWeight bold
buttonWithText :: Html -> Component Html
buttonWithText = new "buttonWithText" css . H.button
buttonWithText = new (prop "buttonWithText" css) . H.button

4
src/Kit/Atoms/ButtonLink.hs
View file

@ -4,7 +4,7 @@ module Kit.Atoms.ButtonLink
import Clay as C
hiding ( (!) )
import Core.Components
import Components
import Kit.Constants.Colors
import Routes
import Text.Blaze.Html5 as H
@ -32,4 +32,4 @@ css = C.a # byClass "button" ? do
backgroundColor (grays @ 70)
buttonLink :: Route -> Html -> Component Html
buttonLink ref = new "buttonLink" css . buttonLinkHtml ref
buttonLink ref = new (prop "buttonLink" css) . buttonLinkHtml ref

4
src/Kit/Atoms/Container.hs
View file

@ -3,7 +3,7 @@ module Kit.Atoms.Container
) where
import Clay
import Core.Components
import Components
import Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes as A
@ -13,4 +13,4 @@ css = element ".container" ? do
marginLeft <> marginRight $ auto
container :: Component (Html -> Html)
container = new "container" css $ H.div H.! class_ "container"
container = new (prop "container" css) $ H.div H.! class_ "container"

4
src/Kit/Atoms/Header.hs
View file

@ -3,7 +3,7 @@ module Kit.Atoms.Header
) where
import Clay as C
import Core.Components
import Components
import Kit.Atoms.BreakpointQueries
import Kit.Constants.Colors
import Kit.Constants.Spacing
@ -20,4 +20,4 @@ css = C.header ? do
header' :: Component (Html -> Html)
header' = new "header" css H.header
header' = new (prop "header" css) H.header

25
src/Kit/Atoms/Image.hs
View file

@ -5,7 +5,7 @@ module Kit.Atoms.Image
) where
import Clay as C
import Core.Components
import Components
import Routes
import Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes as A
@ -20,7 +20,7 @@ baseCss = C.img ? do
img' :: FilePath -> String -> Component Html
img' file description =
new "img" baseCss
new (prop "img" baseCss)
$ H.img
H.! A.src (stringValue . path . Img $ file)
H.! A.alt (stringValue description)
@ -29,19 +29,28 @@ img' file description =
imgWithShape :: Shape -> FilePath -> String -> Component Html
imgWithShape Square file description = img' file description
imgWithShape Circle file description =
new "img circle"
(C.img # byClass "circle" ? uniform borderRadius (pct 50))
new
(prop "img circle"
(C.img # byClass "circle" ? uniform borderRadius (pct 50))
)
(H.! class_ "circle")
<*> img' file description
imgWithShape Rounded file description =
new "img rounded"
(C.img # byClass "rounded" ? uniform borderRadius (pct 10))
new
(prop "img rounded"
(C.img # byClass "rounded" ? uniform borderRadius (pct 10))
)
(H.! class_ "rounded")
<*> img' file description
imgWithShape Drop file description =
new
"img drop"
(C.img # byClass "drop" ? borderRadius (pct 50) (pct 50) (pct 50) (pct 10)
(prop
"img drop"
(C.img # byClass "drop" ? borderRadius (pct 50)
(pct 50)
(pct 50)
(pct 10)
)
)
(H.! class_ "drop")
<*> img' file description

4
src/Kit/Atoms/Stylesheet.hs
View file

@ -3,14 +3,14 @@ module Kit.Atoms.Stylesheet
) where
import Clay ( Css )
import Core.Components
import Components
import Routes
import Text.Blaze.Html5
import Text.Blaze.Html5.Attributes
stylesheet :: Route -> Css -> Component Html
stylesheet route css =
new (path route) css
new (prop (path route) css)
$ link
! rel "stylesheet"
! (href . stringValue . path $ route)

2
src/Kit/Molecules/DefaultCss.hs
View file

@ -4,7 +4,7 @@ module Kit.Molecules.DefaultCss
import Clay as C
import qualified Clay.Pseudo as P
import Core.Components
import Components
import Kit.Atoms.Stylesheet
import Kit.Atoms.Typography
import Kit.Constants.Colors

5
src/Kit/Molecules/ProfileBio.hs
View file

@ -3,7 +3,7 @@ module Kit.Molecules.ProfileBio
) where
import Clay as C
import Core.Components
import Components
import Kit.Atoms.BreakpointQueries
import Kit.Constants.Colors
import Text.Blaze.Html5 as H
@ -21,4 +21,5 @@ css = byClass "profile-bio" & do
profileBio :: String -> Component Html
profileBio bio =
new "profileBio" css $ H.div H.! class_ "profile-bio" $ H.p (toHtml bio)
new (prop "profileBio" css) $ H.div H.! class_ "profile-bio" $ H.p
(toHtml bio)

4
src/Kit/Molecules/ProfileContent.hs
View file

@ -3,7 +3,7 @@ module Kit.Molecules.ProfileContent
) where
import Clay as C
import Core.Components
import Components
import Kit.Constants.Colors
import Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes as A
@ -17,7 +17,7 @@ css = byClass "profile-content" & do
profileContent :: String -> String -> Component Html
profileContent auth desc =
new "profileContent" css
new (prop "profileContent" css)
$ H.div
H.! class_ "profile-content"
$ H.hgroup

4
src/Kit/Molecules/ProfilePic.hs
View file

@ -3,7 +3,7 @@ module Kit.Molecules.ProfilePic
) where
import Clay as C
import Core.Components
import Components
import Kit.Atoms.BreakpointQueries
import Kit.Atoms.Image
import Text.Blaze.Html5 as H
@ -21,5 +21,5 @@ css = byClass "profile-pic" & do
profilePic :: FilePath -> String -> Component Html
profilePic file altText =
new "profilePic" css (H.div H.! class_ "profile-pic")
new (prop "profilePic" css) (H.div H.! class_ "profile-pic")
<*> imgWithShape Rounded file altText

2
src/Kit/Organisms/Head.hs
View file

@ -3,7 +3,7 @@ module Kit.Organisms.Head
, defaultHead
) where
import Core.Components
import Components
import Kit.Molecules.DefaultCss
import Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes as A

2
src/Kit/Organisms/ProfileHeader.hs
View file

@ -1,6 +1,6 @@
module Kit.Organisms.ProfileHeader where
import Core.Components
import Components
import Info
import Kit.Atoms.Container
import Kit.Atoms.Header

6
src/Kit/Templates/Index.hs
View file

@ -3,8 +3,8 @@ module Kit.Templates.Index
, indexTemplate
) where
import Core.Components
import Core.Render ( putHtml )
import Components
import Core.Render
import Kit.Atoms.Button
import Kit.Atoms.ButtonLink
import Kit.Organisms.Head
@ -23,4 +23,4 @@ indexTemplate =
docTypeHtml <$> defaultHead "Very first try" <> (body <$> indexBody)
main :: IO ()
main = putHtml indexTemplate
main = print $ getHtml indexTemplate

6
src/Kit/Templates/Post.hs
View file

@ -3,8 +3,8 @@ module Kit.Templates.Post
, main
) where
import Core.Components
import Core.Render ( putHtml )
import Components
import Core.Render
import Kit.Organisms.Head
import Text.Blaze.Html5 as H
hiding ( main )
@ -17,4 +17,4 @@ postTemplate = docTypeHtml <$> defaultHead "$title$" <> pure
)
main :: IO ()
main = putHtml postTemplate
main = print $ getHtml postTemplate