module Lastik.Find where

import Control.Applicative
import Control.Monad
import Control.Monad.Instances
import Data.Monoid
import System.FilePath
import System.Directory
import qualified System.FilePath as P
import Lastik.Util

newtype FilePather a = FilePather {
  (<?>) :: FilePath -> a
}

instance Functor FilePather where
  fmap f (FilePather k) = FilePather (f . k)

instance Applicative FilePather where
  FilePather f <*> FilePather a = FilePather (f <*> a)
  pure = FilePather . const

instance Monad FilePather where
  FilePather f >>= k = FilePather (f >>= (<?>) . k)
  return = pure

instance (Monoid a) => Monoid (FilePather a) where
  mempty = return mempty
  FilePather x `mappend` FilePather y = FilePather (x `mappend` y)

filePather :: (FilePath -> a) -> FilePather a
filePather = FilePather

filePath :: FilePather FilePath
filePath = filePather id

always :: FilePather Bool
always = filePather (\_ -> True)

always' :: FilePather (a -> Bool)
always' = constant always

never :: FilePather Bool
never = filePather (\_ -> False)

never' :: FilePather (a -> Bool)
never' = constant never

extension :: FilePather FilePath
extension = filePather takeExtension

extension' :: FilePather (a -> FilePath)
extension' = constant extension

directory :: FilePather FilePath
directory = filePather takeDirectory

directory' :: FilePather (a -> FilePath)
directory' = constant directory

hasExtension :: FilePather Bool
hasExtension = filePather P.hasExtension

hasExtension' :: FilePather (a -> Bool)
hasExtension' = constant Lastik.Find.hasExtension

splitExtension :: FilePather (String, String)
splitExtension = filePather P.splitExtension

splitExtension' :: FilePather (a -> (String, String))
splitExtension' = constant Lastik.Find.splitExtension

splitDirectories :: FilePather [FilePath]
splitDirectories = filePather P.splitDirectories

splitDirectories' :: FilePather (a -> [FilePath])
splitDirectories' = constant Lastik.Find.splitDirectories

hasTrailingPathSeparator :: FilePather Bool
hasTrailingPathSeparator = filePather P.hasTrailingPathSeparator

hasTrailingPathSeparator' :: FilePather (a -> Bool)
hasTrailingPathSeparator' = constant Lastik.Find.hasTrailingPathSeparator

fileName :: FilePather FilePath
fileName = filePather takeFileName

fileName' :: FilePather (a -> FilePath)
fileName' = constant fileName

baseName :: FilePather FilePath
baseName = filePather takeBaseName

baseName' :: FilePather (a -> FilePath)
baseName' = constant baseName

normalise :: FilePather FilePath
normalise = filePather P.normalise

normalise' :: FilePather (a -> FilePath)
normalise' = constant Lastik.Find.normalise

makeValid :: FilePather FilePath
makeValid = filePather P.makeValid

makeValid' :: FilePather (a -> FilePath)
makeValid' = constant Lastik.Find.makeValid

isRelative :: FilePather Bool
isRelative = filePather P.isRelative

isRelative' :: FilePather (a -> Bool)
isRelative' = constant Lastik.Find.isRelative

isAbsolute :: FilePather Bool
isAbsolute = filePather P.isAbsolute

isAbsolute' :: FilePather (a -> Bool)
isAbsolute' = constant Lastik.Find.isAbsolute

isValid :: FilePather Bool
isValid = filePather P.isValid

isValid' :: FilePather (a -> Bool)
isValid' = constant Lastik.Find.isValid

not' :: (Functor f) => f Bool -> f Bool
not' = fmap not

constant :: (Functor f) => f a -> f (t -> a)
constant p = fmap const p

(==?) :: (Eq a, Functor f) => f a -> a -> f Bool
p ==? a = fmap (a ==) p

(/=?) :: (Eq a, Functor f) => f a -> a -> f Bool
p /=? a = fmap (a /=) p

(==>) :: (Applicative f) => f Bool -> f Bool -> f Bool
(==>) = liftA2 (\p q -> not p || q)

(===>) :: (Applicative f1, Applicative f2) => f1 (f2 Bool) -> f1 (f2 Bool) -> f1 (f2 Bool)
(===>) = liftA2 (==>)

(/=>) :: (Applicative f) => f Bool -> f Bool -> f Bool
(/=>) = liftA2 (\p q -> not q && p)

(/==>) :: (Applicative f1, Applicative f2) => f1 (f2 Bool) -> f1 (f2 Bool) -> f1 (f2 Bool)
(/==>) = liftA2 (/=>)

(&&?) :: (Applicative f) => f Bool -> f Bool -> f Bool
(&&?) = liftA2 (&&)

(?&&?) :: (Applicative f1, Applicative f2) => f1 (f2 Bool) -> f1 (f2 Bool) -> f1 (f2 Bool)
(?&&?) = liftA2 (&&?)

(||?) :: (Applicative f) => f Bool -> f Bool -> f Bool
(||?) = liftA2 (||)

(?||?) :: (Applicative f1, Applicative f2) => f1 (f2 Bool) -> f1 (f2 Bool) -> f1 (f2 Bool)
(?||?) = liftA2 (||?)

data FileType = File | Directory | Unknown deriving (Eq, Show)

type RecursePredicate = FilePather Bool
type FilterPredicate = FilePather (FileType -> Bool)

isFile :: (Applicative f) => f (FileType -> Bool)
isFile = pure (== File)

isDirectory :: (Applicative f) => f (FileType -> Bool)
isDirectory = pure (== Directory)

isUnknown :: (Applicative f) => f (FileType -> Bool)
isUnknown = pure (== Unknown)

find :: RecursePredicate -> FilterPredicate -> FilePath -> IO [FilePath]
find = find' []
  where
  find' :: FilePath -> RecursePredicate -> FilterPredicate -> FilePath -> IO [FilePath]
  find' k r f p = let z = if null k then p else k </> p
                      z' t = if f <?> z $ t then [z] else []
                  in ifM (doesFileExist z)
                       (return (z' File)) $
                       do e <- doesDirectoryExist z
                          if e
                            then if r <?> z
                                   then do c <- getDirectoryContents z
                                           t <- fmap join $ forM (filter (`notElem` [".", ".."]) c) (find' k r f . (z </>))
                                           return (z' Directory ++ t)
                                   else return (z' Directory)
                            else return (z' Unknown)