site

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