Browse Source

WIP

tag-clouds-and-open-graph
Logan McGrath 9 months ago
parent
commit
de32eeb845
  1. 18
      Makefile
  2. 9
      green.cabal
  3. 4
      site/_partials/teaser-list.html
  4. 63
      src/Green/Common.hs
  5. 30
      src/Green/Compiler.hs
  6. 46
      src/Green/Content/Blog/Compiler.hs
  7. 7
      src/Green/Content/Blog/Context.hs
  8. 8
      src/Green/Content/HomePage.hs
  9. 6
      src/Green/Content/Robot.hs
  10. 4
      src/Green/Template.hs
  11. 2
      src/Green/Template/Ast.hs
  12. 129
      src/Green/Template/Compiler.hs
  13. 227
      src/Green/Template/Context.hs
  14. 12
      src/Green/Template/Custom.hs
  15. 15
      src/Green/Template/Custom/Compiler.hs
  16. 9
      src/Green/Template/Custom/Context.hs
  17. 44
      src/Green/Template/Custom/DateField.hs
  18. 25
      src/Green/Template/Custom/GitField.hs
  19. 19
      src/Green/Template/Custom/HtmlField.hs
  20. 105
      src/Green/Template/Field.hs
  21. 2
      src/Green/Template/Source/Lexer.hs
  22. 2
      src/Green/Template/Source/Parser.hs
  23. 6
      stack.yaml
  24. 15
      stack.yaml.lock

18
Makefile

@ -1,37 +1,37 @@
build:
set -e; source commands.sh; build
set -e; source ./commands.sh; build
.PHONY: build
clean:
set -e; source commands.sh; clean
set -e; source ./commands.sh; clean
.PHONY: clean
clean-all:
set -e; source commands.sh; clean_all
set -e; source ./commands.sh; clean_all
.PHONY: clean-all
rebuild:
set -e; source commands.sh; rebuild
set -e; source ./commands.sh; rebuild
.PHONY: rebuild
rebuild-all:
set -e; source commands.sh; rebuild_all
set -e; source ./commands.sh; rebuild_all
.PHONY: rebuild-all
watch:
set -e; source commands.sh; watch
set -e; source ./commands.sh; watch
.PHONY: watch
publish:
set -e; source commands.sh; publish
set -e; source ./commands.sh; publish
.PHONY: publish
init:
set -e; source commands.sh; init
set -e; source ./commands.sh; init
.PHONY: init
test:
set -e; source commands.sh; test
set -e; source ./commands.sh; test
.PHONY: test
hpack:

9
green.cabal

@ -28,7 +28,6 @@ library
Green.Config
Green.Content.Blog
Green.Content.Blog.Compiler
Green.Content.Blog.Context
Green.Content.Blog.Route
Green.Content.Blog.Rule
Green.Content.BrokenLinks
@ -55,10 +54,10 @@ library
Green.Template.Custom
Green.Template.Custom.Compiler
Green.Template.Custom.Context
Green.Template.Custom.DateFields
Green.Template.Custom.GitFields
Green.Template.Custom.HtmlFields
Green.Template.Fields
Green.Template.Custom.DateField
Green.Template.Custom.GitField
Green.Template.Custom.HtmlField
Green.Template.Field
Green.Template.Pandoc
Green.Template.Source
Green.Template.Source.Lexer

4
site/_partials/teaser-list.html

@ -2,7 +2,7 @@
<header>
<h2>Latest Blog Posts</h2>
</header>
{{#for previousPosts-}}
{{-#for previousPosts-}}
<section class="teaser-item post">
<header class="post-header">
<hgroup>
@ -17,7 +17,7 @@
</p>
</hgroup>
</header>
{{#if teaser}}{{teaser}}{{#end-}}
{{-teaser}}
<p class="read-more"><a href="{{url}}">Read more...</a></p>
</section>
{{-#end}}

63
src/Green/Common.hs

@ -3,6 +3,7 @@ module Green.Common
module Control.Exception,
module Control.Monad,
module Control.Monad.Except,
module Control.Monad.Trans,
module Data.Bifunctor,
module Data.Bool,
module Data.Foldable,
@ -11,69 +12,19 @@ module Green.Common
module Data.Maybe,
module Data.Time,
module Data.Time.Format,
module Hakyll,
module Lens.Micro,
module Lens.Micro.TH,
module System.Directory,
module System.FilePath,
-- common Hakyll types
Compiler,
Dependency,
FeedConfiguration (..),
Identifier (..),
Item (..),
Metadata,
Pattern,
Redirect (..),
Routes,
Rules,
Snapshot,
-- common Hakyll typeclasses
Writable (..),
-- common Hakyll functions
cached,
compile,
composeRoutes,
copyFileCompiler,
create,
debugCompiler,
escapeHtml,
fromFilePath,
fromList,
fromRegex,
getMatches,
getMetadata,
getResourceBody,
getResourceString,
getRoute,
gsubRoute,
idRoute,
itemSetBody,
load,
loadSnapshot,
loadSnapshotBody,
lookupString,
makeItem,
makePatternDependency,
matchRoute,
match,
noResult,
relativizeUrls,
route,
rulesExtraDependencies,
saveSnapshot,
setExtension,
toFilePath,
toUrl,
unsafeCompiler,
withErrorMessage,
withItemBody,
)
where
import Control.Applicative ((<|>))
import Control.Exception
import Control.Monad (join, (<=<), (>=>))
import Control.Monad.Except
import Control.Exception (bracket)
import Control.Monad (forM, join, (<=<), (>=>))
import Control.Monad.Except (MonadError, catchError, throwError)
import Control.Monad.Trans (lift)
import Data.Bifunctor (bimap, first, second)
import Data.Bool (bool)
import Data.Foldable (sequenceA_)
@ -81,7 +32,7 @@ import Data.Functor ((<&>))
import Data.List (intercalate)
import Data.Maybe (fromJust, fromMaybe, isJust, isNothing, maybe, maybeToList)
import Data.Time (ZonedTime)
import Data.Time.Format
import Data.Time.Format (TimeLocale, formatTime, parseTime, parseTimeM)
import Hakyll
( -- types
Compiler,

30
src/Green/Compiler.hs

@ -5,15 +5,29 @@ import Green.Common
-- | Load an item snapshot if it exists.
maybeLoadSnapshot :: Identifier -> Snapshot -> Compiler (Maybe (Item String))
maybeLoadSnapshot id' snapshot =
catchError
(Just <$> loadSnapshot id' snapshot)
\_ -> return Nothing
maybeLoadSnapshot id' snapshot = catchError go onError
where
go = Just <$> loadSnapshot id' snapshot
onError errors = do
debugCompiler $
("Errors occurred while trying to load " ++ toFilePath id')
++ (" for snapshot " ++ show snapshot)
++ (": " ++ show errors)
return Nothing
-- | Loads all item snapshots that exist for items matching a given pattern
-- and snapshot name.
loadExistingSnapshots :: Pattern -> Snapshot -> Compiler [Item String]
loadExistingSnapshots pat snapshot = do
matching <- getMatches pat
results <- mapM (`maybeLoadSnapshot` snapshot) matching
return $ catMaybes results
loadExistingSnapshots pattern' snapshot = withErrorMessage errorMessage do
matching <- getMatches pattern'
debugCompiler $
("Found " ++ show (length matching))
++ (" items for snapshot " ++ show snapshot)
++ (" matching " ++ show pattern')
resultMaybes <- mapM (`maybeLoadSnapshot` snapshot) matching <|> error "GOT IT"
debugCompiler $ "Tried loading " ++ show (length resultMaybes)
let results = catMaybes resultMaybes
debugCompiler $ "Successfully loaded " ++ show (length results)
return results
where
errorMessage = "Tried loading snapshot " ++ show snapshot ++ " with pattern " ++ show pattern'

46
src/Green/Content/Blog/Compiler.hs

@ -1,6 +1,5 @@
module Green.Content.Blog.Compiler where
import Data.Maybe (listToMaybe)
import Green.Common
import Green.Compiler (loadExistingSnapshots)
import Green.Template.Custom
@ -16,32 +15,47 @@ draftCompiler context =
blogCompiler :: Context String -> Compiler (Item String)
blogCompiler context = do
posts <- fmap (take 5) . recentFirst =<< loadPublishedPosts
let latestPost = listToMaybe posts
previousPosts = drop 1 posts
context' =
constField "latestPost" (itemValue context <$> latestPost)
<> constField "previousPosts" (itemsValue context previousPosts)
<> context
pageCompiler context' =<< getResourceBody
blogContext <- (<> context) <$> recentPostsContext
pageCompiler blogContext =<< getResourceBody
archivesCompiler :: Context String -> Compiler (Item String)
archivesCompiler context = do
posts <- recentFirst =<< loadPublishedPosts
let context' = constField "posts" (itemsValue context posts) <> context
pageCompiler context' =<< getResourceBody
let archivesContext =
constField "posts" (itemListValue context posts)
<> context
pageCompiler archivesContext =<< getResourceBody
draftArchivesCompiler :: Context String -> Compiler (Item String)
draftArchivesCompiler context = do
drafts <- recentFirst =<< loadDraftPosts
let context' = constField "drafts" (itemsValue context drafts) <> context
pageCompiler context' =<< getResourceBody
let draftsContext =
constField "posts" (itemListValue context drafts)
<> context
pageCompiler draftsContext =<< getResourceBody
loadDraftPosts :: Compiler [Item String]
loadDraftPosts = loadExistingSnapshots "_drafts/**" draftPostsSnapshot
recentPostsContext :: Compiler (Context String)
recentPostsContext =
withErrorMessage "Failed to load recent posts context" do
posts <- fmap (take 5) . recentFirst =<< loadPublishedPosts
let latestPost = take 1 posts
previousPosts = drop 1 posts
blogContext =
constField "latestPost" (itemListValue teaserContext latestPost)
<> constField "previousPosts" (itemListValue teaserContext previousPosts)
return blogContext
teaserContext :: Context String
teaserContext = teaserField "teaser" publishedPostsSnapshot
loadPublishedPosts :: Compiler [Item String]
loadPublishedPosts = loadExistingSnapshots "_posts/**" publishedPostsSnapshot
loadPublishedPosts = withErrorMessage "Failed to load published posts" $ do
snapshots <- loadExistingSnapshots "_posts/**" publishedPostsSnapshot
debugCompiler $ "Loaded " ++ show (length snapshots) ++ " published posts"
return snapshots
loadDraftPosts :: Compiler [Item String]
loadDraftPosts = loadExistingSnapshots "_drafts/**" draftPostsSnapshot
publishedPostsSnapshot :: String
publishedPostsSnapshot = "_publishedPosts"

7
src/Green/Content/Blog/Context.hs

@ -1,7 +0,0 @@
module Green.Content.Blog.Context where
import Green.Content.Blog.Compiler
import Green.Template
blogContext :: Context String
blogContext = teaserField "teaser" publishedPostsSnapshot

8
src/Green/Content/HomePage.hs

@ -1,10 +1,16 @@
module Green.Content.HomePage where
import Green.Common
import Green.Content.Blog.Compiler
import Green.Template.Custom
homePageRules :: Context String -> Rules ()
homePageRules context =
match "index.html" do
route idRoute
compile $ pageCompiler context =<< getResourceBody
compile $ homePageCompiler context
homePageCompiler :: Context String -> Compiler (Item String)
homePageCompiler context = do
blogContext <- (<> context) <$> recentPostsContext
pageCompiler blogContext =<< getResourceBody

6
src/Green/Content/Robot.hs

@ -10,8 +10,6 @@ robotsTxtRules context = do
compile $ robotsTxtCompiler context
robotsTxtCompiler :: Context String -> Compiler (Item String)
robotsTxtCompiler context = do
robotsTxtCompiler context =
makeItem ""
>>= loadAndApplyTemplate
(fromFilePath "_templates/robots.txt")
context
>>= loadAndApplyTemplate (fromFilePath "_templates/robots.txt") context

4
src/Green/Template.hs

@ -2,7 +2,7 @@ module Green.Template
( module Green.Template.Ast,
module Green.Template.Compiler,
module Green.Template.Context,
module Green.Template.Fields,
module Green.Template.Field,
module Green.Template.Pandoc,
module Green.Template.Source.Parser,
)
@ -11,6 +11,6 @@ where
import Green.Template.Ast
import Green.Template.Compiler
import Green.Template.Context
import Green.Template.Fields
import Green.Template.Field
import Green.Template.Pandoc
import Green.Template.Source.Parser

2
src/Green/Template/Ast.hs

@ -231,7 +231,7 @@ instance (PrettyPrint a) => PrettyPrint (String, a) where
instance (PrettyPrint a) => PrettyPrint (Maybe a) where
prettyIndented' level = \case
Just item -> prettyIndented' level item
Nothing -> "Undefined"
Nothing -> "Nothing"
instance (PrettyPrint a) => PrettyPrint [a] where
prettyIndented' level items

129
src/Green/Template/Compiler.hs

@ -1,12 +1,13 @@
module Green.Template.Compiler where
import Control.Monad.State.Strict
import Data.Bifunctor
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.List.NonEmpty
import Green.Common
import Green.Template.Ast
import Green.Template.Context hiding (field)
import Green.Template.Source.Parser (parse)
import Prelude hiding (lookup)
import Hakyll.Core.Compiler.Internal
-- | Compiles an item as a template.
templateCompiler :: Compiler (Item Template)
@ -22,11 +23,16 @@ compileTemplateItem item = do
let filePath = toFilePath $ itemIdentifier item
either (fail . show) return $ parse filePath (itemBody item)
loadTemplate :: Identifier -> Compiler (Item Template)
loadTemplate = load
loadTemplate' :: Identifier -> TemplateRunner a Template
loadTemplate' = lift . fmap itemBody . load
loadTemplateBody :: Identifier -> Compiler Template
loadTemplateBody id' = itemBody <$> loadTemplate id'
loadAndApplyTemplate :: Identifier -> Context String -> Item String -> Compiler (Item String)
loadAndApplyTemplate id' context item = do
let s = templateRunner context item
evalStateT (loadAndApplyTemplate' id') s
loadAndApplyTemplate' :: Identifier -> TemplateRunner String (Item String)
loadAndApplyTemplate' = lift . makeItem <=< applyTemplate' <=< loadTemplate'
-- | Applies an item as a template to itself.
applyAsTemplate :: Context String -> Item String -> Compiler (Item String)
@ -34,100 +40,104 @@ applyAsTemplate context item = do
template <- compileTemplateItem item
applyTemplate template context item
loadAndApplyTemplate :: Identifier -> Context String -> Item String -> Compiler (Item String)
loadAndApplyTemplate id' context item = do
template <- loadTemplateBody id'
applyTemplate template context item
-- | Applies a template with context to an item
applyTemplate :: Template -> Context String -> Item String -> Compiler (Item String)
applyTemplate (Template bs _) context item = do
result <- reduceBlocks context bs item
return $ itemSetBody result item
applyTemplate template context item = do
let s = templateRunner context item
makeItem =<< evalStateT (applyTemplate' template) s
reduceBlocks :: Context String -> [Block] -> Item String -> Compiler String
reduceBlocks context bs item = do
values <- applyBlocks context bs item
stringify context item . intoValue $ values
applyTemplate' :: Template -> TemplateRunner String String
applyTemplate' (Template bs src) =
tplWithCall ("template " ++ src) (reduceBlocks bs)
applyBlocks :: Context String -> [Block] -> Item String -> Compiler [ContextValue String]
applyBlocks context bs item = mapM applyBlock' bs
where
applyBlock' block = applyBlock context block item
reduceBlocks :: [Block] -> TemplateRunner String String -- Context String -> [Block] -> Item String -> Compiler String
reduceBlocks = stringify . intoValue <=< applyBlocks
applyBlocks :: [Block] -> TemplateRunner String [ContextValue String]
applyBlocks = mapM applyBlock
applyBlock :: Context String -> Block -> Item String -> Compiler (ContextValue String)
applyBlock context block item = case block of
applyBlock :: Block -> TemplateRunner String (ContextValue String)
applyBlock = \case
TextBlock t _ -> return $ intoValue t
ExpressionBlock e _ -> eval context e item
ExpressionBlock e _ -> eval e
CommentBlock {} -> return EmptyValue
ChromeBlock e bs _ -> intoValue <$> applyGuard e bs [] Nothing
AltBlock (ApplyBlock e bs _ :| alts) mdef _ -> intoValue <$> applyGuard e bs alts mdef
where
applyGuard e bs alts mdef =
eval context e item >>= \case
eval e >>= \case
FunctionValue f ->
pure <$> f (intoValue bs) context item
pure <$> f (intoValue bs)
x -> do
truthy <- isTruthy x
if truthy
then applyBlocks context bs item
then applyBlocks bs
else applyAlt alts mdef
--
applyAlt (ApplyBlock e bs _ : alts) mdef = applyGuard e bs alts mdef
applyAlt _ (Just (DefaultBlock bs _)) = applyBlocks context bs item
applyAlt _ (Just (DefaultBlock bs _)) = applyBlocks bs
applyAlt _ Nothing = return []
eval :: Context String -> Expression -> Item String -> Compiler (ContextValue String)
eval context e item = case e of
NameExpression key _ -> unContext context key item
eval :: Expression -> TemplateRunner a (ContextValue a)
eval = \case
NameExpression name _ -> do
context <- tplContext
item <- tplItem
trace <- tplTrace
s <- get
(result, s') <-
lift $
runStateT (unContext context name) s `compilerCatch` \e ->
let msg = "Failed to resolve field " ++ show name ++ " from item context for " ++ itemFilePath item ++ ", trace: [" ++ intercalate ", " trace ++ "]"
in compilerThrow (msg : compilerErrorMessages e)
put s'
return result
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
AccessExpression target field pos ->
eval context target item >>= \case
ContextValue target' -> do
field' <-
eval context field item >>= \case
eval target >>= \case
ContextValue target' ->
eval field
>>= \case
StringValue name -> return name
x -> fail $ "Invalid field " ++ show x ++ " near " ++ show (getExpressionPos field)
unContext target' field' item
x -> fail $ "Invalid context " ++ show x ++ " near " ++ show pos
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
ContextExpression pairs _ -> do
pairs' <- sequence (sequence . second (\x -> eval context x item) <$> pairs)
pairs' <- mapM (sequence . second eval) pairs
return $ ContextValue (intoContext pairs')
ListExpression xs _ -> intoValue <$> mapM (\x -> eval context x item) xs
ListExpression xs _ -> intoValue <$> mapM eval xs
where
apply f x =
eval context f item >>= \case
FunctionValue f' -> f' (ThunkValue (eval context x item)) context item
x' -> fail $ "Invalid function " ++ show x' ++ " in " ++ show (getExpressionPos f)
eval f >>= \case
FunctionValue f' -> f' (ThunkValue $ eval x)
x' -> fail $ "invalid function " ++ show x' ++ " in " ++ show (getExpressionPos f)
stringify :: Context String -> Item String -> ContextValue String -> Compiler String
stringify context item value = case value of
stringify :: ContextValue String -> TemplateRunner String String
stringify = \case
EmptyValue -> return ""
UndefinedValue name -> fail $ "Undefined name: " ++ show name
ContextValue {} -> fail "Can't stringify context"
ListValue xs -> mconcat <$> mapM (stringify context item) xs
ContextValue {} -> tplFail "can't stringify context"
ListValue xs -> mconcat <$> mapM stringify xs
BoolValue b -> return $ show b
StringValue s -> return s
DoubleValue x -> return $ show x
IntValue n -> return $ show n
FunctionValue {} -> fail "Can't stringify function"
FunctionValue {} -> tplFail "can't stringify function"
BlockValue block -> case block of
TextBlock t _ -> return t
CommentBlock {} -> return ""
ExpressionBlock e _ -> stringify context item =<< eval context e item
_ -> stringify context item =<< applyBlock context block item
ItemsValue _ items -> return $ mconcat $ itemBody <$> items
ThunkValue fx -> stringify context item =<< force =<< fx
ExpressionBlock e _ -> stringify =<< eval e
_ -> stringify =<< applyBlock block
ItemValue _ items -> return $ mconcat $ itemBody <$> items
ThunkValue fx -> stringify =<< force =<< fx
isTruthy :: ContextValue a -> Compiler Bool
isTruthy :: ContextValue a -> TemplateRunner a Bool
isTruthy = \case
EmptyValue -> return False
UndefinedValue {} -> return False
ContextValue {} -> return True
ListValue xs -> return $ not (null xs)
BoolValue x -> return x
@ -136,10 +146,11 @@ isTruthy = \case
IntValue x -> return $ x /= 0
FunctionValue {} -> return True
BlockValue {} -> return True
ItemsValue _ xs -> return $ not (null xs)
ItemValue _ xs -> return $ not (null xs)
ThunkValue fx -> isTruthy =<< force =<< fx
force :: ContextValue a -> Compiler (ContextValue a)
force :: ContextValue a -> TemplateRunner a (ContextValue a)
force = \case
ThunkValue fx -> force =<< fx
ThunkValue fx -> do
force =<< fx
x -> return x

227
src/Green/Template/Context.hs

@ -1,5 +1,6 @@
module Green.Template.Context where
import Control.Monad.State.Strict
import Data.Aeson
import Data.Bifunctor
import Data.Either
@ -16,33 +17,94 @@ import Prelude hiding (lookup)
newtype Context a = Context {unContext :: ContextFunction a}
type ContextFunction a = String -> Item a -> Compiler (ContextValue a)
type ContextFunction a = String -> TemplateRunner a (ContextValue a)
getContext :: Identifier -> Compiler (Context a)
getContext id' = intoContext <$> getMetadata id'
itemFilePath :: Item a -> FilePath
itemFilePath = toFilePath . itemIdentifier
data TemplateState a = TemplateState
{ tplContextStack :: [Context a],
tplItemStack :: [Item a],
tplCallStack :: [String]
}
type TemplateRunner a b = StateT (TemplateState a) Compiler b
templateRunner :: Context a -> Item a -> TemplateState a
templateRunner context item =
TemplateState
{ tplContextStack = [context],
tplItemStack = [item],
tplCallStack = ["item " ++ itemFilePath item]
}
tplItem :: TemplateRunner a (Item a)
tplItem = gets $ head . tplItemStack
tplContext :: TemplateRunner a (Context a)
tplContext = gets $ head . tplContextStack
tplWithItem :: Item a -> TemplateRunner a b -> TemplateRunner a b
tplWithItem item f = do
stack <- gets tplItemStack
modify' \s -> s {tplItemStack = item : stack}
x <- f
modify' \s -> s {tplItemStack = stack}
return x
tplWithContext :: Context a -> TemplateRunner a b -> TemplateRunner a b
tplWithContext context f =
gets tplContextStack >>= \stack -> do
let head' = case stack of
(next : _) -> context <> next
[] -> context
modify' \s -> s {tplContextStack = head' : stack}
x <- f
modify' \s -> s {tplContextStack = stack}
return x
tplWithCall :: String -> TemplateRunner a b -> TemplateRunner a b
tplWithCall call f = do
stack <- gets tplCallStack
modify' \s -> s {tplCallStack = call : stack}
x <- f
modify' \s -> s {tplCallStack = stack}
return x
tplWithField :: String -> TemplateRunner a b -> TemplateRunner a b
tplWithField field' f = do
file <- itemFilePath <$> tplItem
tplWithCall (show field' ++ " in " ++ file) f
tplFail :: String -> TemplateRunner a b
tplFail message = fail =<< tplTraced message
tplTrace :: TemplateRunner a [String]
tplTrace = gets tplCallStack
tplTraced :: String -> TemplateRunner a String
tplTraced message = do
trace <- tplTrace
return $ message ++ ", trace: [" ++ intercalate ", " trace ++ "]"
-- | Apply @f@ to an item if @key@ is requested.
field :: (IntoValue v a) => String -> (Item a -> Compiler v) -> Context a
field :: (IntoValue v a) => String -> (Item a -> TemplateRunner a v) -> Context a
field key f = Context f'
where
f' k i
| k == key = tryWithError k i (intoValue <$> f i)
| otherwise = noResult $ "Tried field key " ++ show key
tryWithError :: String -> Item a -> Compiler b -> Compiler b
tryWithError key item =
withErrorMessage $
"Error getting field " ++ show key
++ " for item "
++ show (itemIdentifier item)
f' k
| k == key = tplWithField k do
i <- tplItem
intoValue <$> f i
| otherwise = lift . noResult $ "tried " ++ show key
-- | Reports missing field.
missingField :: Context a
missingField = Context f
where
f key item =
tryWithError key item $
noResult $ "Missing field " ++ show key ++ " in context"
f key = lift . noResult $ "missing " ++ show key
-- | Const-valued field, returns the same @val@ per @key@.
constField :: (IntoValue v a) => String -> v -> Context a
@ -55,37 +117,49 @@ constField key val = field key f
mapField :: (FromValue v a, IntoValue w a) => (v -> w) -> Context a -> Context a
mapField g (Context f) = Context h
where
h k i = tryWithError k i $ fmap (intoValue . g) . fromValue =<< f k i
h k = tplWithCall ("mapField of " ++ show k) do
fmap (intoValue . g) $ fromValue =<< f k
bindField :: (FromValue v a, IntoValue w a) => (v -> Compiler w) -> Context a -> Context a
-- | Binding of function @g@ after context @f@.
bindField :: (FromValue v a, IntoValue w a) => (v -> TemplateRunner a w) -> Context a -> Context a
bindField g (Context f) = Context h
where
h k i = tryWithError k i $ fmap intoValue (g =<< fromValue =<< f k i)
h k = do
tplWithCall ("bindField of " ++ show k) do
fmap intoValue $ g =<< fromValue =<< f k
-- | Alternation of context @g@ after context @f@.
composeField :: Context a -> Context a -> Context a
composeField (Context g) (Context f) = Context h
where
h name item = f name item <|> g name item
h name = do
s <- get
lift $ evalStateT (f name) s <|> evalStateT (g name) s
-- | Lookup of @val@ by @key@ into provided @HashMap@.
hashMapField :: (IntoValue v a) => HashMap String v -> Context a
hashMapField m = Context f
where
m' = intoValue <$> m
f k _ = maybe (tried k) return (HashMap.lookup k m')
tried k = noResult $ "Tried field in map " ++ k
f k = maybe tried return (HashMap.lookup k m')
tried = lift . noResult $ "tried hashmap of " ++ show (HashMap.keys m')
functionField :: (FromValue v a, IntoValue w a) => String -> (v -> Context a -> Item a -> Compiler w) -> Context a
tplWithFunction :: String -> Context a -> Item a -> TemplateRunner a b -> TemplateRunner a b
tplWithFunction key context item =
tplWithField key
. tplWithContext context
. tplWithItem item
functionField :: (FromValue v a, IntoValue w a) => String -> (v -> TemplateRunner a w) -> Context a
functionField = constField
functionField2 :: (FromValue v a, FromValue x a, IntoValue w a) => String -> (v -> x -> Context a -> Item a -> Compiler w) -> Context a
functionField2 :: (FromValue v a, FromValue x a, IntoValue w a) => String -> (v -> x -> TemplateRunner a w) -> Context a
functionField2 = constField
functionField3 :: (FromValue v a, FromValue x a, FromValue y a, IntoValue w a) => String -> (v -> x -> y -> Context a -> Item a -> Compiler w) -> Context a
functionField3 :: (FromValue v a, FromValue x a, FromValue y a, IntoValue w a) => String -> (v -> x -> y -> TemplateRunner a w) -> Context a
functionField3 = constField
functionField4 :: (FromValue v a, FromValue x a, FromValue y a, FromValue z a, IntoValue w a) => String -> (v -> x -> y -> z -> Context a -> Item a -> Compiler w) -> Context a
functionField4 :: (FromValue v a, FromValue x a, FromValue y a, FromValue z a, IntoValue w a) => String -> (v -> x -> y -> z -> TemplateRunner a w) -> Context a
functionField4 = constField
instance Semigroup (Context a) where
@ -111,19 +185,18 @@ instance IntoContext Object a where
data ContextValue a
= EmptyValue
| UndefinedValue String
| ContextValue (Context a)
| ListValue [ContextValue a]
| BoolValue Bool
| StringValue String
| DoubleValue Double
| IntValue Int
| FunctionValue (ContextValue a -> Context a -> Item a -> Compiler (ContextValue a))
| FunctionValue (ContextValue a -> TemplateRunner a (ContextValue a))
| BlockValue Block
| ItemsValue (Context a) [Item a]
| ThunkValue (Compiler (ContextValue a))
| ItemValue (Context a) [Item a]
| ThunkValue (TemplateRunner a (ContextValue a))
type FunctionValue v w a = v -> Context a -> Item a -> Compiler w
type FunctionValue v w a = v -> TemplateRunner a w
type FunctionValue2 v x w a = v -> FunctionValue x w a
@ -134,23 +207,22 @@ type FunctionValue4 v x y z w a = v -> FunctionValue3 x y z w a
instance Show (ContextValue a) where
show = \case
EmptyValue -> "EmptyValue"
UndefinedValue name -> "UndefinedValue " ++ show name
ContextValue {} -> "ContextValue"
ListValue values -> "ListValue (" ++ show values ++ ")"
BoolValue b -> "BoolValue " ++ show b
StringValue t -> "StringValue " ++ show t
DoubleValue d -> "DoubleValue " ++ show d
IntValue i -> "IntValue " ++ show i
ListValue values -> "ListValue " ++ show values
BoolValue value -> "BoolValue " ++ show value
StringValue value -> "StringValue " ++ show value
DoubleValue value -> "DoubleValue " ++ show value
IntValue value -> "IntValue " ++ show value
FunctionValue {} -> "FunctionValue"
BlockValue {} -> "BlockValue"
ItemsValue _ items -> "ItemsValue (contains " ++ show (length items) ++ " items)"
ItemValue _ items -> "ItemValue " ++ show (itemFilePath <$> items)
ThunkValue {} -> "ThunkValue"
itemValue :: Context a -> Item a -> ContextValue a
itemValue context item = intoValue (context, [item])
itemsValue :: Context a -> [Item a] -> ContextValue a
itemsValue context items = intoValue (context, items)
itemListValue :: Context a -> [Item a] -> ContextValue a
itemListValue context items = intoValue (context, items)
class IntoValue' (flag :: Bool) v a where
intoValue' :: Proxy flag -> v -> ContextValue a
@ -160,6 +232,7 @@ type family FString a :: Bool where
FString Char = 'True
FString _ = 'False
-- | Inject a concrete type @v@ into a @ContextValue a@.
class IntoValue v a where
intoValue :: v -> ContextValue a
@ -202,7 +275,7 @@ instance IntoValue Int a where
intoValue = IntValue
instance IntoValue (Context a, [Item a]) a where
intoValue = uncurry ItemsValue
intoValue = uncurry ItemValue
instance (IntoValue v a) => IntoValue (Maybe v) a where
intoValue (Just v) = intoValue v
@ -211,39 +284,37 @@ instance (IntoValue v a) => IntoValue (Maybe v) a where
instance (FromValue v a, IntoValue w a) => IntoValue (FunctionValue v w a) a where
intoValue f = FunctionValue f'
where
f' cv context item = do
v <- tryWithError "into function1" item $ fromValue cv
intoValue <$> f v context item
f' cv = do
v <- fromValue cv
intoValue <$> f v
instance (FromValue v a, FromValue x a, IntoValue w a) => IntoValue (FunctionValue2 v x w a) a where
intoValue f = FunctionValue f'
where
f' cv _ item =
tryWithError "into function2" item $
intoValue . f <$> fromValue cv
f' cv =
intoValue . f <$> fromValue cv
instance (FromValue v a, FromValue x a, FromValue y a, IntoValue w a) => IntoValue (FunctionValue3 v x y w a) a where
intoValue f = FunctionValue f'
where
f' cv _ item =
tryWithError "into function3" item $
intoValue . f <$> fromValue cv
f' cv =
intoValue . f <$> fromValue cv
instance (FromValue v a, FromValue x a, FromValue y a, FromValue z a, IntoValue w a) => IntoValue (FunctionValue4 v x y z w a) a where
intoValue f = FunctionValue f'
where
f' cv _ item =
tryWithError "into function4" item $
intoValue . f <$> fromValue cv
f' cv =
intoValue . f <$> fromValue cv
instance IntoValue (Compiler (ContextValue a)) a where
instance IntoValue (TemplateRunner a (ContextValue a)) a where
intoValue = ThunkValue
-- | Extract a concrete value of type @v@ from a @ContextValue a@.
class FromValue v a where
fromValue :: ContextValue a -> Compiler v
fromValue :: ContextValue a -> TemplateRunner a v
class FromValue' (flag :: Bool) v a where
fromValue' :: Proxy flag -> ContextValue a -> Compiler v
fromValue' :: Proxy flag -> ContextValue a -> TemplateRunner a v
instance (FString v ~ flag, FromValue' flag [v] a) => FromValue [v] a where
fromValue = fromValue' (Proxy :: Proxy flag)
@ -289,7 +360,7 @@ instance FromValue Int a where
instance FromValue (Context a, [Item a]) a where
fromValue = \case
ItemsValue context item -> return (context, item)
ItemValue context items -> return (context, items)
ThunkValue fx -> fromValue =<< fx
x -> fail $ "Tried to get " ++ show x ++ " as Item"
@ -300,50 +371,42 @@ instance FromValue Block a where
x -> fail $ "Tried to get " ++ show x ++ " as Block"
instance (IntoValue v a, FromValue w a) => FromValue (FunctionValue v w a) a where
fromValue = \case
fromValue cv = case cv of
FunctionValue f -> return f'
where
f' v context item = do
tryWithError "from function1" item $
fromValue =<< f (intoValue v) context item
f' v = fromValue =<< f (intoValue v)
ThunkValue fx -> fromValue =<< fx
x -> fail $ "Tried to get " ++ show x ++ " as Function"
instance (IntoValue v a, IntoValue x a, FromValue w a) => FromValue (FunctionValue2 v x w a) a where
fromValue = \case
fromValue cv = case cv of
FunctionValue f -> return f'
where
f' v x context item = do
g <-
tryWithError "from function2" item $
fromValue =<< f (intoValue v) context item
g x context item
f' v x = do
g <- fromValue =<< f (intoValue v)
g x
ThunkValue fx -> fromValue =<< fx
x -> fail $ "Tried to get " ++ show x ++ " as Function"
x -> fail $ "Tried to get " ++ show x ++ " as Function2"
instance (IntoValue v a, IntoValue x a, IntoValue y a, FromValue w a) => FromValue (FunctionValue3 v x y w a) a where
fromValue = \case
FunctionValue f -> return f'
where
f' v x y context item = do
g <-
tryWithError "from function3" item $
fromValue =<< f (intoValue v) context item
h <- g x context item
h y context item
f' v x y = do
g <- fromValue =<< f (intoValue v)
h <- g x
h y
ThunkValue fx -> fromValue =<< fx
x -> fail $ "Tried to get " ++ show x ++ " as Function"
x -> fail $ "Tried to get " ++ show x ++ " as Function3"
instance (IntoValue v a, IntoValue x a, IntoValue y a, IntoValue z a, FromValue w a) => FromValue (FunctionValue4 v x y z w a) a where
fromValue = \case
FunctionValue f -> return f'
where
f' v x y z context item = do
g <-
tryWithError "from function3" item $
fromValue =<< f (intoValue v) context item
h <- g x context item
i <- h y context item
i z context item
f' v x y z = do
g <- fromValue =<< f (intoValue v)
h <- g x
i <- h y
i z
ThunkValue fx -> fromValue =<< fx
x -> fail $ "Tried to get " ++ show x ++ " as Function"
x -> fail $ "Tried to get " ++ show x ++ " as Function4"

12
src/Green/Template/Custom.hs

@ -2,15 +2,15 @@ module Green.Template.Custom
( module Green.Template,
module Green.Template.Custom.Compiler,
module Green.Template.Custom.Context,
module Green.Template.Custom.DateFields,
module Green.Template.Custom.GitFields,
module Green.Template.Custom.HtmlFields,
module Green.Template.Custom.DateField,
module Green.Template.Custom.GitField,
module Green.Template.Custom.HtmlField,
)
where
import Green.Template
import Green.Template.Custom.Compiler
import Green.Template.Custom.Context
import Green.Template.Custom.DateFields
import Green.Template.Custom.GitFields
import Green.Template.Custom.HtmlFields
import Green.Template.Custom.DateField
import Green.Template.Custom.GitField
import Green.Template.Custom.HtmlField

15
src/Green/Template/Custom/Compiler.hs

@ -1,5 +1,6 @@
module Green.Template.Custom.Compiler where
import Control.Monad.State.Strict
import Data.List (nub)
import Green.Common
import Green.Template
@ -16,20 +17,14 @@ pageCompilerWithSnapshots snapshots context =
>=> applyLayout context
>=> relativizeUrls
where
snapshots' =
nub
if "_content" `elem` snapshots
then snapshots
else "_content" : snapshots
snapshots' = nub ("_content" : snapshots)
applyLayout :: Context String -> Item String -> Compiler (Item String)
applyLayout context item = do
metadataContext <- getContext $ itemIdentifier item
unContext metadataContext "layout" item >>= \case
getMetadataField "layout" item >>= \case
StringValue layoutName -> do
let layoutPath = "_layouts" </> layoutName <.> "html"
layoutTemplate <- loadTemplateBody $ fromFilePath layoutPath
applyTemplate layoutTemplate context item
let layoutId = fromFilePath $ "_layouts" </> layoutName <.> "html"
loadAndApplyTemplate layoutId context item
_ -> do
debugCompiler $ "Did not receive String layout key for " ++ show (itemIdentifier item)
return item

9
src/Green/Template/Custom/Context.hs

@ -1,11 +1,10 @@
module Green.Template.Custom.Context where
import Green.Config
import Green.Template.Context
import Green.Template.Custom.DateFields
import Green.Template.Custom.GitFields
import Green.Template.Custom.HtmlFields
import Green.Template.Fields
import Green.Template
import Green.Template.Custom.DateField
import Green.Template.Custom.GitField
import Green.Template.Custom.HtmlField
import Lens.Micro
customContext :: SiteConfig -> Context String

44
src/Green/Template/Custom/DateFields.hs → src/Green/Template/Custom/DateField.hs

@ -1,4 +1,4 @@
module Green.Template.Custom.DateFields (dateFields) where
module Green.Template.Custom.DateField (dateFields) where
import Data.List (tails)
import Data.String.Utils
@ -25,26 +25,28 @@ dateFields config =
dateFormatField :: String -> TimeLocale -> Context a
dateFormatField key timeLocale = functionField2 key f
where
f (dateFormat :: String) (dateString :: String) _ _ = do
date <- thawTime timeLocale dateString
f (dateFormat :: String) (dateString :: String) = do
date <- deserializeTime dateString
return $ formatTime timeLocale dateFormat date
deserializeTime = parseTimeM' timeLocale normalizedFormat
dateField :: String -> TimeLocale -> Context a
dateField key timeLocale = field key f
where
f item =
dateFromMetadata timeLocale ["date", "published"] item
<|> dateFromFilePath timeLocale item
lift $
dateFromMetadata timeLocale ["date", "published"] item
<|> dateFromFilePath timeLocale item
publishedField :: String -> TimeLocale -> Context a
publishedField key timeLocale = field key f
where
f = dateFromMetadata timeLocale ["published"]
f = lift . dateFromMetadata timeLocale ["published"]
updatedField :: String -> TimeLocale -> Context a
updatedField key timeLocale = field key f
where
f = dateFromMetadata timeLocale ["updated"]
f = lift . dateFromMetadata timeLocale ["updated"]
dateFromMetadata :: TimeLocale -> [String] -> Item a -> Compiler String
dateFromMetadata timeLocale sourceKeys item =
@ -54,12 +56,16 @@ dateFromMetadata timeLocale sourceKeys item =
cacheKey = "Green.Template.Custom.DateFields.dateFromMetadata:" ++ show sourceKeys
id' = itemIdentifier item
findDate sourceKey = do
metadata <- getMetadata id' :: Compiler Metadata
metadata <- getMetadata id'
let maybeDate = lookupString sourceKey metadata
debugCompiler $ "Source key " ++ show sourceKey ++ " returned " ++ show maybeDate ++ " for date from metadata"
let notFound = noResult $ "Could not find metadata date using key " ++ show sourceKey
let maybeFrozenDate = freezeTime timeLocale metadataDateFormats =<< maybeDate
let notFound = noResult $ "tried date from metadata key " ++ show sourceKey
let maybeFrozenDate = serializeTime =<< maybeDate
maybe notFound return maybeFrozenDate
serializeTime dateString = do
date <- firstAlt (parse dateString <$> metadataDateFormats)
return $ normalizedTime timeLocale date
parse = flip $ parseTimeM True timeLocale
dateFromFilePath :: TimeLocale -> Item a -> Compiler String
dateFromFilePath timeLocale item =
@ -77,18 +83,14 @@ dateFromFilePath timeLocale item =
paths = splitDirectories $ dropExtension $ toFilePath $ itemIdentifier item
dateFromPath' path = do
debugCompiler $ "Trying to parse date from path " ++ show path
date <- parseTimeM True timeLocale "%Y-%m-%d" path :: Compiler ZonedTime
return $ formatTime timeLocale normalizedFormat date
date <- parseTimeM' timeLocale "%Y-%m-%d" path
return $ normalizedTime timeLocale date
freezeTime :: TimeLocale -> [String] -> String -> Maybe String
freezeTime timeLocale dateFormats dateString = do
date <- firstAlt (parse <$> dateFormats) :: Maybe ZonedTime
return $ formatTime timeLocale normalizedFormat date
where
parse dateFormat = parseTimeM True timeLocale dateFormat dateString
parseTimeM' :: (MonadFail m) => TimeLocale -> String -> String -> m ZonedTime
parseTimeM' = parseTimeM True
thawTime :: TimeLocale -> String -> Compiler ZonedTime
thawTime timeLocale = parseTimeM True timeLocale normalizedFormat
normalizedTime :: TimeLocale -> ZonedTime -> String
normalizedTime = flip formatTime normalizedFormat
normalizedFormat :: String
normalizedFormat = "%Y-%m-%dT%H:%M:%S%EZ"
@ -96,7 +98,7 @@ normalizedFormat = "%Y-%m-%dT%H:%M:%S%EZ"
metadataDateFormats :: [String]
metadataDateFormats =
[ "%Y-%m-%d",
"%Y-%m-%dT%H:%M:%S%EZ",
normalizedFormat,
"%Y-%m-%dT%H:%M:%S",
"%Y-%m-%d %H:%M:%S%EZ",
"%Y-%m-%d %H:%M:%S",

25
src/Green/Template/Custom/GitFields.hs → src/Green/Template/Custom/GitField.hs

@ -1,4 +1,4 @@
module Green.Template.Custom.GitFields (gitCommits) where
module Green.Template.Custom.GitField (gitCommits) where
import Data.Binary
import GHC.Generics (Generic)
@ -34,17 +34,17 @@ gitCommits config =
where
root = config ^. siteProviderDirectory
gitSha1Compiler :: String -> Item a -> Compiler String
gitSha1Compiler :: String -> Item a -> TemplateRunner a String
gitSha1Compiler = gitLogField "%h"
gitMessageCompiler :: String -> Item a -> Compiler String
gitMessageCompiler :: String -> Item a -> TemplateRunner a String
gitMessageCompiler = gitLogField "%s"
type LogFormat = String
gitLogField :: LogFormat -> String -> Item a -> Compiler String
gitLogField :: LogFormat -> String -> Item a -> TemplateRunner a String
gitLogField format root item =
unsafeCompiler do
lift $ unsafeCompiler do
maybeResult <- gitLog format (Just $ root </> toFilePath (itemIdentifier item))
case maybeResult of
Just result -> return result
@ -53,13 +53,14 @@ gitLogField format root item =
gitFileField :: (IntoValue v a) => String -> String -> (GitFile -> v) -> Context a
gitFileField root key f = field key $ fmap f . gitFileCompiler root
gitFileCompiler :: String -> Item a -> Compiler GitFile
gitFileCompiler :: String -> Item a -> TemplateRunner a GitFile
gitFileCompiler root item =
GitFile itemFilePath
<$> unsafeCompiler (doesFileExist itemFilePath)
<*> unsafeCompiler (isChanged itemFilePath)
lift $
GitFile gitFilePath
<$> unsafeCompiler (doesFileExist gitFilePath)
<*> unsafeCompiler (isChanged gitFilePath)
where
itemFilePath = root </> toFilePath (itemIdentifier item)
gitFilePath = root </> toFilePath (itemIdentifier item)
isChanged filePath = do
let args = ["diff", "HEAD", filePath]
(exitCode, stdout, _stderr) <- readProcessWithExitCode "git" args ""
@ -72,8 +73,8 @@ gitLog format filePath = do
(_exitCode, stdout, _stderr) <- readProcessWithExitCode "git" args ""
return if null stdout then Nothing else Just stdout
gitBranchCompiler :: Item a -> Compiler String
gitBranchCompiler _ = unsafeCompiler gitBranch
gitBranchCompiler :: Item a -> TemplateRunner a String
gitBranchCompiler _ = lift $ unsafeCompiler gitBranch
gitBranch :: IO String
gitBranch = do

19
src/Green/Template/Custom/HtmlFields.hs → src/Green/Template/Custom/HtmlField.hs

@ -1,4 +1,4 @@
module Green.Template.Custom.HtmlFields where
module Green.Template.Custom.HtmlField where
import Green.Common
import Green.Template
@ -14,8 +14,8 @@ siteRootField = constField "siteRoot"
codeField :: Context String
codeField = functionField "code" f
where
f (contentsPath :: String) _ _ =
trimStartEndLines <$> (tryLoad codeId <|> tryLoad fileId)
f (contentsPath :: String) =
lift $ trimStartEndLines <$> (tryLoad codeId <|> tryLoad fileId)
where
codeId = fromFilePath $ "code/" ++ contentsPath
fileId = fromFilePath contentsPath
@ -32,14 +32,15 @@ imgField :: Context String
imgField = functionField "img" f
where
defaults = defaultKeys ["id", "src", "title", "alt"]
f (imgFields :: Context String) context item = do
let fields = imgFields <> defaults <> context
itemBody <$> loadAndApplyTemplate (fromFilePath "_templates/image.html") fields item
f (imgFields :: Context String) =
tplWithContext (imgFields <> defaults) do
template <- loadTemplate' (fromFilePath "_templates/image.html")
applyTemplate' template
youtubeField :: Context String
youtubeField = functionField "youtube" f
where
defaults = defaultKeys ["id", "video", "title"]
f (ytFields :: Context String) context item = do
let fields = ytFields <> defaults <> context
itemBody <$> loadAndApplyTemplate "_templates/youtube.html" fields item
f (ytFields :: Context String) = do
tplWithContext (ytFields <> defaults) do
itemBody <$> loadAndApplyTemplate' (fromFilePath "_templates/youtube.html")

105
src/Green/Template/Fields.hs → src/Green/Template/Field.hs

@ -1,6 +1,6 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
module Green.Template.Fields where
module Green.Template.Field where
import qualified Data.HashMap.Strict as HashMap
import Data.String.Utils (endswith)
@ -26,14 +26,9 @@ defaultFields =
withField,
metadataField,
titleFromFileField "title",
undefinedField
missingField
]
undefinedField :: Context a
undefinedField = Context f
where
f k _ = return $ UndefinedValue k
defaultKeys :: [String] -> Context a
defaultKeys keys = intoContext $ (,"" :: String) <$> keys
@ -43,32 +38,39 @@ withField = functionField2 "with" f
f ::
FunctionValue2
(Context String)
(FunctionValue [Block] String String)
(FunctionValue [Block] String String)
[Block]
String
f context' g _ _ = do
return \t context -> g t (context' <> context)
String
f context blocks =
tplWithContext context do
reduceBlocks blocks
includeField :: String -> FilePath -> Context String
includeField key basePath = functionField key f
where
f (filePath :: String) context item =
let id' = fromFilePath (basePath </> filePath <.> "html")
in itemValue context <$> loadAndApplyTemplate id' context item
f (filePath :: String) = do
let filePath' = basePath </> filePath <.> "html"
tplWithCall (filePath' ++ " included via " ++ show key) do
context <- tplContext
result <- loadAndApplyTemplate' (fromFilePath filePath')
return $ itemValue context result
layoutField :: String -> FilePath -> Context String
layoutField key basePath = functionField2 key f
where
f (filePath :: FilePath) (blocks :: [Block]) context item = do
let layoutId = fromFilePath $ basePath </> filePath <.> "html"
reduced <- reduceBlocks context blocks item
template <- loadTemplateBody layoutId
itemValue context <$> applyTemplate template context (itemSetBody reduced item)
f (filePath :: FilePath) (blocks :: [Block]) = do
let filePath' = basePath </> filePath <.> "html"
tplWithCall (filePath' ++ " applied via " ++ show key) do
let layoutId = fromFilePath filePath'
(Template bs _) <- loadTemplate' layoutId
item <- itemSetBody <$> reduceBlocks blocks <*> tplItem
tplWithItem item do
reduceBlocks bs
ifField :: forall a. Context a
ifField = functionField2 "if" f
where
f (arg :: ContextValue a) (blocks :: [Block]) _ _ =
f (arg :: ContextValue a) (blocks :: [Block]) =
isTruthy arg <&> \case
True -> Just blocks
False -> Nothing
@ -76,23 +78,18 @@ ifField = functionField2 "if" f
forField :: Context String
forField = functionField2 "for" f
where
f (arg :: ContextValue String) (blocks :: [Block]) context item = do
arg' <- force arg
isTruthy arg' >>= \case
True ->
case arg' of
ItemsValue ctx xs -> Just . mconcat <$> mapM (reduce ctx) xs
ContextValue ctx -> Just <$> reduce ctx item
x -> fail $ "Unexpected " ++ show x ++ " in {{#for}}"
--
False -> return Nothing
where
reduce ctx = reduceBlocks (ctx <> context) blocks
f ((context, items) :: (Context String, [Item String])) (blocks :: [Block])
| null items = return Nothing
| otherwise =
tplWithContext context do
Just . mconcat <$> forM items \item ->
tplWithItem item do
reduceBlocks blocks
defaultField :: forall a. Context a
defaultField = functionField2 "default" f
where
f (default' :: ContextValue a) (arg :: ContextValue a) _ _ =
f (default' :: ContextValue a) (arg :: ContextValue a) =
isTruthy arg <&> \case
True -> arg
False -> default'
@ -100,21 +97,24 @@ defaultField = functionField2 "default" f
routeField :: Context String
routeField = functionField "route" f
where
f (filePath :: String) _ _ = do
f (filePath :: String) = lift do
let id' = fromFilePath filePath
getRoute id' >>= \case
Just r -> return $ "/" ++ stripSuffix "index.html" r
Nothing -> error $ "no route to " ++ show id'
Nothing -> noResult $ "no route to " ++ show id'
linkedTitleField :: Context String
linkedTitleField = constField "linkedTitle" f
where
f :: FunctionValue String String String
f filePath context item = do
linkedItem <- load (fromFilePath filePath)
makeLink <$> getField "title" linkedItem <*> getField "url" linkedItem
f filePath = do
linkedItem <- lift $ load (fromFilePath filePath)
tplWithItem linkedItem do
makeLink <$> getField "title" <*> getField "url"
where
getField key linkedItem = tryWithError key item $ fromValue =<< unContext context key linkedItem
getField key = do
context <- tplContext
fromValue =<< unContext context key
makeLink title url
| endswith ".html" filePath = "<a href=\"" ++ url ++ "\">" ++ escapeHtml title ++ "</a>"
| endswith ".md" filePath = "[" ++ escapeHtml title ++ "](" ++ url ++ ")"
@ -123,13 +123,15 @@ linkedTitleField = constField "linkedTitle" f
metadataField :: forall a. Context a
metadataField = Context f
where
f :: ContextFunction a
f key item = do
m <- getMetadata (itemIdentifier item)
maybe
(fail $ "Key " ++ show key ++ " not found in metadata")
(return . intoValue)
(HashMap.lookup (T.pack key) m)
f key = lift . getMetadataField key =<< tplItem
getMetadataField :: String -> Item a -> Compiler (ContextValue a)
getMetadataField key item = do
m <- getMetadata (itemIdentifier item)
maybe
(noResult $ "tried metadata key " ++ show key)
(return . intoValue)
(HashMap.lookup (T.pack key) m)
bodyField :: String -> Context String
bodyField key = field key $ return . itemBody
@ -137,10 +139,13 @@ bodyField key = field key $ return . itemBody
urlField :: String -> Context a
urlField key = field key f
where
f item =
f item = lift do
let id' = itemIdentifier item
empty' = fail $ "No route url found for item " ++ show id'
in maybe empty' toUrl <$> getRoute id'
maybeRoute <- getRoute id'
maybe
(fail $ "no url by " ++ show key ++ " found for item " ++ show id')