Merge pull request 'FileTree' (#16) from FileTree into main
Reviewed-on: #16
This commit is contained in:
commit
ad606b4938
19 changed files with 176 additions and 77 deletions
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -1,5 +1,6 @@
|
|||
module Core.Writer
|
||||
( Writer
|
||||
, tell
|
||||
, runWriter
|
||||
, new
|
||||
, (<.>)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
59
src/Utils/FileTree.hs
Normal 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
|
|
@ -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: {}
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue