Combinators.hs

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wall #-}

{- | Combinators for building larger 'FilePather' values from smaller ones.

* Composition: run a 'FilePather' on the output of another, with '~>' and
  '~>>'.
* Rules: a 'Rule' is a 'FilePather' that applies to some file paths and not
  others. Rules combine with 'Control.Applicative.<|>', where the first rule
  that applies is used. Use 'everyFile' to apply a rule to every file in a
  directory.
* Directories: list the files in a directory with 'directoryFiles'.
-}
module System.FilePather.Combinators (
  -- * Composition
  (~>),
  (~>>),
  onFile,
  hoistFilePather,

  -- * Rules
  Rule,
  whenFile,
  rule,
  everyFile,

  -- * Predicates
  hasExtension,
  isFile,
  isWithin,

  -- * Directories
  directoryFiles,
  directoryFilesWhere,
) where

import Control.Applicative (Alternative (empty))
import Control.Lens (over, view, _Wrapped)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Reader (local)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT (..))
import Data.Bool (bool)
import Data.List (isPrefixOf, sort)
import System.Directory (doesDirectoryExist, listDirectory)
import System.FilePath (equalFilePath, isExtensionOf, normalise, splitDirectories, (</>))
import System.FilePather.FilePather (FilePather (..))
import Witherable (wither)

{- $setup
>>> import Control.Applicative ((<|>))
>>> import Control.Lens (view, _Wrapped)
>>> import Control.Monad.Reader (ask, asks)
>>> import Control.Monad.Trans.Maybe (runMaybeT)
>>> import Data.Functor.Identity (Identity (..))
>>> import System.FilePath (replaceExtension)
>>> import System.FilePather.FilePather (FilePather (..))
-}

infixr 1 ~>

infixr 1 ~>>

{- | Run a 'FilePather', then run another on the file path that it produces.

This is composition in the Kleisli category of @f@, at 'FilePath'. It is
associative, with 'Control.Monad.Reader.ask' as the identity.

>>> runIdentity (view _Wrapped (asks (`replaceExtension` "pdf") ~> asks (++ ".png")) "notes.md")
"notes.pdf.png"

@since 0.7.0.0
-}
(~>) :: (Monad f) => FilePather f FilePath -> FilePather f a -> FilePather f a
p ~> q =
  p >>= \o -> local (const o) q
{-# INLINE (~>) #-}

{- | Run a 'FilePather', then run another on each file path that it produces.

>>> view _Wrapped (FilePather (\p -> [[p ++ "-0.png", p ++ "-1.png"]]) ~>> asks length) "a.pdf"
[[11,11]]

@since 0.7.0.0
-}
(~>>) :: (Monad f, Traversable t) => FilePather f (t FilePath) -> FilePather f a -> FilePather f (t a)
p ~>> q =
  p >>= traverse (\o -> local (const o) q)
{-# INLINE (~>>) #-}

{- | Run a 'FilePather' on the given file path, instead of the one being
operated on.

>>> runIdentity (view _Wrapped (onFile "other.md" ask) "notes.md")
"other.md"

@since 0.7.0.0
-}
onFile :: FilePath -> FilePather f a -> FilePather f a
onFile p =
  over _Wrapped (\g -> const (g p))
{-# INLINE onFile #-}

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

>>> view _Wrapped (hoistFilePather (Just . runIdentity) ask) "notes.md"
Just "notes.md"

@since 0.7.0.0
-}
hoistFilePather :: (forall x. f x -> g x) -> FilePather f a -> FilePather g a
hoistFilePather nat =
  over _Wrapped (nat .)
{-# INLINE hoistFilePather #-}

{- | A 'FilePather' that applies to some file paths and not others.

A 'Rule' that does not apply produces 'Nothing' in 'MaybeT'. This is distinct
from failure in @f@: if @f@ is an 'Control.Exitcode.Exitcode' and a rule fails
with an exit code, the failure is not caught by 'Control.Applicative.<|>'.

@since 0.7.0.0
-}
type Rule f a = FilePather (MaybeT f) a

{- | Apply a 'FilePather' only to file paths that satisfy a predicate.

>>> view _Wrapped (whenFile (hasExtension ["md"]) ask) "notes.md" :: Maybe FilePath
Just "notes.md"

>>> view _Wrapped (whenFile (hasExtension ["md"]) ask) "notes.txt" :: Maybe FilePath
Nothing

@since 0.7.0.0
-}
whenFile :: (Alternative f) => (FilePath -> Bool) -> FilePather f a -> FilePather f a
whenFile p =
  over _Wrapped (\g x -> bool empty (g x) (p x))
{-# INLINE whenFile #-}

{- | A 'Rule' that applies a 'FilePather' to file paths that satisfy a
predicate.

>>> let r = rule (isFile "special.md") (pure "special") <|> rule (hasExtension ["md"]) (pure "markdown") :: Rule Identity String
>>> runIdentity (runMaybeT (view _Wrapped r "special.md"))
Just "special"

>>> runIdentity (runMaybeT (view _Wrapped r "notes.md"))
Just "markdown"

>>> runIdentity (runMaybeT (view _Wrapped r "notes.txt"))
Nothing

@since 0.7.0.0
-}
rule :: (Monad f) => (FilePath -> Bool) -> FilePather f a -> Rule f a
rule p =
  whenFile p . hoistFilePather lift
{-# INLINE rule #-}

{- | Apply a 'Rule' to every file path produced by a 'FilePather', such as
'directoryFiles'. The result pairs each file path that the rule applies to
with the result of the rule. File paths that the rule does not apply to are
skipped.

>>> let files = FilePather (\d -> Identity [d ++ "/a.md", d ++ "/b.txt", d ++ "/c.md"])
>>> runIdentity (view _Wrapped (everyFile files (rule (hasExtension ["md"]) (asks length))) "src")
[("src/a.md",8),("src/c.md",8)]

@since 0.7.0.0
-}
everyFile :: (Monad f) => FilePather f [FilePath] -> Rule f a -> FilePather f [(FilePath, a)]
everyFile files r =
  files >>= lift . wither (\p -> runMaybeT (fmap (p,) (view _Wrapped r p)))
{-# INLINE everyFile #-}

{- | Whether a file path has one of the given extensions. An extension may be
given with or without the leading dot.

>>> hasExtension ["fodt", ".odt"] "src/cv.odt"
True

>>> hasExtension ["fodt", "odt"] "src/cv.pdf"
False

@since 0.7.0.0
-}
hasExtension :: [String] -> FilePath -> Bool
hasExtension es p =
  any (`isExtensionOf` p) es
{-# INLINE hasExtension #-}

{- | Whether two file paths are equal, after normalisation.

>>> isFile "src/cv.fodt" "./src//cv.fodt"
True

@since 0.7.0.0
-}
isFile :: FilePath -> FilePath -> Bool
isFile =
  equalFilePath
{-# INLINE isFile #-}

{- | Whether a file path is within a directory, after normalisation.

>>> isWithin "src" "src/a/cv.fodt"
True

>>> isWithin "src/a" "src/b/cv.fodt"
False

>>> isWithin "." "src/cv.fodt"
True

@since 0.7.0.0
-}
isWithin :: FilePath -> FilePath -> Bool
isWithin d p =
  let d' = normalise d
   in d' == "." || splitDirectories d' `isPrefixOf` splitDirectories (normalise p)
{-# INLINE isWithin #-}

{- | The files in a directory and its subdirectories, in sorted order. The
file paths are the directory joined with the path of the file relative to it,
then normalised, so that the files of @"."@ are relative paths, such as
@"src/cv.fodt"@. Symbolic links are followed.

@since 0.7.0.0
-}
directoryFiles :: (MonadIO f) => FilePather f [FilePath]
directoryFiles =
  directoryFilesWhere (const True)
{-# INLINE directoryFiles #-}

{- | The files in a directory, and in each subdirectory that satisfies a
predicate, in sorted order. The predicate is given the normalised path of each
subdirectory.

For example, @directoryFilesWhere (not . isFile ".git")@ skips the @.git@
directory.

@since 0.7.0.0
-}
directoryFilesWhere :: (MonadIO f) => (FilePath -> Bool) -> FilePather f [FilePath]
directoryFilesWhere descend =
  let go d =
        do
          names <- sort <$> listDirectory d
          concat
            <$> traverse
              ( \n ->
                  let p = normalise (d </> n)
                   in doesDirectoryExist p
                        >>= bool (pure [p]) (bool (pure []) (go p) (descend p))
              )
              names
   in FilePather (liftIO . go)
{-# INLINEABLE directoryFilesWhere #-}