1 -- Copyright (C) 2002-2003 David Roundy 2 -- 3 -- This program is free software; you can redistribute it and/or modify 4 -- it under the terms of the GNU General Public License as published by 5 -- the Free Software Foundation; either version 2, or (at your option) 6 -- any later version. 7 -- 8 -- This program is distributed in the hope that it will be useful, 9 -- but WITHOUT ANY WARRANTY; without even the implied warranty of 10 -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 -- GNU General Public License for more details. 12 -- 13 -- You should have received a copy of the GNU General Public License 14 -- along with this program; see the file COPYING. If not, write to 15 -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 16 -- Boston, MA 02110-1301, USA. 17 18 -- | FileName is an abstract type intended to facilitate the input and output of 19 -- unicode filenames. 20 module Darcs.Patch.FileName ( FileName( ), 21 fp2fn, fn2fp, 22 fn2ps, ps2fn, 23 niceps2fn, fn2niceps, 24 break_on_dir, norm_path, own_name, super_name, 25 movedirfilename, 26 encode_white, decode_white, 27 (///), 28 breakup 29 ) where 30 31 import System.IO 32 import Data.Char ( isSpace, chr, ord ) 33 import qualified Codec.Binary.UTF8.String as UTF8 ( encode ) 34 import Data.Word ( Word8( ) ) 35 import ByteStringUtils ( unpackPSfromUTF8 ) 36 import qualified Data.ByteString.Char8 as BC (unpack, pack) 37 import qualified Data.ByteString as B (ByteString, pack) 38 39 newtype FileName = FN FilePath deriving ( Eq, Ord ) 40 encode :: [Char] -> [Word8] 41 encode = UTF8.encode 42 43 instance Show FileName where 44 showsPrec d (FN fp) = showParen (d > app_prec) $ showString "fp2fn " . showsPrec (app_prec + 1) fp 45 where app_prec = 10 46 47 {-# INLINE fp2fn #-} 48 fp2fn :: FilePath -> FileName 49 fp2fn fp = FN fp 50 51 {-# INLINE fn2fp #-} 52 fn2fp :: FileName -> FilePath 53 fn2fp (FN fp) = fp 54 55 {-# INLINE niceps2fn #-} 56 niceps2fn :: B.ByteString -> FileName 57 niceps2fn = FN . decode_white . BC.unpack 58 59 {-# INLINE fn2niceps #-} 60 fn2niceps :: FileName -> B.ByteString 61 fn2niceps (FN fp) = BC.pack $ encode_white fp 62 63 {-# INLINE fn2ps #-} 64 fn2ps :: FileName -> B.ByteString 65 fn2ps (FN fp) = B.pack $ encode $ encode_white fp 66 67 {-# INLINE ps2fn #-} 68 ps2fn :: B.ByteString -> FileName 69 ps2fn ps = FN $ decode_white $ unpackPSfromUTF8 ps 70 71 -- | 'encode_white' translates whitespace in filenames to a darcs-specific 72 -- format (backslash followed by numerical representation according to 'ord'). 73 -- Note that backslashes are also escaped since they are used in the encoding. 74 -- 75 -- > encode_white "hello there" == "hello\32there" 76 -- > encode_white "hello\there" == "hello\\there" 77 encode_white :: FilePath -> String 78 encode_white (c:cs) | isSpace c || c == '\\' = 79 '\\' : (show $ ord c) ++ "\\" ++ encode_white cs 80 encode_white (c:cs) = c : encode_white cs 81 encode_white [] = [] 82 83 -- | 'decode_white' interprets the Darcs-specific \"encoded\" filenames 84 -- produced by 'encode_white' 85 -- 86 -- > decode_white "hello\32there" == "hello there" 87 -- > decode_white "hello\\there" == "hello\there" 88 -- > decode_white "hello\there" == error "malformed filename" 89 decode_white :: String -> FilePath 90 decode_white ('\\':cs) = 91 case break (=='\\') cs of 92 (theord, '\\':rest) -> 93 chr (read theord) : decode_white rest 94 _ -> error "malformed filename" 95 decode_white (c:cs) = c: decode_white cs 96 decode_white "" = "" 97 98 own_name :: FileName -> FileName 99 own_name (FN f) = case breakLast '/' f of Nothing -> FN f 100 Just (_,f') -> FN f' 101 super_name :: FileName -> FileName 102 super_name fn = case norm_path fn of 103 FN f -> case breakLast '/' f of 104 Nothing -> FN "." 105 Just (d,_) -> FN d 106 break_on_dir :: FileName -> Maybe (FileName,FileName) 107 break_on_dir (FN p) = case breakFirst '/' p of 108 Nothing -> Nothing 109 Just (d,f) | d == "." -> break_on_dir $ FN f 110 | otherwise -> Just (FN d, FN f) 111 norm_path :: FileName -> FileName -- remove "./" 112 norm_path (FN p) = FN $ repath $ drop_dotdot $ breakup p 113 114 repath :: [String] -> String 115 repath [] = "" 116 repath [f] = f 117 repath (d:p) = d ++ "/" ++ repath p 118 119 drop_dotdot :: [String] -> [String] 120 drop_dotdot ("":p) = drop_dotdot p 121 drop_dotdot (".":p) = drop_dotdot p 122 drop_dotdot ("..":p) = ".." : (drop_dotdot p) 123 drop_dotdot (_:"..":p) = drop_dotdot p 124 drop_dotdot (d:p) = case drop_dotdot p of 125 ("..":p') -> p' 126 p' -> d : p' 127 drop_dotdot [] = [] 128 129 -- | Split a file path at the slashes 130 breakup :: String -> [String] 131 breakup p = case break (=='/') p of 132 (d,"") -> [d] 133 (d,p') -> d : breakup (tail p') 134 135 breakFirst :: Char -> String -> Maybe (String,String) 136 breakFirst c l = bf [] l 137 where bf a (r:rs) | r == c = Just (reverse a,rs) 138 | otherwise = bf (r:a) rs 139 bf _ [] = Nothing 140 breakLast :: Char -> String -> Maybe (String,String) 141 breakLast c l = case breakFirst c (reverse l) of 142 Nothing -> Nothing 143 Just (a,b) -> Just (reverse b, reverse a) 144 145 (///) :: FileName -> FileName -> FileName 146 (FN "")///b = norm_path b 147 a///b = norm_path $ fp2fn $ fn2fp a ++ "/" ++ fn2fp b 148 149 movedirfilename :: FileName -> FileName -> FileName -> FileName 150 movedirfilename old new name = 151 if name' == old' then new 152 else if length name' > length old' && 153 take (length old'+1) name' == old'++"/" 154 then fp2fn ("./"++new'++drop (length old') name') 155 else name 156 where old' = fn2fp $ norm_path old 157 new' = fn2fp $ norm_path new 158 name' = fn2fp $ norm_path name