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)
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 ((</>), 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 $ KM.fromList [("title", 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 . (>>= title) . (M.!? htag) <$> use tagMeta
  where
    title :: Y.Value -> Maybe String
    title obj = obj ^? key "title" . _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)
      ]

-- | 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 <$> traverse makePageMeta (maybe [] id $ tagmap M.!? htag) -- TODO sort page listings here

-- | 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
  subtags <-
    filter ((== htag) . init) . filter (not . null) . M.keys <$> use ehtags
  {- TODO sort tag listings here -}
  em <- extraMeta htag
  subtagMetas <- Y.array . filter (/= Y.Null) <$> traverse subtagMeta subtags
  pure $ meta `objMerge` Y.object [("subtags", subtagMetas)] `objMerge` em