1{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances #-}
2
3module Development.Shake.Internal.FileName(
4    FileName,
5    fileNameFromString, fileNameFromByteString,
6    fileNameToString, fileNameToByteString,
7    filepathNormalise
8    ) where
9
10import qualified Data.ByteString.Char8 as BS
11import qualified Data.ByteString.UTF8 as UTF8
12import Development.Shake.Classes
13import qualified System.FilePath as Native
14import General.Binary
15import System.Info.Extra
16import Data.List
17
18
19---------------------------------------------------------------------
20-- FileName newtype
21
22-- | UTF8 ByteString
23newtype FileName = FileName BS.ByteString
24    deriving (Hashable, Binary, BinaryEx, Eq, NFData)
25
26instance Show FileName where
27    show = fileNameToString
28
29instance BinaryEx [FileName] where
30    putEx = putEx . map (\(FileName x) -> x)
31    getEx = map FileName . getEx
32
33fileNameToString :: FileName -> FilePath
34fileNameToString = UTF8.toString . fileNameToByteString
35
36fileNameToByteString :: FileName -> BS.ByteString
37fileNameToByteString (FileName x) = x
38
39fileNameFromString :: FilePath -> FileName
40fileNameFromString = fileNameFromByteString . UTF8.fromString
41
42fileNameFromByteString :: BS.ByteString -> FileName
43fileNameFromByteString = FileName . filepathNormalise
44
45
46---------------------------------------------------------------------
47-- NORMALISATION
48
49-- | Equivalent to @toStandard . normaliseEx@ from "Development.Shake.FilePath".
50filepathNormalise :: BS.ByteString -> BS.ByteString
51filepathNormalise xs
52    | isWindows, Just (a,xs) <- BS.uncons xs, sep a, Just (b,_) <- BS.uncons xs, sep b = '/' `BS.cons` f xs
53    | otherwise = f xs
54    where
55        sep = Native.isPathSeparator
56        f o = deslash o $ BS.concat $ (slash:) $ intersperse slash $ reverse $ (BS.empty:) $ g 0 $ reverse $ split o
57
58        deslash o x
59            | x == slash = case (pre,pos) of
60                (True,True) -> slash
61                (True,False) -> BS.pack "/."
62                (False,True) -> BS.pack "./"
63                (False,False) -> dot
64            | otherwise = (if pre then id else BS.tail) $ (if pos then id else BS.init) x
65            where pre = not (BS.null o) && sep (BS.head o)
66                  pos = not (BS.null o) && sep (BS.last o)
67
68        g i [] = replicate i dotDot
69        g i (x:xs) | BS.null x = g i xs
70        g i (x:xs) | x == dotDot = g (i+1) xs
71        g i (x:xs) | x == dot = g i xs
72        g 0 (x:xs) = x : g 0 xs
73        g i (_:xs) = g (i-1) xs -- equivalent to eliminating ../x
74
75        split = BS.splitWith sep
76
77dotDot = BS.pack ".."
78dot = BS.singleton '.'
79slash = BS.singleton '/'
80