Skip to content

Commit 78b3e59

Browse files
hasufellRufflewind
hasufell
authored and
Rufflewind
committed
Add AFPP support
This is tidied up commit containing the following changes by https://github.com/hasufell: * 66b3f48 * 15338c0 Not all changes made their way through. Beyond the stylistic cleanup, notable reversions include: * System.File.OsPath and its submodules have been removed as very little of directory relies on them. The few remaining portions have been inlined into submodules of System.Directory.Internal. For file operations, users are expected to use upstream packages at https://github.com/hasufell/file-io . * Renaming of internal modules have been undone to untangle the AFPP revamp from unrelated refactors. * Dependence on bytestring has been removed as it was found to be unnecessary after the cleanup. Closes #136.
1 parent be6a777 commit 78b3e59

29 files changed

+676
-857
lines changed

‎System/Directory.hs‎

Lines changed: 88 additions & 444 deletions
Large diffs are not rendered by default.

‎System/Directory/Internal/Common.hs‎

Lines changed: 72 additions & 37 deletions
Original file line numberDiff line numberDiff line change
@@ -5,20 +5,32 @@ module System.Directory.Internal.Common
55
) where
66
import Prelude ()
77
import System.Directory.Internal.Prelude
8-
import System.FilePath
9-
( addTrailingPathSeparator
8+
import GHC.IO.Encoding.Failure (CodingFailureMode(TransliterateCodingFailure))
9+
import GHC.IO.Encoding.UTF16 (mkUTF16le)
10+
import GHC.IO.Encoding.UTF8 (mkUTF8)
11+
import System.IO (hSetBinaryMode)
12+
import System.OsPath
13+
( OsPath
14+
, OsString
15+
, addTrailingPathSeparator
16+
, decodeUtf
17+
, decodeWith
18+
, encodeUtf
1019
, hasTrailingPathSeparator
1120
, isPathSeparator
1221
, isRelative
1322
, joinDrive
1423
, joinPath
1524
, normalise
25+
, pack
1626
, pathSeparator
1727
, pathSeparators
1828
, splitDirectories
1929
, splitDrive
30+
, toChar
31+
, unpack
32+
, unsafeFromChar
2033
)
21-
import System.OsPath (OsPath, OsString, decodeUtf, encodeUtf)
2234

2335
-- | A generator with side-effects.
2436
newtype ListT m a = ListT { unListT :: m (Maybe (a, ListT m a)) }
@@ -112,46 +124,57 @@ os = rightOrError . encodeUtf
112124
so :: OsString -> String
113125
so = rightOrError . decodeUtf
114126

127+
ioeSetOsPath :: IOError -> OsPath -> IOError
128+
ioeSetOsPath err =
129+
ioeSetFileName err .
130+
rightOrError .
131+
decodeWith
132+
(mkUTF8 TransliterateCodingFailure)
133+
(mkUTF16le TransliterateCodingFailure)
134+
115135
-- | Given a list of path segments, expand @.@ and @..@. The path segments
116136
-- must not contain path separators.
117-
expandDots :: [FilePath] -> [FilePath]
137+
expandDots :: [OsPath] -> [OsPath]
118138
expandDots = reverse . go []
119139
where
120140
go ys' xs' =
121141
case xs' of
122142
[] -> ys'
123-
x : xs ->
124-
case x of
125-
"." -> go ys' xs
126-
".." ->
143+
x : xs
144+
| x == os "." -> go ys' xs
145+
| x == os ".." ->
127146
case ys' of
128147
[] -> go (x : ys') xs
129-
".." : _ -> go (x : ys') xs
130-
_ : ys -> go ys xs
131-
_ -> go (x : ys') xs
148+
y : ys
149+
| y == os ".." -> go (x : ys') xs
150+
| otherwise -> go ys xs
151+
| otherwise -> go (x : ys') xs
132152

133153
-- | Convert to the right kind of slashes.
134-
normalisePathSeps :: FilePath -> FilePath
135-
normalisePathSeps p = (\ c -> if isPathSeparator c then pathSeparator else c) <$> p
154+
normalisePathSeps :: OsPath -> OsPath
155+
normalisePathSeps p = pack (normaliseChar <$> unpack p)
156+
where normaliseChar c = if isPathSeparator c then pathSeparator else c
136157

137158
-- | Remove redundant trailing slashes and pick the right kind of slash.
138-
normaliseTrailingSep :: FilePath -> FilePath
159+
normaliseTrailingSep :: OsPath -> OsPath
139160
normaliseTrailingSep path = do
140-
let path' = reverse path
161+
let path' = reverse (unpack path)
141162
let (sep, path'') = span isPathSeparator path'
142163
let addSep = if null sep then id else (pathSeparator :)
143-
reverse (addSep path'')
164+
pack (reverse (addSep path''))
144165

145166
-- | Convert empty paths to the current directory, otherwise leave it
146167
-- unchanged.
147-
emptyToCurDir :: FilePath -> FilePath
148-
emptyToCurDir "" = "."
149-
emptyToCurDir path = path
168+
emptyToCurDir :: OsPath -> OsPath
169+
emptyToCurDir path
170+
| path == mempty = os "."
171+
| otherwise = path
150172

151173
-- | Similar to 'normalise' but empty paths stay empty.
152-
simplifyPosix :: FilePath -> FilePath
153-
simplifyPosix "" = ""
154-
simplifyPosix path = normalise path
174+
simplifyPosix :: OsPath -> OsPath
175+
simplifyPosix path
176+
| path == mempty = mempty
177+
| otherwise = normalise path
155178

156179
-- | Similar to 'normalise' but:
157180
--
@@ -160,12 +183,11 @@ simplifyPosix path = normalise path
160183
-- * paths starting with @\\\\?\\@ are preserved.
161184
--
162185
-- The goal is to preserve the meaning of paths better than 'normalise'.
163-
simplifyWindows :: FilePath -> FilePath
164-
simplifyWindows "" = ""
165-
simplifyWindows path =
166-
case drive' of
167-
"\\\\?\\" -> drive' <> subpath
168-
_ -> simplifiedPath
186+
simplifyWindows :: OsPath -> OsPath
187+
simplifyWindows path
188+
| path == mempty = mempty
189+
| drive' == os "\\\\?\\" = drive' <> subpath
190+
| otherwise = simplifiedPath
169191
where
170192
simplifiedPath = joinDrive drive' subpath'
171193
(drive, subpath) = splitDrive path
@@ -174,24 +196,29 @@ simplifyWindows path =
174196
stripPardirs . expandDots . skipSeps .
175197
splitDirectories $ subpath
176198

177-
upperDrive d = case d of
178-
c : ':' : s | isAlpha c && all isPathSeparator s -> toUpper c : ':' : s
199+
upperDrive d = case unpack d of
200+
c : k : s
201+
| isAlpha (toChar c), toChar k == ':', all isPathSeparator s ->
202+
-- unsafeFromChar is safe here since all characters are ASCII.
203+
pack (unsafeFromChar (toUpper (toChar c)) : unsafeFromChar ':' : s)
179204
_ -> d
180-
skipSeps = filter (not . (`elem` (pure <$> pathSeparators)))
181-
stripPardirs | pathIsAbsolute || subpathIsAbsolute = dropWhile (== "..")
205+
skipSeps =
206+
(pack <$>) .
207+
filter (not . (`elem` (pure <$> pathSeparators))) .
208+
(unpack <$>)
209+
stripPardirs | pathIsAbsolute || subpathIsAbsolute = dropWhile (== os "..")
182210
| otherwise = id
183-
prependSep | subpathIsAbsolute = (pathSeparator :)
211+
prependSep | subpathIsAbsolute = (pack [pathSeparator] <>)
184212
| otherwise = id
185213
avoidEmpty | not pathIsAbsolute
186-
&& (null drive || hasTrailingPathSep) -- prefer "C:" over "C:."
214+
, drive == mempty || hasTrailingPathSep -- prefer "C:" over "C:."
187215
= emptyToCurDir
188216
| otherwise = id
189-
appendSep p | hasTrailingPathSep
190-
&& not (pathIsAbsolute && null p)
217+
appendSep p | hasTrailingPathSep, not (pathIsAbsolute && p == mempty)
191218
= addTrailingPathSeparator p
192219
| otherwise = p
193220
pathIsAbsolute = not (isRelative path)
194-
subpathIsAbsolute = any isPathSeparator (take 1 subpath)
221+
subpathIsAbsolute = any isPathSeparator (take 1 (unpack subpath))
195222
hasTrailingPathSep = hasTrailingPathSeparator subpath
196223

197224
data FileType = File
@@ -222,6 +249,14 @@ data Permissions
222249
, searchable :: Bool
223250
} deriving (Eq, Ord, Read, Show)
224251

252+
withBinaryHandle :: IO Handle -> (Handle -> IO r) -> IO r
253+
withBinaryHandle open = bracket openBinary hClose
254+
where
255+
openBinary = do
256+
h <- open
257+
hSetBinaryMode h True
258+
pure h
259+
225260
-- | Copy data from one handle to another until end of file.
226261
copyHandleData :: Handle -- ^ Source handle
227262
-> Handle -- ^ Destination handle

‎System/Directory/Internal/Config.hs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,10 @@
11
{-# LANGUAGE CPP #-}
22
module System.Directory.Internal.Config where
33
#include <HsDirectoryConfig.h>
4+
import System.Directory.Internal.Common
45

5-
exeExtension :: String
6-
exeExtension = EXE_EXTENSION
6+
exeExtension :: OsString
7+
exeExtension = os EXE_EXTENSION
78
-- We avoid using #const_str from hsc because it breaks cross-compilation
89
-- builds, so we use this ugly workaround where we simply paste the C string
910
-- literal directly in here. This will probably break if the EXE_EXTENSION

0 commit comments

Comments
 (0)