Output.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wall #-}

{- | The tree of output files of a build.

Each source file is the root of a tree, and the children of a file are the
files that were made from it. A file made from several files, such as a book
concatenated from several PDF files, appears once, under the first of them.
-}
module Document.Build.Output (
  -- * Trees
  Edges,
  edgeForest,
  describeForest,
  describeFile,

  -- * JSON
  outputForestToJSON,
  outputForestFromJSON,
  writeOutputForest,
  readOutputForest,

  -- * HTML
  outputForestHtml,
) where

import Control.Lens (cloneLens, view)
import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), eitherDecodeFileStrict, withObject, (.:))
import Data.Aeson.Encode.Pretty (encodePretty)
import qualified Data.Aeson.KeyMap as KeyMap
import Data.Aeson.Types (Parser, parseEither)
import qualified Data.ByteString.Lazy as LazyByteString
import Data.Containers.ListUtils (nubOrd)
import Data.Functor (($>))
import Data.List (isPrefixOf, sort)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Tree (Forest, Tree (..), flatten)
import Document.Build.Build (Build, attempt, createParentDirectory, io)
import Document.Build.Error (ReviewBuildError)
import Document.Build.Git (formatTimeUtc, readGitDetails)
import Document.Build.GitDetails (GitDetails)
import Document.Build.Hash (sha256)
import Document.Build.Image (readImageInfo)
import Document.Build.Name.GitCommitHashShort (GitCommitHashShortLike (..))
import Document.Build.Name.GitCommitTime (GitCommitTimeLike (..))
import Document.Build.Name.ImageFormat (ImageFormatLike (..))
import Document.Build.Name.ImageHeight (ImageHeightLike (..))
import Document.Build.Name.ImageWidth (ImageWidthLike (..))
import Document.Build.Name.OutputGitDetails (OutputGitDetailsLike (..))
import Document.Build.Name.OutputImageInfo (OutputImageInfoLike (..))
import Document.Build.Name.OutputPages (OutputPagesLike (..))
import Document.Build.Name.OutputPath (OutputPathLike (..))
import Document.Build.Name.OutputSha256 (OutputSha256Like (..))
import Document.Build.OutputFile (OutputFile (..))
import Document.Build.Pdf (pdfPages)
import Document.Build.Replace (xmlEscape)
import System.FilePath (makeRelative, normalise, splitDirectories)
import System.FilePather.Combinators (hasExtension)
import System.FilePather.Name.PathFunction (PathFunctionLike (..))

{- $setup
>>> import Data.Tree (drawForest)
-}

{- | The files a build made: each input file path, and the file paths that
were made from it.

@since 0.1.0.0
-}
type Edges = [(FilePath, [FilePath])]

{- | The forest of files given by the edges of a build, and other files. A
file that was made from no other file is a root; the children of a file are
the files made from it, in sorted order. A file made from several files is a
child of the first of them in the edges. Every file appears once, so a file
in a cycle of edges is also a root.

>>> putStr (drawForest (edgeForest [("src/report.fodt", ["public/report.fodt"]), ("public/report.fodt", ["public/report.pdf"]), ("public/report.pdf", ["public/report-1.pdf"])] ["public/pages.tar.gz"]))
public/pages.tar.gz
<BLANKLINE>
src/report.fodt
|
`- public/report.fodt
   |
   `- public/report.pdf
      |
      `- public/report-1.pdf
<BLANKLINE>

>>> putStr (drawForest (edgeForest [("a.pdf", ["book.pdf"]), ("b.pdf", ["book.pdf"])] []))
a.pdf
|
`- book.pdf
<BLANKLINE>
b.pdf
<BLANKLINE>

@since 0.1.0.0
-}
edgeForest :: Edges -> [FilePath] -> Forest FilePath
edgeForest es others =
  let pairs = [(normalise o, normalise i) | (i, os) <- es, o <- os, normalise o /= normalise i]
      parents = Map.fromListWith (\_ old -> old) pairs
      children = Map.fromListWith (<>) [(i, [o]) | (o, i) <- Map.toList parents]
      files = sort (nubOrd (concatMap (\(i, os) -> normalise i : fmap normalise os) es <> fmap normalise others))
      grow seen p =
        Node p (fmap (grow (Set.insert p seen)) (filter (`Set.notMember` seen) (sort (nubOrd (Map.findWithDefault [] p children)))))
      -- Files with no parent are roots. A file still not in the forest is in a
      -- cycle of edges, and is made a root as well.
      plant reached candidates =
        case candidates of
          [] -> []
          r : rs ->
            if r `Set.member` reached
              then plant reached rs
              else
                let t = grow reached r
                 in t : plant (foldr Set.insert reached (flatten t)) rs
   in plant Set.empty (filter (`Map.notMember` parents) files <> files)

{- | Describe every file of a forest. The git details of the root of each tree
are given to every file in the tree.

@since 0.1.0.0
-}
describeForest :: (ReviewBuildError e) => Forest FilePath -> Build e (Forest OutputFile)
describeForest =
  traverse
    ( \t@(Node r _) ->
        attempt (view (cloneLens pathFunction) readGitDetails r) >>= \g -> traverse (describeFile g) t
    )

{- | Describe a file, with the given git details: its hash, and its page count
or image information if it has them.

@since 0.1.0.0
-}
describeFile :: (ReviewBuildError e) => Maybe GitDetails -> FilePath -> Build e OutputFile
describeFile g p =
  do
    h <- view (cloneLens pathFunction) sha256 p
    n <- if hasExtension ["pdf"] p then attempt (view (cloneLens pathFunction) pdfPages p) else pure Nothing
    i <- if hasExtension ["png", "jpg", "jpeg", "gif", "svg", "webp", "tif", "tiff", "bmp"] p then attempt (view (cloneLens pathFunction) readImageInfo p) else pure Nothing
    pure (OutputFile p h g n i)

{- | A forest of output files as JSON: an array of trees, where each tree is
the object of its file, with its children in the field @children@.

@since 0.1.0.0
-}
outputForestToJSON :: Forest OutputFile -> Value
outputForestToJSON =
  let tree (Node a cs) =
        case toJSON a of
          Object o -> Object (KeyMap.insert "children" (toJSON (fmap tree cs)) o)
          v -> v
   in toJSON . fmap tree

{- | Parse a forest of output files from JSON, as written by
'outputForestToJSON'.

@since 0.1.0.0
-}
outputForestFromJSON :: Value -> Parser (Forest OutputFile)
outputForestFromJSON v =
  let tree =
        withObject "tree" $ \o ->
          Node <$> parseJSON (Object o) <*> (o .: "children" >>= traverse tree)
   in parseJSON v >>= traverse tree

{- | Write a forest of output files to a JSON file.

@since 0.1.0.0
-}
writeOutputForest :: FilePath -> Forest OutputFile -> Build e FilePath
writeOutputForest p f =
  (createParentDirectory p *> io (LazyByteString.writeFile p (encodePretty (outputForestToJSON f)))) $> p

{- | Read a forest of output files from a JSON file, as written by
'writeOutputForest'.

@since 0.1.0.0
-}
readOutputForest :: FilePath -> IO (Either String (Forest OutputFile))
readOutputForest p =
  (>>= parseEither outputForestFromJSON) <$> eitherDecodeFileStrict p

{- | An HTML page of a forest of output files, with a title. A file in the
given directory links to its path relative to the directory, so the page
belongs in that directory.

>>> Text.isInfixOf (Text.pack "<a href=\"report.pdf\">report.pdf</a>") (outputForestHtml "public" "Report" [Node (OutputFile "public/report.pdf" "ab" Nothing (Just 2) Nothing) []])
True

@since 0.1.0.0
-}
outputForestHtml :: FilePath -> String -> Forest OutputFile -> Text
outputForestHtml dir title f =
  let within p = splitDirectories (normalise dir) `isPrefixOf` splitDirectories (normalise p)
      name p =
        if within p
          then let r = makeRelative dir p in "<a href=\"" <> xmlEscape r <> "\">" <> xmlEscape r <> "</a>"
          else "<code>" <> xmlEscape p <> "</code>"
      details o =
        let parts =
              maybe [] (\pages -> [show pages <> if pages == 1 then " page" else " pages"]) (view (cloneLens outputPages) o)
                <> maybe [] (\i -> [show (view (cloneLens imageWidth) i) <> "×" <> show (view (cloneLens imageHeight) i) <> " " <> view (cloneLens imageFormat) i]) (view (cloneLens outputImageInfo) o)
                <> ["sha256 " <> take 12 (view (cloneLens outputSha256) o)]
                <> maybe [] (\d -> ["commit " <> view (cloneLens gitCommitHashShort) d <> " " <> formatTimeUtc (view (cloneLens gitCommitTime) d)]) (view (cloneLens outputGitDetails) o)
         in " <small>(" <> xmlEscape (concatWith "; " parts) <> ")</small>"
      tree (Node a cs) =
        "<li>" <> name (view (cloneLens outputPath) a) <> details a <> list cs <> "</li>\n"
      list cs =
        if null cs then "" else "\n<ul>\n" <> concatMap tree cs <> "</ul>\n"
      concatWith s xs =
        case xs of
          [] -> ""
          x : r -> x <> concatMap (s <>) r
   in Text.pack $
        "<!DOCTYPE html>\n<html>\n<head>\n<meta charset=\"utf-8\">\n<title>"
          <> xmlEscape title
          <> "</title>\n</head>\n<body>\n<h1>"
          <> xmlEscape title
          <> "</h1>"
          <> list f
          <> "</body>\n</html>\n"