src/Darcs/Patch/FileName.lhs

   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
  19 FileName is an abstract type intended to facilitate the input and output of
  20 unicode filenames.
  21
  22 \begin{code}
  23 module Darcs.Patch.FileName ( FileName( ),
  24                               fp2fn, fn2fp,
  25                               fn2ps, ps2fn,
  26                               niceps2fn, fn2niceps,
  27                               break_on_dir, norm_path, own_name, super_name,
  28                               movedirfilename,
  29                               encode_white, decode_white,
  30                               (///),
  31                             ) where
  32
  33 import System.IO
  34 import Data.Char ( isSpace, chr, ord )
  35 import qualified UTF8 ( encode )
  36 import Data.Word ( Word8( ) )
  37 import ByteStringUtils ( unpackPSfromUTF8 )
  38 import qualified Data.ByteString.Char8 as BC (unpack, pack)
  39 import qualified Data.ByteString       as B  (ByteString, pack)
  40 \end{code}
  41
  42 \begin{code}
  43 newtype FileName = FN FilePath deriving ( Eq, Ord )
  44 encode :: [Char] -> [Word8]
  45 encode = UTF8.encode
  46
  47 instance Show FileName where
  48    showsPrec d (FN fp) = showParen (d > app_prec) $ showString "fp2fn " . showsPrec (app_prec + 1) fp
  49       where app_prec = 10
  50
  51 {-# INLINE fp2fn #-}
  52 fp2fn :: FilePath -> FileName
  53 fp2fn fp = FN fp
  54
  55 {-# INLINE fn2fp #-}
  56 fn2fp :: FileName -> FilePath
  57 fn2fp (FN fp) = fp
  58
  59 {-# INLINE niceps2fn #-}
  60 niceps2fn :: B.ByteString -> FileName
  61 niceps2fn = FN . decode_white . BC.unpack
  62
  63 {-# INLINE fn2niceps #-}
  64 fn2niceps :: FileName -> B.ByteString
  65 fn2niceps (FN fp) = BC.pack $ encode_white fp
  66
  67 {-# INLINE fn2ps #-}
  68 fn2ps :: FileName -> B.ByteString
  69 fn2ps (FN fp) = B.pack $ encode $ encode_white fp
  70
  71 {-# INLINE ps2fn #-}
  72 ps2fn :: B.ByteString -> FileName
  73 ps2fn ps = FN $ decode_white $ unpackPSfromUTF8 ps
  74
  75 encode_white :: FilePath -> String
  76 encode_white (c:cs) | isSpace c || c == '\\' =
  77     '\\' : (show $ ord c) ++ "\\" ++ encode_white cs
  78 encode_white (c:cs) = c : encode_white cs
  79 encode_white [] = []
  80
  81 decode_white :: String -> FilePath
  82 decode_white ('\\':cs) =
  83     case break (=='\\') cs of
  84     (theord, '\\':rest) ->
  85         chr (read theord) : decode_white rest
  86     _ -> error "malformed filename"
  87 decode_white (c:cs) = c: decode_white cs
  88 decode_white "" = ""
  89 \end{code}
  90
  91 \begin{code}
  92 own_name :: FileName -> FileName
  93 own_name (FN f) = case breakLast '/' f of Nothing -> FN f
  94                                           Just (_,f') -> FN f'
  95 super_name :: FileName -> FileName
  96 super_name fn = case norm_path fn of
  97                 FN f -> case breakLast '/' f of
  98                         Nothing -> FN "."
  99                         Just (d,_) -> FN d
 100 break_on_dir :: FileName -> Maybe (FileName,FileName)
 101 break_on_dir (FN p) = case breakFirst '/' p of
 102                       Nothing -> Nothing
 103                       Just (d,f) | d == "." -> break_on_dir $ FN f
 104                                  | otherwise -> Just (FN d, FN f)
 105 norm_path :: FileName -> FileName -- remove "./"
 106 norm_path (FN p) = FN $ repath $ drop_dotdot $ breakup p
 107
 108 repath :: [String] -> String
 109 repath [] = ""
 110 repath [f] = f
 111 repath (d:p) = d ++ "/" ++ repath p
 112
 113 drop_dotdot :: [String] -> [String]
 114 drop_dotdot ("":p) = drop_dotdot p
 115 drop_dotdot (".":p) = drop_dotdot p
 116 drop_dotdot ("..":p) = ".." : (drop_dotdot p)
 117 drop_dotdot (_:"..":p) = drop_dotdot p
 118 drop_dotdot (d:p) = case drop_dotdot p of
 119                     ("..":p') -> p'
 120                     p' -> d : p'
 121 drop_dotdot [] = []
 122
 123 breakup :: String -> [String]
 124 breakup p = case break (=='/') p of
 125             (d,"") -> [d]
 126             (d,p') -> d : breakup (tail p')
 127
 128 breakFirst :: Char -> String -> Maybe (String,String)
 129 breakFirst c l = bf [] l
 130     where bf a (r:rs) | r == c = Just (reverse a,rs)
 131                       | otherwise = bf (r:a) rs
 132           bf _ [] = Nothing
 133 breakLast :: Char -> String -> Maybe (String,String)
 134 breakLast c l = case breakFirst c (reverse l) of
 135                 Nothing -> Nothing
 136                 Just (a,b) -> Just (reverse b, reverse a)
 137
 138 (///) :: FileName -> FileName -> FileName
 139 (FN "")///b = norm_path b
 140 a///b = norm_path $ fp2fn $ fn2fp a ++ "/" ++ fn2fp b
 141
 142 movedirfilename :: FileName -> FileName -> FileName -> FileName
 143 movedirfilename old new name =
 144     if name' == old' then new
 145                      else if length name' > length old' &&
 146                              take (length old'+1) name' == old'++"/"
 147                           then fp2fn ("./"++new'++drop (length old') name')
 148                           else name
 149     where old' = fn2fp $ norm_path old
 150           new' = fn2fp $ norm_path new
 151           name' = fn2fp $ norm_path name
 152
 153 \end{code}