first commit
This commit is contained in:
222
src/ChaoDoc.hs
Normal file
222
src/ChaoDoc.hs
Normal file
@@ -0,0 +1,222 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
|
||||
module ChaoDoc (chaoDocRead, chaoDocWrite, chaoDocCompiler) where
|
||||
|
||||
import SideNoteHTML (usingSideNotesHTML)
|
||||
import Control.Monad.State
|
||||
import Data.Either
|
||||
import Data.Functor
|
||||
import Data.List (intersect)
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe
|
||||
import Data.Text (Text, pack)
|
||||
import qualified Data.Text as T
|
||||
import Hakyll
|
||||
import System.IO.Unsafe
|
||||
import Text.Pandoc
|
||||
import Text.Pandoc.Builder
|
||||
import Text.Pandoc.Citeproc
|
||||
import Text.Pandoc.Walk (query, walk, walkM)
|
||||
|
||||
-- setMeta key val (Pandoc (Meta ms) bs) = Pandoc (Meta $ M.insert key val ms) bs
|
||||
|
||||
-- On mac, please do `export LANG=C` before using this thing
|
||||
chaoDocRead :: ReaderOptions
|
||||
chaoDocRead =
|
||||
def
|
||||
{ readerExtensions =
|
||||
enableExtension Ext_tex_math_double_backslash $
|
||||
enableExtension Ext_tex_math_single_backslash $
|
||||
enableExtension
|
||||
Ext_raw_tex
|
||||
pandocExtensions
|
||||
}
|
||||
|
||||
chaoDocWrite :: WriterOptions
|
||||
chaoDocWrite =
|
||||
def
|
||||
{ writerHTMLMathMethod = MathJax "",
|
||||
-- writerHtml5 = True,
|
||||
-- writerHighlightStyle = Just syntaxHighlightingStyle,
|
||||
writerNumberSections = True,
|
||||
writerTableOfContents = True,
|
||||
writerTOCDepth = 2
|
||||
}
|
||||
|
||||
-- getInline :: Inline -> [Inline]
|
||||
-- getInline x = [x]
|
||||
|
||||
pandocToInline :: Pandoc -> [Inline]
|
||||
pandocToInline (Pandoc _ blocks) = case blocks of
|
||||
[Plain inlines] -> inlines
|
||||
[Para inlines] -> inlines
|
||||
_ -> []
|
||||
|
||||
incrementalBlock :: [Text]
|
||||
incrementalBlock =
|
||||
[ "Theorem",
|
||||
"Conjecture",
|
||||
"Definition",
|
||||
"Example",
|
||||
"Lemma",
|
||||
"Problem",
|
||||
"Proposition",
|
||||
"Corollary",
|
||||
"Observation",
|
||||
"定理",
|
||||
"猜想",
|
||||
"定义",
|
||||
"例",
|
||||
"引理",
|
||||
"问题",
|
||||
"命题",
|
||||
"推论",
|
||||
"观察"
|
||||
]
|
||||
|
||||
otherBlock :: [Text]
|
||||
otherBlock = ["Proof", "Remark", "证明", "备注"]
|
||||
|
||||
theoremClasses :: [Text]
|
||||
theoremClasses = incrementalBlock ++ otherBlock
|
||||
|
||||
-- create a filter for theorems
|
||||
getClass :: Attr -> [Text]
|
||||
getClass (_, c, _) = c
|
||||
|
||||
addClass :: Attr -> Text -> Attr
|
||||
addClass (a, b, c) d = (a, d : b, c)
|
||||
|
||||
addAttr :: Attr -> Text -> Text -> Attr
|
||||
addAttr (a, b, c) x y = (a, b, (x, y) : c)
|
||||
|
||||
-- For each theorem, add a number, and also add add class theorem
|
||||
preprocessTheorems :: Block -> State Int Block
|
||||
preprocessTheorems (Div attr xs)
|
||||
| isIncremental = do
|
||||
curId <- get
|
||||
put (curId + 1)
|
||||
return $ Div (addAttr attr' "index" (pack $ show curId)) xs
|
||||
| isOtherBlock = return $ Div attr' xs
|
||||
| otherwise = return (Div attr xs)
|
||||
where
|
||||
isIncremental = getClass attr `intersect` incrementalBlock /= []
|
||||
isOtherBlock = getClass attr `intersect` otherBlock /= []
|
||||
theoremType = head (getClass attr `intersect` theoremClasses)
|
||||
attr' = addAttr attr "type" theoremType
|
||||
preprocessTheorems x = return x
|
||||
|
||||
theoremFilter :: Pandoc -> Pandoc
|
||||
theoremFilter doc = walk makeTheorem $ autorefFilter $ evalState (walkM preprocessTheorems doc) 1
|
||||
|
||||
-- [index, type, idx]
|
||||
theoremIndex :: Block -> [(Text, (Text, Text))]
|
||||
theoremIndex (Div attr _)
|
||||
| isNothing t = []
|
||||
| isIncremental = [(idx, (fromJust t, fromJust index))]
|
||||
| otherwise = []
|
||||
where
|
||||
(idx, _, parm) = attr
|
||||
t = lookup "type" parm
|
||||
index = lookup "index" parm
|
||||
isIncremental = fromJust t `elem` incrementalBlock
|
||||
theoremIndex _ = []
|
||||
|
||||
autoref :: [(Text, (Text, Text))] -> Inline -> Inline
|
||||
autoref x (Cite citations inlines)
|
||||
| valid = Link nullAttr [Str linkTitle] ("#" <> citeid, linkTitle)
|
||||
| otherwise = Cite citations inlines
|
||||
where
|
||||
citeid = citationId $ head citations
|
||||
valid = citeid `elem` map fst x
|
||||
(theoremType, num) = fromJust $ lookup citeid x
|
||||
linkTitle = theoremType <> " " <> num
|
||||
autoref _ y = y
|
||||
|
||||
autorefFilter :: Pandoc -> Pandoc
|
||||
autorefFilter x = walk (autoref links) x
|
||||
where
|
||||
links = query theoremIndex x
|
||||
|
||||
-- processCitations works on AST. If you want to use citations in theorem name,
|
||||
-- then you need to convert citations there to AST as well and then use processCitations\
|
||||
-- Thus one need to apply the theorem filter first.
|
||||
-- autoref still does not work.
|
||||
thmNamePandoc :: Text -> Pandoc
|
||||
thmNamePandoc x = fromRight (Pandoc nullMeta []) . runPure $ readMarkdown chaoDocRead x
|
||||
|
||||
makeTheorem :: Block -> Block
|
||||
makeTheorem (Div attr xs)
|
||||
| isNothing t = Div attr xs
|
||||
| otherwise = Div (addClass attr "theorem-environment") (Plain [header] : xs)
|
||||
where
|
||||
(_, _, parm) = attr
|
||||
t = lookup "type" parm
|
||||
name = lookup "title" parm
|
||||
index = lookup "index" parm
|
||||
header = Span (addClass nullAttr "theorem-header") [typetext, indextext, nametext]
|
||||
typetext = Span (addClass nullAttr "type") [Str $ fromJust t]
|
||||
indextext =
|
||||
if isNothing index
|
||||
then Str ""
|
||||
else Span (addClass nullAttr "index") [Str $ fromJust index]
|
||||
nametext =
|
||||
if isNothing name
|
||||
then Str ""
|
||||
else Span (addClass nullAttr "name") (pandocToInline $ thmNamePandoc $ fromJust name)
|
||||
makeTheorem x = x
|
||||
|
||||
-- bib from https://github.com/chaoxu/chaoxu.github.io/tree/develop
|
||||
cslFile :: String
|
||||
cslFile = "bib_style.csl"
|
||||
|
||||
bibFile :: String
|
||||
bibFile = "reference.bib"
|
||||
|
||||
chaoDocCompiler :: Compiler (Item String)
|
||||
chaoDocCompiler = do
|
||||
( getResourceBody
|
||||
>>= myReadPandocBiblio chaoDocRead (T.pack cslFile) (T.pack bibFile) myFilter
|
||||
)
|
||||
<&> writePandocWith chaoDocWrite
|
||||
|
||||
addMeta :: T.Text -> MetaValue -> Pandoc -> Pandoc
|
||||
addMeta name value (Pandoc meta a) =
|
||||
let prevMap = unMeta meta
|
||||
newMap = M.insert name value prevMap
|
||||
newMeta = Meta newMap
|
||||
in Pandoc newMeta a
|
||||
|
||||
myReadPandocBiblio ::
|
||||
ReaderOptions ->
|
||||
T.Text -> -- csl file name
|
||||
T.Text ->
|
||||
(Pandoc -> Pandoc) -> -- apply a filter before citeproc
|
||||
Item String ->
|
||||
Compiler (Item Pandoc)
|
||||
myReadPandocBiblio ropt csl biblio pdfilter item = do
|
||||
-- Parse CSL file, if given
|
||||
-- style <- unsafeCompiler $ CSL.readCSLFile Nothing . toFilePath . itemIdentifier $ csl
|
||||
|
||||
-- We need to know the citation keys, add then *before* actually parsing the
|
||||
-- actual page. If we don't do this, pandoc won't even consider them
|
||||
-- citations!
|
||||
-- let Biblio refs = itemBody biblio
|
||||
pandoc <- itemBody <$> readPandocWith ropt item
|
||||
let pandoc' =
|
||||
fromRight pandoc $
|
||||
unsafePerformIO $
|
||||
runIO $
|
||||
processCitations $
|
||||
addMeta "bibliography" (MetaList [MetaString biblio]) $
|
||||
addMeta "csl" (MetaString csl) $
|
||||
addMeta "link-citations" (MetaBool True) $
|
||||
addMeta "reference-section-title" (MetaInlines [Str "References"]) $
|
||||
pdfilter pandoc -- here's the change
|
||||
-- let a x = itemSetBody (pandoc' x)
|
||||
return $ fmap (const pandoc') item
|
||||
|
||||
myFilter :: Pandoc -> Pandoc
|
||||
myFilter = usingSideNotesHTML chaoDocWrite . theoremFilter
|
||||
161
src/SideNoteHTML.hs
Normal file
161
src/SideNoteHTML.hs
Normal file
@@ -0,0 +1,161 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{- |
|
||||
Module : Text.Pandoc.SideNoteHTML
|
||||
Description : Convert pandoc footnotes to sidenotes
|
||||
Copyright : (c) Tony Zorman 2023
|
||||
License : MIT
|
||||
Maintainer : Tony Zorman <soliditsallgood@mailbox.org>
|
||||
Stability : experimental
|
||||
Portability : non-portable
|
||||
-}
|
||||
module SideNoteHTML (usingSideNotesHTML) where
|
||||
|
||||
import Control.Monad (foldM)
|
||||
import Control.Monad.State (State, get, modify', runState)
|
||||
import Data.Text (Text)
|
||||
import Text.Pandoc (runPure, writeHtml5String)
|
||||
import Text.Pandoc.Definition (Block (..), Inline (..), Pandoc (..))
|
||||
import Text.Pandoc.Options (WriterOptions)
|
||||
import Text.Pandoc.Shared (tshow)
|
||||
import Text.Pandoc.Walk (walkM)
|
||||
import qualified Data.Text as T
|
||||
|
||||
-- type NoteType :: Type
|
||||
data NoteType = Sidenote | Marginnote
|
||||
deriving stock (Show, Eq)
|
||||
|
||||
-- type SidenoteState :: Type
|
||||
data SidenoteState = SNS
|
||||
{ _writer :: !WriterOptions
|
||||
, counter :: !Int
|
||||
}
|
||||
|
||||
-- type Sidenote :: Type -> Type
|
||||
type Sidenote = State SidenoteState
|
||||
|
||||
-- | Like 'Text.Pandoc.SideNote.usingSideNotes', but immediately
|
||||
-- pre-render the sidenotes. This has the advantage that sidenotes may
|
||||
-- be wrapped in a @<div>@ (instead of a 'Span'), which allows arbitrary
|
||||
-- blocks to be nested in them. The disadvantage is that one now has to
|
||||
-- specify the 'WriterOptions' for the current document, meaning this is
|
||||
-- meant to be used as a module and is unlikely to be useful as a
|
||||
-- standalone application.
|
||||
--
|
||||
-- ==== __Example__
|
||||
--
|
||||
-- Using this function with <https://jaspervdj.be/hakyll/ hakyll> could
|
||||
-- look something like the following, defining an equivalent to the
|
||||
-- default @pandocCompiler@.
|
||||
--
|
||||
-- > myPandocCompiler :: Compiler (Item String)
|
||||
-- > myPandocCompiler =
|
||||
-- > pandocCompilerWithTransformM
|
||||
-- > defaultHakyllReaderOptions
|
||||
-- > defaultHakyllWriterOptions
|
||||
-- > (usingSideNotesHTML defaultHakyllWriterOptions)
|
||||
--
|
||||
usingSideNotesHTML :: WriterOptions -> Pandoc -> Pandoc
|
||||
usingSideNotesHTML writer (Pandoc meta blocks) =
|
||||
-- Drop a superfluous paragraph at the start of the document.
|
||||
Pandoc meta . someStart . walkBlocks (SNS writer 0) $ blocks
|
||||
where
|
||||
someStart :: [Block] -> [Block]
|
||||
someStart = \case
|
||||
(Para [Str ""] : bs) -> bs
|
||||
bs -> bs
|
||||
|
||||
walkBlocks :: SidenoteState -> [Block] -> [Block]
|
||||
walkBlocks sns = \case
|
||||
[] -> []
|
||||
(b : bs) -> b' <> walkBlocks s' bs
|
||||
where (b', s') = walkM mkSidenote [b] `runState` sns
|
||||
|
||||
-- Sidenotes can probably appear in more places; this should be
|
||||
-- filled-in at some point.
|
||||
mkSidenote :: [Block] -> Sidenote [Block]
|
||||
mkSidenote = foldM (\acc b -> (acc <>) <$> single b) []
|
||||
where
|
||||
-- Try to find and render a sidenote in a single block.
|
||||
single :: Block -> Sidenote [Block]
|
||||
single = \case
|
||||
-- Simulate a paragraph by inserting a dummy block; this is needed
|
||||
-- in case two consecutive paragraphs have sidenotes, or a paragraph
|
||||
-- doesn't have one at all.
|
||||
Para inlines -> (Para [Str ""] :) <$> renderSidenote [] inlines
|
||||
Plain inlines -> renderSidenote [] inlines
|
||||
OrderedList attrs bs -> (:[]) . OrderedList attrs <$> traverse mkSidenote bs
|
||||
BulletList bs -> (:[]) . BulletList <$> traverse mkSidenote bs
|
||||
block -> pure [block]
|
||||
|
||||
renderSidenote :: [Inline] -> [Inline] -> Sidenote [Block]
|
||||
renderSidenote !inlines = \case
|
||||
[] -> pure [plain inlines]
|
||||
Note bs : xs -> do block <- go bs
|
||||
mappend [ -- Start gluing before, see [Note Comment].
|
||||
plain (RawInline "html" commentStart : inlines)
|
||||
, block
|
||||
]
|
||||
<$> renderSidenote
|
||||
[RawInline "html" commentEnd] -- End gluing after
|
||||
xs
|
||||
b : xs -> renderSidenote (b : inlines) xs
|
||||
where
|
||||
go :: [Block] -> Sidenote Block
|
||||
go blocks = do
|
||||
SNS w i <- get <* modify' (\sns -> sns{ counter = 1 + counter sns })
|
||||
let (typ, noteText) = getNoteType (render w blocks)
|
||||
pure . RawBlock "html" $
|
||||
mconcat [ commentEnd -- End gluing before
|
||||
, label typ i <> input i <> note typ noteText
|
||||
, commentStart -- Start gluing after
|
||||
]
|
||||
|
||||
-- The '{-}' symbol differentiates between margin note and side note.
|
||||
getNoteType :: Text -> (NoteType, Text)
|
||||
getNoteType t
|
||||
| "{-} " `T.isPrefixOf` t = (Marginnote, T.drop 4 t)
|
||||
| otherwise = (Sidenote , t)
|
||||
|
||||
render :: WriterOptions -> [Block] -> Text
|
||||
render w bs = case runPure (writeHtml5String w (Pandoc mempty bs)) of
|
||||
Left err -> error $ "Text.Pandoc.SideNoteHTML.writePandocWith: " ++ show err
|
||||
Right txt -> T.drop 1 (T.dropWhile (/= '\n') txt)
|
||||
|
||||
commentEnd :: T.Text
|
||||
commentEnd = "-->"
|
||||
|
||||
commentStart :: T.Text
|
||||
commentStart = "<!--"
|
||||
|
||||
plain :: [Inline] -> Block
|
||||
plain = Plain . reverse
|
||||
|
||||
label :: NoteType -> Int -> Text
|
||||
label nt i = "<label for=\"sn-" <> tshow i <> "\" class=\"margin-toggle" <> sidenoteNumber <> "\">" <> altSymbol <> "</label>"
|
||||
where
|
||||
sidenoteNumber :: Text = case nt of
|
||||
Sidenote -> " sidenote-number"
|
||||
Marginnote -> ""
|
||||
altSymbol :: Text = case nt of
|
||||
Sidenote -> ""
|
||||
Marginnote -> "⊕"
|
||||
|
||||
input :: Int -> Text
|
||||
input i = "<input type=\"checkbox\" id=\"sn-" <> tshow i <> "\" class=\"margin-toggle\"/>"
|
||||
|
||||
note :: NoteType -> Text -> Text
|
||||
note nt body = "<div class=\"" <> T.toLower (tshow nt) <> "\">" <> body <> "</div>"
|
||||
|
||||
{- [Note Comment]
|
||||
|
||||
This is obviously horrible, but we have to do this in order for the
|
||||
blocks (which are now not inline elements anymore!) immediately before
|
||||
and after the sidenote to be "glued" to the sidenote itself. In this
|
||||
way, the number indicating the sidenote does not have an extra space
|
||||
associated to it on either side, which otherwise would be the case.
|
||||
|
||||
-}
|
||||
256
src/site.hs
Normal file
256
src/site.hs
Normal file
@@ -0,0 +1,256 @@
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
import ChaoDoc
|
||||
-- import Data.Either
|
||||
-- import Data.Functor
|
||||
-- import qualified Data.Map as M
|
||||
import qualified Data.Text as T
|
||||
import Hakyll
|
||||
-- import System.IO.Unsafe
|
||||
import Text.Pandoc
|
||||
-- import Text.Pandoc.Citeproc
|
||||
import System.FilePath
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- https://www.rohanjain.in/hakyll-clean-urls/
|
||||
cleanRoute :: Routes
|
||||
cleanRoute = customRoute createIndexRoute
|
||||
where
|
||||
createIndexRoute ident = takeDirectory p </> takeBaseName p </> "index.html"
|
||||
where p = toFilePath ident
|
||||
|
||||
cleanIndexHtmls :: Item String -> Compiler (Item String)
|
||||
cleanIndexHtmls = return . fmap (replaceAll pattern replacement)
|
||||
where
|
||||
pattern::String = "/index.html"
|
||||
replacement::String->String = const "/"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
main :: IO ()
|
||||
main = hakyll $ do
|
||||
match "images/**" $ do
|
||||
route idRoute
|
||||
compile copyFileCompiler
|
||||
|
||||
match "mathjax/**" $ do
|
||||
route idRoute
|
||||
compile copyFileCompiler
|
||||
|
||||
match "mathjax-fira-font/**" $ do
|
||||
route idRoute
|
||||
compile copyFileCompiler
|
||||
|
||||
match "fonts/*" $ do
|
||||
route idRoute
|
||||
compile copyFileCompiler
|
||||
|
||||
match "404.html" $ do
|
||||
route cleanRoute
|
||||
compile copyFileCompiler
|
||||
|
||||
match "css/*" $ do
|
||||
route idRoute
|
||||
compile compressCssCompiler
|
||||
|
||||
match "index.md" $ do
|
||||
route $ setExtension "html"
|
||||
compile $
|
||||
chaoDocCompiler
|
||||
>>= loadAndApplyTemplate "templates/index.html" defaultContext
|
||||
>>= relativizeUrls
|
||||
>>= cleanIndexHtmls
|
||||
|
||||
match ( fromList["talks.md","invited_speaker.md","registration.md","program.md","venue.md","travel.md","social_event.md","travel_support.md","contact.md"] ) $ do
|
||||
route cleanRoute
|
||||
compile $
|
||||
chaoDocCompiler
|
||||
>>= loadAndApplyTemplate "templates/standalone.html" defaultContext
|
||||
>>= relativizeUrls
|
||||
|
||||
-- -- build up tags
|
||||
-- tags <- buildTags "posts/*" (fromCapture "tags/*.html")
|
||||
-- tagsRules tags $ \tag pattern -> do
|
||||
-- let title = "Posts tagged \"" ++ tag ++ "\""
|
||||
-- route cleanRoute
|
||||
-- compile $ do
|
||||
-- posts <- recentFirst =<< loadAll pattern
|
||||
-- let ctx =
|
||||
-- constField "title" title
|
||||
-- `mappend` listField "posts" (postCtxWithTags tags) (return posts)
|
||||
-- `mappend` defaultContext
|
||||
-- makeItem ""
|
||||
-- >>= loadAndApplyTemplate "templates/tag.html" ctx
|
||||
-- >>= loadAndApplyTemplate "templates/default.html" ctx
|
||||
-- >>= relativizeUrls
|
||||
|
||||
-- create ["tags.html"] $ do
|
||||
-- route cleanRoute
|
||||
-- compile $ do
|
||||
-- makeItem ""
|
||||
-- >>= loadAndApplyTemplate "templates/tags.html" (defaultCtxWithTags tags)
|
||||
-- >>= loadAndApplyTemplate "templates/default.html" (defaultCtxWithTags tags)
|
||||
|
||||
-- match "posts/*" $ do
|
||||
-- route cleanRoute
|
||||
-- compile $ do
|
||||
-- tocCtx <- getTocCtx (postCtxWithTags tags)
|
||||
-- chaoDocCompiler
|
||||
-- >>= loadAndApplyTemplate "templates/post.html" tocCtx
|
||||
-- >>= loadAndApplyTemplate "templates/default.html" tocCtx
|
||||
-- >>= relativizeUrls
|
||||
-- -- >>= katexFilter -- use mathjax.
|
||||
|
||||
-- match "standalone/*" $ do
|
||||
-- route cleanRoute
|
||||
-- compile $ do
|
||||
-- tocCtx <- getTocCtx (postCtxWithTags tags)
|
||||
-- chaoDocCompiler
|
||||
-- >>= loadAndApplyTemplate "templates/standalone.html" tocCtx
|
||||
-- >>= relativizeUrls
|
||||
|
||||
-- create ["notes.html"] $ do
|
||||
-- route cleanRoute
|
||||
-- compile $ do
|
||||
-- notes <- recentFirst =<< loadAll "standalone/*"
|
||||
-- let notesCtx =
|
||||
-- listField "posts" postCtx (return notes)
|
||||
-- `mappend` constField "title" "Notes"
|
||||
-- `mappend` defaultContext
|
||||
-- makeItem ""
|
||||
-- >>= loadAndApplyTemplate "templates/notes.html" notesCtx
|
||||
-- >>= loadAndApplyTemplate "templates/index.html" notesCtx
|
||||
-- >>= relativizeUrls
|
||||
-- >>= cleanIndexHtmls
|
||||
|
||||
-- create ["archive.html"] $ do
|
||||
-- route cleanRoute
|
||||
-- compile $ do
|
||||
-- posts <- recentFirst =<< loadAll "posts/*"
|
||||
-- let archiveCtx =
|
||||
-- listField "posts" postCtx (return posts)
|
||||
-- `mappend` constField "title" "Archives"
|
||||
-- `mappend` defaultContext
|
||||
-- makeItem ""
|
||||
-- >>= loadAndApplyTemplate "templates/archive.html" archiveCtx
|
||||
-- >>= loadAndApplyTemplate "templates/index.html" archiveCtx
|
||||
-- >>= relativizeUrls
|
||||
-- >>= cleanIndexHtmls
|
||||
|
||||
-- create ["draft.html"] $ do
|
||||
-- route cleanRoute
|
||||
-- compile $ do
|
||||
-- posts <- recentFirst =<< loadAll "posts/*"
|
||||
-- let draftCtx =
|
||||
-- listField "posts" postCtx (return posts)
|
||||
-- `mappend` constField "title" "Drafts"
|
||||
-- `mappend` defaultContext
|
||||
-- makeItem ""
|
||||
-- >>= loadAndApplyTemplate "templates/draft.html" draftCtx
|
||||
-- >>= loadAndApplyTemplate "templates/index.html" draftCtx
|
||||
-- >>= relativizeUrls
|
||||
-- >>= cleanIndexHtmls
|
||||
|
||||
-- match "index.html" $ do
|
||||
-- route idRoute
|
||||
-- compile $ do
|
||||
-- posts <- fmap (take 25) . recentFirst =<< loadAll "posts/*"
|
||||
-- let indexCtx =
|
||||
-- listField "posts" postCtx (return posts)
|
||||
-- `mappend` defaultContext
|
||||
-- getResourceBody
|
||||
-- >>= applyAsTemplate indexCtx
|
||||
-- >>= loadAndApplyTemplate "templates/index.html" indexCtx
|
||||
-- >>= relativizeUrls
|
||||
-- >>= cleanIndexHtmls
|
||||
|
||||
match "templates/*" $ compile templateBodyCompiler
|
||||
|
||||
-- https://robertwpearce.com/hakyll-pt-2-generating-a-sitemap-xml-file.html
|
||||
-- create ["sitemap.xml"] $ do
|
||||
-- route idRoute
|
||||
-- compile $ do
|
||||
-- posts <- recentFirst =<< loadAll "posts/*"
|
||||
-- singlePages <- loadAll (fromList ["about.md"])
|
||||
-- let pages = posts <> singlePages
|
||||
-- sitemapCtx =
|
||||
-- constField "root" root
|
||||
-- <> listField "pages" postCtx (return pages) -- here
|
||||
-- makeItem ""
|
||||
-- >>= loadAndApplyTemplate "templates/sitemap.xml" sitemapCtx
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
postCtx :: Context String
|
||||
postCtx =
|
||||
dateField "date" "%B %e, %Y"
|
||||
-- <> constField "root" root
|
||||
<> dateField "date" "%Y-%m-%d"
|
||||
<> defaultContext
|
||||
|
||||
postCtxWithTags :: Tags -> Context String
|
||||
postCtxWithTags tags = tagsField "tags" tags `mappend` postCtx
|
||||
|
||||
defaultCtxWithTags :: Tags -> Context String
|
||||
defaultCtxWithTags tags = listField "tags" tagsCtx getAllTags <> defaultContext
|
||||
where
|
||||
getAllTags :: Compiler [Item (String, [Identifier])]
|
||||
getAllTags = pure . map mkItem $ tagsMap tags
|
||||
where
|
||||
mkItem :: (String, [Identifier]) -> Item (String, [Identifier])
|
||||
mkItem x@(t, _) = Item (tagsMakeId tags t) x
|
||||
tagsCtx =
|
||||
listFieldWith "posts" (postCtxWithTags tags) getPosts
|
||||
<> metadataField
|
||||
<> urlField "url"
|
||||
<> pathField "path"
|
||||
<> titleField "title"
|
||||
<> missingField
|
||||
where
|
||||
getPosts ::
|
||||
Item (String, [Identifier]) ->
|
||||
Compiler [Item String]
|
||||
getPosts (itemBody -> (_, is)) = mapM load is
|
||||
|
||||
|
||||
-- toc from https://github.com/slotThe/slotThe.github.io
|
||||
getTocCtx :: Context a -> Compiler (Context a)
|
||||
getTocCtx ctx = do
|
||||
noToc <- (Just "true" ==) <$> (getUnderlying >>= (`getMetadataField` "no-toc"))
|
||||
writerOpts <- mkTocWriter defaultHakyllWriterOptions
|
||||
toc <- renderPandocWith chaoDocRead writerOpts =<< getResourceBody
|
||||
pure $
|
||||
mconcat
|
||||
[ ctx,
|
||||
constField "toc" $ killLinkIds (itemBody toc),
|
||||
if noToc then boolField "no-toc" (pure noToc) else mempty
|
||||
]
|
||||
where
|
||||
mkTocWriter :: WriterOptions -> Compiler WriterOptions
|
||||
mkTocWriter writerOpts = do
|
||||
tmpl <- either (const Nothing) Just <$> unsafeCompiler (compileTemplate "" "$toc$")
|
||||
pure $
|
||||
writerOpts
|
||||
{ writerTableOfContents = True,
|
||||
writerTOCDepth = 2,
|
||||
writerTemplate = tmpl,
|
||||
writerHTMLMathMethod = MathJax ""
|
||||
}
|
||||
|
||||
asTxt :: (T.Text -> T.Text) -> String -> String
|
||||
asTxt f = T.unpack . f . T.pack
|
||||
|
||||
killLinkIds :: String -> String
|
||||
killLinkIds = asTxt (mconcat . go . T.splitOn "id=\"toc-")
|
||||
where
|
||||
go :: [T.Text] -> [T.Text]
|
||||
go = \case
|
||||
[] -> []
|
||||
x : xs -> x : map (T.drop 1 . T.dropWhile (/= '\"')) xs
|
||||
|
||||
-- katexFilter :: Item String -> Compiler (Item String)
|
||||
-- katexFilter = withItemBody (unixFilter "./katex_cli" [])
|
||||
Reference in New Issue
Block a user