Browse Source

trying to get my own tag clouds to work

tag-clouds-and-open-graph
Logan McGrath 5 months ago
parent
commit
daa91acb96
  1. 2
      config.ini
  2. 3
      green.cabal
  3. 1
      package.yaml
  4. 4
      site/_layouts/default.html
  5. 25
      site/_layouts/skeleton.html
  6. 2
      site/_pages/contact.md
  7. 2
      site/_templates/post-header.html
  8. 2
      site/_templates/posts-under-category.html
  9. 2
      site/_templates/posts-under-tag.html
  10. 2
      site/archives.html
  11. 2
      site/drafts.html
  12. 2
      site/index.html
  13. 4
      src/Green/Config.hs
  14. 169
      src/Green/Site/Blog.hs
  15. 132
      src/Green/Site/Tags.hs
  16. 2
      src/Green/Template.hs
  17. 12
      src/Green/Template/Ast.hs
  18. 34
      src/Green/Template/Compiler.hs
  19. 20
      src/Green/Template/Context.hs
  20. 24
      src/Green/Template/Custom/GitField.hs
  21. 10
      src/Green/Template/Field.hs
  22. 12
      src/Green/Template/Source/Parser.hs
  23. 74
      src/Green/Template/Tags.hs

2
config.ini

@ -1,7 +1,7 @@
[Site]
title = This Field Was Green
description = ""
root = https://thisfieldwas.green
siteRoot = https://thisfieldwas.green
authorName = Logan McGrath
authorEmail = logan.mcgrath@thisfieldwas.green
linkedInProfile = https://www.linkedin.com/in/loganmcgrath

3
green.cabal

@ -43,6 +43,7 @@ library
Green.Site.Pages
Green.Site.Robots
Green.Site.Sitemap
Green.Site.Tags
Green.Site.Templates
Green.Template
Green.Template.Ast
@ -60,7 +61,6 @@ library
Green.Template.Source.Lexer
Green.Template.Source.Parser
Green.Template.Source.Util
Green.Template.Tags
Green.Util
other-modules:
Paths_green
@ -116,6 +116,7 @@ library
, binary
, bytestring
, config-ini
, containers
, data-default
, directory
, filepath

1
package.yaml

@ -21,6 +21,7 @@ library:
- binary
- bytestring
- config-ini
- containers
- data-default
- directory
- filepath

4
site/_layouts/default.html

@ -4,7 +4,7 @@
<div class="logo-icon"><a href="/"></a></div>
<div class="logo-nav">
<h1 class="logo"><a href="/">This Field Was Green</a></h1>
{{partial "main-nav"}}
{{>"main-nav"}}
</div>
</div>
</header>
@ -17,7 +17,7 @@
<footer class="page-footer">
<div class="content-bound">
{{partial "main-nav"}}
{{>"main-nav"}}
<p class="copyright">Copyright &copy; <span class="copyright-date">2012</span> Logan McGrath. All rights reserved.</p>
<ul class="acks">
<li>Site proudly generated by <a href="http://jaspervdj.be/hakyll">Hakyll</a>.</li>

25
site/_layouts/skeleton.html

@ -1,5 +1,5 @@
<!doctype html>
<html lang="en">
<html lang="en" prefix="og: https://ogp.me/ns#"{{#if post}} prefix="article: https://ogp.me/ns/article#"{{#end}}>
<head>
<meta charset="utf-8">
@ -7,10 +7,29 @@
<meta name="viewport" content="width=device-width, initial-scale=1">
<title>{{siteTitle}}{{#if title}} - {{title}}{{#end}}</title>
<meta rel="canonical" href="{{siteRoot}}{{url}}">
{{#if author}}<link rel="author" href="{{siteRoot}}" content="{{author}}">{{#end}}
{{#if description}}<meta name="description" content="{{description}}">{{#end}}
{{#if keywords}}<meta name="keywords" content="{{keywords | join ', '}}">{{#end}}
{{#if author}}<link rel="author" href='/' content="{{author}}">{{#end}}
<link rel="icon" href="/images/grass.svg">
<meta property="og:site_name" content="{{siteTitle}}">
<meta property="og:title" content="{{title}}">
{{#if description}}<meta property="og:description" content="{{description}}">{{#end}}
<meta property="og:url" content="{{url}}">
{{#if image}}<meta property="og:image" content="{{image}}">{{#end}}
{{#if type-}}
<meta property="og:type" content="{{type}}">
{{#else if post-}}
<meta property="og:type" content="article">
{{#if published}}<meta property="article:published_time" content="{{published}}">{{#end}}
{{#if updated}}<meta property="article:modified_time" content="{{updated}}">{{#end}}
{{#if author}}<meta property="article:author" content="{{author}}">{{#end}}
{{#if section}}<meta property="article:section" content="{{categories | join ', '}}">{{#end}}
{{#if tags}}<meta property="article:tag" content="{{tags | join ', '}}">{{#end}}
{{#end}}
<link rel="icon" href="/images/grass.svg">
<link rel="stylesheet" href="/css/main.css">
<script src="/js/main.js"></script>

2
site/_pages/contact.md

@ -4,4 +4,4 @@ layout: page
---
I live in a tiramisù and have pudding in my ears. Please contact me via [{{authorEmail}}](mailto:{{authorEmail}}) and I shall free my eyes to read and reply heartily; my fingers typing though they have been soaking like biscuits in espresso and cream. I welcome conversations and questions about what I do and I might even ask a few questions of my own, but I do not know how I came to be floating in mascarpone.
{{partial "employment"}}
{{>"employment"}}

2
site/_templates/post-header.html

@ -18,7 +18,7 @@
{{-#end}}
{{-#if tags}}
<p class="post-tags">
Tags: {{tagLinks}}
Tags: {{#for tags}}{{name}}{{#end}}
</p>
{{-#end}}
</header>

2
site/_templates/posts-under-category.html

@ -1 +1 @@
{{partial "post-list"}}
{{>"post-list"}}

2
site/_templates/posts-under-tag.html

@ -1 +1 @@
{{partial "post-list"}}
{{>"post-list"}}

2
site/archives.html

@ -5,4 +5,4 @@ layout: page
Here you can find all my previous posts:
{{partial "post-list"}}
{{>"post-list"}}

2
site/drafts.html

@ -4,4 +4,4 @@ layout: page
---
Here you can find all my drafts:
{{partial "post-list"}}
{{>"post-list"}}

2
site/index.html

@ -109,7 +109,7 @@ layout: page
</ul>
</section>
{{partial "employment"}}
{{>"employment"}}
<section class="personal-stuff">
<aside class="meatball-jellybean">

4
src/Green/Config.hs

@ -81,7 +81,7 @@ instance Show SiteConfig where
show config =
intercalate "\n" $
[ "SiteConfig:",
" Root: " <> show (config ^. siteRoot),
" SiteRoot: " <> show (config ^. siteRoot),
" Title: " <> show (config ^. siteTitle),
" Description: " <> show (config ^. siteDescription),
" AuthorName: " <> show (config ^. siteAuthorName),
@ -136,7 +136,7 @@ parseConfigIni env timeLocale time iniText = parseIniFile iniText do
section "Site" do
SiteConfig env
<$> fieldOf "root" string
<$> fieldOf "siteRoot" string
<*> fieldOf "title" string
<*> (fieldOf "description" string <|> return "")
<*> fieldOf "authorName" string

169
src/Green/Site/Blog.hs

@ -1,18 +1,27 @@
module Green.Site.Blog where
-- import qualified Data.HashMap.Strict as HashMap
import Control.Monad (forM_)
import Green.Common
import Green.Compiler (loadExistingSnapshots)
import Green.Route
import Green.Site.Tags
import Green.Template
import Green.Template.Custom
import qualified Hakyll as H
blog :: Context String -> Rules ()
blog context = do
blog siteContext = do
categories <- buildCategories "_posts/**" makeCategoryId
tags <- buildTags "_posts/**" makeTagId
let context =
tagCloudField "categoryCloud" categories
<> tagCloudField "tagCloud" tags
<> postContext categories tags
<> siteContext
blogHome categories tags context
blogHome context
posts context
archives context
@ -22,23 +31,16 @@ blog context = do
draftsIndex context
drafts context
blogHome :: Tags -> Tags -> Context String -> Rules ()
blogHome categories tags context =
blogHome :: Context String -> Rules ()
blogHome context =
match "blog.html" do
route indexRoute
compile do
categoryCloud <- renderTagCloud categories
tagCloud <- renderTagCloud tags
recentPosts <- recentPostsContext
let blogContext =
constField "categoryCloud" categoryCloud
<> constField "tagCloud" tagCloud
<> recentPosts
<> postContext
<> context
let context' = recentPosts <> context
getResourceBody
>>= contentCompiler blogContext
>>= layoutCompiler blogContext
>>= contentCompiler context'
>>= layoutCompiler context'
>>= relativizeUrls
archives :: Context String -> Rules ()
@ -47,13 +49,12 @@ archives context = do
route indexRoute
compile do
publishedPosts <- H.recentFirst =<< loadPublishedPosts
let archivesContext =
let context' =
constField "posts" (itemListValue context publishedPosts)
<> postContext
<> context
getResourceBody
>>= contentCompiler archivesContext
>>= layoutCompiler archivesContext
>>= contentCompiler context'
>>= layoutCompiler context'
>>= relativizeUrls
draftsIndex :: Context String -> Rules ()
@ -64,12 +65,13 @@ draftsIndex context = do
draftPosts <- H.recentFirst =<< loadDraftPosts
let draftsContext =
constField "posts" (itemListValue context draftPosts)
<> postContext
<> context
getResourceBody
>>= contentCompiler draftsContext
>>= layoutCompiler draftsContext
>>= relativizeUrls
where
loadDraftPosts = loadExistingSnapshots "_drafts/**" "_draftPosts"
posts :: Context String -> Rules ()
posts context = do
@ -77,12 +79,10 @@ posts context = do
route postsRoute
compile $
getResourceBody
>>= contentCompiler postsContext
>>= contentCompiler context
>>= snapshotCompiler [publishedPostsSnapshot]
>>= layoutCompiler postsContext
>>= layoutCompiler context
>>= relativizeUrls
where
postsContext = postContext <> context
postsRoute :: Routes
postsRoute =
@ -97,12 +97,52 @@ drafts context = do
route draftsRoute
compile $
getResourceBody
>>= contentCompiler draftsContext
>>= contentCompiler context
>>= snapshotCompiler [draftPostsSnapshot]
>>= layoutCompiler draftsContext
>>= layoutCompiler context
>>= relativizeUrls
where
draftsContext = postContext <> context
categoriesPages :: TagCloud -> Context String -> Rules ()
categoriesPages categories context =
forM_ (tagCloudTags categories) \category ->
rulesExtraDependencies [tagCloudDependency categories] do
create [tagId category] do
route indexRoute
compile do
categoryPosts <- H.recentFirst =<< H.loadAll (fromList $ tagIds category)
let tagsContext =
constField "category" (tagContext category)
<> constField "title" ("Posted under " ++ tagName category)
<> constField "posts" (itemListValue context categoryPosts)
<> constField "layout" ("page" :: String)
<> context
template <- loadBody "_templates/posts-under-category.html"
makeItem ""
>>= applyTemplate template tagsContext
>>= pandocCompiler
>>= layoutCompiler tagsContext
>>= relativizeUrls
tagsPages :: TagCloud -> Context String -> Rules ()
tagsPages tags context =
forM_ (tagCloudTags tags) \tag ->
rulesExtraDependencies [tagCloudDependency tags] do
create [tagId tag] do
route indexRoute
compile do
tagPosts <- H.recentFirst =<< H.loadAll (fromList $ tagIds tag)
let tagsContext =
constField "tag" (tagContext tag)
<> constField "title" ("Posted under " ++ tagName tag)
<> constField "posts" (itemListValue context tagPosts)
<> constField "layout" ("page" :: String)
<> context
template <- loadBody "_templates/posts-under-tag.html"
makeItem ""
>>= applyTemplate template tagsContext
>>= pandocCompiler
>>= layoutCompiler tagsContext
>>= relativizeUrls
draftsRoute :: Routes
draftsRoute =
@ -111,52 +151,25 @@ draftsRoute =
`composeRoutes` setExtension "html"
`composeRoutes` indexRoute
categoriesPages :: Tags -> Context String -> Rules ()
categoriesPages categories context =
H.tagsRules categories \category pat -> do
route indexRoute
compile do
categoryPosts <- H.recentFirst =<< H.loadAll pat
let categoryContext =
constField "category" category
<> constField "title" ("Posts under \"" ++ category ++ "\"")
<> constField "posts" (itemListValue context categoryPosts)
<> constField "layout" ("page" :: String)
<> postContext
<> context
dummy <- makeItem ""
template <- loadBody "_templates/posts-under-category.html"
applyTemplate template categoryContext dummy
>>= pandocCompiler
>>= layoutCompiler categoryContext
>>= relativizeUrls
tagsPages :: Tags -> Context String -> Rules ()
tagsPages tags context =
H.tagsRules tags \tag pat -> do
route indexRoute
compile do
tagPosts <- H.recentFirst =<< H.loadAll pat
let tagsContext =
constField "tag" tag
<> constField "title" ("Posts tagged \"" ++ tag ++ "\"")
<> constField "posts" (itemListValue context tagPosts)
<> constField "layout" ("page" :: String)
<> postContext
<> context
dummy <- makeItem ""
template <- loadBody "_templates/posts-under-tag.html"
applyTemplate template tagsContext dummy
>>= pandocCompiler
>>= layoutCompiler tagsContext
>>= relativizeUrls
dateRoute :: Routes
dateRoute = gsubRoute datePattern (H.replaceAll "-" (const "/"))
where
datePattern = "[0-9]{4}-[0-9]{2}-[0-9]{2}-"
postContext :: Context String
postContext =
categoryLinksField "categoryLinks"
<> tagLinksField "tagLinks"
postContext :: TagCloud -> TagCloud -> Context String
postContext categories tags =
tagsField "categories" categories
<> tagsField "tags" tags
<> postHeaderField "postHeader"
postHeaderField :: String -> Context String
postHeaderField key = functionField key f
where
defaults = defaultKeys ["headerLevel", "latestPost"]
f (fields :: Context String) = do
tplWithContext (fields <> defaults) do
itemBody <$> loadAndApplyTemplate' (fromFilePath "_templates/post-header.html")
recentPostsContext :: Compiler (Context String)
recentPostsContext = do
recentPosts <- fmap (take 5) . H.recentFirst =<< loadPublishedPosts
@ -172,24 +185,8 @@ teaserContext = teaserField "teaser" publishedPostsSnapshot
loadPublishedPosts :: Compiler [Item String]
loadPublishedPosts = loadExistingSnapshots "_posts/**" publishedPostsSnapshot
loadDraftPosts :: Compiler [Item String]
loadDraftPosts = loadExistingSnapshots "_drafts/**" draftPostsSnapshot
publishedPostsSnapshot :: String
publishedPostsSnapshot = "_publishedPosts"
draftPostsSnapshot :: String
draftPostsSnapshot = "_draftPosts"
dateRoute :: Routes
dateRoute = gsubRoute datePattern (H.replaceAll "-" (const "/"))
where
datePattern = "[0-9]{4}-[0-9]{2}-[0-9]{2}-"
postHeaderField :: String -> Context String
postHeaderField key = functionField key f
where
defaults = defaultKeys ["headerLevel", "latestPost"]
f (fields :: Context String) = do
tplWithContext (fields <> defaults) do
itemBody <$> loadAndApplyTemplate' (fromFilePath "_templates/post-header.html")

132
src/Green/Site/Tags.hs

@ -0,0 +1,132 @@
module Green.Site.Tags where
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Green.Common
import Green.Template.Context
import Hakyll (MonadMetadata, Tags, buildTagsWith)
import qualified Hakyll as H
import System.FilePath
sanitizeTerm :: String -> String
sanitizeTerm = subSuspiciousDots . subWindowsBaddies
where
subWindowsBaddies =
mconcat . fmap \case
'\\' -> "/"
'*' -> "$splat$"
'<' -> "$lt$"
'>' -> "$gt$"
'?' -> "$eh$"
'|' -> "$or$"
':' -> "$dots$"
';' -> "$semi$"
'"' -> "$quot$"
x -> [x]
subSuspiciousDots = joinPath . fmap go . splitDirectories
where
go path
| path == ".." = "__"
| path == "." = "_"
| last path == '.' = init path ++ "_"
| otherwise = path
makeTagId :: String -> Identifier
makeTagId = H.fromCapture "tags/*.html" . sanitizeTerm
makeCategoryId :: String -> Identifier
makeCategoryId = H.fromCapture "categories/*.html" . sanitizeTerm
getCategory :: (MonadMetadata m) => Identifier -> m [String]
getCategory = (filter isCategory <$>) . H.getCategory
where
isCategory = not . (`elem` sourceDirs)
sourceDirs = ["_posts", "_drafts"]
buildTags :: (MonadMetadata m) => Pattern -> (String -> Identifier) -> m TagCloud
buildTags pattern' makeId = toTagCloud <$> H.buildTags pattern' makeId
buildCategories :: (MonadMetadata m) => Pattern -> (String -> Identifier) -> m TagCloud
buildCategories pattern' makeId = toTagCloud <$> buildTagsWith getCategory pattern' makeId
data TagCloud = TagCloud
{ tagCloudMinCount :: Int,
tagCloudMaxCount :: Int,
tagCloudTags :: [Tag],
tagCloudById :: HashMap FilePath [Tag],
tagCloudDependency :: Dependency
}
data Tag = Tag
{ tagName :: String,
tagId :: Identifier,
tagCount :: Int,
tagWeight :: Double,
tagIds :: [Identifier]
}
toTagCloud :: Tags -> TagCloud
toTagCloud tags =
TagCloud
{ tagCloudMinCount = minCount,
tagCloudMaxCount = maxCount,
tagCloudTags = tags',
tagCloudById = tagsById,
tagCloudDependency = H.tagsDependency tags
}
where
tagsMap = H.tagsMap tags
tagsMakeId = H.tagsMakeId tags
minCount = minimum $ length . snd <$> tagsMap
maxCount = maximum $ length . snd <$> tagsMap
tags' = uncurry toTag <$> tagsMap
toTag name ids =
Tag
{ tagName = name,
tagId = tagsMakeId name,
tagCount = count,
tagWeight = weight,
tagIds = ids
}
where
weight = fromIntegral (count - minCount) / fromIntegral (maxCount - minCount)
count = length ids
tagsById =
HashMap.fromListWith (<>)
. mconcat
. fmap (\tag -> (,[tag]) . toFilePath <$> tagIds tag)
$ tags'
tagCloudField :: String -> TagCloud -> Context String
tagCloudField key tags = constField key (f :: Context String)
where
f =
hashMapField . HashMap.fromList $
[ ("minCount", intoValue minCount :: ContextValue String),
("maxCount", intoValue maxCount),
("tags", intoValue tags')
]
minCount = tagCloudMinCount tags
maxCount = tagCloudMinCount tags
tags' = tagContext <$> tagCloudTags tags
tagContext :: Tag -> Context String
tagContext Tag {tagName, tagId, tagCount, tagWeight, tagIds} =
hashMapField $
HashMap.fromList
[ ("name", intoValue tagName :: ContextValue String),
("path", intoValue . toFilePath $ tagId),
("count", intoValue tagCount),
("weight", intoValue tagWeight),
("items", intoValue . fmap toFilePath $ tagIds)
]
tagsField :: String -> TagCloud -> Context String
tagsField key tags = field key f
where
f item = return tagItems
where
id' = toFilePath $ itemIdentifier item
tagsById = tagCloudById tags
itemTags = fromMaybe [] $ HashMap.lookup id' tagsById
tagItems = tagContext <$> itemTags

2
src/Green/Template.hs

@ -5,7 +5,6 @@ module Green.Template
module Green.Template.Field,
module Green.Template.Pandoc,
module Green.Template.Source.Parser,
module Green.Template.Tags,
)
where
@ -15,4 +14,3 @@ import Green.Template.Context
import Green.Template.Field
import Green.Template.Pandoc
import Green.Template.Source.Parser
import Green.Template.Tags

12
src/Green/Template/Ast.hs

@ -36,6 +36,7 @@ data Block
= TextBlock String SourcePos
| ExpressionBlock Expression SourcePos
| CommentBlock String SourcePos
| IncludeBlock Expression SourcePos
| ChromeBlock Expression [Block] SourcePos
| AltBlock
(NonEmpty ApplyBlock)
@ -48,6 +49,7 @@ getBlockName = \case
TextBlock {} -> "TextBlock"
ExpressionBlock {} -> "ExpressionBlock"
CommentBlock {} -> "CommentBlock"
IncludeBlock {} -> "IncludeBlock"
ChromeBlock {} -> "ApplyBlock"
AltBlock {} -> "AltBlock"
@ -56,6 +58,7 @@ getBlockPos = \case
TextBlock _ pos -> pos
ExpressionBlock _ pos -> pos
CommentBlock _ pos -> pos
IncludeBlock _ pos -> pos
ChromeBlock _ _ pos -> pos
AltBlock _ _ pos -> pos
@ -64,6 +67,7 @@ getBlockTag = \case
TextBlock {} -> 1
ExpressionBlock {} -> 2
CommentBlock {} -> 3
IncludeBlock {} -> 4
ChromeBlock {} -> 4
AltBlock {} -> 5
@ -76,6 +80,7 @@ instance Binary Block where
3 -> CommentBlock <$> get
4 -> ChromeBlock <$> get <*> get
5 -> AltBlock <$> get <*> get
6 -> IncludeBlock <$> get
_ -> error $ "Unrecognized block tag " ++ show tag
binaryPos <- get :: Get BinaryPos
return $ f (unBinaryPos binaryPos)
@ -88,6 +93,7 @@ instance Binary Block where
CommentBlock text _ -> put text
ChromeBlock expression blocks _ -> put expression >> put blocks
AltBlock blocks default' _ -> put blocks >> put default'
IncludeBlock expression _ -> put expression
put $ BinaryPos (getBlockPos block)
newtype BinaryPos = BinaryPos SourcePos
@ -268,6 +274,12 @@ instance PrettyPrint Block where
prettyText comment,
pp pos
]
IncludeBlock expression pos ->
intercalate "\n" $
[ "IncludeBlock",
pl "expression" expression,
pp pos
]
ChromeBlock expression blocks pos ->
intercalate "\n" $
[ "ChromeBlock",

34
src/Green/Template/Compiler.hs

@ -9,6 +9,7 @@ import Green.Template.Ast
import Green.Template.Context hiding (field)
import Green.Template.Source.Parser (parse)
import Hakyll.Core.Compiler.Internal
import Text.Parsec (SourcePos)
-- | Compiles an item as a template.
getResourceTemplate :: Compiler (Item Template)
@ -62,6 +63,7 @@ applyBlock = \case
TextBlock t _ -> return $ intoValue t
ExpressionBlock e _ -> eval e
CommentBlock {} -> return EmptyValue
IncludeBlock e pos -> evalApply (NameExpression "partial" pos) e
ChromeBlock e bs _ -> intoValue <$> applyGuard e bs [] Nothing
AltBlock (ApplyBlock e bs _ :| alts) mdef _ -> intoValue <$> applyGuard e bs alts mdef
where
@ -81,18 +83,12 @@ applyBlock = \case
eval :: Expression -> TemplateRunner a (ContextValue a)
eval = \case
NameExpression name pos -> do
(context, item, trace) <- liftA3 (,,) tplContext tplItem tplTrace
s <- get
lift $
evalStateT (unContext context name) s `compilerCatch` \case
CompilationFailure ne -> compilerThrow (NonEmpty.toList ne)
CompilationNoResult ss -> return $ UndefinedValue name item (show pos : trace) ss
NameExpression name pos -> evalName name pos
StringExpression s _ -> return $ intoValue s
IntExpression n _ -> return $ intoValue n
DoubleExpression x _ -> return $ intoValue x
BoolExpression b _ -> return $ intoValue b
ApplyExpression f x _ -> apply f x
ApplyExpression f x _ -> evalApply f x
AccessExpression target field pos ->
eval target >>= \case
ContextValue target' ->
@ -102,16 +98,26 @@ eval = \case
x -> tplFail $ "invalid field " ++ show x ++ " near " ++ show (getExpressionPos field)
>>= unContext target'
x -> tplFail $ "invalid context " ++ show x ++ " near " ++ show pos
FilterExpression x f _ -> apply f x
FilterExpression x f _ -> evalApply f x
ContextExpression pairs _ -> do
pairs' <- mapM (sequence . second eval) pairs
return $ ContextValue (intoContext pairs')
ListExpression xs _ -> intoValue <$> mapM eval xs
where
apply f x =
eval f >>= \case
FunctionValue f' -> f' (ThunkValue $ eval x)
x' -> fail $ "invalid function " ++ show x' ++ " in " ++ show (getExpressionPos f)
evalName :: String -> SourcePos -> TemplateRunner a (ContextValue a)
evalName name pos = do
(context, item, trace) <- liftA3 (,,) tplContext tplItem tplTrace
s <- get
lift $
evalStateT (unContext context name) s `compilerCatch` \case
CompilationFailure ne -> compilerThrow (NonEmpty.toList ne)
CompilationNoResult ss -> return $ UndefinedValue name item (show pos : trace) ss
evalApply :: Expression -> Expression -> TemplateRunner a (ContextValue a)
evalApply f x =
eval f >>= \case
FunctionValue f' -> f' (ThunkValue $ eval x)
x' -> fail $ "invalid function " ++ show x' ++ " in " ++ show (getExpressionPos f)
stringify :: ContextValue String -> TemplateRunner String String
stringify = \case

20
src/Green/Template/Context.hs

@ -13,6 +13,7 @@ import qualified Data.Text as T
import qualified Data.Vector as Vector
import Green.Common
import Green.Template.Ast
import Hakyll.Core.Compiler.Internal (CompilerErrors (..), compilerTry)
import Prelude hiding (lookup)
newtype Context a = Context {unContext :: ContextFunction a}
@ -41,6 +42,24 @@ templateRunner context item =
tplCallStack = ["item " ++ itemFilePath item]
}
tplTry :: TemplateRunner a b -> TemplateRunner a (Either (CompilerErrors String) b)
tplTry f =
get >>= lift . compilerTry . runStateT f >>= \case
Right (x, s2) -> do
put s2
return $ Right x
Left e -> return $ Left e
tplMaybe :: TemplateRunner a b -> TemplateRunner a (Maybe b)
tplMaybe f = tplTry f >>= \case
Right x -> return $ Just x
Left _ -> return Nothing
tplCatch :: TemplateRunner a b -> (CompilerErrors String -> TemplateRunner a b) -> TemplateRunner a b
tplCatch f g = tplTry f >>= \case
Right x -> return x
Left e -> g e
tplItem :: TemplateRunner a (Item a)
tplItem = gets $ head . tplItemStack
@ -324,6 +343,7 @@ instance IntoValue (TemplateRunner a (ContextValue a)) a where
-- | Extract a concrete value of type @v@ from a @ContextValue a@.
class FromValue v a where
fromValue :: ContextValue a -> TemplateRunner a v
tryFromValue :: ContextValue a -> TemplateRunner a (Maybe v)
class FromValue' (flag :: Bool) v a where
fromValue' :: Proxy flag -> ContextValue a -> TemplateRunner a v

24
src/Green/Template/Custom/GitField.hs

@ -23,16 +23,16 @@ gitCommits :: SiteConfig -> Context a
gitCommits config =
mconcat
[ constField "gitWebUrl" (config ^. siteGitWebUrl),
field "gitSha1" (gitSha1Compiler root),
field "gitMessage" (gitMessageCompiler root),
field "gitSha1" (gitSha1Compiler siteSrc),
field "gitMessage" (gitMessageCompiler siteSrc),
field "gitBranch" gitBranchCompiler,
gitFileField root "gitFilePath" gitFilePath,
gitFileField root "gitFileName" (takeFileName . gitFilePath),
gitFileField root "isFromSource" gitFileIsFromSource,
gitFileField root "isChanged" gitFileIsChanged
gitFileField siteSrc "gitFilePath" gitFilePath,
gitFileField siteSrc "gitFileName" (takeFileName . gitFilePath),
gitFileField siteSrc "isFromSource" gitFileIsFromSource,
gitFileField siteSrc "isChanged" gitFileIsChanged
]
where
root = config ^. siteProviderDirectory
siteSrc = config ^. siteProviderDirectory
gitSha1Compiler :: String -> Item a -> TemplateRunner a String
gitSha1Compiler = gitLogField "%h"
@ -43,24 +43,24 @@ gitMessageCompiler = gitLogField "%s"
type LogFormat = String
gitLogField :: LogFormat -> String -> Item a -> TemplateRunner a String
gitLogField format root item =
gitLogField format siteSrc item =
lift $ unsafeCompiler do
maybeResult <- gitLog format (Just $ root </> toFilePath (itemIdentifier item))
maybeResult <- gitLog format (Just $ siteSrc </> toFilePath (itemIdentifier item))
case maybeResult of
Just result -> return result
Nothing -> fromJust <$> gitLog format Nothing
gitFileField :: (IntoValue v a) => String -> String -> (GitFile -> v) -> Context a
gitFileField root key f = field key $ fmap f . gitFileCompiler root
gitFileField siteSrc key f = field key $ fmap f . gitFileCompiler siteSrc
gitFileCompiler :: String -> Item a -> TemplateRunner a GitFile
gitFileCompiler root item =
gitFileCompiler siteSrc item =
lift $
GitFile gitFilePath
<$> unsafeCompiler (doesFileExist gitFilePath)
<*> unsafeCompiler (isChanged gitFilePath)
where
gitFilePath = root </> toFilePath (itemIdentifier item)
gitFilePath = siteSrc </> toFilePath (itemIdentifier item)
isChanged filePath = do
let args = ["diff", "HEAD", filePath]
(exitCode, stdout, _stderr) <- readProcessWithExitCode "git" args ""

10
src/Green/Template/Field.hs

@ -27,6 +27,7 @@ defaultFields =
withField,
metadataField,
titleFromFileField "title",
joinField "join",
missingField
]
@ -169,3 +170,12 @@ metadataPriorityField :: String -> [String] -> Context a
metadataPriorityField key priorityKeys = field key f
where
f item = lift $ foldl (<|>) (noResult "") (flip getMetadataField item <$> priorityKeys)
joinField :: String -> Context String
joinField key = functionField2 key f
where
f (separator :: ContextValue String) (items :: [ContextValue String]) =
tplWithCall (key ++ " with separator " ++ show separator) do
separator' <- fromValue separator :: TemplateRunner String String
items' <- mapM fromValue items
return $ intercalate separator' items'

12
src/Green/Template/Source/Parser.hs

@ -24,6 +24,7 @@ block =
tryOne
[ offBlock,
commentBlock,
includeBlock,
chromeBlock,
altBlock,
expressionBlock,
@ -43,6 +44,17 @@ commentBlock = labeled "CommentBlock" $
closeBlock
return $ CommentBlock value
includeBlock :: Parser Block
includeBlock = labeled "IncludeBlock" $
withPosition do
-- {{>
withTag IncludeBlockToken
-- ..."this/file" + ext...
e <- expression
-- }}
closeBlock
return $ IncludeBlock e
offBlock :: Parser Block
offBlock = labeled "OffBlock" $
withPosition do

74
src/Green/Template/Tags.hs

@ -1,74 +0,0 @@
module Green.Template.Tags
( module Green.Template.Tags,
Tags,
buildTags,
getTags,
)
where
import Green.Common
import Green.Template.Context
import Hakyll (MonadMetadata, Tags, buildTags, getTags, renderTagCloudWith)
import qualified Hakyll
makeTagId :: String -> Identifier
makeTagId = Hakyll.fromCapture "tags/*.html"
tagsField :: String -> Context a
tagsField key = field key $ lift . getTags . itemIdentifier
tagLinksFieldWith :: String -> (Identifier -> Compiler [String]) -> Context a
tagLinksFieldWith key f = field key f'
where
f' item = lift do
tags <- f $ itemIdentifier item
links <- mapM makeLink' tags
return $ intercalate ", " links
makeLink' tag =
getRoute (makeTagId tag) >>= \case
Just url -> return $ "<a class=\"tag\" href=\"/" ++ url ++ "\">" ++ tag ++ "</a>"
Nothing -> return $ "<span class=\"tag\">" ++ tag ++ "</span>"
tagLinksField :: String -> Context a
tagLinksField key = tagLinksFieldWith key getTags
categoryLinksField :: String -> Context a
categoryLinksField key = tagLinksFieldWith key getCategory
makeCategoryId :: String -> Identifier
makeCategoryId = Hakyll.fromCapture "categories/*.html"
categoriesField :: String -> Context a
categoriesField key = field key $ lift . getCategory . itemIdentifier
getCategory :: (MonadMetadata m) => Identifier -> m [String]
getCategory = (filter isCategory <$>) . Hakyll.getCategory
where
isCategory = not . (`elem` sourceDirs)
sourceDirs = ["_posts", "_drafts"]
buildCategories :: (MonadMetadata m) => Pattern -> (String -> Identifier) -> m Tags
buildCategories = Hakyll.buildTagsWith getCategory
renderTagCloud :: Tags -> Compiler String
renderTagCloud = renderTagCloudWith makeLink unwords minSize maxSize
where
minSize = 1.0
maxSize = 2.0
makeLink :: Double -> Double -> String -> String -> Int -> Int -> Int -> String
makeLink _minSize _maxSize tag url count minCount maxCount =
mconcat
[ "<a",
" data-count=\"" ++ show count ++ "\"",
" class=\"tag\"",
" style=\""
++ mconcat
[ ";--count:" ++ show count,
";--min-count:" ++ show minCount,
";--max-count:" ++ show maxCount
]
++ "\"",
" href=\"" ++ url ++ "\"",
">" ++ tag ++ "</a>"
]
Loading…
Cancel
Save