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
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
|
{-# LANGUAGE OverloadedStrings #-}
module Tags where
import qualified Data.Aeson.Key as K
import qualified Data.Aeson.KeyMap as KM
import Data.Foldable (traverse_)
import Data.List (inits, nub, sortOn)
import Data.List.Extra (groupSort)
import qualified Data.Map as M
import Data.String (fromString)
import qualified Data.Text as T
import qualified Data.Yaml as Y
import Lens.Micro
import Lens.Micro.Aeson
import Lens.Micro.Mtl
import System.FilePath (joinPath, splitDirectories, takeFileName)
import AesonUtils
import Types
import Utils
-- | Split a tag string into a hierarchical tag elements. Corner slashes and
-- slash groups are removed.
splitTag :: String -> [String]
splitTag = dropWhile (all (== '/')) . splitDirectories
-- | Load all tag metadata from a directory.
sourceTagMeta :: FilePath -> Site ()
sourceTagMeta fp = do
tmf <- use tagMetaFile
let go p
| takeFileName p == tmf = sourceTagMetaFile (fp </> p)
| otherwise = pure ()
sourcePaths fp go
-- | Load a given tag metadata file.
sourceTagMetaFile :: FilePath -> Site ()
sourceTagMetaFile fp = do
yml' <-
io $ do
putStrLn $ "# <- " ++ fp
Y.decodeFileEither fp
case yml' of
Left err ->
error
("Failed to load tag metadata from "
++ fp
++ ": "
++ Y.prettyPrintParseException err)
Right yml -> traverse_ go (KM.toList yml)
where go :: (KM.Key, Y.Value) -> Site ()
go (k, v') =
let ks = K.toString k
kx = splitTag ks
v
| Y.String t <- v' = Y.object [("name", Y.String t)]
| Y.Object _ <- v' = v'
| otherwise =
error ("invalid definition of tag " ++ ks ++ " in " ++ fp)
ins (Just ov)
| v == ov = Just ov
| otherwise =
error
("conflicting tag metadata for tag "
++ ks
++ " in "
++ fp)
ins Nothing = Just v
in tagMeta %= M.alter ins kx
-- | Find a good display name for the _last_ hierarchical part of the htag.
getTagGroupName :: [String] -> Site String
getTagGroupName htag =
handleEmpty . maybe backup id . (>>= name) . (M.!? htag) <$> use tagMeta
where
name :: Y.Value -> Maybe String
name obj = obj ^? key "name" . _String . to T.unpack
backup
| null htag = ""
| null (last htag) = "(unnamed)"
| otherwise = last htag
handleEmpty x
| null x = "(root)"
| otherwise = x
-- | Get all tags from the pages of the site and fill in the `htags` and
-- `ehtags` data.
sourceTags :: Site ()
sourceTags = do
sgat <-
map
(second
$ map splitTag
. (^.. pageMeta . key "tags" . values . _String . to T.unpack))
. M.assocs
<$> use pages
ehtags .= M.fromList (invExpandTags sgat)
htags .= M.fromList (invTags sgat)
-- | Organize a list of pages with hierarchical tags to a list with
-- hierarchical tags with pages attached; with tags implying parents.
invExpandTags :: [(FilePath, [[String]])] -> [([String], [FilePath])]
invExpandTags x =
map (fmap nub) $ groupSort [(t, p) | (p, htl) <- x, ht <- htl, t <- inits ht]
-- | Like `invExpandTags` but without the expansion.
invTags :: [(FilePath, [[String]])] -> [([String], [FilePath])]
invTags x = map (fmap nub) $ groupSort [(t, p) | (p, htl) <- x, t <- htl]
-- | Extract the known metadata about a given tag, or give null if there's none.
htagMeta :: [String] -> Site Y.Value
htagMeta htag = maybe Y.Null id . (M.!? htag) <$> use tagMeta
-- | Make metadata for printing out a single hierarchical tag
htagRenderMeta :: ([String] -> Site FilePath) -> [String] -> Site Y.Value
htagRenderMeta makeLink htag = do
let htags = inits htag
links <- map fromString <$> traverse makeLink htags
names <- map fromString <$> traverse getTagGroupName htags
metas <- traverse htagMeta htags
pure
$ Y.object
[ ("href", last links)
, ("name", last names)
, ("meta", last metas)
, ( "htag"
, Y.array
$ zipWith3
(\l n m -> Y.object [("href", l), ("name", n), ("meta", m)])
links
names
metas)
]
data SortKey num
= Negative num
| Stringy String
| Positive num
deriving (Show, Eq, Ord)
toSortKey ident x
| Just i <- x ^? key "meta" . key "order" . _Number =
if i <= 0
then Negative i
else Positive i
| Just s <- x ^? key "meta" . key "order" . _String = Stringy (T.unpack s)
| Just n <- x ^? key "meta" . key "name" . _String = Stringy (T.unpack n)
| otherwise = Stringy ident
-- | A generic helper for rendering metadata for tagged pages.
genericTaggedPagesRenderMeta ::
(FilePath -> Site Y.Value)
-> [String]
-> M.Map [String] [FilePath]
-> Site Y.Value
genericTaggedPagesRenderMeta makePageMeta htag tagmap =
Y.array . map snd . sortOn (uncurry toSortKey)
<$> traverse metaPair (maybe [] id $ tagmap M.!? htag)
where
metaPair x = do
m <- makePageMeta x
pure (x, m)
-- | Render metadata for all precisely tagged pages (not considering the
-- inheritance of tags following the hierarchy).
exactlyTaggedPagesRenderMeta ::
(FilePath -> Site Y.Value) -> [String] -> Site Y.Value
exactlyTaggedPagesRenderMeta makePageLinkMeta t =
use htags >>= genericTaggedPagesRenderMeta makePageLinkMeta t
-- | Render metadata for all pages tagged by a given hierarchical tags (subtags
-- included).
allTaggedPagesRenderMeta ::
(FilePath -> Site Y.Value) -> [String] -> Site Y.Value
allTaggedPagesRenderMeta makePageLinkMeta t =
use ehtags >>= genericTaggedPagesRenderMeta makePageLinkMeta t
-- | Like `htagRenderMeta`, but has hooks for extra metadata (e.g., listing of
-- pages) and for sub-tag rendering. That can be used for recursively building
-- metadata for whole tag hierarchies.
htagRenderMetaWithSubtags ::
([String] -> Site FilePath)
-> ([String] -> Site Y.Value)
-> ([String] -> Site Y.Value)
-> [String]
-> Site Y.Value
htagRenderMetaWithSubtags makeLink extraMeta subtagMeta htag = do
meta <- htagRenderMeta makeLink htag
em <- extraMeta htag
subtags <-
filter ((== htag) . init) . filter (not . null) . M.keys <$> use ehtags
let metaPair x = do
m <- subtagMeta x
pure (joinPath x, m)
subtagMetas <-
Y.array . filter (/= Y.Null) . map snd . sortOn (uncurry toSortKey)
<$> traverse metaPair subtags
pure $ meta `objMerge` Y.object [("subtags", subtagMetas)] `objMerge` em
|
