Find.hs

{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE NoImplicitPrelude #-}

module System.FilePath.FilePather.Find(
  findWith
, findWith'
, findAllDirectories
, findAll
, findAllFiles
) where

import Control.Applicative ( Applicative(pure) )
import Control.Category ( Category((.)) )
import Control.Exception ( Exception )
import Control.Lens ( view, _Wrapped, _1, _2 )
import Control.Monad ( Monad((>>=)), filterM )
import Control.Monad.IO.Class ( MonadIO(liftIO) )
import Control.Monad.Reader
    ( MonadReader(local, ask) )
import Data.Bool ( Bool(True), bool )
import Data.Foldable ( fold )
import Data.Functor ( Functor(fmap), (<$>) )
import Data.Maybe ( Maybe(..), catMaybes )
import Data.Semigroup ( Semigroup((<>)) )
import Data.Traversable ( Traversable(traverse) )
import System.FilePath ( FilePath, (</>) )
import System.FilePath.FilePather.Directory
    ( listDirectory, doesFileExist, doesDirectoryExist )
import System.FilePath.FilePather.ReadFilePath ( ReadFilePathT )
import System.IO ( IO )
import System.IO.Unsafe( unsafeInterleaveIO )

findWith ::
  Exception e =>
  ReadFilePathT e IO (Maybe b)
  -> ReadFilePathT e IO [b]
findWith p =
  let setl =
        local . pure
      mapMaybeM f xs =
        catMaybes <$> traverse f xs
  in  do  z <- ask
          a <- listDirectory
          let y = (z </>) <$> a
          b <- mapMaybeM (\fp -> fmap (fmap (\s -> (s, fp))) (fp `setl` p)) y
          d <- filterM (`setl` doesDirectoryExist) (fmap (view _2) b)
          let bs = fmap (view _1) b
          case d of
            [] ->
              pure bs
            _ ->
              do  n <- liftIO (unsafeInterleaveIO (fmap (>>= fold) (traverse (view _Wrapped (findWith p)) d)))
                  pure (bs <> n)
{-# INLINE findWith #-}

findWith' ::
  Exception e =>
  ReadFilePathT e IO Bool
  -> ReadFilePathT e IO [FilePath]
findWith' s =
  findWith (ask >>= \d -> fmap (bool Nothing (Just d)) s)
{-# INLINE findWith' #-}

findAllDirectories ::
  Exception e =>
  ReadFilePathT e IO [FilePath]
findAllDirectories =
  findWith' doesDirectoryExist
{-# INLINE findAllDirectories #-}

findAll ::
  Exception e =>
  ReadFilePathT e IO [FilePath]
findAll =
  findWith' (pure True)
{-# INLINE findAll #-}

findAllFiles ::
  Exception e =>
  ReadFilePathT e IO [FilePath]
findAllFiles =
  findAll >>= filterM (\p -> local (pure p) doesFileExist)
{-# INLINE findAllFiles #-}