{-# LANGUAGE CPP #-}
-- File created: 2008-10-10 13:40:35

module System.FilePath.Glob.Utils
   ( isLeft, fromLeft
   , increasingSeq
   , addToRange, inRange, overlap
   , dropLeadingZeroes
   , pathParts
   , nubOrd
   , partitionDL
   , getRecursiveContents
   , catchIO
   ) where

import Control.Monad    (foldM)
import qualified Control.Exception as E
import Data.List        ((\\))
import qualified Data.DList as DL
import Data.DList       (DList)
import qualified Data.Set as Set
import System.Directory (getDirectoryContents)
import System.FilePath  ((</>), isPathSeparator, dropDrive)
import System.IO.Unsafe (unsafeInterleaveIO)

#if mingw32_HOST_OS
import Data.Bits          ((.&.))
import System.Win32.Types (withTString)
import System.Win32.File  (c_GetFileAttributes, fILE_ATTRIBUTE_DIRECTORY)
#else
import Foreign.C.String      (withCString)
import Foreign.Marshal.Alloc (allocaBytes)
import System.FilePath
   (isDrive, dropTrailingPathSeparator, addTrailingPathSeparator)
import System.Posix.Internals (sizeof_stat, lstat, s_isdir, st_mode)
#endif

inRange :: Ord a => (a,a) -> a -> Bool
inRange (a,b) c = c >= a && c <= b

-- returns Just (a range which covers both given ranges) or Nothing if they are
-- disjoint.
--
-- Assumes that the ranges are in the correct order, i.e. (fst x < snd x).
overlap :: Ord a => (a,a) -> (a,a) -> Maybe (a,a)
overlap (a,b) (c,d) =
   if b >= c
      then if b >= d
              then if a <= c
                      then Just (a,b)
                      else Just (c,b)
              else if a <= c
                      then Just (a,d)
                      else Just (c,d)
      else Nothing

addToRange :: (Ord a, Enum a) => (a,a) -> a -> Maybe (a,a)
addToRange (a,b) c
   | inRange (a,b) c = Just (a,b)
   | c == pred a     = Just (c,b)
   | c == succ b     = Just (a,c)
   | otherwise       = Nothing

-- fst of result is in reverse order so that:
--
-- If x = fst (increasingSeq (a:xs)), then
-- x == reverse [a .. head x]
increasingSeq :: (Eq a, Enum a) => [a] -> ([a],[a])
increasingSeq []     = ([],[])
increasingSeq (x:xs) = go [x] xs
 where
   go is       []     = (is,[])
   go is@(i:_) (y:ys) =
      if y == succ i
         then go (y:is) ys
         else (is, y:ys)
   go _ _ = error "Glob.increasingSeq :: internal error"

isLeft :: Either a b -> Bool
isLeft (Left _) = True
isLeft _        = False

fromLeft :: Either a b -> a
fromLeft (Left x) = x
fromLeft _        = error "fromLeft :: Right"

dropLeadingZeroes :: String -> String
dropLeadingZeroes s =
   let x = dropWhile (=='0') s
    in if null x then "0" else x

-- foo/bar/baz -> [foo/bar/baz,bar/baz,baz]
pathParts :: FilePath -> [FilePath]
pathParts p = p : let d = dropDrive p
                   in if null d || d == p
                         then     f d
                         else d : f d
 where
   f []  = []
   f (x:xs@(y:_)) | isPathSeparator x && isPathSeparator y = f xs
   f (x:xs) =
      if isPathSeparator x
         then xs : f xs
         else      f xs

-- Significantly speedier than System.Directory.doesDirectoryExist.
doesDirectoryExist :: FilePath -> IO Bool
#if mingw32_HOST_OS
-- This one allocates more memory since it has to do a UTF-16 conversion, but
-- that can't really be helped: the below version is locale-dependent.
doesDirectoryExist = flip withTString $ \s -> do
   a <- c_GetFileAttributes s
   return (a /= 0xffffffff && a.&.fILE_ATTRIBUTE_DIRECTORY /= 0)
#else
doesDirectoryExist s =
   allocaBytes sizeof_stat $ \p ->
      withCString
         (if isDrive s
             then addTrailingPathSeparator s
             else dropTrailingPathSeparator s)
         $ \c -> do
            st <- lstat c p
            if st == 0
               then fmap s_isdir (st_mode p)
               else return False
#endif

getRecursiveContents :: FilePath -> IO (DList FilePath)
getRecursiveContents dir =
   flip catchIO (\_ -> return $ DL.singleton dir) $ do

      raw <- getDirectoryContents dir

      let entries = map (dir </>) (raw \\ [".",".."])
      (dirs,files) <- partitionM doesDirectoryExist entries

      subs <- unsafeInterleaveIO . mapM getRecursiveContents $ dirs

      return$ DL.cons dir (DL.fromList files `DL.append` DL.concat subs)

partitionM :: (Monad m) => (a -> m Bool) -> [a] -> m ([a], [a])
partitionM p_ = foldM (f p_) ([],[])
 where
   f p (ts,fs) x = p x >>= \b ->
      if b
         then return (x:ts, fs)
         else return (ts, x:fs)

partitionDL :: (a -> Bool) -> DList a -> (DList a, DList a)
partitionDL p_ = DL.foldr (f p_) (DL.empty,DL.empty)
 where
   f p x (ts,fs) =
      if p x
         then (DL.cons x ts, fs)
         else (ts, DL.cons x fs)

nubOrd :: Ord a => [a] -> [a]
nubOrd = go Set.empty
 where
   go _ [] = []
   go set (x:xs) =
      if Set.member x set
         then go set xs
         else x : go (Set.insert x set) xs

catchIO :: IO a -> (E.IOException -> IO a) -> IO a
catchIO = E.catch