site

  1{-# LANGUAGE OverloadedStrings #-}
  2{-# LANGUAGE ViewPatterns #-}
  3
  4import Data.Maybe (fromJust)
  5import qualified Data.Char as Char
  6import qualified Data.Text as T
  7import Hakyll hiding (renderTagList)
  8import Hakyll.Core.Compiler.Internal (compilerTellDependencies)
  9import Hakyll.Core.Dependencies
 10import System.FilePath (replaceExtension, takeExtension)
 11import Text.Blaze ((!))
 12import Text.Blaze.Html.Renderer.String (renderHtml)
 13import qualified Text.Blaze.Html5 as H
 14import qualified Text.Blaze.Html5.Attributes as A
 15import qualified Text.Pandoc as P
 16import Text.Pandoc.Highlighting (Style, haddock, styleToCss)
 17import Text.Pandoc.Walk (walk)
 18
 19toLower :: String -> String
 20toLower = fmap Char.toLower
 21
 22------------------------------------------------------------------------
 23
 24linkToTag :: T.Text -> P.Inline
 25linkToTag name =
 26  let desc = "All pages tagged '" `T.append` name `T.append` "'"
 27      file = "/tags/" `T.append` T.toLower name `T.append` ".html"
 28    in P.Link ("", [], []) [P.Str name] (file, desc)
 29
 30-- Transform zk references to .md files to .html files.
 31--
 32-- TODO: Filter out references to private notes.
 33-- TODO: Support note references with anchors (e.g., for referencing a section).
 34fixupNoteRefs :: Item String -> Compiler (Item String)
 35fixupNoteRefs = pure . fmap (withUrls go)
 36 where
 37  go :: String -> String
 38  go url
 39    | isZkRef url = replaceExtension url ".html"
 40    | otherwise = url
 41
 42  -- Returns true if the URL is a reference to another zk note.
 43  isZkRef :: String -> Bool
 44  isZkRef ('#' : _) = False
 45  isZkRef url =
 46    let ext = takeExtension url
 47      in not (isExternal url) && (ext == "" || ext == ".md")
 48
 49-- Implements support for tags using Bear's multi-word tag syntax.
 50--
 51-- See:
 52--   • https://github.com/zk-org/zk/blob/dev/docs/notes/tags.md>
 53--   • https://github.com/zk-org/zk/blob/v0.15.1/internal/adapter/markdown/extensions/tag.go#L79
 54inlineBearTags :: [P.Inline] -> [P.Inline]
 55inlineBearTags (i@(P.Str (T.stripPrefix "#" -> Just tagRst)) : ix) =
 56  case takeTagElems (P.Str tagRst : ix) of
 57    Nothing -> i : inlineBearTags ix
 58    Just el ->
 59      let (tag, rst) = splitTag $ T.unwords el
 60          numElement = (length el - 1) * 2 -- count P.Space too
 61       in [linkToTag tag, P.Str rst] ++ inlineBearTags (drop numElement ix)
 62  where
 63    takeTagElems :: [P.Inline] -> Maybe [T.Text]
 64    takeTagElems (P.Str str : xs)
 65      | T.elem '#' str = Just [str]
 66      | otherwise = (str :) <$> takeTagElems xs
 67    takeTagElems (P.Space : xs) = takeTagElems xs
 68    takeTagElems _ = Nothing
 69
 70    splitTag :: T.Text -> (T.Text, T.Text)
 71    splitTag t = splitAtEx (fromJust $ T.findIndex (== '#') t) t
 72
 73    -- Like T.splitAt because exclude the seperator in 'snd'.
 74    splitAtEx :: Int -> T.Text -> (T.Text, T.Text)
 75    splitAtEx n t = let (b, a) = T.splitAt n t in (b, T.drop 1 a)
 76inlineBearTags (i : ix) = i : inlineBearTags ix
 77inlineBearTags [] = []
 78
 79pandocCodeStyle :: Style
 80pandocCodeStyle = haddock
 81
 82pandocCompilerZk :: Compiler (Item String)
 83pandocCompilerZk =
 84  cached "pandocCompilerZk" $
 85    (pandocCompilerZk' >>= fixupNoteRefs)
 86  where
 87    pandocCompilerZk' :: Compiler (Item String)
 88    pandocCompilerZk' =
 89      pandocCompilerWithTransform
 90       defaultHakyllReaderOptions
 91         { P.readerStripComments = True }
 92       defaultHakyllWriterOptions
 93         { P.writerHighlightStyle = Just pandocCodeStyle }
 94       (walk transform)
 95
 96    transform :: P.Block -> P.Block
 97    transform = walk inlineBearTags
 98
 99------------------------------------------------------------------------
100
101getMetadataItems :: Pattern -> Compiler [Item Metadata]
102getMetadataItems pattern = map (uncurry Item) <$> getAllMetadata pattern
103
104-- Custom version of Hakyll's renderTagList.
105-- TODO: Maybe produce a Context here.
106renderTagList :: Tags -> Compiler String
107renderTagList = renderTags makeLink concat
108  where
109    makeLink tag url count _minCount _maxCount =
110      renderHtml . H.li
111        $ H.a
112          ! A.href (H.toValue url)
113          ! A.class_ "tag"
114          ! A.title ("Navigate posts by tag '" <> H.stringValue tag <> "'")
115        $ H.toHtml (tag ++ " (" ++ show count ++ ")")
116
117------------------------------------------------------------------------
118
119config :: Configuration
120config = defaultConfiguration
121  { deployCommand = "./deploy.sh" }
122
123main :: IO ()
124main = hakyllWith config $ do
125    match "css/*" $ do
126        route   idRoute
127        compile compressCssCompiler
128    create ["css/syntax.css"] $ do
129        route idRoute
130        compile $
131          makeItem $ (compressCss $ styleToCss pandocCodeStyle)
132
133    tags <- buildTags "notes/*" (fromCapture "tags/*.html" . toLower)
134    create ["sidebar"] $ do
135      deps <- makePatternDependency KindMetadata (fromGlob "notes/*")
136      compile $ do
137        -- XXX: renderTagList/renderTags does not tell dependencies itself.
138        -- It cannot do so properly as it does not receive a 'Pattern' and
139        -- can thus not express the need for rebuilds on newly added pages.
140        --
141        -- https://github.com/jaspervdj/hakyll/blob/v4.16.7.1/lib/Hakyll/Web/Tags.hs#L183
142        compilerTellDependencies [deps]
143
144        allTagsCtx <- constField "allTags" <$> renderTagList tags
145        makeItem []
146          >>= loadAndApplyTemplate "templates/sidebar.html" allTagsCtx
147
148    match "index.md" $ do
149      route $ setExtension "html"
150      compile $ do
151        notes   <- getMetadataItems (fromGlob "notes/*") >>= recentFirst
152        sidebar <- constField "sidebar" <$> loadBody "sidebar"
153
154        pandocCompilerZk
155            >>= loadAndApplyTemplate
156                    "templates/index.html"
157                    (notesField "notes" (take 5 notes) <> defaultContext)
158            >>= saveSnapshot "content"
159            >>= loadAndApplyTemplate "templates/default.html" (sidebar <> noteCtx)
160            >>= relativizeUrls
161
162    match "notes/*" $ do
163      route $ setExtension "html"
164      compile $ do
165        sidebar <- constField "sidebar" <$> loadBody "sidebar"
166        let postTags = tagsField "tags" tags
167
168        pandocCompilerZk
169          >>= loadAndApplyTemplate "templates/note.html" (postTags <> noteCtx)
170          >>= saveSnapshot "content"
171          >>= loadAndApplyTemplate "templates/default.html" (sidebar <> noteCtx)
172          >>= relativizeUrls
173
174    tagsRules tags $ \tagStr tagsPattern -> do
175      route idRoute
176      compile $ do
177        aside <- constField "sidebar" <$> loadBody "sidebar"
178        notes <- getMetadataItems tagsPattern >>= recentFirst
179
180        let title   = constField "title" tagStr
181            baseCtx = title <> aside <> defaultContext
182            listCtx = title <> notesField "notes" notes
183
184        makeItem []
185          >>= loadAndApplyTemplate "templates/notes.html" listCtx
186          >>= loadAndApplyTemplate "templates/default.html" baseCtx
187          >>= relativizeUrls
188
189    match "templates/*" $ compile templateBodyCompiler
190
191--------------------------------------------------------------------------------
192
193dateCtx :: Context b
194dateCtx =
195  dateField "date" "%B %e, %Y"
196    -- See https://developer.mozilla.org/en-US/docs/Web/HTML/Reference/Elements/time#valid_datetime_values
197    <> dateField "datetime" "%F"
198
199noteCtx :: Context String
200noteCtx = dateCtx <> defaultContext
201
202notesField :: String -> [Item Metadata] -> Context String
203notesField name notes =
204  let fields = dateCtx <> urlField "url" <> metadataField
205   in listField name fields (pure notes)