{-# LANGUAGE CApiFFI #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}

{-# OPTIONS_GHC -Wall #-}


module GHCup.Prelude.File.Posix.Traversals (
-- lower-level stuff
  readDirEnt
, unpackDirStream
) where


#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif
import GHCup.Prelude.File.Posix.Foreign

import Unsafe.Coerce (unsafeCoerce)
import Foreign.C.Error
import Foreign.C.String
import Foreign.C.Types
import Foreign.Ptr
import Foreign.Storable
import System.Posix
import Foreign (alloca)
import System.Posix.Internals (peekFilePath)





----------------------------------------------------------
-- dodgy stuff

type CDir = ()
type CDirent = ()

-- Posix doesn't export DirStream, so to re-use that type we need to use
-- unsafeCoerce.  It's just a newtype, so this is a legitimate usage.
-- ugly trick.
unpackDirStream :: DirStream -> Ptr CDir
unpackDirStream :: DirStream -> Ptr CDir
unpackDirStream = DirStream -> Ptr CDir
forall a b. a -> b
unsafeCoerce

-- the __hscore_* functions are defined in the unix package.  We can import them and let
-- the linker figure it out.
foreign import ccall unsafe "__hscore_readdir"
  c_readdir  :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt

foreign import ccall unsafe "__hscore_free_dirent"
  c_freeDirEnt  :: Ptr CDirent -> IO ()

foreign import ccall unsafe "__hscore_d_name"
  c_name :: Ptr CDirent -> IO CString

foreign import ccall unsafe "__posixdir_d_type"
  c_type :: Ptr CDirent -> IO DirType

----------------------------------------------------------
-- less dodgy but still lower-level


readDirEnt :: DirStream -> IO (DirType, FilePath)
readDirEnt :: DirStream -> IO (DirType, FilePath)
readDirEnt (DirStream -> Ptr CDir
unpackDirStream -> Ptr CDir
dirp) =
  (Ptr (Ptr CDir) -> IO (DirType, FilePath))
-> IO (DirType, FilePath)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr (Ptr CDir) -> IO (DirType, FilePath))
 -> IO (DirType, FilePath))
-> (Ptr (Ptr CDir) -> IO (DirType, FilePath))
-> IO (DirType, FilePath)
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr CDir)
ptr_dEnt  -> Ptr (Ptr CDir) -> IO (DirType, FilePath)
loop Ptr (Ptr CDir)
ptr_dEnt
 where
  loop :: Ptr (Ptr CDir) -> IO (DirType, FilePath)
loop Ptr (Ptr CDir)
ptr_dEnt = do
    IO CDir
resetErrno
    CInt
r <- Ptr CDir -> Ptr (Ptr CDir) -> IO CInt
c_readdir Ptr CDir
dirp Ptr (Ptr CDir)
ptr_dEnt
    if CInt
r CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0
       then do
         Ptr CDir
dEnt <- Ptr (Ptr CDir) -> IO (Ptr CDir)
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr CDir)
ptr_dEnt
         if Ptr CDir
dEnt Ptr CDir -> Ptr CDir -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr CDir
forall a. Ptr a
nullPtr
            then (DirType, FilePath) -> IO (DirType, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (DirType
dtUnknown, FilePath
forall a. Monoid a => a
mempty)
            else do
                 FilePath
dName <- Ptr CDir -> IO CString
c_name Ptr CDir
dEnt IO CString -> (CString -> IO FilePath) -> IO FilePath
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CString -> IO FilePath
peekFilePath
                 DirType
dType <- Ptr CDir -> IO DirType
c_type Ptr CDir
dEnt
                 Ptr CDir -> IO CDir
c_freeDirEnt Ptr CDir
dEnt
                 (DirType, FilePath) -> IO (DirType, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (DirType
dType, FilePath
dName)
       else do
         Errno
errno <- IO Errno
getErrno
         if Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eINTR
            then Ptr (Ptr CDir) -> IO (DirType, FilePath)
loop Ptr (Ptr CDir)
ptr_dEnt
            else do
                 let (Errno CInt
eo) = Errno
errno
                 if CInt
eo CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0
                    then (DirType, FilePath) -> IO (DirType, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (DirType
dtUnknown, FilePath
forall a. Monoid a => a
mempty)
                    else FilePath -> IO (DirType, FilePath)
forall a. FilePath -> IO a
throwErrno FilePath
"readDirEnt"