Documents.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wall #-}

{- | Build a document project with its directories and rules.

A build file is a cabal script that runs 'build' in the project directory:

@
main :: IO ()
main =
  'build'
    ('Document.Build.Context.Directories' "public" ["src"] Nothing)
    ('Document.Build.Rules.prepareRules' ["md"] 'Document.Build.Project.filePlaceholders' "src" <> 'Document.Build.Rules.markdownRules' (flip replaceExtension) [("pdf", pure ["--standalone"])])
@

The build:

1. removes the output directory
2. runs the rules on every file of the input directories, in order, then on
   every file they make, and so on, until they make no more files
3. runs the rules on every directory of the output directory, then goes back
   to 2 for the files they make, until they make no more files
4. runs the rules once more, on the output directory, when the build is
   complete (see 'Document.Build.Context.onComplete'), such as to archive
   files or write the tree of output files

Each file has a trail: the steps that made it, back to its input file. A
step that would make a file already in its chain, or that is already in its
chain, stops the build with 'Document.Build.Error.BuildCycle'. A file made by
two different steps is kept as the first made it, with a warning. A step that
makes a file outside the output directory stops the build with
'Document.Build.Error.OutputNotInDirectory', so that a build never changes its
input directories, and builds the same files every time.
-}
module Document.Build.Documents (
  build,
  buildProject,
) where

import Control.Lens (preview, review, view, (^.), _Cons)
import Control.Monad (foldM, void)
import Control.Monad.Trans.Class (lift)
import Data.Bool (bool)
import Data.List (sort)
import qualified Data.Map as Map
import Document.Build.Build (Build', Command', commandMain, failBuild, io, say)
import Document.Build.Context (Context (..), Directories, KnownFiles, Rules, Target (..), fontsDirectory, inputDirectories, outputDirectory)
import Document.Build.Error (BuildError (..))
import Document.Build.File (filesIn)
import Document.Build.Project (clean, projectPath, withFonts)
import System.Directory (doesDirectoryExist, listDirectory, withCurrentDirectory)
import System.Environment (getArgs)
import System.Exit (exitFailure)
import System.FilePath (equalFilePath, normalise, (</>))
import System.FilePather.Combinators (isWithin)
import System.FilePather.Tracked (trackedFunction)
import System.FilePather.Trail (Step (..), Trail (..), lastStep)
import System.IO (hPutStrLn, stderr)

{- | Build the project in the directory given as the only argument, or the
current directory, with its directories and rules.

@since 0.1.0.0
-}
build :: Directories -> Rules -> IO ()
build ds r =
  getArgs >>= \case
    [] -> run "."
    [d] -> run d
    _ -> hPutStrLn stderr "usage: build [DIRECTORY]" *> exitFailure
 where
  run d =
    withCurrentDirectory d (void (commandMain (buildProject ds r) "."))

{- | Build the project in the directory being operated on, which must be the
current directory, with its directories and rules, and return every file the
build knows, with its trail.

@since 0.1.0.0
-}
buildProject :: Directories -> Rules -> Command' KnownFiles
buildProject ds r =
  do
    project <- projectPath
    lift . maybe id withFonts (ds ^. fontsDirectory) $
      do
        let out = ds ^. outputDirectory
            context = Context ds project
        clean out
        roots <- concat <$> traverse filesIn (ds ^. inputDirectories)
        known <-
          settle
            (runRules out r (context TargetFile))
            (runRules out r (context TargetDirectory))
            out
            (Map.fromList (fmap (\f -> (normalise f, Trail [])) roots))
            (fmap (,Trail []) roots)
        fst <$> runRules out r (context (TargetComplete known)) known [(out, Trail [])]

-- | Run the rules on files or directories, given the known files.
type RunRules = KnownFiles -> [(FilePath, Trail)] -> Build' (KnownFiles, [(FilePath, Trail)])

{- | Run the rules on files until they make no more, then on the directories
of the output directory, and again, until nothing new is made.
-}
settle :: RunRules -> RunRules -> FilePath -> KnownFiles -> [(FilePath, Trail)] -> Build' KnownFiles
settle onFiles onDirectories out known items =
  do
    known' <- files known items
    dirs <- io (directoriesOf out)
    (known'', made) <- onDirectories known' (fmap (,Trail []) dirs)
    bool (settle onFiles onDirectories out known'' made) (pure known'') (null made)
 where
  files k xs =
    bool (onFiles k xs >>= uncurry files) (pure k) (null xs)

{- | Run the rules on each file or directory, with its trail, and return the
known files with the files the rules made, and those files with their
trails, in the order they were made. A 'System.FilePather.Trail.Cycle', or a
file made outside the output directory, stops the build. A file that is
already known is kept as it is, with a warning, unless the same step made it
again.
-}
runRules :: FilePath -> Rules -> Context -> RunRules
runRules out r c known items =
  fmap reverse <$> foldM runOne (known, []) items
 where
  runOne acc (x, t) =
    view trackedFunction (r c) t x
      >>= either (failBuild . BuildCycle) (foldM record acc . fst)
  record (k, made) (o, s@(Step n i)) =
    let o' = normalise o
     in bool (failBuild (OutputNotInDirectory o out)) (pure ()) (isWithin out o) *> case Map.lookup o' k of
          Just t ->
            (k, made)
              <$ bool
                (say ("warning: " <> o <> " is made by " <> n <> " from " <> i <> ", and was made first " <> describeMaker t <> "; the first is kept"))
                (pure ())
                (sameStep s (preview lastStep t))
          Nothing ->
            let t = review _Cons (s, Map.findWithDefault (Trail []) (normalise i) k)
             in pure (Map.insert o' t k, (o, t) : made)
  sameStep (Step n i) =
    maybe False (\(Step n' i') -> n == n' && equalFilePath i i')
  describeMaker t =
    maybe "as a source file" (\(Step n i) -> "by " <> n <> " from " <> i) (preview lastStep t)

-- | A directory and its subdirectories, in sorted order, if it exists.
directoriesOf :: FilePath -> IO [FilePath]
directoriesOf d =
  doesDirectoryExist d
    >>= bool
      (pure [])
      ( do
          names <- sort <$> listDirectory d
          (d :) . concat <$> traverse (\n -> directoriesOf (normalise (d </> n))) names
      )