document-build (empty) → 0.1.0.0
raw patch · 29 files changed
+6248/−0 lines, 29 filesdep +aesondep +aeson-prettydep +base
Dependencies added: aeson, aeson-pretty, base, bytestring, containers, criterion, cryptohash-sha256, deepseq, directory, document-build, either-n, exitcode, filepath, filepather, hedgehog, lens, mtl, natural, process, temporary, text, time, transformers
Files
- LICENCE +27/−0
- README.md +336/−0
- bench/Main.hs +85/−0
- build.hs +685/−0
- changelog.md +45/−0
- document-build.cabal +215/−0
- src/Document/Build.hs +54/−0
- src/Document/Build/Build.hs +307/−0
- src/Document/Build/Context.hs +573/−0
- src/Document/Build/Documents.hs +158/−0
- src/Document/Build/Error.hs +460/−0
- src/Document/Build/File.hs +132/−0
- src/Document/Build/Git.hs +374/−0
- src/Document/Build/Hash.hs +44/−0
- src/Document/Build/Image.hs +338/−0
- src/Document/Build/LibreOffice.hs +197/−0
- src/Document/Build/Operations.hs +59/−0
- src/Document/Build/Output.hs +359/−0
- src/Document/Build/Pandoc.hs +82/−0
- src/Document/Build/Pdf.hs +314/−0
- src/Document/Build/Project.hs +278/−0
- src/Document/Build/Replace.hs +99/−0
- src/Document/Build/Rules.hs +457/−0
- test/BuildTests.hs +240/−0
- test/Gens.hs +29/−0
- test/Laws.hs +63/−0
- test/OutputTests.hs +177/−0
- test/doctest_tests.hs +38/−0
- test/hedgehog_tests.hs +23/−0
+ LICENCE view
@@ -0,0 +1,27 @@+Copyright (c) 2021-2026 Tony Morris++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,336 @@+# document-build++++Build documents with Haskell: convert them between formats, get information+about them, and replace strings in them.++The project has four layers:++1. [`filepather`](filepather): the `FilePather` type, and `Tracked` build+ steps that record the files they make+2. `Document.Build.Operations`: the canonical document operations, every one+ a `FilePather` value+3. `Document.Build.Context`, `Document.Build.Rules` and+ `Document.Build.Documents`: rules that wrap the operations in named steps,+ combinators that choose the files they apply to, and `build`, which runs+ rules over a project+4. The build file of a document project, which calls `build` with the+ directories of the project and its rules++The library has no settings of its own: no directories, file names,+extensions, sizes or styles. A build file gives them all, as arguments.++## 1. `FilePather` and `Tracked`++The [`filepather`](filepather) package, in this repository, provides+`FilePather`, a computation that depends on the file path being operated on:++```haskell+newtype FilePather f a = FilePather (FilePath -> f a)+type FilePather' a = FilePather Identity a+```++It is isomorphic to `ReaderT FilePath f a`, with the same instances: when `f`+is a `Monad`, so is `FilePather f`, and `ask` is the file path being operated+on. `p ~> q` runs `q` on the file path that `p` produces, `onFile` runs on+another file path, and `everyFile directoryFiles r` applies the rule `r` to+every file in a directory.++It also provides `Tracked`, a named build step that records the files it+makes, with the steps that made them:++```haskell+newtype Tracked f a = Tracked (FilePather (ReaderT Trail (ExceptT Cycle f)) (Outputs, a))++step :: Applicative f => String -> (FilePath -> [FilePath]) -> FilePather f a -> Tracked f a+step' :: Functor f => String -> FilePather f ([FilePath], a) -> Tracked f a+```++A `Tracked` value runs with the `Trail` of its input file: the steps that+built it, back to its source file. `step` checks the trail before it runs: a+step that is already in the trail, or that would make a file already in the+trail, is stopped with a `Cycle`, and does not run. `step'` checks after it+runs, for steps whose outputs are known only then. A `Cycle` describes the+whole chain:++```+src/a.md → markdown to pdf → public/a.pdf → pdf page 1 → public/a_page1.pdf → pdf page 1 again+```++`Tracked` is a separate type, so that `FilePather` keeps all of its+instances. Its `<>` runs both steps and keeps the outputs of both, and its+`<|>` and `catchError` alternate in `f`, so that a `Cycle` is never caught or+discarded.++## 2. Operations++`Document.Build.Operations` provides the canonical document operations: every+one a `FilePather` value in `Build e`, which runs `IO` and fails with an exit+code and an error, using [exitcode](https://hackage.haskell.org/package/exitcode).++```haskell+type Build e = Exitcode e (ExceptT IOException IO)+type Command e a = FilePather (Build e) a+```++| Input | Operation | Result |+|---|---|---|+| PDF | `pdfPages`, `pdfPageCountFile` | number of pages |+| LibreOffice, Word | `libreofficePages`, `docxPages` | number of pages |+| markdown | `markdownToPdf`, `markdownToHtml`, `markdownToDocx`, `markdownToOdt`, `pandoc` | PDF, HTML, Word, OpenDocument |+| PDF | `pdfToJpg`, `pdfToPng`, `pdfToGif`, `pdfToSvg`, `pdfToImages` | an image for each page |+| any file | `sha256` | SHA-256 hash |+| PDF | `pdfFirstPage`, `pdfPage`, `pdfSelect` | a PDF of some pages |+| `.odt`, `.ods`, `.odp`, `.odg` | `libreofficeFlat` | `.fodt`, `.fods`, `.fodp`, `.fodg` |+| `.fodt`, `.fods`, `.fodp`, `.fodg` | `libreofficeZipped` | `.odt`, `.ods`, `.odp`, `.odg` |+| LibreOffice, Word | `libreoffice`, `libreofficeToPdf`, ... | any format LibreOffice exports |+| PDF | `pdfSplit`, `pdfBurst` | PDF files |+| any file | `gitDetails`, `gitPlaceholders` | the last commit and authors, and placeholders for them |+| text file | `replaceStrings`, `requireStrings` | a file with strings replaced |+| image | `imageInfo` | format, width, height, resolution, ... |+| image | `imageResize`, `imageConvert` | images |+| directory | `pdfJoin`, `pdfConcatenate`, `pdftk` | one PDF of the PDF files in it |+| directory | `imageAppend` | one image of images in it, side by side |+| file, directory | `requireInput`, `requireDirectory`, `requirePath` | an assertion that it exists |++An operation with parameters is a function that returns a `FilePather`+value, such as `replaceStrings :: [(String, String)] -> FilePath -> Command e+FilePath`. An operation that takes several input files takes the directory+they are in as its file path, and their paths relative to it. Every operation+checks that its input exists and that the tool produced its output, so a+failure stops the build with an error that says what went wrong, and an exit+code.++### Writing an operation++An operation is a `FilePather`, so a build file can define its own. Use `ask`+or `requireInput` for the input file, `process` to run a program, `io` to run+an `IO` action, and `failBuild` to fail:++```haskell+wordCount :: ReviewBuildError e => Command e Int+wordCount =+ do+ p <- requireInput+ o <- lift (process (CommandLine "wc" ["-w", p]))+ maybe+ (lift (failBuild (ProcessOutputUnrecognised (CommandLine "wc" ["-w", p]) "a word count")))+ pure+ (readMaybe (takeWhile (/= ' ') o))+```++Operations fail with any error type `e` that has a `ReviewBuildError`+instance, so a build file can have an error type of its own that includes+`BuildError`.++## 3. Rules and builds++A rule wraps an operation in a named step, and says which files it applies+to:++```haskell+type Rules = Context -> Tracked Build' ()+data Directories = Directories FilePath [FilePath] (Maybe FilePath)+```++The `Context` holds the `Directories` of the build (the output directory, the+input directories, and the fonts directory, if any), the path of the project+(such as `group/project`, from `CI_PROJECT_PATH` in CI, or the path of the+`origin` git remote otherwise), and what the rules are running on. Rules+combine with `<>`, which runs both. `onProject`, `onProjects`, `withProject`,+`onPaths`, `onFiles`, `onDirectories`, `onComplete`, `onSources`,+`onOutputs`, `afterStep` and `unlessAfterStep` choose the files a rule+applies to, and `buildStep` makes a named step of an operation.++`build directories rules` builds the project in the current directory, or+the directory given as its argument. It removes the output directory, then:++1. 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+2. runs the rules on every directory of the output directory, then goes back+ to 1 for the files they make, until nothing new is made+3. runs the rules once more, on the output directory, when the build is+ complete, such as to archive files or write the tree of output files++Each file has a trail, the steps that made it. A step that would make a file+already in its chain, or that is already in its chain, stops the build with+the chain (`BuildCycle`). A step that makes a file outside the output+directory stops the build (`OutputNotInDirectory`), so a build never changes+its input directories. A file that two different steps make is kept as the+first made it, with a warning. Building twice gives the same output: a build+never reads the output of an earlier build.++### The rules++Every rule takes its settings as arguments, and none has a default:++| Rule | Step | What it does |+|---|---|---|+| `prepareRules exts placeholders dir` | `prepare` | prepare the files of `dir` in the output directory, replacing placeholders in files with the extensions `exts` |+| `assetRules exts placeholders dir` | `prepare asset` | the same, for files that are not converted |+| `fontRules dir` | `copy font` | copy the files of `dir` to the output directory |+| `libreofficeRules [(exts, formats)]` | `libreoffice FORMAT` | convert prepared LibreOffice files to formats |+| `libreofficeCounterpartRules` | `libreoffice flat`, `libreoffice zipped` | convert prepared flat LibreOffice files to zipped, and zipped to flat |+| `pandocHtmlRules exts name options` | `pandoc html` | convert LibreOffice text documents to standalone HTML with pandoc |+| `markdownRules name [(format, options)]` | `pandoc FORMAT` | convert prepared markdown files with pandoc |+| `bookRules parts` | `book` | concatenate `name-PART.pdf` for each part into `name.pdf` |+| `imageJoinRules names` | `join images` | join `name-N.png` side by side into `name.png` |+| `mergePdf inputs ranges output` | `pdf merge` | merge pages of PDF files with pdftk |+| `pageCountRules name` | `page count` | write the page count of every PDF file |+| `pageOneRules pdfName imageName` | `pdf page 1`, `page 1 image` | extract the first page of every PDF file, and make an image of it |+| `pdfPageImageRules options name` | `pdf page images` | make an image of each page of every PDF file |+| `splitPdf pdf [(range, file)]` | `pdf split` | split a PDF file by page ranges |+| `imageRules exts formats sizes convertedName resizedName` | `image FORMAT`, `image FORMAT SIZE` | convert images to formats, and resize them |+| `requirePlaceholders names` | `require placeholders` | fail unless files contain placeholders |+| `archiveRules select archive` | `archive` | when the build is complete, archive the files that satisfy a predicate |+| `outputTreeRules json html title` | `output tree` | when the build is complete, write the tree of output files |++Names of output files are functions, such as ``(`replaceExtension` "png")``+or `(<> ".pages")`. pandoc options are commands, run on the input file, so+that they can depend on the files of the project: `whenFileExists` and+`filesWithExtension` give options for files that a project may or may not+have. A build file can choose files by the step that made them, with+`afterStep` and `unlessAfterStep`, such as to count the pages of every PDF+file except first pages:++```haskell+unlessAfterStep (== "pdf page 1") (pageCountRules (<> ".pages"))+```++### Placeholders++Text files have their placeholders, such as `${NAME}`, replaced as+`prepareRules` and `assetRules` prepare them, with the values of a command,+run on each file. The library gives the parts to make it of:++* `filePlaceholders`: placeholders of the last commit to change the file,+ not of the repository, so each document says when it last changed, and by+ whom: `${GIT_COMMIT_HASH}`, `${GIT_COMMIT_HASH_SHORT}`,+ `${GIT_AUTHOR_NAME}`, `${GIT_AUTHOR_EMAIL}`, `${GIT_AUTHOR_TIME}`,+ `${GIT_COMMITTER_NAME}`, `${GIT_COMMITTER_EMAIL}`, `${GIT_COMMIT_TIME}`,+ `${GIT_SUBJECT}` and `${GIT_AUTHORS}` (everyone who has changed the file,+ most recent first)+* `environmentPlaceholders`: placeholders from environment variables, the+ same for every file, each with a value for when it is not set, such as+ `directoryName`+* `placeholderAliases`: placeholders with the values of others, such as+ `${UPDATED}` for `${GIT_COMMIT_TIME}`+* `withPlaceholder`: set the value of a placeholder, such as for one project+ with `withProject`++A file that has not been committed has the placeholders of the last commit+of the repository, with a warning. `filePlaceholders` needs the whole git+history, and stops with `ShallowRepository` if it is shallow: in GitLab CI,+set `GIT_DEPTH: 0`.++## 4. The build file++A build file is a cabal script in the project, so it runs as an executable:++```+./build.hs [DIRECTORY]+cabal run build.hs -- [DIRECTORY]+```++It gives `build` the directories of the project and its rules. For example,+a project of markdown documents in `src`, built into `public`:++```haskell+#!/usr/bin/env cabal+{- cabal:+build-depends: base, document-build, filepath+-}+import Document.Build+import System.FilePath (dropExtension, replaceExtension)++main :: IO ()+main =+ build+ (Directories "public" ["src"] Nothing)+ ( prepareRules ["md"] placeholders "src"+ <> markdownRules (flip replaceExtension) [("pdf", pure ["--standalone"]), ("html", pure ["--standalone"])]+ <> pageOneRules (\p -> dropExtension p <> "-1.pdf") (`replaceExtension` "png")+ <> onProject "group/project" (splitPdf "report.pdf" [("1", "report_cover.pdf")])+ <> outputTreeRules "outputs.json" "outputs.html" directoryName+ )+ where+ placeholders =+ placeholderAliases [("UPDATED", "GIT_COMMIT_TIME")] <$> filePlaceholders+```++A build file can define operations of its own, and make rules of them with+`buildStep`:++```haskell+-- writeWordCount :: Command' (), an operation of your own+onFiles (onOutputs (onPaths (hasExtension ["txt"]) (fromTracked (buildStep "word count" (\p -> [p <> ".words"]) writeWordCount))))+```++The `build.hs` of this repository is the build file of a set of document+projects that share it: one file, byte for byte, in each, with the settings+of every project, and exceptions for some.++### The output tree++`outputTreeRules` writes the tree of output files. Each file of the input+directories is a root, and each file is a child of the input file of the+step that made it:++```+src/report.fodt+`- public/report.fodt+ |- public/report.docx+ |- public/report.pdf+ | |- public/report.pdf.pages+ | `- public/report-1.pdf+ | `- public/report-1.png+ `- ...+```++A file made from several files, such as a concatenated book, appears once,+under the first of them. Each node holds the path, the SHA-256 hash, the git+details of the file at the root, the page count of a PDF file, and the+width, height and format of an image. The JSON file holds the tree for other+programs (read it with `readOutputForest`), and the HTML page links to every+output file.++### Getting the library++A cabal script cannot depend on a package from a git repository, so the+libraries must come from a package repository: Hackage, once they are+released, or a local repository until then. To use a local repository, add+it to the cabal configuration (`~/.cabal/config`, or the configuration in+CI):++```+repository document-build-local+ url: file+noindex:///path/to/repository+```++and put the source distributions of both packages there:++```+cabal sdist all -o /path/to/repository+cabal update+```++### Tools++The operations run these programs, which must be installed:++* `soffice` (LibreOffice)+* `pandoc`, and `xelatex` for PDF output+* `pdfinfo` and `pdftocairo` (poppler-utils), and `pdftk`+* `convert` and `identify` (ImageMagick 6), with PDF enabled in its+ `policy.xml`+* `git` and `tar`++## Development++```+cabal build all+cabal test all+bin/lint.sh # apply hlint suggestions and format with fourmolu+bin/lint.sh --check+```
+ bench/Main.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}++{- | Benchmarks of the pure parts of the library: composing 'FilePather' and+'Tracked' values, replacing strings, and parsing tool output.+-}+module Main (main) where++import Control.Lens (view, _Wrapped)+import Control.Monad.Reader (asks)+import Criterion.Main (bench, bgroup, defaultMain, nf, whnf)+import qualified Data.ByteString.Lazy.Char8 as Char8+import Data.Functor.Identity (Identity (..))+import qualified Data.Text as Text+import Document.Build (parsePdfinfoPages, replaceText, sha256Hex)+import System.FilePather (FilePather, Step (..), Tracked, Trail (..), step, trackedFunction, (~>))++-- | A 'FilePather' mapped over many times, to measure the fusion of 'fmap'.+mapped :: Int -> FilePather Identity Int+mapped n =+ iterate (fmap (+ 1)) (asks length) !! n++-- | A 'FilePather' piped into itself many times.+piped :: Int -> FilePather Identity FilePath+piped n =+ foldr (~>) (asks id) (replicate n (asks (<> "x")))++-- | A 'Tracked' value mapped over many times, to measure the fusion of 'fmap'.+mappedTracked :: Int -> Tracked Identity Int+mappedTracked n =+ iterate (fmap (+ 1)) (step "length" (const []) (asks length)) !! n++-- | Many steps combined with '<>', run with a trail of many steps.+combinedTracked :: Int -> Tracked Identity ()+combinedTracked n =+ foldMap (\k -> step ("step " <> show k) (\p -> [p <> "." <> show k]) (pure ())) [1 .. n]++-- | A trail of many steps.+longTrail :: Trail+longTrail =+ Trail (fmap (\k -> Step ("earlier " <> show k) ("public/" <> show k <> ".pdf")) [1 .. 100 :: Int])++-- | A flat LibreOffice document of about 1MB, with placeholders.+document :: Text.Text+document =+ Text.replicate 10000 "<text:p>Updated ${COMMIT_TIME} by ${GITLAB_USER_NAME} at revision ${CI_COMMIT_SHA}.</text:p>\n"++placeholders :: [(Text.Text, Text.Text)]+placeholders =+ [ ("${COMMIT_TIME}", "2026-10-09 01:02:03 UTC")+ , ("${GITLAB_USER_NAME}", "Tony Morris")+ , ("${CI_COMMIT_SHA}", "0123456789abcdef0123456789abcdef01234567")+ , ("${CI_PROJECT_VISIBILITY}", "public")+ ]++pdfinfo :: String+pdfinfo =+ unlines (replicate 20 "Producer: LibreOffice" <> ["Pages: 254"])++main :: IO ()+main =+ defaultMain+ [ bgroup+ "FilePather"+ [ bench "fmap x1000" $ whnf (\n -> runIdentity (view _Wrapped (mapped n) "src/report.fodt")) 1000+ , bench "~> x1000" $ nf (\n -> runIdentity (view _Wrapped (piped n) "src/report.fodt")) 1000+ ]+ , bgroup+ "Tracked"+ [ bench "fmap x1000" $ nf (\n -> fmap snd (runIdentity (view trackedFunction (mappedTracked n) (Trail []) "src/report.fodt"))) 1000+ , bench "<> x100, trail of 100" $ nf (\n -> either (const 0) (length . fst) (runIdentity (view trackedFunction (combinedTracked n) longTrail "src/report.fodt"))) 100+ ]+ , bgroup+ "replaceText"+ [ bench "1MB, 4 placeholders" $ nf (replaceText placeholders) document+ ]+ , bgroup+ "parse"+ [ bench "parsePdfinfoPages" $ nf parsePdfinfoPages pdfinfo+ ]+ , bgroup+ "sha256Hex"+ [ bench "1MB" $ nf sha256Hex (Char8.replicate 1000000 'x')+ ]+ ]
+ build.hs view
@@ -0,0 +1,685 @@+#!/usr/bin/env cabal+{- cabal:+build-depends:+ base >= 4.18 && < 5+ , document-build >= 0.1 && < 0.2+ , filepath >= 1.4.301.0 && < 1.6+ , mtl >= 2.3.1 && < 2.4+ghc-options: -Wall+-}+{-# OPTIONS_GHC -Wall #-}++{- | The build file for every document project. It is the same file in every+project.++@+./build.hs [DIRECTORY]+cabal run build.hs -- [DIRECTORY]+@++builds the project in DIRECTORY (default: the current directory) into+@public@, with the rules below: the rules of every project, then the+exceptions for specific projects and files.+-}+module Main (main) where++import Control.Monad.Trans (lift)+import Data.Bool (bool)+import Data.List (isInfixOf, isPrefixOf)+import Document.Build+import System.FilePath (dropExtension, replaceExtension, takeExtension, takeFileName, (<.>))++main :: IO ()+main =+ build projectDirectories (rules <> exceptions <> complete)++{- | Every file of @files@, @share@, @fonts@ and @src@ is built, in that order,+into @public@, with the fonts of @fonts@.+-}+projectDirectories :: Directories+projectDirectories =+ Directories "public" ["files", "share", "fonts", "src"] (Just "fonts")++-- | The rules of every project.+rules :: Rules+rules =+ withProject+ ( \project ->+ foldMap (assetRules textExtensions (placeholders project)) ["files", "share"]+ <> prepareRules textExtensions (placeholders project) "src"+ )+ <> onPaths (not . hasExtension ["md"]) (fontRules "fonts")+ <> libreofficeRules+ [ (["fodt", "odt"], ["pdf", "html", "docx", "txt"])+ , (["fods", "ods"], ["pdf", "html", "xlsx"])+ , (["fodg", "odg"], ["pdf", "html", "svg"])+ , (["fodp", "odp"], ["pdf", "html", "pptx"])+ ]+ <> libreofficeCounterpartRules+ <> pandocHtmlRules ["fodt", "odt"] (\p -> dropExtension p <> ".pandoc.html") pandocStyle+ <> markdownRules (flip replaceExtension) markdownConversions+ <> bookRules ["front-cover", "book", "back-cover"]+ <> imageJoinRules ["flight-notification"]+ <> unlessAfterStep (== "pdf page 1") (pageCountRules (<> ".npages"))+ <> pageOneRules (\p -> dropExtension p <> "_page1.pdf") (`replaceExtension` "png")+ -- LibreOffice makes images named *_html_* for its HTML.+ <> onPaths+ (not . isInfixOf "_html_" . takeFileName)+ ( imageRules+ ["png", "jpg", "jpeg", "gif", "svg", "webp"]+ ["png", "jpg"]+ [1200, 800, 600, 450, 350, 250, 200, 150, 100, 65, 45]+ (flip replaceExtension)+ (\n p -> dropExtension p <> "-" <> show n <> takeExtension p)+ )++-- | The rules that run when the build is complete.+complete :: Rules+complete =+ archiveRules (hasExtension ["npages"]) "npages.tar.gz"+ <> outputTreeRules "outputs.json" "outputs.html" ((`placeholderValue` "CI_PROJECT_TITLE") <$> onFile "." projectPlaceholders)++-- | The extensions of the text files whose placeholders are replaced.+textExtensions :: [String]+textExtensions =+ ["fodt", "fods", "fodg", "fodp", "md", "txt", "html", "css", "svg"]++{- | The placeholders of a file in a project: those of the project, and those+of the last commit to change the file, with the names that the documents use.+-}+placeholders :: String -> Command' Placeholders+placeholders project =+ (\f p -> overrides project (placeholderAliases aliases (f <> p)))+ <$> filePlaceholders+ <*> onFile "." projectPlaceholders+ where+ aliases =+ [ ("COMMIT_TIME", "GIT_COMMIT_TIME")+ , ("GITLAB_USER_NAME", "GIT_AUTHOR_NAME")+ , ("GITLAB_USER_EMAIL", "GIT_AUTHOR_EMAIL")+ , ("CI_COMMIT_SHA", "GIT_COMMIT_HASH")+ ]++-- | The placeholders of the project, from the variables that GitLab CI sets.+projectPlaceholders :: Command' Placeholders+projectPlaceholders =+ environmentPlaceholders+ [ ("CI_PAGES_DOMAIN", pure "")+ , ("CI_PAGES_URL", pure "")+ , ("CI_PROJECT_TITLE", directoryName)+ , ("CI_PROJECT_URL", pure "")+ , ("CI_PROJECT_VISIBILITY", pure "")+ ]++-- | The values of placeholders for specific projects.+overrides :: String -> Placeholders -> Placeholders+overrides project =+ case project of+ -- The default pages domain does not work for this project.+ "system-f/media/elp/elp-forms" -> withPlaceholder "CI_PAGES_URL" "https://elp-forms.systemf.com.au/"+ _ -> id++-- | The styles of the standalone HTML of LibreOffice text documents.+pandocStyle :: Command' [String]+pandocStyle =+ lift $+ (<>)+ <$> (concatMap (\x -> ["-c", x]) <$> filesWithExtension ["css"] "css")+ <*> whenFileExists "etc/lua-filter.lua" ["--lua-filter=etc/lua-filter.lua"]++{- | The formats of markdown files, with their pandoc options. Images are not+made into figures, and the main font is DejaVu Sans Mono.+-}+markdownConversions :: [(String, Command' [String])]+markdownConversions =+ let options = ["--standalone", "-fmarkdown-implicit_figures", "-M", "mainfont=DejaVu Sans Mono"]+ in [ ("pdf", pure (options <> xelatex))+ , ("html", (options <>) <$> lift htmlOptions)+ , ("docx", pure options)+ , ("odt", pure options)+ ]++{- | The options of HTML from markdown: @etc/template.html@ as its template,+and the HTML files in @public/etc@: @header.html@ before the body,+@footer.html@ after it, and the others in the head.+-}+htmlOptions :: Build' [String]+htmlOptions =+ let header = "public/etc/header.html"+ footer = "public/etc/footer.html"+ in do+ template <- whenFileExists "etc/template.html" ["--template", "etc/template.html"]+ etc <- filesWithExtension ["html"] "public/etc"+ pure $+ template+ <> concatMap (\h -> ["-H", h]) (filter (`notElem` [header, footer]) etc)+ <> bool [] ["-B", header] (header `elem` etc)+ <> bool [] ["-A", footer] (footer `elem` etc)++-- | Rules for specific projects and files.+exceptions :: Rules+exceptions =+ onProject+ "system-f/media/elp/elp-certificate"+ ( onPaths+ (\p -> isWithin "src" p && hasExtension textExtensions p)+ (requirePlaceholders ["CI_PAGES_URL", "CI_PROJECT_URL", "COMMIT_TIME", "GITLAB_USER_NAME", "GITLAB_USER_EMAIL", "CI_COMMIT_SHA", "CI_PROJECT_VISIBILITY"])+ )+ <> onProjects isManual (aquilaA210 <> foldMap (uncurry splitPdf) manualSplits)++-- | Whether a project is an aircraft manual project.+isManual :: String -> Bool+isManual =+ isPrefixOf "system-f/aircraft/manual/"++{- | Apply service bulletin SB-AT01-029 (B.01) to the Aquila A210 flight+manual FM-AT01-1010-100E (B.04).+-}+aquilaA210 :: Rules+aquilaA210 =+ mergePdf+ [("A", "FM_AT01_1010_100E_B04.pdf"), ("B", "SB_AT01_029_02-AFM_page_1-8_2-4_5.pdf")]+ ["A1-16", "B1", "A18-24", "B2", "B3", "A27-end"]+ "FM_AT01_1010_100E_B04____SB_AT01_029_02-AFM_page_1-8_2-4_5.pdf"++{- | The sections that aircraft manuals are split into, from+'manualSections', as PDF files relative to the output directory.+-}+manualSplits :: [(FilePath, [(String, FilePath)])]+manualSplits =+ [ (path <.> "pdf", fmap (\(r, s) -> (r, path <> s <.> "pdf")) sections)+ | (path, sections) <- manualSections+ , not (null sections)+ ]++{- | The sections of aircraft manuals: the path of each manual in the output+directory, without @.pdf@, and its sections, each a @pdftk@ page range and+the suffix of the file of the section. For example,+@("vh-bne/aquila-a210_vh-bne", [("1", "_cover")])@ splits page 1 of+@public/vh-bne/aquila-a210_vh-bne.pdf@ into+@public/vh-bne/aquila-a210_vh-bne_cover.pdf@.+-}+manualSections :: [(FilePath, [(String, String)])]+manualSections =+ [ ("vh-ysa/normal-procedures", [])+ , ("vh-ysa/emergency-procedures", [])+ , ("vh-nqx/8kcab_vh-nqx", [])+ ,+ ( "FM_AT01_1010_100E_B04____SB_AT01_029_02-AFM_page_1-8_2-4_5"+ ,+ [ ("1", "_section0")+ , ("10-21", "_section1_general")+ , ("22-41", "_section2_limitations")+ , ("42-57", "_section3_emergency_procedures")+ , ("58-77", "_section4_normal_procedures")+ , ("78-110", "_section5_performance")+ , ("111-124", "_section6_weight_and_balance")+ , ("125-156", "_section7_system_description")+ , ("157-164", "_section8_handling_service_maintenance")+ , ("165-167", "_section9_supplements")+ ]+ )+ ,+ ( "vh-bne/aquila-a210_vh-bne"+ ,+ [ ("1", "_cover")+ , ("2-9", "_introduction")+ , ("10-21", "_section1_general")+ , ("22-46", "_section2_limitations")+ , ("47-62", "_section3_emergency_procedures")+ , ("63-82", "_section4_normal_procedures")+ , ("83-117", "_section5_performance")+ , ("118-132", "_section6_weight_and_balance_equipment_list")+ , ("133-164", "_section7_description_of_the_aircraft_and_its_systems")+ , ("165-172", "_section8_handling_service_maintenance")+ , ("173-254", "_section9_supplements")+ , ("178-183", "_section9_supplements_ave4")+ , ("184-189", "_section9_supplements_ave5")+ , ("190-193", "_section9_supplements_ave10")+ , ("194-203", "_section9_supplements_ave11")+ , ("204-214", "_section9_supplements_ave12")+ , ("215-226", "_section9_supplements_ave16")+ , ("227-244", "_section9_supplements_ave23")+ , ("245-254", "_section9_supplements_ave26")+ ]+ )+ ,+ ( "Sling-2-POH-2.3-RSA-operating_handbook"+ ,+ [ ("1", "_cover")+ , ("2-9", "_introduction")+ , ("10", "_table_of_contents")+ , ("11-28", "_1_general_information")+ , ("29-44", "_2_limitations")+ , ("45-64", "_3_emergency_procedures")+ , ("65-85", "_4_normal_procedures")+ , ("86-91", "_5_performance")+ , ("92-99", "_6_weight_and_balance")+ , ("100-134", "_7_systems")+ , ("135-142", "_8_airplane_ground_handling_service")+ , ("143-192", "_9_supplementary_information")+ ]+ )+ ,+ ( "24-4844/eurofox-3k_24-4844"+ ,+ [ ("1", "_cover")+ , ("2-4", "_introduction")+ , ("5-8", "_table_of_contents")+ , ("9", "_general_information")+ , ("10-21", "_airplane_and_systems_description")+ , ("22-25", "_operating_limitations")+ , ("26-29", "_weight_and_balance_information")+ , ("30-32", "_performance")+ , ("33-41", "_emergency_procedures")+ , ("42-57", "_normal_procedures")+ , ("58-60", "_aircraft_ground_handling_and_servicing")+ , ("61-63", "_required_placards_and_markings")+ , ("64", "_supplementary_information")+ ]+ )+ ,+ ( "24-5350/eurofox-3k_24-5350"+ ,+ [ ("1", "_cover")+ , ("2-3", "_introduction")+ , ("4-7", "_table_of_contents")+ , ("8", "_general_information")+ , ("9-20", "_airplane_and_systems_description")+ , ("21-24", "_operating_limitations")+ , ("25-29", "_weight_and_balance_information")+ , ("30-32", "_performance")+ , ("33-41", "_emergency_procedures")+ , ("42-57", "_normal_procedures")+ , ("58-60", "_aircraft_ground_handling_and_servicing")+ , ("61-63", "_required_placards_and_markings")+ , ("64", "_supplementary_information")+ ]+ )+ ,+ ( "24-8881/eurofox-3k_24-8881"+ ,+ [ ("1", "_cover")+ , ("2-10", "_introduction")+ , ("11-14", "_table_of_contents")+ , ("15-16", "_general_information")+ , ("17-28", "_airplane_and_systems_description")+ , ("29-32", "_operating_limitations")+ , ("33-39", "_weight_and_balance_information")+ , ("40-42", "_performance")+ , ("43-51", "_emergency_procedures")+ , ("52-67", "_normal_procedures")+ , ("68-69", "_aircraft_ground_handling_and_servicing")+ , ("70-72", "_required_placards_and_markings")+ , ("73", "_supplementary_information")+ ]+ )+ ,+ ( "a240-poh"+ ,+ [ ("1", "_cover")+ , ("4-6", "_table_of_contents")+ , ("7-7", "_general_information")+ , ("8-17", "_airplane_and_systems_description")+ , ("18-20", "_operating_limitations")+ , ("21-23", "_weight_and_balance_information")+ , ("24-25", "_performance")+ , ("26-34", "_normal_procedures")+ , ("35-40", "_emergency_procedures")+ , ("41-44", "_aircraft_ground_handling_and_servicing")+ , ("45-45", "_supplementary_information")+ , ("46-50", "_flight_training_supplement")+ ]+ )+ ,+ ( "maintenance-manual"+ ,+ [ ("1", "_cover")+ , ("2", "_list_of_effective_pages")+ , ("3", "_table_of_contents")+ , ("4", "_foreword")+ , ("5", "_common_conversions_and_abbreviations")+ , ("6-13", "_section1_general_description")+ , ("14-24", "_section2_ground_handling_servicing_lubrication_and_inspection")+ , ("25-33", "_section3_structures_fuselage")+ , ("34-41", "_section4_structures_wings_and_empennage")+ , ("42-54", "_section5_structures_landing_gear_and_brakes_tricycle_gear")+ , ("55-61", "_section6_structures_aileron_and_flap_control_system")+ , ("62-65", "_section7_structures_elevator_control_system")+ , ("66-69", "_section8_structures_elevator_trim_control_system")+ , ("70-72", "_section9_structures_rudder_control_system")+ , ("72-94", "_section10_engine")+ , ("95-101", "_section11_fuel_system")+ , ("102-103", "_section12_propeller")+ , ("104-106", "_section13_utility_systems")+ , ("107-114", "_section14_instruments_and_instrument_system")+ , ("115-123", "_section15_electrical_systems")+ , ("124", "_section16_structural_repair")+ , ("125", "_section17_exterior_painting")+ , ("126", "_section18_wiring_diagrams_general_wiring_scheme")+ , ("127-128", "_section19_safety_directives_and_safety_monitoring_system")+ , ("129-141", "_a220_taildragger_supplement")+ ]+ )+ , ("POH_Supplement_MTOW", [])+ , ("Annex_01-151107", [])+ , ("24-8300/foxbat-a22ls_24-8300", [])+ , ("A-22LS_POH-S-N-146-R912iS", [])+ , ("A22LS-POH-V5-Complete", [])+ , ("23-2212/magnus-fusion-212_23-2212_manual", [])+ ,+ ( "vh-rmv/vans-rv14_vh-rmv"+ ,+ [ ("1", "_cover")+ , ("2-3", "_equipment_list")+ , ("4-5", "_performance_specifications")+ , ("7", "_aerobatic_information")+ , ("8-9", "_preflight_inspection")+ , ("10", "_starting_engine")+ , ("11", "_before_takeoff")+ , ("12", "_takeoff")+ , ("13", "_landing")+ , ("14", "_performance")+ , ("15", "_engine_information")+ , ("17-20", "_emergency_procedures")+ , ("21-25", "_weight_and_balance")+ ]+ )+ ,+ ( "vh-egy/cessna-152_vh-egy"+ ,+ [ ("1-2", "_certificate_of_registration")+ , ("3", "_cover")+ , ("4", "_performance_specifications")+ , ("5", "_table_of_contents")+ , ("6-13", "_section1_general")+ , ("14-22", "_section2_limitations")+ , ("23-36", "_section3_emergency_procedures")+ , ("37-57", "_section4_normal_procedures")+ , ("58-77", "_section5_performance")+ , ("78-98", "_section6_weight_and_balance")+ , ("99-131", "_section7_airplane_and_systems_descriptions")+ , ("132-144", "_section8_airplane_handling_and_maintenance")+ , ("145-201", "_section9_supplements")+ , ("202", "_stc_SA1000NW")+ ]+ )+ ,+ ( "vh-nkj/cessna-152_vh-nkj"+ ,+ [ ("1", "_vhnkj_load_data_sheet")+ , ("5-6", "_cover")+ , ("7", "_congratulations")+ , ("8", "_performance_specifications")+ , ("9", "_table_of_contents")+ , ("10-17", "_section1_general")+ , ("18-25", "_section2_limitations")+ , ("26-40", "_section3_emergency_procedures")+ , ("41-61", "_section4_normal_procedures")+ , ("62-79", "_section5_performance")+ , ("80-99", "_section6_weight_and_balance")+ , ("100-132", "_section7_airplane_and_systems_descriptions")+ , ("133-145", "_section8_airplane_handling_and_maintenance")+ , ("146-205", "_section9_supplements")+ ]+ )+ , ("Cessna_172_C172N-1978-POH-S1to7-scanned", [])+ ,+ ( "cessna-172p"+ ,+ [ ("1", "_cover")+ , ("3", "_congratulations")+ , ("4", "_performance_specifications")+ , ("5-6", "_coverage_revisions_log_of_effective_pages")+ , ("7", "_table_of_contents")+ , ("8-16", "_section1_general")+ , ("17-28", "_section2_limitations")+ , ("29-45", "_section3_emergency_procedures")+ , ("46-70", "_section4_normal_procedures")+ , ("71-94", "_section5_performance")+ , ("95-121", "_section6_weight_and_balance_equipment")+ , ("122-158", "_section7_airplane_and_systems_descriptions")+ , ("159-176", "_section8_airplane_handling_service_and_maintenance")+ , ("177-190", "_section9_supplements")+ ]+ )+ ,+ ( "vh-azq/vh-azq"+ ,+ [ ("1-4", "_coverage_revision_log_of_effective_pages")+ , ("5", "_table_of_contents")+ , ("7-8", "_certificate_of_registration")+ , ("9-17", "_section1_general")+ , ("19-33", "_section2_limitations")+ , ("35-52", "_section3_emergency_procedures")+ , ("53-77", "_section4_normal_procedures")+ , ("79-103", "_section5_performance")+ , ("105-135", "_section6_weight_and_balance_equipment")+ , ("137-175", "_section7_airplane_and_systems_descriptions")+ , ("177-195", "_section8_airplane_handling_service_and_maintenance")+ , ("197-410", "_section9_supplements")+ ]+ )+ ,+ ( "skyhawk_pim-20130523"+ ,+ [ ("1", "_notice")+ , ("2-3", "_performance_specifications")+ , ("5", "_cover")+ , ("7", "_table_of_contents")+ , ("9-38", "_section1_general")+ , ("39-66", "_section2_operating_limitations")+ , ("67-105", "_section3_emergency_procedures")+ , ("107-154", "_section4_normal_procedures")+ , ("155-176", "_section5_performance")+ , ("177-200", "_section6_weight_and_balance_equipment")+ , ("201-280", "_section7_airplane_and_systems_descriptions")+ , ("281-305", "_section8_airplane_handling_service_and_maintenance")+ , ("307-349", "_section9_supplements")+ ]+ )+ ,+ ( "skyhawksp_pim-20130523"+ ,+ [ ("1", "_notice")+ , ("2-3", "_performance_specifications")+ , ("5", "_cover")+ , ("7", "_table_of_contents")+ , ("9-38", "_section1_general")+ , ("39-66", "_section2_operating_limitations")+ , ("67-105", "_section3_emergency_procedures")+ , ("107-154", "_section4_normal_procedures")+ , ("155-178", "_section5_performance")+ , ("179-202", "_section6_weight_and_balance_equipment")+ , ("203-282", "_section7_airplane_and_systems_descriptions")+ , ("283-307", "_section8_airplane_handling_service_and_maintenance")+ , ("308-351", "_section9_supplements")+ ]+ )+ ,+ ( "cessna-182p"+ ,+ [ ("1", "_cover")+ , ("2", "_list_of_effective_pages")+ , ("3", "_congratulations")+ , ("4", "_performance_specifications")+ , ("5", "_table_of_contents")+ , ("7-14", "_section1_general")+ , ("15-25", "_section2_limitations")+ , ("27-41", "_section3_emergency_procedures")+ , ("43-64", "_section4_normal_procedures")+ , ("65-91", "_section5_performance")+ , ("93-117", "_section6_weight_and_balance_equipment")+ , ("119-158", "_section7_airplane_and_systems_descriptions")+ , ("159-172", "_section8_airplane_handling_service_and_maintenance")+ , ("173-258", "_section9_supplements")+ ]+ )+ ,+ ( "vh-tin/cessna-182p_vh-tin"+ ,+ [ ("1", "_amendment_record_sheet")+ , ("2-13", "_certificate_of_registration")+ , ("14-15", "_cover")+ , ("16-26", "_amendment_record_sheets")+ , ("27-27", "_introduction")+ , ("28-30", "_list_of_contents")+ , ("31-31", "_definitions")+ , ("32-34", "_section1_general_aeroplane_particulars")+ , ("35-38", "_section2_operating_limitations")+ , ("39-41", "_section3_handling")+ , ("42-44", "_section4_performance")+ , ("45-48", "_section5_instrument_and_equipment_installations")+ , ("49-57", "_section6_loading_data")+ , ("58-92", "_section7_supplements")+ ]+ )+ ,+ ( "OM_912_Series_ED4_R2"+ ,+ [ ("1", "_cover")+ , ("2", "_rotax")+ , ("3", "_table_of_contents")+ , ("5", "_introduction")+ , ("7-8", "_list_of_effective_pages")+ , ("9-12", "_table_of_amendments")+ , ("13-27", "_general_note")+ , ("29-40", "_operating_instructions")+ , ("41-48", "_abnormal_operation")+ , ("49-62", "_standard_operation")+ , ("63-72", "_performance_and_fuel_consumption")+ , ("73-85", "_system_description")+ , ("87-89", "_preservation_and_storage")+ , ("91", "_supplement")+ , ("93-94", "_index")+ , ("96", "_back_cover")+ ]+ )+ ,+ ( "si-912-016-r13"+ ,+ [ ("1-2", "_1_planning_information_2_material_information")+ , ("3-5", "_3_lubricant")+ , ("6-8", "_4_coolant")+ , ("9-14", "_5_fuel")+ , ("15", "_6_general_engine_operation_requirements_7_summary_8_inquiries")+ ]+ )+ ,+ ( "sv-d700_sv-d1000_sv-d1000t/SkyView_System_Installation_Guide-Rev_W_v14_0"+ ,+ [ ("1", "_cover")+ , ("3-4", "_changes_and_contacts")+ , ("5-11", "_table_of_contents")+ , ("13-18", "_introduction")+ , ("19-34", "_system_planning")+ , ("35-53", "_basic_skyview_display_operation")+ , ("55-87", "_sv-d700_sv-d1000_sv-d1000t_installation_and_onfiguration")+ , ("89-106", "_sv-adahrs-200_201_installation_and_configuration")+ , ("107-114", "_sv-map-270_navigation_mapping_license_purchase_and_setup")+ , ("115-191", "_sv-ems-220_221_installation_and_configuration")+ , ("193-205", "_sv-gps-250_sv-gps-2020_gps_receiver_installation_and_configuration")+ , ("207-213", "_sv-bat-320_installation")+ , ("215-236", "_autopilot_servo_installation_configuration_and_calibration")+ , ("237-275", "_sv-xpndr-261_262_installation_configuration_and_testing")+ , ("277-288", "_sv-arinc-429_installation_and_configuration")+ , ("289-293", "_vertical_power_vp-x_ntegration_and_onfiguration")+ , ("295-304", "_sv-adsb-470_installation_configuration_and_testing")+ , ("305-319", "_accessory_installation_and_configuration")+ , ("321-339", "_sv-com-c25_installation_configuration_and_testing")+ , ("341-362", "_sv-com-x83_installation_configuration_and_testing")+ , ("363-371", "_sv-ap-panel_installation")+ , ("373-375", "_sv-knob-panel_installation")+ , ("377-385", "_sv-mag-236_installation_and_configuration")+ , ("387-399", "_appendix_a_maintenance_and_troubleshooting")+ , ("401-413", "_appendix_b_specifications")+ , ("415-438", "_appendix_c_wiring_and_electrical_connections")+ , ("439-440", "_appendix_d_sv-ems-220_221_sensor_input_mapping_worksheet")+ , ("441-453", "_appendix_e_serial_data_output")+ , ("455-458", "_appendix_f_user_data_logs")+ , ("459", "_appendix_g_kavlico_pressure_sensor_part_numbers")+ , ("461-463", "_appendix_h_sensor_debug_data")+ , ("465-489", "_appendix_i_skyview_system_installation_guide_revision_history")+ , ("491-496", "_appendix_j_checklists")+ ]+ )+ ,+ ( "flightdek-d180/FlightDEK-D180_Pilot's_User_Guide_Rev_H"+ ,+ [ ("1-2", "_cover")+ , ("2-3", "_contact_information")+ , ("4-7", "_table_of_contacts")+ , ("8-10", "_introduction")+ , ("11-15", "_product_overview")+ , ("16-23", "_product_operation")+ , ("24-37", "_available_pages")+ , ("38-52", "_efis_operation")+ , ("53-62", "_hsi_operation")+ , ("63-79", "_autopilot_operation")+ , ("80-85", "_alerts")+ , ("86-89", "_ems_monitoring_functions")+ , ("90-96", "_ems_operation")+ , ("97-108", "_appendix")+ ]+ )+ ,+ ( "efis-d100/EFIS-D100_Pilot's_User_Guide_Rev_H"+ ,+ [ ("1", "_cover")+ , ("2-3", "_contact_information")+ , ("4-6", "_table_of_contents")+ , ("7-9", "_introduction")+ , ("10-14", "_product_overview")+ , ("15-22", "_product_operation")+ , ("23-33", "_available_pages")+ , ("34-49", "_efis_operation")+ , ("50-59", "_hsi_operation")+ , ("60-76", "_autopilot_operation")+ , ("77-80", "_alerts")+ , ("81-89", "_appendix")+ ]+ )+ ,+ ( "d500_d600/190-00601-02_K"+ ,+ [ ("1", "_cover")+ , ("2-10", "_foreword")+ , ("11-16", "_table_of_contents")+ , ("17-42", "_system_overview")+ , ("43-82", "_primary_flight_display")+ , ("83-158", "_multi_function_display")+ , ("159-316", "_hazard_avoidance")+ , ("317-368", "_additional_features")+ , ("369-384", "_annunciations_and_alerts")+ , ("385-392", "_symbols")+ , ("393-400", "_glossary")+ , ("401-408", "_appendix_a")+ , ("409-418", "_index")+ ]+ )+ ,+ ( "ekpiv_ekpiv_pro/EKP_pro_inglese_162"+ ,+ [ ("1", "_cover")+ , ("2-3", "_foreword")+ , ("4-8", "_table_of_contents")+ , ("5-15", "_introduction")+ , ("16-21", "_the_basics")+ , ("22-35", "_the_moving_maps")+ , ("36-37", "_navigation_and_location")+ , ("38-39", "_the_hsi_screen")+ , ("40-44", "_flight_plan")+ , ("45-47", "_the_global_positioning_system")+ , ("48-51", "_waypoint_and_database")+ , ("52-53", "_approach_data_procedures")+ , ("54-59", "_calculator")+ , ("60-61", "_the_checklists")+ , ("62-63", "_simulator")+ , ("64-65", "_the_communication")+ , ("66-75", "_the_system_setup_menu")+ , ("76-82", "_operating_requirements")+ , ("83", "_ekp_iv_pro")+ , ("84-95", "_appendices")+ ]+ )+ ]
+ changelog.md view
@@ -0,0 +1,45 @@+# Changelog++## 0.1.0.0++* Start again, replacing the earlier prototype, with the project layout,+ linting and CI of either-n+* Depend on filepather 0.7, in this repository, for FilePather and Tracked+ build steps+* Add Document.Build.Build: Build and Command, running builds, running+ processes, and the assertions requireInput, requireDirectory and+ requirePath+* Add Document.Build.Error: BuildError and CommandLine, with prisms,+ lenses, exit codes and classy optics, including BuildCycle for a chain of+ build steps that would go round in a cycle, and OutputNotInDirectory for a+ build step that makes a file outside the output directory, and+ ShallowRepository for a git history that is too shallow to give the last+ commit of each file+* Add operations for PDF (Document.Build.Pdf), LibreOffice+ (Document.Build.LibreOffice), pandoc (Document.Build.Pandoc), images+ (Document.Build.Image), git (Document.Build.Git), hashes+ (Document.Build.Hash), string replacement (Document.Build.Replace) and+ files (Document.Build.File), every one a FilePather value; operations+ that take several input files (pdfJoin, pdfConcatenate, pdftk,+ imageAppend) take the directory they are in+* Add Document.Build.Operations, which exports every operation+* Add Document.Build.Project: projectPath, placeholders from environment+ variables and of each file, from the last commit to change it rather than+ of the repository, placeholder aliases, prepareFile, and project fonts+* Add Document.Build.Context: the Directories of a build and the Context+ that rules run in, as data with optics, Rules, buildStep, and combinators+ that choose the files rules apply to+* Add Document.Build.Rules: rules that prepare, convert, join, split,+ count, extract pages of and resize the files of a project, archive files+ and write the tree of output files, each with its settings as arguments,+ and no defaults+* Add Document.Build.Documents: build and buildProject, which run rules over+ the directories of a project until they make no more files, then once+ more when the build is complete+* Add Document.Build.Output: the tree of output files of a build, with the+ hash, git details, page count and image information of each file, in JSON+ and an HTML page+* Add build.hs, the build file of a set of projects, a cabal script with+ the settings of every project, and exceptions for some+* Add hedgehog property tests for the laws of the optics, doctests, and+ criterion benchmarks
+ document-build.cabal view
@@ -0,0 +1,215 @@+cabal-version: 2.4+name: document-build+version: 0.1.0.0+license: BSD-3-Clause+license-file: LICENCE+author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> <dibblego>+maintainer: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> <dibblego>+copyright: Copyright (c) 2021-2026 Tony Morris+synopsis: Build documents with Haskell+category: Development+description:+ <<https://logo.systemf.com.au/systemf-450x450.png>>+ .+ Build documents with Haskell: convert them between formats, get information+ about them, and replace strings in them.+ .+ == Operations+ .+ @Document.Build.Operations@ provides the canonical document operations,+ every one a @FilePather@ value (from the @filepather@ package) in an effect+ that fails with an exit code (from the @exitcode@ package): convert+ LibreOffice, markdown, PDF and image files; count pages; split and join PDF+ files; hash files; get git details of files; and replace strings in files.+ .+ == Rules and builds+ .+ @Document.Build.Rules@ wraps the operations in named, tracked build steps,+ which say which files are made from which, each with its settings as+ arguments, and @Document.Build.Documents@ runs rules over a project until+ they make no more files.+ .+ The library has no settings of its own: the build file of a project, a+ cabal script, gives @build@ the directories of the project and its rules.++homepage: https://gitlab.com/tonymorris/document-build+bug-reports: https://gitlab.com/tonymorris/document-build/issues+build-type: Simple+extra-doc-files: README.md+ changelog.md+tested-with: GHC == 9.14.1, GHC == 9.12.4, GHC == 9.10.3, GHC == 9.8.4, GHC == 9.6.7++source-repository head+ type: git+ location: https://gitlab.com/tonymorris/document-build.git++flag doctest+ description: Build the doctest test suite, which runs doctest through cabal. It is enabled in cabal.project, and disabled by default so that builds from the source distribution do not need cabal or doctest at test time.+ default: False+ manual: True++library+ default-language:+ Haskell2010++ build-depends:+ base >= 4.18 && < 5+ , aeson >= 2.2.3 && < 2.4+ , aeson-pretty >= 0.8.10 && < 0.9+ , bytestring >= 0.11.5.4 && < 0.13+ , containers >= 0.6.7 && < 0.9+ , cryptohash-sha256 >= 0.11.102.1 && < 0.12+ , deepseq >= 1.4.8.1 && < 2+ , directory >= 1.3.8.5 && < 2+ , either-n >= 0.1 && < 0.2+ , exitcode >= 0.3.0.1 && < 0.4+ , filepath >= 1.4.301.0 && < 1.6+ , filepather >= 0.7 && < 0.8+ , lens >= 5.2.1 && < 6+ , mtl >= 2.3.1 && < 2.4+ , natural >= 0.5.0.1 && < 0.6+ , process >= 1.6.19.0 && < 2+ , temporary >= 1.3 && < 2+ , text >= 2.0.2 && < 2.2+ , time >= 1.12.2 && < 2+ , transformers >= 0.6.1 && < 0.7++ ghc-options:+ -Wall+ -Wcompat+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wredundant-constraints++ hs-source-dirs:+ src++ exposed-modules:+ Document.Build+ Document.Build.Build+ Document.Build.Context+ Document.Build.Documents+ Document.Build.Error+ Document.Build.File+ Document.Build.Git+ Document.Build.Hash+ Document.Build.Image+ Document.Build.LibreOffice+ Document.Build.Operations+ Document.Build.Output+ Document.Build.Pandoc+ Document.Build.Pdf+ Document.Build.Project+ Document.Build.Replace+ Document.Build.Rules++-- The build file, build.hs, which is a cabal script that each document project+-- runs. Building it here checks that it compiles.+executable document-build+ main-is:+ build.hs++ default-language:+ Haskell2010++ build-depends:+ base >= 4.18 && < 5+ , document-build+ , filepath >= 1.4.301.0 && < 1.6+ , mtl >= 2.3.1 && < 2.4++ ghc-options:+ -Wall+ -Wcompat+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wredundant-constraints++ hs-source-dirs:+ .++test-suite hedgehog+ type:+ exitcode-stdio-1.0++ main-is:+ hedgehog_tests.hs++ other-modules:+ BuildTests+ Gens+ Laws+ OutputTests++ default-language:+ Haskell2010++ build-depends:+ base >= 4.18 && < 5+ , aeson >= 2.2.3 && < 2.4+ , bytestring >= 0.11.5.4 && < 0.13+ , containers >= 0.6.7 && < 0.9+ , document-build+ , hedgehog >= 1.2 && < 2+ , lens >= 5.2.1 && < 6+ , text >= 2.0.2 && < 2.2+ , time >= 1.12.2 && < 2++ ghc-options:+ -Wall+ -threaded++ hs-source-dirs:+ test++test-suite doctest+ type:+ exitcode-stdio-1.0++ if !flag(doctest)+ buildable: False++ main-is:+ doctest_tests.hs++ default-language:+ Haskell2010++ build-depends:+ base >= 4.18 && < 5+ , process >= 1.6.19.0 && < 2+ , document-build++ ghc-options:+ -Wall+ -threaded++ hs-source-dirs:+ test++benchmark bench+ type:+ exitcode-stdio-1.0++ main-is:+ Main.hs++ default-language:+ Haskell2010++ build-depends:+ base >= 4.18 && < 5+ , bytestring >= 0.11.5.4 && < 0.13+ , criterion >= 1.6.2.0 && < 2+ , filepather+ , lens >= 5.2.1 && < 6+ , mtl >= 2.3.1 && < 2.4+ , text >= 2.0.2 && < 2.2+ , document-build++ ghc-options:+ -Wall+ -O2++ hs-source-dirs:+ bench
+ src/Document/Build.hs view
@@ -0,0 +1,54 @@+{-# OPTIONS_GHC -Wall #-}++{- | Build documents: convert them between formats, get information about+them, and replace strings in them.++The library has four layers:++1. "System.FilePather" (the @filepather@ package): 'FilePather', a+ computation that depends on the file path being operated on, and+ 'Tracked', named build steps that record the files they make, so that a+ chain of steps that would go round in a cycle is stopped.+2. "Document.Build.Operations": the canonical document operations, every one+ a 'FilePather' value, such as 'pdfPages', 'markdownToPdf' and 'sha256'.+3. "Document.Build.Context", "Document.Build.Rules" and+ "Document.Build.Documents": the rules that wrap the operations in named+ steps, each with its settings as arguments, the combinators that choose+ the files rules apply to, and 'build', which runs rules over a project.+4. The build file of each project, a cabal script, which gives 'build' the+ directories of the project and its rules:++@+import Document.Build++main :: IO ()+main =+ 'build'+ ('Directories' "public" ["src"] Nothing)+ ( 'prepareRules' ["md"] 'filePlaceholders' "src"+ <> 'markdownRules' (flip replaceExtension) [("pdf", pure ["--standalone"])]+ <> 'pageOneRules' (\p -> dropExtension p <> "-1.pdf") (\`replaceExtension\` "png")+ )+@+-}+module Document.Build (+ module Document.Build.Build,+ module Document.Build.Context,+ module Document.Build.Documents,+ module Document.Build.Error,+ module Document.Build.Operations,+ module Document.Build.Output,+ module Document.Build.Project,+ module Document.Build.Rules,+ module System.FilePather,+) where++import Document.Build.Build+import Document.Build.Context+import Document.Build.Documents+import Document.Build.Error+import Document.Build.Operations+import Document.Build.Output+import Document.Build.Project+import Document.Build.Rules+import System.FilePather
+ src/Document/Build/Build.hs view
@@ -0,0 +1,307 @@+{-# 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
+ src/Document/Build/Context.hs view
@@ -0,0 +1,573 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -Wall #-}++{- | The context that rules run in, and the combinators that make rules and+choose the files they apply to.++A 'Rules' value is a function of the 'Context' of a build, to a 'Tracked'+build step. The build (see "Document.Build.Documents") runs it on every file+of its input directories, then on every file it makes, until it makes no+more; then on every directory of the output directory, and so on, until+nothing new is made; then once more, on the output directory, when the build+is complete. Rules combine with '<>', which runs both:++@+'Document.Build.Rules.pageCountRules' (\<> ".pages")+ <> 'onProject' "group/project" ('Document.Build.Rules.splitPdf' "report.pdf" [("1", "report_cover.pdf")])+@+-}+module Document.Build.Context (+ -- * Directories+ Directories (..),+ outputDirectory,+ inputDirectories,+ fontsDirectory,+ GetDirectories (..),+ HasDirectories (..),+ ReviewDirectories (..),+ AsDirectories (..),++ -- * Targets+ KnownFiles,+ Target (..),+ _TargetFile,+ _TargetDirectory,+ _TargetComplete,+ GetTarget (..),+ HasTarget (..),+ ReviewTarget (..),+ AsTarget (..),++ -- * Context+ Context (..),+ contextDirectories,+ contextProject,+ contextTarget,+ GetContext (..),+ HasContext (..),+ ReviewContext (..),+ AsContext (..),++ -- * Rules+ Rules,+ fromTracked,+ buildStep,+ buildStep',++ -- * Choosing files+ onProject,+ onProjects,+ withProject,+ onPaths,+ onFiles,+ onDirectories,+ onComplete,+ onSources,+ onOutputs,+ afterStep,+ unlessAfterStep,+) where++import Control.DeepSeq (NFData)+import Control.Lens (Field1, Field2, Field3, Getter, Lens', Prism', Review, lens, preview, prism', review, unto, view, (^.), _1, _2, _3, _Wrapped)+import Data.Bool (bool)+import Data.Data (Data)+import Data.Lens.Injection (Injection1 (..), Injection2 (..), Injection3 (..))+import Data.Map (Map)+import Document.Build.Build (Build', Command', io)+import GHC.Generics (Generic)+import System.Directory (doesFileExist)+import System.FilePather.Combinators (isWithin)+import System.FilePather.FilePather (FilePather (..))+import System.FilePather.Tracked (Tracked, step, step', whenPath, whenTrail)+import System.FilePather.Trail (Trail, lastStep, stepName)++{- $setup+>>> import Control.Lens ((^.), (&), (.~), (^?))+-}++{- | The directories of a build: the output directory, which the build removes+and writes to; the input directories, whose files the rules run on, in+order; and the fonts directory, whose fonts LibreOffice uses during the+build, if there is one.++>>> Directories "public" ["src"] Nothing ^. outputDirectory+"public"++>>> (Directories "public" ["src"] Nothing & fontsDirectory .~ Just "fonts") ^. fontsDirectory+Just "fonts"++@since 0.1.0.0+-}+data Directories+ = Directories FilePath [FilePath] (Maybe FilePath)+ deriving stock (Eq, Ord, Show, Generic, Data)+ deriving anyclass (NFData)++-- | @since 0.1.0.0+instance Field1 Directories Directories FilePath FilePath++-- | @since 0.1.0.0+instance Field2 Directories Directories [FilePath] [FilePath]++-- | @since 0.1.0.0+instance Field3 Directories Directories (Maybe FilePath) (Maybe FilePath)++{- | The directory that the build writes to. It is removed at the start of+the build, and every file the rules make must be in it.++@since 0.1.0.0+-}+outputDirectory :: Lens' Directories FilePath+outputDirectory =+ _1+{-# INLINE outputDirectory #-}++{- | The directories whose files the rules run on, in order: when two files+make the same file, the first is kept.++@since 0.1.0.0+-}+inputDirectories :: Lens' Directories [FilePath]+inputDirectories =+ _2+{-# INLINE inputDirectories #-}++{- | The directory of fonts that LibreOffice uses during the build, if there+is one (see 'Document.Build.Project.withFonts').++@since 0.1.0.0+-}+fontsDirectory :: Lens' Directories (Maybe FilePath)+fontsDirectory =+ _3+{-# INLINE fontsDirectory #-}++-- | @since 0.1.0.0+class GetDirectories s where+ getDirectories :: Getter s Directories++-- | @since 0.1.0.0+instance GetDirectories Directories where+ getDirectories =+ id+ {-# INLINE getDirectories #-}++-- | @since 0.1.0.0+class (GetDirectories s) => HasDirectories s where+ {-# MINIMAL setDirectories #-}+ setDirectories :: Directories -> s -> s++ directories :: Lens' s Directories+ directories =+ lens (view getDirectories) (flip setDirectories)+ {-# INLINE directories #-}++-- | @since 0.1.0.0+instance HasDirectories Directories where+ setDirectories =+ const+ {-# INLINE setDirectories #-}++-- | @since 0.1.0.0+class ReviewDirectories t where+ reviewDirectories :: Review t Directories++-- | @since 0.1.0.0+instance ReviewDirectories Directories where+ reviewDirectories =+ unto id+ {-# INLINE reviewDirectories #-}++-- | @since 0.1.0.0+class (ReviewDirectories t) => AsDirectories t where+ {-# MINIMAL matchDirectories #-}+ matchDirectories :: t -> Maybe Directories++ _Directories :: Prism' t Directories+ _Directories =+ prism' (review reviewDirectories) matchDirectories+ {-# INLINE _Directories #-}++-- | @since 0.1.0.0+instance AsDirectories Directories where+ matchDirectories =+ Just+ {-# INLINE matchDirectories #-}++{- | The files that a build knows: the files of its input directories, with+the empty trail, and the files that the rules made, with their trails, by+normalised path.++@since 0.1.0.0+-}+type KnownFiles = Map FilePath Trail++{- | What a build is running the rules on.++@since 0.1.0.0+-}+data Target+ = -- | A file: a file of an input directory, or a file the rules made.+ TargetFile+ | -- | A directory of the output directory.+ TargetDirectory+ | -- | The output directory, once, when the rules make no more files, with+ -- every file the build knows.+ TargetComplete KnownFiles+ deriving stock (Eq, Ord, Show, Generic, Data)+ deriving anyclass (NFData)++-- | @since 0.1.0.0+instance Injection1 Target Target () ()++-- | @since 0.1.0.0+instance Injection2 Target Target () ()++-- | @since 0.1.0.0+instance Injection3 Target Target KnownFiles KnownFiles++-- | @since 0.1.0.0+_TargetFile :: Prism' Target ()+_TargetFile =+ _I1+{-# INLINE _TargetFile #-}++-- | @since 0.1.0.0+_TargetDirectory :: Prism' Target ()+_TargetDirectory =+ _I2+{-# INLINE _TargetDirectory #-}++{- | >>> TargetComplete mempty ^? _TargetComplete+Just (fromList [])++@since 0.1.0.0+-}+_TargetComplete :: Prism' Target KnownFiles+_TargetComplete =+ _I3+{-# INLINE _TargetComplete #-}++-- | @since 0.1.0.0+class GetTarget s where+ getTarget :: Getter s Target++-- | @since 0.1.0.0+instance GetTarget Target where+ getTarget =+ id+ {-# INLINE getTarget #-}++-- | @since 0.1.0.0+class (GetTarget s) => HasTarget s where+ {-# MINIMAL setTarget #-}+ setTarget :: Target -> s -> s++ target :: Lens' s Target+ target =+ lens (view getTarget) (flip setTarget)+ {-# INLINE target #-}++-- | @since 0.1.0.0+instance HasTarget Target where+ setTarget =+ const+ {-# INLINE setTarget #-}++-- | @since 0.1.0.0+class ReviewTarget t where+ reviewTarget :: Review t Target++-- | @since 0.1.0.0+instance ReviewTarget Target where+ reviewTarget =+ unto id+ {-# INLINE reviewTarget #-}++-- | @since 0.1.0.0+class (ReviewTarget t) => AsTarget t where+ {-# MINIMAL matchTarget #-}+ matchTarget :: t -> Maybe Target++ _Target :: Prism' t Target+ _Target =+ prism' (review reviewTarget) matchTarget+ {-# INLINE _Target #-}++-- | @since 0.1.0.0+instance AsTarget Target where+ matchTarget =+ Just+ {-# INLINE matchTarget #-}++{- | The context that rules are run in: the directories of the build, the+path of the project (see 'Document.Build.Project.projectPath'), and what the+rules are running on.++@since 0.1.0.0+-}+data Context+ = Context Directories String Target+ deriving stock (Eq, Ord, Show, Generic, Data)+ deriving anyclass (NFData)++-- | @since 0.1.0.0+instance Field1 Context Context Directories Directories++-- | @since 0.1.0.0+instance Field2 Context Context String String++-- | @since 0.1.0.0+instance Field3 Context Context Target Target++-- | @since 0.1.0.0+contextDirectories :: Lens' Context Directories+contextDirectories =+ _1+{-# INLINE contextDirectories #-}++-- | @since 0.1.0.0+contextProject :: Lens' Context String+contextProject =+ _2+{-# INLINE contextProject #-}++-- | @since 0.1.0.0+contextTarget :: Lens' Context Target+contextTarget =+ _3+{-# INLINE contextTarget #-}++-- | @since 0.1.0.0+class GetContext s where+ getContext :: Getter s Context++-- | @since 0.1.0.0+instance GetContext Context where+ getContext =+ id+ {-# INLINE getContext #-}++-- | @since 0.1.0.0+class (GetContext s) => HasContext s where+ {-# MINIMAL setContext #-}+ setContext :: Context -> s -> s++ context :: Lens' s Context+ context =+ lens (view getContext) (flip setContext)+ {-# INLINE context #-}++-- | @since 0.1.0.0+instance HasContext Context where+ setContext =+ const+ {-# INLINE setContext #-}++-- | @since 0.1.0.0+instance GetDirectories Context where+ getDirectories =+ contextDirectories+ {-# INLINE getDirectories #-}++-- | @since 0.1.0.0+instance HasDirectories Context where+ setDirectories d (Context _ p t) =+ Context d p t+ {-# INLINE setDirectories #-}++-- | @since 0.1.0.0+instance GetTarget Context where+ getTarget =+ contextTarget+ {-# INLINE getTarget #-}++-- | @since 0.1.0.0+instance HasTarget Context where+ setTarget t (Context d p _) =+ Context d p t+ {-# INLINE setTarget #-}++-- | @since 0.1.0.0+class ReviewContext t where+ reviewContext :: Review t Context++-- | @since 0.1.0.0+instance ReviewContext Context where+ reviewContext =+ unto id+ {-# INLINE reviewContext #-}++-- | @since 0.1.0.0+class (ReviewContext t) => AsContext t where+ {-# MINIMAL matchContext #-}+ matchContext :: t -> Maybe Context++ _Context :: Prism' t Context+ _Context =+ prism' (review reviewContext) matchContext+ {-# INLINE _Context #-}++-- | @since 0.1.0.0+instance AsContext Context where+ matchContext =+ Just+ {-# INLINE matchContext #-}++{- | The rules of a build: a function of its context, to the build steps to+run on a file or directory. Rules combine with '<>', which runs both, and+'mempty' is no rules.++@since 0.1.0.0+-}+type Rules = Context -> Tracked Build' ()++{- | Rules that do not depend on the context.++@since 0.1.0.0+-}+fromTracked :: Tracked Build' () -> Rules+fromTracked =+ const+{-# INLINE fromTracked #-}++{- | A named step that runs a command, which makes the files given by a+function of its input file. See 'System.FilePather.Tracked.step'.++The command is not run if one of the files already exists, because the build+removes the output directory first, so another step made it in this build:+the first step to make a file keeps it.++@since 0.1.0.0+-}+buildStep :: (Monoid a) => String -> (FilePath -> [FilePath]) -> Command' a -> Tracked Build' a+buildStep n outs c =+ step n outs $+ FilePather $ \p ->+ io (or <$> traverse doesFileExist (outs p))+ >>= bool (view _Wrapped c p) (pure mempty)++{- | A named step that runs a command, which returns the files it made. See+'System.FilePather.Tracked.step''.++@since 0.1.0.0+-}+buildStep' :: String -> Command' [FilePath] -> Tracked Build' ()+buildStep' n c =+ step' n (fmap (,()) c)++{- | Rules for one project, by its path, such as @"group/project"@.++@since 0.1.0.0+-}+onProject :: String -> Rules -> Rules+onProject p =+ onProjects (== p)+{-# INLINE onProject #-}++{- | Rules for the projects whose paths satisfy a predicate.++@since 0.1.0.0+-}+onProjects :: (String -> Bool) -> Rules -> Rules+onProjects f r c =+ bool mempty (r c) (f (c ^. contextProject))+{-# INLINE onProjects #-}++{- | Rules that depend on the path of the project, such as rules with+different placeholders for some projects.++@since 0.1.0.0+-}+withProject :: (String -> Rules) -> Rules+withProject f c =+ f (c ^. contextProject) c+{-# INLINE withProject #-}++{- | Rules for the files and directories whose paths satisfy a predicate.++@since 0.1.0.0+-}+onPaths :: (FilePath -> Bool) -> Rules -> Rules+onPaths f r =+ whenPath f . r+{-# INLINE onPaths #-}++{- | Rules for files: the files of the input directories, and the files that+rules make.++@since 0.1.0.0+-}+onFiles :: Rules -> Rules+onFiles r c =+ maybe mempty (const (r c)) (preview (contextTarget . _TargetFile) c)+{-# INLINE onFiles #-}++{- | Rules for the directories of the output directory, which run after the+rules for files have made every file they can.++@since 0.1.0.0+-}+onDirectories :: Rules -> Rules+onDirectories r c =+ maybe mempty (const (r c)) (preview (contextTarget . _TargetDirectory) c)+{-# INLINE onDirectories #-}++{- | Rules that run once, on the output directory, when the rules make no+more files, given every file the build knows. The files they make are not+given to any rules.++@since 0.1.0.0+-}+onComplete :: (KnownFiles -> Rules) -> Rules+onComplete r c =+ maybe mempty (`r` c) (preview (contextTarget . _TargetComplete) c)+{-# INLINE onComplete #-}++{- | Rules for the files of the input directories only: files with the empty+trail.++@since 0.1.0.0+-}+onSources :: Rules -> Rules+onSources r =+ whenTrail (null . preview lastStep) . r+{-# INLINE onSources #-}++{- | Rules for the files and directories in the output directory. Every rule+that makes files from files the rules made, rather than from the files of the+input directories, should apply only to these, so that the input directories+are not changed.++@since 0.1.0.0+-}+onOutputs :: Rules -> Rules+onOutputs r c =+ whenPath (isWithin (c ^. contextDirectories . outputDirectory)) (r c)+{-# INLINE onOutputs #-}++{- | Rules for files made by a step whose name satisfies a predicate.++@since 0.1.0.0+-}+afterStep :: (String -> Bool) -> Rules -> Rules+afterStep f r =+ whenTrail (any f . preview (lastStep . stepName)) . r+{-# INLINE afterStep #-}++{- | Rules for the files of the input directories, and files made by a step+whose name does not satisfy a predicate.++@since 0.1.0.0+-}+unlessAfterStep :: (String -> Bool) -> Rules -> Rules+unlessAfterStep f r =+ whenTrail (not . any f . preview (lastStep . stepName)) . r+{-# INLINE unlessAfterStep #-}
+ src/Document/Build/Documents.hs view
@@ -0,0 +1,158 @@+{-# 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+ )
+ src/Document/Build/Error.hs view
@@ -0,0 +1,460 @@+{-# 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 #-}
+ src/Document/Build/File.hs view
@@ -0,0 +1,132 @@+{-# OPTIONS_GHC -Wall #-}++-- | Commands that find, copy, read, write and archive files.+module Document.Build.File (+ -- * Finding+ whenFileExists,+ filesIn,+ filesWithExtension,++ -- * Copying+ copyTo,+ copyDirectoryTo,++ -- * Text+ readUtf8,+ writeUtf8,++ -- * Archives+ tarGz,+) where++import Control.Lens (view, _Wrapped)+import Control.Monad.Trans.Class (lift)+import Data.Bool (bool)+import qualified Data.ByteString as ByteString+import Data.Functor (($>))+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8', encodeUtf8)+import Document.Build.Build (Build, Command, createParentDirectory, expectOutput, failBuild, io, processWith, requireDirectory, requireInput)+import Document.Build.Error (BuildError (..), CommandLine (..), ReviewBuildError)+import System.Directory (copyFileWithMetadata, doesDirectoryExist, doesFileExist, makeAbsolute)+import System.FilePath (makeRelative, (</>))+import System.FilePather.Combinators (directoryFiles, hasExtension)+import System.FilePather.FilePather (FilePather (..))+import System.Process (cwd)++{- | A value if a file exists, and 'mempty' otherwise, such as options for a+template that a project may have:++@+whenFileExists "etc/template.html" ["--template", "etc/template.html"]+@++@since 0.1.0.0+-}+whenFileExists :: (Monoid a) => FilePath -> a -> Build e a+whenFileExists p a =+ bool mempty a <$> io (doesFileExist p)++{- | The files in a directory and its subdirectories, in sorted order, or none+if the directory does not exist.++@since 0.1.0.0+-}+filesIn :: FilePath -> Build e [FilePath]+filesIn d =+ io (doesDirectoryExist d)+ >>= bool (pure []) (view _Wrapped directoryFiles d)++{- | The files with one of the extensions in a directory and its+subdirectories, in sorted order, or none if the directory does not exist.++@since 0.1.0.0+-}+filesWithExtension :: [String] -> FilePath -> Build e [FilePath]+filesWithExtension exts =+ fmap (filter (hasExtension exts)) . filesIn++{- | Copy the file being operated on to a file path, creating its directory if+needed, and return the file path.++@since 0.1.0.0+-}+copyTo :: (ReviewBuildError e) => FilePath -> Command e FilePath+copyTo o =+ do+ i <- requireInput+ lift (createParentDirectory o *> io (copyFileWithMetadata i o))+ pure o++{- | Copy every file in the directory being operated on, and its+subdirectories, to the same relative path in another directory, and return+the copied file paths. This is like @rsync -a src/ dst@.++Fails with 'InputFileMissing' if the directory does not exist.++@since 0.1.0.0+-}+copyDirectoryTo :: (ReviewBuildError e) => FilePath -> Command e [FilePath]+copyDirectoryTo o =+ do+ d <- requireDirectory+ fs <- directoryFiles+ lift (traverse (\f -> let t = o </> makeRelative d f in ((createParentDirectory t *> io (copyFileWithMetadata f t)) $> t)) fs)++{- | Read a file as UTF-8 text. Fails with 'InputFileMissing' if it does not+exist, and 'FileNotUtf8' if it is not valid UTF-8.++@since 0.1.0.0+-}+readUtf8 :: (ReviewBuildError e) => FilePath -> Build e Text+readUtf8 p =+ do+ _ <- view _Wrapped requireInput p+ b <- io (ByteString.readFile p)+ either (const (failBuild (FileNotUtf8 p))) pure (decodeUtf8' b)++{- | Write text to a file as UTF-8, creating its directory if needed, and+return the file path.++@since 0.1.0.0+-}+writeUtf8 :: FilePath -> Text -> Build e FilePath+writeUtf8 p t =+ (createParentDirectory p *> io (ByteString.writeFile p (encodeUtf8 t))) $> p++{- | Create a gzipped tar archive of files in the directory being operated+on, and return the file path of the archive. The files are given relative to+the directory, and are stored in the archive with those paths. An empty list+of files creates an empty archive.++@since 0.1.0.0+-}+tarGz :: (ReviewBuildError e) => [FilePath] -> FilePath -> Command e FilePath+tarGz fs o =+ FilePather $ \d ->+ do+ createParentDirectory o+ o' <- io (makeAbsolute o)+ let c = CommandLine "tar" ["-czf", o', "--null", "--files-from=-"]+ _ <- processWith (\p -> p{cwd = Just d}) (concatMap (<> "\NUL") fs) c+ expectOutput c o
+ src/Document/Build/Git.hs view
@@ -0,0 +1,374 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}++{- | Commands that get details of files from git, ready to be inserted into+documents.+-}+module Document.Build.Git (+ -- * Details+ GitDetails (..),+ gitCommitHash,+ gitCommitHashShort,+ gitAuthorName,+ gitAuthorEmail,+ gitAuthorTime,+ gitCommitterName,+ gitCommitterEmail,+ gitCommitTime,+ gitSubject,+ gitAuthors,+ gitDetails,+ gitLastCommit,+ gitLogFormat,+ parseGitLog,+ GetGitDetails (..),+ HasGitDetails (..),+ ReviewGitDetails (..),+ AsGitDetails (..),++ -- * Placeholders+ gitPlaceholders,+ formatTimeUtc,++ -- * Files+ gitFiles,+) where++import Control.DeepSeq (NFData)+import Control.Lens (Field1, Field10, Field2, Field3, Field4, Field5, Field6, Field7, Field8, Field9, Getter, Lens', Prism', Review, lens, prism', review, unto, view, _1, _10, _2, _3, _4, _5, _6, _7, _8, _9)+import Control.Monad.Reader (ask)+import Control.Monad.Trans.Class (lift)+import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.=))+import Data.Bool (bool)+import Data.Containers.ListUtils (nubOrd)+import Data.Data (Data)+import Data.List (intercalate)+import Data.Time (UTCTime, defaultTimeLocale, formatTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Document.Build.Build (Command, failBuild, io, process)+import Document.Build.Error (BuildError (..), CommandLine (..), ReviewBuildError)+import GHC.Generics (Generic)+import System.Directory (doesDirectoryExist)+import System.FilePath (normalise, takeDirectory, takeFileName, (</>))+import Text.Read (readMaybe)++{- $setup+>>> import Control.Lens ((^.), (^?), _Just)+-}++{- | Details of the last commit to change a file, and everyone who has+changed it: the commit hash, abbreviated commit hash, author name, author+email, author time, committer name, committer email, commit time, subject,+and the authors of every commit to change the file as @Name \<email\>@, most+recent first, without duplicates.++@since 0.1.0.0+-}+data GitDetails+ = GitDetails String String String String UTCTime String String UTCTime String [String]+ deriving stock (Eq, Ord, Show, Generic, Data)+ deriving anyclass (NFData)++-- | @since 0.1.0.0+instance ToJSON GitDetails where+ toJSON (GitDetails h h' an ae at cn ce ct subject as) =+ object+ [ "hash" .= h+ , "hashShort" .= h'+ , "authorName" .= an+ , "authorEmail" .= ae+ , "authorTime" .= at+ , "committerName" .= cn+ , "committerEmail" .= ce+ , "commitTime" .= ct+ , "subject" .= subject+ , "authors" .= as+ ]++-- | @since 0.1.0.0+instance FromJSON GitDetails where+ parseJSON =+ withObject "GitDetails" $ \o ->+ GitDetails+ <$> o .: "hash"+ <*> o .: "hashShort"+ <*> o .: "authorName"+ <*> o .: "authorEmail"+ <*> o .: "authorTime"+ <*> o .: "committerName"+ <*> o .: "committerEmail"+ <*> o .: "commitTime"+ <*> o .: "subject"+ <*> o .: "authors"++-- | @since 0.1.0.0+instance Field1 GitDetails GitDetails String String++-- | @since 0.1.0.0+instance Field2 GitDetails GitDetails String String++-- | @since 0.1.0.0+instance Field3 GitDetails GitDetails String String++-- | @since 0.1.0.0+instance Field4 GitDetails GitDetails String String++-- | @since 0.1.0.0+instance Field5 GitDetails GitDetails UTCTime UTCTime++-- | @since 0.1.0.0+instance Field6 GitDetails GitDetails String String++-- | @since 0.1.0.0+instance Field7 GitDetails GitDetails String String++-- | @since 0.1.0.0+instance Field8 GitDetails GitDetails UTCTime UTCTime++-- | @since 0.1.0.0+instance Field9 GitDetails GitDetails String String++-- | @since 0.1.0.0+instance Field10 GitDetails GitDetails [String] [String]++-- | @since 0.1.0.0+gitCommitHash :: Lens' GitDetails String+gitCommitHash =+ _1+{-# INLINE gitCommitHash #-}++-- | @since 0.1.0.0+gitCommitHashShort :: Lens' GitDetails String+gitCommitHashShort =+ _2+{-# INLINE gitCommitHashShort #-}++-- | @since 0.1.0.0+gitAuthorName :: Lens' GitDetails String+gitAuthorName =+ _3+{-# INLINE gitAuthorName #-}++-- | @since 0.1.0.0+gitAuthorEmail :: Lens' GitDetails String+gitAuthorEmail =+ _4+{-# INLINE gitAuthorEmail #-}++-- | @since 0.1.0.0+gitAuthorTime :: Lens' GitDetails UTCTime+gitAuthorTime =+ _5+{-# INLINE gitAuthorTime #-}++-- | @since 0.1.0.0+gitCommitterName :: Lens' GitDetails String+gitCommitterName =+ _6+{-# INLINE gitCommitterName #-}++-- | @since 0.1.0.0+gitCommitterEmail :: Lens' GitDetails String+gitCommitterEmail =+ _7+{-# INLINE gitCommitterEmail #-}++-- | @since 0.1.0.0+gitCommitTime :: Lens' GitDetails UTCTime+gitCommitTime =+ _8+{-# INLINE gitCommitTime #-}++-- | @since 0.1.0.0+gitSubject :: Lens' GitDetails String+gitSubject =+ _9+{-# INLINE gitSubject #-}++-- | @since 0.1.0.0+gitAuthors :: Lens' GitDetails [String]+gitAuthors =+ _10+{-# INLINE gitAuthors #-}++{- | The @git log@ format that 'parseGitLog' reads: fields separated by NUL.++@since 0.1.0.0+-}+gitLogFormat :: String+gitLogFormat =+ "%H%x00%h%x00%aN%x00%aE%x00%at%x00%cN%x00%cE%x00%ct%x00%s"++{- | Parse the output of @git log -n 1@ with 'gitLogFormat', and the authors.++>>> let d = parseGitLog "0123abcd\NUL0123\NULTony\NULtony@example.com\NUL0\NULTony\NULtony@example.com\NUL86400\NULfix typo\n" ["Tony <tony@example.com>"]+>>> d ^? _Just . gitSubject+Just "fix typo"++>>> fmap (formatTimeUtc . (^. gitCommitTime)) d+Just "1970-01-02 00:00:00 UTC"++>>> parseGitLog "" []+Nothing++@since 0.1.0.0+-}+parseGitLog :: String -> [String] -> Maybe GitDetails+parseGitLog s as =+ let time = fmap (posixSecondsToUTCTime . fromInteger) . readMaybe+ in case splitOn '\NUL' (takeWhile (/= '\n') s) of+ [h, h', an, ae, at, cn, ce, ct, subject] ->+ (\at' ct' -> GitDetails h h' an ae at' cn ce ct' subject as) <$> time at <*> time ct+ _ -> Nothing++splitOn :: Char -> String -> [String]+splitOn c s =+ case break (== c) s of+ (a, []) -> [a]+ (a, _ : r) -> a : splitOn c r++{- | Details of the last commit to change the file or directory being operated+on, from @git log@. Fails with 'FileNotInGit' if no commit has changed it, and+with 'ShallowRepository' if the git history is shallow (see 'gitLastCommit').++@since 0.1.0.0+-}+gitDetails :: (ReviewBuildError e) => Command e GitDetails+gitDetails =+ do+ p <- ask+ gitLastCommit >>= maybe (lift (failBuild (FileNotInGit p))) pure++{- | Details of the last commit to change the file or directory being operated+on, from @git log@, or 'Nothing' if no commit has changed it, such as a file+that has not been committed.++Fails with 'ShallowRepository' if the git history is shallow, such as a clone+in GitLab CI without @GIT_DEPTH: 0@: the last commit to change a file is not+known if it is older than the history, and the authors are not all known.++@since 0.1.0.0+-}+gitLastCommit :: (ReviewBuildError e) => Command e (Maybe GitDetails)+gitLastCommit =+ do+ p <- ask+ isDirectory <- lift (io (doesDirectoryExist p))+ let (d, f) = bool (takeDirectory p, takeFileName p) (p, ".") isDirectory+ c = CommandLine "git" ["-C", d, "log", "-n", "1", "--format=" <> gitLogFormat, "--", f]+ shallow <- lift (process (CommandLine "git" ["-C", d, "rev-parse", "--is-shallow-repository"]))+ o <-+ lift $+ bool+ (process c)+ (failBuild (ShallowRepository d))+ (takeWhile (/= '\n') shallow == "true")+ if null o+ then pure Nothing+ else do+ as <- lift (process (CommandLine "git" ["-C", d, "log", "--format=%aN <%aE>", "--", f]))+ lift (maybe (failBuild (ProcessOutputUnrecognised c ("fields in the format " <> gitLogFormat))) (pure . Just) (parseGitLog o (nubOrd (lines as))))++{- | Placeholders and their values for the details of a commit, to use with+'Document.Build.Replace.replaceStrings'.++>>> fmap fst (gitPlaceholders (GitDetails "" "" "" "" (read "1970-01-01 00:00:00 UTC") "" "" (read "1970-01-01 00:00:00 UTC") "" []))+["${GIT_COMMIT_HASH}","${GIT_COMMIT_HASH_SHORT}","${GIT_AUTHOR_NAME}","${GIT_AUTHOR_EMAIL}","${GIT_AUTHOR_TIME}","${GIT_COMMITTER_NAME}","${GIT_COMMITTER_EMAIL}","${GIT_COMMIT_TIME}","${GIT_SUBJECT}","${GIT_AUTHORS}"]++@since 0.1.0.0+-}+gitPlaceholders :: GitDetails -> [(String, String)]+gitPlaceholders (GitDetails h h' an ae at cn ce ct subject as) =+ [ ("${GIT_COMMIT_HASH}", h)+ , ("${GIT_COMMIT_HASH_SHORT}", h')+ , ("${GIT_AUTHOR_NAME}", an)+ , ("${GIT_AUTHOR_EMAIL}", ae)+ , ("${GIT_AUTHOR_TIME}", formatTimeUtc at)+ , ("${GIT_COMMITTER_NAME}", cn)+ , ("${GIT_COMMITTER_EMAIL}", ce)+ , ("${GIT_COMMIT_TIME}", formatTimeUtc ct)+ , ("${GIT_SUBJECT}", subject)+ , ("${GIT_AUTHORS}", intercalate ", " as)+ ]++{- | Format a time in UTC, as @YYYY-MM-DD HH:MM:SS UTC@.++>>> formatTimeUtc (read "2026-10-09 01:02:03 UTC")+"2026-10-09 01:02:03 UTC"++@since 0.1.0.0+-}+formatTimeUtc :: UTCTime -> String+formatTimeUtc =+ formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S %Z"+{-# INLINE formatTimeUtc #-}++{- | The files in the git index of the directory being operated on, in the+form of 'System.FilePather.Combinators.directoryFiles'.++@since 0.1.0.0+-}+gitFiles :: (ReviewBuildError e) => Command e [FilePath]+gitFiles =+ do+ d <- ask+ o <- lift (process (CommandLine "git" ["-C", d, "ls-files", "-z"]))+ pure (fmap (normalise . (d </>)) (filter (not . null) (splitOn '\NUL' o)))++-- | @since 0.1.0.0+class GetGitDetails s where+ getGitDetails :: Getter s GitDetails++-- | @since 0.1.0.0+instance GetGitDetails GitDetails where+ getGitDetails =+ id+ {-# INLINE getGitDetails #-}++-- | @since 0.1.0.0+class (GetGitDetails s) => HasGitDetails s where+ {-# MINIMAL setGitDetails #-}+ setGitDetails :: GitDetails -> s -> s++ gitDetailsLens :: Lens' s GitDetails+ gitDetailsLens =+ lens (view getGitDetails) (flip setGitDetails)+ {-# INLINE gitDetailsLens #-}++-- | @since 0.1.0.0+instance HasGitDetails GitDetails where+ setGitDetails =+ const+ {-# INLINE setGitDetails #-}++-- | @since 0.1.0.0+class ReviewGitDetails t where+ reviewGitDetails :: Review t GitDetails++-- | @since 0.1.0.0+instance ReviewGitDetails GitDetails where+ reviewGitDetails =+ unto id+ {-# INLINE reviewGitDetails #-}++-- | @since 0.1.0.0+class (ReviewGitDetails t) => AsGitDetails t where+ {-# MINIMAL matchGitDetails #-}+ matchGitDetails :: t -> Maybe GitDetails++ _GitDetails :: Prism' t GitDetails+ _GitDetails =+ prism' (review reviewGitDetails) matchGitDetails+ {-# INLINE _GitDetails #-}++-- | @since 0.1.0.0+instance AsGitDetails GitDetails where+ matchGitDetails =+ Just+ {-# INLINE matchGitDetails #-}
+ src/Document/Build/Hash.hs view
@@ -0,0 +1,44 @@+{-# OPTIONS_GHC -Wall #-}++-- | Commands that compute hashes of files.+module Document.Build.Hash (+ sha256,+ sha256Hex,+) where++import Control.Monad.Trans.Class (lift)+import qualified Crypto.Hash.SHA256 as SHA256+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Lazy as LazyByteString+import Document.Build.Build (Command, io, requireInput)+import Document.Build.Error (ReviewBuildError)+import Numeric (showHex)++{- $setup+>>> import qualified Data.ByteString.Lazy.Char8 as Char8+-}++{- | The SHA-256 hash of the file being operated on, in lower-case+hexadecimal, as printed by @sha256sum@.++@since 0.1.0.0+-}+sha256 :: (ReviewBuildError e) => Command e String+sha256 =+ do+ i <- requireInput+ lift (io (sha256Hex <$> LazyByteString.readFile i))++{- | The SHA-256 hash of a byte string, in lower-case hexadecimal.++>>> sha256Hex (Char8.pack "abc")+"ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad"++>>> sha256Hex LazyByteString.empty+"e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"++@since 0.1.0.0+-}+sha256Hex :: LazyByteString.ByteString -> String+sha256Hex =+ ByteString.foldr (\w s -> let h = showHex w s in if w < 16 then '0' : h else h) "" . SHA256.hashlazy
+ src/Document/Build/Image.hs view
@@ -0,0 +1,338 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}++{- | Commands that operate on images, with ImageMagick (@identify@ and+@convert@).+-}+module Document.Build.Image (+ -- * Information+ ImageInfo (..),+ imageFormat,+ imageWidth,+ imageHeight,+ imageResolutionX,+ imageResolutionY,+ imageResolutionUnits,+ imageColourspace,+ imageDepth,+ imageFrames,+ imageInfo,+ parseImageInfo,+ GetImageInfo (..),+ HasImageInfo (..),+ ReviewImageInfo (..),+ AsImageInfo (..),++ -- * Conversion+ imageConvert,+ imageConvertWith,+ imageConvertFirstFrame,+ imageResize,+ imageAppend,+) where++import Control.DeepSeq (NFData)+import Control.Lens (Field1, Field2, Field3, Field4, Field5, Field6, Field7, Field8, Field9, Getter, Lens', Prism', Review, lens, prism', review, unto, view, _1, _2, _3, _4, _5, _6, _7, _8, _9, _Wrapped)+import Control.Monad.Trans.Class (lift)+import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.=))+import Data.Data (Data)+import Document.Build.Build (Command, createParentDirectory, expectOutput, failBuild, process, requireDirectory, requireInput)+import Document.Build.Error (BuildError (..), CommandLine (..), ReviewBuildError)+import GHC.Generics (Generic)+import System.FilePath ((</>))+import Text.Read (readMaybe)++{- $setup+>>> import Control.Lens ((^.))+-}++{- | Information about an image: its format (such as @"PNG"@), width and+height in pixels, horizontal and vertical resolution, the units of the+resolution (such as @"PixelsPerInch"@ or @"Undefined"@), colourspace (such as+@"sRGB"@), bit depth, and number of frames.++@since 0.1.0.0+-}+data ImageInfo+ = ImageInfo String Int Int Double Double String String Int Int+ deriving stock (Eq, Ord, Show, Generic, Data)+ deriving anyclass (NFData)++-- | @since 0.1.0.0+instance ToJSON ImageInfo where+ toJSON (ImageInfo m w h x y u c z n) =+ object+ [ "format" .= m+ , "width" .= w+ , "height" .= h+ , "resolutionX" .= x+ , "resolutionY" .= y+ , "resolutionUnits" .= u+ , "colourspace" .= c+ , "depth" .= z+ , "frames" .= n+ ]++-- | @since 0.1.0.0+instance FromJSON ImageInfo where+ parseJSON =+ withObject "ImageInfo" $ \o ->+ ImageInfo+ <$> o .: "format"+ <*> o .: "width"+ <*> o .: "height"+ <*> o .: "resolutionX"+ <*> o .: "resolutionY"+ <*> o .: "resolutionUnits"+ <*> o .: "colourspace"+ <*> o .: "depth"+ <*> o .: "frames"++-- | @since 0.1.0.0+instance Field1 ImageInfo ImageInfo String String++-- | @since 0.1.0.0+instance Field2 ImageInfo ImageInfo Int Int++-- | @since 0.1.0.0+instance Field3 ImageInfo ImageInfo Int Int++-- | @since 0.1.0.0+instance Field4 ImageInfo ImageInfo Double Double++-- | @since 0.1.0.0+instance Field5 ImageInfo ImageInfo Double Double++-- | @since 0.1.0.0+instance Field6 ImageInfo ImageInfo String String++-- | @since 0.1.0.0+instance Field7 ImageInfo ImageInfo String String++-- | @since 0.1.0.0+instance Field8 ImageInfo ImageInfo Int Int++-- | @since 0.1.0.0+instance Field9 ImageInfo ImageInfo Int Int++-- | @since 0.1.0.0+imageFormat :: Lens' ImageInfo String+imageFormat =+ _1+{-# INLINE imageFormat #-}++-- | @since 0.1.0.0+imageWidth :: Lens' ImageInfo Int+imageWidth =+ _2+{-# INLINE imageWidth #-}++-- | @since 0.1.0.0+imageHeight :: Lens' ImageInfo Int+imageHeight =+ _3+{-# INLINE imageHeight #-}++-- | @since 0.1.0.0+imageResolutionX :: Lens' ImageInfo Double+imageResolutionX =+ _4+{-# INLINE imageResolutionX #-}++-- | @since 0.1.0.0+imageResolutionY :: Lens' ImageInfo Double+imageResolutionY =+ _5+{-# INLINE imageResolutionY #-}++-- | @since 0.1.0.0+imageResolutionUnits :: Lens' ImageInfo String+imageResolutionUnits =+ _6+{-# INLINE imageResolutionUnits #-}++-- | @since 0.1.0.0+imageColourspace :: Lens' ImageInfo String+imageColourspace =+ _7+{-# INLINE imageColourspace #-}++-- | @since 0.1.0.0+imageDepth :: Lens' ImageInfo Int+imageDepth =+ _8+{-# INLINE imageDepth #-}++-- | @since 0.1.0.0+imageFrames :: Lens' ImageInfo Int+imageFrames =+ _9+{-# INLINE imageFrames #-}++-- | The @identify@ format that 'parseImageInfo' reads.+identifyFormat :: String+identifyFormat =+ "%m\\n%w\\n%h\\n%x\\n%y\\n%U\\n%[colorspace]\\n%z\\n%n\\n"++{- | Information about the image being operated on, from its first frame,+using @identify@.++@since 0.1.0.0+-}+imageInfo :: (ReviewBuildError e) => Command e ImageInfo+imageInfo =+ do+ i <- requireInput+ let c = CommandLine "identify" ["-format", identifyFormat, i <> "[0]"]+ o <- lift (process c)+ maybe+ (lift (failBuild (ProcessOutputUnrecognised c "image format, width, height, resolution, units, colourspace, depth and frames")))+ pure+ (parseImageInfo o)++{- | Parse the output of @identify@ with the format+@%m\\n%w\\n%h\\n%x\\n%y\\n%U\\n%[colorspace]\\n%z\\n%n\\n@. A resolution may+be followed by its units, which are ignored.++>>> fmap (^. imageWidth) (parseImageInfo "PNG\n3384\n262\n72\n72\nUndefined\nsRGB\n8\n1\n")+Just 3384++>>> parseImageInfo "PNG\n3384\n262\n72 PixelsPerInch\n72 PixelsPerInch\nPixelsPerInch\nsRGB\n8\n1\n"+Just (ImageInfo "PNG" 3384 262 72.0 72.0 "PixelsPerInch" "sRGB" 8 1)++>>> parseImageInfo "PNG\n"+Nothing++@since 0.1.0.0+-}+parseImageInfo :: String -> Maybe ImageInfo+parseImageInfo s =+ let number :: (Read a) => String -> Maybe a+ number x =+ case words x of+ (n : _) -> readMaybe n+ [] -> Nothing+ in case lines s of+ (m : w : h : x : y : u : c : z : n : _) ->+ ImageInfo m <$> number w <*> number h <*> number x <*> number y <*> pure u <*> pure c <*> number z <*> number n+ _ -> Nothing++-- | @since 0.1.0.0+class GetImageInfo s where+ getImageInfo :: Getter s ImageInfo++-- | @since 0.1.0.0+instance GetImageInfo ImageInfo where+ getImageInfo =+ id+ {-# INLINE getImageInfo #-}++-- | @since 0.1.0.0+class (GetImageInfo s) => HasImageInfo s where+ {-# MINIMAL setImageInfo #-}+ setImageInfo :: ImageInfo -> s -> s++ imageInfoLens :: Lens' s ImageInfo+ imageInfoLens =+ lens (view getImageInfo) (flip setImageInfo)+ {-# INLINE imageInfoLens #-}++-- | @since 0.1.0.0+instance HasImageInfo ImageInfo where+ setImageInfo =+ const+ {-# INLINE setImageInfo #-}++-- | @since 0.1.0.0+class ReviewImageInfo t where+ reviewImageInfo :: Review t ImageInfo++-- | @since 0.1.0.0+instance ReviewImageInfo ImageInfo where+ reviewImageInfo =+ unto id+ {-# INLINE reviewImageInfo #-}++-- | @since 0.1.0.0+class (ReviewImageInfo t) => AsImageInfo t where+ {-# MINIMAL matchImageInfo #-}+ matchImageInfo :: t -> Maybe ImageInfo++ _ImageInfo :: Prism' t ImageInfo+ _ImageInfo =+ prism' (review reviewImageInfo) matchImageInfo+ {-# INLINE _ImageInfo #-}++-- | @since 0.1.0.0+instance AsImageInfo ImageInfo where+ matchImageInfo =+ Just+ {-# INLINE matchImageInfo #-}++{- | Convert the image being operated on to a file path, with the format given+by its extension, and return the file path.++@since 0.1.0.0+-}+imageConvert :: (ReviewBuildError e) => FilePath -> Command e FilePath+imageConvert =+ imageConvertWith []+{-# INLINE imageConvert #-}++{- | Convert the image being operated on with @convert@ and options that+follow the input file, writing to a file path, and return the file path.++@since 0.1.0.0+-}+imageConvertWith :: (ReviewBuildError e) => [String] -> FilePath -> Command e FilePath+imageConvertWith opts o =+ do+ i <- requireInput+ let c = CommandLine "convert" ([i] <> opts <> [o])+ lift (createParentDirectory o *> process c *> expectOutput c o)++{- | Convert the first frame of the image being operated on with @convert@+and options that follow the input file, writing to a file path, and return+the file path. Unlike 'imageConvertWith', an image with more than one frame,+such as an animated GIF, produces one file.++@since 0.1.0.0+-}+imageConvertFirstFrame :: (ReviewBuildError e) => [String] -> FilePath -> Command e FilePath+imageConvertFirstFrame opts o =+ do+ i <- requireInput+ let c = CommandLine "convert" ([i <> "[0]"] <> opts <> [o])+ lift (createParentDirectory o *> process c *> expectOutput c o)++{- | Resize the image being operated on to fit within a square of a number of+pixels, keeping its aspect ratio, writing to a file path, and return the file+path.++@since 0.1.0.0+-}+imageResize :: (ReviewBuildError e) => Int -> FilePath -> Command e FilePath+imageResize n =+ imageConvertWith ["-resize", show n <> "x" <> show n]+{-# INLINE imageResize #-}++{- | Join images in the directory being operated on, given by their paths+relative to it, side by side, from left to right, into a file path, and+return the file path.++@since 0.1.0.0+-}+imageAppend :: (ReviewBuildError e) => [FilePath] -> FilePath -> Command e FilePath+imageAppend fs o =+ do+ d <- requireDirectory+ let is = fmap (d </>) fs+ c = CommandLine "convert" (is <> ["+append", o])+ _ <- lift (traverse (view _Wrapped requireInput) is)+ lift (createParentDirectory o *> process c *> expectOutput c o)
+ src/Document/Build/LibreOffice.hs view
@@ -0,0 +1,197 @@+{-# OPTIONS_GHC -Wall #-}++{- | Commands that operate on LibreOffice files, and other files that+LibreOffice can open, such as @.docx@.++These run @soffice@ with a LibreOffice profile of their own, in the temporary+directory. Without it, a conversion does nothing when LibreOffice is already+open.+-}+module Document.Build.LibreOffice (+ -- * Conversion+ libreoffice,+ libreofficeOutput,+ libreofficeToPdf,+ libreofficeToHtml,+ libreofficeToDocx,+ libreofficeToOdt,+ libreofficeFlat,+ libreofficeZipped,+ flatExtension,+ zippedExtension,++ -- * Information+ libreofficePages,+ docxPages,+) where++import Control.Lens (view, _Wrapped)+import Control.Monad.Trans.Class (lift)+import Data.Bool (bool)+import Document.Build.Build (Build, Command, expectOutput, failBuild, io, process, requireInput, withTempDirectory)+import Document.Build.Error (BuildError (..), CommandLine (..), ReviewBuildError)+import Document.Build.Pdf (pdfPages)+import System.Directory (createDirectoryIfMissing, getTemporaryDirectory, makeAbsolute, removePathForcibly)+import System.FilePath (equalFilePath, takeBaseName, takeExtension, (<.>), (</>))+import System.FilePather.Combinators ((~>))++{- | Convert the file being operated on with @soffice --convert-to@, into a+directory, and return the file path of the result.++The format is any that @--convert-to@ accepts, such as @"pdf"@, @"html"@,+@"docx"@, @"png"@ or @"txt:Text"@. The output file is named after the input+file, with the extension before any @:@ in the format. LibreOffice exits+successfully even when a conversion fails, so the build fails with+'OutputFileMissing' if the output file is not produced.++@since 0.1.0.0+-}+libreoffice :: (ReviewBuildError e) => String -> FilePath -> Command e FilePath+libreoffice fmt d =+ do+ i <- requireInput+ lift $+ do+ p <- libreofficeProfile+ let o = libreofficeOutput fmt d i+ c = CommandLine "soffice" ["-env:UserInstallation=" <> p, "--invisible", "--headless", "--convert-to", fmt, "--outdir", d, i]+ io (createDirectoryIfMissing True d)+ -- Remove the output of an earlier build, so that a conversion that+ -- fails is not mistaken for one that succeeds.+ io (bool (removePathForcibly o) (pure ()) (equalFilePath i o))+ _ <- process c+ expectOutput c o++{- | The file that 'libreoffice' converts a file to, given the format, the+output directory and the input file.++>>> libreofficeOutput "txt:Text" "public" "src/report.fodt"+"public/report.txt"++@since 0.1.0.0+-}+libreofficeOutput :: String -> FilePath -> FilePath -> FilePath+libreofficeOutput fmt d i =+ d </> takeBaseName i <.> takeWhile (/= ':') fmt++-- | The URL of the LibreOffice profile that 'libreoffice' uses.+libreofficeProfile :: Build e String+libreofficeProfile =+ io (fmap ("file://" <>) (getTemporaryDirectory >>= makeAbsolute . (</> "document-build-libreoffice")))++{- | Convert the file being operated on to PDF, into a directory. See+'libreoffice'.++@since 0.1.0.0+-}+libreofficeToPdf :: (ReviewBuildError e) => FilePath -> Command e FilePath+libreofficeToPdf =+ libreoffice "pdf"+{-# INLINE libreofficeToPdf #-}++{- | Convert the file being operated on to HTML, into a directory. See+'libreoffice'.++@since 0.1.0.0+-}+libreofficeToHtml :: (ReviewBuildError e) => FilePath -> Command e FilePath+libreofficeToHtml =+ libreoffice "html"+{-# INLINE libreofficeToHtml #-}++{- | Convert the file being operated on to Word, into a directory. See+'libreoffice'.++@since 0.1.0.0+-}+libreofficeToDocx :: (ReviewBuildError e) => FilePath -> Command e FilePath+libreofficeToDocx =+ libreoffice "docx"+{-# INLINE libreofficeToDocx #-}++{- | Convert the file being operated on to OpenDocument text, into a+directory. See 'libreoffice'.++@since 0.1.0.0+-}+libreofficeToOdt :: (ReviewBuildError e) => FilePath -> Command e FilePath+libreofficeToOdt =+ libreoffice "odt"+{-# INLINE libreofficeToOdt #-}++{- | The extension of the flat (XML) form of a zipped OpenDocument extension.++>>> flatExtension "odt"+Just "fodt"++>>> flatExtension "docx"+Nothing++@since 0.1.0.0+-}+flatExtension :: String -> Maybe String+flatExtension =+ flip lookup [("odt", "fodt"), ("ods", "fods"), ("odp", "fodp"), ("odg", "fodg")]++{- | The extension of the zipped form of a flat (XML) OpenDocument extension.++>>> zippedExtension "fods"+Just "ods"++@since 0.1.0.0+-}+zippedExtension :: String -> Maybe String+zippedExtension =+ flip lookup [("fodt", "odt"), ("fods", "ods"), ("fodp", "odp"), ("fodg", "odg")]++convertExtension :: (ReviewBuildError e) => (String -> Maybe String) -> [String] -> FilePath -> Command e FilePath+convertExtension f supported d =+ do+ i <- requireInput+ maybe+ (lift (failBuild (FileTypeUnsupported i supported)))+ (`libreoffice` d)+ (f (drop 1 (takeExtension i)))++{- | Convert the zipped OpenDocument file being operated on (@.odt@, @.ods@,+@.odp@ or @.odg@) to its flat form (@.fodt@, @.fods@, @.fodp@ or @.fodg@),+into a directory. Fails with 'FileTypeUnsupported' for other files.++@since 0.1.0.0+-}+libreofficeFlat :: (ReviewBuildError e) => FilePath -> Command e FilePath+libreofficeFlat =+ convertExtension flatExtension ["odt", "ods", "odp", "odg"]+{-# INLINE libreofficeFlat #-}++{- | Convert the flat OpenDocument file being operated on (@.fodt@, @.fods@,+@.fodp@ or @.fodg@) to its zipped form (@.odt@, @.ods@, @.odp@ or @.odg@),+into a directory. Fails with 'FileTypeUnsupported' for other files.++@since 0.1.0.0+-}+libreofficeZipped :: (ReviewBuildError e) => FilePath -> Command e FilePath+libreofficeZipped =+ convertExtension zippedExtension ["fodt", "fods", "fodp", "fodg"]+{-# INLINE libreofficeZipped #-}++{- | The number of pages in the file being operated on, as laid out by+LibreOffice. The file is converted to PDF in a temporary directory.++@since 0.1.0.0+-}+libreofficePages :: (ReviewBuildError e) => Command e Int+libreofficePages =+ do+ i <- requireInput+ lift (withTempDirectory "libreoffice-pages" (\d -> view _Wrapped (libreofficeToPdf d ~> pdfPages) i))++{- | The number of pages in the Word file being operated on. See+'libreofficePages'.++@since 0.1.0.0+-}+docxPages :: (ReviewBuildError e) => Command e Int+docxPages =+ libreofficePages+{-# INLINE docxPages #-}
+ src/Document/Build/Operations.hs view
@@ -0,0 +1,59 @@+{-# OPTIONS_GHC -Wall #-}++{- | The canonical document operations: every one a+'System.FilePather.FilePather' value in 'Document.Build.Build.Build', or a+function that returns one, with nothing project-specific in it.++* the number of pages of a PDF file: 'pdfPages', 'pdfPageCountFile'+* the number of pages of a LibreOffice file: 'libreofficePages'+* the number of pages of a Word file: 'docxPages'+* a markdown file to PDF, HTML, Word and OpenDocument: 'markdownToPdf',+ 'markdownToHtml', 'markdownToDocx', 'markdownToOdt', 'pandoc'+* a PDF file to an image of each page, as JPEG, PNG, GIF or SVG:+ 'pdfToJpg', 'pdfToPng', 'pdfToGif', 'pdfToSvg', 'pdfToImages'+* the SHA-256 hash of a file: 'sha256'+* page 1 of a PDF file, or other pages: 'pdfFirstPage', 'pdfPage',+ 'pdfSelect'+* a zipped LibreOffice file (@.odt@, @.ods@, @.odp@, @.odg@) to its flat+ form (@.fodt@, @.fods@, @.fodp@, @.fodg@), and back: 'libreofficeFlat',+ 'libreofficeZipped'+* a PDF file split into several PDF files: 'pdfSplit', 'pdfBurst'+* the git details of a file, ready to insert into a file: 'gitDetails',+ 'gitPlaceholders'+* each first string replaced with the second in a file: 'replaceStrings'+* the format, width, height and other details of an image: 'imageInfo'+* the PDF files of a directory joined into one PDF file: 'pdfJoin',+ 'pdfConcatenate', 'pdftk'+* images of a directory joined side by side: 'imageAppend'+* an assertion that a file or directory exists: 'requireInput',+ 'requireDirectory', 'requirePath'++An operation that takes several input files takes the directory they are in+as its file path, and their paths relative to it.+-}+module Document.Build.Operations (+ -- * Assertions+ requireInput,+ requireDirectory,+ requirePath,++ -- * Kinds of file+ module Document.Build.Pdf,+ module Document.Build.LibreOffice,+ module Document.Build.Pandoc,+ module Document.Build.Image,+ module Document.Build.Hash,+ module Document.Build.Git,+ module Document.Build.Replace,+ module Document.Build.File,+) where++import Document.Build.Build (requireDirectory, requireInput, requirePath)+import Document.Build.File+import Document.Build.Git+import Document.Build.Hash+import Document.Build.Image+import Document.Build.LibreOffice+import Document.Build.Pandoc+import Document.Build.Pdf+import Document.Build.Replace
+ src/Document/Build/Output.hs view
@@ -0,0 +1,359 @@+{-# 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"
+ src/Document/Build/Pandoc.hs view
@@ -0,0 +1,82 @@+{-# OPTIONS_GHC -Wall #-}++-- | Commands that convert documents with @pandoc@.+module Document.Build.Pandoc (+ pandoc,+ xelatex,+ markdownToPdf,+ markdownToHtml,+ markdownToDocx,+ markdownToOdt,+) where++import Control.Monad.Trans.Class (lift)+import Document.Build.Build (Command, createParentDirectory, expectOutput, process, requireInput)+import Document.Build.Error (CommandLine (..), ReviewBuildError)+import System.FilePath (takeBaseName, (<.>), (</>))++{- | Convert the file being operated on with @pandoc@ and its options, writing+to a file path, and return the file path. Unless the options say otherwise,+pandoc chooses the output format from the extension of the file path.++@since 0.1.0.0+-}+pandoc :: (ReviewBuildError e) => [String] -> FilePath -> Command e FilePath+pandoc opts o =+ do+ i <- requireInput+ let c = CommandLine "pandoc" (opts <> [i, "-o", o])+ lift (createParentDirectory o *> process c *> expectOutput c o)++{- | The option to produce PDF with XeLaTeX, which supports Unicode and system+fonts, such as with @-M mainfont=...@.++@since 0.1.0.0+-}+xelatex :: [String]+xelatex =+ ["--pdf-engine=xelatex"]++markdownTo :: (ReviewBuildError e) => [String] -> String -> [String] -> FilePath -> Command e FilePath+markdownTo base ext opts d =+ requireInput >>= \i -> pandoc (base <> opts) (d </> takeBaseName i <.> ext)++{- | Convert the markdown file being operated on to PDF, with 'xelatex' and+pandoc options, into a directory.++@since 0.1.0.0+-}+markdownToPdf :: (ReviewBuildError e) => [String] -> FilePath -> Command e FilePath+markdownToPdf =+ markdownTo xelatex "pdf"+{-# INLINE markdownToPdf #-}++{- | Convert the markdown file being operated on to HTML, with pandoc+options, into a directory.++@since 0.1.0.0+-}+markdownToHtml :: (ReviewBuildError e) => [String] -> FilePath -> Command e FilePath+markdownToHtml =+ markdownTo [] "html"+{-# INLINE markdownToHtml #-}++{- | Convert the markdown file being operated on to Word, with pandoc options,+into a directory.++@since 0.1.0.0+-}+markdownToDocx :: (ReviewBuildError e) => [String] -> FilePath -> Command e FilePath+markdownToDocx =+ markdownTo [] "docx"+{-# INLINE markdownToDocx #-}++{- | Convert the markdown file being operated on to OpenDocument text, with+pandoc options, into a directory.++@since 0.1.0.0+-}+markdownToOdt :: (ReviewBuildError e) => [String] -> FilePath -> Command e FilePath+markdownToOdt =+ markdownTo [] "odt"+{-# INLINE markdownToOdt #-}
+ src/Document/Build/Pdf.hs view
@@ -0,0 +1,314 @@+{-# OPTIONS_GHC -Wall #-}++{- | Commands that operate on PDF files.++These run @pdfinfo@ (poppler-utils), @pdftk@, @pdftocairo@ (poppler-utils)+and @convert@ (ImageMagick).+-}+module Document.Build.Pdf (+ -- * Information+ pdfPages,+ pdfPageCountFile,+ parsePdfinfoPages,++ -- * Pages+ pdfSelect,+ pdfPage,+ pdfFirstPage,+ pdfSplit,+ pdfBurst,+ pdfJoin,+ pdfConcatenate,+ pdftk,++ -- * Images+ pdfToImages,+ pdfToPng,+ pdfToJpg,+ pdfToGif,+ pdfToSvg,+ pdfToSvgImages,+ pageImagePaths,+) where++import Control.Lens (preview, view, _Wrapped, _head)+import Control.Monad.Trans.Class (lift)+import Data.List (sort)+import Data.Maybe (mapMaybe)+import qualified Data.Text as Text+import Document.Build.Build (Command, createParentDirectory, expectOutput, failBuild, io, process, processIn, requireDirectory, requireInput)+import Document.Build.Error (BuildError (..), CommandLine (..), ReviewBuildError)+import Document.Build.File (writeUtf8)+import System.Directory (createDirectoryIfMissing, doesFileExist, listDirectory, makeAbsolute, removePathForcibly)+import System.FilePath (equalFilePath, splitExtension, takeBaseName, takeDirectory, takeFileName, (<.>), (</>))+import System.FilePather.Combinators (hasExtension, onFile)+import Text.Read (readMaybe)++{- | The number of pages in the PDF file being operated on, using @pdfinfo@.++@since 0.1.0.0+-}+pdfPages :: (ReviewBuildError e) => Command e Int+pdfPages =+ do+ i <- requireInput+ let c = CommandLine "pdfinfo" [i]+ o <- lift (process c)+ maybe+ (lift (failBuild (ProcessOutputUnrecognised c "a line \"Pages: <number>\"")))+ pure+ (parsePdfinfoPages o)++{- | Write the number of pages in the PDF file being operated on to a file+path, and return the file path.++@since 0.1.0.0+-}+pdfPageCountFile :: (ReviewBuildError e) => FilePath -> Command e FilePath+pdfPageCountFile o =+ pdfPages >>= lift . writeUtf8 o . Text.pack . show++{- | The number of pages in the output of @pdfinfo@.++>>> parsePdfinfoPages "Creator: Writer\nPages: 3\nEncrypted: no\n"+Just 3++>>> parsePdfinfoPages "Creator: Writer\n"+Nothing++@since 0.1.0.0+-}+parsePdfinfoPages :: String -> Maybe Int+parsePdfinfoPages =+ let pages l =+ case words l of+ ["Pages:", n] -> readMaybe n+ _ -> Nothing+ in preview _head . mapMaybe pages . lines++{- | Select pages from the PDF file being operated on, with a @pdftk@ page+range such as @"1"@, @"10-21"@, @"1-endodd"@ or @"1 3 5-end"@, writing them+to a file path, and return the file path.++@since 0.1.0.0+-}+pdfSelect :: (ReviewBuildError e) => String -> FilePath -> Command e FilePath+pdfSelect r o =+ do+ i <- requireInput+ onFile (takeDirectory i) (pdftk [takeFileName i, "cat"] (words r) o)++{- | Select one page, numbered from 1, from the PDF file being operated on.+See 'pdfSelect'.++@since 0.1.0.0+-}+pdfPage :: (ReviewBuildError e) => Int -> FilePath -> Command e FilePath+pdfPage n =+ pdfSelect (show n)+{-# INLINE pdfPage #-}++{- | Select the first page of the PDF file being operated on. See 'pdfSelect'.++@since 0.1.0.0+-}+pdfFirstPage :: (ReviewBuildError e) => FilePath -> Command e FilePath+pdfFirstPage =+ pdfPage 1+{-# INLINE pdfFirstPage #-}++{- | Split the PDF file being operated on into several files, given by a+@pdftk@ page range and a file path for each. See 'pdfSelect'.++@since 0.1.0.0+-}+pdfSplit :: (ReviewBuildError e) => [(String, FilePath)] -> Command e [FilePath]+pdfSplit =+ traverse (uncurry pdfSelect)+{-# INLINE pdfSplit #-}++{- | Split the PDF file being operated on into one file for each page, in a+directory, and return the file paths in page order. The file for page @n@,+numbered from 1, of @dir/name.pdf@ is @dir/name-n.pdf@.++@since 0.1.0.0+-}+pdfBurst :: (ReviewBuildError e) => FilePath -> Command e [FilePath]+pdfBurst d =+ do+ i <- requireInput+ n <- pdfPages+ lift $+ do+ io (createDirectoryIfMissing True d)+ i' <- io (makeAbsolute i)+ let b = takeBaseName i+ c = CommandLine "pdftk" [i', "burst", "output", b <> "-%d.pdf"]+ -- pdftk writes doc_data.txt to its working directory.+ _ <- processIn d c+ io (removePathForcibly (d </> "doc_data.txt"))+ traverse (\k -> expectOutput c (d </> b <> "-" <> show k <.> "pdf")) [1 .. n]++{- | Join the PDF files in the directory being operated on, in sorted order of+their names, into a file path, and return the file path. The directory must+have at least two PDF files, other than the output file, or the build fails+with 'InputFilesTooFew'. Files in subdirectories are not joined.++@since 0.1.0.0+-}+pdfJoin :: (ReviewBuildError e) => FilePath -> Command e FilePath+pdfJoin o =+ do+ d <- requireDirectory+ fs <-+ lift . io $+ do+ names <- sort . filter (hasExtension ["pdf"]) <$> listDirectory d+ files <- traverse (\n -> (\x -> [n | x]) <$> doesFileExist (d </> n)) names+ pure (concatMap (filter (not . equalFilePath o . (d </>))) files)+ if length fs < 2+ then lift (failBuild (InputFilesTooFew d (length fs) 2))+ else pdfConcatenate fs o++{- | Concatenate PDF files in the directory being operated on, given by their+paths relative to it, in order, into a file path, and return the file path.++@since 0.1.0.0+-}+pdfConcatenate :: (ReviewBuildError e) => [FilePath] -> FilePath -> Command e FilePath+pdfConcatenate fs o =+ do+ d <- requireDirectory+ _ <- lift (traverse (view _Wrapped requireInput . (d </>)) fs)+ pdftk fs ["cat"] o++{- | Run @pdftk@ in the directory being operated on, with input arguments and+operation arguments, then @output@ and a file path, and return the file path.+Input files are relative to the directory, and the output file path is not.+For example, to merge pages from two files in @public@:++@+'onFile' "public" (pdftk ["A=manual.pdf", "B=supplement.pdf", "cat"] ["A1-16", "B1", "A18-end"] "public/merged.pdf")+@++@since 0.1.0.0+-}+pdftk :: (ReviewBuildError e) => [String] -> [String] -> FilePath -> Command e FilePath+pdftk is os o =+ do+ d <- requireDirectory+ lift $+ do+ createParentDirectory o+ o' <- io (makeAbsolute o)+ let c = CommandLine "pdftk" (is <> os <> ["output", o'])+ _ <- processIn d c+ expectOutput c o++{- | Convert each page of the PDF file being operated on to an image, with+@convert@ and its options, and return the file paths of the images in page+order. The format of the images is given by the extension of the output file+path.++As with @convert@, a PDF file with one page produces the output file path,+and a PDF file with more than one page produces one file for each page,+numbered from 0, except for formats that hold more than one frame, such as+GIF. See 'pageImagePaths'.++@since 0.1.0.0+-}+pdfToImages :: (ReviewBuildError e) => [String] -> FilePath -> Command e [FilePath]+pdfToImages opts o =+ do+ i <- requireInput+ n <- pdfPages+ let c = CommandLine "convert" (opts <> [i, o])+ lift (createParentDirectory o *> process c *> traverse (expectOutput c) (pageImagePaths n o))++{- | The file paths of the images that @convert@ produces from a PDF file with+a number of pages. A format that holds more than one frame (GIF and TIFF)+produces one file, with a frame for each page.++>>> pageImagePaths 1 "public/report.pdf.png"+["public/report.pdf.png"]++>>> pageImagePaths 3 "public/report.pdf.png"+["public/report.pdf-0.png","public/report.pdf-1.png","public/report.pdf-2.png"]++>>> pageImagePaths 3 "public/report.pdf.gif"+["public/report.pdf.gif"]++@since 0.1.0.0+-}+pageImagePaths :: Int -> FilePath -> [FilePath]+pageImagePaths n o =+ let (b, e) = splitExtension o+ in if n == 1 || e `elem` [".gif", ".tif", ".tiff"]+ then [o]+ else fmap (\k -> b <> "-" <> show k <> e) [0 .. n - 1]++pdfToRaster :: (ReviewBuildError e) => String -> FilePath -> Command e [FilePath]+pdfToRaster ext d =+ requireInput >>= \i -> pdfToImages ["-density", "180"] (d </> takeBaseName i <.> ext)++{- | Convert each page of the PDF file being operated on to a PNG image, in a+directory, at 180 dots per inch. See 'pdfToImages'.++@since 0.1.0.0+-}+pdfToPng :: (ReviewBuildError e) => FilePath -> Command e [FilePath]+pdfToPng =+ pdfToRaster "png"+{-# INLINE pdfToPng #-}++{- | Convert each page of the PDF file being operated on to a JPEG image, in+a directory, at 180 dots per inch. See 'pdfToImages'.++@since 0.1.0.0+-}+pdfToJpg :: (ReviewBuildError e) => FilePath -> Command e [FilePath]+pdfToJpg =+ pdfToRaster "jpg"+{-# INLINE pdfToJpg #-}++{- | Convert each page of the PDF file being operated on to a GIF image, in a+directory, at 180 dots per inch. See 'pdfToImages'.++@since 0.1.0.0+-}+pdfToGif :: (ReviewBuildError e) => FilePath -> Command e [FilePath]+pdfToGif =+ pdfToRaster "gif"+{-# INLINE pdfToGif #-}++{- | Convert each page of the PDF file being operated on to an SVG image, in a+directory, with @pdftocairo@, and return the file paths in page order. See+'pdfToSvgImages'.++@since 0.1.0.0+-}+pdfToSvg :: (ReviewBuildError e) => FilePath -> Command e [FilePath]+pdfToSvg d =+ requireInput >>= \i -> pdfToSvgImages (d </> takeBaseName i <.> "svg")++{- | Convert each page of the PDF file being operated on to an SVG image, with+@pdftocairo@, and return the file paths in page order. The file paths follow+'pageImagePaths' for the output file path, as with 'pdfToImages'. Unlike+@convert@, @pdftocairo@ keeps text and vector graphics as vectors.++@since 0.1.0.0+-}+pdfToSvgImages :: (ReviewBuildError e) => FilePath -> Command e [FilePath]+pdfToSvgImages o =+ do+ i <- requireInput+ n <- pdfPages+ lift $+ do+ createParentDirectory o+ traverse+ ( \(k, p) ->+ let c = CommandLine "pdftocairo" ["-svg", "-f", show k, "-l", show k, i, p]+ in process c *> expectOutput c p+ )+ (zip [1 :: Int ..] (pageImagePaths n o))
+ src/Document/Build/Project.hs view
@@ -0,0 +1,278 @@+{-# OPTIONS_GHC -Wall #-}++{- | Steps for building a whole project: identifying it, replacing+placeholders in its files as they are prepared, and building with its fonts.++Placeholders such as @${NAME}@ come from environment variables (see+'environmentPlaceholders'), the same for every file, and from the last commit+to change each file (see 'filePlaceholders'), so that a document says when it+last changed. 'placeholderAliases' gives a placeholder the value of another.++A project is a directory, and the build runs with it as the working+directory, so file paths are relative to it, such as @"src/report.fodt"@ and+@"public/report.pdf"@.+-}+module Document.Build.Project (+ -- * Projects+ projectPath,+ projectPathOf,++ -- * Placeholders+ Placeholders,+ environmentPlaceholders,+ directoryName,+ filePlaceholderNames,+ filePlaceholders,+ placeholderValue,+ withPlaceholder,+ placeholderAliases,+ substitutePlaceholders,++ -- * Files+ clean,+ prepareFile,++ -- * Fonts+ withFonts,+) where++import Control.Monad.Reader (ask)+import Control.Monad.Trans.Class (lift)+import Data.Bool (bool)+import Data.List (isPrefixOf, stripPrefix, tails)+import Data.Maybe (fromMaybe, listToMaybe)+import qualified Data.Text as Text+import Data.Time (UTCTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Document.Build.Build (Build, Command, io, process, say, withTempDirectory)+import Document.Build.Error (CommandLine (..), ReviewBuildError)+import Document.Build.File (copyTo, writeUtf8)+import Document.Build.Git (GitDetails (..), gitDetails, gitLastCommit, gitPlaceholders)+import Document.Build.Replace (replaceStrings, xmlEscape)+import System.Directory (doesDirectoryExist, makeAbsolute, removePathForcibly)+import System.Environment (lookupEnv, setEnv, unsetEnv)+import System.FilePath (dropTrailingPathSeparator, takeFileName, (</>))+import System.FilePather.Combinators (hasExtension, onFile)++{- | The path of the project in the directory being operated on, such as+@"group/project"@: the environment variable @CI_PROJECT_PATH@,+which GitLab CI sets, or otherwise the path in the URL of the @origin@ git+remote (see 'projectPathOf'), or otherwise the empty string.++Use it to make an exception for one project in a build file.++@since 0.1.0.0+-}+projectPath :: (ReviewBuildError e) => Command e String+projectPath =+ do+ d <- ask+ lift $+ io (lookupEnv "CI_PROJECT_PATH")+ >>= maybe+ ( io (doesDirectoryExist (d </> ".git"))+ >>= bool+ (pure "")+ (projectPathOf . takeWhile (/= '\n') <$> process (CommandLine "git" ["-C", d, "config", "--default", "", "--get", "remote.origin.url"]))+ )+ pure++{- | The project path in a git remote URL: the path after the host, without+@.git@. A remote without a host is a local path, which is used as it is.++>>> projectPathOf "git@gitlab.com:group/project.git"+"group/project"++>>> projectPathOf "https://example.com/group/subgroup/project.git"+"group/subgroup/project"++>>> projectPathOf "/srv/git/project"+"/srv/git/project"++@since 0.1.0.0+-}+projectPathOf :: String -> String+projectPathOf url =+ let u =+ let x = dropTrailingPathSeparator url+ in maybe x reverse (stripPrefix (reverse ".git") (reverse x))+ scheme =+ listToMaybe [drop 3 t | t <- tails u, "://" `isPrefixOf` t]+ in case scheme of+ Just h -> drop 1 (dropWhile (/= '/') h)+ Nothing -> bool u (drop 1 (dropWhile (/= ':') u)) ('@' `elem` u)++{- | Placeholders, such as @${GIT_COMMIT_TIME}@, and their values.++@since 0.1.0.0+-}+type Placeholders = [(String, String)]++{- | Placeholders from environment variables, each by its name without @${@+and @}@, with the command that gives its value when the variable is not set.+For example, for some of the variables that GitLab CI sets:++@+environmentPlaceholders [("CI_PAGES_URL", pure ""), ("CI_PROJECT_TITLE", 'directoryName')]+@++@since 0.1.0.0+-}+environmentPlaceholders :: [(String, Command e String)] -> Command e Placeholders+environmentPlaceholders =+ traverse+ ( \(n, fallback) ->+ (,) ("${" <> n <> "}")+ <$> (lift (io (lookupEnv n)) >>= maybe fallback pure)+ )++{- | The name of the directory being operated on, such as @"project"@ for+@"."@ in @\/home\/user\/project@.++@since 0.1.0.0+-}+directoryName :: Command e String+directoryName =+ ask >>= lift . io . fmap (takeFileName . dropTrailingPathSeparator) . makeAbsolute++{- | The names of the placeholders of 'filePlaceholders', without @${@ and+@}@.++>>> filePlaceholderNames+["GIT_COMMIT_HASH","GIT_COMMIT_HASH_SHORT","GIT_AUTHOR_NAME","GIT_AUTHOR_EMAIL","GIT_AUTHOR_TIME","GIT_COMMITTER_NAME","GIT_COMMITTER_EMAIL","GIT_COMMIT_TIME","GIT_SUBJECT","GIT_AUTHORS"]++@since 0.1.0.0+-}+filePlaceholderNames :: [String]+filePlaceholderNames =+ fmap (takeWhile (/= '}') . drop 2 . fst) (gitPlaceholders (GitDetails "" "" "" "" epoch "" "" epoch "" []))++{- | Placeholders for the last commit to change the file being operated on,+named by 'filePlaceholderNames' (see 'Document.Build.Git.gitPlaceholders').++These are of the file, not of the repository, so a document says when it last+changed, and by whom. A file that no commit has changed, such as a new file,+has the placeholders of the last commit of the repository, with a warning.+Fails with 'Document.Build.Error.ShallowRepository' if the git history is+shallow (see 'Document.Build.Git.gitLastCommit').++@since 0.1.0.0+-}+filePlaceholders :: (ReviewBuildError e) => Command e Placeholders+filePlaceholders =+ do+ p <- ask+ gitPlaceholders+ <$> ( gitLastCommit+ >>= maybe+ (lift (say ("warning: " <> p <> " has no git history, so its placeholders are of the last commit of the repository")) *> onFile "." gitDetails)+ pure+ )++-- | The start of 1970, UTC.+epoch :: UTCTime+epoch =+ posixSecondsToUTCTime 0++{- | The value of a placeholder, by its name without @${@ and @}@.++>>> placeholderValue [("${UPDATED}", "now")] "UPDATED"+"now"++@since 0.1.0.0+-}+placeholderValue :: Placeholders -> String -> String+placeholderValue ph n =+ fromMaybe "" (lookup ("${" <> n <> "}") ph)++{- | Set the value of a placeholder, by its name without @${@ and @}@, adding+it if there is none.++>>> withPlaceholder "PAGES_URL" "https://example.com/" [("${PAGES_URL}", ""), ("${TITLE}", "Report")]+[("${PAGES_URL}","https://example.com/"),("${TITLE}","Report")]++>>> withPlaceholder "PAGES_URL" "https://example.com/" [("${TITLE}", "Report")]+[("${TITLE}","Report"),("${PAGES_URL}","https://example.com/")]++@since 0.1.0.0+-}+withPlaceholder :: String -> String -> Placeholders -> Placeholders+withPlaceholder n v ph =+ let k = "${" <> n <> "}"+ in maybe (ph <> [(k, v)]) (const (fmap (\(k', x) -> (k', bool x v (k' == k))) ph)) (lookup k ph)++{- | Add placeholders that have the values of others, each as a pair of names+without @${@ and @}@: the new placeholder, and the placeholder whose value it+has. A placeholder with no value has the empty string.++>>> placeholderAliases [("UPDATED", "GIT_COMMIT_TIME")] [("${GIT_COMMIT_TIME}", "2026-10-09 01:02:03 UTC")]+[("${GIT_COMMIT_TIME}","2026-10-09 01:02:03 UTC"),("${UPDATED}","2026-10-09 01:02:03 UTC")]++@since 0.1.0.0+-}+placeholderAliases :: [(String, String)] -> Placeholders -> Placeholders+placeholderAliases as ph =+ foldl (\x (n, v) -> withPlaceholder n (placeholderValue ph v) x) ph as++{- | Replace placeholders in the file being operated on, writing to a file+path, and return the file path. Values are escaped for XML files (flat+LibreOffice files, HTML and SVG), and inserted as they are into other files.++@since 0.1.0.0+-}+substitutePlaceholders :: (ReviewBuildError e) => Placeholders -> FilePath -> Command e FilePath+substitutePlaceholders ph o =+ do+ p <- ask+ let xml = hasExtension ["fodt", "fods", "fodg", "fodp", "html", "svg"] p+ replaceStrings (bool ph (fmap (fmap xmlEscape) ph) xml) o++{- | Remove a directory, such as the output of an earlier build.++@since 0.1.0.0+-}+clean :: FilePath -> Build e ()+clean d =+ say ("+ rm -rf " <> d) *> io (removePathForcibly d)++{- | Prepare the file being operated on as a file path, and return the file+path: replace placeholders in it if it has one of the given extensions (see+'substitutePlaceholders'), and copy it otherwise. The placeholders are a+command, run on the file being operated on, only if it has one of the+extensions, such as 'filePlaceholders'.++@since 0.1.0.0+-}+prepareFile :: (ReviewBuildError e) => [String] -> Command e Placeholders -> FilePath -> Command e FilePath+prepareFile text ph o =+ ask >>= bool (copyTo o) (ph >>= \x -> substitutePlaceholders x o) . hasExtension text++{- | Run a build with the fonts in a directory available to LibreOffice and+pandoc, through a fontconfig file in a temporary directory, if the directory+exists, so that documents look the same on every machine.++@since 0.1.0.0+-}+withFonts :: FilePath -> Build e a -> Build e a+withFonts dir b =+ io (doesDirectoryExist dir)+ >>= bool+ b+ ( withTempDirectory "fonts" $ \tmp ->+ do+ dir' <- io (makeAbsolute dir)+ conf <-+ writeUtf8 (tmp </> "fonts.conf") . Text.pack . unlines $+ [ "<?xml version=\"1.0\"?>"+ , "<!DOCTYPE fontconfig SYSTEM \"fonts.dtd\">"+ , "<fontconfig>"+ , " <include ignore_missing=\"yes\">/etc/fonts/fonts.conf</include>"+ , " <dir>" <> xmlEscape dir' <> "</dir>"+ , " <cachedir>" <> xmlEscape (tmp </> "fontcache") <> "</cachedir>"+ , "</fontconfig>"+ ]+ io (setEnv "FONTCONFIG_FILE" conf)+ r <- b+ io (unsetEnv "FONTCONFIG_FILE")+ pure r+ )
+ src/Document/Build/Replace.hs view
@@ -0,0 +1,99 @@+{-# OPTIONS_GHC -Wall #-}++{- | Commands that replace strings in text files, such as placeholders for+the git revision of a document.++These operate on text files, such as flat LibreOffice files (@.fodt@,+@.fods@, @.fodg@), markdown, HTML and SVG. They do not apply to zipped+LibreOffice files (@.odt@), which can be converted to flat files with+'Document.Build.LibreOffice.libreofficeFlat'.+-}+module Document.Build.Replace (+ replaceText,+ replaceStrings,+ requireStrings,+ xmlEscape,+) where++import Control.Monad.Trans.Class (lift)+import Data.Bifunctor (bimap)+import Data.List.NonEmpty (nonEmpty)+import Data.Text (Text)+import qualified Data.Text as Text+import Document.Build.Build (Command, failBuild, requireInput)+import Document.Build.Error (BuildError (..), ReviewBuildError)+import Document.Build.File (readUtf8, writeUtf8)++{- $setup+>>> :set -XOverloadedStrings+-}++{- | Replace every occurrence of the first string of each pair with the+second. The pairs are applied in order, so a later pair also applies to the+replacements made by an earlier pair. A pair whose first string is empty is+skipped.++>>> replaceText [("${NAME}", "Tony"), ("${DATE}", "2026-10-09")] "${NAME} wrote this on ${DATE}, ${NAME}"+"Tony wrote this on 2026-10-09, Tony"++>>> replaceText [("", "x")] "abc"+"abc"++>>> replaceText [("a", "b"), ("b", "c")] "ab"+"cc"++@since 0.1.0.0+-}+replaceText :: [(Text, Text)] -> Text -> Text+replaceText = foldr (\(a, b) k -> k . if Text.null a then id else Text.replace a b) id+{-# INLINE replaceText #-}++{- | Replace strings in the file being operated on, as with 'replaceText',+writing the result to a file path, and return the file path. The file is read+and written as UTF-8.++The output file path may be the same as the input file path.++@since 0.1.0.0+-}+replaceStrings :: (ReviewBuildError e) => [(String, String)] -> FilePath -> Command e FilePath+replaceStrings rs o =+ do+ i <- requireInput+ lift (readUtf8 i >>= writeUtf8 o . replaceText (fmap (bimap Text.pack Text.pack) rs))++{- | Fail with 'StringsMissing' unless the file being operated on contains+every one of the given strings.++@since 0.1.0.0+-}+requireStrings :: (ReviewBuildError e) => [String] -> Command e ()+requireStrings xs =+ do+ i <- requireInput+ t <- lift (readUtf8 i)+ maybe+ (pure ())+ (lift . failBuild . StringsMissing i)+ (nonEmpty (filter (\x -> not (Text.pack x `Text.isInfixOf` t)) xs))++{- | Escape a string for XML text or an attribute value. Use this for+replacement strings in XML files, such as flat LibreOffice files.++>>> xmlEscape "Tony <tony@example.com> & \"friends\""+"Tony <tony@example.com> & "friends""++@since 0.1.0.0+-}+xmlEscape :: String -> String+xmlEscape =+ concatMap+ ( \c ->+ case c of+ '&' -> "&"+ '<' -> "<"+ '>' -> ">"+ '"' -> """+ '\'' -> "'"+ _ -> [c]+ )
+ src/Document/Build/Rules.hs view
@@ -0,0 +1,457 @@+{-# OPTIONS_GHC -Wall #-}++{- | Rules: named build steps, made from the commands of+"Document.Build.Operations", that say which files are made from which.++Each rule takes its settings as arguments: the directories, extensions,+formats, sizes and names of its files. None has a default, so a build file+says what it builds:++@+'Document.Build.Context.onPaths' (isWithin "src") ('prepareRules' ["md"] 'Document.Build.Project.filePlaceholders' "src")+ \<> 'markdownRules' (flip replaceExtension) [("pdf", pure ["--standalone"])]+ \<> 'pageCountRules' (\<> ".pages")+@++The rules in this module define no actions of their own: each wraps a+command of "Document.Build.Operations" in a named step with+'Document.Build.Context.buildStep', and says which files it applies to. A+rule excludes the files that it makes itself, by their trail (see+'Document.Build.Context.afterStep' and+'Document.Build.Context.unlessAfterStep'), so that it never runs on its own+outputs. A rule that would, by mistake, is stopped with a+'System.FilePather.Trail.Cycle' before it runs again.++The step names that rules use, such as @prepare@ and @pdf page 1@, are given+in their documentation, so that a build file can choose files by the step+that made them.+-}+module Document.Build.Rules (+ -- * Preparing+ prepareRules,+ assetRules,+ fontRules,++ -- * Converting+ libreofficeRules,+ libreofficeCounterpartRules,+ pandocHtmlRules,+ markdownRules,++ -- * Joining+ bookRules,+ imageJoinRules,+ mergePdf,++ -- * Pages+ pageCountRules,+ pageOneRules,+ pdfPageImageRules,+ splitPdf,++ -- * Images+ imageRules,++ -- * Checking+ requirePlaceholders,++ -- * Completing+ archiveRules,+ outputTreeRules,+) where++import Control.Lens (preview, (^.))+import Control.Monad (void)+import Control.Monad.Reader (ask)+import Control.Monad.Trans.Class (lift)+import Data.Bool (bool)+import Data.Char (isDigit)+import Data.List (isPrefixOf, sort, stripPrefix)+import qualified Data.Map as Map+import Data.Maybe (mapMaybe)+import Document.Build.Build (Build', Command', io)+import Document.Build.Context+import Document.Build.File (copyTo, filesIn, tarGz, writeUtf8)+import Document.Build.Image (imageAppend, imageConvert, imageConvertFirstFrame)+import Document.Build.LibreOffice (flatExtension, libreoffice, libreofficeOutput, zippedExtension)+import Document.Build.Output (describeForest, edgeForest, outputForestHtml, writeOutputForest)+import Document.Build.Pandoc (pandoc)+import Document.Build.Pdf (pdfConcatenate, pdfFirstPage, pdfPageCountFile, pdfSplit, pdfToImages, pdftk)+import Document.Build.Project (Placeholders, prepareFile)+import Document.Build.Replace (requireStrings)+import System.Directory (doesFileExist, listDirectory)+import System.FilePath (equalFilePath, makeRelative, normalise, takeDirectory, takeExtension, takeFileName, (</>))+import System.FilePather.Combinators (hasExtension, isFile, isWithin, onFile)+import System.FilePather.Tracked (Tracked, askTrail, onPath, whenPath)+import System.FilePather.Trail (Step (..), lastStep)++{- | Prepare the files of a directory at the same path relative to the output+directory (step @prepare@): replace placeholders in the files with one of the+text extensions, and copy the others. The placeholders are a command, run on+each text file, such as 'Document.Build.Project.filePlaceholders'.++@since 0.1.0.0+-}+prepareRules :: [String] -> Command' Placeholders -> FilePath -> Rules+prepareRules =+ prepareWith "prepare"+{-# INLINE prepareRules #-}++{- | Prepare the files of a directory of assets, which are not converted, as+'prepareRules' does (step @prepare asset@).++@since 0.1.0.0+-}+assetRules :: [String] -> Command' Placeholders -> FilePath -> Rules+assetRules =+ prepareWith "prepare asset"+{-# INLINE assetRules #-}++prepareWith :: String -> [String] -> Command' Placeholders -> FilePath -> Rules+prepareWith n text placeholders d =+ onFiles . onSources $ \c ->+ let out = c ^. contextDirectories . outputDirectory+ in whenPath (isWithin d) . buildStep n (\p -> [out </> makeRelative d p]) $+ ask >>= void . prepareFile text placeholders . (out </>) . makeRelative d++{- | Copy the files of a directory, such as a directory of fonts, to the+output directory, keeping the directory: @fonts/a.ttf@ is copied to+@public/fonts/a.ttf@ (step @copy font@).++@since 0.1.0.0+-}+fontRules :: FilePath -> Rules+fontRules d =+ onFiles . onSources $ \c ->+ let out = c ^. contextDirectories . outputDirectory+ in whenPath (isWithin d) . buildStep "copy font" (\p -> [out </> p]) $+ ask >>= void . copyTo . (out </>)++{- | Convert each prepared LibreOffice file with one of a set of extensions to+each of its formats, next to the file (steps such as @libreoffice pdf@). For+example:++@+libreofficeRules [(["fodt", "odt"], ["pdf", "docx"]), (["fods", "ods"], ["pdf", "xlsx"])]+@++@since 0.1.0.0+-}+libreofficeRules :: [([String], [String])] -> Rules+libreofficeRules conversions =+ onFiles . onOutputs . afterStep (== "prepare") . fromTracked $+ foldMap+ (\(exts, fmts) -> whenPath (hasExtension exts) (foldMap (\fmt -> libreofficeStep ("libreoffice " <> fmt) fmt) fmts))+ conversions++{- | Convert each prepared flat LibreOffice file, such as @.fodt@, to its+zipped form, such as @.odt@ (step @libreoffice zipped@), and each zipped file+to its flat form (step @libreoffice flat@).++@since 0.1.0.0+-}+libreofficeCounterpartRules :: Rules+libreofficeCounterpartRules =+ onFiles . onOutputs . afterStep (== "prepare") . fromTracked $+ do+ p <- ask+ let ext = drop 1 (takeExtension p)+ foldMap (libreofficeStep "libreoffice zipped") (zippedExtension ext)+ <> foldMap (libreofficeStep "libreoffice flat") (flatExtension ext)++-- | A step that converts a file with LibreOffice, next to the file.+libreofficeStep :: String -> String -> Tracked Build' ()+libreofficeStep n fmt =+ buildStep n (\p -> [libreofficeOutput fmt (takeDirectory p) p]) $+ ask >>= void . libreoffice fmt . takeDirectory++{- | Convert each LibreOffice text document with one of the extensions to+standalone HTML with pandoc (step @pandoc html@), named by a function of the+document, with more pandoc options, such as styles. The options are a+command, run on the document. pandoc reads zipped OpenDocument text, so it+reads a prepared @.odt@ file, or the @.odt@ file made from a prepared @.fodt@+file by 'libreofficeCounterpartRules'.++@since 0.1.0.0+-}+pandocHtmlRules :: [String] -> (FilePath -> FilePath) -> Command' [String] -> Rules+pandocHtmlRules exts name opts =+ onFiles . onOutputs . onPaths (hasExtension ["odt"]) . fromTracked $+ do+ t <- askTrail+ p <- ask+ let source =+ case preview lastStep t of+ Just (Step "prepare" _) -> Just p+ Just (Step "libreoffice zipped" i) -> Just i+ _ -> Nothing+ foldMap+ ( \s ->+ bool+ mempty+ ( buildStep "pandoc html" (const [name s]) $+ do+ o <- opts+ void (pandoc (["-f", "odt", "-t", "html5", "--standalone", "--embed-resources", "--strip-comments", "-M", "pagetitle=" <> takeFileName s] <> o) (name s))+ )+ (hasExtension exts s)+ )+ source++{- | Convert each prepared markdown file to each format, named by a function+of the format and the file, with pandoc options (steps such as+@pandoc pdf@). The options are a command, run on the markdown file. For+example:++@+markdownRules (flip replaceExtension) [("pdf", pure ("--standalone" : 'Document.Build.Pandoc.xelatex')), ("html", pure ["--standalone"])]+@++@since 0.1.0.0+-}+markdownRules :: (String -> FilePath -> FilePath) -> [(String, Command' [String])] -> Rules+markdownRules name conversions =+ onFiles . onOutputs . afterStep (== "prepare") . onPaths (hasExtension ["md"]) . fromTracked $+ foldMap+ ( \(ext, opts) ->+ buildStep ("pandoc " <> ext) (\p -> [name ext p]) $+ do+ p <- ask+ o <- opts+ void (pandoc o (name ext p))+ )+ conversions++{- | Concatenate the parts of each book in a directory of the output directory+(step @book@): @name-part.pdf@, for each part in order, into @name.pdf@, once+every part exists. The book is made from its first part. For example, with+the parts @["front", "body", "back"]@, @report-front.pdf@,+@report-body.pdf@ and @report-back.pdf@ are concatenated into @report.pdf@.++@since 0.1.0.0+-}+bookRules :: [String] -> Rules+bookRules parts =+ onDirectories . onOutputs . fromTracked $+ case parts of+ [] -> mempty+ first : _ ->+ do+ d <- ask+ names <- lift (namesIn d)+ foldMap+ ( \name ->+ let files = fmap (\part -> name <> "-" <> part <> ".pdf") parts+ o = d </> name <> ".pdf"+ in whenReady (fmap (d </>) files) o $+ onPath (d </> name <> "-" <> first <> ".pdf") (buildStep "book" (const [o]) (void (onFile d (pdfConcatenate files o))))+ )+ (mapMaybe (stripSuffix ("-" <> first <> ".pdf")) names)++{- | Join images in a directory of the output directory side by side (step+@join images@): for each name, @name-N.png@, for each digit @N@ in order, into+@name.png@. The joined image is made from the first.++@since 0.1.0.0+-}+imageJoinRules :: [String] -> Rules+imageJoinRules prefixes =+ onDirectories . onOutputs . fromTracked $+ do+ d <- ask+ names <- lift (namesIn d)+ foldMap+ ( \prefix ->+ let isPart n =+ case stripPrefix (prefix <> "-") n of+ Just [x, '.', 'p', 'n', 'g'] -> isDigit x+ _ -> False+ o = d </> prefix <> ".png"+ in case filter isPart names of+ [] -> mempty+ files@(first : _) ->+ whenReady (fmap (d </>) files) o $+ onPath (d </> first) (buildStep "join images" (const [o]) (void (onFile d (imageAppend files o))))+ )+ prefixes++{- | Merge pages from several PDF files into one, with @pdftk@ (step+@pdf merge@), once every input file exists: the input files, each with a+@pdftk@ handle such as @"A"@; the page ranges, such as+@["A1-16", "B1", "A18-end"]@; and the output file. The file paths are+relative to the output directory. The output is made from the first input+file.++@since 0.1.0.0+-}+mergePdf :: [(String, FilePath)] -> [String] -> FilePath -> Rules+mergePdf inputs ranges o =+ onDirectories $ \c ->+ let out = c ^. contextDirectories . outputDirectory+ in case inputs of+ [] -> mempty+ (_, first) : _ ->+ whenPath (isFile out) . whenReady (fmap ((out </>) . snd) inputs) (out </> o) $+ onPath (out </> first) $+ buildStep "pdf merge" (const [out </> o]) (void (onFile out (pdftk (fmap (\(h, f) -> h <> "=" <> f) inputs <> ["cat"]) ranges (out </> o))))++{- | Write the page count of every PDF file to a file named by a function of+the PDF file (step @page count@).++@since 0.1.0.0+-}+pageCountRules :: (FilePath -> FilePath) -> Rules+pageCountRules name =+ onFiles . onOutputs . onPaths (hasExtension ["pdf"]) . fromTracked $+ buildStep "page count" (pure . name) (ask >>= void . pdfPageCountFile . name)++{- | Extract the first page of every PDF file to a PDF file named by a function+of the PDF file (step @pdf page 1@), and convert that to an image named by a+function of it, in the format of its extension (step @page 1 image@).++@since 0.1.0.0+-}+pageOneRules :: (FilePath -> FilePath) -> (FilePath -> FilePath) -> Rules+pageOneRules page1 image =+ onFiles . onOutputs . onPaths (hasExtension ["pdf"]) $+ unlessAfterStep (== "pdf page 1") (fromTracked (buildStep "pdf page 1" (pure . page1) (ask >>= void . pdfFirstPage . page1)))+ <> afterStep (== "pdf page 1") (fromTracked (buildStep "page 1 image" (pure . image) (ask >>= void . imageConvert . image)))++{- | Convert each page of every PDF file to an image (step @pdf page images@),+with @convert@ options, named by a function of the PDF file before the images+are numbered (see 'Document.Build.Pdf.pdfToImages'). For example, for the+PDF files of one project:++@+'Document.Build.Context.onProject' "group/project" (pdfPageImageRules ["-density", "180"] (\`replaceExtension\` "png"))+@++@since 0.1.0.0+-}+pdfPageImageRules :: [String] -> (FilePath -> FilePath) -> Rules+pdfPageImageRules opts name =+ onFiles . onOutputs . onPaths (hasExtension ["pdf"]) . fromTracked $+ buildStep' "pdf page images" (ask >>= pdfToImages opts . name)++{- | Split a PDF file into several files (step @pdf split@), given by a+@pdftk@ page range and a file for each. The file paths are relative to the+output directory. For example:++@+splitPdf "report.pdf" [("1", "report_cover.pdf"), ("2-end", "report_body.pdf")]+@++@since 0.1.0.0+-}+splitPdf :: FilePath -> [(String, FilePath)] -> Rules+splitPdf pdf sections =+ onFiles $ \c ->+ let out = c ^. contextDirectories . outputDirectory+ sections' = fmap (fmap (out </>)) sections+ in whenPath (isFile (out </> pdf)) (buildStep "pdf split" (const (fmap snd sections')) (void (pdfSplit sections')))++{- | Convert every image with one of the extensions to each of the formats,+named by a function of the format and the image (steps such as+@image jpg@), and resize it to fit squares of each of the sizes, named by a+function of the size and the converted image (steps such as+@image png 250@): in its own format if that is one of the formats, and+otherwise the first of them. Images made by these steps are not converted+again. For example:++@+imageRules ["png", "jpg", "svg"] ["png", "jpg"] [800, 250] (flip replaceExtension) (\\n p -> dropExtension p <> "-" <> show n <> takeExtension p)+@++@since 0.1.0.0+-}+imageRules :: [String] -> [String] -> [Int] -> (String -> FilePath -> FilePath) -> (Int -> FilePath -> FilePath) -> Rules+imageRules exts formats sizes converted resized =+ onFiles . onOutputs . unlessAfterStep (isPrefixOf "image ") . onPaths (hasExtension exts) . fromTracked $+ do+ p <- ask+ let ext = (\e -> bool e "jpg" (e == "jpeg")) (drop 1 (takeExtension p))+ sized = bool (take 1 formats) [ext] (ext `elem` formats)+ convertedTo f = converted f p+ resizedTo n f = resized n (convertedTo f)+ foldMap+ (\f -> buildStep ("image " <> f) (const [convertedTo f]) (void (imageConvertFirstFrame [] (convertedTo f))))+ (filter (/= ext) formats)+ <> foldMap+ (\(n, f) -> buildStep ("image " <> f <> " " <> show n) (const [resizedTo n f]) (void (imageConvertFirstFrame ["-resize", show n <> "x" <> show n] (resizedTo n f))))+ [(n, f) | f <- sized, n <- sizes]++{- | Fail unless every file of the input directories that these rules apply+to contains each of the placeholders, by name without @${@ and @}@ (step+@require placeholders@). Choose the files with+'Document.Build.Context.onPaths'.++@since 0.1.0.0+-}+requirePlaceholders :: [String] -> Rules+requirePlaceholders names =+ onFiles . onSources . fromTracked $+ buildStep "require placeholders" (const []) (requireStrings (fmap (\n -> "${" <> n <> "}") names))++{- | When the build is complete, archive the files the build made in the output+directory that satisfy a predicate, in a @.tar.gz@ file, relative to the+output directory (step @archive@).++@since 0.1.0.0+-}+archiveRules :: (FilePath -> Bool) -> FilePath -> Rules+archiveRules select name =+ onComplete $ \known c ->+ let out = c ^. contextDirectories . outputDirectory+ files = ["." </> makeRelative out p | p <- Map.keys known, isWithin out p, select p]+ in buildStep "archive" (const [out </> name]) (void (tarGz files (out </> name)))++{- | When the build is complete, write the tree of output files to a JSON file+and an HTML page, relative to the output directory, with a title (step+@output tree@): each file of the input directories is a root, and each file+is a child of the input file of the step that made it. A file made from a+directory, and a file in the output directory that no step made, such as one+made by rules before these when the build is complete, is a root. The title+is a command, run on the output directory.++@since 0.1.0.0+-}+outputTreeRules :: FilePath -> FilePath -> Command' String -> Rules+outputTreeRules json html title =+ onComplete $ \known c ->+ let out = c ^. contextDirectories . outputDirectory+ json' = out </> json+ html' = out </> html+ edges =+ [ (i, [o])+ | (o, t) <- Map.toList known+ , Step _ i <- maybe [] pure (preview lastStep t)+ , Map.member (normalise i) known+ ]+ in buildStep "output tree" (const [json', html']) $+ do+ t <- title+ lift $+ do+ untracked <- filter (\f -> not (any (equalFilePath f) [json', html'])) <$> filesIn out+ forest <- describeForest (edgeForest edges (Map.keys known <> untracked))+ _ <- writeOutputForest json' forest+ void (writeUtf8 html' (outputForestHtml out t forest))++{- | Run when every input file exists and the output file does not, and+otherwise make nothing. A step that makes a file from several files runs+once, when they all exist.+-}+whenReady :: [FilePath] -> FilePath -> Tracked Build' () -> Tracked Build' ()+whenReady inputs o x =+ lift (io (((&&) . and <$> traverse doesFileExist inputs) <*> (not <$> doesFileExist o)))+ >>= bool mempty x++-- | The names of the entries of a directory, in sorted order.+namesIn :: FilePath -> Build' [FilePath]+namesIn d =+ io (sort <$> listDirectory d)++-- | Remove a suffix from a list, if it ends with it.+stripSuffix :: String -> String -> Maybe String+stripSuffix s x =+ reverse <$> stripPrefix (reverse s) (reverse x)
+ test/BuildTests.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}++{- | Properties of the pure parts of the document build commands: parsers,+string replacement, hashing, and the optics of the data types.+-}+module BuildTests (+ buildTests,+) where++import qualified Data.ByteString.Lazy.Char8 as Char8+import Data.Char (isHexDigit)+import Data.List (isPrefixOf, isSuffixOf, nub)+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Text as Text+import Data.Time (UTCTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)+import Document.Build+import Gens (genInt, genString)+import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Laws (Laws, lensLaws, prismLaws)++genCommandLine :: Gen CommandLine+genCommandLine =+ CommandLine <$> genString <*> Gen.list (Range.linear 0 4) genString++genBuildError :: Gen BuildError+genBuildError =+ Gen.choice+ [ ProcessFailed <$> genCommandLine <*> genString <*> genString+ , ProcessOutputUnrecognised <$> genCommandLine <*> genString+ , InputFileMissing <$> genString+ , OutputFileMissing <$> genCommandLine <*> genString+ , StringsMissing <$> genString <*> Gen.nonEmpty (Range.linear 1 3) genString+ , FileTypeUnsupported <$> genString <*> Gen.list (Range.linear 0 3) genString+ , FileNotInGit <$> genString+ , FileNotUtf8 <$> genString+ , BuildCycle <$> genCycle+ , InputFilesTooFew <$> genString <*> Gen.int (Range.linear 0 10) <*> Gen.int (Range.linear 0 10)+ , OutputNotInDirectory <$> genString <*> genString+ , ShallowRepository <$> genString+ ]++genCycle :: Gen Cycle+genCycle =+ let genStep = Step <$> genString <*> genString+ genTrail = Trail <$> Gen.list (Range.linear 0 3) genStep+ in Gen.choice+ [ ReproducesInput <$> genString <*> genStep <*> genTrail+ , RepeatsStep <$> genStep <*> genTrail+ ]++genTime :: Gen UTCTime+genTime =+ posixSecondsToUTCTime . fromIntegral <$> Gen.int (Range.linear 0 2000000000)++genImageInfo :: Gen ImageInfo+genImageInfo =+ ImageInfo+ <$> Gen.element ["PNG", "JPEG", "GIF", "PDF"]+ <*> Gen.int (Range.linear 1 10000)+ <*> Gen.int (Range.linear 1 10000)+ <*> (fromIntegral <$> Gen.int (Range.linear 1 1200))+ <*> (fromIntegral <$> Gen.int (Range.linear 1 1200))+ <*> Gen.element ["Undefined", "PixelsPerInch", "PixelsPerCentimeter"]+ <*> Gen.element ["sRGB", "Gray", "CMYK"]+ <*> Gen.element [1, 8, 16]+ <*> Gen.int (Range.linear 1 100)++genWord :: Gen String+genWord =+ Gen.string (Range.linear 1 20) Gen.alphaNum++genGitDetails :: Gen GitDetails+genGitDetails =+ GitDetails+ <$> genWord+ <*> genWord+ <*> genWord+ <*> genWord+ <*> genTime+ <*> genWord+ <*> genWord+ <*> genTime+ <*> Gen.string (Range.linear 0 40) (Gen.filter (`notElem` ("\NUL\n" :: String)) Gen.unicode)+ <*> Gen.list (Range.linear 0 3) genWord++buildTests :: Laws+buildTests =+ concat+ [ lensLaws "commandLineProgram" commandLineProgram genCommandLine genString+ , lensLaws "commandLineArguments" commandLineArguments genCommandLine (Gen.list (Range.linear 0 3) genString)+ , lensLaws "imageWidth" imageWidth genImageInfo genInt+ , lensLaws "imageColourspace" imageColourspace genImageInfo genString+ , lensLaws "gitCommitHash" gitCommitHash genGitDetails genString+ , lensLaws "gitCommitTime" gitCommitTime genGitDetails genTime+ , lensLaws "gitAuthors" gitAuthors genGitDetails (Gen.list (Range.linear 0 3) genString)+ , prismLaws "_ProcessFailed" _ProcessFailed genBuildError ((,,) <$> genCommandLine <*> genString <*> genString)+ , prismLaws "_ProcessOutputUnrecognised" _ProcessOutputUnrecognised genBuildError ((,) <$> genCommandLine <*> genString)+ , prismLaws "_InputFileMissing" _InputFileMissing genBuildError genString+ , prismLaws "_OutputFileMissing" _OutputFileMissing genBuildError ((,) <$> genCommandLine <*> genString)+ , prismLaws "_StringsMissing" _StringsMissing genBuildError ((,) <$> genString <*> Gen.nonEmpty (Range.linear 1 3) genString)+ , prismLaws "_FileTypeUnsupported" _FileTypeUnsupported genBuildError ((,) <$> genString <*> Gen.list (Range.linear 0 3) genString)+ , prismLaws "_FileNotInGit" _FileNotInGit genBuildError genString+ , prismLaws "_FileNotUtf8" _FileNotUtf8 genBuildError genString+ , prismLaws "_BuildCycle" _BuildCycle genBuildError genCycle+ , prismLaws "_InputFilesTooFew" _InputFilesTooFew genBuildError ((,,) <$> genString <*> Gen.int (Range.linear 0 10) <*> Gen.int (Range.linear 0 10))+ , prismLaws "_OutputNotInDirectory" _OutputNotInDirectory genBuildError ((,) <$> genString <*> genString)+ , prismLaws "_ShallowRepository" _ShallowRepository genBuildError genString+ , prismLaws "_BuildError" _BuildError genBuildError genBuildError+ ,+ [ ("parsePdfinfoPages finds the page count", prop_parsePdfinfoPages)+ , ("parseImageInfo round trip", prop_parseImageInfo)+ , ("parseGitLog round trip", prop_parseGitLog)+ , ("pageImagePaths has one path for each page", prop_pageImagePaths)+ , ("replaceText with no pairs is the identity", prop_replaceTextEmpty)+ , ("replaceText of a string with itself is the identity", prop_replaceTextSame)+ , ("replaceText of an absent string is the identity", prop_replaceTextAbsent)+ , ("sha256Hex is 64 hexadecimal digits", prop_sha256Hex)+ , ("xmlEscape leaves no markup", prop_xmlEscape)+ , ("shellQuote leaves no unquoted special characters", prop_shellQuote)+ , ("flatExtension and zippedExtension are inverse", prop_flatZipped)+ , ("buildErrorExitCode is distinct for each kind of error", prop_exitCodes)+ , ("displayBuildError ends with a newline", prop_display)+ ]+ ]++prop_parsePdfinfoPages :: Property+prop_parsePdfinfoPages =+ property $+ do+ n <- forAll (Gen.int (Range.linear 0 10000))+ before <- forAll (Gen.list (Range.linear 0 4) (("Title: " <>) <$> genWord))+ parsePdfinfoPages (unlines (before <> ["Pages: " <> show n, "Encrypted: no"])) === Just n++prop_parseImageInfo :: Property+prop_parseImageInfo =+ property $+ do+ i@(ImageInfo m w h x y u c z n) <- forAll genImageInfo+ parseImageInfo (unlines [m, show w, show h, show x, show y, u, c, show z, show n]) === Just i++prop_parseGitLog :: Property+prop_parseGitLog =+ property $+ do+ g@(GitDetails h h' an ae at cn ce ct subject as) <- forAll genGitDetails+ let seconds t = show (floor (utcTimeToPOSIXSeconds t) :: Integer)+ parseGitLog (concatMap (<> "\NUL") [h, h', an, ae, seconds at, cn, ce, seconds ct] <> subject <> "\n") as === Just g++prop_pageImagePaths :: Property+prop_pageImagePaths =+ property $+ do+ n <- forAll (Gen.int (Range.linear 1 50))+ length (pageImagePaths n "public/report.pdf.png") === n+ pageImagePaths n "public/report.pdf.gif" === ["public/report.pdf.gif"]++prop_replaceTextEmpty :: Property+prop_replaceTextEmpty =+ property $+ do+ t <- Text.pack <$> forAll genString+ replaceText [] t === t++prop_replaceTextSame :: Property+prop_replaceTextSame =+ property $+ do+ a <- Text.pack <$> forAll genWord+ t <- Text.pack <$> forAll genString+ replaceText [(a, a)] t === t++prop_replaceTextAbsent :: Property+prop_replaceTextAbsent =+ property $+ do+ t <- Text.pack <$> forAll (Gen.string (Range.linear 0 30) Gen.lower)+ b <- Text.pack <$> forAll genString+ replaceText [("0", b)] t === t++prop_sha256Hex :: Property+prop_sha256Hex =+ property $+ do+ s <- forAll genString+ let h = sha256Hex (Char8.pack s)+ length h === 64+ assert (all isHexDigit h)++prop_xmlEscape :: Property+prop_xmlEscape =+ property $+ do+ s <- forAll genString+ assert (all (`notElem` ("<>\"'" :: String)) (xmlEscape s))++prop_shellQuote :: Property+prop_shellQuote =+ property $+ do+ s <- forAll genString+ let q = shellQuote s+ assert (q == s || ("'" `isPrefixOf` q && "'" `isSuffixOf` q))++prop_flatZipped :: Property+prop_flatZipped =+ property $+ do+ e <- forAll (Gen.element ["odt", "ods", "odp", "odg"])+ (flatExtension e >>= zippedExtension) === Just e++prop_exitCodes :: Property+prop_exitCodes =+ withTests 1 . property $+ let errors =+ [ ProcessOutputUnrecognised (CommandLine "" []) ""+ , InputFileMissing ""+ , OutputFileMissing (CommandLine "" []) ""+ , StringsMissing "" ("" NonEmpty.:| [])+ , FileTypeUnsupported "" []+ , FileNotInGit ""+ , FileNotUtf8 ""+ , BuildCycle (RepeatsStep (Step "" "") (Trail []))+ , InputFilesTooFew "" 0 0+ , OutputNotInDirectory "" ""+ , ShallowRepository ""+ ]+ codes = fmap buildErrorExitCode errors+ in length (nub codes) === length codes++prop_display :: Property+prop_display =+ property $+ do+ e <- forAll genBuildError+ let d = displayBuildError e+ assert ("\n" `isSuffixOf` d)
+ test/Gens.hs view
@@ -0,0 +1,29 @@+{-# OPTIONS_GHC -Wall #-}++-- | Generators shared by the property tests.+module Gens (+ genInt,+ genString,+ genPath,+) where++import Hedgehog (Gen)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++genInt :: Gen Int+genInt =+ Gen.int (Range.linear (-100) 100)++genString :: Gen String+genString =+ Gen.string (Range.linear 0 30) Gen.unicode++-- | A file path, such as @src/a/report.fodt@.+genPath :: Gen FilePath+genPath =+ let part = Gen.string (Range.linear 1 6) Gen.alphaNum+ in (\ds f e -> concatMap (<> "/") ds <> f <> "." <> e)+ <$> Gen.list (Range.linear 0 3) part+ <*> part+ <*> Gen.element ["fodt", "md", "pdf", "png", "txt"]
+ test/Laws.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE RankNTypes #-}+{-# OPTIONS_GHC -Wall #-}++-- | Laws of lenses and prisms.+module Laws (+ Laws,+ lensLaws,+ prismLaws,+) where++import Control.Lens (ALens', APrism', cloneLens, clonePrism, preview, review, set, view)+import Data.String (fromString)+import Hedgehog++type Laws = [(PropertyName, Property)]++-- | The lens laws: view-set, set-view and set-set.+lensLaws :: (Eq s, Show s, Eq a, Show a) => String -> ALens' s a -> Gen s -> Gen a -> Laws+lensLaws name l genS genA =+ [+ ( fromString (name <> " view . set")+ , property $+ do+ s <- forAll genS+ a <- forAll genA+ view (cloneLens l) (set (cloneLens l) a s) === a+ )+ ,+ ( fromString (name <> " set . view")+ , property $+ do+ s <- forAll genS+ set (cloneLens l) (view (cloneLens l) s) s === s+ )+ ,+ ( fromString (name <> " set . set")+ , property $+ do+ s <- forAll genS+ a <- forAll genA+ b <- forAll genA+ set (cloneLens l) b (set (cloneLens l) a s) === set (cloneLens l) b s+ )+ ]++-- | The prism laws: preview-review and review-preview.+prismLaws :: (Eq s, Show s, Eq a, Show a) => String -> APrism' s a -> Gen s -> Gen a -> Laws+prismLaws name p genS genA =+ [+ ( fromString (name <> " preview . review")+ , property $+ do+ a <- forAll genA+ preview (clonePrism p) (review (clonePrism p) a) === Just a+ )+ ,+ ( fromString (name <> " review . preview")+ , property $+ do+ s <- forAll genS+ maybe s (review (clonePrism p)) (preview (clonePrism p) s) === s+ )+ ]
+ test/OutputTests.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}++-- | Properties of the output tree, its JSON, the optics of the context, and placeholders.+module OutputTests (+ outputTests,+) where++import Data.Aeson (fromJSON, toJSON)+import qualified Data.Aeson as Aeson+import Data.Aeson.Types (parseEither)+import Data.Containers.ListUtils (nubOrd)+import Data.Foldable (toList)+import Data.List (sort)+import qualified Data.Map as Map+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Data.Tree (Forest, Tree (..), flatten)+import Document.Build+import Gens (genPath)+import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Laws (Laws, lensLaws, prismLaws)++genWord :: Gen String+genWord =+ Gen.string (Range.linear 1 12) Gen.alphaNum++genGitDetails :: Gen GitDetails+genGitDetails =+ let time = posixSecondsToUTCTime . fromIntegral <$> Gen.int (Range.linear 0 2000000000)+ in GitDetails <$> genWord <*> genWord <*> genWord <*> genWord <*> time <*> genWord <*> genWord <*> time <*> genWord <*> Gen.list (Range.linear 0 3) genWord++genImageInfo :: Gen ImageInfo+genImageInfo =+ ImageInfo+ <$> genWord+ <*> Gen.int (Range.linear 1 5000)+ <*> Gen.int (Range.linear 1 5000)+ <*> (fromIntegral <$> Gen.int (Range.linear 1 600))+ <*> (fromIntegral <$> Gen.int (Range.linear 1 600))+ <*> genWord+ <*> genWord+ <*> Gen.int (Range.linear 1 16)+ <*> Gen.int (Range.linear 1 10)++genOutputFile :: Gen OutputFile+genOutputFile =+ OutputFile <$> genPath <*> genWord <*> Gen.maybe genGitDetails <*> Gen.maybe (Gen.int (Range.linear 1 500)) <*> Gen.maybe genImageInfo++genForest :: Gen (Forest OutputFile)+genForest =+ Gen.list (Range.linear 0 3) (Gen.recursive Gen.choice [Node <$> genOutputFile <*> pure []] [Node <$> genOutputFile <*> Gen.list (Range.linear 0 3) (Node <$> genOutputFile <*> pure [])])++{- | Edges between a small set of file paths, so that some outputs have more+than one input.+-}+genEdges :: Gen Edges+genEdges =+ let file = Gen.element (fmap (\n -> "public/f" <> show n <> ".pdf") [1 .. 12 :: Int])+ in Gen.list (Range.linear 0 10) ((,) <$> file <*> Gen.list (Range.linear 0 3) file)++outputTests :: Laws+outputTests =+ [ ("edgeForest has every file once", prop_everyFileOnce)+ , ("edgeForest puts an output under its first input", prop_firstInput)+ , ("OutputFile JSON round trip", prop_outputFileJson)+ , ("output forest JSON round trip", prop_forestJson)+ , ("GitDetails JSON round trip", prop_gitDetailsJson)+ , ("ImageInfo JSON round trip", prop_imageInfoJson)+ , ("withPlaceholder then placeholderValue gives the value", prop_withPlaceholder)+ , ("placeholderAliases gives the value of the other placeholder", prop_placeholderAliases)+ ]+ <> concat+ [ lensLaws "outputDirectory" outputDirectory genDirectories genPath+ , lensLaws "inputDirectories" inputDirectories genDirectories (Gen.list (Range.linear 0 3) genPath)+ , lensLaws "fontsDirectory" fontsDirectory genDirectories (Gen.maybe genPath)+ , lensLaws "contextDirectories" contextDirectories genContext genDirectories+ , lensLaws "contextProject" contextProject genContext genWord+ , lensLaws "contextTarget" contextTarget genContext genTarget+ , prismLaws "_TargetFile" _TargetFile genTarget (pure ())+ , prismLaws "_TargetDirectory" _TargetDirectory genTarget (pure ())+ , prismLaws "_TargetComplete" _TargetComplete genTarget genKnownFiles+ ]++genDirectories :: Gen Directories+genDirectories =+ Directories <$> genPath <*> Gen.list (Range.linear 0 3) genPath <*> Gen.maybe genPath++genKnownFiles :: Gen KnownFiles+genKnownFiles =+ Map.fromList <$> Gen.list (Range.linear 0 3) ((,) <$> genPath <*> (Trail <$> Gen.list (Range.linear 0 3) (Step <$> genWord <*> genPath)))++genTarget :: Gen Target+genTarget =+ Gen.choice [pure TargetFile, pure TargetDirectory, TargetComplete <$> genKnownFiles]++genContext :: Gen Context+genContext =+ Context <$> genDirectories <*> genWord <*> genTarget++genPlaceholders :: Gen Placeholders+genPlaceholders =+ Gen.list (Range.linear 0 5) ((,) <$> fmap (\n -> "${" <> n <> "}") genWord <*> genWord)++prop_withPlaceholder :: Property+prop_withPlaceholder =+ property $+ do+ ph <- forAll genPlaceholders+ n <- forAll genWord+ v <- forAll genWord+ placeholderValue (withPlaceholder n v ph) n === v++prop_placeholderAliases :: Property+prop_placeholderAliases =+ property $+ do+ ph <- forAll genPlaceholders+ n <- forAll genWord+ v <- forAll genWord+ placeholderValue (placeholderAliases [(n, v)] ph) n === placeholderValue ph v++prop_everyFileOnce :: Property+prop_everyFileOnce =+ property $+ do+ es <- forAll genEdges+ others <- forAll (Gen.list (Range.linear 0 3) genPath)+ let files = concatMap flatten (edgeForest es others)+ expected = sort (nubOrd (concatMap (uncurry (:)) es <> others))+ sort files === expected++prop_firstInput :: Property+prop_firstInput =+ property $+ do+ es <- forAll genEdges+ let forest = edgeForest es []+ parent o = lookup o (concatMap pairs forest)+ pairs (Node p cs) = fmap (\(Node c _) -> (c, p)) cs <> concatMap pairs cs+ firstInput o = lookup o [(x, i) | (i, os) <- es, x <- os, x /= i]+ for' (nubOrd (concatMap snd es)) $ \o ->+ case parent o of+ Nothing -> pure ()+ Just p -> Just p === firstInput o+ where+ for' xs f = mapM_ f xs++prop_outputFileJson :: Property+prop_outputFileJson =+ property $+ do+ o <- forAll genOutputFile+ fromJSON (toJSON o) === Aeson.Success o++prop_forestJson :: Property+prop_forestJson =+ property $+ do+ f <- forAll genForest+ parseEither outputForestFromJSON (outputForestToJSON f) === Right f+ length (concatMap toList f) === length (concatMap flatten f)++prop_gitDetailsJson :: Property+prop_gitDetailsJson =+ property $+ do+ g <- forAll genGitDetails+ fromJSON (toJSON g) === Aeson.Success g++prop_imageInfoJson :: Property+prop_imageInfoJson =+ property $+ do+ i <- forAll genImageInfo+ fromJSON (toJSON i) === Aeson.Success i
+ test/doctest_tests.hs view
@@ -0,0 +1,38 @@+import Control.Monad (unless)+import System.Exit (ExitCode (..), exitFailure)+import System.Process (rawSystem)++main :: IO ()+main = do+ results <-+ mapM+ ( \f ->+ rawSystem+ "cabal"+ [ "exec"+ , "--"+ , "doctest"+ , "-isrc"+ , "-package=filepather"+ , f+ ]+ )+ [ "src/Document/Build/Build.hs"+ , "src/Document/Build/Documents.hs"+ , "src/Document/Build/Error.hs"+ , "src/Document/Build/File.hs"+ , "src/Document/Build/Git.hs"+ , "src/Document/Build/Hash.hs"+ , "src/Document/Build.hs"+ , "src/Document/Build/Image.hs"+ , "src/Document/Build/LibreOffice.hs"+ , "src/Document/Build/Operations.hs"+ , "src/Document/Build/Output.hs"+ , "src/Document/Build/Pandoc.hs"+ , "src/Document/Build/Context.hs"+ , "src/Document/Build/Pdf.hs"+ , "src/Document/Build/Project.hs"+ , "src/Document/Build/Replace.hs"+ , "src/Document/Build/Rules.hs"+ ]+ unless (all (== ExitSuccess) results) exitFailure
+ test/hedgehog_tests.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE OverloadedStrings #-}++import BuildTests (buildTests)+import Control.Monad (unless)+import Hedgehog (Group (..), checkParallel)+import OutputTests (outputTests)+import System.Exit (exitFailure)+import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)++main :: IO ()+main = do+ hSetBuffering stdout LineBuffering+ hSetBuffering stderr LineBuffering++ result <-+ and+ <$> mapM+ checkParallel+ [ Group "Document.Build" buildTests+ , Group "Output" outputTests+ ]++ unless result exitFailure