Minor refactoring.

This commit is contained in:
Wen Kokke 2021-08-25 13:17:15 +01:00
parent a5e1f77d22
commit 78108f5750
No known key found for this signature in database
GPG key ID: 7EB7DBBCEB539DB8
3 changed files with 82 additions and 63 deletions

View file

@ -120,26 +120,28 @@ list:
.PHONY: publish .PHONY: publish
publish: setup-check-rsync publish: setup-check-rsync
make all @make all
make test @echo "Cleaning intermediate files"
@echo "Creating web branch..." rm -rf $(RAW_DIR)
@make test
@echo "Creating web branch"
git fetch --all git fetch --all
git checkout -b web --track origin/web git checkout -b web --track origin/web
rsync -a \ rsync -a \
--filter='P _site/' \ --filter='P $(SITE_DIR)/' \
--filter='P _cache/' \ --filter='P $(CACHE_DIR)' \
--filter='P .git/' \ --filter='P .git/' \
--filter='P .gitignore' \ --filter='P .gitignore' \
--filter='P .stack-work' \ --filter='P .stack-work' \
--filter='P .nojekyll' \ --filter='P .nojekyll' \
--filter='P CNAME' \ --filter='P CNAME' \
--delete-excluded \ --delete-excluded \
_site/ . $(SITE_DIR) .
git add -A git add -A
@echo "Publishing web branch..." @echo "Publishing web branch"
git commit -m "Publish." git commit -m "Publish."
git push origin web:web git push origin web:web
@echo "Deleting web branch..." @echo "Deleting web branch"
git checkout dev git checkout dev
git branch -D web git branch -D web

View file

@ -1,25 +1,47 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Hakyll.Web.Template.Context.Metadata where module Hakyll.Web.Template.Context.Metadata
( includeContext
, metadataContext
, objectContext
, restoreMetadata
) where
import Control.Monad ((<=<)) import Control.Monad ((<=<))
import Data.Aeson (Object, Value(..)) import Data.Aeson (Object, Value(..))
import qualified Data.ByteString.Char8 as BS
import qualified Data.HashMap.Strict as H import qualified Data.HashMap.Strict as H
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Vector as V import qualified Data.Vector as V
import Hakyll import Hakyll
import Text.Printf (printf) import Text.Printf (printf)
import qualified Data.Yaml as Y
-- |Create a context from a JSON object which loads the included file and uses it to generate a context.
includeContext :: Context String -> Context Object -- |Create a |Context| from the |Metadata| associated with an |Item|.
metadataContext
:: Context String -- ^ |Context| used when unfolding a JSON |Array| into a |ListField|.
-> Context String
metadataContext ctx = Context $ \k a i -> do
let identifier = itemIdentifier i
metadata <- getMetadata identifier
item <- makeItem metadata
unContext (objectContext ctx) k a item
-- |Create a |Context| from a JSON |Object| which loads data from files under "include" keys.
includeContext
:: Context String -- ^ |Context| used when unfolding a JSON |Array| into a |ListField|.
-> Context Object
includeContext ctx = Context $ \k a i -> do includeContext ctx = Context $ \k a i -> do
let o = itemBody i let o = itemBody i
v <- lookupObject "include" o v <- lookupObject "include" o
identifier <- fromFilePath <$> toString v identifier <- fromFilePath <$> toString v
unContext (ctx <> metadataContext ctx) k a =<< load identifier unContext (ctx <> metadataContext ctx) k a =<< load identifier
-- |Create a Context based on a JSON Object. -- |Create a |Context| from a JSON |Object|.
objectContext :: Context String -> Context Object objectContext
:: Context String -- ^ |Context| used when unfolding a JSON |Array| into a |ListField|.
-> Context Object
objectContext ctx = Context $ \k _ i -> do objectContext ctx = Context $ \k _ i -> do
let o = itemBody i let o = itemBody i
decodeValue ctx =<< lookupObject k o decodeValue ctx =<< lookupObject k o
@ -34,24 +56,30 @@ decodeValue _ctx (Number n) = return . StringField $ show n
decodeValue _ctx (Bool b) = return . StringField $ show b decodeValue _ctx (Bool b) = return . StringField $ show b
decodeValue _ctx v = fail $ printf "Unsupported value '%s'" (show v) decodeValue _ctx v = fail $ printf "Unsupported value '%s'" (show v)
-- |Create a Context based on the Metadata. -- |Lookup the |Value| stored in an |Object| at the given key.
metadataContext :: Context String -> Context String lookupObject :: MonadFail m => String -> Object -> m Value
metadataContext ctx = Context $ \k a i -> do
let identifier = itemIdentifier i
metadata <- getMetadata identifier
item <- makeItem metadata
unContext (objectContext ctx) k a item
lookupObject :: String -> Object -> Compiler Value
lookupObject k o = maybe ifNotFound ifFound (H.lookup (T.pack k) o) lookupObject k o = maybe ifNotFound ifFound (H.lookup (T.pack k) o)
where where
ifFound = return ifFound = return
ifNotFound = fail $ printf "Key '%s' undefined in context '%s'" k (show o) ifNotFound = fail $ printf "Key '%s' undefined in context '%s'" k (show o)
-- |Convert a |Value| to an |Object|, or fail.
toObject :: MonadFail m => Value -> m Object toObject :: MonadFail m => Value -> m Object
toObject (Object o) = return o toObject (Object o) = return o
toObject v = fail $ printf "Not an object '%s'" (show v) toObject v = fail $ printf "Not an object '%s'" (show v)
-- |Convert a |Value| to an |String|, or fail.
toString :: MonadFail m => Value -> m String toString :: MonadFail m => Value -> m String
toString (String s) = return (T.unpack s) toString (String s) = return (T.unpack s)
toString v = fail $ printf "Not a string '%s'" (show v) toString v = fail $ printf "Not a string '%s'" (show v)
-- |Add the original |Metadata| block back to the file.
restoreMetadata :: Item String -> Compiler (Item String)
restoreMetadata item = do
metadata <- getMetadata (itemIdentifier item)
if H.null metadata then
return item
else do
let yaml = "---\n" <> BS.unpack (Y.encode metadata) <> "---\n\n"
withItemBody (\body -> return (yaml <> body)) item

View file

@ -1,14 +1,12 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
import Control.Monad ((<=<), forM_) import Control.Monad ((<=<), (>=>), forM_)
import qualified Data.ByteString.Char8 as BS
import Data.Char (toLower) import Data.Char (toLower)
import Data.Functor ((<&>)) import Data.Functor ((<&>))
import Data.List (isPrefixOf, stripPrefix) import Data.List (isPrefixOf, stripPrefix)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.ICU as RE import qualified Data.Text.ICU as RE
import qualified Data.Text.ICU.Replace as T import qualified Data.Text.ICU.Replace as T
import qualified Data.Yaml as Y
import Hakyll import Hakyll
import Hakyll.Web.Agda import Hakyll.Web.Agda
import Hakyll.Web.Routes.Permalink import Hakyll.Web.Routes.Permalink
@ -149,30 +147,26 @@ main = do
-- Build function to fix local URLs -- Build function to fix local URLs
fixLocalLink <- mkFixLocalLink "src" fixLocalLink <- mkFixLocalLink "src"
-- Build compiler for Markdown pages let maybeCompileAgda
let pageCompiler :: Compiler (Item String) :: Maybe CommandLineOptions -- ^ If this argument is passed, Agda compilation is used.
pageCompiler = do -> Item String
csl <- load cslFileName -> Compiler (Item String)
bib <- load bibFileName maybeCompileAgda Nothing = return
getResourceBody maybeCompileAgda (Just opts) =
>>= saveSnapshot "raw" compileAgdaWith opts >=>
>>= readMarkdownWith siteReaderOptions withItemBody (return . withUrls fixStdlibLink) >=>
>>= processCites csl bib withItemBody (return . withUrls fixLocalLink)
<&> writeHTML5With siteWriterOptions
>>= loadAndApplyTemplate "templates/page.html" siteSectionContext
>>= loadAndApplyTemplate "templates/default.html" siteSectionContext
>>= prettifyUrls
-- Build compiler for literate Agda pages -- Build compiler for Markdown pages with optional Literate Agda
let pageWithAgdaCompiler :: CommandLineOptions -> Compiler (Item String) let pageCompiler
pageWithAgdaCompiler opts = do :: Maybe CommandLineOptions -- ^ If this argument is passed, Agda compilation is used.
-> Compiler (Item String)
pageCompiler maybeOpts = do
csl <- load cslFileName csl <- load cslFileName
bib <- load bibFileName bib <- load bibFileName
getResourceBody getResourceBody
>>= saveSnapshot "raw" >>= saveSnapshot "raw"
>>= compileAgdaWith opts >>= maybeCompileAgda maybeOpts
>>= withItemBody (return . withUrls fixStdlibLink)
>>= withItemBody (return . withUrls fixLocalLink)
>>= readMarkdownWith siteReaderOptions >>= readMarkdownWith siteReaderOptions
>>= processCites csl bib >>= processCites csl bib
<&> writeHTML5With siteWriterOptions <&> writeHTML5With siteWriterOptions
@ -250,12 +244,12 @@ main = do
-- Compile sections using literate Agda -- Compile sections using literate Agda
match "src/**.lagda.md" $ do match "src/**.lagda.md" $ do
route permalinkRoute route permalinkRoute
compile $ pageWithAgdaCompiler agdaOptions compile $ pageCompiler (Just agdaOptions)
-- Compile other sections and pages -- Compile other sections and pages
match ("README.md" .||. "src/**.md") $ do match ("README.md" .||. "src/**.md") $ do
route permalinkRoute route permalinkRoute
compile pageCompiler compile (pageCompiler Nothing)
-- Compile course pages -- Compile course pages
match "courses/**.lagda.md" $ do match "courses/**.lagda.md" $ do
@ -265,11 +259,11 @@ main = do
let courseOptions = agdaOptions let courseOptions = agdaOptions
{ optIncludePaths = courseDir : optIncludePaths agdaOptions { optIncludePaths = courseDir : optIncludePaths agdaOptions
} }
pageWithAgdaCompiler courseOptions pageCompiler (Just courseOptions)
match "courses/**.md" $ do match "courses/**.md" $ do
route permalinkRoute route permalinkRoute
compile pageCompiler compile $ pageCompiler Nothing
match "courses/**.pdf" $ do match "courses/**.pdf" $ do
route idRoute route idRoute
@ -324,6 +318,8 @@ main = do
compile copyFileCompiler compile copyFileCompiler
-- Raw versions used from Makefile for PDF and EPUB construction
-- Compile raw version of acknowledgements used in constructing the PDF -- Compile raw version of acknowledgements used in constructing the PDF
match "src/plfa/backmatter/acknowledgements.md" $ version "raw" $ do match "src/plfa/backmatter/acknowledgements.md" $ version "raw" $ do
route $ gsubRoute "src/" (const "raw/") route $ gsubRoute "src/" (const "raw/")
@ -475,10 +471,3 @@ addShiftedBody key = addDerivedField ("shifted_" <> key) deriveShiftedBody
shiftHeadersBy body = T.unpack (T.replaceAll re "#$1" (T.pack body)) shiftHeadersBy body = T.unpack (T.replaceAll re "#$1" (T.pack body))
where where
re = RE.regex [RE.Multiline] "^(#+)" re = RE.regex [RE.Multiline] "^(#+)"
-- |Add the original metadata block back to the file.
restoreMetadata :: Item String -> Compiler (Item String)
restoreMetadata item = do
metadata <- getMetadata (itemIdentifier item)
let yaml = "---\n" <> BS.unpack (Y.encode metadata) <> "---\n\n"
withItemBody (\body -> return (yaml <> body)) item