diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,42 @@ +0.7.0: + * BREAKING CHANGE: "fileExtension" now throws an exception if the file has no + extension. You can use the result as a "Maybe" in pure + code or handle the exception appropriately in any other monad. + * Old extension operations "addFileExtension" and "setFileExtension" have + been deprecated and replaced by "addExtension" and "replaceExtension" + respectively with new behavior. + ADAPTING YOUR CODE TO THIS CHANGE: + * Code that sets an extension not starting with a "." e.g. "foo", must + be changed such that it starts with a "." i.e. ".foo". + * Code that sets multiple extensions in one go e.g. ".tar.gz" must be + changed to set them one at a time instead i.e. add ".tar" first and + then add ".gz". + * Code that sets an extension starting with multiple dots e.g. + "..foo" must be changed such as to make the extra dots part of the + file name instead. + Details: + The new operations "addExtension" and "replaceExtension" accept only "valid" + extension forms which is exactly the same as what "fileExtension" returns. + A valid extension starts with a @.@ followed by one or more characters + not including @.@ followed by zero or more @.@s in trailing position. + This change allows extension operations to be principled following + these laws: + * flip addExtension file >=> fileExtension == return + * (fileExtension >=> flip replaceExtension file) file == return file + * Add splitExtension operation such that: + * uncurry addExtension . swap >=> splitExtension == return + * splitExtension >=> uncurry addExtension . swap == return + * fileExtension == (fmap snd) . splitExtension@ + * Add 'Path.Posix' and 'Path.Windows' modules for manipulating + Windows or Posix style paths independently of the current platform. + * Add 'Lift' instance for 'Path'. + * `Path.Windows` normalizes path separators throughout path, + including immediately following drive letter. + * `Path.Windows` handles UNC (`\\host\share\`) and Unicode (`\\?\C:\`) path + without breaking the double-separator prefix. + * Remove support for old GHC version. The oldest supported version + is 8.2. + 0.6.1: * Add 'addFileExtension' function and its operator form: (<.>). * Derive 'Eq' instance for 'PathException'. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015–2016, FP Complete +Copyright (c) 2015–2018, FP Complete All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -92,7 +92,7 @@ ```haskell newtype Path b t = Path FilePath - deriving (Typeable) + deriving (Data, Typeable, Generic) ``` The type variables are: @@ -269,7 +269,7 @@ Stripping the parent directory from a path: ```haskell -stripDir :: MonadThrow m => Path b Dir -> Path b t -> m (Path Rel t) +stripProperPrefix :: MonadThrow m => Path b Dir -> Path b t -> m (Path Rel t) ``` ## Review @@ -401,7 +401,7 @@ ## Accepting user input Sometimes you have user input that contains `../`. The solution we went with -is to have a function like `resolveDir`: +is to have a function like `resolveDir` (found in [`path-io`](http://hackage.haskell.org/package/path-io) package): ```haskell resolveDir :: (MonadIO m, MonadThrow m) diff --git a/path.cabal b/path.cabal --- a/path.cabal +++ b/path.cabal @@ -1,29 +1,49 @@ name: path -version: 0.6.1 +version: 0.7.0 synopsis: Support for well-typed paths description: Support for well-typed paths. license: BSD3 license-file: LICENSE author: Chris Done maintainer: Chris Done -copyright: 2015–2017 FP Complete +copyright: 2015–2018 FP Complete category: System, Filesystem build-type: Simple -cabal-version: >=1.10 -tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.1 -extra-source-files: README.md, CHANGELOG +cabal-version: 1.18 +tested-with: GHC==8.2.2, GHC==8.4.4, GHC==8.6.5 +extra-source-files: README.md + , CHANGELOG + , src/Path/Include.hs +flag dev + description: Turn on development settings. + manual: True + default: False + library hs-source-dirs: src - ghc-options: -Wall -O2 - exposed-modules: Path, Path.Internal + exposed-modules: Path + , Path.Internal + , Path.Posix + , Path.Windows build-depends: aeson - , base >= 4.7 && < 5 + , base >= 4.10 && < 5 , deepseq - , exceptions >= 0.4 && < 0.9 + , exceptions >= 0.4 && < 0.11 , filepath < 1.2.0.1 || >= 1.3 , hashable >= 1.2 && < 1.3 + , text , template-haskell + if flag(dev) + ghc-options: -Wall -Werror + else + ghc-options: -O2 -Wall + if flag(dev) + ghc-options: -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wnoncanonical-monad-instances + -Wnoncanonical-monadfail-instances default-language: Haskell2010 test-suite test @@ -31,14 +51,19 @@ main-is: Main.hs other-modules: Posix , Windows + , Common hs-source-dirs: test build-depends: aeson - , base >= 4.7 && < 5 + , base >= 4.10 && < 5 , bytestring , filepath < 1.2.0.1 || >= 1.3 , hspec >= 2.0 && < 3 , mtl >= 2.0 && < 3 , path + if flag(dev) + ghc-options: -Wall -Werror + else + ghc-options: -O2 -Wall default-language: Haskell2010 test-suite validity-test @@ -48,15 +73,16 @@ hs-source-dirs: test build-depends: QuickCheck , aeson - , base >= 4.7 && < 5 + , base >= 4.10 && < 5 , bytestring , filepath < 1.2.0.1 || >= 1.3 - , genvalidity >= 0.3 && < 0.4 - , genvalidity-property >= 0.0 && < 0.1 + , genvalidity >= 0.8 + , genvalidity-property >= 0.4 + , genvalidity-hspec >= 0.7 , hspec >= 2.0 && < 3 , mtl >= 2.0 && < 3 , path - , validity >= 0.3.1.1 && < 0.4 + , validity >= 0.8.0.0 default-language: Haskell2010 ghc-options: -threaded -rtsopts -with-rtsopts=-N diff --git a/src/Path.hs b/src/Path.hs --- a/src/Path.hs +++ b/src/Path.hs @@ -1,611 +1,15 @@ -- | This library provides a well-typed representation of paths in a filesystem --- directory tree. A path is represented by a number of path components --- separated by a path separator which is a @/@ on POSIX systems and can be a --- @/@ or @\\@ on Windows. +-- directory tree. -- --- The root of the tree is represented by a @/@ on POSIX and a drive letter --- followed by a @/@ or @\\@ on Windows (e.g. @C:\\@). Paths can be absolute --- or relative. An absolute path always starts from the root of the tree (e.g. --- @\/x/y@) whereas a relative path never starts with the root (e.g. @x/y@). --- Just like we represent the notion of an absolute root by "@/@", the same way --- we represent the notion of a relative root by "@.@". The relative root denotes --- the directory which contains the first component of a relative path. +-- Both "Path.Posix" and "Path.Windows" provide the same interface. This +-- module will reexport the appropriate module for your platform. {-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleInstances #-} -module Path - (-- * Types - Path - ,Abs - ,Rel - ,File - ,Dir - -- * Exceptions - ,PathException(..) - -- * QuasiQuoters - -- | Using the following requires the QuasiQuotes language extension. - -- - -- __For Windows users__, the QuasiQuoters are especially beneficial because they - -- prevent Haskell from treating @\\@ as an escape character. - -- This makes Windows paths easier to write. - -- - -- @ - -- [absfile|C:\\chris\\foo.txt|] - -- @ - ,absdir - ,reldir - ,absfile - ,relfile - -- * Operations - ,() - ,stripProperPrefix - ,isProperPrefixOf - ,parent - ,filename - ,dirname - ,fileExtension - ,addFileExtension - ,(<.>) - ,setFileExtension - ,(-<.>) - -- * Parsing - ,parseAbsDir - ,parseRelDir - ,parseAbsFile - ,parseRelFile - -- * Conversion - ,toFilePath - ,fromAbsDir - ,fromRelDir - ,fromAbsFile - ,fromRelFile - -- * TemplateHaskell constructors - -- | These require the TemplateHaskell language extension. - ,mkAbsDir - ,mkRelDir - ,mkAbsFile - ,mkRelFile - -- * Deprecated - ,PathParseException - ,stripDir - ,isParentOf - ) - where - -import Control.Exception (Exception) -import Control.Monad -import Control.Monad.Catch (MonadThrow(..)) -import Data.Aeson (FromJSON (..)) -import qualified Data.Aeson.Types as Aeson -import Data.Data -import Data.List -import Data.Maybe -import Language.Haskell.TH -import Language.Haskell.TH.Quote (QuasiQuoter(..)) -import Path.Internal -import qualified System.FilePath as FilePath - --------------------------------------------------------------------------------- --- Types - --- | An absolute path. -data Abs deriving (Typeable) - --- | A relative path; one without a root. Note that a @..@ path component to --- represent the parent directory is not allowed by this library. -data Rel deriving (Typeable) - --- | A file path. -data File deriving (Typeable) - --- | A directory path. -data Dir deriving (Typeable) - -instance FromJSON (Path Abs File) where - parseJSON = parseJSONWith parseAbsFile - {-# INLINE parseJSON #-} - -instance FromJSON (Path Rel File) where - parseJSON = parseJSONWith parseRelFile - {-# INLINE parseJSON #-} - -instance FromJSON (Path Abs Dir) where - parseJSON = parseJSONWith parseAbsDir - {-# INLINE parseJSON #-} - -instance FromJSON (Path Rel Dir) where - parseJSON = parseJSONWith parseRelDir - {-# INLINE parseJSON #-} - -parseJSONWith :: (Show e, FromJSON a) - => (a -> Either e b) -> Aeson.Value -> Aeson.Parser b -parseJSONWith f x = - do fp <- parseJSON x - case f fp of - Right p -> return p - Left e -> fail (show e) -{-# INLINE parseJSONWith #-} - --- | Exceptions that can occur during path operations. --- --- @since 0.6.0 -data PathException - = InvalidAbsDir FilePath - | InvalidRelDir FilePath - | InvalidAbsFile FilePath - | InvalidRelFile FilePath - | NotAProperPrefix FilePath FilePath - deriving (Show,Eq,Typeable) -instance Exception PathException - --------------------------------------------------------------------------------- --- QuasiQuoters - -qq :: (String -> Q Exp) -> QuasiQuoter -qq quoteExp' = - QuasiQuoter - { quoteExp = quoteExp' - , quotePat = \_ -> - fail "illegal QuasiQuote (allowed as expression only, used as a pattern)" - , quoteType = \_ -> - fail "illegal QuasiQuote (allowed as expression only, used as a type)" - , quoteDec = \_ -> - fail "illegal QuasiQuote (allowed as expression only, used as a declaration)" - } - --- | Construct a 'Path' 'Abs' 'Dir' using QuasiQuotes. --- --- @ --- [absdir|/|] --- --- [absdir|\/home\/chris|] --- @ --- --- Remember: due to the nature of absolute paths a path like @[absdir|\/home\/chris|]@ --- may compile on your platform, but it may not compile on another --- platform (Windows). --- --- @since 0.5.13 -absdir :: QuasiQuoter -absdir = qq mkAbsDir - --- | Construct a 'Path' 'Rel' 'Dir' using QuasiQuotes. --- --- @ --- [absdir|\/home|]\<\/>[reldir|chris|] --- @ --- --- @since 0.5.13 -reldir :: QuasiQuoter -reldir = qq mkRelDir - --- | Construct a 'Path' 'Abs' 'File' using QuasiQuotes. --- --- @ --- [absfile|\/home\/chris\/foo.txt|] --- @ --- --- Remember: due to the nature of absolute paths a path like @[absdir|\/home\/chris\/foo.txt|]@ --- may compile on your platform, but it may not compile on another --- platform (Windows). --- --- @since 0.5.13 -absfile :: QuasiQuoter -absfile = qq mkAbsFile - --- | Construct a 'Path' 'Rel' 'File' using QuasiQuotes. --- --- @ --- [absdir|\/home\/chris|]\<\/>[relfile|foo.txt|] --- @ --- --- @since 0.5.13 -relfile :: QuasiQuoter -relfile = qq mkRelFile - --------------------------------------------------------------------------------- --- Operations - --- | Append two paths. --- --- The following cases are valid and the equalities hold: --- --- @$(mkAbsDir x) \<\/> $(mkRelDir y) = $(mkAbsDir (x ++ \"/\" ++ y))@ --- --- @$(mkAbsDir x) \<\/> $(mkRelFile y) = $(mkAbsFile (x ++ \"/\" ++ y))@ --- --- @$(mkRelDir x) \<\/> $(mkRelDir y) = $(mkRelDir (x ++ \"/\" ++ y))@ --- --- @$(mkRelDir x) \<\/> $(mkRelFile y) = $(mkRelFile (x ++ \"/\" ++ y))@ --- --- The following are proven not possible to express: --- --- @$(mkAbsFile …) \<\/> x@ --- --- @$(mkRelFile …) \<\/> x@ --- --- @x \<\/> $(mkAbsFile …)@ --- --- @x \<\/> $(mkAbsDir …)@ --- -infixr 5 -() :: Path b Dir -> Path Rel t -> Path b t -() (Path a) (Path b) = Path (a ++ b) - --- | If the directory in the first argument is a proper prefix of the path in --- the second argument strip it from the second argument, generating a path --- relative to the directory. --- Throws 'NotAProperPrefix' if the directory is not a proper prefix of the --- path. --- --- The following properties hold: --- --- @stripProperPrefix x (x \<\/> y) = y@ --- --- Cases which are proven not possible: --- --- @stripProperPrefix (a :: Path Abs …) (b :: Path Rel …)@ --- --- @stripProperPrefix (a :: Path Rel …) (b :: Path Abs …)@ --- --- In other words the bases must match. --- --- @since 0.6.0 -stripProperPrefix :: MonadThrow m - => Path b Dir -> Path b t -> m (Path Rel t) -stripProperPrefix (Path p) (Path l) = - case stripPrefix p l of - Nothing -> throwM (NotAProperPrefix p l) - Just "" -> throwM (NotAProperPrefix p l) - Just ok -> return (Path ok) - --- | Determines if the path in the first parameter is a proper prefix of the --- path in the second parameter. --- --- The following properties hold: --- --- @not (x \`isProperPrefixOf\` x)@ --- --- @x \`isProperPrefixOf\` (x \<\/\> y)@ --- --- @since 0.6.0 -isProperPrefixOf :: Path b Dir -> Path b t -> Bool -isProperPrefixOf p l = isJust (stripProperPrefix p l) - --- | Take the parent path component from a path. --- --- The following properties hold: --- --- @ --- parent (x \<\/> y) == x --- parent \"\/x\" == \"\/\" --- parent \"x\" == \".\" --- @ --- --- On the root (absolute or relative), getting the parent is idempotent: --- --- @ --- parent \"\/\" = \"\/\" --- parent \"\.\" = \"\.\" --- @ --- -parent :: Path b t -> Path b Dir -parent (Path "") = Path "" -parent (Path fp) | FilePath.isDrive fp = Path fp -parent (Path fp) = - Path - $ normalizeDir - $ FilePath.takeDirectory - $ FilePath.dropTrailingPathSeparator fp - --- | Extract the file part of a path. --- --- The following properties hold: --- --- @filename (p \<\/> a) == filename a@ --- -filename :: Path b File -> Path Rel File -filename (Path l) = - Path (FilePath.takeFileName l) - --- | Extract the last directory name of a path. --- --- The following properties hold: --- --- @dirname $(mkRelDir ".") == $(mkRelDir ".")@ --- --- @dirname (p \<\/> a) == dirname a@ --- -dirname :: Path b Dir -> Path Rel Dir -dirname (Path "") = Path "" -dirname (Path l) | FilePath.isDrive l = Path "" -dirname (Path l) = Path (last (FilePath.splitPath l)) - --- | Get extension from given file path. --- --- @since 0.5.11 -fileExtension :: Path b File -> String -fileExtension = FilePath.takeExtension . toFilePath - --- | Add extension to given file path. Throws if the --- resulting filename does not parse. --- --- >>> addFileExtension "txt $(mkRelFile "foo") --- "foo.txt" --- >>> addFileExtension "symbols" $(mkRelFile "Data.List") --- "Data.List.symbols" --- >>> addFileExtension ".symbols" $(mkRelFile "Data.List") --- "Data.List.symbols" --- >>> addFileExtension "symbols" $(mkRelFile "Data.List.") --- "Data.List..symbols" --- >>> addFileExtension ".symbols" $(mkRelFile "Data.List.") --- "Data.List..symbols" --- >>> addFileExtension "evil/" $(mkRelFile "Data.List") --- *** Exception: InvalidRelFile "Data.List.evil/" --- --- @since 0.6.1 -addFileExtension :: MonadThrow m - => String -- ^ Extension to add - -> Path b File -- ^ Old file name - -> m (Path b File) -- ^ New file name with the desired extension added at the end -addFileExtension ext (Path path) = - if FilePath.isAbsolute path - then liftM coercePath (parseAbsFile (FilePath.addExtension path ext)) - else liftM coercePath (parseRelFile (FilePath.addExtension path ext)) - where coercePath :: Path a b -> Path a' b' - coercePath (Path a) = Path a - --- | A synonym for 'addFileExtension' in the form of an operator. --- See more examples there. --- --- >>> $(mkRelFile "Data.List") <.> "symbols" --- "Data.List.symbols" --- >>> $(mkRelFile "Data.List") <.> "evil/" --- *** Exception: InvalidRelFile "Data.List.evil/" --- --- @since 0.6.1 -infixr 7 <.> -(<.>) :: MonadThrow m - => Path b File -- ^ Old file name - -> String -- ^ Extension to add - -> m (Path b File) -- ^ New file name with the desired extension added at the end -(<.>) = flip addFileExtension - --- | Replace\/add extension to given file path. Throws if the --- resulting filename does not parse. --- --- @since 0.5.11 -setFileExtension :: MonadThrow m - => String -- ^ Extension to set - -> Path b File -- ^ Old file name - -> m (Path b File) -- ^ New file name with the desired extension -setFileExtension ext (Path path) = - if FilePath.isAbsolute path - then liftM coercePath (parseAbsFile (FilePath.replaceExtension path ext)) - else liftM coercePath (parseRelFile (FilePath.replaceExtension path ext)) - where coercePath :: Path a b -> Path a' b' - coercePath (Path a) = Path a - --- | A synonym for 'setFileExtension' in the form of an operator. --- --- @since 0.6.0 -infixr 7 -<.> -(-<.>) :: MonadThrow m - => Path b File -- ^ Old file name - -> String -- ^ Extension to set - -> m (Path b File) -- ^ New file name with the desired extension -(-<.>) = flip setFileExtension - --------------------------------------------------------------------------------- --- Parsers - --- | Convert an absolute 'FilePath' to a normalized absolute dir 'Path'. --- --- Throws: 'InvalidAbsDir' when the supplied path: --- --- * is not an absolute path --- * contains a @..@ path component representing the parent directory --- * is not a valid path (See 'System.FilePath.isValid') --- -parseAbsDir :: MonadThrow m - => FilePath -> m (Path Abs Dir) -parseAbsDir filepath = - if FilePath.isAbsolute filepath && - not (hasParentDir filepath) && - FilePath.isValid filepath - then return (Path (normalizeDir filepath)) - else throwM (InvalidAbsDir filepath) - --- | Convert a relative 'FilePath' to a normalized relative dir 'Path'. --- --- Throws: 'InvalidRelDir' when the supplied path: --- --- * is not a relative path --- * is @""@ --- * contains a @..@ path component representing the parent directory --- * is not a valid path (See 'System.FilePath.isValid') --- -parseRelDir :: MonadThrow m - => FilePath -> m (Path Rel Dir) -parseRelDir filepath = - if not (FilePath.isAbsolute filepath) && - not (hasParentDir filepath) && - not (null filepath) && - FilePath.isValid filepath - then return (Path (normalizeDir filepath)) - else throwM (InvalidRelDir filepath) - --- | Convert an absolute 'FilePath' to a normalized absolute file 'Path'. --- --- Throws: 'InvalidAbsFile' when the supplied path: --- --- * is not an absolute path --- * is a directory path i.e. --- --- * has a trailing path separator --- * is @.@ or ends in @/.@ --- --- * contains a @..@ path component representing the parent directory --- * is not a valid path (See 'System.FilePath.isValid') --- -parseAbsFile :: MonadThrow m - => FilePath -> m (Path Abs File) -parseAbsFile filepath = - case validAbsFile filepath of - True - | normalized <- normalizeFilePath filepath - , validAbsFile normalized -> - return (Path normalized) - _ -> throwM (InvalidAbsFile filepath) - --- | Is the string a valid absolute file? -validAbsFile :: FilePath -> Bool -validAbsFile filepath = - FilePath.isAbsolute filepath && - not (FilePath.hasTrailingPathSeparator filepath) && - not (hasParentDir filepath) && - FilePath.isValid filepath - --- | Convert a relative 'FilePath' to a normalized relative file 'Path'. --- --- Throws: 'InvalidRelFile' when the supplied path: --- --- * is not a relative path --- * is @""@ --- * is a directory path i.e. --- --- * has a trailing path separator --- * is @.@ or ends in @/.@ --- --- * contains a @..@ path component representing the parent directory --- * is not a valid path (See 'System.FilePath.isValid') --- -parseRelFile :: MonadThrow m - => FilePath -> m (Path Rel File) -parseRelFile filepath = - case validRelFile filepath of - True - | normalized <- normalizeFilePath filepath - , validRelFile normalized -> return (Path normalized) - _ -> throwM (InvalidRelFile filepath) - --- | Is the string a valid relative file? -validRelFile :: FilePath -> Bool -validRelFile filepath = - not - (FilePath.isAbsolute filepath || FilePath.hasTrailingPathSeparator filepath) && - not (null filepath) && - not (hasParentDir filepath) && - filepath /= "." && FilePath.isValid filepath - --------------------------------------------------------------------------------- --- Conversion - --- | Convert absolute path to directory to 'FilePath' type. -fromAbsDir :: Path Abs Dir -> FilePath -fromAbsDir = toFilePath - --- | Convert relative path to directory to 'FilePath' type. -fromRelDir :: Path Rel Dir -> FilePath -fromRelDir = toFilePath - --- | Convert absolute path to file to 'FilePath' type. -fromAbsFile :: Path Abs File -> FilePath -fromAbsFile = toFilePath - --- | Convert relative path to file to 'FilePath' type. -fromRelFile :: Path Rel File -> FilePath -fromRelFile = toFilePath - --------------------------------------------------------------------------------- --- Constructors - --- | Make a 'Path' 'Abs' Dir'. --- --- Remember: due to the nature of absolute paths this (e.g. @\/home\/foo@) --- may compile on your platform, but it may not compile on another --- platform (Windows). -mkAbsDir :: FilePath -> Q Exp -mkAbsDir s = - case parseAbsDir s of - Left err -> error (show err) - Right (Path str) -> - [|Path $(return (LitE (StringL str))) :: Path Abs Dir|] - --- | Make a 'Path' 'Rel' 'Dir'. -mkRelDir :: FilePath -> Q Exp -mkRelDir s = - case parseRelDir s of - Left err -> error (show err) - Right (Path str) -> - [|Path $(return (LitE (StringL str))) :: Path Rel Dir|] - --- | Make a 'Path' 'Abs' 'File'. --- --- Remember: due to the nature of absolute paths this (e.g. @\/home\/foo@) --- may compile on your platform, but it may not compile on another --- platform (Windows). -mkAbsFile :: FilePath -> Q Exp -mkAbsFile s = - case parseAbsFile s of - Left err -> error (show err) - Right (Path str) -> - [|Path $(return (LitE (StringL str))) :: Path Abs File|] - --- | Make a 'Path' 'Rel' 'File'. -mkRelFile :: FilePath -> Q Exp -mkRelFile s = - case parseRelFile s of - Left err -> error (show err) - Right (Path str) -> - [|Path $(return (LitE (StringL str))) :: Path Rel File|] - --------------------------------------------------------------------------------- --- Internal functions - --- | Internal use for normalizing a directory. -normalizeDir :: FilePath -> FilePath -normalizeDir = - normalizeRelDir - . FilePath.addTrailingPathSeparator - . normalizeFilePath - where - -- Represent a "." in relative dir path as "" internally so that it - -- composes without having to renormalize the path. - normalizeRelDir p | p == relRootFP = "" - normalizeRelDir p = p - -normalizeFilePath :: FilePath -> FilePath -#if defined(mingw32_HOST_OS) || defined(__MINGW32__) || MIN_VERSION_filepath(1,4,0) -normalizeFilePath = FilePath.normalise +#if defined(mingw32_HOST_OS) +module Path(module Path.Windows) where +import Path.Windows #else -normalizeFilePath = normalizeLeadingSeparators . FilePath.normalise - where - sep = FilePath.pathSeparator - normalizeLeadingSeparators (x1:x2:xs) | x1 == sep && x2 == sep - = normalizeLeadingSeparators (sep:xs) - normalizeLeadingSeparators x = x +module Path(module Path.Posix) where +import Path.Posix #endif - --------------------------------------------------------------------------------- --- Deprecated - -{-# DEPRECATED PathParseException "Please use PathException instead." #-} --- | Same as 'PathException'. -type PathParseException = PathException - -{-# DEPRECATED stripDir "Please use stripProperPrefix instead." #-} --- | Same as 'stripProperPrefix'. -stripDir :: MonadThrow m - => Path b Dir -> Path b t -> m (Path Rel t) -stripDir = stripProperPrefix - -{-# DEPRECATED isParentOf "Please use isProperPrefixOf instead." #-} --- | Same as 'isProperPrefixOf'. -isParentOf :: Path b Dir -> Path b t -> Bool -isParentOf = isProperPrefixOf diff --git a/src/Path/Include.hs b/src/Path/Include.hs new file mode 100644 --- /dev/null +++ b/src/Path/Include.hs @@ -0,0 +1,814 @@ +-- This template expects CPP definitions for: +-- PLATFORM_NAME = Posix | Windows +-- IS_WINDOWS = False | True + +-- | This library provides a well-typed representation of paths in a filesystem +-- directory tree. +-- +-- __Note__: This module is for working with PLATFORM_NAME style paths. Importing +-- "Path" is usually better. +-- +-- A path is represented by a number of path components separated by a path +-- separator which is a @/@ on POSIX systems and can be a @/@ or @\\@ on Windows. +-- The root of the tree is represented by a @/@ on POSIX and a drive letter +-- followed by a @/@ or @\\@ on Windows (e.g. @C:\\@). Paths can be absolute +-- or relative. An absolute path always starts from the root of the tree (e.g. +-- @\/x/y@) whereas a relative path never starts with the root (e.g. @x/y@). +-- Just like we represent the notion of an absolute root by "@/@", the same way +-- we represent the notion of a relative root by "@.@". The relative root denotes +-- the directory which contains the first component of a relative path. + +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleInstances #-} + +module Path.PLATFORM_NAME + (-- * Types + Path + ,Abs + ,Rel + ,File + ,Dir + -- * Exceptions + ,PathException(..) + -- * QuasiQuoters + -- | Using the following requires the QuasiQuotes language extension. + -- + -- __For Windows users__, the QuasiQuoters are especially beneficial because they + -- prevent Haskell from treating @\\@ as an escape character. + -- This makes Windows paths easier to write. + -- + -- @ + -- [absfile|C:\\chris\\foo.txt|] + -- @ + ,absdir + ,reldir + ,absfile + ,relfile + -- * Operations + ,() + ,stripProperPrefix + ,isProperPrefixOf + ,parent + ,filename + ,dirname + ,addExtension + ,splitExtension + ,fileExtension + ,replaceExtension + -- * Parsing + ,parseAbsDir + ,parseRelDir + ,parseAbsFile + ,parseRelFile + -- * Conversion + ,toFilePath + ,fromAbsDir + ,fromRelDir + ,fromAbsFile + ,fromRelFile + -- * TemplateHaskell constructors + -- | These require the TemplateHaskell language extension. + ,mkAbsDir + ,mkRelDir + ,mkAbsFile + ,mkRelFile + -- * Deprecated + ,PathParseException + ,stripDir + ,isParentOf + ,addFileExtension + ,(<.>) + ,setFileExtension + ,(-<.>) + ) + where + +import Control.Exception (Exception(..)) +import Control.Monad (liftM, when) +import Control.Monad.Catch (MonadThrow(..)) +import Data.Aeson (FromJSON (..), FromJSONKey(..)) +import qualified Data.Aeson.Types as Aeson +import Data.Data +import qualified Data.Text as T +import Data.List +import Data.Maybe +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (lift) +import Language.Haskell.TH.Quote (QuasiQuoter(..)) +import Path.Internal +import qualified System.FilePath.PLATFORM_NAME as FilePath + +-------------------------------------------------------------------------------- +-- Types + +-- | An absolute path. +data Abs deriving (Typeable) + +-- | A relative path; one without a root. Note that a @..@ path component to +-- represent the parent directory is not allowed by this library. +data Rel deriving (Typeable) + +-- | A file path. +data File deriving (Typeable) + +-- | A directory path. +data Dir deriving (Typeable) + +instance FromJSON (Path Abs File) where + parseJSON = parseJSONWith parseAbsFile + {-# INLINE parseJSON #-} + +instance FromJSON (Path Rel File) where + parseJSON = parseJSONWith parseRelFile + {-# INLINE parseJSON #-} + +instance FromJSON (Path Abs Dir) where + parseJSON = parseJSONWith parseAbsDir + {-# INLINE parseJSON #-} + +instance FromJSON (Path Rel Dir) where + parseJSON = parseJSONWith parseRelDir + {-# INLINE parseJSON #-} + +parseJSONWith :: (Show e, FromJSON a) + => (a -> Either e b) -> Aeson.Value -> Aeson.Parser b +parseJSONWith f x = + do fp <- parseJSON x + case f fp of + Right p -> return p + Left e -> fail (show e) +{-# INLINE parseJSONWith #-} + +instance FromJSONKey (Path Abs File) where + fromJSONKey = fromJSONKeyWith parseAbsFile + {-# INLINE fromJSONKey #-} + +instance FromJSONKey (Path Rel File) where + fromJSONKey = fromJSONKeyWith parseRelFile + {-# INLINE fromJSONKey #-} + +instance FromJSONKey (Path Abs Dir) where + fromJSONKey = fromJSONKeyWith parseAbsDir + {-# INLINE fromJSONKey #-} + +instance FromJSONKey (Path Rel Dir) where + fromJSONKey = fromJSONKeyWith parseRelDir + {-# INLINE fromJSONKey #-} + +fromJSONKeyWith :: (Show e) + => (String -> Either e b) -> Aeson.FromJSONKeyFunction b +fromJSONKeyWith f = + Aeson.FromJSONKeyTextParser $ \t -> + case f (T.unpack t) of + Left e -> fail (show e) + Right rf -> pure rf + +{-# INLINE fromJSONKeyWith #-} + +-- | Exceptions that can occur during path operations. +-- +-- @since 0.6.0 +data PathException + = InvalidAbsDir FilePath + | InvalidRelDir FilePath + | InvalidAbsFile FilePath + | InvalidRelFile FilePath + | NotAProperPrefix FilePath FilePath + | HasNoExtension FilePath + | InvalidExtension String + deriving (Show,Eq,Typeable) + +instance Exception PathException where + displayException (InvalidExtension ext) = concat + [ "Invalid extension [" + , ext + , "]. A valid extension starts with a '.' followed by one or more " + , "characters other than '.', and it must be a valid filename, " + , "notably it cannot include a path separator." + ] + displayException x = show x + +-------------------------------------------------------------------------------- +-- QuasiQuoters + +qq :: (String -> Q Exp) -> QuasiQuoter +qq quoteExp' = + QuasiQuoter + { quoteExp = quoteExp' + , quotePat = \_ -> + fail "illegal QuasiQuote (allowed as expression only, used as a pattern)" + , quoteType = \_ -> + fail "illegal QuasiQuote (allowed as expression only, used as a type)" + , quoteDec = \_ -> + fail "illegal QuasiQuote (allowed as expression only, used as a declaration)" + } + +-- | Construct a 'Path' 'Abs' 'Dir' using QuasiQuotes. +-- +-- @ +-- [absdir|/|] +-- +-- [absdir|\/home\/chris|] +-- @ +-- +-- Remember: due to the nature of absolute paths a path like @[absdir|\/home\/chris|]@ +-- may compile on your platform, but it may not compile on another +-- platform (Windows). +-- +-- @since 0.5.13 +absdir :: QuasiQuoter +absdir = qq mkAbsDir + +-- | Construct a 'Path' 'Rel' 'Dir' using QuasiQuotes. +-- +-- @ +-- [absdir|\/home|]\<\/>[reldir|chris|] +-- @ +-- +-- @since 0.5.13 +reldir :: QuasiQuoter +reldir = qq mkRelDir + +-- | Construct a 'Path' 'Abs' 'File' using QuasiQuotes. +-- +-- @ +-- [absfile|\/home\/chris\/foo.txt|] +-- @ +-- +-- Remember: due to the nature of absolute paths a path like @[absdir|\/home\/chris\/foo.txt|]@ +-- may compile on your platform, but it may not compile on another +-- platform (Windows). +-- +-- @since 0.5.13 +absfile :: QuasiQuoter +absfile = qq mkAbsFile + +-- | Construct a 'Path' 'Rel' 'File' using QuasiQuotes. +-- +-- @ +-- [absdir|\/home\/chris|]\<\/>[relfile|foo.txt|] +-- @ +-- +-- @since 0.5.13 +relfile :: QuasiQuoter +relfile = qq mkRelFile + +-------------------------------------------------------------------------------- +-- Operations + +-- | Append two paths. +-- +-- The following cases are valid and the equalities hold: +-- +-- @$(mkAbsDir x) \<\/> $(mkRelDir y) = $(mkAbsDir (x ++ \"/\" ++ y))@ +-- +-- @$(mkAbsDir x) \<\/> $(mkRelFile y) = $(mkAbsFile (x ++ \"/\" ++ y))@ +-- +-- @$(mkRelDir x) \<\/> $(mkRelDir y) = $(mkRelDir (x ++ \"/\" ++ y))@ +-- +-- @$(mkRelDir x) \<\/> $(mkRelFile y) = $(mkRelFile (x ++ \"/\" ++ y))@ +-- +-- The following are proven not possible to express: +-- +-- @$(mkAbsFile …) \<\/> x@ +-- +-- @$(mkRelFile …) \<\/> x@ +-- +-- @x \<\/> $(mkAbsFile …)@ +-- +-- @x \<\/> $(mkAbsDir …)@ +-- +infixr 5 +() :: Path b Dir -> Path Rel t -> Path b t +() (Path a) (Path b) = Path (a ++ b) + +-- | If the directory in the first argument is a proper prefix of the path in +-- the second argument strip it from the second argument, generating a path +-- relative to the directory. +-- Throws 'NotAProperPrefix' if the directory is not a proper prefix of the +-- path. +-- +-- The following properties hold: +-- +-- @stripProperPrefix x (x \<\/> y) = y@ +-- +-- Cases which are proven not possible: +-- +-- @stripProperPrefix (a :: Path Abs …) (b :: Path Rel …)@ +-- +-- @stripProperPrefix (a :: Path Rel …) (b :: Path Abs …)@ +-- +-- In other words the bases must match. +-- +-- @since 0.6.0 +stripProperPrefix :: MonadThrow m + => Path b Dir -> Path b t -> m (Path Rel t) +stripProperPrefix (Path p) (Path l) = + case stripPrefix p l of + Nothing -> throwM (NotAProperPrefix p l) + Just "" -> throwM (NotAProperPrefix p l) + Just ok -> return (Path ok) + +-- | Determines if the path in the first parameter is a proper prefix of the +-- path in the second parameter. +-- +-- The following properties hold: +-- +-- @not (x \`isProperPrefixOf\` x)@ +-- +-- @x \`isProperPrefixOf\` (x \<\/\> y)@ +-- +-- @since 0.6.0 +isProperPrefixOf :: Path b Dir -> Path b t -> Bool +isProperPrefixOf p l = isJust (stripProperPrefix p l) + +-- | Take the parent path component from a path. +-- +-- The following properties hold: +-- +-- @ +-- parent (x \<\/> y) == x +-- parent \"\/x\" == \"\/\" +-- parent \"x\" == \".\" +-- @ +-- +-- On the root (absolute or relative), getting the parent is idempotent: +-- +-- @ +-- parent \"\/\" = \"\/\" +-- parent \"\.\" = \"\.\" +-- @ +-- +parent :: Path b t -> Path b Dir +parent (Path "") = Path "" +parent (Path fp) | FilePath.isDrive fp = Path fp +parent (Path fp) = + Path + $ normalizeDir + $ FilePath.takeDirectory + $ FilePath.dropTrailingPathSeparator fp + +-- | Extract the file part of a path. +-- +-- The following properties hold: +-- +-- @filename (p \<\/> a) == filename a@ +-- +filename :: Path b File -> Path Rel File +filename (Path l) = + Path (FilePath.takeFileName l) + +-- | Extract the last directory name of a path. +-- +-- The following properties hold: +-- +-- @dirname $(mkRelDir ".") == $(mkRelDir ".")@ +-- +-- @dirname (p \<\/> a) == dirname a@ +-- +dirname :: Path b Dir -> Path Rel Dir +dirname (Path "") = Path "" +dirname (Path l) | FilePath.isDrive l = Path "" +dirname (Path l) = Path (last (FilePath.splitPath l)) + +-- | 'splitExtension' is the inverse of 'addExtension'. It splits the given +-- file path into a valid filename and a valid extension. +-- +-- >>> splitExtension $(mkRelFile "name.foo" ) == Just ($(mkRelFile "name" ), ".foo" ) +-- >>> splitExtension $(mkRelFile "name.foo." ) == Just ($(mkRelFile "name" ), ".foo." ) +-- >>> splitExtension $(mkRelFile "name.foo.." ) == Just ($(mkRelFile "name" ), ".foo..") +-- >>> splitExtension $(mkRelFile "name.bar.foo" ) == Just ($(mkRelFile "name.bar"), ".foo" ) +-- >>> splitExtension $(mkRelFile ".name.foo" ) == Just ($(mkRelFile ".name" ), ".foo" ) +-- >>> splitExtension $(mkRelFile "name..foo" ) == Just ($(mkRelFile "name." ), ".foo" ) +-- >>> splitExtension $(mkRelFile "....foo" ) == Just ($(mkRelFile "..." ), ".foo" ) +-- +-- Throws 'HasNoExtension' exception if the filename does not have an extension +-- or in other words it cannot be split into a valid filename and a valid +-- extension. The following cases throw an exception, please note that "." and +-- ".." are not valid filenames: +-- +-- >>> splitExtension $(mkRelFile "name" ) +-- >>> splitExtension $(mkRelFile "name." ) +-- >>> splitExtension $(mkRelFile "name.." ) +-- >>> splitExtension $(mkRelFile ".name" ) +-- >>> splitExtension $(mkRelFile "..name" ) +-- >>> splitExtension $(mkRelFile "...name") +-- +-- 'splitExtension' and 'addExtension' are inverses of each other, the +-- following laws hold: +-- +-- @ +-- uncurry addExtension . swap >=> splitExtension == return +-- splitExtension >=> uncurry addExtension . swap == return +-- @ +-- +-- @since 0.7.0 +splitExtension :: MonadThrow m => Path b File -> m (Path b File, String) +splitExtension (Path fpath) = + if nameDot == [] || ext == [] + then throwM $ HasNoExtension fpath + else let fname = init nameDot + in if fname == [] || fname == "." || fname == ".." + then throwM $ HasNoExtension fpath + else return ( Path (normalizeDrive drv ++ dir ++ fname) + , FilePath.extSeparator : ext + ) + where + + -- trailing separators are ignored for the split and considered part of the + -- second component in the split. + splitLast isSep str = + let rstr = reverse str + notSep = not . isSep + name = (dropWhile notSep . dropWhile isSep) rstr + trailingSeps = takeWhile isSep rstr + xtn = (takeWhile notSep . dropWhile isSep) rstr + in (reverse name, reverse xtn ++ trailingSeps) + normalizeDrive + | IS_WINDOWS = normalizeTrailingSeps + | otherwise = id + + (drv, pth) = FilePath.splitDrive fpath + (dir, file) = splitLast FilePath.isPathSeparator pth + (nameDot, ext) = splitLast FilePath.isExtSeparator file + +-- | Get extension from given file path. Throws 'HasNoExtension' exception if +-- the file does not have an extension. The following laws hold: +-- +-- @ +-- flip addExtension file >=> fileExtension == return +-- fileExtension == (fmap snd) . splitExtension +-- @ +-- +-- @since 0.5.11 +fileExtension :: MonadThrow m => Path b File -> m String +fileExtension = (liftM snd) . splitExtension + +-- | Add extension to given file path. +-- +-- >>> addExtension ".foo" $(mkRelFile "name" ) == Just $(mkRelFile "name.foo" ) +-- >>> addExtension ".foo." $(mkRelFile "name" ) == Just $(mkRelFile "name.foo." ) +-- >>> addExtension ".foo.." $(mkRelFile "name" ) == Just $(mkRelFile "name.foo.." ) +-- >>> addExtension ".foo" $(mkRelFile "name.bar" ) == Just $(mkRelFile "name.bar.foo") +-- >>> addExtension ".foo" $(mkRelFile ".name" ) == Just $(mkRelFile ".name.foo" ) +-- >>> addExtension ".foo" $(mkRelFile "name." ) == Just $(mkRelFile "name..foo" ) +-- >>> addExtension ".foo" $(mkRelFile "..." ) == Just $(mkRelFile "....foo" ) +-- +-- Throws an 'InvalidExtension' exception if the extension is not valid. A +-- valid extension starts with a @.@ followed by one or more characters not +-- including @.@ followed by zero or more @.@ in trailing position. Moreover, +-- an extension must be a valid filename, notably it cannot include path +-- separators. Particularly, @.foo.bar@ is an invalid extension, instead you +-- have to first set @.foo@ and then @.bar@ individually. Some examples of +-- invalid extensions are: +-- +-- >>> addExtension "foo" $(mkRelFile "name") +-- >>> addExtension "..foo" $(mkRelFile "name") +-- >>> addExtension ".foo.bar" $(mkRelFile "name") +-- >>> addExtension ".foo/bar" $(mkRelFile "name") +-- +-- @since 0.7.0 +addExtension :: MonadThrow m + => String -- ^ Extension to add + -> Path b File -- ^ Old file name + -> m (Path b File) -- ^ New file name with the desired extension added at the end +addExtension ext (Path path) = do + validateExtension ext + return $ Path (path ++ ext) + + where + + validateExtension ex@(sep:xs) = do + -- has to start with a "." + when (not $ FilePath.isExtSeparator sep) $ + throwM $ InvalidExtension ex + + -- just a "." is not a valid extension + when (xs == []) $ + throwM $ InvalidExtension ex + + -- cannot have path separators + when (any FilePath.isPathSeparator xs) $ + throwM $ InvalidExtension ex + + -- All "."s is not a valid extension + let ys = dropWhile FilePath.isExtSeparator (reverse xs) + when (ys == []) $ + throwM $ InvalidExtension ex + + -- Cannot have "."s except in trailing position + when (any FilePath.isExtSeparator ys) $ + throwM $ InvalidExtension ex + + -- must be valid as a filename + _ <- parseRelFile ex + return () + validateExtension ex = throwM $ InvalidExtension ex + +-- | Add extension to given file path. Throws if the +-- resulting filename does not parse. +-- +-- >>> addFileExtension "txt $(mkRelFile "foo") +-- "foo.txt" +-- >>> addFileExtension "symbols" $(mkRelFile "Data.List") +-- "Data.List.symbols" +-- >>> addFileExtension ".symbols" $(mkRelFile "Data.List") +-- "Data.List.symbols" +-- >>> addFileExtension "symbols" $(mkRelFile "Data.List.") +-- "Data.List..symbols" +-- >>> addFileExtension ".symbols" $(mkRelFile "Data.List.") +-- "Data.List..symbols" +-- >>> addFileExtension "evil/" $(mkRelFile "Data.List") +-- *** Exception: InvalidRelFile "Data.List.evil/" +-- +-- @since 0.6.1 +{-# DEPRECATED addFileExtension "Please use addExtension instead." #-} +addFileExtension :: MonadThrow m + => String -- ^ Extension to add + -> Path b File -- ^ Old file name + -> m (Path b File) -- ^ New file name with the desired extension added at the end +addFileExtension ext (Path path) = + if FilePath.isAbsolute path + then liftM coercePath (parseAbsFile (FilePath.addExtension path ext)) + else liftM coercePath (parseRelFile (FilePath.addExtension path ext)) + where coercePath :: Path a b -> Path a' b' + coercePath (Path a) = Path a + +-- | A synonym for 'addFileExtension' in the form of an infix operator. +-- See more examples there. +-- +-- >>> $(mkRelFile "Data.List") <.> "symbols" +-- "Data.List.symbols" +-- >>> $(mkRelFile "Data.List") <.> "evil/" +-- *** Exception: InvalidRelFile "Data.List.evil/" +-- +-- @since 0.6.1 +infixr 7 <.> +{-# DEPRECATED (<.>) "Please use addExtension instead." #-} +(<.>) :: MonadThrow m + => Path b File -- ^ Old file name + -> String -- ^ Extension to add + -> m (Path b File) -- ^ New file name with the desired extension added at the end +(<.>) = flip addFileExtension + +-- | If the file has an extension replace it with the given extension otherwise +-- add the new extension to it. Throws an 'InvalidExtension' exception if the +-- new extension is not a valid extension (see 'fileExtension' for validity +-- rules). +-- +-- The following law holds: +-- +-- @(fileExtension >=> flip replaceExtension file) file == return file@ +-- +-- @since 0.7.0 +replaceExtension :: MonadThrow m + => String -- ^ Extension to set + -> Path b File -- ^ Old file name + -> m (Path b File) -- ^ New file name with the desired extension +replaceExtension ext path = + addExtension ext (maybe path fst $ splitExtension path) + +-- | Replace\/add extension to given file path. Throws if the +-- resulting filename does not parse. +-- +-- @since 0.5.11 +{-# DEPRECATED setFileExtension "Please use replaceExtension instead." #-} +setFileExtension :: MonadThrow m + => String -- ^ Extension to set + -> Path b File -- ^ Old file name + -> m (Path b File) -- ^ New file name with the desired extension +setFileExtension ext (Path path) = + if FilePath.isAbsolute path + then liftM coercePath (parseAbsFile (FilePath.replaceExtension path ext)) + else liftM coercePath (parseRelFile (FilePath.replaceExtension path ext)) + where coercePath :: Path a b -> Path a' b' + coercePath (Path a) = Path a + +-- | A synonym for 'setFileExtension' in the form of an operator. +-- +-- @since 0.6.0 +infixr 7 -<.> +{-# DEPRECATED (-<.>) "Please use replaceExtension instead." #-} +(-<.>) :: MonadThrow m + => Path b File -- ^ Old file name + -> String -- ^ Extension to set + -> m (Path b File) -- ^ New file name with the desired extension +(-<.>) = flip setFileExtension + +-------------------------------------------------------------------------------- +-- Parsers + +-- | Convert an absolute 'FilePath' to a normalized absolute dir 'Path'. +-- +-- Throws: 'InvalidAbsDir' when the supplied path: +-- +-- * is not an absolute path +-- * contains a @..@ path component representing the parent directory +-- * is not a valid path (See 'FilePath.isValid') +-- +parseAbsDir :: MonadThrow m + => FilePath -> m (Path Abs Dir) +parseAbsDir filepath = + if FilePath.isAbsolute filepath && + not (hasParentDir filepath) && + FilePath.isValid filepath + then return (Path (normalizeDir filepath)) + else throwM (InvalidAbsDir filepath) + +-- | Convert a relative 'FilePath' to a normalized relative dir 'Path'. +-- +-- Throws: 'InvalidRelDir' when the supplied path: +-- +-- * is not a relative path +-- * is @""@ +-- * contains a @..@ path component representing the parent directory +-- * is not a valid path (See 'FilePath.isValid') +-- * is all path separators +-- +parseRelDir :: MonadThrow m + => FilePath -> m (Path Rel Dir) +parseRelDir filepath = + if not (FilePath.isAbsolute filepath) && + not (hasParentDir filepath) && + not (null filepath) && + not (all FilePath.isPathSeparator filepath) && + FilePath.isValid filepath + then return (Path (normalizeDir filepath)) + else throwM (InvalidRelDir filepath) + +-- | Convert an absolute 'FilePath' to a normalized absolute file 'Path'. +-- +-- Throws: 'InvalidAbsFile' when the supplied path: +-- +-- * is not an absolute path +-- * is a directory path i.e. +-- +-- * has a trailing path separator +-- * is @.@ or ends in @/.@ +-- +-- * contains a @..@ path component representing the parent directory +-- * is not a valid path (See 'FilePath.isValid') +-- +parseAbsFile :: MonadThrow m + => FilePath -> m (Path Abs File) +parseAbsFile filepath = + case validAbsFile filepath of + True + | normalized <- normalizeFilePath filepath + , validAbsFile normalized -> + return (Path normalized) + _ -> throwM (InvalidAbsFile filepath) + +-- | Is the string a valid absolute file? +validAbsFile :: FilePath -> Bool +validAbsFile filepath = + FilePath.isAbsolute filepath && + not (FilePath.hasTrailingPathSeparator filepath) && + not (hasParentDir filepath) && + FilePath.isValid filepath + +-- | Convert a relative 'FilePath' to a normalized relative file 'Path'. +-- +-- Throws: 'InvalidRelFile' when the supplied path: +-- +-- * is not a relative path +-- * is @""@ +-- * is a directory path i.e. +-- +-- * has a trailing path separator +-- * is @.@ or ends in @/.@ +-- +-- * contains a @..@ path component representing the parent directory +-- * is not a valid path (See 'FilePath.isValid') +-- +parseRelFile :: MonadThrow m + => FilePath -> m (Path Rel File) +parseRelFile filepath = + case validRelFile filepath of + True + | normalized <- normalizeFilePath filepath + , validRelFile normalized -> return (Path normalized) + _ -> throwM (InvalidRelFile filepath) + +-- | Is the string a valid relative file? +validRelFile :: FilePath -> Bool +validRelFile filepath = + not + (FilePath.isAbsolute filepath || FilePath.hasTrailingPathSeparator filepath) && + not (null filepath) && + not (hasParentDir filepath) && + filepath /= "." && FilePath.isValid filepath + +-------------------------------------------------------------------------------- +-- Conversion + +-- | Convert absolute path to directory to 'FilePath' type. +fromAbsDir :: Path Abs Dir -> FilePath +fromAbsDir = toFilePath + +-- | Convert relative path to directory to 'FilePath' type. +fromRelDir :: Path Rel Dir -> FilePath +fromRelDir = toFilePath + +-- | Convert absolute path to file to 'FilePath' type. +fromAbsFile :: Path Abs File -> FilePath +fromAbsFile = toFilePath + +-- | Convert relative path to file to 'FilePath' type. +fromRelFile :: Path Rel File -> FilePath +fromRelFile = toFilePath + +-------------------------------------------------------------------------------- +-- Constructors + +-- | Make a 'Path' 'Abs' 'Dir'. +-- +-- Remember: due to the nature of absolute paths this (e.g. @\/home\/foo@) +-- may compile on your platform, but it may not compile on another +-- platform (Windows). +mkAbsDir :: FilePath -> Q Exp +mkAbsDir = either (error . show) lift . parseAbsDir + +-- | Make a 'Path' 'Rel' 'Dir'. +mkRelDir :: FilePath -> Q Exp +mkRelDir = either (error . show) lift . parseRelDir + +-- | Make a 'Path' 'Abs' 'File'. +-- +-- Remember: due to the nature of absolute paths this (e.g. @\/home\/foo@) +-- may compile on your platform, but it may not compile on another +-- platform (Windows). +mkAbsFile :: FilePath -> Q Exp +mkAbsFile = either (error . show) lift . parseAbsFile + +-- | Make a 'Path' 'Rel' 'File'. +mkRelFile :: FilePath -> Q Exp +mkRelFile = either (error . show) lift . parseRelFile + +-------------------------------------------------------------------------------- +-- Internal functions + +-- | Normalizes directory path with platform-specific rules. +normalizeDir :: FilePath -> FilePath +normalizeDir = + normalizeRelDir + . FilePath.addTrailingPathSeparator + . normalizeFilePath + where -- Represent a "." in relative dir path as "" internally so that it + -- composes without having to renormalize the path. + normalizeRelDir p + | p == relRootFP = "" + | otherwise = p + +-- | Replaces consecutive path seps with single sep and replaces alt sep with standard sep. +normalizeAllSeps :: FilePath -> FilePath +normalizeAllSeps = foldr normSeps [] + where normSeps ch [] = [ch] + normSeps ch path@(p0:_) + | FilePath.isPathSeparator ch && FilePath.isPathSeparator p0 = path + | FilePath.isPathSeparator ch = FilePath.pathSeparator:path + | otherwise = ch:path + +-- | Normalizes seps in whole path, but if there are 2+ seps at the beginning, +-- they are normalized to exactly 2 to preserve UNC and Unicode prefixed paths. +normalizeWindowsSeps :: FilePath -> FilePath +normalizeWindowsSeps path = normLeadingSeps ++ normalizeAllSeps rest + where (leadingSeps, rest) = span FilePath.isPathSeparator path + normLeadingSeps = replicate (min 2 (length leadingSeps)) FilePath.pathSeparator + +-- | Normalizes seps only at the beginning of a path. +normalizeLeadingSeps :: FilePath -> FilePath +normalizeLeadingSeps path = normLeadingSep ++ rest + where (leadingSeps, rest) = span FilePath.isPathSeparator path + normLeadingSep = replicate (min 1 (length leadingSeps)) FilePath.pathSeparator + +-- | Normalizes seps only at the end of a path. +normalizeTrailingSeps :: FilePath -> FilePath +normalizeTrailingSeps = reverse . normalizeLeadingSeps . reverse + +-- | Applies platform-specific sep normalization following @FilePath.normalise@. +normalizeFilePath :: FilePath -> FilePath +normalizeFilePath + | IS_WINDOWS = normalizeWindowsSeps . FilePath.normalise + | otherwise = normalizeLeadingSeps . FilePath.normalise + +-------------------------------------------------------------------------------- +-- Deprecated + +{-# DEPRECATED PathParseException "Please use PathException instead." #-} +-- | Same as 'PathException'. +type PathParseException = PathException + +{-# DEPRECATED stripDir "Please use stripProperPrefix instead." #-} +-- | Same as 'stripProperPrefix'. +stripDir :: MonadThrow m + => Path b Dir -> Path b t -> m (Path Rel t) +stripDir = stripProperPrefix + +{-# DEPRECATED isParentOf "Please use isProperPrefixOf instead." #-} +-- | Same as 'isProperPrefixOf'. +isParentOf :: Path b Dir -> Path b t -> Bool +isParentOf = isProperPrefixOf diff --git a/src/Path/Internal.hs b/src/Path/Internal.hs --- a/src/Path/Internal.hs +++ b/src/Path/Internal.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} -- | Internal types and functions. @@ -12,10 +14,14 @@ where import Control.DeepSeq (NFData (..)) -import Data.Aeson (ToJSON (..)) +import Data.Aeson (ToJSON (..), ToJSONKey(..)) +import Data.Aeson.Types (toJSONKeyText) +import qualified Data.Text as T (pack) +import GHC.Generics (Generic) import Data.Data import Data.Hashable import Data.List +import Language.Haskell.TH.Syntax (Exp(..), Lift(..), Lit(..)) import qualified System.FilePath as FilePath -- | Path of some base and type. @@ -33,7 +39,7 @@ -- All directories end in a trailing separator. There are no duplicate -- path separators @\/\/@, no @..@, no @.\/@, no @~\/@, etc. newtype Path b t = Path FilePath - deriving (Typeable) + deriving (Data, Typeable, Generic) -- | String equality. -- @@ -83,6 +89,9 @@ {-# INLINE toEncoding #-} #endif +instance ToJSONKey (Path b t) where + toJSONKey = toJSONKeyText $ T.pack . toFilePath + instance Hashable (Path b t) where -- A "." is represented as an empty string ("") internally. Hashing "" -- results in a hash that is the same as the salt. To produce a more @@ -103,3 +112,6 @@ case FilePath.pathSeparator of '/' -> filepath' x -> map (\y -> if x == y then '/' else y) filepath' + +instance Lift (Path a b) where + lift (Path str) = [|Path $(return (LitE (StringL str)))|] diff --git a/src/Path/Posix.hs b/src/Path/Posix.hs new file mode 100644 --- /dev/null +++ b/src/Path/Posix.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE CPP #-} +#define PLATFORM_NAME Posix +#define IS_WINDOWS False +#include "Include.hs" diff --git a/src/Path/Windows.hs b/src/Path/Windows.hs new file mode 100644 --- /dev/null +++ b/src/Path/Windows.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE CPP #-} +#define PLATFORM_NAME Windows +#define IS_WINDOWS True +#include "Include.hs" diff --git a/test/Common.hs b/test/Common.hs new file mode 100644 --- /dev/null +++ b/test/Common.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Test functions that are common to Posix and Windows + +module Common (extensionOperations) where + +import Control.Monad +import Path +import System.FilePath (pathSeparator) +import Test.Hspec + +validExtensionsSpec :: String -> Path b File -> Path b File -> Spec +validExtensionsSpec ext file fext = do + let f = show $ toFilePath file + let fx = show $ toFilePath fext + + it ("addExtension " ++ show ext ++ " " ++ f ++ " == " ++ fx) $ + addExtension ext file `shouldReturn` fext + + it ("fileExtension " ++ fx ++ " == " ++ ext) $ + fileExtension fext `shouldReturn` ext + + it ("replaceExtension " ++ show ext ++ " " ++ fx ++ " == " ++ fx) $ + replaceExtension ext fext `shouldReturn` fext + +extensionOperations :: String -> Spec +extensionOperations rootDrive = do + let ext = ".foo" + let extensions = ext : [".foo.", ".foo.."] + + -- Only filenames and extensions + forM_ extensions (\x -> + forM_ filenames $ \f -> do + let Just file = parseRelFile f + let Just fext = parseRelFile (f ++ x) + (validExtensionsSpec x file fext)) + + -- Relative dir paths + forM_ dirnames (\d -> do + forM_ filenames (\f -> do + let f1 = d ++ [pathSeparator] ++ f + let Just file = parseRelFile f1 + let Just fext = parseRelFile (f1 ++ ext) + validExtensionsSpec ext file fext)) + + -- Absolute dir paths + forM_ dirnames (\d -> do + forM_ filenames (\f -> do + let f1 = rootDrive ++ d ++ [pathSeparator] ++ f + let Just file = parseAbsFile f1 + let Just fext = parseAbsFile (f1 ++ ext) + validExtensionsSpec ext file fext)) + + -- Invalid extensions + forM_ invalidExtensions $ \x -> do + it ("throws InvalidExtension when extension is [" ++ x ++ "]") $ + addExtension x $(mkRelFile "name") + `shouldThrow` (== InvalidExtension x) + + where + + filenames = + [ "name" + , "name." + , "name.." + , ".name" + , "..name" + , "name.name" + , "name..name" + , "..." + ] + dirnames = filenames ++ ["."] + invalidExtensions = + [ "" + , "." + , "x" + , ".." + , "..." + , "xy" + , "foo" + , "foo." + , "foo.." + , "..foo" + , "...foo" + , ".foo.bar" + , ".foo" ++ [pathSeparator] ++ "bar" + ] diff --git a/test/Path/Gen.hs b/test/Path/Gen.hs --- a/test/Path/Gen.hs +++ b/test/Path/Gen.hs @@ -1,76 +1,152 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} + module Path.Gen where -import Data.Functor -import Prelude +import Data.Functor +import Prelude -import Path -import Path.Internal +import Path +import Path.Internal import qualified System.FilePath as FilePath -import Data.Maybe (mapMaybe) -import Data.List (isInfixOf) -import Data.Validity -import Data.GenValidity - -import Test.QuickCheck +import Data.GenValidity +import Data.List (isInfixOf, isSuffixOf) +import Data.Maybe (isJust, mapMaybe) +import Data.Validity +import Test.QuickCheck +-- | An absolute path to a file is valid if: +-- +-- * Its path is an absolute path +-- * Its path has no trailing path separators +-- * Its path is valid according to 'System.FilePath's definition. +-- * Its path does not end in '/.' +-- * Its path is not '.' +-- * Its path does not contain '..'. +-- * Parsing the path and rendering it again results in the same path. instance Validity (Path Abs File) where - isValid p@(Path fp) - = FilePath.isAbsolute fp - && not (FilePath.hasTrailingPathSeparator fp) - && FilePath.isValid fp - && not (hasParentDir fp) - && (parseAbsFile fp == Just p) + validate p@(Path fp) = + mconcat + [ declare "The path is absolute." $ FilePath.isAbsolute fp + , declare "The path has no trailing path separator." $ + not (FilePath.hasTrailingPathSeparator fp) + , declare "System.FilePath considers the path valid." $ FilePath.isValid fp + , declare "The path does not end in /." $ not ("/." `isSuffixOf` fp) + , declare "The path does not equal \".\"" $ fp /= "." + , declare "The path does not a parent directory." $ not (hasParentDir fp) + , declare "The path can be identically parsed as an absolute file path." $ + parseAbsFile fp == Just p + ] +-- | A relative path to a file is valid if: +-- +-- * Its path is a relative path +-- * Its path does not have a trailing path separator +-- * Its path is valid according to 'System.FilePath's definition. +-- * Its path is not '.' +-- * Its path is not empty +-- * Its path does not end in '/.' +-- * Its path is not '.' +-- * Its path does not contain '..'. +-- * Parsing the path and rendering it again results in the same path. instance Validity (Path Rel File) where - isValid p@(Path fp) - = FilePath.isRelative fp - && not (FilePath.hasTrailingPathSeparator fp) - && FilePath.isValid fp - && fp /= "." - && not (hasParentDir fp) - && (parseRelFile fp == Just p) + validate p@(Path fp) = + mconcat + [ declare "The path is relative." $ FilePath.isRelative fp + , declare "The path has no trailing path separator." $ + not (FilePath.hasTrailingPathSeparator fp) + , declare "System.FilePath considers the path valid." $ FilePath.isValid fp + , declare "The path does not equal \".\"" $ fp /= "." + , declare "The path is not empty" $ not (null fp) + , declare "The path does not end in /." $ not ("/." `isSuffixOf` fp) + , declare "The path does not a parent directory." $ not (hasParentDir fp) + , declare "The path can be identically parsed as a relative file path." $ + parseRelFile fp == Just p + ] +-- | An absolute path to a directory is valid if: +-- +-- * Its path is an absolute path +-- * Its path has a trailing path separator +-- * Its path is valid according to 'System.FilePath's definition. +-- * Its path does not contain '..'. +-- * Parsing the path and rendering it again results in the same path. instance Validity (Path Abs Dir) where - isValid p@(Path fp) - = FilePath.isAbsolute fp - && FilePath.hasTrailingPathSeparator fp - && FilePath.isValid fp - && not (hasParentDir fp) - && (parseAbsDir fp == Just p) + validate p@(Path fp) = + mconcat + [ declare "The path is absolute." $ FilePath.isAbsolute fp + , declare "The path has a trailing path separator." $ FilePath.hasTrailingPathSeparator fp + , declare "System.FilePath considers the path valid." $ FilePath.isValid fp + , declare "The path does not a parent directory." $ not (hasParentDir fp) + , declare "The path can be identically parsed as an absolute directory path." $ + parseAbsDir fp == Just p + ] +-- | A relative path to a directory is valid if: +-- +-- * Its path is a relative path +-- * Its path has a trailing path separator +-- * Its path is valid according to 'System.FilePath's definition. +-- * Its path does not contain '..'. +-- * Parsing the path and rendering it again results in the same path. instance Validity (Path Rel Dir) where - isValid p = - FilePath.isRelative fp - && FilePath.hasTrailingPathSeparator fp - && FilePath.isValid fp - && not (hasParentDir fp) - && (parseRelDir fp == Just p) - where fp = toFilePath p + validate (Path "") = valid + validate p@(Path fp) = + mconcat + [ declare "The path is relative." $ FilePath.isRelative fp + , declare "The path has a trailing path separator." $ FilePath.hasTrailingPathSeparator fp + , declare "System.FilePath considers the path valid." $ FilePath.isValid fp + , declare "The path is not empty." $ not (null fp) + , declare "The path does not a parent directory." $ not (hasParentDir fp) + , declare "The path can be identically parsed as a relative directory path." $ + parseRelDir fp == Just p + ] instance GenUnchecked (Path Abs File) where genUnchecked = Path <$> genFilePath -instance GenValid (Path Abs File) +instance GenValid (Path Abs File) where + shrinkValid = shrinkValidWith parseAbsFile instance GenUnchecked (Path Rel File) where genUnchecked = Path <$> genFilePath -instance GenValid (Path Rel File) +instance GenValid (Path Rel File) where + shrinkValid = shrinkValidWith parseRelFile instance GenUnchecked (Path Abs Dir) where genUnchecked = Path <$> genFilePath -instance GenValid (Path Abs Dir) +instance GenValid (Path Abs Dir) where + shrinkValid = shrinkValidWith parseAbsDir instance GenUnchecked (Path Rel Dir) where genUnchecked = Path <$> genFilePath -instance GenValid (Path Rel Dir) +instance GenValid (Path Rel Dir) where + shrinkValid = shrinkValidWith parseRelDir +data Extension = + Extension String + deriving (Show) + +instance Validity Extension where + validate (Extension ext) = + mconcat + [ delve "Extension" ext + , declare "It is possible to add the extension to \"./\"" $ + isJust $ addExtension ext $(mkRelFile "x") + ] + +instance GenUnchecked Extension where + genUnchecked = Extension <$> genFilePath + shrinkUnchecked (Extension e) = Extension <$> shrinkUnchecked e + +instance GenValid Extension + -- | Generates 'FilePath's with a high occurence of @'.'@, @'\/'@ and -- @'\\'@ characters. The resulting 'FilePath's are not guaranteed to -- be valid. @@ -78,20 +154,11 @@ genFilePath = listOf genPathyChar genPathyChar :: Gen Char -genPathyChar = frequency [(2, arbitrary), (1, elements "./\\")] - -shrinkValidAbsFile :: Path Abs File -> [Path Abs File] -shrinkValidAbsFile = shrinkValidWith parseAbsFile - -shrinkValidAbsDir :: Path Abs Dir -> [Path Abs Dir] -shrinkValidAbsDir = shrinkValidWith parseAbsDir - -shrinkValidRelFile :: Path Rel File -> [Path Rel File] -shrinkValidRelFile = shrinkValidWith parseRelFile - -shrinkValidRelDir :: Path Rel Dir -> [Path Rel Dir] -shrinkValidRelDir (Path []) = [] -shrinkValidRelDir p = shrinkValidWith parseRelDir p +genPathyChar = frequency [(2, choose (minBound, maxBound)), (1, elements "./\\")] shrinkValidWith :: (FilePath -> Maybe (Path a b)) -> Path a b -> [Path a b] -shrinkValidWith fun (Path s) = mapMaybe fun $ shrink s +shrinkValidWith fun (Path f) = filter (/= (Path f)) . mapMaybe fun $ shrinkUnchecked f + +shrinkValidExtension :: Extension -> [Extension] +shrinkValidExtension (Extension s) = + map (Extension . drop 1 . toFilePath) $ mapMaybe (flip addExtension $(mkRelFile "x")) (shrink s) diff --git a/test/Posix.hs b/test/Posix.hs --- a/test/Posix.hs +++ b/test/Posix.hs @@ -12,10 +12,12 @@ import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Maybe -import Path +import Path.Posix import Path.Internal import Test.Hspec +import Common (extensionOperations) + -- | Test suite (Posix version). spec :: Spec spec = @@ -30,8 +32,7 @@ describe "Operations: parent" operationParent describe "Operations: filename" operationFilename describe "Operations: dirname" operationDirname - describe "Operations: addFileExtension" operationAddFileExtension - describe "Operations: setFileExtension" operationSetFileExtension + describe "Operations: extensions" (extensionOperations "/") describe "Restrictions" restrictions describe "Aeson Instances" aesonInstances describe "QuasiQuotes" quasiquotes @@ -179,45 +180,6 @@ (toFilePath $(mkRelDir ".") == "./") it "show $(mkRelDir \".\") == \"\\\"./\\\"\"" (show $(mkRelDir ".") == "\"./\"") - -operationAddFileExtension :: Spec -operationAddFileExtension = do - it "adds extension if there is none" $ - addFileExtension "ext" $(mkAbsFile "/directory/path") - `shouldReturn` $(mkAbsFile "/directory/path.ext") - it "adds extension if there is already one" $ - addFileExtension "baz" $(mkRelFile "foo.bar") - `shouldReturn` $(mkRelFile "foo.bar.baz") - it "adds extension with dot" $ - addFileExtension ".bar" $(mkRelFile "foo") - `shouldReturn` $(mkRelFile "foo.bar") - it "adds extension with dot after dot" $ - $(mkRelFile "foo.") <.> ".bar" - `shouldReturn` $(mkRelFile "foo..bar") - it "adds extension without dot after dot" $ - $(mkRelFile "foo.") <.> "bar" - `shouldReturn` $(mkRelFile "foo..bar") - it "adds extension with separator" $ -- I'm not sure it's okay - $(mkRelFile "foo") <.> "evil/extension" - `shouldReturn` $(mkRelFile "foo.evil/extension") - it "adds extension to file inside dotted directory" $ - $(mkRelFile "foo.bar/baz") <.> "txt" - `shouldReturn` $(mkRelFile "foo.bar/baz.txt") - it "throws InvalidRelFile extension if extenstion ends with /" $ - $(mkRelFile "foo") <.> "evil/" - `shouldThrow` (== InvalidRelFile "foo.evil/") - it "throws InvalidAbsFile extension if extenstion ends with /" $ - $(mkAbsFile "/home/cfg") <.> "txt/" -- No Eq instance for PathException - `shouldThrow` (== InvalidAbsFile "/home/cfg.txt/") - -operationSetFileExtension :: Spec -operationSetFileExtension = do - it "adds extension if there is none" $ - setFileExtension "txt" $(mkRelFile "foo") - `shouldReturn` $(mkRelFile "foo.txt") - it "replaces extension if the input path already has one" $ - setFileExtension "txt" $(mkRelFile "foo.bar") - `shouldReturn` $(mkRelFile "foo.txt") -- | Tests for the tokenizer. parseAbsDirSpec :: Spec diff --git a/test/ValidityTest.hs b/test/ValidityTest.hs --- a/test/ValidityTest.hs +++ b/test/ValidityTest.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} -- | Test suite. - module Main where import Control.Applicative @@ -13,8 +14,9 @@ import Path import Path.Internal import Test.Hspec +import Test.Hspec.QuickCheck import Test.QuickCheck -import Test.Validity.Property +import Test.Validity import Path.Gen @@ -24,121 +26,195 @@ -- | Test suite. spec :: Spec -spec = parallel $ do - describe "Parsing: Path Abs Dir" (parserSpec parseAbsDir) - describe "Parsing: Path Rel Dir" (parserSpec parseRelDir) - describe "Parsing: Path Abs File" (parserSpec parseAbsFile) - describe "Parsing: Path Rel File" (parserSpec parseRelFile) - describe "Operations: ()" operationAppend - describe "Operations: stripProperPrefix" operationStripDir - describe "Operations: isProperPrefixOf" operationIsParentOf - describe "Operations: parent" operationParent - describe "Operations: filename" operationFilename +spec = + modifyMaxShrinks (const 100) $ + parallel $ do + genValidSpec @(Path Abs File) + shrinkValidSpec @(Path Abs File) + genValidSpec @(Path Rel File) + shrinkValidSpec @(Path Rel File) + genValidSpec @(Path Abs Dir) + shrinkValidSpec @(Path Abs Dir) + genValidSpec @(Path Rel Dir) + shrinkValidSpec @(Path Rel Dir) + describe "Parsing" $ do + describe "Path Abs Dir" (parserSpec parseAbsDir) + describe "Path Rel Dir" (parserSpec parseRelDir) + describe "Path Abs File" (parserSpec parseAbsFile) + describe "Path Rel File" (parserSpec parseRelFile) + describe "Operations" $ do + describe "()" operationAppend + describe "stripProperPrefix" operationStripDir + describe "isProperPrefixOf" operationIsParentOf + describe "parent" operationParent + describe "filename" operationFilename + describe "dirname" operationDirname + describe "Extensions" extensionsSpec -- | The 'filename' operation. operationFilename :: Spec operationFilename = do - it "filename ($(mkAbsDir parent) $(mkRelFile filename)) == filename $(mkRelFile filename)" $ - forAllShrink genValid shrinkValidAbsDir $ \parent -> - forAllShrink genValid shrinkValidRelFile $ \file -> - filename (parent file) `shouldBe` filename file - - it "filename ($(mkRelDir parent) $(mkRelFile filename)) == filename $(mkRelFile filename)" $ - forAllShrink genValid shrinkValidRelDir $ \parent -> - forAllShrink genValid shrinkValidRelFile $ \file -> - filename (parent file) `shouldBe` filename file - - it "produces a valid path on when passed a valid absolute path" $ do - producesValidsOnValids (filename :: Path Abs File -> Path Rel File) + forAllDirs "filename parent $(mkRelFile filename)) == filename $(mkRelFile filename)" $ \parent -> + forAllValid $ \file -> filename (parent file) `shouldBe` filename file + it "produces a valid path on when passed a valid absolute path" $ do + producesValidsOnValids (filename :: Path Abs File -> Path Rel File) + it "produces a valid path on when passed a valid relative path" $ do + producesValidsOnValids (filename :: Path Rel File -> Path Rel File) - it "produces a valid path on when passed a valid relative path" $ do - producesValidsOnValids (filename :: Path Rel File -> Path Rel File) +-- | The 'dirname' operation. +operationDirname :: Spec +operationDirname = do + forAllDirs "dirname parent $(mkRelDir dirname)) == dirname $(mkRelDir dirname)" $ \parent -> + forAllValid $ \dir -> if dir == Path [] then pure () else dirname (parent dir) `shouldBe` dirname dir + it "produces a valid path on when passed a valid absolute path" $ do + producesValidsOnValids (dirname :: Path Abs Dir -> Path Rel Dir) + it "produces a valid path on when passed a valid relative path" $ do + producesValidsOnValids (dirname :: Path Rel Dir -> Path Rel Dir) -- | The 'parent' operation. operationParent :: Spec operationParent = do - it "produces a valid path on when passed a valid file path" $ do - producesValidsOnValids (parent :: Path Abs File -> Path Abs Dir) - - it "produces a valid path on when passed a valid directory path" $ do - producesValidsOnValids (parent :: Path Abs Dir -> Path Abs Dir) + it "produces a valid path on when passed a valid file path" $ do + producesValidsOnValids (parent :: Path Abs File -> Path Abs Dir) + it "produces a valid path on when passed a valid directory path" $ do + producesValidsOnValids (parent :: Path Abs Dir -> Path Abs Dir) -- | The 'isProperPrefixOf' operation. operationIsParentOf :: Spec operationIsParentOf = do - it "isProperPrefixOf parent (parent child)" $ - forAllShrink genValid shrinkValidAbsDir $ \parent -> - forAllShrink genValid shrinkValidRelFile $ \child -> - isProperPrefixOf parent (parent child) - - it "isProperPrefixOf parent (parent child)" $ - forAllShrink genValid shrinkValidAbsDir $ \parent -> - forAllShrink genValid shrinkValidRelDir $ \child -> - child == Path [] || isProperPrefixOf parent (parent child) - - it "isProperPrefixOf parent (parent child)" $ - forAllShrink genValid shrinkValidRelDir $ \parent -> - forAllShrink genValid shrinkValidRelFile $ \child -> - isProperPrefixOf parent (parent child) - - it "isProperPrefixOf parent (parent child)" $ - forAllShrink genValid shrinkValidRelDir $ \parent -> - forAllShrink genValid shrinkValidRelDir $ \child -> - child == Path [] || isProperPrefixOf parent (parent child) + forAllParentsAndChildren "isProperPrefixOf parent (parent child)" $ \parent child -> + if child == Path [] + then True -- TODO do we always need this condition? + else isProperPrefixOf parent (parent child) -- | The 'stripProperPrefix' operation. operationStripDir :: Spec operationStripDir = do - it "stripProperPrefix parent (parent child) = child" $ - forAllShrink genValid shrinkValidAbsDir $ \parent -> - forAllShrink genValid shrinkValidRelFile $ \child -> - stripProperPrefix parent (parent child) == Just child - - it "stripProperPrefix parent (parent child) = child" $ - forAllShrink genValid shrinkValidRelDir $ \parent -> - forAllShrink genValid shrinkValidRelFile $ \child -> - stripProperPrefix parent (parent child) == Just child - - it "stripProperPrefix parent (parent child) = child" $ - forAllShrink genValid shrinkValidAbsDir $ \parent -> - forAllShrink genValid shrinkValidRelDir $ \child -> - child == Path [] - || stripProperPrefix parent (parent child) == Just child - - it "stripProperPrefix parent (parent child) = child" $ - forAllShrink genValid shrinkValidRelDir $ \parent -> - forAllShrink genValid shrinkValidRelDir $ \child -> - child == Path [] - || stripProperPrefix parent (parent child) == Just child - - it "produces a valid path on when passed a valid absolute file paths" $ do - producesValidsOnValids2 (stripProperPrefix :: Path Abs Dir -> Path Abs File -> Maybe (Path Rel File)) - - it "produces a valid path on when passed a valid absolute directory paths" $ do - producesValidsOnValids2 (stripProperPrefix :: Path Abs Dir -> Path Abs Dir -> Maybe (Path Rel Dir)) - - it "produces a valid path on when passed a valid relative file paths" $ do - producesValidsOnValids2 (stripProperPrefix :: Path Rel Dir -> Path Rel File-> Maybe (Path Rel File)) - - it "produces a valid path on when passed a valid relative directory paths" $ do - producesValidsOnValids2 (stripProperPrefix :: Path Rel Dir -> Path Rel Dir -> Maybe (Path Rel Dir)) + forAllParentsAndChildren "stripProperPrefix parent (parent child) = child" $ \parent child -> + if child == Path [] + then pure () -- TODO do we always need this condition? + else stripProperPrefix parent (parent child) `shouldBe` Just child + it "produces a valid path on when passed a valid absolute file paths" $ do + producesValidsOnValids2 + (stripProperPrefix :: Path Abs Dir -> Path Abs File -> Maybe (Path Rel File)) + it "produces a valid path on when passed a valid absolute directory paths" $ do + producesValidsOnValids2 + (stripProperPrefix :: Path Abs Dir -> Path Abs Dir -> Maybe (Path Rel Dir)) + it "produces a valid path on when passed a valid relative file paths" $ do + producesValidsOnValids2 + (stripProperPrefix :: Path Rel Dir -> Path Rel File -> Maybe (Path Rel File)) + it "produces a valid path on when passed a valid relative directory paths" $ do + producesValidsOnValids2 + (stripProperPrefix :: Path Rel Dir -> Path Rel Dir -> Maybe (Path Rel Dir)) -- | The '' operation. operationAppend :: Spec operationAppend = do - it "produces a valid path on when creating valid absolute file paths" $ do - producesValidsOnValids2 (() :: Path Abs Dir -> Path Rel File -> Path Abs File) + it "produces a valid path on when creating valid absolute file paths" $ do + producesValidsOnValids2 (() :: Path Abs Dir -> Path Rel File -> Path Abs File) + it "produces a valid path on when creating valid absolute directory paths" $ do + producesValidsOnValids2 (() :: Path Abs Dir -> Path Rel Dir -> Path Abs Dir) + it "produces a valid path on when creating valid relative file paths" $ do + producesValidsOnValids2 (() :: Path Rel Dir -> Path Rel File -> Path Rel File) + it "produces a valid path on when creating valid relative directory paths" $ do + producesValidsOnValids2 (() :: Path Rel Dir -> Path Rel Dir -> Path Rel Dir) - it "produces a valid path on when creating valid absolute directory paths" $ do - producesValidsOnValids2 (() :: Path Abs Dir -> Path Rel Dir -> Path Abs Dir) +extensionsSpec :: Spec +extensionsSpec = do + it "if addExtension a b succeeds then parseRelFile b succeeds - 1" $ + forAll genFilePath addExtGensValidFile + -- skew the generated path towards a valid extension by prefixing a "." + it "if addExtension a b succeeds then parseRelFile b succeeds - 2" $ + forAll genFilePath $ addExtGensValidFile . ("." ++) + forAllFiles + "(toFilePath . fromJust . addExtension ext) file \ + \== toFilePath a ++ b" $ \file -> + forAllValid $ \(Extension ext) -> + (toFilePath . fromJust . addExtension ext) file `shouldBe` toFilePath file ++ ext + forAllFiles "splitExtension output joins to result in the original file" $ \file -> + case splitExtension file of + Nothing -> pure () + Just (f, ext) -> toFilePath f ++ ext `shouldBe` toFilePath file + forAllFiles "splitExtension generates a valid filename and valid extension" $ \file -> + case splitExtension file of + Nothing -> True + Just (f, ext) -> + case parseRelFile ext of + Nothing -> False + Just _ -> + case parseRelFile (toFilePath f) of + Nothing -> + case parseAbsFile (toFilePath f) of + Nothing -> False + Just _ -> True + Just _ -> True + forAllFiles "splitExtension >=> uncurry addExtension . swap == return" $ \file -> + case splitExtension file of + Nothing -> pure () + Just (f, ext) -> addExtension ext f `shouldBe` Just file + forAllFiles "uncurry addExtension . swap >=> splitExtension == return" $ \file -> + forAllValid $ \(Extension ext) -> + (addExtension ext file >>= splitExtension) `shouldReturn` (file, ext) + forAllFiles "fileExtension == (fmap snd) . splitExtension" $ \file -> + case splitExtension file of + Nothing -> pure () + Just (_, ext) -> fileExtension file `shouldBe` Just ext + forAllFiles "flip addExtension file >=> fileExtension == return" $ \file -> + forAllValid $ \(Extension ext) -> + (fileExtension . fromJust . addExtension ext) file `shouldReturn` ext + forAllFiles "(fileExtension >=> flip replaceExtension file) file == return file" $ \file -> + case fileExtension file of + Nothing -> pure () + Just ext -> replaceExtension ext file `shouldBe` Just file + where + addExtGensValidFile p = + case addExtension p $(mkRelFile "x") of + Nothing -> True + Just x -> + case parseRelFile p of + Nothing -> False + _ -> True - it "produces a valid path on when creating valid relative file paths" $ do - producesValidsOnValids2 (() :: Path Rel Dir -> Path Rel File -> Path Rel File) +forAllFiles :: Testable a => String -> (forall b. Path b File -> a) -> Spec +forAllFiles n func = do + it (unwords [n, "Path Abs File"]) $ forAllValid $ \(file :: Path Abs File) -> func file + it (unwords [n, "Path Rel File"]) $ forAllValid $ \(file :: Path Rel File) -> func file - it "produces a valid path on when creating valid relative directory paths" $ do - producesValidsOnValids2 (() :: Path Rel Dir -> Path Rel Dir -> Path Rel Dir) +forAllDirs :: Testable a => String -> (forall b. Path b Dir -> a) -> Spec +forAllDirs n func = do + it (unwords [n, "Path Abs Dir"]) $ forAllValid $ \(parent :: Path Abs Dir) -> func parent + it (unwords [n, "Path Rel Dir"]) $ forAllValid $ \(parent :: Path Rel Dir) -> func parent +forAllParentsAndChildren :: + Testable a => String -> (forall b t. Path b Dir -> Path Rel t -> a) -> Spec +forAllParentsAndChildren n func = do + it (unwords [n, "Path Abs Dir", "Path Rel Dir"]) $ + forAllValid $ \(parent :: Path Abs Dir) -> + forAllValid $ \(child :: Path Rel Dir) -> func parent child + it (unwords [n, "Path Rel Dir", "Path Rel Dir"]) $ + forAllValid $ \(parent :: Path Rel Dir) -> + forAllValid $ \(child :: Path Rel Dir) -> func parent child + it (unwords [n, "Path Abs Dir", "Path Rel File"]) $ + forAllValid $ \(parent :: Path Abs Dir) -> + forAllValid $ \(child :: Path Rel File) -> func parent child + it (unwords [n, "Path Rel Dir", "Path Rel File"]) $ + forAllValid $ \(parent :: Path Rel Dir) -> + forAllValid $ \(child :: Path Rel File) -> func parent child + +forAllPaths :: Testable a => String -> (forall b t. Path b t -> a) -> Spec +forAllPaths n func = do + it (unwords [n, "Path Abs Dir"]) $ forAllValid $ \(path :: Path Abs Dir) -> func path + it (unwords [n, "Path Rel Dir"]) $ forAllValid $ \(path :: Path Rel Dir) -> func path + it (unwords [n, "Path Abs File"]) $ forAllValid $ \(path :: Path Abs File) -> func path + it (unwords [n, "Path Rel File"]) $ forAllValid $ \(path :: Path Rel File) -> func path + parserSpec :: (Show p, Validity p) => (FilePath -> Maybe p) -> Spec parserSpec parser = - it "Produces valid paths when it succeeds" $ - validIfSucceedsOnGen parser genFilePath + it "Produces valid paths when it succeeds" $ + forAllShrink genFilePath shrinkUnchecked $ \path -> + case parser path of + Nothing -> pure () + Just p -> + case prettyValidate p of + Left err -> expectationFailure err + Right _ -> pure () diff --git a/test/Windows.hs b/test/Windows.hs --- a/test/Windows.hs +++ b/test/Windows.hs @@ -11,11 +11,14 @@ import Control.Monad import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Function (on) import Data.Maybe -import Path +import Path.Windows import Path.Internal import Test.Hspec +import Common (extensionOperations) + -- | Test suite (Windows version). spec :: Spec spec = @@ -30,8 +33,7 @@ describe "Operations: parent" operationParent describe "Operations: filename" operationFilename describe "Operations: dirname" operationDirname - describe "Operations: addFileExtension" operationAddFileExtension - describe "Operations: setFileExtension" operationSetFileExtension + describe "Operations: extensions" (extensionOperations "C:\\") describe "Restrictions" restrictions describe "Aeson Instances" aesonInstances describe "QuasiQuotes" quasiquotes @@ -57,43 +59,57 @@ -- | The 'dirname' operation. operationDirname :: Spec -operationDirname = do - it - "dirname ($(mkAbsDir parent) $(mkRelFile dirname)) == dirname $(mkRelFile dirname) (unit test)" - (dirname ($(mkAbsDir "C:\\chris\\") $(mkRelDir "bar")) == - dirname $(mkRelDir "bar")) - it - "dirname ($(mkRelDir parent) $(mkRelFile dirname)) == dirname $(mkRelFile dirname) (unit test)" - (dirname ($(mkRelDir "home\\chris\\") $(mkRelDir "bar")) == - dirname $(mkRelDir "bar")) - it - "dirname $(mkRelDir .) == $(mkRelDir .)" - (dirname $(mkRelDir ".") == $(mkRelDir ".")) - it - "dirname C:\\ must be a Rel path" - ((parseAbsDir $ show $ dirname (fromJust (parseAbsDir "C:\\")) - :: Maybe (Path Abs Dir)) == Nothing) +operationDirname = + do it "dirname ($(mkAbsDir parent) $(mkRelFile dirname)) == dirname $(mkRelFile dirname) (absolute)" + (dirnamesShouldBeEqual + ($(mkAbsDir "C:\\chris\\") $(mkRelDir "bar")) + $(mkRelDir "bar")) + it "dirname ($(mkRelDir parent) $(mkRelFile dirname)) == dirname $(mkRelFile dirname) (relative)" + (dirnamesShouldBeEqual + ($(mkRelDir "home\\chris\\") $(mkRelDir "bar")) + $(mkRelDir "bar")) + it "dirname ($(mkAbsDir parent) $(mkRelFile dirname)) == dirname $(mkRelFile dirname) (UNC)" + (dirnamesShouldBeEqual + ($(mkAbsDir "\\\\home\\chris\\") $(mkRelDir "bar")) + $(mkRelDir "bar")) + it "dirname ($(mkAbsDir parent) $(mkRelFile dirname)) == dirname $(mkRelFile dirname) (Unicode)" + (dirnamesShouldBeEqual + ($(mkAbsDir "\\\\?\\C:\\home\\chris\\") $(mkRelDir "bar")) + $(mkRelDir "bar")) + it "dirname $(mkRelDir .) == $(mkRelDir .)" + (dirnamesShouldBeEqual + $(mkRelDir ".") + $(mkRelDir ".")) + it "dirname C:\\ must be a Rel path" + ((parseAbsDir $ show $ dirname (fromJust (parseAbsDir "C:\\")) :: Maybe (Path Abs Dir)) == Nothing) + where dirnamesShouldBeEqual = (==) `on` dirname -- | The 'filename' operation. operationFilename :: Spec operationFilename = - do it "filename ($(mkAbsDir parent) $(mkRelFile filename)) == filename $(mkRelFile filename) (unit test)" - (filename ($(mkAbsDir "C:\\chris\\") - $(mkRelFile "bar.txt")) == - filename $(mkRelFile "bar.txt")) - - it "filename ($(mkRelDir parent) $(mkRelFile filename)) == filename $(mkRelFile filename) (unit test)" - (filename ($(mkRelDir "home\\chris\\") - $(mkRelFile "bar.txt")) == - filename $(mkRelFile "bar.txt")) + do it "filename ($(mkAbsDir parent) $(mkRelFile filename)) == filename $(mkRelFile filename) (absolute)" + (filenamesShouldBeEqual + ($(mkAbsDir "C:\\chris\\") $(mkRelFile "bar.txt")) + $(mkRelFile "bar.txt")) + it "filename ($(mkRelDir parent) $(mkRelFile filename)) == filename $(mkRelFile filename) (relative)" + (filenamesShouldBeEqual + ($(mkRelDir "home\\chris\\") $(mkRelFile "bar.txt")) + $(mkRelFile "bar.txt")) + it "filename ($(mkAbsDir parent) $(mkRelFile filename)) == filename $(mkRelFile filename) (UNC)" + (filenamesShouldBeEqual + ($(mkAbsDir "\\\\host\\share\\chris\\") $(mkRelFile "bar.txt")) + $(mkRelFile "bar.txt")) + it "filename ($(mkAbsDir parent) $(mkRelFile filename)) == filename $(mkRelFile filename) (Unicode)" + (filenamesShouldBeEqual + ($(mkAbsDir "\\\\?\\C:\\home\\chris\\") $(mkRelFile "bar.txt")) + $(mkRelFile "bar.txt")) + where filenamesShouldBeEqual = (==) `on` filename -- | The 'parent' operation. operationParent :: Spec operationParent = do it "parent (parent child) == parent" - (parent ($(mkAbsDir "C:\\foo") - $(mkRelDir "bar")) == - $(mkAbsDir "C:\\foo")) + (parent ($(mkAbsDir "C:\\foo") $(mkRelDir "bar")) == $(mkAbsDir "C:\\foo")) it "parent \"C:\\\" == \"C:\\\"" (parent $(mkAbsDir "C:\\") == $(mkAbsDir "C:\\")) it "parent \"C:\\x\" == \"C:\\\"" @@ -108,67 +124,103 @@ operationIsProperPrefixOf = do it "isProperPrefixOf parent (parent child) (absolute)" (isProperPrefixOf - $(mkAbsDir "C:\\\\\\bar\\") - ($(mkAbsDir "C:\\\\\\bar\\") - $(mkRelFile "bar\\foo.txt"))) - + $(mkAbsDir "C:\\\\\\bar\\") + ($(mkAbsDir "C:\\\\\\bar\\") $(mkRelFile "bar\\foo.txt"))) it "isProperPrefixOf parent (parent child) (relative)" (isProperPrefixOf - $(mkRelDir "bar\\") - ($(mkRelDir "bar\\") - $(mkRelFile "bob\\foo.txt"))) - + $(mkRelDir "bar\\") + ($(mkRelDir "bar\\") $(mkRelFile "bob\\foo.txt"))) + it "isProperPrefixOf parent (parent child) (UNC)" + (isProperPrefixOf + $(mkAbsDir "\\\\host\\share\\") + ($(mkAbsDir "\\\\host\\share\\") $(mkRelFile "bob\\foo.txt"))) + it "isProperPrefixOf parent (parent child) (Unicode)" + (isProperPrefixOf + $(mkAbsDir "\\\\?\\C:\\folder\\") + ($(mkAbsDir "\\\\?\\C:\\folder\\") $(mkRelFile "bob\\foo.txt"))) it "not (x `isProperPrefixOf` x)" (not (isProperPrefixOf $(mkRelDir "x") $(mkRelDir "x"))) - it "not (\\ `isProperPrefixOf` \\)" (not (isProperPrefixOf $(mkAbsDir "C:\\") $(mkAbsDir "C:\\"))) -- | The 'stripProperPrefix' operation. operationStripProperPrefix :: Spec operationStripProperPrefix = - do it "stripProperPrefix parent (parent child) = child (unit test)" - (stripProperPrefix $(mkAbsDir "C:\\\\\\bar\\") - ($(mkAbsDir "C:\\\\\\bar\\") - $(mkRelFile "bar\\foo.txt")) == - Just $(mkRelFile "bar\\foo.txt")) - - it "stripProperPrefix parent (parent child) = child (unit test)" - (stripProperPrefix $(mkRelDir "bar\\") - ($(mkRelDir "bar\\") - $(mkRelFile "bob\\foo.txt")) == - Just $(mkRelFile "bob\\foo.txt")) - + do it "stripProperPrefix parent (parent child) = child (absolute)" + (remainingPathShouldBe + $(mkAbsDir "C:\\\\\\bar\\") + ($(mkAbsDir "C:\\\\\\bar\\") $(mkRelFile "bar\\foo.txt")) + (Just $(mkRelFile "bar\\foo.txt"))) + it "stripProperPrefix parent (parent child) = child (relative)" + (remainingPathShouldBe + $(mkRelDir "bar\\") + ($(mkRelDir "bar\\") $(mkRelFile "bob\\foo.txt")) + (Just $(mkRelFile "bob\\foo.txt"))) + it "stripProperPrefix parent (parent child) = child (UNC)" + (remainingPathShouldBe + $(mkAbsDir "\\\\host\\share\\") + ($(mkAbsDir "\\\\host\\share\\") $(mkRelFile "bob\\foo.txt")) + (Just $(mkRelFile "bob\\foo.txt"))) + it "stripProperPrefix parent (parent child) = child (Unicode)" + (remainingPathShouldBe + $(mkAbsDir "\\\\?\\C:\\folder\\") + ($(mkAbsDir "\\\\?\\C:\\folder\\") $(mkRelFile "bob\\foo.txt")) + (Just $(mkRelFile "bob\\foo.txt"))) it "stripProperPrefix parent parent = _|_" - (stripProperPrefix $(mkAbsDir "C:\\home\\chris\\foo") - $(mkAbsDir "C:\\home\\chris\\foo") == - Nothing) + (remainingPathShouldBe + $(mkAbsDir "C:\\home\\chris\\foo") + $(mkAbsDir "C:\\home\\chris\\foo") + Nothing) + where remainingPathShouldBe prefix path suffix = + stripProperPrefix prefix path == suffix -- | The '' operation. operationAppend :: Spec operationAppend = do it "AbsDir + RelDir = AbsDir" - ($(mkAbsDir "C:\\home\\") - $(mkRelDir "chris") == - $(mkAbsDir "C:\\home\\chris\\")) + (shouldBe + ($(mkAbsDir "C:\\home\\") $(mkRelDir "chris")) + $(mkAbsDir "C:\\home\\chris\\")) it "AbsDir + RelFile = AbsFile" - ($(mkAbsDir "C:\\home\\") - $(mkRelFile "chris\\test.txt") == - $(mkAbsFile "C:\\home\\chris\\test.txt")) + (shouldBe + ($(mkAbsDir "C:\\home\\") $(mkRelFile "chris\\test.txt")) + $(mkAbsFile "C:\\home\\chris\\test.txt")) it "RelDir + RelDir = RelDir" - ($(mkRelDir "home\\") - $(mkRelDir "chris") == - $(mkRelDir "home\\chris")) + (shouldBe + ($(mkRelDir "home\\") $(mkRelDir "chris")) + $(mkRelDir "home\\chris")) it ". + . = ." - ($(mkRelDir ".\\") $(mkRelDir ".") == $(mkRelDir ".")) + (shouldBe + ($(mkRelDir ".\\") $(mkRelDir ".")) + $(mkRelDir ".")) it ". + x = x" - ($(mkRelDir ".") $(mkRelDir "x") == $(mkRelDir "x")) + (shouldBe + ($(mkRelDir ".") $(mkRelDir "x")) + $(mkRelDir "x")) it "x + . = x" - ($(mkRelDir "x") $(mkRelDir ".\\") == $(mkRelDir "x")) + (shouldBe + ($(mkRelDir "x") $(mkRelDir ".\\")) + $(mkRelDir "x")) it "RelDir + RelFile = RelFile" - ($(mkRelDir "home\\") - $(mkRelFile "chris\\test.txt") == - $(mkRelFile "home\\chris\\test.txt")) + (shouldBe + ($(mkRelDir "home\\") $(mkRelFile "chris\\test.txt")) + $(mkRelFile "home\\chris\\test.txt")) + it "AbsDir(UNC) + RelDir = AbsDir(UNC)" + (shouldBe + ($(mkAbsDir "\\\\host\\share\\") $(mkRelDir "folder\\")) + $(mkAbsDir "\\\\host\\share\\folder\\")) + it "AbsDir(UNC) + RelFile = AbsFile(UNC)" + (shouldBe + ($(mkAbsDir "\\\\host\\share\\") $(mkRelFile "folder\\file.txt")) + $(mkAbsFile "\\\\host\\share\\folder\\file.txt")) + it "AbsDir(Unicode) + RelDir = AbsDir(Unicode)" + (shouldBe + ($(mkAbsDir "\\\\?\\C:\\folder\\") $(mkRelDir "another\\")) + $(mkAbsDir "\\\\?\\C:\\folder\\another\\")) + it "AbsDir(Unicode) + RelFile = AbsFile(Unicode)" + (shouldBe + ($(mkAbsDir "\\\\?\\C:\\folder\\") $(mkRelFile "file.txt")) + $(mkAbsFile "\\\\?\\C:\\folder\\file.txt")) operationToFilePath :: Spec operationToFilePath = @@ -177,56 +229,24 @@ it "show $(mkRelDir \".\") == \"\\\".\\\\\"\"" (show $(mkRelDir ".") == "\".\\\\\"") -operationAddFileExtension :: Spec -operationAddFileExtension = do - it "adds extension if there is none" $ - addFileExtension "ext" $(mkAbsFile "C:\\directory\\path") - `shouldReturn` $(mkAbsFile "C:\\directory\\path.ext") - it "adds extension if there is already one" $ - addFileExtension "baz" $(mkRelFile "foo.bar") - `shouldReturn` $(mkRelFile "foo.bar.baz") - it "adds extension with dot" $ - addFileExtension ".bar" $(mkRelFile "foo") - `shouldReturn` $(mkRelFile "foo.bar") - it "adds extension with dot after dot" $ - $(mkRelFile "foo.") <.> ".bar" - `shouldReturn` $(mkRelFile "foo..bar") - it "adds extension without dot after dot" $ - $(mkRelFile "foo.") <.> "bar" - `shouldReturn` $(mkRelFile "foo..bar") - it "adds extension with separator" $ -- I'm not sure it's okay - $(mkRelFile "foo") <.> "evil\\extension" - `shouldReturn` $(mkRelFile "foo.evil\\extension") - it "adds extension to file inside dotted directory" $ - $(mkRelFile "foo.bar\\baz") <.> "txt" - `shouldReturn` $(mkRelFile "foo.bar\\baz.txt") - it "throws InvalidRelFile extension if extenstion ends with \\" $ - $(mkRelFile "foo") <.> "evil\\" - `shouldThrow` (== InvalidRelFile "foo.evil\\") - it "throws InvalidAbsFile extension if extenstion ends with \\" $ - $(mkAbsFile "C:\\home\\cfg") <.> "txt\\" - `shouldThrow` (== InvalidAbsFile "C:\\home\\cfg.txt\\") - -operationSetFileExtension :: Spec -operationSetFileExtension = do - it "adds extension if there is none" $ - setFileExtension "txt" $(mkRelFile "foo") - `shouldReturn` $(mkRelFile "foo.txt") - it "replaces extension if the input path already has one" $ - setFileExtension "txt" $(mkRelFile "foo.bar") - `shouldReturn` $(mkRelFile "foo.txt") - -- | Tests for the tokenizer. parseAbsDirSpec :: Spec parseAbsDirSpec = do failing "" failing ".\\" failing "foo.txt" + failing "C:" succeeding "C:\\" (Path "C:\\") - succeeding "C:\\\\" (Path "C:\\\\") - -- succeeding "C:\\\\\\foo\\\\bar\\\\mu\\" (Path "C:\\foo\\bar\\mu\\") FIXME - -- succeeding "C:\\\\\\foo\\\\bar\\\\mu" (Path "C:\\foo\\bar\\mu\\") FIXME - -- succeeding "C:\\\\\\foo\\\\bar\\.\\\\mu" (Path "C:\\foo\\bar\\mu\\") FIXME + succeeding "C:\\\\" (Path "C:\\") + succeeding "C:\\\\\\foo\\\\bar\\\\mu\\" (Path "C:\\foo\\bar\\mu\\") + succeeding "C:\\\\\\foo\\\\bar\\\\mu" (Path "C:\\foo\\bar\\mu\\") + succeeding "C:\\\\\\foo\\\\bar\\.\\\\mu" (Path "C:\\foo\\bar\\mu\\") + succeeding "\\\\unchost\\share" (Path "\\\\unchost\\share\\") + succeeding "\\/unchost\\share" (Path "\\\\unchost\\share\\") + succeeding "\\\\unchost\\share\\\\folder\\" (Path "\\\\unchost\\share\\folder\\") + succeeding "\\\\?\\C:\\" (Path "\\\\?\\C:\\") + succeeding "/\\?\\C:\\" (Path "\\\\?\\C:\\") + succeeding "\\\\?\\C:\\\\\\folder\\\\" (Path "\\\\?\\C:\\folder\\") where failing x = parserTest parseAbsDir x Nothing succeeding x with = parserTest parseAbsDir x (Just with) @@ -235,16 +255,17 @@ parseRelDirSpec :: Spec parseRelDirSpec = do failing "" - -- failing "/" FIXME - -- failing "//" FIXME - -- succeeding "~/" (Path "~/") -- https://github.com/chrisdone/path/issues/19 - -- failing "\\" FIXME - succeeding ".\\" (Path "") - succeeding ".\\.\\" (Path "") + failing "/" + failing "//" + failing "\\" failing "\\\\" failing "\\\\\\foo\\\\bar\\\\mu\\" failing "\\\\\\foo\\\\bar\\\\\\\\mu" failing "\\\\\\foo\\\\bar\\.\\\\mu" + failing "\\\\unchost\\share" + failing "\\\\?\\C:\\" + succeeding ".\\" (Path "") + succeeding ".\\.\\" (Path "") succeeding "..." (Path "...\\") succeeding "foo.bak" (Path "foo.bak\\") succeeding ".\\foo" (Path "foo\\") @@ -269,10 +290,16 @@ failing "\\" failing "\\\\" failing "\\\\\\foo\\\\bar\\\\mu\\" - -- succeeding "\\..." (Path "\\...") FIXME - -- succeeding "\\foo.txt" (Path "\\foo.txt") FIXME - -- succeeding "C:\\\\\\foo\\\\bar\\\\\\\\mu.txt" (Path "C:\\foo\\bar\\mu.txt") FIXME - -- succeeding "C:\\\\\\foo\\\\bar\\.\\\\mu.txt" (Path "C:\\foo\\bar\\mu.txt") FIXME + failing "\\..." + failing "\\foo.txt" + succeeding "C:\\\\\\foo\\\\bar\\\\\\\\mu.txt" (Path "C:\\foo\\bar\\mu.txt") + succeeding "C:\\\\\\foo\\\\bar\\.\\\\mu.txt" (Path "C:\\foo\\bar\\mu.txt") + succeeding "\\\\unchost\\share\\\\file.txt" (Path "\\\\unchost\\share\\file.txt") + succeeding "\\/unchost\\share\\\\file.txt" (Path "\\\\unchost\\share\\file.txt") + succeeding "\\\\unchost\\share\\.\\folder\\\\\\file.txt" (Path "\\\\unchost\\share\\folder\\file.txt") + succeeding "\\\\?\\C:\\file.txt" (Path "\\\\?\\C:\\file.txt") + succeeding "/\\?\\C:\\file.txt" (Path "\\\\?\\C:\\file.txt") + succeeding "\\\\?\\C:\\\\\\folder\\.\\\\file.txt" (Path "\\\\?\\C:\\folder\\file.txt") where failing x = parserTest parseAbsFile x Nothing succeeding x with = parserTest parseAbsFile x (Just with) @@ -294,6 +321,8 @@ failing "\\\\\\foo\\\\bar\\\\mu\\" failing "\\\\\\foo\\\\bar\\\\\\\\mu" failing "\\\\\\foo\\\\bar\\.\\\\mu" + failing "\\\\unchost\\share\\\\file.txt" + failing "\\\\?\\C:\\file.txt" succeeding "a.." (Path "a..") succeeding "..." (Path "...") succeeding "foo.txt" (Path "foo.txt")