ReadFilePaths.hs

{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}

module System.FilePath.FilePather.ReadFilePaths (
  ReadFilePathsT
, ReadFilePaths
, ReadFilePathsT1
, ReadFilePaths1
, readFilePaths1
, readFilePaths
, swapReadFilePaths
, pureReadFilePaths
, liftReadFilePaths
, successReadFilePaths
, errorReadFilePaths
, maybeReadFilePaths
, tryReadFilePaths
) where

import Control.Applicative ( Applicative((<*>), pure) )
import Control.Category ( Category((.)) )
import Control.Exception ( try, Exception )
import Control.Lens
    ( view,
      iso,
      swapped,
      _Wrapped,
      Field1(_1),
      Iso,
      Rewrapped,
      Wrapped(..) )
import Control.Monad
    ( join, Monad(return, (>>=)) )
import Control.Monad.Cont.Class ( MonadCont(callCC) )
import Control.Monad.Error.Class ( MonadError(throwError, catchError) )
import Control.Monad.Fail ( MonadFail(fail) )
import Control.Monad.Fix ( MonadFix(mfix) )
import Control.Monad.IO.Class ( MonadIO(liftIO) )
import Control.Monad.Morph ( MFunctor(hoist), MMonad(embed) )
import Control.Monad.Reader.Class ( MonadReader(reader, local, ask) )
import Control.Monad.State.Class ( MonadState(state, get, put) )
import Control.Monad.Trans.Class(MonadTrans(lift))
import Control.Monad.Writer.Class ( MonadWriter(pass, tell, writer, listen) )
import Control.Monad.Zip ( MonadZip(mzipWith) )
import Data.Either ( Either(..), either )
import Data.Functor ( Functor(fmap) )
import Data.Functor.Alt ( Apply((<.>)), Alt((<!>)) )
import Data.Functor.Bind ( Bind((>>-)) )
import Data.Functor.Identity( Identity(..) )
import Data.Maybe ( Maybe, maybe )
import Data.Monoid ( Monoid(mempty, mappend) )
import Data.Semigroup ( Semigroup((<>)) )
import System.FilePath ( FilePath )
import System.FilePath.FilePather.ReadFilePath
    ( ReadFilePathT(..) )
import System.IO ( IO )

newtype ReadFilePathsT e f a =
  ReadFilePathsT ([FilePath] -> f (Either e a))

instance ReadFilePathsT e f a ~ t =>
  Rewrapped (ReadFilePathsT e' f' a') t

instance Wrapped (ReadFilePathsT e f a) where
  type Unwrapped (ReadFilePathsT e f a) =
    [FilePath]
    -> f (Either e a)
  _Wrapped' =
    iso (\(ReadFilePathsT x) -> x) ReadFilePathsT
  {-# INLINE _Wrapped' #-}

type ReadFilePaths e a =
  ReadFilePathsT e Identity a

type ReadFilePathsT1 e f =
  ReadFilePathsT e f ()

type ReadFilePaths1 e f =
  ReadFilePaths e ()

readFilePaths1 ::
  ReadFilePathsT e f a
  -> ReadFilePathT e f a
readFilePaths1 x =
  ReadFilePathT (view _Wrapped x . pure)
{-# INLINE readFilePaths1 #-}

readFilePaths ::
  Iso
    (ReadFilePaths e a)
    (ReadFilePaths e' a')
    ([FilePath] -> Either e a)
    ([FilePath] -> Either e' a')
readFilePaths =
  iso
    (\(ReadFilePathsT x) -> runIdentity . x)
    (\p -> ReadFilePathsT (Identity . p))
{-# INLINE readFilePaths #-}

swapReadFilePaths ::
  Functor f =>
  Iso
    (ReadFilePathsT e f a)
    (ReadFilePathsT e' f a')
    (ReadFilePathsT a f e)
    (ReadFilePathsT a' f e')
swapReadFilePaths =
  iso
    (\r -> ReadFilePathsT (fmap (view swapped) . view _Wrapped r))
    (\r -> ReadFilePathsT (fmap (view swapped) . view _Wrapped r))
{-# INLINE swapReadFilePaths #-}

pureReadFilePaths ::
  Applicative f =>
  ReadFilePaths e a
  -> ReadFilePathsT e f a
pureReadFilePaths =
  hoist (pure . runIdentity)
{-# INLINE pureReadFilePaths #-}

liftReadFilePaths ::
  Applicative f =>
  ([FilePath] -> a)
  -> ReadFilePathsT e f a
liftReadFilePaths =
  pureReadFilePaths . reader
{-# INLINE liftReadFilePaths #-}

successReadFilePaths ::
  Functor f =>
  ([FilePath] -> f a)
  -> ReadFilePathsT e f a
successReadFilePaths k =
  ReadFilePathsT (fmap Right . k)
{-# INLINE successReadFilePaths #-}

errorReadFilePaths ::
  Functor f =>
  ([FilePath] -> f e)
  -> ReadFilePathsT e f a
errorReadFilePaths k =
  ReadFilePathsT (fmap Left . k)
{-# INLINE errorReadFilePaths #-}

maybeReadFilePaths ::
  Functor f =>
  ([FilePath] -> f (Maybe a))
  -> ReadFilePathsT () f a
maybeReadFilePaths k =
  ReadFilePathsT (fmap (maybe (Left ()) Right) . k)
{-# INLINE maybeReadFilePaths #-}

tryReadFilePaths ::
  Exception e =>
  ([FilePath] -> IO a)
  -> ReadFilePathsT e IO a
tryReadFilePaths k =
  ReadFilePathsT (try . k)
{-# INLINE tryReadFilePaths #-}

instance (Monad f, Semigroup a) => Semigroup (ReadFilePathsT e f a) where
  ReadFilePathsT x <> ReadFilePathsT y =
    ReadFilePathsT (\p -> x p >>= either (pure . Left) (\a -> fmap (fmap (a <>)) (y p)))
  {-# INLINE (<>) #-}

instance (Monad f, Monoid a) => Monoid (ReadFilePathsT e f a) where
  mappend =
    (<>)
  {-# INLINE mappend #-}
  mempty =
    ReadFilePathsT (pure (pure (pure mempty)))
  {-# INLINE mempty #-}

instance Functor f => Functor (ReadFilePathsT e f) where
  fmap f (ReadFilePathsT x) =
    ReadFilePathsT (fmap (fmap (fmap f)) x)
  {-# INLINE fmap #-}

instance Monad f => Apply (ReadFilePathsT e f) where
  ReadFilePathsT f <.> ReadFilePathsT k =
    ReadFilePathsT (\p -> f p >>= either (pure . Left) (\a -> fmap (fmap a) (k p)))
  {-# INLINE (<.>) #-}

instance Monad f => Bind (ReadFilePathsT e f) where
  ReadFilePathsT f >>- g =
    ReadFilePathsT (\p -> f p >>= either (pure . Left) (\a -> view _Wrapped (g a) p))
  {-# INLINE (>>-) #-}

instance Monad f => Applicative (ReadFilePathsT e f) where
  (<*>) =
    (<.>)
  pure =
    ReadFilePathsT . pure . pure . pure

instance Monad f => Alt (ReadFilePathsT e f) where
  ReadFilePathsT a <!> ReadFilePathsT b =
    ReadFilePathsT (\p -> a p >>= either (pure (b p)) (pure . pure))
  {-# INLINE (<!>) #-}

instance Monad f => Monad (ReadFilePathsT e f) where
  (>>=) =
    (>>-)
  {-# INLINE (>>=) #-}
  return =
    pure
  {-# INLINE return #-}

instance MonadTrans (ReadFilePathsT e) where
  lift =
    ReadFilePathsT . pure . fmap pure
  {-# INLINE lift #-}

instance MonadIO f => MonadIO (ReadFilePathsT e f) where
  liftIO =
    ReadFilePathsT . pure . liftIO . fmap pure
  {-# INLINE liftIO #-}

instance MFunctor (ReadFilePathsT e) where
  hoist k (ReadFilePathsT f) =
    ReadFilePathsT (k .f)
  {-# INLINE hoist #-}

instance MMonad (ReadFilePathsT e) where
  embed k (ReadFilePathsT f) =
    ReadFilePathsT (\p -> fmap join (view _Wrapped (k (f p)) p))
  {-# INLINE embed #-}

instance Monad f => MonadReader [FilePath] (ReadFilePathsT e f) where
  ask =
    ReadFilePathsT (pure . pure)
  {-# INLINE ask #-}
  local k (ReadFilePathsT f) =
    ReadFilePathsT (f . k)
  {-# INLINE local #-}
  reader k =
    ReadFilePathsT (pure . pure . k)
  {-# INLINE reader #-}

instance MonadState [FilePath] f => MonadState [FilePath] (ReadFilePathsT e f) where
  state =
    lift . state
  {-# INLINE state #-}
  get =
    lift get
  {-# INLINE get #-}
  put =
    lift . put
  {-# INLINE put #-}

instance MonadWriter [FilePath] f => MonadWriter [FilePath] (ReadFilePathsT e f) where
  writer =
    lift . writer
  {-# INLINE writer #-}
  tell =
    lift . tell
  {-# INLINE tell #-}
  listen (ReadFilePathsT f) =
    ReadFilePathsT (\p -> fmap (fmap (\a -> (a, p))) (f p))
  {-# INLINE listen #-}
  pass (ReadFilePathsT f) =
    ReadFilePathsT (fmap (fmap (view _1)) . f)
  {-# INLINE pass #-}

instance MonadFail f => MonadFail (ReadFilePathsT e f) where
  fail =
    lift . fail
  {-# INLINE fail #-}

instance MonadFix f => MonadFix (ReadFilePathsT e f) where
  mfix f =
    ReadFilePathsT (\p -> mfix (either (pure . Left) (\a -> view _Wrapped (f a) p)))
  {-# INLINE mfix #-}

instance MonadZip f => MonadZip (ReadFilePathsT e f) where
  mzipWith f (ReadFilePathsT m) (ReadFilePathsT n) =
    ReadFilePathsT (\p -> m p >>= either (pure . Left) (\a -> fmap (fmap (f a)) (n p)))
  {-# INLINE mzipWith #-}

instance MonadCont f => MonadCont (ReadFilePathsT e f) where
  callCC p =
    ReadFilePathsT (\r -> callCC (\c -> view _Wrapped (p (ReadFilePathsT . pure . c . pure)) r))
  {-# INLINE callCC #-}

instance MonadError e f => MonadError e (ReadFilePathsT e f) where
  throwError =
    lift . throwError
  {-# INLINE throwError #-}
  catchError (ReadFilePathsT f) g =
    ReadFilePathsT (\ r -> catchError (f r) (\ e -> view _Wrapped (g e) r))
  {-# INLINE catchError #-}