Add AFPP support

System/Directory/Internal/Common.hs

@@ -5,20 +5,32 @@ module System.Directory.Internal.Common
   ) where
 import Prelude ()
 import System.Directory.Internal.Prelude
-import System.FilePath
-  ( addTrailingPathSeparator
+import GHC.IO.Encoding.Failure (CodingFailureMode(TransliterateCodingFailure))
+import GHC.IO.Encoding.UTF16 (mkUTF16le)
+import GHC.IO.Encoding.UTF8 (mkUTF8)
+import System.IO (hSetBinaryMode)
+import System.OsPath
+  ( OsPath
+  , OsString
+  , addTrailingPathSeparator
+  , decodeUtf
+  , decodeWith
+  , encodeUtf
   , hasTrailingPathSeparator
   , isPathSeparator
   , isRelative
   , joinDrive
   , joinPath
   , normalise
+  , pack
   , pathSeparator
   , pathSeparators
   , splitDirectories
   , splitDrive
+  , toChar
+  , unpack
+  , unsafeFromChar
   )
-import System.OsPath (OsPath, OsString, decodeUtf, encodeUtf)
 
 -- | A generator with side-effects.
 newtype ListT m a = ListT { unListT :: m (Maybe (a, ListT m a)) }
@@ -112,46 +124,57 @@ os = rightOrError . encodeUtf
 so :: OsString -> String
 so = rightOrError . decodeUtf
 
+ioeSetOsPath :: IOError -> OsPath -> IOError
+ioeSetOsPath err =
+  ioeSetFileName err .
+  rightOrError .
+  decodeWith
+    (mkUTF8 TransliterateCodingFailure)
+    (mkUTF16le TransliterateCodingFailure)
+
 -- | Given a list of path segments, expand @.@ and @..@.  The path segments
 -- must not contain path separators.
-expandDots :: [FilePath] -> [FilePath]
+expandDots :: [OsPath] -> [OsPath]
 expandDots = reverse . go []
   where
     go ys' xs' =
       case xs' of
         [] -> ys'
-        x : xs ->
-          case x of
-            "." -> go ys' xs
-            ".." ->
+        x : xs
+          | x == os "." -> go ys' xs
+          | x == os ".." ->
               case ys' of
                 [] -> go (x : ys') xs
-                ".." : _ -> go (x : ys') xs
-                _ : ys -> go ys xs
-            _ -> go (x : ys') xs
+                y : ys
+                  | y == os ".." -> go (x : ys') xs
+                  | otherwise -> go ys xs
+          | otherwise -> go (x : ys') xs
 
 -- | Convert to the right kind of slashes.
-normalisePathSeps :: FilePath -> FilePath
-normalisePathSeps p = (\ c -> if isPathSeparator c then pathSeparator else c) <$> p
+normalisePathSeps :: OsPath -> OsPath
+normalisePathSeps p = pack (normaliseChar <$> unpack p)
+  where normaliseChar c = if isPathSeparator c then pathSeparator else c
 
 -- | Remove redundant trailing slashes and pick the right kind of slash.
-normaliseTrailingSep :: FilePath -> FilePath
+normaliseTrailingSep :: OsPath -> OsPath
 normaliseTrailingSep path = do
-  let path' = reverse path
+  let path' = reverse (unpack path)
   let (sep, path'') = span isPathSeparator path'
   let addSep = if null sep then id else (pathSeparator :)
-  reverse (addSep path'')
+  pack (reverse (addSep path''))
 
 -- | Convert empty paths to the current directory, otherwise leave it
 -- unchanged.
-emptyToCurDir :: FilePath -> FilePath
-emptyToCurDir ""   = "."
-emptyToCurDir path = path
+emptyToCurDir :: OsPath -> OsPath
+emptyToCurDir path
+  | path == mempty = os "."
+  | otherwise      = path
 
 -- | Similar to 'normalise' but empty paths stay empty.
-simplifyPosix :: FilePath -> FilePath
-simplifyPosix ""   = ""
-simplifyPosix path = normalise path
+simplifyPosix :: OsPath -> OsPath
+simplifyPosix path
+  | path == mempty = mempty
+  | otherwise      = normalise path
 
 -- | Similar to 'normalise' but:
 --
@@ -160,12 +183,11 @@ simplifyPosix path = normalise path
 -- * paths starting with @\\\\?\\@ are preserved.
 --
 -- The goal is to preserve the meaning of paths better than 'normalise'.
-simplifyWindows :: FilePath -> FilePath
-simplifyWindows "" = ""
-simplifyWindows path =
-  case drive' of
-    "\\\\?\\" -> drive' <> subpath
-    _ -> simplifiedPath
+simplifyWindows :: OsPath -> OsPath
+simplifyWindows path
+  | path == mempty         = mempty
+  | drive' == os "\\\\?\\" = drive' <> subpath
+  | otherwise              = simplifiedPath
   where
     simplifiedPath = joinDrive drive' subpath'
     (drive, subpath) = splitDrive path
@@ -174,24 +196,29 @@ simplifyWindows path =
                stripPardirs . expandDots . skipSeps .
                splitDirectories $ subpath
 
-    upperDrive d = case d of
-      c : ':' : s | isAlpha c && all isPathSeparator s -> toUpper c : ':' : s
+    upperDrive d = case unpack d of
+      c : k : s
+        | isAlpha (toChar c), toChar k == ':', all isPathSeparator s ->
+          -- unsafeFromChar is safe here since all characters are ASCII.
+          pack (unsafeFromChar (toUpper (toChar c)) : unsafeFromChar ':' : s)
       _ -> d
-    skipSeps = filter (not . (`elem` (pure <$> pathSeparators)))
-    stripPardirs | pathIsAbsolute || subpathIsAbsolute = dropWhile (== "..")
+    skipSeps =
+      (pack <$>) .
+      filter (not . (`elem` (pure <$> pathSeparators))) .
+      (unpack <$>)
+    stripPardirs | pathIsAbsolute || subpathIsAbsolute = dropWhile (== os "..")
                  | otherwise = id
-    prependSep | subpathIsAbsolute = (pathSeparator :)
+    prependSep | subpathIsAbsolute = (pack [pathSeparator] <>)
                | otherwise = id
     avoidEmpty | not pathIsAbsolute
-                 && (null drive || hasTrailingPathSep) -- prefer "C:" over "C:."
+               , drive == mempty || hasTrailingPathSep -- prefer "C:" over "C:."
                  = emptyToCurDir
                | otherwise = id
-    appendSep p | hasTrailingPathSep
-                  && not (pathIsAbsolute && null p)
+    appendSep p | hasTrailingPathSep, not (pathIsAbsolute && p == mempty)
                   = addTrailingPathSeparator p
                 | otherwise = p
     pathIsAbsolute = not (isRelative path)
-    subpathIsAbsolute = any isPathSeparator (take 1 subpath)
+    subpathIsAbsolute = any isPathSeparator (take 1 (unpack subpath))
     hasTrailingPathSep = hasTrailingPathSeparator subpath
 
 data FileType = File
@@ -222,6 +249,14 @@ data Permissions
   , searchable :: Bool
   } deriving (Eq, Ord, Read, Show)
 
+withBinaryHandle :: IO Handle -> (Handle -> IO r) -> IO r
+withBinaryHandle open = bracket openBinary hClose
+  where
+    openBinary = do
+      h <- open
+      hSetBinaryMode h True
+      pure h
+
 -- | Copy data from one handle to another until end of file.
 copyHandleData :: Handle                -- ^ Source handle
                -> Handle                -- ^ Destination handle

System/Directory/Internal/Config.hs

@@ -1,9 +1,10 @@
 {-# LANGUAGE CPP #-}
 module System.Directory.Internal.Config where
 #include <HsDirectoryConfig.h>
+import System.Directory.Internal.Common
 
-exeExtension :: String
-exeExtension = EXE_EXTENSION
+exeExtension :: OsString
+exeExtension = os EXE_EXTENSION
 -- We avoid using #const_str from hsc because it breaks cross-compilation
 -- builds, so we use this ugly workaround where we simply paste the C string
 -- literal directly in here.  This will probably break if the EXE_EXTENSION