ReadFilePath.hs

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

module System.FilePath.FilePather.ReadFilePath(
  ReadFilePathT
, ReadFilePathT1
, ReadFilePath1
, readFilePath
, swapReadFilePath
, pureReadFilePath
, liftReadFilePath
, successReadFilePath
, errorReadFilePath
, maybeReadFilePath
, tryReadFilePath
) 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.IO ( IO )

newtype ReadFilePathT e f a =
  ReadFilePathT (FilePath -> f (Either e a))

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

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

type ReadFilePath e a =
  ReadFilePathT e Identity a

type ReadFilePathT1 e f =
  ReadFilePathT e f ()

type ReadFilePath1 e f =
  ReadFilePath e ()

readFilePath ::
  Iso
    (ReadFilePath e a)
    (ReadFilePath e' a')
    (FilePath -> Either e a)
    (FilePath -> Either e' a')
readFilePath =
  iso
    (\(ReadFilePathT x) -> runIdentity . x)
    (\p -> ReadFilePathT (Identity . p))
{-# INLINE readFilePath #-}

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

pureReadFilePath ::
  Applicative f =>
  ReadFilePath e a
  -> ReadFilePathT e f a
pureReadFilePath =
  hoist (pure . runIdentity)
{-# INLINE pureReadFilePath #-}

liftReadFilePath ::
  Applicative f =>
  (FilePath -> a)
  -> ReadFilePathT e f a
liftReadFilePath =
  pureReadFilePath . reader
{-# INLINE liftReadFilePath #-}

successReadFilePath ::
  Functor f =>
  (FilePath -> f a)
  -> ReadFilePathT e f a
successReadFilePath k =
  ReadFilePathT (fmap Right . k)
{-# INLINE successReadFilePath #-}

errorReadFilePath ::
  Functor f =>
  (FilePath -> f e)
  -> ReadFilePathT e f a
errorReadFilePath k =
  ReadFilePathT (fmap Left . k)
{-# INLINE errorReadFilePath #-}

maybeReadFilePath ::
  Functor f =>
  (FilePath -> f (Maybe a))
  -> ReadFilePathT () f a
maybeReadFilePath k =
  ReadFilePathT (fmap (maybe (Left ()) Right) . k)
{-# INLINE maybeReadFilePath #-}

tryReadFilePath ::
  Exception e =>
  (FilePath -> IO a)
  -> ReadFilePathT e IO a
tryReadFilePath k =
  ReadFilePathT (try . k)
{-# INLINE tryReadFilePath #-}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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