filepather-0.7.0.0: src/System/FilePather/Tracked.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
-- Required for the MonadState, MonadWriter and MonadError instances: the
-- functional dependency of each class (for example, m -> s) is not covered by
-- the instance head MonadState s (Tracked f), because s does not occur in
-- Tracked f.
-- Terminates: each instance context is the same class at f, which is a strict
-- subterm of the instance head Tracked f, so resolution moves to a smaller
-- type at each step.
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wall #-}

{- | Named build steps that record the files they make, so that a chain of
build steps that would go round in a cycle is stopped before it does.

@
newtype Tracked f a =
  Tracked (FilePather (ReaderT Trail (ExceptT Cycle f)) (Outputs, a))
@

A 'Tracked' value is run on a file path, with the 'Trail' of that file: the
steps that built it. It produces its result, and the files it made, each with
the 'Step' that made it. Make one from a 'FilePather' with 'step', which
names the step and checks it against the trail before it runs, or 'step'',
which checks after it runs, for steps whose outputs are known only then.

'Tracked' is separate from 'FilePather', so that 'FilePather' keeps all of
its instances: tracking adds a result to the function, so 'Tracked' has no
'Data.Distributive.Distributive' or 'Data.Functor.Rep.Representable'
instance, and its 'Alt', 'Alternative', 'Semigroup' and 'MonadError'
instances are written so that a 'Cycle' is never caught or discarded.
-}
module System.FilePather.Tracked (
  -- * Types
  Outputs,
  Tracked (..),
  Tracked',

  -- * Steps
  step,
  stepWith,
  step',
  stepWith',
  untracked,

  -- * Combinators
  askTrail,
  onPath,
  whenPath,
  whenTrail,
  hoistTracked,

  -- * Optics
  trackedFunction,
  GetTracked (..),
  HasTracked (..),
  ReviewTracked (..),
  AsTracked (..),

  -- * Fusion workers
  mapTracked,
  mapMaybeTracked,
) where

import Control.Applicative (Alternative (..))
import Control.DeepSeq (NFData)
import Control.Lens (Getter, Iso, Lens', Prism', Review, Rewrapped, Wrapped (..), from, iso, lens, over, prism', review, unto, view, _Wrapped)
import Control.Monad (MonadPlus)
import Control.Monad.Error.Class (MonadError (..))
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Reader (ReaderT (..))
import Control.Monad.Reader.Class (MonadReader (..))
import Control.Monad.State.Class (MonadState (..))
import Control.Monad.Trans.Class (MonadTrans (..))
import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
import Control.Monad.Writer.Class (MonadWriter (..))
import Control.Selective (Selective (..), selectM)
import Data.Bifunctor (first)
import Data.Bool (bool)
import Data.Functor.Alt (Alt (..))
import Data.Functor.Apply (Apply (..))
import Data.Functor.Bind (Bind (..))
import Data.Functor.Contravariant (Contravariant (..))
import Data.Functor.Identity (Identity)
import Data.Functor.Plus (Plus (..))
import Data.Kind (Type)
import GHC.Generics (Generic)
import System.FilePather.FilePather (FilePather (..))
import System.FilePather.Trail (Cycle, Repetition (..), Step (..), Trail, checkStep)
import Witherable (Filterable (..))

{- $setup
>>> import Control.Lens (view)
>>> import Control.Monad.Reader (asks)
>>> import Data.Functor.Identity (Identity (..))
>>> import System.FilePath (replaceExtension)
>>> import System.FilePather.Trail
>>> let run x t p = runIdentity (view trackedFunction x t p)
-}

{- | The files that build steps made, each with the step that made it.

@since 0.7.0.0
-}
type Outputs = [(FilePath, Step)]

{- | A build step, or several, that records the files it makes.

==== __Examples__

>>> let pdf = step "markdown to pdf" (\p -> [replaceExtension p "pdf"]) (asks length) :: Tracked Identity Int
>>> run pdf (Trail []) "src/a.md"
Right ([("src/a.pdf",Step "markdown to pdf" "src/a.md")],8)

>>> run pdf (Trail [Step "markdown to pdf" "src/b.md"]) "src/a.md"
Left (RepeatsStep (Step "markdown to pdf" "src/a.md") (Trail [Step "markdown to pdf" "src/b.md"]))

@since 0.7.0.0
-}
type Tracked :: (Type -> Type) -> Type -> Type
newtype Tracked f a
  = Tracked (FilePather (ReaderT Trail (ExceptT Cycle f)) (Outputs, a))
  deriving stock (Generic)
  deriving newtype (NFData)

{- | A 'Tracked' value without effects.

@since 0.7.0.0
-}
type Tracked' a = Tracked Identity a

{- | The isomorphism between a 'Tracked' value and the function it is: from
the trail of a file and its path, to the result and the files it made, or the
'Cycle' that stopped it.

>>> run (pure 'x') (Trail []) "a.md"
Right ([],'x')

@since 0.7.0.0
-}
trackedFunction :: Iso (Tracked f a) (Tracked g b) (Trail -> FilePath -> f (Either Cycle (Outputs, a))) (Trail -> FilePath -> g (Either Cycle (Outputs, b)))
trackedFunction =
  iso
    (\(Tracked (FilePather k)) t p -> runExceptT (runReaderT (k p) t))
    (\h -> Tracked (FilePather (\p -> ReaderT (ExceptT . (`h` p)))))
{-# INLINE trackedFunction #-}

-- | Make a 'Tracked' value from its function.
tracked :: (Trail -> FilePath -> f (Either Cycle (Outputs, a))) -> Tracked f a
tracked =
  view (from trackedFunction)
{-# INLINE tracked #-}

-- | Run a 'Tracked' value as its function.
runTracked :: Tracked f a -> Trail -> FilePath -> f (Either Cycle (Outputs, a))
runTracked =
  view trackedFunction
{-# INLINE runTracked #-}

-- | Bind for 'Tracked': the outputs of both are kept, and a 'Cycle' stops.
bindTracked :: (Monad f) => Tracked f a -> (a -> Tracked f b) -> Tracked f b
bindTracked m k =
  tracked $ \t p ->
    runTracked m t p
      >>= either
        (pure . Left)
        (\(os, a) -> fmap (fmap (first (os <>))) (runTracked (k a) t p))
{-# INLINE bindTracked #-}

{- | Map over the result of a 'Tracked' value. This is 'fmap', and is the
function that the fusion rules match.

>>> run (mapTracked (+ 1) (pure 1)) (Trail []) "a.md"
Right ([],2)

@since 0.7.0.0
-}
mapTracked :: (Functor f) => (a -> b) -> Tracked f a -> Tracked f b
mapTracked g =
  over trackedFunction (\h t p -> fmap (fmap (fmap g)) (h t p))
{-# NOINLINE [1] mapTracked #-}

{- | Filter and map over the result of a 'Tracked' value. This is
'mapMaybe', and is the function that the fusion rules match. A result that is
filtered out is removed in @f@, as 'mapMaybe' of @f@ removes it, with the
files it made. A 'Cycle' is never removed.

@since 0.7.0.0
-}
mapMaybeTracked :: (Filterable f) => (a -> Maybe b) -> Tracked f a -> Tracked f b
mapMaybeTracked g =
  over trackedFunction (\h t p -> mapMaybe (traverse (traverse g)) (h t p))
{-# NOINLINE [1] mapMaybeTracked #-}

{-# RULES
"mapTracked/mapTracked" [~1] forall f g x.
  mapTracked f (mapTracked g x) =
    mapTracked (f . g) x
"mapMaybeTracked/mapMaybeTracked" [~1] forall f g x.
  mapMaybeTracked f (mapMaybeTracked g x) =
    mapMaybeTracked (\a -> g a >>= f) x
"mapMaybeTracked/mapTracked" [~1] forall f g x.
  mapMaybeTracked f (mapTracked g x) =
    mapMaybeTracked (f . g) x
  #-}

-- | @since 0.7.0.0
instance (Functor f) => Functor (Tracked f) where
  fmap =
    mapTracked
  {-# INLINE fmap #-}

{- | Both are run on the same file path, and the outputs of both are kept. A
'Cycle' in the first stops the second from running.

@since 0.7.0.0
-}
instance (Monad f) => Apply (Tracked f) where
  mf <.> mx =
    bindTracked mf (`mapTracked` mx)
  {-# INLINE (<.>) #-}

-- | @since 0.7.0.0
instance (Monad f) => Applicative (Tracked f) where
  pure a =
    tracked (\_ _ -> pure (Right ([], a)))
  {-# INLINE pure #-}
  (<*>) =
    (<.>)
  {-# INLINE (<*>) #-}

-- | @since 0.7.0.0
instance (Monad f) => Bind (Tracked f) where
  (>>-) =
    bindTracked
  {-# INLINE (>>-) #-}

-- | @since 0.7.0.0
instance (Monad f) => Monad (Tracked f) where
  (>>=) =
    bindTracked
  {-# INLINE (>>=) #-}

-- | @since 0.7.0.0
instance (Monad f) => Selective (Tracked f) where
  select =
    selectM
  {-# INLINE select #-}

{- | Alternation in @f@: the second is run only if the first fails in @f@. A
'Cycle' is a result in @f@, not a failure, so it is never caught.

@since 0.7.0.0
-}
instance (Alt f) => Alt (Tracked f) where
  x <!> y =
    tracked (\t p -> runTracked x t p <!> runTracked y t p)
  {-# INLINE (<!>) #-}

-- | @since 0.7.0.0
instance (Plus f) => Plus (Tracked f) where
  zero =
    tracked (\_ _ -> zero)
  {-# INLINE zero #-}

{- | As for 'Alt', a 'Cycle' is never caught.

@since 0.7.0.0
-}
instance (Alternative f, Monad f) => Alternative (Tracked f) where
  empty =
    tracked (\_ _ -> empty)
  {-# INLINE empty #-}
  x <|> y =
    tracked (\t p -> runTracked x t p <|> runTracked y t p)
  {-# INLINE (<|>) #-}

-- | @since 0.7.0.0
instance (MonadPlus f) => MonadPlus (Tracked f)

{- | Both are run on the same file path, their results are combined, and the
outputs of both are kept. A 'Cycle' in the first stops the second from
running, and is the result.

@since 0.7.0.0
-}
instance (Monad f, Semigroup a) => Semigroup (Tracked f a) where
  x <> y =
    (<>) <$> x <*> y
  {-# INLINE (<>) #-}

-- | @since 0.7.0.0
instance (Monad f, Monoid a) => Monoid (Tracked f a) where
  mempty =
    pure mempty
  {-# INLINE mempty #-}

-- | @since 0.7.0.0
instance (Filterable f) => Filterable (Tracked f) where
  mapMaybe =
    mapMaybeTracked
  {-# INLINE mapMaybe #-}

{- | An effect of @f@, which makes no files.

@since 0.7.0.0
-}
instance MonadTrans Tracked where
  lift m =
    tracked (\_ _ -> fmap (\a -> Right ([], a)) m)
  {-# INLINE lift #-}

-- | @since 0.7.0.0
instance (MonadIO f) => MonadIO (Tracked f) where
  liftIO =
    lift . liftIO
  {-# INLINE liftIO #-}

-- | @since 0.7.0.0
instance (MonadFail f) => MonadFail (Tracked f) where
  fail =
    lift . fail
  {-# INLINE fail #-}

{- | 'ask' is the file path being operated on, and 'local' runs on another
file path, with the same trail.

@since 0.7.0.0
-}
instance (Monad f) => MonadReader FilePath (Tracked f) where
  ask =
    tracked (\_ p -> pure (Right ([], p)))
  {-# INLINE ask #-}
  local g x =
    tracked (\t -> runTracked x t . g)
  {-# INLINE local #-}

{- | The state of @f@.

@since 0.7.0.0
-}
instance (MonadState s f) => MonadState s (Tracked f) where
  state =
    lift . state
  {-# INLINE state #-}

{- | The errors of @f@. 'catchError' catches the errors of @f@, and never a
'Cycle'.

@since 0.7.0.0
-}
instance (MonadError e f) => MonadError e (Tracked f) where
  throwError =
    lift . throwError
  {-# INLINE throwError #-}
  catchError x h =
    tracked (\t p -> catchError (runTracked x t p) (\e -> runTracked (h e) t p))
  {-# INLINE catchError #-}

{- | The output of @f@, which is separate from the files that steps make.

@since 0.7.0.0
-}
instance (MonadWriter w f) => MonadWriter w (Tracked f) where
  writer =
    lift . writer
  {-# INLINE writer #-}
  tell =
    lift . tell
  {-# INLINE tell #-}
  listen x =
    tracked (\t p -> fmap (\(r, w) -> fmap (fmap (,w)) r) (listen (runTracked x t p)))
  {-# INLINE listen #-}
  pass x =
    tracked $ \t p ->
      pass
        ( fmap
            ( either
                (\c -> (Left c, id))
                (\(os, (a, g)) -> (Right (os, a), g))
            )
            (runTracked x t p)
        )
  {-# INLINE pass #-}

-- | @since 0.7.0.0
instance (Contravariant f) => Contravariant (Tracked f) where
  contramap g =
    over trackedFunction (\h t p -> contramap (fmap (fmap g)) (h t p))
  {-# INLINE contramap #-}

-- | @since 0.7.0.0
instance Wrapped (Tracked f a) where
  type Unwrapped (Tracked f a) = FilePather (ReaderT Trail (ExceptT Cycle f)) (Outputs, a)
  _Wrapped' =
    iso (\(Tracked x) -> x) Tracked
  {-# INLINE _Wrapped' #-}

-- | @since 0.7.0.0
instance (t ~ Tracked g b) => Rewrapped (Tracked f a) t

{- | A named step that makes the files given by a function of its input file,
and may appear 'Once' in a trail. See 'stepWith'.

@since 0.7.0.0
-}
step :: (Applicative f) => String -> (FilePath -> [FilePath]) -> FilePather f a -> Tracked f a
step =
  stepWith Once
{-# INLINE step #-}

{- | A named step that makes the files given by a function of its input file.
The step is checked against the trail of its input file with 'checkStep'
before it runs: if it is stopped, the 'FilePather' is not run.

>>> let page1 = stepWith Once "pdf page 1" (\p -> [p <> ".page1.pdf"]) (pure ()) :: Tracked Identity ()
>>> run page1 (Trail [Step "markdown to pdf" "a.md"]) "a.pdf"
Right ([("a.pdf.page1.pdf",Step "pdf page 1" "a.pdf")],())

>>> run page1 (Trail [Step "pdf page 1" "a.pdf"]) "a.pdf.page1.pdf"
Left (RepeatsStep (Step "pdf page 1" "a.pdf.page1.pdf") (Trail [Step "pdf page 1" "a.pdf"]))

@since 0.7.0.0
-}
stepWith :: (Applicative f) => Repetition -> String -> (FilePath -> [FilePath]) -> FilePather f a -> Tracked f a
stepWith r n outs x =
  tracked $ \t p ->
    let s = Step n p
        os = outs p
     in either
          (pure . Left)
          (\() -> fmap (\a -> Right (fmap (,s) os, a)) (view _Wrapped x p))
          (checkStep r s os t)
{-# INLINE stepWith #-}

{- | A named step that returns the files it made, and may appear 'Once' in a
trail. See 'stepWith''.

@since 0.7.0.0
-}
step' :: (Functor f) => String -> FilePather f ([FilePath], a) -> Tracked f a
step' =
  stepWith' Once
{-# INLINE step' #-}

{- | A named step that returns the files it made, for a step whose outputs are
known only after it runs, such as an image for each page of a PDF file. The
step is checked against the trail of its input file with 'checkStep' after it
runs, so it cannot be stopped before it runs, but its outputs are not passed
on.

>>> let pages = stepWith' Once "pdf pages" (asks (\p -> ([p <> "-0.png", p <> "-1.png"], ()))) :: Tracked Identity ()
>>> run pages (Trail []) "a.pdf"
Right ([("a.pdf-0.png",Step "pdf pages" "a.pdf"),("a.pdf-1.png",Step "pdf pages" "a.pdf")],())

@since 0.7.0.0
-}
stepWith' :: (Functor f) => Repetition -> String -> FilePather f ([FilePath], a) -> Tracked f a
stepWith' r n x =
  tracked $ \t p ->
    let s = Step n p
     in fmap (\(os, a) -> fmap (\() -> (fmap (,s) os, a)) (checkStep r s os t)) (view _Wrapped x p)
{-# INLINE stepWith' #-}

{- | A 'FilePather' that makes no files, such as one that gets information
about a file, or a condition.

>>> run (untracked (asks length)) (Trail []) "a.md"
Right ([],4)

@since 0.7.0.0
-}
untracked :: (Functor f) => FilePather f a -> Tracked f a
untracked x =
  tracked (\_ p -> fmap (\a -> Right ([], a)) (view _Wrapped x p))
{-# INLINE untracked #-}

{- | The trail of the file being operated on.

>>> run askTrail (Trail [Step "prepare" "src/a.md"]) "public/a.md"
Right ([],Trail [Step "prepare" "src/a.md"])

@since 0.7.0.0
-}
askTrail :: (Applicative f) => Tracked f Trail
askTrail =
  tracked (\t _ -> pure (Right ([], t)))
{-# INLINE askTrail #-}

{- | Run on the given file path, instead of the one being operated on, with
the same trail. This is 'local' with a constant function.

@since 0.7.0.0
-}
onPath :: FilePath -> Tracked f a -> Tracked f a
onPath q x =
  tracked (\t _ -> runTracked x t q)
{-# INLINE onPath #-}

{- | Run only on file paths that satisfy a predicate. On other file paths, the
result is 'mempty' and no files are made.

>>> let md = whenPath (\p -> p == "a.md") (step "copy" (\p -> [p <> ".bak"]) (pure ())) :: Tracked Identity ()
>>> run md (Trail []) "a.md"
Right ([("a.md.bak",Step "copy" "a.md")],())

>>> run md (Trail []) "a.txt"
Right ([],())

@since 0.7.0.0
-}
whenPath :: (Applicative f, Monoid a) => (FilePath -> Bool) -> Tracked f a -> Tracked f a
whenPath f x =
  tracked (\t p -> bool (pure (Right ([], mempty))) (runTracked x t p) (f p))
{-# INLINE whenPath #-}

{- | Run only on files whose trail satisfies a predicate, such as files made
by a particular step. On other files, the result is 'mempty' and no files are
made.

@since 0.7.0.0
-}
whenTrail :: (Applicative f, Monoid a) => (Trail -> Bool) -> Tracked f a -> Tracked f a
whenTrail f x =
  tracked (\t p -> bool (pure (Right ([], mempty))) (runTracked x t p) (f t))
{-# INLINE whenTrail #-}

{- | Change the type constructor of a 'Tracked' value with a natural
transformation.

@since 0.7.0.0
-}
hoistTracked :: (forall x. f x -> g x) -> Tracked f a -> Tracked g a
hoistTracked nat =
  over trackedFunction (\h t -> nat . h t)
{-# INLINE hoistTracked #-}

-- | @since 0.7.0.0
class GetTracked s f a | s -> f a where
  getTracked :: Getter s (Tracked f a)

-- | @since 0.7.0.0
instance GetTracked (Tracked f a) f a where
  getTracked =
    id
  {-# INLINE getTracked #-}

-- | @since 0.7.0.0
class (GetTracked s f a) => HasTracked s f a | s -> f a where
  {-# MINIMAL setTracked #-}
  setTracked :: Tracked f a -> s -> s

  trackedLens :: Lens' s (Tracked f a)
  trackedLens =
    lens (view getTracked) (flip setTracked)
  {-# INLINE trackedLens #-}

-- | @since 0.7.0.0
instance HasTracked (Tracked f a) f a where
  setTracked =
    const
  {-# INLINE setTracked #-}

-- | @since 0.7.0.0
class ReviewTracked t f a | t -> f a where
  reviewTracked :: Review t (Tracked f a)

-- | @since 0.7.0.0
instance ReviewTracked (Tracked f a) f a where
  reviewTracked =
    unto id
  {-# INLINE reviewTracked #-}

-- | @since 0.7.0.0
class (ReviewTracked t f a) => AsTracked t f a | t -> f a where
  {-# MINIMAL matchTracked #-}
  matchTracked :: t -> Maybe (Tracked f a)

  _Tracked :: Prism' t (Tracked f a)
  _Tracked =
    prism' (review reviewTracked) matchTracked
  {-# INLINE _Tracked #-}

-- | @since 0.7.0.0
instance AsTracked (Tracked f a) f a where
  matchTracked =
    Just
  {-# INLINE matchTracked #-}