{-# 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)

-- | Get the current working directory without using the system locale
--   to convert it to text. This is implemented with a safe FFI call
--   since it may block.
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
    -- It may be nice to add a variant of getCurrentWorkingDirectory that
    -- allow the user to supply an initial pinned buffer. I'm not sure
    -- how many other POSIX functions there are that could benefit
    -- from this. Calls to getCurrentWorkingDirectory are extremely rare,
    -- so there would be little benefit here, but there may be other
    -- functions where these repeated 4KB allocations might trigger
    -- GC very quickly.
    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)
    -- We probably want to use touch# or with# here.
    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

-- There must be a null byte present or bad things will happen.
-- This will return a nonnegative number.
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