FilePather.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# 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 (FilePather f), because s does not occur in
-- FilePather f.
-- Terminates: each instance context is the same class at f, which is a strict
-- subterm of the instance head FilePather f, so resolution moves to a smaller
-- type at each step.
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wall #-}

{- | A 'FilePather' is a computation that depends on the file path being
operated on, producing a value in a type constructor @f@.

@
newtype FilePather f a = FilePather (FilePath -> f a)
@

A 'FilePather' is isomorphic to @ReaderT FilePath f a@ (see
'filePatherReaderT'), and has the same instances. In particular, when @f@ is a
'Monad', so is @FilePather f@, and 'Control.Monad.Reader.ask' returns the file path being operated
on.
-}
module System.FilePather.FilePather (
  -- * Types
  FilePather (..),

  -- * Type aliases
  FilePather',
  FilePatherIO,
  FilePatherMaybe,
  FilePatherList,
  FilePatherNonEmpty,
  FilePatherEither,
  FilePatherMaybeT,
  FilePatherExceptT,
  FilePatherExitcode,
  FilePatherExitcode',

  -- * Optics
  filePatherReaderT,
  GetFilePather (..),
  HasFilePather (..),
  ReviewFilePather (..),
  AsFilePather (..),

  -- * Fusion workers
  mapFilePather,
  mapMaybeFilePather,
) where

import Control.Applicative (Alternative)
import Control.DeepSeq (NFData)
import Control.Exitcode (Exitcode)
import Control.Lens (Getter, Iso, Lens', Prism', Review, Rewrapped, Wrapped (..), iso, lens, prism', review, unto, view, _Wrapped)
import Control.Monad (MonadPlus)
import Control.Monad.Cont.Class (MonadCont)
import Control.Monad.Error.Class (MonadError)
import Control.Monad.Fix (MonadFix)
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)
import Control.Monad.Trans.Maybe (MaybeT)
import Control.Monad.Writer.Class (MonadWriter)
import Control.Monad.Zip (MonadZip)
import Control.Selective (Selective)
import Data.Distributive (Distributive (..))
import Data.Functor.Alt (Alt (..))
import Data.Functor.Apply (Apply)
import Data.Functor.Bind (Bind (..))
import Data.Functor.Contravariant (Contravariant)
import Data.Functor.Contravariant.Divisible (Decidable, Divisible)
import Data.Functor.Identity (Identity)
import Data.Functor.Plus (Plus)
import Data.Functor.Rep (Representable (..))
import Data.Kind (Type)
import Data.List.NonEmpty (NonEmpty)
import GHC.Generics (Generic, Generic1)
import Witherable (Filterable (..))

{- $setup
>>> import Control.Lens (view, _Wrapped)
>>> import Control.Monad.Reader (ask, asks)
>>> import Data.Functor.Identity (Identity (..))
>>> import System.FilePath (takeExtension)
>>> import Witherable (mapMaybe)
-}

{- | A computation that depends on the file path being operated on.

The file path is typically an input file, and the result is typically one or
more output files, or some information about the input file. Use 'Control.Monad.Reader.ask' for the
file path, and 'Control.Monad.Reader.local' to operate on a different file path.

==== __Examples__

>>> runIdentity (view _Wrapped (asks takeExtension :: FilePather' String) "notes.md")
".md"

>>> view _Wrapped (FilePather (\p -> [p, p ++ ".bak"])) "notes.md"
["notes.md","notes.md.bak"]

>>> runIdentity (view _Wrapped ((,) <$> ask <*> asks length :: FilePather' (FilePath, Int)) "notes.md")
("notes.md",8)

@since 0.7.0.0
-}
type FilePather :: (Type -> Type) -> Type -> Type
newtype FilePather f a
  = FilePather (FilePath -> f a)
  deriving stock (Generic, Generic1)
  deriving newtype (NFData)
  deriving
    ( Apply
    , Applicative
    , Alternative
    , Plus
    , Monad
    , MonadPlus
    , MonadFail
    , MonadFix
    , MonadZip
    , MonadIO
    , MonadCont
    , MonadReader FilePath
    , Selective
    , Contravariant
    , Divisible
    , Decidable
    )
    via (ReaderT FilePath f)
  deriving (Semigroup, Monoid) via (FilePath -> f a)

deriving via (ReaderT FilePath) instance MonadTrans FilePather

deriving via (ReaderT FilePath f) instance (MonadState s f) => MonadState s (FilePather f)

deriving via (ReaderT FilePath f) instance (MonadWriter w f) => MonadWriter w (FilePather f)

deriving via (ReaderT FilePath f) instance (MonadError e f) => MonadError e (FilePather f)

{- | A 'FilePather' that produces a value without effects.

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

-- | @since 0.7.0.0
type FilePatherIO a = FilePather IO a

-- | @since 0.7.0.0
type FilePatherMaybe a = FilePather Maybe a

-- | @since 0.7.0.0
type FilePatherList a = FilePather [] a

-- | @since 0.7.0.0
type FilePatherNonEmpty a = FilePather NonEmpty a

-- | @since 0.7.0.0
type FilePatherEither e a = FilePather (Either e) a

-- | @since 0.7.0.0
type FilePatherMaybeT f a = FilePather (MaybeT f) a

-- | @since 0.7.0.0
type FilePatherExceptT e f a = FilePather (ExceptT e f) a

{- | A 'FilePather' that fails with an exit code, using 'Exitcode'.

@since 0.7.0.0
-}
type FilePatherExitcode e f a = FilePather (Exitcode e f) a

-- | @since 0.7.0.0
type FilePatherExitcode' e a = FilePather (Exitcode e Identity) a

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

>>> runIdentity (view _Wrapped (mapFilePather length ask) "notes.md")
8

@since 0.7.0.0
-}
mapFilePather :: (Functor f) => (a -> b) -> FilePather f a -> FilePather f b
mapFilePather f (FilePather g) =
  FilePather (fmap f . g)
{-# NOINLINE [1] mapFilePather #-}

{- | Filter and map over the result of a 'FilePather'. This is 'mapMaybe', and
is the function that the fusion rules match.

>>> view _Wrapped (mapMaybeFilePather (\x -> if x > 1 then Just (x * 10) else Nothing) (FilePather (\p -> [1, length p]))) "abc"
[30]

@since 0.7.0.0
-}
mapMaybeFilePather :: (Filterable f) => (a -> Maybe b) -> FilePather f a -> FilePather f b
mapMaybeFilePather f (FilePather g) =
  FilePather (mapMaybe f . g)
{-# NOINLINE [1] mapMaybeFilePather #-}

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

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

-- | @since 0.7.0.0
instance (Bind f) => Bind (FilePather f) where
  FilePather g >>- k =
    FilePather (\p -> g p >>- \a -> view _Wrapped (k a) p)
  {-# INLINE (>>-) #-}

-- | @since 0.7.0.0
instance (Alt f) => Alt (FilePather f) where
  FilePather g <!> FilePather h =
    FilePather (\p -> g p <!> h p)
  {-# INLINE (<!>) #-}

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

-- | @since 0.7.0.0
instance (Distributive f) => Distributive (FilePather f) where
  distribute w =
    FilePather (\p -> distribute (fmap (\x -> view _Wrapped x p) w))
  {-# INLINE distribute #-}

{- | The representation pairs the file path with the representation of @f@.

@since 0.7.0.0
-}
instance (Representable f) => Representable (FilePather f) where
  type Rep (FilePather f) = (FilePath, Rep f)
  tabulate h =
    FilePather (\p -> tabulate (\r -> h (p, r)))
  {-# INLINE tabulate #-}
  index (FilePather g) (p, r) =
    index (g p) r
  {-# INLINE index #-}

-- | @since 0.7.0.0
instance Wrapped (FilePather f a) where
  type Unwrapped (FilePather f a) = FilePath -> f a
  _Wrapped' =
    iso (\(FilePather g) -> g) FilePather
  {-# INLINE _Wrapped' #-}

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

{- | The isomorphism between 'FilePather' and 'ReaderT'.

>>> runIdentity (runReaderT (view filePatherReaderT (asks length)) "notes.md")
8

@since 0.7.0.0
-}
filePatherReaderT :: Iso (FilePather f a) (FilePather g b) (ReaderT FilePath f a) (ReaderT FilePath g b)
filePatherReaderT =
  iso (\(FilePather g) -> ReaderT g) (\(ReaderT g) -> FilePather g)
{-# INLINE filePatherReaderT #-}

{- | Values that can be viewed as a 'FilePather'.

>>> runIdentity (view (getFilePather . _Wrapped) (asks length :: FilePather' Int) "notes.md")
8

@since 0.7.0.0
-}
class GetFilePather s f a | s -> f a where
  getFilePather :: Getter s (FilePather f a)

-- | @since 0.7.0.0
instance GetFilePather (FilePather f a) f a where
  getFilePather =
    id
  {-# INLINE getFilePather #-}

{- | Values with a lens to a 'FilePather'.

@since 0.7.0.0
-}
class (GetFilePather s f a) => HasFilePather s f a | s -> f a where
  {-# MINIMAL setFilePather #-}
  setFilePather :: FilePather f a -> s -> s

  filePather :: Lens' s (FilePather f a)
  filePather =
    lens (view getFilePather) (flip setFilePather)
  {-# INLINE filePather #-}

-- | @since 0.7.0.0
instance HasFilePather (FilePather f a) f a where
  setFilePather =
    const
  {-# INLINE setFilePather #-}

{- | Values that can be constructed from a 'FilePather'.

@since 0.7.0.0
-}
class ReviewFilePather t f a | t -> f a where
  reviewFilePather :: Review t (FilePather f a)

-- | @since 0.7.0.0
instance ReviewFilePather (FilePather f a) f a where
  reviewFilePather =
    unto id
  {-# INLINE reviewFilePather #-}

{- | Values with a prism to a 'FilePather'.

@since 0.7.0.0
-}
class (ReviewFilePather t f a) => AsFilePather t f a | t -> f a where
  {-# MINIMAL matchFilePather #-}
  matchFilePather :: t -> Maybe (FilePather f a)

  _FilePather :: Prism' t (FilePather f a)
  _FilePather =
    prism' (review reviewFilePather) matchFilePather
  {-# INLINE _FilePather #-}

-- | @since 0.7.0.0
instance AsFilePather (FilePather f a) f a where
  matchFilePather =
    Just
  {-# INLINE matchFilePather #-}