Context.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# 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")])
@


A 'Context' is a product: its fields are named 'directories', 'contextProject' and 'target'.
It holds 'Directories' and 'Target', so it inherits their names.
-}
module Document.Build.Context (
  -- * Type
  Context (..),

  -- * Rules
  Rules,
  fromTracked,
  buildStep,
  buildStep',

  -- * Choosing files
  onProject,
  onProjects,
  withProject,
  onPaths,
  onFiles,
  onDirectories,
  onComplete,
  onSources,
  onOutputs,
  afterStep,
  unlessAfterStep,

  -- * Optics
  ContextLike (..),
  lawNamesContext,
  InheritContext,
  inheritContext,
  inheritsContext,
) where

import Control.DeepSeq (NFData)
import Control.Lens (Optic, cloneLens, preview, view)
import Data.Bool (bool)
import Data.Data (Data)
import Data.Functor.Const (Const)
import Data.Proxy (Proxy (..))
import Document.Build.Build (Build', Command', io)
import Document.Build.Directories (Directories, DirectoriesLike (..), inheritDirectories)
import Document.Build.Name.ContextProject (ContextProjectLike (..))
import Document.Build.Name.FontsDirectory (FontsDirectoryLike (..))
import Document.Build.Name.InputDirectories (InputDirectoriesLike (..))
import Document.Build.Name.OutputDirectory (OutputDirectoryLike (..))
import Document.Build.Name.TargetComplete (TargetCompleteLike (..))
import Document.Build.Name.TargetDirectory (TargetDirectoryLike (..))
import Document.Build.Name.TargetFile (TargetFileLike (..))
import Document.Build.Target (KnownFiles, Target, TargetLike (..), inheritTarget)
import GHC.Generics (Generic)
import System.Directory (doesFileExist)
import System.FilePather.Combinators (isWithin)
import System.FilePather.FilePather (FilePather (..))
import System.FilePather.Name.PathFunction (PathFunctionLike (..))
import System.FilePather.Name.StepName (stepName)
import System.FilePather.Tracked (Tracked, track, track', whenPath, whenTrail)
import System.FilePather.Trail (lastStep)

{- $setup
>>> import Control.Lens (cloneLens, preview, view)
>>> import Document.Build.Directories (Directories (..))
>>> import Document.Build.Target (Target (..))
-}

{- | The context that rules are run in: the directories of the build
('directories'), the path of the project ('contextProject', see
'Document.Build.Project.projectPath'), and what the rules are running on
('target').

>>> view (cloneLens outputDirectory) (Context (Directories "public" ["src"] Nothing) "group/project" TargetFile)
"public"

>>> preview targetFile (Context (Directories "public" ["src"] Nothing) "group/project" TargetFile)
Just ()

@since 0.1.0.0
-}
data Context
  = Context Directories String Target
  deriving stock (Eq, Ord, Show, Generic, Data)
  deriving anyclass (NFData)

{- | The class of 'Context'.

@since 0.2.0.0
-}
class ContextLike p f x x' where
  context ::
    Optic p f x x' Context Context

{- | Identity

@since 0.2.0.0
-}
instance (x' ~ Context) => ContextLike p f Context x' where
  context =
    id
  {-# INLINE context #-}

{- | Lens: 'directories' is the default name of the field of type 'Directories'.

@since 0.2.0.0
-}
instance (p ~ (->), Functor f, x' ~ Context) => DirectoriesLike p f Context x' where
  directories f (Context x1 x2 x3) =
    fmap (\x1' -> Context x1' x2 x3) (f x1)
  {-# INLINE directories #-}

{- | Lens

@since 0.2.0.0
-}
instance (p ~ (->), Functor f, x' ~ Context) => ContextProjectLike p f Context x' where
  contextProject f (Context x1 x2 x3) =
    fmap (\x2' -> Context x1 x2' x3) (f x2)
  {-# INLINE contextProject #-}

{- | Lens: 'target' is the default name of the field of type 'Target'.

@since 0.2.0.0
-}
instance (p ~ (->), Functor f, x' ~ Context) => TargetLike p f Context x' where
  target f (Context x1 x2 x3) =
    fmap (Context x1 x2) (f x3)
  {-# INLINE target #-}

{- | Lens: through 'directories', a lens, then 'Directories''s 'outputDirectory', a lens.

@since 0.2.0.0
-}
instance (p ~ (->), Functor f, x' ~ Context) => OutputDirectoryLike p f Context x' where
  outputDirectory =
    directories . outputDirectory
  {-# INLINE outputDirectory #-}

{- | Lens: through 'directories', a lens, then 'Directories''s 'inputDirectories', a lens.

@since 0.2.0.0
-}
instance (p ~ (->), Functor f, x' ~ Context) => InputDirectoriesLike p f Context x' where
  inputDirectories =
    directories . inputDirectories
  {-# INLINE inputDirectories #-}

{- | Lens: through 'directories', a lens, then 'Directories''s 'fontsDirectory', a lens.

@since 0.2.0.0
-}
instance (p ~ (->), Functor f, x' ~ Context) => FontsDirectoryLike p f Context x' where
  fontsDirectory =
    directories . fontsDirectory
  {-# INLINE fontsDirectory #-}

{- | Affine traversal: through 'target', a lens, then 'Target''s 'targetFile', a prism.

@since 0.2.0.0
-}
instance (p ~ (->), Applicative f, x' ~ Context) => TargetFileLike p f Context x' where
  targetFile =
    target . targetFile
  {-# INLINE targetFile #-}

{- | Affine traversal: through 'target', a lens, then 'Target''s 'targetDirectory', a prism.

@since 0.2.0.0
-}
instance (p ~ (->), Applicative f, x' ~ Context) => TargetDirectoryLike p f Context x' where
  targetDirectory =
    target . targetDirectory
  {-# INLINE targetDirectory #-}

{- | Affine traversal: through 'target', a lens, then 'Target''s 'targetComplete', a prism.

@since 0.2.0.0
-}
instance (p ~ (->), Applicative f, x' ~ Context) => TargetCompleteLike p f Context x' where
  targetComplete =
    target . targetComplete
  {-# INLINE targetComplete #-}

{- | Rebuild a value using only the name of each field.

Laws:

> lawNamesContext == id

@since 0.2.0.0
-}
lawNamesContext :: Context -> Context
lawNamesContext s =
  Context
    (view (cloneLens directories) s)
    (view (cloneLens contextProject) s)
    (view (cloneLens target) s)

{- | The classes that a data type holding 'Context' inherits.

@since 0.2.0.0
-}
type InheritContext s =
  ( ContextLike (->) (Const ()) s s
  , DirectoriesLike (->) (Const ()) s s
  , ContextProjectLike (->) (Const ()) s s
  , TargetLike (->) (Const ()) s s
  , OutputDirectoryLike (->) (Const ()) s s
  , InputDirectoriesLike (->) (Const ()) s s
  , FontsDirectoryLike (->) (Const ()) s s
  , TargetFileLike (->) (Const ()) s s
  , TargetDirectoryLike (->) (Const ()) s s
  , TargetCompleteLike (->) (Const ()) s s
  )

{- | Check, where it is applied, that @s@ inherits every name of 'Context'.

@since 0.2.0.0
-}
inheritContext :: (InheritContext s) => proxy s -> ()
inheritContext _ =
  ()

{- | 'Context' inherits every name of 'Directories' and of 'Target'.

@since 0.2.0.0
-}
inheritsContext :: [()]
inheritsContext =
  let p = Proxy :: Proxy Context
   in [inheritDirectories p, inheritTarget p]

{- | 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.track'.

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 =
  track n outs $
    FilePather $ \p ->
      io (or <$> traverse doesFileExist (outs p))
        >>= bool (view (cloneLens pathFunction) c p) (pure mempty)

{- | A named step that runs a command, which returns the files it made. See
'System.FilePather.Tracked.track''.

@since 0.1.0.0
-}
buildStep' :: String -> Command' [FilePath] -> Tracked Build' ()
buildStep' n c =
  track' 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 (view (cloneLens contextProject) c))
{-# 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 (view (cloneLens contextProject) c) 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 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 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 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 (view (cloneLens outputDirectory) c)) (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 #-}