{-# language BangPatterns #-}
{-# language MagicHash #-}
{-# language LambdaCase #-}
{-# language UnboxedTuples #-}
module Posix.Directory
( getCurrentWorkingDirectory
) where
import Data.Primitive (ByteArray)
import GHC.Exts (Ptr(..))
import Foreign.Ptr (nullPtr)
import Foreign.C.Error (Errno,eRANGE,getErrno)
import Foreign.C.Types (CChar,CSize(..))
import GHC.IO (IO(..))
import qualified Data.Primitive as PM
import qualified Foreign.Storable as FS
foreign import ccall safe "getcwd"
c_getcwd :: Ptr CChar -> CSize -> IO (Ptr CChar)
getCurrentWorkingDirectory :: IO (Either Errno ByteArray)
getCurrentWorkingDirectory :: IO (Either Errno ByteArray)
getCurrentWorkingDirectory = Int -> IO (Either Errno ByteArray)
go (Int
4096 forall a. Num a => a -> a -> a
- Int
chunkOverhead) where
go :: Int -> IO (Either Errno ByteArray)
go !Int
sz = do
MutableByteArray RealWorld
marr <- forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
PM.newPinnedByteArray Int
sz
let !(Ptr Addr#
addr) = forall s. MutableByteArray s -> Ptr Word8
PM.mutableByteArrayContents MutableByteArray RealWorld
marr
Ptr CChar
ptr <- Ptr CChar -> CSize -> IO (Ptr CChar)
c_getcwd (forall a. Addr# -> Ptr a
Ptr Addr#
addr) (Int -> CSize
intToCSize Int
sz)
if Ptr CChar
ptr forall a. Eq a => a -> a -> Bool
/= forall a. Ptr a
nullPtr
then do
Int
strSize <- Ptr CChar -> IO Int
findNullByte Ptr CChar
ptr
MutableByteArray RealWorld
dst <- forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
PM.newByteArray Int
strSize
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m)
-> Int -> MutableByteArray (PrimState m) -> Int -> Int -> m ()
PM.copyMutableByteArray MutableByteArray RealWorld
dst Int
0 MutableByteArray RealWorld
marr Int
0 Int
strSize
ByteArray
dst' <- forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
PM.unsafeFreezeByteArray MutableByteArray RealWorld
dst
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right ByteArray
dst')
else do
Errno
errno <- IO Errno
getErrno
if Errno
errno forall a. Eq a => a -> a -> Bool
== Errno
eRANGE
then Int -> IO (Either Errno ByteArray)
go (Int
2 forall a. Num a => a -> a -> a
* Int
sz)
else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left IO Errno
getErrno
chunkOverhead :: Int
chunkOverhead :: Int
chunkOverhead = Int
2 forall a. Num a => a -> a -> a
* forall a. Prim a => a -> Int
PM.sizeOf (forall a. HasCallStack => a
undefined :: Int)
intToCSize :: Int -> CSize
intToCSize :: Int -> CSize
intToCSize = forall a b. (Integral a, Num b) => a -> b
fromIntegral
findNullByte :: Ptr CChar -> IO Int
findNullByte :: Ptr CChar -> IO Int
findNullByte = Int -> Ptr CChar -> IO Int
go Int
0 where
go :: Int -> Ptr CChar -> IO Int
go :: Int -> Ptr CChar -> IO Int
go !Int
ix !Ptr CChar
ptr = do
forall a. Storable a => Ptr a -> Int -> IO a
FS.peekElemOff Ptr CChar
ptr Int
ix forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
CChar
0 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
ix
CChar
_ -> Int -> Ptr CChar -> IO Int
go (Int
ix forall a. Num a => a -> a -> a
+ Int
1) Ptr CChar
ptr