Build.hs

{-# OPTIONS_GHC -Wall #-}

{- | The effect that document builds run in, and the operations that the
commands in this library are built from.

A 'Build' runs @IO@, and fails with an exit code and an error value, using
'Exitcode'. A 'Command' is a 'FilePather' in 'Build': a build step that
operates on a file path.

To write a command of your own, use 'process' to run an external program, 'io'
to run an @IO@ action, and 'failBuild' to fail. For example, a command that
produces the word count of a text file:

@
wordCount :: ('ReviewBuildError' e) => 'Command' e Int
wordCount =
  do
    p <- 'requireInput'
    o <- 'lift' ('process' ('CommandLine' "wc" ["-w", p]))
    case words o of
      (n : _) | Just c <- readMaybe n -> pure c
      _ -> 'lift' ('failBuild' ('ProcessOutputUnrecognised' ('CommandLine' "wc" ["-w", p]) "a word count"))
@
-}
module Document.Build.Build (
  -- * Types
  Build,
  Build',
  Command,
  Command',
  BuildRule,
  BuildRule',

  -- * Running
  runBuild,
  buildMain,
  commandMain,

  -- * Operations
  io,
  failBuild,
  attempt,
  say,

  -- * Processes
  process,
  processIn,
  processWith,

  -- * Assertions
  requireInput,
  requireDirectory,
  requirePath,

  -- * Files
  expectOutput,
  createParentDirectory,
  withTempDirectory,
) where

import Control.Exception (IOException)
import Control.Exitcode (Exitcode, bimapExitcode, liftTryExitcode, mkExitFailure, runExitcode)
import Control.Lens (review, view, _Wrapped)
import Control.Monad.Reader (ask)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
import Control.Process.Process (readCreateProcessWithExitCode)
import Data.Bool (bool)
import Document.Build.Error (BuildError (..), CommandLine (..), ReviewBuildError (..), buildErrorExitCode, displayBuildError, displayCommandLine)
import GHC.IO.Encoding (setLocaleEncoding, utf8)
import Natural (NotZero, notZeroInteger)
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, doesPathExist, getTemporaryDirectory, removePathForcibly)
import System.Exit (ExitCode (..), exitWith)
import System.FilePath (takeDirectory)
import System.FilePather.Combinators (Rule)
import System.FilePather.FilePather (FilePather)
import System.IO (hPrint, hPutStr, hPutStrLn, hSetEncoding, stderr, stdout)
import System.IO.Temp (createTempDirectory)
import System.Process (CreateProcess (cwd), proc)

{- | Build steps, which run @IO@ and fail with an exit code and an error of
type @e@.

@since 0.1.0.0
-}
type Build e = Exitcode e (ExceptT IOException IO)

-- | @since 0.1.0.0
type Build' = Build BuildError

{- | A build step that operates on a file path.

@since 0.1.0.0
-}
type Command e a = FilePather (Build e) a

-- | @since 0.1.0.0
type Command' a = Command BuildError a

{- | A build step that applies to some file paths and not others.

@since 0.1.0.0
-}
type BuildRule e a = Rule (Build e) a

-- | @since 0.1.0.0
type BuildRule' a = BuildRule BuildError a

{- | Run a 'Build'. The outer 'Either' holds an exception thrown while running
a process or an @IO@ action from 'io'; the inner holds a build failure.

@since 0.1.0.0
-}
runBuild :: Build e a -> IO (Either IOException (Either (e, NotZero) a))
runBuild =
  runExceptT . runExitcode
{-# INLINE runBuild #-}

{- | Run a 'Build' as the main action of a program. On failure, print the error
to standard error and exit with the exit code of the failure. Standard output
and standard error are set to UTF-8.

@since 0.1.0.0
-}
buildMain :: Build' a -> IO a
buildMain b =
  do
    setLocaleEncoding utf8
    hSetEncoding stdout utf8
    hSetEncoding stderr utf8
    runBuild b
      >>= either
        (\x -> hPrint stderr x *> exitWith (ExitFailure 1))
        ( either
            (\(e, n) -> hPutStr stderr (displayBuildError e) *> exitWith (ExitFailure (exitCodeOf n)))
            pure
        )

-- | An exit code that a process can exit with, which is never 0 modulo 256.
exitCodeOf :: NotZero -> Int
exitCodeOf n =
  let c = fromInteger (notZeroInteger n `mod` 256)
   in bool c 1 (c == 0)

{- | Run a 'Command' on a file path, as the main action of a program. See
'buildMain'.

@since 0.1.0.0
-}
commandMain :: Command' a -> FilePath -> IO a
commandMain c =
  buildMain . view _Wrapped c
{-# INLINE commandMain #-}

{- | Run an @IO@ action, catching an 'IOException'.

@since 0.1.0.0
-}
io :: IO a -> Build e a
io =
  liftTryExitcode
{-# INLINE io #-}

{- | Fail with a 'BuildError', and the exit code given by
'buildErrorExitCode'.

@since 0.1.0.0
-}
failBuild :: (ReviewBuildError e) => BuildError -> Build e a
failBuild e =
  mkExitFailure (pure (buildErrorExitCode e)) (pure (review reviewBuildError e))
{-# INLINE failBuild #-}

{- | Run a build, and return its result, or 'Nothing' if it fails, either
with an exit code or an exception. Use this for information that is useful
when it is available, such as the git details of a file that may not be in
git.

@since 0.1.0.0
-}
attempt :: Build e a -> Build e (Maybe a)
attempt b =
  either (const Nothing) (either (const Nothing) Just) <$> lift (lift (runExceptT (runExitcode b)))

{- | Print a line to standard error.

@since 0.1.0.0
-}
say :: String -> Build e ()
say =
  io . hPutStrLn stderr
{-# INLINE say #-}

{- | Run a program and return its standard output. See 'processWith'.

@since 0.1.0.0
-}
process :: (ReviewBuildError e) => CommandLine -> Build e String
process =
  processWith id ""
{-# INLINE process #-}

{- | Run a program in a working directory and return its standard output. See
'processWith'.

@since 0.1.0.0
-}
processIn :: (ReviewBuildError e) => FilePath -> CommandLine -> Build e String
processIn d =
  processWith (\p -> p{cwd = Just d}) ""
{-# INLINE processIn #-}

{- | Run a program, with a modification to how it is created and a string for
its standard input, and return its standard output.

The command line is printed to standard error before the program runs, and
the standard error of the program is passed through to standard error. If the
program exits with a non-zero exit code, the build fails with
'ProcessFailed' and the same exit code. If the program cannot be run, for
example because it is not installed, the build fails with an 'IOException'.

@since 0.1.0.0
-}
processWith :: (ReviewBuildError e) => (CreateProcess -> CreateProcess) -> String -> CommandLine -> Build e String
processWith f i c@(CommandLine p as) =
  do
    say ("+ " <> displayCommandLine c)
    (o, r) <-
      bimapExitcode
        (\(o, r) -> review reviewBuildError (ProcessFailed c o r))
        id
        (readCreateProcessWithExitCode (f (proc p as)) i)
    io (hPutStr stderr r)
    pure o

{- | Assert that the file being operated on exists, and return its path.
Fails with 'InputFileMissing' if it does not exist, or is a directory.

@since 0.1.0.0
-}
requireInput :: (ReviewBuildError e) => Command e FilePath
requireInput =
  requireWith doesFileExist
{-# INLINE requireInput #-}

{- | Assert that the directory being operated on exists, and return its path.
Fails with 'InputFileMissing' if it does not exist, or is a file.

@since 0.1.0.0
-}
requireDirectory :: (ReviewBuildError e) => Command e FilePath
requireDirectory =
  requireWith doesDirectoryExist
{-# INLINE requireDirectory #-}

{- | Assert that the file or directory being operated on exists, and return
its path. Fails with 'InputFileMissing' if it does not exist.

@since 0.1.0.0
-}
requirePath :: (ReviewBuildError e) => Command e FilePath
requirePath =
  requireWith doesPathExist
{-# INLINE requirePath #-}

-- | Assert that the path being operated on satisfies a test of the file system.
requireWith :: (ReviewBuildError e) => (FilePath -> IO Bool) -> Command e FilePath
requireWith exists =
  do
    p <- ask
    lift (io (exists p) >>= bool (failBuild (InputFileMissing p)) (pure p))

{- | Return the path of a file that a command should have produced. Fails with
'OutputFileMissing' if the file does not exist.

@since 0.1.0.0
-}
expectOutput :: (ReviewBuildError e) => CommandLine -> FilePath -> Build e FilePath
expectOutput c p =
  io (doesFileExist p) >>= bool (failBuild (OutputFileMissing c p)) (pure p)

{- | Create the directory that a file path is in, and its parents, if they do
not exist.

@since 0.1.0.0
-}
createParentDirectory :: FilePath -> Build e ()
createParentDirectory =
  io . createDirectoryIfMissing True . takeDirectory
{-# INLINE createParentDirectory #-}

{- | Run a 'Build' with a new temporary directory, whose name starts with the
given template. The directory is removed afterwards, whether the build
succeeds or fails.

@since 0.1.0.0
-}
withTempDirectory :: String -> (FilePath -> Build e a) -> Build e a
withTempDirectory t k =
  do
    d <- io (getTemporaryDirectory >>= \tmp -> createTempDirectory tmp t)
    r <- lift (lift (runExceptT (runExitcode (k d))))
    io (removePathForcibly d)
    either
      (lift . throwE)
      (either (\(e, n) -> mkExitFailure (pure n) (pure e)) pure)
      r