Merge pull request 'FileTree' (#16) from FileTree into main

Reviewed-on: #16
This commit is contained in:
Etienne Werly 2023-06-19 21:27:04 +01:00
commit ad606b4938
19 changed files with 176 additions and 77 deletions

View file

@ -11,7 +11,6 @@ and this project adheres to the
### Backend
* Add Atom and RSS feeds
* Add sitemap.xml
### Planned utils
@ -19,6 +18,12 @@ and this project adheres to the
* Add font subsetting (or svg icons support / fonts)
* Add images utils such as conversion to png, avif and other formats (see hip and JuicyPixels)
## 0.2.0.0 - 2023-06-19
* Added sitemap.xml
* Declaration of Props changed with `add(...)` functions.
* Props now have a FileTree structure to gather assets.
## 0.1.0.0 - 2023-06-18
* Added colours and palettes support (with colour package back-end)

View file

@ -11,6 +11,7 @@ import Text.Blaze.Html
import Components
import Core.Compilers
import Core.Render
import Utils.FileTree
import Kit.Templates.Index ( indexTemplate )
import Kit.Templates.Post ( postTemplate )
@ -18,6 +19,9 @@ import Kit.Templates.Post ( postTemplate )
allTemplates :: [Component Html]
allTemplates = [postTemplate, indexTemplate]
assets :: [FilePath]
assets = map tail . getPaths . getAssets . mconcat $ allTemplates
allCss :: String
allCss = show . getCss . mconcat $ allTemplates
@ -52,7 +56,7 @@ main = hakyll $ do
route $ constRoute "css/default.css"
compile css
match "assets/img/*" $ do
match (fromList . map fromFilePath $ assets) $ do
route idRoute
compile copyFileCompiler

View file

@ -48,6 +48,7 @@ library
Kit.Templates.Sitemap
Routes
Utils.Clay
Utils.FileTree
Utils.XML
other-modules:
Paths_etienne_moqueur
@ -68,6 +69,7 @@ library
, hakyll
, hashable
, mtl
, split
, text
default-language: Haskell2010
@ -93,6 +95,7 @@ executable etienne-moqueur-exe
, hakyll
, hashable
, mtl
, split
, text
default-language: Haskell2010
@ -119,5 +122,6 @@ test-suite etienne-moqueur-test
, hakyll
, hashable
, mtl
, split
, text
default-language: Haskell2010

View file

@ -1,9 +1,9 @@
name: etienne-moqueur
version: 0.1.0.0
version: 0.2.0.0
license: BSD3
author: "etienne"
maintainer: "etienne@moqueur.chat"
copyright: "2022 etienne"
copyright: "2023 etienne"
extra-source-files:
- README.md
@ -31,6 +31,7 @@ dependencies:
- mtl
- containers
- hashable
- split
ghc-options:
- -Wall

View file

@ -4,8 +4,12 @@ module Components
, Component(..)
, new
, (<.>)
, addCss
, addAsset
, addAsset'
, getHtml
, getCss
, getAssets
) where
import Clay ( Css
@ -14,43 +18,49 @@ import Clay ( Css
)
import Core.Writer
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Text.Lazy ( unpack )
import Routes
import Text.Blaze.Html
import Text.Blaze.Html.Renderer.String
import Text.Blaze.Html5 ( Html )
import Utils.FileTree
-- |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
{ cssMap :: Map.Map String Css
, assetsTree :: FileTree
}
instance Semigroup Prop where
p1 <> p2 = Prop (Map.union (cssMap p1) (cssMap p2))
p1 <> p2 = Prop { cssMap = Map.union (cssMap p1) (cssMap p2)
, assetsTree = assetsTree p1 <> assetsTree 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)
mempty = Prop Map.empty mempty
type Component = Writer Prop
prop :: String -> Css -> Prop
prop name css = Prop (Map.singleton name css) mempty
-- |Add a name and css to a Prop.
addCss :: String -> Css -> Component ()
addCss name css = tell $ Prop (Map.singleton name css) mempty
-- |Add an asset to the Prop's tree.
addAsset :: FilePath -> Component ()
addAsset fp = tell $ Prop Map.empty (build fp)
addAsset' :: Route -> Component ()
addAsset' r = tell $ Prop Map.empty (build' r)
-- |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
-- |Get a Component's assets tree
getAssets :: Component a -> FileTree
getAssets = assetsTree . snd . runWriter

View file

@ -1,5 +1,6 @@
module Core.Writer
( Writer
, tell
, runWriter
, new
, (<.>)

View file

@ -13,5 +13,7 @@ css = C.button ? do
color white
fontWeight bold
buttonWithText :: Html -> Component Html
buttonWithText = new (prop "buttonWithText" css) . H.button
buttonWithText :: Component (Html -> Html)
buttonWithText = do
addCss "buttonWithText" css
return H.button

View file

@ -31,5 +31,7 @@ css = C.a # byClass "button" ? do
color (grays @ 100)
backgroundColor (grays @ 70)
buttonLink :: Route -> Html -> Component Html
buttonLink ref = new (prop "buttonLink" css) . buttonLinkHtml ref
buttonLink :: Route -> Component (Html -> Html)
buttonLink ref = do
addCss "buttonLink" css
return $ buttonLinkHtml ref

View file

@ -13,4 +13,6 @@ css = element ".container" ? do
marginLeft <> marginRight $ auto
container :: Component (Html -> Html)
container = new (prop "container" css) $ H.div H.! class_ "container"
container = do
addCss "container" css
return $ H.div H.! class_ "container"

View file

@ -20,4 +20,6 @@ css = C.header ? do
header' :: Component (Html -> Html)
header' = new (prop "header" css) H.header
header' = do
addCss "header" css
return H.header

View file

@ -19,38 +19,32 @@ baseCss = C.img ? do
maxWidth (pct 100)
img' :: FilePath -> String -> Component Html
img' file description =
new (prop "img" baseCss)
$ H.img
H.! A.src (stringValue . path . Img $ file)
H.! A.alt (stringValue description)
img' file description = do
addCss "img" baseCss
addAsset' $ Img file
return $ H.img H.! A.src (stringValue . path . Img $ file) H.! A.alt
(stringValue description)
imgWithShape :: Shape -> FilePath -> String -> Component Html
imgWithShape Square file description = img' file description
imgWithShape Circle file description =
new
(prop "img circle"
(C.img # byClass "circle" ? uniform borderRadius (pct 50))
)
(H.! class_ "circle")
<*> img' file description
do
addCss "img circle"
(C.img # byClass "circle" ? uniform borderRadius (pct 50))
return (H.! class_ "circle")
<*> img' file description
imgWithShape Rounded file description =
new
(prop "img rounded"
(C.img # byClass "rounded" ? uniform borderRadius (pct 10))
)
(H.! class_ "rounded")
<*> img' file description
do
addCss "img rounded"
(C.img # byClass "rounded" ? uniform borderRadius (pct 10))
return (H.! class_ "rounded")
<*> img' file description
imgWithShape Drop file description =
new
(prop
"img drop"
(C.img # byClass "drop" ? borderRadius (pct 50)
(pct 50)
(pct 50)
(pct 10)
)
do
addCss
"img drop"
(C.img # byClass "drop" ? borderRadius (pct 50) (pct 50) (pct 50) (pct 10)
)
(H.! class_ "drop")
<*> img' file description
return (H.! class_ "drop")
<*> img' file description

View file

@ -9,8 +9,6 @@ import Text.Blaze.Html5
import Text.Blaze.Html5.Attributes
stylesheet :: Route -> Css -> Component Html
stylesheet route css =
new (prop (path route) css)
$ link
! rel "stylesheet"
! (href . stringValue . path $ route)
stylesheet route css = do
addCss (path route) css
return $ link ! rel "stylesheet" ! (href . stringValue . path $ route)

View file

@ -20,6 +20,6 @@ css = byClass "profile-bio" & do
C.width (C.em 20)
profileBio :: String -> Component Html
profileBio bio =
new (prop "profileBio" css) $ H.div H.! class_ "profile-bio" $ H.p
(toHtml bio)
profileBio bio = do
addCss "profileBio" css
return $ H.div H.! class_ "profile-bio" $ H.p (toHtml bio)

View file

@ -16,8 +16,9 @@ css = byClass "profile-content" & do
borderLeft (px 10) solid $ secondary @ 50
profileContent :: String -> String -> Component Html
profileContent auth desc =
new (prop "profileContent" css)
profileContent auth desc = do
addCss "profileContent" css
return
$ H.div
H.! class_ "profile-content"
$ H.hgroup

View file

@ -21,5 +21,7 @@ css = byClass "profile-pic" & do
profilePic :: FilePath -> String -> Component Html
profilePic file altText =
new (prop "profilePic" css) (H.div H.! class_ "profile-pic")
<*> imgWithShape Rounded file altText
do
addCss "profilePic" css
return $ H.div H.! class_ "profile-pic"
<*> imgWithShape Rounded file altText

View file

@ -15,8 +15,11 @@ import Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes as A
indexBody :: Component Html
indexBody =
mconcat [profileHeader, buttonWithText "Click!", buttonLink Blog "All posts"]
indexBody = mconcat
[ profileHeader
, buttonWithText <*> pure "Click!"
, buttonLink Blog <*> pure "All posts"
]
indexTemplate :: Component Html
indexTemplate =

59
src/Utils/FileTree.hs Normal file
View file

@ -0,0 +1,59 @@
module Utils.FileTree
( FileTree(..)
, build
, build'
, getPaths
) where
import Control.Monad
import Data.List
import Data.List.Split
import qualified Data.Set as Set
import Data.Tree
import Routes
type FileName = String
type FileTree = Tree FileName
instance Semigroup FileTree where
Node root dirs <> Node root' dirs'
| root == root' = Node root $ merge dirs dirs'
| otherwise = error "In FileTree Semigroup; cannot merge different folders"
instance Monoid FileTree where
mempty = Node "" []
-- |Build a FileTree from a FilePath. The dir separator is '/'.
build :: FilePath -> FileTree
build = addNode . splitOn "/"
where
addNode [] = Node "" []
addNode [x ] = Node x []
addNode (x : xs) = Node x [addNode xs]
build' :: Route -> FileTree
build' = build . path
-- |Merge two lists of Trees by merging Nodes at the same level that have the same value.
merge :: Ord a => [Tree a] -> [Tree a] -> [Tree a]
merge list [] = list
merge [] list' = list'
merge list list' = case ord of
EQ ->
Node (rootLabel minimum) (merge (subForest minimum) (subForest minimum'))
: merge rest rest'
LT -> minimum : merge rest sorted'
GT -> minimum' : merge sorted rest'
where
sorted = sort list
sorted' = sort list'
minimum = head sorted
minimum' = head sorted'
rest = tail sorted
rest' = tail sorted'
ord = compare (rootLabel minimum) (rootLabel minimum')
-- | Extract all different paths from a FileTree, from root to file.
getPaths :: FileTree -> [FilePath]
getPaths (Node x [] ) = [x]
getPaths (Node x txs) = fmap ((x ++) . ("/" ++)) . join . map getPaths $ txs

View file

@ -18,7 +18,7 @@
# resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml
resolver:
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/24.yaml
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/26.yaml
# User packages to be built.
# Various formats can be used as shown in the example below.
@ -41,6 +41,8 @@ packages:
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
#
# extra-deps: []
extra-deps:
- clay-0.14.0@sha256:382eced24317f9ed0f7a0a4789cdfc6fc8dd32895cdb0c4ea50a1613bee08af3,2128
# Override default flag values for local packages and extra-deps
# flags: {}

View file

@ -3,11 +3,18 @@
# For more information, please see the documentation at:
# https://docs.haskellstack.org/en/stable/lock_files
packages: []
packages:
- completed:
hackage: clay-0.14.0@sha256:382eced24317f9ed0f7a0a4789cdfc6fc8dd32895cdb0c4ea50a1613bee08af3,2128
pantry-tree:
sha256: 63de34c432705d98e4309392eb0c3901fec45d4bbf9f0aab750db114467533b1
size: 2256
original:
hackage: clay-0.14.0@sha256:382eced24317f9ed0f7a0a4789cdfc6fc8dd32895cdb0c4ea50a1613bee08af3,2128
snapshots:
- completed:
size: 619403
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/24.yaml
sha256: 98f5bee5bf07ff25263d7061e03c34595bfca543b611f9d3da5c95f2a6c8d723
sha256: 5a59b2a405b3aba3c00188453be172b85893cab8ebc352b1ef58b0eae5d248a2
size: 650475
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/26.yaml
original:
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/24.yaml
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/26.yaml