Compare commits

...

5 commits

Author SHA1 Message Date
7107b0e99f Stash 2023-07-18 19:06:45 +02:00
a9c51756fc Some code clean-up. 2023-07-18 16:26:26 +02:00
a051dba102 First working example!
The parser for $img$ is very rough: it does not yet take other arguments
in img, and in the resource gathering stage, I hand picked the test post
but it would be preferable to have a pattern and parse from it.
2023-07-18 15:31:54 +02:00
f5052e12bf First try: Problems with parsing $ in hs code...
Hakyll thinks every $ is a template but some are the ($) operator...
2023-07-18 03:30:33 +02:00
a384414d4c Add post with basic img include syntax. 2023-07-08 16:06:58 +02:00
12 changed files with 131 additions and 52 deletions

View file

@ -9,6 +9,7 @@ import Hakyll
import Components
import Core.Compilers
import Core.Parsers
import Core.Render ( )
import Routes
import Utils.FileTree
@ -16,37 +17,37 @@ import Utils.Routes
import Kit.Templates.Archive
import Kit.Templates.Index
import Kit.Templates.Post ( postTemplate )
import Kit.Templates.Post
import Kit.Templates.Sitemap
resources :: Component ()
resources = do
mconcat [postTemplate, indexTemplate, archiveTemplate]
return ()
assets :: [FilePath]
assets = map tail . getPaths . getAssets $ resources
allCss :: String
allCss = getCss resources
css :: Compiler (Item String)
css = makeItem allCss
cssHash :: Identifier
cssHash = fromString . show . hash $ allCss
main :: IO ()
main = hakyll $ do
main = do
parseResult <- mkParse parseFile (local $ Post "test.md")
let resources =
parseResult
>> mconcat [postTemplate, indexTemplate, archiveTemplate]
>> return ()
runHakyll resources
runHakyll :: Component () -> IO ()
runHakyll res = hakyll $ do
let assets = map (drop 1) . getPaths . getAssets $ res
allCss = getCss res
css = makeItem allCss
cssHash = fromString . show . hash $ allCss
tags <- buildTags (patrn $ Post "*.md") (fromCapture . patrn $ Tag "*")
match (patrn $ Post "*.md") $ do
route $ setExtension "html"
compile $ do
pandocCompiler
getResourceBody
>>= applyAsTemplate postCtx
>>= renderPandoc
>>= saveSnapshot "content"
>>= componentTemplate postTemplate defaultContext
>>= componentTemplate postTemplate postCtx
. fmap demoteHeaders
create ["index.html"] $ do
@ -61,7 +62,7 @@ main = hakyll $ do
(archiveCtx tags)
create [cssHash] $ do
route $ constRoute . tail . path $ DefaultStylesheet
route $ constRoute . local $ DefaultStylesheet
compile css
match (fromList . map fromFilePath $ assets) $ do

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.2 MiB

View file

@ -20,6 +20,7 @@ library
Components
Core.Colors
Core.Compilers
Core.Parsers
Core.Render
Core.Routers
Core.Rules
@ -91,6 +92,7 @@ library
, hashable
, megaparsec
, mtl
, pandoc
, split
, text
default-language: Haskell2010
@ -118,6 +120,7 @@ executable etienne-moqueur-exe
, hashable
, megaparsec
, mtl
, pandoc
, split
, text
default-language: Haskell2010
@ -146,6 +149,7 @@ test-suite etienne-moqueur-test
, hashable
, megaparsec
, mtl
, pandoc
, split
, text
default-language: Haskell2010

View file

@ -33,6 +33,7 @@ dependencies:
- hashable
- split
- megaparsec
- pandoc
ghc-options:
- -Wall

View file

@ -46,8 +46,8 @@ import Text.Blaze.Html5.Attributes as A
import Text.Blaze.Html.Renderer.Pretty
main :: IO ()
main = putStr . renderHtml $ do
ul ! class_ "foo" $ do
main = putStr . renderHtml $$ do
ul ! class_ "foo" $$ do
li "bar"
li "baz"
```
@ -72,7 +72,7 @@ import Clay
import Data.Text.Lazy.IO as T
main :: IO ()
main = T.putStr . render $ ul # byClass "foo" ? do
main = T.putStr . render $$ ul # byClass "foo" ? do
listStyle none outside none
paddingLeft nil
li ? do
@ -110,14 +110,14 @@ compileHs = getResourceString
>>= withItemBody (unixFilter "stack" ["runghc", "--", "-XOverloadedStrings"]
main :: IO ()
main = hakyll $ do
match "html.hs" $ do
route $ constRoute "myUl.html"
compile $ compileHs
main = hakyll $$ do
match "html.hs" $$ do
route $$ constRoute "myUl.html"
compile $$ compileHs
match "css.hs" $ do
route $ constRoute "css/default.css"
compile $ compileHs
match "css.hs" $$ do
route $$ constRoute "css/default.css"
compile $$ compileHs
```
**EDIT**: (2023-06-21) Actually, no need to make those main functions. Something like
@ -127,10 +127,10 @@ import Text.Blaze.Html.Renderer.Pretty
import Hakyll
main :: IO ()
main = hakyll $ do
create ["myUl.html"] $ do
main = hakyll $$ do
create ["myUl.html"] $$ do
route idRoute
compile $ makeItem (renderHtml someHtml) -- someHtml :: Html
compile $$ makeItem (renderHtml someHtml) -- someHtml :: Html
```
will work just fine.
@ -185,14 +185,14 @@ import Data.Map (singleton, empty)
addCss :: String -> Css -> Component ()
addCss name css = tell
$ Prop
$$ Prop
{ cssMap = singleton name css
, assetsTree = mempty
}
addAsset :: FilePath -> Component ()
addAsset fp = tell
$ Prop
$$ Prop
{ cssMap = empty
, assetsTree = build fp -- build :: FilePath -> FileTree
}
@ -212,12 +212,12 @@ comp :: Component (Html -> Html)
comp = do
addCss "comp" css
addAsset asset
return $ ... -- some Html -> Html function
return $$ ... -- some Html -> Html function
comp' :: Component Html
comp' = do
addCss css'
return $ ... -- some Html
return $$ ... -- some Html
comp'' :: Html
comp'' = comp <*> (comp' <> comp')

11
posts/test.md Normal file
View file

@ -0,0 +1,11 @@
---
title: test post with image
date: 2023-06-27
tags: test
---
This is just a test post with a very basic image integration to add the support for pictures.
<!--more-->
In the *idea*, a picture would just be included with a call like $img("test/fluidGradientBG.png")$. Maybe I'll add a couple arguments for img size and shape, but for the moment this is about it.

View file

@ -1,20 +1,17 @@
module Core.Compilers
( runGHC
, componentTemplate
( componentTemplate
, myPandocReaderOptions
) where
import Components
import Core.Render ( )
import Hakyll
import Text.Pandoc.Options
-- Redundant... Those default extensions should be kept in sync with package.yaml, but `stack runghc` won't take those in account.
defaultExtensions :: [String]
defaultExtensions =
["--", "-XQuasiQuotes", "-XOverloadedStrings", "-XFlexibleInstances"]
runGHC :: Compiler (Item String)
runGHC = getResourceString
>>= withItemBody (unixFilter "stack" $ "runghc" : defaultExtensions)
myPandocReaderOptions :: ReaderOptions
myPandocReaderOptions = def
{ readerExtensions = disableExtension Ext_tex_math_dollars pandocExtensions
}
componentTemplate
:: Show s => Component s -> Context a -> Item a -> Compiler (Item String)

45
src/Core/Parsers.hs Normal file
View file

@ -0,0 +1,45 @@
module Core.Parsers where
import Components
import Control.Monad ( join )
import Data.Functor
import Data.Void
import Routes
import Text.Megaparsec
import Text.Megaparsec.Char
import Utils.FileTree
type Parser = Parsec Void String
parseFilePath :: Parser FilePath
parseFilePath = some $ alphaNumChar <|> oneOf ("/-_., " :: String)
parseWord :: Parser (Component ())
parseWord = fmap return $ some (alphaNumChar <|> punctuationChar) *> space
parseComment :: Parser (Component ())
parseComment =
mconcat <$> between (string "<!--") (string ">") (many parseWord) <* space
parseImgField :: Parser (Component ())
parseImgField =
addAsset
. path
. Img
<$> between
(char '$')
(char '$')
(string "img" *> between (string "(\"") (string "\")") parseFilePath)
<* space
parseFile :: Parser (Component ())
parseFile =
mconcat <$> manyTill (choice [parseImgField, parseWord, parseComment]) eof
---------
mkParse :: Parser a -> FilePath -> IO a
mkParse p f = do
str <- readFile f
let treat = either (const $ fail "parse failed") return
treat $ runParser p f str

View file

@ -2,10 +2,12 @@ module Kit.Atoms.Image
( Shape(..)
, img'
, imgWithShape
, imgCtx
) where
import Clay as C
import Components
import Hakyll.Web.Template.Context
import Routes
import Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes as A
@ -13,7 +15,6 @@ import Utils.Clay
data Shape = Square | Circle | Rounded | Drop
baseCss :: Css
baseCss = C.img ? do
maxWidth (pct 100)
@ -45,3 +46,12 @@ imgWithShape Drop file description =
)
return (H.! class_ "drop")
<*> img' file description
imgCtx :: Context a
imgCtx = functionField
"img"
(\args _ -> case args of
[p] -> return $ show . getBody . img' p $ ""
[p, a] -> return $ show . getBody . img' p $ a
_ -> fail "img takes 1 or 2 arguments"
)

View file

@ -1,9 +1,12 @@
module Kit.Templates.Post
( postTemplate
, postCtx
) where
import Components
import Core.Render
import Hakyll.Web.Template.Context
import Kit.Atoms.Image ( imgCtx )
import Kit.Atoms.Section
import Kit.Organisms.Head
import Kit.Organisms.TopMenu
@ -17,3 +20,6 @@ postTemplate = docTypeHtml
postBody = body $ do
h1 "$title$"
"$body$"
postCtx :: Context String
postCtx = imgCtx <> defaultContext

View file

@ -13,4 +13,4 @@ uniform = join . join . join
-- |Get a selector from byClass.
byClass' :: Text -> Selector
byClass' c = selectorFromText "" # byClass c
byClass' c = star # byClass c

View file

@ -1,9 +1,13 @@
module Utils.Routes
( patrn
, local
) where
import Hakyll
import Routes
patrn :: Route -> Pattern
patrn = fromGlob . tail . path
patrn = fromGlob . local
local :: Route -> FilePath
local = drop 1 . path