1-- This template expects CPP definitions for: 2-- PLATFORM_NAME = Posix | Windows 3-- IS_WINDOWS = False | True 4 5-- | This library provides a well-typed representation of paths in a filesystem 6-- directory tree. 7-- 8-- __Note__: This module is for working with PLATFORM_NAME style paths. Importing 9-- "Path" is usually better. 10-- 11-- A path is represented by a number of path components separated by a path 12-- separator which is a @/@ on POSIX systems and can be a @/@ or @\\@ on Windows. 13-- The root of the tree is represented by a @/@ on POSIX and a drive letter 14-- followed by a @/@ or @\\@ on Windows (e.g. @C:\\@). Paths can be absolute 15-- or relative. An absolute path always starts from the root of the tree (e.g. 16-- @\/x/y@) whereas a relative path never starts with the root (e.g. @x/y@). 17-- Just like we represent the notion of an absolute root by "@/@", the same way 18-- we represent the notion of a relative root by "@.@". The relative root denotes 19-- the directory which contains the first component of a relative path. 20 21{-# LANGUAGE TemplateHaskell #-} 22{-# LANGUAGE PatternGuards #-} 23{-# LANGUAGE DeriveDataTypeable #-} 24{-# LANGUAGE DeriveGeneric #-} 25{-# LANGUAGE EmptyDataDecls #-} 26{-# LANGUAGE FlexibleInstances #-} 27 28module Path.PLATFORM_NAME 29 (-- * Types 30 Path 31 ,Abs 32 ,Rel 33 ,File 34 ,Dir 35 ,SomeBase(..) 36 -- * Exceptions 37 ,PathException(..) 38 -- * QuasiQuoters 39 -- | Using the following requires the QuasiQuotes language extension. 40 -- 41 -- __For Windows users__, the QuasiQuoters are especially beneficial because they 42 -- prevent Haskell from treating @\\@ as an escape character. 43 -- This makes Windows paths easier to write. 44 -- 45 -- @ 46 -- [absfile|C:\\chris\\foo.txt|] 47 -- @ 48 ,absdir 49 ,reldir 50 ,absfile 51 ,relfile 52 -- * Operations 53 ,(</>) 54 ,stripProperPrefix 55 ,isProperPrefixOf 56 ,parent 57 ,filename 58 ,dirname 59 ,addExtension 60 ,splitExtension 61 ,fileExtension 62 ,replaceExtension 63 -- * Parsing 64 ,parseAbsDir 65 ,parseRelDir 66 ,parseAbsFile 67 ,parseRelFile 68 ,parseSomeDir 69 ,parseSomeFile 70 -- * Conversion 71 ,toFilePath 72 ,fromAbsDir 73 ,fromRelDir 74 ,fromAbsFile 75 ,fromRelFile 76 ,fromSomeDir 77 ,fromSomeFile 78 -- * TemplateHaskell constructors 79 -- | These require the TemplateHaskell language extension. 80 ,mkAbsDir 81 ,mkRelDir 82 ,mkAbsFile 83 ,mkRelFile 84 -- * Deprecated 85 ,PathParseException 86 ,stripDir 87 ,isParentOf 88 ,addFileExtension 89 ,(<.>) 90 ,setFileExtension 91 ,(-<.>) 92 ) 93 where 94 95import Control.Applicative (Alternative(..)) 96import Control.DeepSeq (NFData (..)) 97import Control.Exception (Exception(..)) 98import Control.Monad (liftM, when) 99import Control.Monad.Catch (MonadThrow(..)) 100import Data.Aeson (FromJSON (..), FromJSONKey(..), ToJSON(..)) 101import qualified Data.Aeson.Types as Aeson 102import Data.Data 103import qualified Data.Text as T 104import Data.Hashable 105import qualified Data.List as L 106import Data.Maybe 107import GHC.Generics (Generic) 108import Language.Haskell.TH 109import Language.Haskell.TH.Syntax (lift) 110import Language.Haskell.TH.Quote (QuasiQuoter(..)) 111import Path.Internal 112import qualified System.FilePath.PLATFORM_NAME as FilePath 113 114-------------------------------------------------------------------------------- 115-- Types 116 117-- | An absolute path. 118data Abs deriving (Typeable) 119 120-- | A relative path; one without a root. Note that a @..@ path component to 121-- represent the parent directory is not allowed by this library. 122data Rel deriving (Typeable) 123 124-- | A file path. 125data File deriving (Typeable) 126 127-- | A directory path. 128data Dir deriving (Typeable) 129 130instance FromJSON (Path Abs File) where 131 parseJSON = parseJSONWith parseAbsFile 132 {-# INLINE parseJSON #-} 133 134instance FromJSON (Path Rel File) where 135 parseJSON = parseJSONWith parseRelFile 136 {-# INLINE parseJSON #-} 137 138instance FromJSON (Path Abs Dir) where 139 parseJSON = parseJSONWith parseAbsDir 140 {-# INLINE parseJSON #-} 141 142instance FromJSON (Path Rel Dir) where 143 parseJSON = parseJSONWith parseRelDir 144 {-# INLINE parseJSON #-} 145 146parseJSONWith :: (Show e, FromJSON a) 147 => (a -> Either e b) -> Aeson.Value -> Aeson.Parser b 148parseJSONWith f x = 149 do fp <- parseJSON x 150 case f fp of 151 Right p -> return p 152 Left e -> fail (show e) 153{-# INLINE parseJSONWith #-} 154 155instance FromJSONKey (Path Abs File) where 156 fromJSONKey = fromJSONKeyWith parseAbsFile 157 {-# INLINE fromJSONKey #-} 158 159instance FromJSONKey (Path Rel File) where 160 fromJSONKey = fromJSONKeyWith parseRelFile 161 {-# INLINE fromJSONKey #-} 162 163instance FromJSONKey (Path Abs Dir) where 164 fromJSONKey = fromJSONKeyWith parseAbsDir 165 {-# INLINE fromJSONKey #-} 166 167instance FromJSONKey (Path Rel Dir) where 168 fromJSONKey = fromJSONKeyWith parseRelDir 169 {-# INLINE fromJSONKey #-} 170 171fromJSONKeyWith :: (Show e) 172 => (String -> Either e b) -> Aeson.FromJSONKeyFunction b 173fromJSONKeyWith f = 174 Aeson.FromJSONKeyTextParser $ \t -> 175 case f (T.unpack t) of 176 Left e -> fail (show e) 177 Right rf -> pure rf 178 179{-# INLINE fromJSONKeyWith #-} 180 181-- | Exceptions that can occur during path operations. 182-- 183-- @since 0.6.0 184data PathException 185 = InvalidAbsDir FilePath 186 | InvalidRelDir FilePath 187 | InvalidAbsFile FilePath 188 | InvalidRelFile FilePath 189 | InvalidFile FilePath 190 | InvalidDir FilePath 191 | NotAProperPrefix FilePath FilePath 192 | HasNoExtension FilePath 193 | InvalidExtension String 194 deriving (Show,Eq,Typeable) 195 196instance Exception PathException where 197 displayException (InvalidExtension ext) = concat 198 [ "Invalid extension [" 199 , ext 200 , "]. A valid extension starts with a '.' followed by one or more " 201 , "characters other than '.', and it must be a valid filename, " 202 , "notably it cannot include a path separator." 203 ] 204 displayException x = show x 205 206-------------------------------------------------------------------------------- 207-- QuasiQuoters 208 209qq :: (String -> Q Exp) -> QuasiQuoter 210qq quoteExp' = 211 QuasiQuoter 212 { quoteExp = quoteExp' 213 , quotePat = \_ -> 214 fail "illegal QuasiQuote (allowed as expression only, used as a pattern)" 215 , quoteType = \_ -> 216 fail "illegal QuasiQuote (allowed as expression only, used as a type)" 217 , quoteDec = \_ -> 218 fail "illegal QuasiQuote (allowed as expression only, used as a declaration)" 219 } 220 221-- | Construct a 'Path' 'Abs' 'Dir' using QuasiQuotes. 222-- 223-- @ 224-- [absdir|/|] 225-- 226-- [absdir|\/home\/chris|] 227-- @ 228-- 229-- Remember: due to the nature of absolute paths a path like @[absdir|\/home\/chris|]@ 230-- may compile on your platform, but it may not compile on another 231-- platform (Windows). 232-- 233-- @since 0.5.13 234absdir :: QuasiQuoter 235absdir = qq mkAbsDir 236 237-- | Construct a 'Path' 'Rel' 'Dir' using QuasiQuotes. 238-- 239-- @ 240-- [absdir|\/home|]\<\/>[reldir|chris|] 241-- @ 242-- 243-- @since 0.5.13 244reldir :: QuasiQuoter 245reldir = qq mkRelDir 246 247-- | Construct a 'Path' 'Abs' 'File' using QuasiQuotes. 248-- 249-- @ 250-- [absfile|\/home\/chris\/foo.txt|] 251-- @ 252-- 253-- Remember: due to the nature of absolute paths a path like @[absdir|\/home\/chris\/foo.txt|]@ 254-- may compile on your platform, but it may not compile on another 255-- platform (Windows). 256-- 257-- @since 0.5.13 258absfile :: QuasiQuoter 259absfile = qq mkAbsFile 260 261-- | Construct a 'Path' 'Rel' 'File' using QuasiQuotes. 262-- 263-- @ 264-- [absdir|\/home\/chris|]\<\/>[relfile|foo.txt|] 265-- @ 266-- 267-- @since 0.5.13 268relfile :: QuasiQuoter 269relfile = qq mkRelFile 270 271-------------------------------------------------------------------------------- 272-- Operations 273 274-- | Append two paths. 275-- 276-- The following cases are valid and the equalities hold: 277-- 278-- @$(mkAbsDir x) \<\/> $(mkRelDir y) = $(mkAbsDir (x ++ \"/\" ++ y))@ 279-- 280-- @$(mkAbsDir x) \<\/> $(mkRelFile y) = $(mkAbsFile (x ++ \"/\" ++ y))@ 281-- 282-- @$(mkRelDir x) \<\/> $(mkRelDir y) = $(mkRelDir (x ++ \"/\" ++ y))@ 283-- 284-- @$(mkRelDir x) \<\/> $(mkRelFile y) = $(mkRelFile (x ++ \"/\" ++ y))@ 285-- 286-- The following are proven not possible to express: 287-- 288-- @$(mkAbsFile …) \<\/> x@ 289-- 290-- @$(mkRelFile …) \<\/> x@ 291-- 292-- @x \<\/> $(mkAbsFile …)@ 293-- 294-- @x \<\/> $(mkAbsDir …)@ 295-- 296infixr 5 </> 297(</>) :: Path b Dir -> Path Rel t -> Path b t 298(</>) (Path a) (Path b) = Path (a ++ b) 299 300-- | If the directory in the first argument is a proper prefix of the path in 301-- the second argument strip it from the second argument, generating a path 302-- relative to the directory. 303-- Throws 'NotAProperPrefix' if the directory is not a proper prefix of the 304-- path. 305-- 306-- The following properties hold: 307-- 308-- @stripProperPrefix x (x \<\/> y) = y@ 309-- 310-- Cases which are proven not possible: 311-- 312-- @stripProperPrefix (a :: Path Abs …) (b :: Path Rel …)@ 313-- 314-- @stripProperPrefix (a :: Path Rel …) (b :: Path Abs …)@ 315-- 316-- In other words the bases must match. 317-- 318-- @since 0.6.0 319stripProperPrefix :: MonadThrow m 320 => Path b Dir -> Path b t -> m (Path Rel t) 321stripProperPrefix (Path p) (Path l) = 322 case L.stripPrefix p l of 323 Nothing -> throwM (NotAProperPrefix p l) 324 Just "" -> throwM (NotAProperPrefix p l) 325 Just ok -> return (Path ok) 326 327-- | Determines if the path in the first parameter is a proper prefix of the 328-- path in the second parameter. 329-- 330-- The following properties hold: 331-- 332-- @not (x \`isProperPrefixOf\` x)@ 333-- 334-- @x \`isProperPrefixOf\` (x \<\/\> y)@ 335-- 336-- @since 0.6.0 337isProperPrefixOf :: Path b Dir -> Path b t -> Bool 338isProperPrefixOf p l = isJust (stripProperPrefix p l) 339 340-- | Take the parent path component from a path. 341-- 342-- The following properties hold: 343-- 344-- @ 345-- parent (x \<\/> y) == x 346-- parent \"\/x\" == \"\/\" 347-- parent \"x\" == \".\" 348-- @ 349-- 350-- On the root (absolute or relative), getting the parent is idempotent: 351-- 352-- @ 353-- parent \"\/\" = \"\/\" 354-- parent \"\.\" = \"\.\" 355-- @ 356-- 357parent :: Path b t -> Path b Dir 358parent (Path "") = Path "" 359parent (Path fp) | FilePath.isDrive fp = Path fp 360parent (Path fp) = 361 Path 362 $ normalizeDir 363 $ FilePath.takeDirectory 364 $ FilePath.dropTrailingPathSeparator fp 365 366-- | Extract the file part of a path. 367-- 368-- The following properties hold: 369-- 370-- @filename (p \<\/> a) == filename a@ 371-- 372filename :: Path b File -> Path Rel File 373filename (Path l) = 374 Path (FilePath.takeFileName l) 375 376-- | Extract the last directory name of a path. 377-- 378-- The following properties hold: 379-- 380-- @dirname $(mkRelDir ".") == $(mkRelDir ".")@ 381-- 382-- @dirname (p \<\/> a) == dirname a@ 383-- 384dirname :: Path b Dir -> Path Rel Dir 385dirname (Path "") = Path "" 386dirname (Path l) | FilePath.isDrive l = Path "" 387dirname (Path l) = Path (last (FilePath.splitPath l)) 388 389-- | 'splitExtension' is the inverse of 'addExtension'. It splits the given 390-- file path into a valid filename and a valid extension. 391-- 392-- >>> splitExtension $(mkRelFile "name.foo" ) == Just ($(mkRelFile "name" ), ".foo" ) 393-- >>> splitExtension $(mkRelFile "name.foo." ) == Just ($(mkRelFile "name" ), ".foo." ) 394-- >>> splitExtension $(mkRelFile "name.foo.." ) == Just ($(mkRelFile "name" ), ".foo..") 395-- >>> splitExtension $(mkRelFile "name.bar.foo" ) == Just ($(mkRelFile "name.bar"), ".foo" ) 396-- >>> splitExtension $(mkRelFile ".name.foo" ) == Just ($(mkRelFile ".name" ), ".foo" ) 397-- >>> splitExtension $(mkRelFile "name..foo" ) == Just ($(mkRelFile "name." ), ".foo" ) 398-- >>> splitExtension $(mkRelFile "....foo" ) == Just ($(mkRelFile "..." ), ".foo" ) 399-- 400-- Throws 'HasNoExtension' exception if the filename does not have an extension 401-- or in other words it cannot be split into a valid filename and a valid 402-- extension. The following cases throw an exception, please note that "." and 403-- ".." are not valid filenames: 404-- 405-- >>> splitExtension $(mkRelFile "name" ) 406-- >>> splitExtension $(mkRelFile "name." ) 407-- >>> splitExtension $(mkRelFile "name.." ) 408-- >>> splitExtension $(mkRelFile ".name" ) 409-- >>> splitExtension $(mkRelFile "..name" ) 410-- >>> splitExtension $(mkRelFile "...name") 411-- 412-- 'splitExtension' and 'addExtension' are inverses of each other, the 413-- following laws hold: 414-- 415-- @ 416-- uncurry addExtension . swap >=> splitExtension == return 417-- splitExtension >=> uncurry addExtension . swap == return 418-- @ 419-- 420-- @since 0.7.0 421splitExtension :: MonadThrow m => Path b File -> m (Path b File, String) 422splitExtension (Path fpath) = 423 if nameDot == [] || ext == [] 424 then throwM $ HasNoExtension fpath 425 else let fname = init nameDot 426 in if fname == [] || fname == "." || fname == ".." 427 then throwM $ HasNoExtension fpath 428 else return ( Path (normalizeDrive drv ++ dir ++ fname) 429 , FilePath.extSeparator : ext 430 ) 431 where 432 433 -- trailing separators are ignored for the split and considered part of the 434 -- second component in the split. 435 splitLast isSep str = 436 let rstr = reverse str 437 notSep = not . isSep 438 name = (dropWhile notSep . dropWhile isSep) rstr 439 trailingSeps = takeWhile isSep rstr 440 xtn = (takeWhile notSep . dropWhile isSep) rstr 441 in (reverse name, reverse xtn ++ trailingSeps) 442 normalizeDrive 443 | IS_WINDOWS = normalizeTrailingSeps 444 | otherwise = id 445 446 (drv, pth) = FilePath.splitDrive fpath 447 (dir, file) = splitLast FilePath.isPathSeparator pth 448 (nameDot, ext) = splitLast FilePath.isExtSeparator file 449 450-- | Get extension from given file path. Throws 'HasNoExtension' exception if 451-- the file does not have an extension. The following laws hold: 452-- 453-- @ 454-- flip addExtension file >=> fileExtension == return 455-- fileExtension == (fmap snd) . splitExtension 456-- @ 457-- 458-- @since 0.5.11 459fileExtension :: MonadThrow m => Path b File -> m String 460fileExtension = (liftM snd) . splitExtension 461 462-- | Add extension to given file path. 463-- 464-- >>> addExtension ".foo" $(mkRelFile "name" ) == Just $(mkRelFile "name.foo" ) 465-- >>> addExtension ".foo." $(mkRelFile "name" ) == Just $(mkRelFile "name.foo." ) 466-- >>> addExtension ".foo.." $(mkRelFile "name" ) == Just $(mkRelFile "name.foo.." ) 467-- >>> addExtension ".foo" $(mkRelFile "name.bar" ) == Just $(mkRelFile "name.bar.foo") 468-- >>> addExtension ".foo" $(mkRelFile ".name" ) == Just $(mkRelFile ".name.foo" ) 469-- >>> addExtension ".foo" $(mkRelFile "name." ) == Just $(mkRelFile "name..foo" ) 470-- >>> addExtension ".foo" $(mkRelFile "..." ) == Just $(mkRelFile "....foo" ) 471-- 472-- Throws an 'InvalidExtension' exception if the extension is not valid. A 473-- valid extension starts with a @.@ followed by one or more characters not 474-- including @.@ followed by zero or more @.@ in trailing position. Moreover, 475-- an extension must be a valid filename, notably it cannot include path 476-- separators. Particularly, @.foo.bar@ is an invalid extension, instead you 477-- have to first set @.foo@ and then @.bar@ individually. Some examples of 478-- invalid extensions are: 479-- 480-- >>> addExtension "foo" $(mkRelFile "name") 481-- >>> addExtension "..foo" $(mkRelFile "name") 482-- >>> addExtension ".foo.bar" $(mkRelFile "name") 483-- >>> addExtension ".foo/bar" $(mkRelFile "name") 484-- 485-- @since 0.7.0 486addExtension :: MonadThrow m 487 => String -- ^ Extension to add 488 -> Path b File -- ^ Old file name 489 -> m (Path b File) -- ^ New file name with the desired extension added at the end 490addExtension ext (Path path) = do 491 validateExtension ext 492 return $ Path (path ++ ext) 493 494 where 495 496 validateExtension ex@(sep:xs) = do 497 -- has to start with a "." 498 when (not $ FilePath.isExtSeparator sep) $ 499 throwM $ InvalidExtension ex 500 501 -- just a "." is not a valid extension 502 when (xs == []) $ 503 throwM $ InvalidExtension ex 504 505 -- cannot have path separators 506 when (any FilePath.isPathSeparator xs) $ 507 throwM $ InvalidExtension ex 508 509 -- All "."s is not a valid extension 510 let ys = dropWhile FilePath.isExtSeparator (reverse xs) 511 when (ys == []) $ 512 throwM $ InvalidExtension ex 513 514 -- Cannot have "."s except in trailing position 515 when (any FilePath.isExtSeparator ys) $ 516 throwM $ InvalidExtension ex 517 518 -- must be valid as a filename 519 _ <- parseRelFile ex 520 return () 521 validateExtension ex = throwM $ InvalidExtension ex 522 523-- | Add extension to given file path. Throws if the 524-- resulting filename does not parse. 525-- 526-- >>> addFileExtension "txt $(mkRelFile "foo") 527-- "foo.txt" 528-- >>> addFileExtension "symbols" $(mkRelFile "Data.List") 529-- "Data.List.symbols" 530-- >>> addFileExtension ".symbols" $(mkRelFile "Data.List") 531-- "Data.List.symbols" 532-- >>> addFileExtension "symbols" $(mkRelFile "Data.List.") 533-- "Data.List..symbols" 534-- >>> addFileExtension ".symbols" $(mkRelFile "Data.List.") 535-- "Data.List..symbols" 536-- >>> addFileExtension "evil/" $(mkRelFile "Data.List") 537-- *** Exception: InvalidRelFile "Data.List.evil/" 538-- 539-- @since 0.6.1 540{-# DEPRECATED addFileExtension "Please use addExtension instead." #-} 541addFileExtension :: MonadThrow m 542 => String -- ^ Extension to add 543 -> Path b File -- ^ Old file name 544 -> m (Path b File) -- ^ New file name with the desired extension added at the end 545addFileExtension ext (Path path) = 546 if FilePath.isAbsolute path 547 then liftM coercePath (parseAbsFile (FilePath.addExtension path ext)) 548 else liftM coercePath (parseRelFile (FilePath.addExtension path ext)) 549 where coercePath :: Path a b -> Path a' b' 550 coercePath (Path a) = Path a 551 552-- | A synonym for 'addFileExtension' in the form of an infix operator. 553-- See more examples there. 554-- 555-- >>> $(mkRelFile "Data.List") <.> "symbols" 556-- "Data.List.symbols" 557-- >>> $(mkRelFile "Data.List") <.> "evil/" 558-- *** Exception: InvalidRelFile "Data.List.evil/" 559-- 560-- @since 0.6.1 561infixr 7 <.> 562{-# DEPRECATED (<.>) "Please use addExtension instead." #-} 563(<.>) :: MonadThrow m 564 => Path b File -- ^ Old file name 565 -> String -- ^ Extension to add 566 -> m (Path b File) -- ^ New file name with the desired extension added at the end 567(<.>) = flip addFileExtension 568 569-- | If the file has an extension replace it with the given extension otherwise 570-- add the new extension to it. Throws an 'InvalidExtension' exception if the 571-- new extension is not a valid extension (see 'fileExtension' for validity 572-- rules). 573-- 574-- The following law holds: 575-- 576-- @(fileExtension >=> flip replaceExtension file) file == return file@ 577-- 578-- @since 0.7.0 579replaceExtension :: MonadThrow m 580 => String -- ^ Extension to set 581 -> Path b File -- ^ Old file name 582 -> m (Path b File) -- ^ New file name with the desired extension 583replaceExtension ext path = 584 addExtension ext (maybe path fst $ splitExtension path) 585 586-- | Replace\/add extension to given file path. Throws if the 587-- resulting filename does not parse. 588-- 589-- @since 0.5.11 590{-# DEPRECATED setFileExtension "Please use replaceExtension instead." #-} 591setFileExtension :: MonadThrow m 592 => String -- ^ Extension to set 593 -> Path b File -- ^ Old file name 594 -> m (Path b File) -- ^ New file name with the desired extension 595setFileExtension ext (Path path) = 596 if FilePath.isAbsolute path 597 then liftM coercePath (parseAbsFile (FilePath.replaceExtension path ext)) 598 else liftM coercePath (parseRelFile (FilePath.replaceExtension path ext)) 599 where coercePath :: Path a b -> Path a' b' 600 coercePath (Path a) = Path a 601 602-- | A synonym for 'setFileExtension' in the form of an operator. 603-- 604-- @since 0.6.0 605infixr 7 -<.> 606{-# DEPRECATED (-<.>) "Please use replaceExtension instead." #-} 607(-<.>) :: MonadThrow m 608 => Path b File -- ^ Old file name 609 -> String -- ^ Extension to set 610 -> m (Path b File) -- ^ New file name with the desired extension 611(-<.>) = flip setFileExtension 612 613-------------------------------------------------------------------------------- 614-- Parsers 615 616-- | Convert an absolute 'FilePath' to a normalized absolute dir 'Path'. 617-- 618-- Throws: 'InvalidAbsDir' when the supplied path: 619-- 620-- * is not an absolute path 621-- * contains a @..@ path component representing the parent directory 622-- * is not a valid path (See 'FilePath.isValid') 623-- 624parseAbsDir :: MonadThrow m 625 => FilePath -> m (Path Abs Dir) 626parseAbsDir filepath = 627 if FilePath.isAbsolute filepath && 628 not (hasParentDir filepath) && 629 FilePath.isValid filepath 630 then return (Path (normalizeDir filepath)) 631 else throwM (InvalidAbsDir filepath) 632 633-- | Convert a relative 'FilePath' to a normalized relative dir 'Path'. 634-- 635-- Throws: 'InvalidRelDir' when the supplied path: 636-- 637-- * is not a relative path 638-- * is @""@ 639-- * contains a @..@ path component representing the parent directory 640-- * is not a valid path (See 'FilePath.isValid') 641-- * is all path separators 642-- 643parseRelDir :: MonadThrow m 644 => FilePath -> m (Path Rel Dir) 645parseRelDir filepath = 646 if not (FilePath.isAbsolute filepath) && 647 not (hasParentDir filepath) && 648 not (null filepath) && 649 not (all FilePath.isPathSeparator filepath) && 650 FilePath.isValid filepath 651 then return (Path (normalizeDir filepath)) 652 else throwM (InvalidRelDir filepath) 653 654-- | Convert an absolute 'FilePath' to a normalized absolute file 'Path'. 655-- 656-- Throws: 'InvalidAbsFile' when the supplied path: 657-- 658-- * is not an absolute path 659-- * is a directory path i.e. 660-- 661-- * has a trailing path separator 662-- * is @.@ or ends in @/.@ 663-- 664-- * contains a @..@ path component representing the parent directory 665-- * is not a valid path (See 'FilePath.isValid') 666-- 667parseAbsFile :: MonadThrow m 668 => FilePath -> m (Path Abs File) 669parseAbsFile filepath = 670 case validAbsFile filepath of 671 True 672 | normalized <- normalizeFilePath filepath 673 , validAbsFile normalized -> 674 return (Path normalized) 675 _ -> throwM (InvalidAbsFile filepath) 676 677-- | Is the string a valid absolute file? 678validAbsFile :: FilePath -> Bool 679validAbsFile filepath = 680 FilePath.isAbsolute filepath && 681 not (FilePath.hasTrailingPathSeparator filepath) && 682 not (hasParentDir filepath) && 683 FilePath.isValid filepath 684 685-- | Convert a relative 'FilePath' to a normalized relative file 'Path'. 686-- 687-- Throws: 'InvalidRelFile' when the supplied path: 688-- 689-- * is not a relative path 690-- * is @""@ 691-- * is a directory path i.e. 692-- 693-- * has a trailing path separator 694-- * is @.@ or ends in @/.@ 695-- 696-- * contains a @..@ path component representing the parent directory 697-- * is not a valid path (See 'FilePath.isValid') 698-- 699parseRelFile :: MonadThrow m 700 => FilePath -> m (Path Rel File) 701parseRelFile filepath = 702 case validRelFile filepath of 703 True 704 | normalized <- normalizeFilePath filepath 705 , validRelFile normalized -> return (Path normalized) 706 _ -> throwM (InvalidRelFile filepath) 707 708-- | Is the string a valid relative file? 709validRelFile :: FilePath -> Bool 710validRelFile filepath = 711 not 712 (FilePath.isAbsolute filepath || FilePath.hasTrailingPathSeparator filepath) && 713 not (null filepath) && 714 not (hasParentDir filepath) && 715 filepath /= "." && FilePath.isValid filepath 716 717-------------------------------------------------------------------------------- 718-- Conversion 719 720-- | Convert absolute path to directory to 'FilePath' type. 721fromAbsDir :: Path Abs Dir -> FilePath 722fromAbsDir = toFilePath 723 724-- | Convert relative path to directory to 'FilePath' type. 725fromRelDir :: Path Rel Dir -> FilePath 726fromRelDir = toFilePath 727 728-- | Convert absolute path to file to 'FilePath' type. 729fromAbsFile :: Path Abs File -> FilePath 730fromAbsFile = toFilePath 731 732-- | Convert relative path to file to 'FilePath' type. 733fromRelFile :: Path Rel File -> FilePath 734fromRelFile = toFilePath 735 736-------------------------------------------------------------------------------- 737-- Constructors 738 739-- | Make a 'Path' 'Abs' 'Dir'. 740-- 741-- Remember: due to the nature of absolute paths this (e.g. @\/home\/foo@) 742-- may compile on your platform, but it may not compile on another 743-- platform (Windows). 744mkAbsDir :: FilePath -> Q Exp 745mkAbsDir = either (error . show) lift . parseAbsDir 746 747-- | Make a 'Path' 'Rel' 'Dir'. 748mkRelDir :: FilePath -> Q Exp 749mkRelDir = either (error . show) lift . parseRelDir 750 751-- | Make a 'Path' 'Abs' 'File'. 752-- 753-- Remember: due to the nature of absolute paths this (e.g. @\/home\/foo@) 754-- may compile on your platform, but it may not compile on another 755-- platform (Windows). 756mkAbsFile :: FilePath -> Q Exp 757mkAbsFile = either (error . show) lift . parseAbsFile 758 759-- | Make a 'Path' 'Rel' 'File'. 760mkRelFile :: FilePath -> Q Exp 761mkRelFile = either (error . show) lift . parseRelFile 762 763-------------------------------------------------------------------------------- 764-- Internal functions 765 766-- | Normalizes directory path with platform-specific rules. 767normalizeDir :: FilePath -> FilePath 768normalizeDir = 769 normalizeRelDir 770 . FilePath.addTrailingPathSeparator 771 . normalizeFilePath 772 where -- Represent a "." in relative dir path as "" internally so that it 773 -- composes without having to renormalize the path. 774 normalizeRelDir p 775 | p == relRootFP = "" 776 | otherwise = p 777 778-- | Replaces consecutive path seps with single sep and replaces alt sep with standard sep. 779normalizeAllSeps :: FilePath -> FilePath 780normalizeAllSeps = foldr normSeps [] 781 where normSeps ch [] = [ch] 782 normSeps ch path@(p0:_) 783 | FilePath.isPathSeparator ch && FilePath.isPathSeparator p0 = path 784 | FilePath.isPathSeparator ch = FilePath.pathSeparator:path 785 | otherwise = ch:path 786 787-- | Normalizes seps in whole path, but if there are 2+ seps at the beginning, 788-- they are normalized to exactly 2 to preserve UNC and Unicode prefixed paths. 789normalizeWindowsSeps :: FilePath -> FilePath 790normalizeWindowsSeps path = normLeadingSeps ++ normalizeAllSeps rest 791 where (leadingSeps, rest) = span FilePath.isPathSeparator path 792 normLeadingSeps = replicate (min 2 (length leadingSeps)) FilePath.pathSeparator 793 794-- | Normalizes seps only at the beginning of a path. 795normalizeLeadingSeps :: FilePath -> FilePath 796normalizeLeadingSeps path = normLeadingSep ++ rest 797 where (leadingSeps, rest) = span FilePath.isPathSeparator path 798 normLeadingSep = replicate (min 1 (length leadingSeps)) FilePath.pathSeparator 799 800-- | Normalizes seps only at the end of a path. 801normalizeTrailingSeps :: FilePath -> FilePath 802normalizeTrailingSeps = reverse . normalizeLeadingSeps . reverse 803 804-- | Applies platform-specific sep normalization following @FilePath.normalise@. 805normalizeFilePath :: FilePath -> FilePath 806normalizeFilePath 807 | IS_WINDOWS = normalizeWindowsSeps . FilePath.normalise 808 | otherwise = normalizeLeadingSeps . FilePath.normalise 809 810-- | Path of some type. @t@ represents the type, whether file or 811-- directory. Pattern match to find whether the path is absolute or 812-- relative. 813data SomeBase t = Abs (Path Abs t) 814 | Rel (Path Rel t) 815 deriving (Typeable, Generic, Eq, Ord) 816 817instance NFData (SomeBase t) where 818 rnf (Abs p) = rnf p 819 rnf (Rel p) = rnf p 820 821instance Show (SomeBase t) where 822 show = show . fromSomeBase 823 824instance ToJSON (SomeBase t) where 825 toJSON = toJSON . fromSomeBase 826 {-# INLINE toJSON #-} 827#if MIN_VERSION_aeson(0,10,0) 828 toEncoding = toEncoding . fromSomeBase 829 {-# INLINE toEncoding #-} 830#endif 831 832instance Hashable (SomeBase t) where 833 -- See 'Hashable' 'Path' instance for details. 834 hashWithSalt n path = hashWithSalt n (fromSomeBase path) 835 836instance FromJSON (SomeBase Dir) where 837 parseJSON = parseJSONWith parseSomeDir 838 {-# INLINE parseJSON #-} 839 840instance FromJSON (SomeBase File) where 841 parseJSON = parseJSONWith parseSomeFile 842 {-# INLINE parseJSON #-} 843 844-- | Convert a valid path to a 'FilePath'. 845fromSomeBase :: SomeBase t -> FilePath 846fromSomeBase (Abs p) = toFilePath p 847fromSomeBase (Rel p) = toFilePath p 848 849-- | Convert a valid directory to a 'FilePath'. 850fromSomeDir :: SomeBase Dir -> FilePath 851fromSomeDir = fromSomeBase 852 853-- | Convert a valid file to a 'FilePath'. 854fromSomeFile :: SomeBase File -> FilePath 855fromSomeFile = fromSomeBase 856 857-- | Convert an absolute or relative 'FilePath' to a normalized 'SomeBase' 858-- representing a directory. 859-- 860-- Throws: 'InvalidDir' when the supplied path: 861-- 862-- * contains a @..@ path component representing the parent directory 863-- * is not a valid path (See 'FilePath.isValid') 864parseSomeDir :: MonadThrow m => FilePath -> m (SomeBase Dir) 865parseSomeDir fp = maybe (throwM (InvalidDir fp)) pure 866 $ (Abs <$> parseAbsDir fp) 867 <|> (Rel <$> parseRelDir fp) 868 869-- | Convert an absolute or relative 'FilePath' to a normalized 'SomeBase' 870-- representing a file. 871-- 872-- Throws: 'InvalidFile' when the supplied path: 873-- 874-- * is a directory path i.e. 875-- 876-- * has a trailing path separator 877-- * is @.@ or ends in @/.@ 878-- 879-- * contains a @..@ path component representing the parent directory 880-- * is not a valid path (See 'FilePath.isValid') 881parseSomeFile :: MonadThrow m => FilePath -> m (SomeBase File) 882parseSomeFile fp = maybe (throwM (InvalidFile fp)) pure 883 $ (Abs <$> parseAbsFile fp) 884 <|> (Rel <$> parseRelFile fp) 885 886-------------------------------------------------------------------------------- 887-- Deprecated 888 889{-# DEPRECATED PathParseException "Please use PathException instead." #-} 890-- | Same as 'PathException'. 891type PathParseException = PathException 892 893{-# DEPRECATED stripDir "Please use stripProperPrefix instead." #-} 894-- | Same as 'stripProperPrefix'. 895stripDir :: MonadThrow m 896 => Path b Dir -> Path b t -> m (Path Rel t) 897stripDir = stripProperPrefix 898 899{-# DEPRECATED isParentOf "Please use isProperPrefixOf instead." #-} 900-- | Same as 'isProperPrefixOf'. 901isParentOf :: Path b Dir -> Path b t -> Bool 902isParentOf = isProperPrefixOf 903