Output.hs

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# 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 (
  -- * Output files
  OutputFile (..),
  outputPath,
  outputSha256,
  outputGitDetails,
  outputPages,
  outputImageInfo,
  GetOutputFile (..),
  HasOutputFile (..),
  ReviewOutputFile (..),
  AsOutputFile (..),

  -- * Trees
  Edges,
  edgeForest,
  describeForest,
  describeFile,

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

  -- * HTML
  outputForestHtml,
) where

import Control.DeepSeq (NFData)
import Control.Lens (Field1, Field2, Field3, Field4, Field5, Getter, Lens', Prism', Review, lens, prism', review, unto, view, _1, _2, _3, _4, _5, _Wrapped)
import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), eitherDecodeFileStrict, object, 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.Data (Data)
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 (GitDetails, formatTimeUtc, gitCommitHashShort, gitCommitTime, gitDetails)
import Document.Build.Hash (sha256)
import Document.Build.Image (ImageInfo (..), imageInfo)
import Document.Build.Pdf (pdfPages)
import Document.Build.Replace (xmlEscape)
import GHC.Generics (Generic)
import System.FilePath (makeRelative, normalise, splitDirectories)
import System.FilePather.Combinators (hasExtension)

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

{- | An output file: its path, its SHA-256 hash, the git details of the source
file at the root of its tree, its number of pages if it is a PDF file, and
information about it if it is an image.

@since 0.1.0.0
-}
data OutputFile
  = OutputFile FilePath String (Maybe GitDetails) (Maybe Int) (Maybe ImageInfo)
  deriving stock (Eq, Ord, Show, Generic, Data)
  deriving anyclass (NFData)

-- | @since 0.1.0.0
instance Field1 OutputFile OutputFile FilePath FilePath

-- | @since 0.1.0.0
instance Field2 OutputFile OutputFile String String

-- | @since 0.1.0.0
instance Field3 OutputFile OutputFile (Maybe GitDetails) (Maybe GitDetails)

-- | @since 0.1.0.0
instance Field4 OutputFile OutputFile (Maybe Int) (Maybe Int)

-- | @since 0.1.0.0
instance Field5 OutputFile OutputFile (Maybe ImageInfo) (Maybe ImageInfo)

-- | @since 0.1.0.0
instance ToJSON OutputFile where
  toJSON (OutputFile p h g n i) =
    object ["path" .= p, "sha256" .= h, "git" .= g, "pages" .= n, "image" .= i]

-- | @since 0.1.0.0
instance FromJSON OutputFile where
  parseJSON =
    withObject "OutputFile" $ \o ->
      OutputFile <$> o .: "path" <*> o .: "sha256" <*> o .:? "git" <*> o .:? "pages" <*> o .:? "image"

-- | @since 0.1.0.0
outputPath :: Lens' OutputFile FilePath
outputPath =
  _1
{-# INLINE outputPath #-}

-- | @since 0.1.0.0
outputSha256 :: Lens' OutputFile String
outputSha256 =
  _2
{-# INLINE outputSha256 #-}

{- | The git details of the source file at the root of the tree of the file.

@since 0.1.0.0
-}
outputGitDetails :: Lens' OutputFile (Maybe GitDetails)
outputGitDetails =
  _3
{-# INLINE outputGitDetails #-}

-- | @since 0.1.0.0
outputPages :: Lens' OutputFile (Maybe Int)
outputPages =
  _4
{-# INLINE outputPages #-}

-- | @since 0.1.0.0
outputImageInfo :: Lens' OutputFile (Maybe ImageInfo)
outputImageInfo =
  _5
{-# INLINE outputImageInfo #-}

-- | @since 0.1.0.0
class GetOutputFile s where
  getOutputFile :: Getter s OutputFile

-- | @since 0.1.0.0
instance GetOutputFile OutputFile where
  getOutputFile =
    id
  {-# INLINE getOutputFile #-}

-- | @since 0.1.0.0
class (GetOutputFile s) => HasOutputFile s where
  {-# MINIMAL setOutputFile #-}
  setOutputFile :: OutputFile -> s -> s

  outputFile :: Lens' s OutputFile
  outputFile =
    lens (view getOutputFile) (flip setOutputFile)
  {-# INLINE outputFile #-}

-- | @since 0.1.0.0
instance HasOutputFile OutputFile where
  setOutputFile =
    const
  {-# INLINE setOutputFile #-}

-- | @since 0.1.0.0
class ReviewOutputFile t where
  reviewOutputFile :: Review t OutputFile

-- | @since 0.1.0.0
instance ReviewOutputFile OutputFile where
  reviewOutputFile =
    unto id
  {-# INLINE reviewOutputFile #-}

-- | @since 0.1.0.0
class (ReviewOutputFile t) => AsOutputFile t where
  {-# MINIMAL matchOutputFile #-}
  matchOutputFile :: t -> Maybe OutputFile

  _OutputFile :: Prism' t OutputFile
  _OutputFile =
    prism' (review reviewOutputFile) matchOutputFile
  {-# INLINE _OutputFile #-}

-- | @since 0.1.0.0
instance AsOutputFile OutputFile where
  matchOutputFile =
    Just
  {-# INLINE matchOutputFile #-}

{- | 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 _Wrapped gitDetails 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 _Wrapped sha256 p
    n <- if hasExtension ["pdf"] p then attempt (view _Wrapped pdfPages p) else pure Nothing
    i <- if hasExtension ["png", "jpg", "jpeg", "gif", "svg", "webp", "tif", "tiff", "bmp"] p then attempt (view _Wrapped imageInfo 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 (OutputFile _ h g n i) =
        let parts =
              maybe [] (\pages -> [show pages <> if pages == 1 then " page" else " pages"]) n
                <> maybe [] (\(ImageInfo fmt w ht _ _ _ _ _ _) -> [show w <> "×" <> show ht <> " " <> fmt]) i
                <> ["sha256 " <> take 12 h]
                <> maybe [] (\d -> ["commit " <> view gitCommitHashShort d <> " " <> formatTimeUtc (view gitCommitTime d)]) g
         in " <small>(" <> xmlEscape (concatWith "; " parts) <> ")</small>"
      tree (Node a@(OutputFile p _ _ _ _) cs) =
        "<li>" <> name p <> 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"