1{-# OPTIONS_GHC -fno-warn-orphans #-} 2 3-- | 4-- Module: Filesystem.Path 5-- Copyright: 2010 John Millikin 6-- License: MIT 7-- 8-- Maintainer: jmillikin@gmail.com 9-- Portability: portable 10-- 11-- High‐level, byte‐based file and directory path 12-- manipulations. You probably want to import "Filesystem.Path.CurrentOS" 13-- instead, since it handles detecting which rules to use in the current 14-- compilation. 15-- 16module Filesystem.Path 17 ( FilePath 18 , empty 19 20 -- * Basic properties 21 , null 22 , root 23 , directory 24 , parent 25 , filename 26 , dirname 27 , basename 28 , absolute 29 , relative 30 31 -- * Basic operations 32 , append 33 , (</>) 34 , concat 35 , commonPrefix 36 , stripPrefix 37 , collapse 38 , splitDirectories 39 40 -- * Extensions 41 , extension 42 , extensions 43 , hasExtension 44 45 , addExtension 46 , (<.>) 47 , dropExtension 48 , replaceExtension 49 50 , addExtensions 51 , dropExtensions 52 , replaceExtensions 53 54 , splitExtension 55 , splitExtensions 56 ) where 57 58import Prelude hiding (FilePath, concat, null) 59import qualified Prelude as Prelude 60 61import Data.List (foldl') 62import Data.Maybe (isJust, isNothing) 63import qualified Data.Semigroup as Sem 64import qualified Data.Monoid as M 65import qualified Data.Text as T 66 67import Filesystem.Path.Internal 68 69instance Sem.Semigroup FilePath where 70 (<>) = append 71 72instance M.Monoid FilePath where 73 mempty = empty 74 mappend = append 75 mconcat = concat 76 77------------------------------------------------------------------------------- 78-- Basic properties 79------------------------------------------------------------------------------- 80 81-- | @null p = (p == 'empty')@ 82null :: FilePath -> Bool 83null = (== empty) 84 85-- | Retrieves the 'FilePath'’s root. 86root :: FilePath -> FilePath 87root p = empty { pathRoot = pathRoot p } 88 89-- | Retrieves the 'FilePath'’s directory. If the path is already a 90-- directory, it is returned unchanged. 91directory :: FilePath -> FilePath 92directory p = empty 93 { pathRoot = pathRoot p 94 , pathDirectories = let 95 dot' | isJust (pathRoot p) = [] 96 | Prelude.null (pathDirectories p) = [dot] 97 | otherwise = [] 98 in dot' ++ pathDirectories p 99 } 100 101-- | Retrieves the 'FilePath'’s parent directory. 102parent :: FilePath -> FilePath 103parent p = empty 104 { pathRoot = pathRoot p 105 , pathDirectories = let 106 starts = map Just [dot, dots] 107 directories = if null (filename p) 108 then safeInit (pathDirectories p) 109 else pathDirectories p 110 111 dot' | safeHead directories `elem` starts = [] 112 | isNothing (pathRoot p) = [dot] 113 | otherwise = [] 114 in dot' ++ directories 115 } 116 117-- | Retrieve a 'FilePath'’s filename component. 118-- 119-- @ 120-- filename \"foo\/bar.txt\" == \"bar.txt\" 121-- @ 122filename :: FilePath -> FilePath 123filename p = empty 124 { pathBasename = pathBasename p 125 , pathExtensions = pathExtensions p 126 } 127 128-- | Retrieve a 'FilePath'’s directory name. This is only the 129-- /file name/ of the directory, not its full path. 130-- 131-- @ 132-- dirname \"foo\/bar\/baz.txt\" == \"bar\" 133-- dirname \"/\" == \"\" 134-- @ 135-- 136-- Since: 0.4.1 137dirname :: FilePath -> FilePath 138dirname p = case reverse (pathDirectories p) of 139 [] -> FilePath Nothing [] Nothing [] 140 (d:_) -> case parseFilename d of 141 (base, exts) -> FilePath Nothing [] base exts 142 143-- | Retrieve a 'FilePath'’s basename component. 144-- 145-- @ 146-- basename \"foo/bar.txt\" == \"bar\" 147-- @ 148basename :: FilePath -> FilePath 149basename p = empty 150 { pathBasename = pathBasename p 151 } 152 153-- | Test whether a path is absolute. 154absolute :: FilePath -> Bool 155absolute p = case pathRoot p of 156 Just RootPosix -> True 157 Just RootWindowsVolume{} -> True 158 Just RootWindowsCurrentVolume -> False 159 Just RootWindowsUnc{} -> True 160 Just RootWindowsDoubleQMark -> True 161 Nothing -> False 162 163-- | Test whether a path is relative. 164relative :: FilePath -> Bool 165relative p = case pathRoot p of 166 Just _ -> False 167 _ -> True 168 169------------------------------------------------------------------------------- 170-- Basic operations 171------------------------------------------------------------------------------- 172 173-- | Appends two 'FilePath's. If the second path is absolute, it is returned 174-- unchanged. 175append :: FilePath -> FilePath -> FilePath 176append x y = cased where 177 cased = case pathRoot y of 178 Just RootPosix -> y 179 Just RootWindowsVolume{} -> y 180 Just RootWindowsCurrentVolume -> case pathRoot x of 181 Just RootWindowsVolume{} -> y { pathRoot = pathRoot x } 182 _ -> y 183 Just RootWindowsUnc{} -> y 184 Just RootWindowsDoubleQMark -> y 185 Nothing -> xy 186 xy = y 187 { pathRoot = pathRoot x 188 , pathDirectories = directories 189 } 190 directories = xDirectories ++ pathDirectories y 191 xDirectories = (pathDirectories x ++) $ if null (filename x) 192 then [] 193 else [filenameChunk x] 194 195-- | An alias for 'append'. 196(</>) :: FilePath -> FilePath -> FilePath 197(</>) = append 198 199-- | A fold over 'append'. 200concat :: [FilePath] -> FilePath 201concat [] = empty 202concat ps = foldr1 append ps 203 204-- | Find the greatest common prefix between a list of 'FilePath's. 205commonPrefix :: [FilePath] -> FilePath 206commonPrefix [] = empty 207commonPrefix ps = foldr1 step ps where 208 step x y = if pathRoot x /= pathRoot y 209 then empty 210 else let cs = commonDirectories x y in 211 if cs /= pathDirectories x || pathBasename x /= pathBasename y 212 then empty { pathRoot = pathRoot x, pathDirectories = cs } 213 else let exts = commonExtensions x y in 214 x { pathExtensions = exts } 215 216 commonDirectories x y = common (pathDirectories x) (pathDirectories y) 217 commonExtensions x y = common (pathExtensions x) (pathExtensions y) 218 219 common [] _ = [] 220 common _ [] = [] 221 common (x:xs) (y:ys) = if x == y 222 then x : common xs ys 223 else [] 224 225-- | Remove a prefix from a path. 226-- 227-- @ 228-- 'stripPrefix' \"\/foo\/\" \"\/foo\/bar\/baz.txt\" == Just \"bar\/baz.txt\" 229-- 'stripPrefix' \"\/foo\/\" \"\/bar\/baz.txt\" == Nothing 230-- @ 231-- 232-- This function operates on logical prefixes, rather than by counting 233-- characters. The prefix @\"\/foo\/bar\/baz\"@ is interpreted the path 234-- @(\"\/foo\/bar\/\", \"baz\")@, and will be stripped accordingly: 235-- 236-- @ 237-- 'stripPrefix' \"\/foo\/bar\/baz\" \"\/foo\/bar\/baz\/qux\" == Nothing 238-- 'stripPrefix' \"\/foo\/bar\/baz\" \"\/foo\/bar\/baz.txt\" == Just \".txt\" 239-- @ 240-- 241-- Since: 0.4.1 242stripPrefix :: FilePath -> FilePath -> Maybe FilePath 243stripPrefix x y = if pathRoot x /= pathRoot y 244 then case pathRoot x of 245 Nothing -> Just y 246 Just _ -> Nothing 247 else do 248 dirs <- strip (pathDirectories x) (pathDirectories y) 249 case dirs of 250 [] -> case (pathBasename x, pathBasename y) of 251 (Nothing, Nothing) -> do 252 exts <- strip (pathExtensions x) (pathExtensions y) 253 return (y { pathRoot = Nothing, pathDirectories = dirs, pathExtensions = exts }) 254 (Nothing, Just _) -> case pathExtensions x of 255 [] -> Just (y { pathRoot = Nothing, pathDirectories = dirs }) 256 _ -> Nothing 257 (Just x_b, Just y_b) | x_b == y_b -> do 258 exts <- strip (pathExtensions x) (pathExtensions y) 259 return (empty { pathExtensions = exts }) 260 _ -> Nothing 261 _ -> case (pathBasename x, pathExtensions x) of 262 (Nothing, []) -> Just (y { pathRoot = Nothing, pathDirectories = dirs }) 263 _ -> Nothing 264 265strip :: Eq a => [a] -> [a] -> Maybe [a] 266strip [] ys = Just ys 267strip _ [] = Nothing 268strip (x:xs) (y:ys) = if x == y 269 then strip xs ys 270 else Nothing 271 272-- | Remove intermediate @\".\"@ and @\"..\"@ directories from a path. 273-- 274-- @ 275-- 'collapse' \"\/foo\/.\/bar\" == \"\/foo\/bar\" 276-- 'collapse' \"\/foo\/bar\/..\/baz\" == \"\/foo\/baz\" 277-- 'collapse' \"\/foo\/..\/..\/bar\" == \"\/bar\" 278-- 'collapse' \".\/foo\/bar\" == \".\/foo\/baz\" 279-- @ 280-- 281-- Note that if any of the elements are symbolic links, 'collapse' may change 282-- which file the path resolves to. 283-- 284-- Since: 0.2 285collapse :: FilePath -> FilePath 286collapse p = p { pathDirectories = newDirs } where 287 newDirs = case pathRoot p of 288 Nothing -> reverse revNewDirs 289 Just _ -> dropWhile (\x -> x == dot || x == dots) (reverse revNewDirs) 290 (_, revNewDirs) = foldl' step (True, []) (pathDirectories p) 291 292 step (True, acc) c = (False, c:acc) 293 step (_, acc) c | c == dot = (False, acc) 294 step (_, acc) c | c == dots = case acc of 295 [] -> (False, c:acc) 296 (h:ts) | h == dot -> (False, c:ts) 297 | h == dots -> (False, c:acc) 298 | otherwise -> (False, ts) 299 step (_, acc) c = (False, c:acc) 300 301-- | expand a FilePath into a list of the root name, directories, and file name 302-- 303-- Since: 0.4.7 304splitDirectories :: FilePath -> [FilePath] 305splitDirectories p = rootName ++ dirNames ++ fileName where 306 rootName = case pathRoot p of 307 Nothing -> [] 308 r -> [empty { pathRoot = r }] 309 dirNames = map (\d -> empty { pathDirectories = [d] }) (pathDirectories p) 310 fileName = case (pathBasename p, pathExtensions p) of 311 (Nothing, []) -> [] 312 _ -> [filename p] 313 314------------------------------------------------------------------------------- 315-- Extensions 316------------------------------------------------------------------------------- 317 318-- | Get a 'FilePath'’s last extension, or 'Nothing' if it has no 319-- extensions. 320extension :: FilePath -> Maybe T.Text 321extension p = case extensions p of 322 [] -> Nothing 323 es -> Just (last es) 324 325-- | Get a 'FilePath'’s full extension list. 326extensions :: FilePath -> [T.Text] 327extensions = map unescape' . pathExtensions 328 329 330-- | Get whether a 'FilePath'’s last extension is the predicate. 331hasExtension :: FilePath -> T.Text -> Bool 332hasExtension p e = extension p == Just e 333 334-- | Append an extension to the end of a 'FilePath'. 335addExtension :: FilePath -> T.Text -> FilePath 336addExtension p ext = addExtensions p [ext] 337 338-- | Append many extensions to the end of a 'FilePath'. 339addExtensions :: FilePath -> [T.Text] -> FilePath 340addExtensions p exts = p { pathExtensions = newExtensions } where 341 newExtensions = pathExtensions p ++ map escape exts 342 343-- | An alias for 'addExtension'. 344(<.>) :: FilePath -> T.Text -> FilePath 345(<.>) = addExtension 346 347-- | Remove a 'FilePath'’s last extension. 348dropExtension :: FilePath -> FilePath 349dropExtension p = p { pathExtensions = safeInit (pathExtensions p) } 350 351-- | Remove all extensions from a 'FilePath'. 352dropExtensions :: FilePath -> FilePath 353dropExtensions p = p { pathExtensions = [] } 354 355-- | Replace a 'FilePath'’s last extension. 356replaceExtension :: FilePath -> T.Text -> FilePath 357replaceExtension = addExtension . dropExtension 358 359-- | Remove all extensions from a 'FilePath', and replace them with a new 360-- list. 361replaceExtensions :: FilePath -> [T.Text] -> FilePath 362replaceExtensions = addExtensions . dropExtensions 363 364-- | @splitExtension p = ('dropExtension' p, 'extension' p)@ 365splitExtension :: FilePath -> (FilePath, Maybe T.Text) 366splitExtension p = (dropExtension p, extension p) 367 368-- | @splitExtensions p = ('dropExtensions' p, 'extensions' p)@ 369splitExtensions :: FilePath -> (FilePath, [T.Text]) 370splitExtensions p = (dropExtensions p, extensions p) 371 372------------------------------------------------------------------------------- 373-- Utils 374------------------------------------------------------------------------------- 375 376safeInit :: [a] -> [a] 377safeInit xs = case xs of 378 [] -> [] 379 _ -> init xs 380 381safeHead :: [a] -> Maybe a 382safeHead [] = Nothing 383safeHead (x:_) = Just x 384