reploy/Tags.hs

{-# 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