Error.hs

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# OPTIONS_GHC -Wall #-}

-- | Errors that occur while building documents.
module Document.Build.Error (
  -- * Command lines
  CommandLine (..),
  commandLineProgram,
  commandLineArguments,
  displayCommandLine,
  shellQuote,
  GetCommandLine (..),
  HasCommandLine (..),
  ReviewCommandLine (..),
  AsCommandLine (..),

  -- * Build errors
  BuildError (..),
  _ProcessFailed,
  _ProcessOutputUnrecognised,
  _InputFileMissing,
  _OutputFileMissing,
  _StringsMissing,
  _FileTypeUnsupported,
  _FileNotInGit,
  _FileNotUtf8,
  _BuildCycle,
  _InputFilesTooFew,
  _OutputNotInDirectory,
  _ShallowRepository,
  buildErrorExitCode,
  displayBuildError,
  GetBuildError (..),
  HasBuildError (..),
  ReviewBuildError (..),
  AsBuildError (..),
) where

import Control.DeepSeq (NFData)
import Control.Lens (Field1, Field2, Getter, Lens', Prism', Review, lens, prism', review, unto, view, _1, _2)
import Data.Data (Data)
import Data.Foldable (toList)
import Data.Lens.Injection (Injection1 (..), Injection10 (..), Injection11 (..), Injection12 (..), Injection2 (..), Injection3 (..), Injection4 (..), Injection5 (..), Injection6 (..), Injection7 (..), Injection8 (..), Injection9 (..))
import Data.List.NonEmpty (NonEmpty)
import GHC.Generics (Generic)
import Natural (NotZero, notZeroOr)
import System.FilePather.Trail (Cycle, displayCycle)

{- $setup
>>> import Control.Lens ((^.), (^?), (#))
>>> import Data.List.NonEmpty (NonEmpty (..))
-}

{- | A program and its arguments.

>>> CommandLine "pdfinfo" ["my file.pdf"] ^. commandLineProgram
"pdfinfo"

@since 0.1.0.0
-}
data CommandLine
  = CommandLine FilePath [String]
  deriving stock (Eq, Ord, Show, Generic, Data)
  deriving anyclass (NFData)

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

-- | @since 0.1.0.0
instance Field2 CommandLine CommandLine [String] [String]

{- | The program of a command line.

@since 0.1.0.0
-}
commandLineProgram :: Lens' CommandLine FilePath
commandLineProgram =
  _1
{-# INLINE commandLineProgram #-}

{- | The arguments of a command line.

>>> CommandLine "pdfinfo" ["my file.pdf"] ^. commandLineArguments
["my file.pdf"]

@since 0.1.0.0
-}
commandLineArguments :: Lens' CommandLine [String]
commandLineArguments =
  _2
{-# INLINE commandLineArguments #-}

{- | A command line as it would be written in a POSIX shell.

>>> displayCommandLine (CommandLine "pdfinfo" ["my file.pdf", "-box"])
"pdfinfo 'my file.pdf' -box"

@since 0.1.0.0
-}
displayCommandLine :: CommandLine -> String
displayCommandLine (CommandLine p as) =
  unwords (fmap shellQuote (p : as))

{- | Quote a word for a POSIX shell, if it needs quoting.

>>> shellQuote "public/report.pdf"
"public/report.pdf"

>>> shellQuote "it's"
"'it'\\''s'"

>>> shellQuote ""
"''"

@since 0.1.0.0
-}
shellQuote :: String -> String
shellQuote s =
  let safe c = c `elem` ("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_./=:,+%@" :: String)
      quote c = if c == '\'' then "'\\''" else [c]
   in if not (null s) && all safe s
        then s
        else "'" <> concatMap quote s <> "'"

-- | @since 0.1.0.0
class GetCommandLine s where
  getCommandLine :: Getter s CommandLine

-- | @since 0.1.0.0
instance GetCommandLine CommandLine where
  getCommandLine =
    id
  {-# INLINE getCommandLine #-}

-- | @since 0.1.0.0
class (GetCommandLine s) => HasCommandLine s where
  {-# MINIMAL setCommandLine #-}
  setCommandLine :: CommandLine -> s -> s

  commandLine :: Lens' s CommandLine
  commandLine =
    lens (view getCommandLine) (flip setCommandLine)
  {-# INLINE commandLine #-}

-- | @since 0.1.0.0
instance HasCommandLine CommandLine where
  setCommandLine =
    const
  {-# INLINE setCommandLine #-}

-- | @since 0.1.0.0
class ReviewCommandLine t where
  reviewCommandLine :: Review t CommandLine

-- | @since 0.1.0.0
instance ReviewCommandLine CommandLine where
  reviewCommandLine =
    unto id
  {-# INLINE reviewCommandLine #-}

-- | @since 0.1.0.0
class (ReviewCommandLine t) => AsCommandLine t where
  {-# MINIMAL matchCommandLine #-}
  matchCommandLine :: t -> Maybe CommandLine

  _CommandLine :: Prism' t CommandLine
  _CommandLine =
    prism' (review reviewCommandLine) matchCommandLine
  {-# INLINE _CommandLine #-}

-- | @since 0.1.0.0
instance AsCommandLine CommandLine where
  matchCommandLine =
    Just
  {-# INLINE matchCommandLine #-}

{- | An error that occurs while building documents.

@since 0.1.0.0
-}
data BuildError
  = -- | A process exited with a non-zero exit code, with its standard output
    -- and standard error.
    ProcessFailed CommandLine String String
  | -- | The output of a process was not recognised, with a description of what
    -- was expected.
    ProcessOutputUnrecognised CommandLine String
  | -- | An input file does not exist.
    InputFileMissing FilePath
  | -- | A process succeeded, but did not produce an output file it should
    -- have.
    OutputFileMissing CommandLine FilePath
  | -- | A file does not contain strings it is required to contain.
    StringsMissing FilePath (NonEmpty String)
  | -- | A file does not have one of the supported extensions.
    FileTypeUnsupported FilePath [String]
  | -- | A file has no history in git.
    FileNotInGit FilePath
  | -- | A file is not valid UTF-8 text.
    FileNotUtf8 FilePath
  | -- | A chain of build steps was stopped, because it would go round in a
    -- cycle.
    BuildCycle Cycle
  | -- | A directory has fewer input files than a command needs: the
    -- directory, the number of files it has, and the number the command
    -- needs.
    InputFilesTooFew FilePath Int Int
  | -- | A build step made a file outside the output directory: the file, and
    -- the output directory.
    OutputNotInDirectory FilePath FilePath
  | -- | The git history of a directory is shallow, so the last commit to
    -- change a file in it is not known.
    ShallowRepository FilePath
  deriving stock (Eq, Ord, Show, Generic, Data)
  deriving anyclass (NFData)

-- | @since 0.1.0.0
instance Injection1 BuildError BuildError (CommandLine, String, String) (CommandLine, String, String)

-- | @since 0.1.0.0
instance Injection2 BuildError BuildError (CommandLine, String) (CommandLine, String)

-- | @since 0.1.0.0
instance Injection3 BuildError BuildError FilePath FilePath

-- | @since 0.1.0.0
instance Injection4 BuildError BuildError (CommandLine, FilePath) (CommandLine, FilePath)

-- | @since 0.1.0.0
instance Injection5 BuildError BuildError (FilePath, NonEmpty String) (FilePath, NonEmpty String)

-- | @since 0.1.0.0
instance Injection6 BuildError BuildError (FilePath, [String]) (FilePath, [String])

-- | @since 0.1.0.0
instance Injection7 BuildError BuildError FilePath FilePath

-- | @since 0.1.0.0
instance Injection8 BuildError BuildError FilePath FilePath

-- | @since 0.1.0.0
instance Injection9 BuildError BuildError Cycle Cycle

-- | @since 0.1.0.0
instance Injection10 BuildError BuildError (FilePath, Int, Int) (FilePath, Int, Int)

-- | @since 0.1.0.0
instance Injection11 BuildError BuildError (FilePath, FilePath) (FilePath, FilePath)

-- | @since 0.1.0.0
instance Injection12 BuildError BuildError FilePath FilePath

-- | @since 0.1.0.0
_ProcessFailed :: Prism' BuildError (CommandLine, String, String)
_ProcessFailed =
  _I1
{-# INLINE _ProcessFailed #-}

-- | @since 0.1.0.0
_ProcessOutputUnrecognised :: Prism' BuildError (CommandLine, String)
_ProcessOutputUnrecognised =
  _I2
{-# INLINE _ProcessOutputUnrecognised #-}

{- | >>> InputFileMissing "report.fodt" ^? _InputFileMissing
Just "report.fodt"

@since 0.1.0.0
-}
_InputFileMissing :: Prism' BuildError FilePath
_InputFileMissing =
  _I3
{-# INLINE _InputFileMissing #-}

-- | @since 0.1.0.0
_OutputFileMissing :: Prism' BuildError (CommandLine, FilePath)
_OutputFileMissing =
  _I4
{-# INLINE _OutputFileMissing #-}

-- | @since 0.1.0.0
_StringsMissing :: Prism' BuildError (FilePath, NonEmpty String)
_StringsMissing =
  _I5
{-# INLINE _StringsMissing #-}

-- | @since 0.1.0.0
_FileTypeUnsupported :: Prism' BuildError (FilePath, [String])
_FileTypeUnsupported =
  _I6
{-# INLINE _FileTypeUnsupported #-}

-- | @since 0.1.0.0
_FileNotInGit :: Prism' BuildError FilePath
_FileNotInGit =
  _I7
{-# INLINE _FileNotInGit #-}

{- | >>> _FileNotUtf8 # "report.odt"
FileNotUtf8 "report.odt"

@since 0.1.0.0
-}
_FileNotUtf8 :: Prism' BuildError FilePath
_FileNotUtf8 =
  _I8
{-# INLINE _FileNotUtf8 #-}

-- | @since 0.1.0.0
_BuildCycle :: Prism' BuildError Cycle
_BuildCycle =
  _I9
{-# INLINE _BuildCycle #-}

-- | @since 0.1.0.0
_InputFilesTooFew :: Prism' BuildError (FilePath, Int, Int)
_InputFilesTooFew =
  _I10
{-# INLINE _InputFilesTooFew #-}

-- | @since 0.1.0.0
_OutputNotInDirectory :: Prism' BuildError (FilePath, FilePath)
_OutputNotInDirectory =
  _I11
{-# INLINE _OutputNotInDirectory #-}

-- | @since 0.1.0.0
_ShallowRepository :: Prism' BuildError FilePath
_ShallowRepository =
  _I12
{-# INLINE _ShallowRepository #-}

{- | The exit code for an error that is not the failure of a process. A
failed process keeps its own exit code, and this function gives @1@ for it.

>>> buildErrorExitCode (InputFileMissing "report.fodt")
NotZero True (Positive 22)

@since 0.1.0.0
-}
buildErrorExitCode :: BuildError -> NotZero
buildErrorExitCode e =
  notZeroOr $
    case e of
      ProcessFailed{} -> 1 :: Int
      FileNotInGit{} -> 12
      ProcessOutputUnrecognised{} -> 14
      InputFileMissing{} -> 22
      StringsMissing{} -> 26
      OutputFileMissing{} -> 28
      FileTypeUnsupported{} -> 30
      FileNotUtf8{} -> 32
      BuildCycle{} -> 34
      InputFilesTooFew{} -> 36
      OutputNotInDirectory{} -> 38
      ShallowRepository{} -> 40

{- | A description of an error, for people to read.

>>> putStr (displayBuildError (StringsMissing "report.fodt" ("${UPDATED}" :| [])))
report.fodt does not contain:
  ${UPDATED}

@since 0.1.0.0
-}
displayBuildError :: BuildError -> String
displayBuildError e =
  case e of
    ProcessFailed c o r ->
      unlines (("command failed: " <> displayCommandLine c) : section "stdout" o <> section "stderr" r)
    ProcessOutputUnrecognised c x ->
      unlines ["output not recognised: " <> displayCommandLine c, "  expected " <> x]
    InputFileMissing p ->
      unlines ["input file does not exist: " <> p]
    OutputFileMissing c p ->
      unlines ["command did not produce " <> p <> ": " <> displayCommandLine c]
    StringsMissing p xs ->
      unlines ((p <> " does not contain:") : fmap ("  " <>) (toList xs))
    FileTypeUnsupported p xs ->
      unlines [p <> " is not one of the supported file types: " <> unwords xs]
    FileNotInGit p ->
      unlines ["file has no git history: " <> p]
    FileNotUtf8 p ->
      unlines ["file is not UTF-8 text: " <> p]
    BuildCycle c ->
      unlines ["build step stopped, because it would go round in a cycle:", "  " <> displayCycle c]
    InputFilesTooFew d n m ->
      unlines ["directory has " <> show n <> " input files, and needs at least " <> show m <> ": " <> d]
    OutputNotInDirectory f d ->
      unlines ["build step made a file outside the output directory " <> d <> ": " <> f]
    ShallowRepository d ->
      unlines ["git history is shallow, so the last commit to change each file is not known: " <> d, "  fetch the whole history, such as with GIT_DEPTH: 0 in GitLab CI"]

section :: String -> String -> [String]
section name x =
  if null x
    then []
    else ("  " <> name <> ":") : fmap ("    " <>) (lines x)

-- | @since 0.1.0.0
class GetBuildError s where
  getBuildError :: Getter s BuildError

-- | @since 0.1.0.0
instance GetBuildError BuildError where
  getBuildError =
    id
  {-# INLINE getBuildError #-}

-- | @since 0.1.0.0
class (GetBuildError s) => HasBuildError s where
  {-# MINIMAL setBuildError #-}
  setBuildError :: BuildError -> s -> s

  buildError :: Lens' s BuildError
  buildError =
    lens (view getBuildError) (flip setBuildError)
  {-# INLINE buildError #-}

-- | @since 0.1.0.0
instance HasBuildError BuildError where
  setBuildError =
    const
  {-# INLINE setBuildError #-}

{- | Error types that can be constructed from a 'BuildError'. The commands in
this library fail with any such error type, so that a build script can define
its own error type that includes 'BuildError'.

@since 0.1.0.0
-}
class ReviewBuildError t where
  reviewBuildError :: Review t BuildError

-- | @since 0.1.0.0
instance ReviewBuildError BuildError where
  reviewBuildError =
    unto id
  {-# INLINE reviewBuildError #-}

-- | @since 0.1.0.0
class (ReviewBuildError t) => AsBuildError t where
  {-# MINIMAL matchBuildError #-}
  matchBuildError :: t -> Maybe BuildError

  _BuildError :: Prism' t BuildError
  _BuildError =
    prism' (review reviewBuildError) matchBuildError
  {-# INLINE _BuildError #-}

-- | @since 0.1.0.0
instance AsBuildError BuildError where
  matchBuildError =
    Just
  {-# INLINE matchBuildError #-}