1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
|
{-# LANGUAGE OverloadedStrings #-}
import Hakyll
import Control.Monad ((>=>), when)
import Data.Foldable (traverse_)
import Data.List (inits, nub)
import Data.List.Extra (groupSort)
import Data.Maybe (fromMaybe)
import System.FilePath
( (</>)
, dropTrailingPathSeparator
, joinPath
, normalise
, splitDirectories
)
import Debug.Trace
getMount' :: a -> (String -> a) -> Metadata -> a
getMount' a b = maybe a b . lookupString "mount"
getMount :: Metadata -> Routes
getMount = getMount' idRoute constRoute
indexInDir :: Routes -> Routes
indexInDir = flip composeRoutes . customRoute $ (</> "index.html") . toFilePath
makePage :: Rules ()
makePage = do
route $ indexInDir (metadataRoute getMount)
compile $
pandocCompiler >>= loadAndApplyTemplate "templates/page.html" pageCtx >>=
loadAndApplyTemplate "templates/default.html" pageCtx >>=
relativizeUrls
extractRedirs :: Identifier -> Rules (Identifier, [Identifier])
extractRedirs ident = do
md <- getMetadata ident
let to = getMount' ident fromFilePath md
froms =
fromMaybe [] $
map (fromFilePath . dropTrailingPathSeparator . normalise) <$>
lookupStringList "redirects" md
pure (to, froms)
makeRedirects :: Identifier -> [Identifier] -> Rules ()
makeRedirects to froms =
create froms $ do
route $ indexInDir idRoute
compile . makeItem . Redirect . ('/' :) . toFilePath $ to
spawnRedirects :: [Identifier] -> Rules ()
spawnRedirects = traverse_ (extractRedirs >=> uncurry makeRedirects)
extractHTagLinks :: Identifier -> Rules (Identifier, [[String]])
extractHTagLinks ident = do
md <- getMetadata ident
let to = getMount' ident fromFilePath md
htags = maybe [] (map splitDirectories) $ lookupStringList "tags" md
when (null htags) . fail $ "Uncategorized: " ++ show ident
pure (to, htags)
invTags :: [(Identifier, [[String]])] -> [([String], [String])]
invTags x =
map (fmap (map ('/' :) . nub . map toFilePath)) $
groupSort [(t, p) | (p, htl) <- x, ht <- htl, t <- inits ht]
makeTag :: [FilePath] -> [String] -> Rules ()
makeTag htag pages =
create [fromFilePath $ joinPath ("tags" : htag)] $ do
route (indexInDir idRoute)
compile $ do
let ctx =
mconcat
[ constField "title" ("Pages tagged " ++ joinPath htag)
, listField
"htags"
(field "htag" (return . itemBody))
(traverse makeItem htag)
, listField
"pages"
(field "page" (return . itemBody))
(traverse makeItem pages)
, defaultContext
]
makeItem "" >>= loadAndApplyTemplate "templates/tag.html" ctx >>=
loadAndApplyTemplate "templates/default.html" ctx >>=
relativizeUrls
spawnTags =
traverse extractHTagLinks >=> pure . invTags >=> traverse_ (uncurry makeTag)
main :: IO ()
main =
hakyll $
{- Source the pages -}
do
match "external/**/*.md" makePage
{- Source and process the redirects -}
getMatches "external/**/*.md" >>= spawnRedirects
{- Source and process the tags -}
getMatches "external/**/*.md" >>= spawnTags
{- Compile the templates (no routing, cache-only) -}
match "templates/*" $ compile templateBodyCompiler
pageCtx :: Context String
pageCtx = defaultContext
|
