Cycle.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wall #-}

{- | Why a chain of build steps is stopped.

A 'Cycle' is a sum: its constructors are named 'reproducesInput' and
'repeatsStep', the default names of the types they hold, and it inherits the
names of both. The names it reaches through both constructors ('step',
'trail', 'stepName', 'stepInput' and 'steps') are affine traversals.
-}
module System.FilePather.Cycle (
  -- * Type
  Cycle (..),

  -- * Cycles
  checkStep,
  displayCycle,

  -- * Optics
  CycleLike (..),
  lawNamesCycle,
  InheritCycle,
  inheritCycle,
  inheritsCycle,
) where

import Control.DeepSeq (NFData)
import Control.Lens (Choice, Optic, cloneLens, each, prism', review, toListOf, view)
import Data.Data (Data)
import Data.Functor.Const (Const)
import Data.List (find, intercalate)
import Data.Proxy (Proxy (..))
import GHC.Generics (Generic)
import System.FilePath (normalise)
import System.FilePather.Name.File (FileLike (..))
import System.FilePather.Name.StepInput (StepInputLike (..))
import System.FilePather.Name.StepName (StepNameLike (..))
import System.FilePather.Name.Steps (StepsLike (..))
import System.FilePather.RepeatsStep (RepeatsStep (..), RepeatsStepLike (..), inheritRepeatsStep)
import System.FilePather.Repetition (Repetition (..))
import System.FilePather.ReproducesInput (ReproducesInput (..), ReproducesInputLike (..), inheritReproducesInput)
import System.FilePather.Step (Step (..), StepLike (..))
import System.FilePather.Trail (Trail (..), TrailLike (..), trailFiles)
import Prelude hiding (cycle)

{- $setup
>>> import Control.Lens (preview, review)
-}

{- | Why a chain of build steps is stopped, with the step that is stopped and
the trail of its input file.

>>> review repeatsStep (RepeatsStep (Step "pdf page 1" "a_page1.pdf") (Trail [])) :: Cycle
CycleRepeatsStep (RepeatsStep (Step "pdf page 1" "a_page1.pdf") (Trail []))

>>> preview step (CycleRepeatsStep (RepeatsStep (Step "pdf page 1" "a_page1.pdf") (Trail [])))
Just (Step "pdf page 1" "a_page1.pdf")

@since 0.7.0.0
-}
data Cycle
  = -- | The step would make a file that is already in the chain: its input
    -- file, or an input file of a step in the trail ('reproducesInput').
    CycleReproducesInput ReproducesInput
  | -- | The step is already in the trail ('repeatsStep').
    CycleRepeatsStep RepeatsStep
  deriving stock (Eq, Ord, Show, Generic, Data)
  deriving anyclass (NFData)

{- | The class of 'Cycle'.

@since 0.8.0.0
-}
class CycleLike p f x x' where
  cycle ::
    Optic p f x x' Cycle Cycle

{- | Identity

@since 0.8.0.0
-}
instance (x' ~ Cycle) => CycleLike p f Cycle x' where
  cycle =
    id
  {-# INLINE cycle #-}

{- | Prism: 'reproducesInput' is the default name of 'CycleReproducesInput'.

@since 0.8.0.0
-}
instance (Choice p, Applicative f, x' ~ Cycle) => ReproducesInputLike p f Cycle x' where
  reproducesInput =
    prism' CycleReproducesInput (\case CycleReproducesInput r -> Just r; CycleRepeatsStep _ -> Nothing)
  {-# INLINE reproducesInput #-}

{- | Prism: 'repeatsStep' is the default name of 'CycleRepeatsStep'.

@since 0.8.0.0
-}
instance (Choice p, Applicative f, x' ~ Cycle) => RepeatsStepLike p f Cycle x' where
  repeatsStep =
    prism' CycleRepeatsStep (\case CycleRepeatsStep r -> Just r; CycleReproducesInput _ -> Nothing)
  {-# INLINE repeatsStep #-}

{- | Affine traversal: through 'CycleReproducesInput', a prism, then
'ReproducesInput''s 'file', a lens.

@since 0.8.0.0
-}
instance (p ~ (->), Applicative f, x' ~ Cycle) => FileLike p f Cycle x' where
  file =
    reproducesInput . file
  {-# INLINE file #-}

{- | Affine traversal: 'step' is reached through both constructors, once each.

@since 0.8.0.0
-}
instance (p ~ (->), Applicative f, x' ~ Cycle) => StepLike p f Cycle x' where
  step f = \case
    CycleReproducesInput r -> CycleReproducesInput <$> step f r
    CycleRepeatsStep r -> CycleRepeatsStep <$> step f r
  {-# INLINE step #-}

{- | Affine traversal: 'trail' is reached through both constructors, once
each.

@since 0.8.0.0
-}
instance (p ~ (->), Applicative f, x' ~ Cycle) => TrailLike p f Cycle x' where
  trail f = \case
    CycleReproducesInput r -> CycleReproducesInput <$> trail f r
    CycleRepeatsStep r -> CycleRepeatsStep <$> trail f r
  {-# INLINE trail #-}

{- | Affine traversal: 'stepName' is reached through both constructors, once
each.

@since 0.8.0.0
-}
instance (p ~ (->), Applicative f, x' ~ Cycle) => StepNameLike p f Cycle x' where
  stepName f = \case
    CycleReproducesInput r -> CycleReproducesInput <$> stepName f r
    CycleRepeatsStep r -> CycleRepeatsStep <$> stepName f r
  {-# INLINE stepName #-}

{- | Affine traversal: 'stepInput' is reached through both constructors, once
each.

@since 0.8.0.0
-}
instance (p ~ (->), Applicative f, x' ~ Cycle) => StepInputLike p f Cycle x' where
  stepInput f = \case
    CycleReproducesInput r -> CycleReproducesInput <$> stepInput f r
    CycleRepeatsStep r -> CycleRepeatsStep <$> stepInput f r
  {-# INLINE stepInput #-}

{- | Affine traversal: 'steps' is reached through both constructors, once
each.

@since 0.8.0.0
-}
instance (p ~ (->), Applicative f, x' ~ Cycle) => StepsLike p f Cycle x' where
  steps f = \case
    CycleReproducesInput r -> CycleReproducesInput <$> steps f r
    CycleRepeatsStep r -> CycleRepeatsStep <$> steps f r
  {-# INLINE steps #-}

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

Laws:

> lawNamesCycle == id

@since 0.8.0.0
-}
lawNamesCycle :: Cycle -> Cycle
lawNamesCycle = \case
  CycleReproducesInput r -> review reproducesInput r
  CycleRepeatsStep r -> review repeatsStep r

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

@since 0.8.0.0
-}
type InheritCycle s =
  ( CycleLike (->) (Const ()) s s
  , ReproducesInputLike (->) (Const ()) s s
  , RepeatsStepLike (->) (Const ()) s s
  , FileLike (->) (Const ()) s s
  , StepLike (->) (Const ()) s s
  , TrailLike (->) (Const ()) s s
  , StepNameLike (->) (Const ()) s s
  , StepInputLike (->) (Const ()) s s
  , StepsLike (->) (Const ()) s s
  )

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

@since 0.8.0.0
-}
inheritCycle :: (InheritCycle s) => proxy s -> ()
inheritCycle _ =
  ()

{- | 'Cycle' inherits every name of 'ReproducesInput' and of 'RepeatsStep'.

@since 0.8.0.0
-}
inheritsCycle :: [()]
inheritsCycle =
  let p = Proxy :: Proxy Cycle
   in [inheritReproducesInput p, inheritRepeatsStep p]

{- | Check a step, with the files it makes, against the trail of its input
file. A step that is already in the trail, and may appear 'Once', is a
'CycleRepeatsStep'. Otherwise, a step that makes its input file, or the input
file of a step in the trail, is a 'CycleReproducesInput'. File paths are
compared after normalisation.

>>> let t = Trail [Step "markdown to pdf" "src/a.md"]
>>> checkStep Once (Step "pdf page 1" "public/a.pdf") ["public/a_page1.pdf"] t
Right ()

>>> checkStep Once (Step "markdown to pdf" "public/a.pdf") ["public/b.pdf"] t
Left (CycleRepeatsStep (RepeatsStep (Step "markdown to pdf" "public/a.pdf") (Trail [Step "markdown to pdf" "src/a.md"])))

>>> checkStep Repeatable (Step "markdown to pdf" "public/a.pdf") ["public/b.pdf"] t
Right ()

>>> checkStep Once (Step "pdf to markdown" "public/a.pdf") ["./src/a.md"] t
Left (CycleReproducesInput (ReproducesInput "./src/a.md" (Step "pdf to markdown" "public/a.pdf") (Trail [Step "markdown to pdf" "src/a.md"])))

@since 0.7.0.0
-}
checkStep :: Repetition -> Step -> [FilePath] -> Trail -> Either Cycle ()
checkStep r s os t =
  let repeated =
        case r of
          Once -> view (cloneLens stepName) s `elem` toListOf (each . stepName) t
          Repeatable -> False
      files = fmap normalise (view (cloneLens stepInput) s : toListOf trailFiles t)
   in if repeated
        then Left (review repeatsStep (RepeatsStep s t))
        else maybe (Right ()) (\o -> Left (review reproducesInput (ReproducesInput o s t))) (find ((`elem` files) . normalise) os)

{- | A description of a cycle, for people to read: the chain of files and
steps from the source file.

>>> putStrLn (displayCycle (CycleRepeatsStep (RepeatsStep (Step "pdf page 1" "public/a_page1.pdf") (Trail [Step "pdf page 1" "public/a.pdf", Step "markdown to pdf" "src/a.md"]))))
src/a.md → markdown to pdf → public/a.pdf → pdf page 1 → public/a_page1.pdf → pdf page 1 again

>>> putStrLn (displayCycle (CycleReproducesInput (ReproducesInput "src/a.md" (Step "pdf to markdown" "public/a.pdf") (Trail [Step "markdown to pdf" "src/a.md"]))))
src/a.md → markdown to pdf → public/a.pdf → pdf to markdown → src/a.md, which is already in the chain

@since 0.7.0.0
-}
displayCycle :: Cycle -> String
displayCycle c =
  let chain t = concatMap (\s -> [view (cloneLens stepInput) s, view (cloneLens stepName) s]) (reverse (view (cloneLens steps) t))
      arrows = intercalate " → "
   in case c of
        CycleRepeatsStep r ->
          arrows (chain (view (cloneLens trail) r) <> [view (cloneLens stepInput) r, view (cloneLens stepName) r <> " again"])
        CycleReproducesInput r ->
          arrows (chain (view (cloneLens trail) r) <> [view (cloneLens stepInput) r, view (cloneLens stepName) r, view (cloneLens file) r]) <> ", which is already in the chain"