Core change: Components use a Writer Monad instead of State.

Replacing Core.Components is the Components module where Props are
defined with a Monoid structure. Component is a synonym of Writer Prop.

app/Main.hs

@@ -8,9 +8,8 @@ import           Data.String
 import           Hakyll
 import           Text.Blaze.Html5               ( Html )
 
+import           Components
 import           Core.Compilers
-import           Core.Components
-import           Core.Render                    ( toCss )
 
 import           Kit.Templates.Index            ( indexTemplate )
 import           Kit.Templates.Post             ( postTemplate )

etienne-moqueur.cabal

@@ -17,11 +17,11 @@ 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

src/Components.hs

@@ -0,0 +1,57 @@
+module Components
+  ( Prop(..)
+  , prop
+  , Component(..)
+  , new
+  , (<.>)
+  , putHtml
+  , toCss
+  , putCss
+  ) 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
+
+-- |render a Component's Html
+putHtml :: Component Html -> IO ()
+putHtml = putStr . renderHtml . 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
+
+-- |render a Component's Css
+putCss :: Component a -> IO ()
+putCss = putStr . toCss

src/Core/Components.hs

@@ -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)
-(<.>) = (<*>) . ((.) <$>)

src/Core/Render.hs

@@ -1,36 +0,0 @@
-module Core.Render
-  ( putHtml
-  , toCss
-  , putCss
-  ) where
-
-import           Clay                           ( Css
-                                                , compact
-                                                , renderWith
-                                                )
-import           Control.Monad.State.Lazy
-import           Core.Components
-import qualified Data.Map                      as Map
-import           Data.Text.Lazy                 ( unpack )
-import           Text.Blaze.Html.Renderer.String
-import           Text.Blaze.Html5               ( Html )
-
--- |render a Component's Html
-putHtml :: Component Html -> IO ()
-putHtml c = putStr . renderHtml . evalState c $ Map.empty
-
--- |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

src/Core/Writer.hs

@@ -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)
+(<.>) = (<*>) . ((.) <$>)

src/Kit/Atoms/Button.hs

@@ -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

src/Kit/Atoms/ButtonLink.hs

@@ -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

src/Kit/Atoms/Container.hs

@@ -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"

src/Kit/Atoms/Header.hs

@@ -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

src/Kit/Atoms/Image.hs

@@ -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

src/Kit/Atoms/Stylesheet.hs

@@ -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)

src/Kit/Molecules/DefaultCss.hs

@@ -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

src/Kit/Molecules/ProfileBio.hs

@@ -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)

src/Kit/Molecules/ProfileContent.hs

@@ -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

src/Kit/Molecules/ProfilePic.hs

@@ -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

src/Kit/Organisms/Head.hs

@@ -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

src/Kit/Organisms/ProfileHeader.hs

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

src/Kit/Templates/Index.hs

@@ -3,8 +3,7 @@ module Kit.Templates.Index
   , indexTemplate
   ) where
 
-import           Core.Components
-import           Core.Render                    ( putHtml )
+import           Components
 import           Kit.Atoms.Button
 import           Kit.Atoms.ButtonLink
 import           Kit.Organisms.Head

src/Kit/Templates/Post.hs

@@ -3,8 +3,7 @@ module Kit.Templates.Post
   , main
   ) where
 
-import           Core.Components
-import           Core.Render                    ( putHtml )
+import           Components
 import           Kit.Organisms.Head
 import           Text.Blaze.Html5              as H
                                          hiding ( main )