path 0.8.0 → 0.9.6
raw patch · 50 files changed
Files
- CHANGELOG +21/−0
- README.md +3/−5
- os-string-compat/System/OsString/Compat/Include.hs +139/−0
- os-string-compat/System/OsString/Compat/Posix.hs +6/−0
- os-string-compat/System/OsString/Compat/Windows.hs +6/−0
- path.cabal +142/−41
- src/OsPath.hs +15/−0
- src/OsPath/Include.hs +819/−0
- src/OsPath/Internal.hs +9/−0
- src/OsPath/Internal/Include.hs +297/−0
- src/OsPath/Internal/Posix.hs +7/−0
- src/OsPath/Internal/Windows.hs +7/−0
- src/OsPath/Posix.hs +8/−0
- src/OsPath/Windows.hs +8/−0
- src/Path/Include.hs +83/−24
- src/Path/Internal.hs +7/−136
- src/Path/Internal/Include.hs +147/−0
- src/Path/Internal/Posix.hs +4/−0
- src/Path/Internal/Windows.hs +4/−0
- src/Path/Posix.hs +0/−1
- src/Path/Windows.hs +0/−1
- test-ospath/Common/Include.hs +344/−0
- test-ospath/Common/Posix.hs +9/−0
- test-ospath/Common/Windows.hs +18/−0
- test-ospath/Main.hs +12/−0
- test-ospath/Posix.hs +154/−0
- test-ospath/TH/Posix.hs +23/−0
- test-ospath/TH/Windows.hs +23/−0
- test-ospath/Windows.hs +164/−0
- test/Common.hs +0/−87
- test/Common/Include.hs +335/−0
- test/Common/Posix.hs +7/−0
- test/Common/Windows.hs +16/−0
- test/Main.hs +5/−8
- test/Path/Gen.hs +0/−164
- test/Posix.hs +6/−157
- test/TH.hs +0/−58
- test/TH/Posix.hs +22/−0
- test/TH/Windows.hs +22/−0
- test/ValidityTest.hs +0/−220
- test/Windows.hs +6/−210
- validity-test-ospath/Include.hs +268/−0
- validity-test-ospath/Main.hs +21/−0
- validity-test-ospath/OsPath/Gen/Include.hs +163/−0
- validity-test-ospath/OsPath/Gen/Posix.hs +8/−0
- validity-test-ospath/OsPath/Gen/Windows.hs +8/−0
- validity-test-ospath/Posix.hs +6/−0
- validity-test-ospath/Windows.hs +6/−0
- validity-test/Main.hs +259/−0
- validity-test/Path/Gen.hs +126/−0
CHANGELOG view
@@ -1,3 +1,24 @@+0.9.6+ * Support for `ospath`++0.9.5+ * Add `splitDrive`, `takeDrive`, `dropDrive` and `isDrive`.++ 0.9.4 was an accidental release of the unreleased 0.9.3 without the appropriate changelog.++0.9.2+ * Data instances for Rel, Abs, File, and Dir.+ * Bump hashable upper bound to <1.5.++0.9.1+ * Support for genvalidity >=1.0.0.0+ * `mapSomeBase` and `prjSomeBase` for modifying or projecting SomeBase.++0.9.0+ * Fix inconsistencies on different platforms: [#166](https://github.com/commercialhaskell/path/issues/166)+ * `replaceProperPrefix`+ * Make it possible to use windows paths on posix and vice versa+ 0.8.0 * Rerelease of 0.7.1 with better version number
README.md view
@@ -1,7 +1,6 @@ # Path -[](https://travis-ci.org/commercialhaskell/path)-[](https://ci.appveyor.com/project/chrisdone/path)+ [](https://hackage.haskell.org/package/path) [](http://stackage.org/lts/package/path) [](http://stackage.org/nightly/package/path)@@ -181,7 +180,6 @@ ``` That’s really convenient and we take advantage of this at FP Complete a lot.-The instances Equality, ordering and printing are simply re-using the `String` instances: @@ -442,7 +440,7 @@ ### pathtype -Finally, we come to a path library that path is similar to: the+Finally, we come to a path library that is similar to: the [`pathtype`](http://hackage.haskell.org/package/pathtype) library. There are the same types of `Path Abs File` / `Path Rel Dir`, etc. @@ -487,7 +485,7 @@ False ``` -* It has functions like `<.>/addExtension` which lets you insert an+* It has functions like `<.>/addExtension` which let you insert an arbitrary string into a path. * Some functions let you produce nonsense (could be prevented by a stricter
+ os-string-compat/System/OsString/Compat/Include.hs view
@@ -0,0 +1,139 @@+-- This template expects CPP definitions for:+-- PLATFORM_NAME = Posix | Windows+-- PLATFORM_STRING = PosixString | WindowsString+-- PLATFORM_CHAR = PosixChar | WindowsChar+-- IS_WINDOWS = 0 | 1++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}++{-# OPTIONS_GHC -Wno-deprecations #-}+{-# OPTIONS_GHC -Wno-orphans #-}++#define USE_os_string 0+#if defined MIN_VERSION_os_string+#if MIN_VERSION_os_string(2,0,0)+#undef USE_os_string+#define USE_os_string 1+#endif+#endif++module System.OsString.Compat.PLATFORM_NAME+#if USE_os_string+ ( PLATFORM_STRING(..)+ , PLATFORM_CHAR(..)+ , module OsString+ )+#else+ ( PLATFORM_STRING(..)+ , PLATFORM_CHAR(..)+ , OsString.pstr+ , System.OsString.Compat.PLATFORM_NAME.all+ , System.OsString.Compat.PLATFORM_NAME.any+ , System.OsString.Compat.PLATFORM_NAME.break+ , System.OsString.Compat.PLATFORM_NAME.breakEnd+ , System.OsString.Compat.PLATFORM_NAME.dropWhileEnd+ , System.OsString.Compat.PLATFORM_NAME.empty+ , System.OsString.Compat.PLATFORM_NAME.init+ , System.OsString.Compat.PLATFORM_NAME.isInfixOf+ , System.OsString.Compat.PLATFORM_NAME.isPrefixOf+ , System.OsString.Compat.PLATFORM_NAME.isSuffixOf+ , System.OsString.Compat.PLATFORM_NAME.length+ , System.OsString.Compat.PLATFORM_NAME.map+ , System.OsString.Compat.PLATFORM_NAME.null+ , System.OsString.Compat.PLATFORM_NAME.replicate+ , System.OsString.Compat.PLATFORM_NAME.singleton+ , System.OsString.Compat.PLATFORM_NAME.span+ , System.OsString.Compat.PLATFORM_NAME.spanEnd+ , System.OsString.Compat.PLATFORM_NAME.stripPrefix+ , System.OsString.Compat.PLATFORM_NAME.uncons+ )+#endif+ where++import Data.Data (Data)+import System.OsString.Internal.Types (PLATFORM_STRING(..), PLATFORM_CHAR(..))+import System.OsString.PLATFORM_NAME as OsString++#if !USE_os_string+import Data.Coerce (coerce)++#if IS_WINDOWS+import qualified System.OsPath.Data.ByteString.Short.Word16 as BSP+#else+import qualified System.OsPath.Data.ByteString.Short as BSP+#endif+#endif++deriving instance Data PLATFORM_STRING++#if !USE_os_string+all :: (PLATFORM_CHAR -> Bool) -> PLATFORM_STRING -> Bool+all = coerce BSP.all++any :: (PLATFORM_CHAR -> Bool) -> PLATFORM_STRING -> Bool+any = coerce BSP.any++break+ :: (PLATFORM_CHAR -> Bool)+ -> PLATFORM_STRING+ -> (PLATFORM_STRING, PLATFORM_STRING)+break = coerce BSP.break++breakEnd+ :: (PLATFORM_CHAR -> Bool)+ -> PLATFORM_STRING+ -> (PLATFORM_STRING, PLATFORM_STRING)+breakEnd = coerce BSP.breakEnd++dropWhileEnd :: (PLATFORM_CHAR -> Bool) -> PLATFORM_STRING -> PLATFORM_STRING+dropWhileEnd = coerce BSP.dropWhileEnd++empty :: PLATFORM_STRING+empty = coerce BSP.empty++init :: PLATFORM_STRING -> PLATFORM_STRING+init = coerce BSP.init++isInfixOf :: PLATFORM_STRING -> PLATFORM_STRING -> Bool+isInfixOf = coerce BSP.isInfixOf++isPrefixOf :: PLATFORM_STRING -> PLATFORM_STRING -> Bool+isPrefixOf = coerce BSP.isPrefixOf++isSuffixOf :: PLATFORM_STRING -> PLATFORM_STRING -> Bool+isSuffixOf = coerce BSP.isSuffixOf++length :: PLATFORM_STRING -> Int+length = coerce BSP.length++map :: (PLATFORM_CHAR -> PLATFORM_CHAR) -> PLATFORM_STRING -> PLATFORM_STRING+map = coerce BSP.map++null :: PLATFORM_STRING -> Bool+null = coerce BSP.null++replicate :: Int -> PLATFORM_CHAR -> PLATFORM_STRING+replicate = coerce BSP.replicate++singleton :: PLATFORM_CHAR -> PLATFORM_STRING+singleton = coerce BSP.singleton++span+ :: (PLATFORM_CHAR -> Bool)+ -> PLATFORM_STRING+ -> (PLATFORM_STRING, PLATFORM_STRING)+span = coerce BSP.span++spanEnd+ :: (PLATFORM_CHAR -> Bool)+ -> PLATFORM_STRING+ -> (PLATFORM_STRING, PLATFORM_STRING)+spanEnd = coerce BSP.spanEnd++stripPrefix :: PLATFORM_STRING -> PLATFORM_STRING -> Maybe PLATFORM_STRING+stripPrefix = coerce BSP.stripPrefix++uncons :: PLATFORM_STRING -> Maybe (PLATFORM_CHAR, PLATFORM_STRING)+uncons = coerce BSP.uncons+#endif
+ os-string-compat/System/OsString/Compat/Posix.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE CPP #-}+#define PLATFORM_NAME Posix+#define PLATFORM_STRING PosixString+#define PLATFORM_CHAR PosixChar+#define IS_WINDOWS 0+#include "Include.hs"
+ os-string-compat/System/OsString/Compat/Windows.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE CPP #-}+#define PLATFORM_NAME Windows+#define PLATFORM_STRING WindowsString+#define PLATFORM_CHAR WindowsChar+#define IS_WINDOWS 1+#include "Include.hs"
path.cabal view
@@ -1,91 +1,192 @@+cabal-version: 3.0 name: path-version: 0.8.0+version: 0.9.6 synopsis: Support for well-typed paths description: Support for well-typed paths.-license: BSD3+license: BSD-3-Clause license-file: LICENSE author: Chris Done <chrisdone@fpcomplete.com> maintainer: Chris Done <chrisdone@fpcomplete.com> copyright: 2015–2018 FP Complete category: System, Filesystem build-type: Simple-cabal-version: 1.18-tested-with: GHC==8.6.5, GHC==8.8.3, GHC==8.10.1+tested-with: GHC==9.2.8, GHC==9.4.8, GHC==9.6.6, GHC==9.8.2, GHC==9.10.1 extra-source-files: README.md , CHANGELOG+ , os-string-compat/System/OsString/Compat/Include.hs , src/Path/Include.hs+ , src/Path/Internal/Include.hs+ , src/OsPath/Include.hs+ , src/OsPath/Internal/Include.hs+ , test/Common/Include.hs+ , test-ospath/Common/Include.hs+ , validity-test-ospath/Include.hs+ , validity-test-ospath/OsPath/Gen/Include.hs flag dev description: Turn on development settings. manual: True default: False +flag os-string+ description: Use an older version of the os-string library.+ manual: False+ default: False++common language+ ghc-options: -Wall++ if flag(dev)+ ghc-options: -Wcompat+ -Werror+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wnoncanonical-monad-instances++ default-language: Haskell2010++common rts+ ghc-options: -O2+ -threaded+ -rtsopts+ -with-rtsopts=-N+ library+ import: language+ hs-source-dirs: src+ exposed-modules: Path- , Path.Internal , Path.Posix , Path.Windows- build-depends: aeson- , base >= 4.12 && < 5+ , Path.Internal+ , Path.Internal.Posix+ , Path.Internal.Windows+ , OsPath+ , OsPath.Posix+ , OsPath.Windows+ , OsPath.Internal+ , OsPath.Internal.Posix+ , OsPath.Internal.Windows++ build-depends: aeson >= 1.0.0.0+ , base >= 4.12 && < 5 , deepseq , exceptions >= 0.4 && < 0.11- , filepath < 1.2.0.1 || >= 1.3- , hashable >= 1.2 && < 1.4+ , hashable >= 1.2 && < 1.5+ , path:os-string-compat , text , template-haskell- if flag(dev)- ghc-options: -Wall -Werror++ if flag(os-string)+ build-depends: filepath >= 1.5 else- ghc-options: -O2 -Wall- if flag(dev)- ghc-options: -Wcompat- -Wincomplete-record-updates- -Wincomplete-uni-patterns- -Wnoncanonical-monad-instances- default-language: Haskell2010+ build-depends: filepath >= 1.4.100.0 && <1.5 +library os-string-compat+ import: language++ hs-source-dirs: os-string-compat+ visibility: private++ exposed-modules: System.OsString.Compat.Posix+ , System.OsString.Compat.Windows++ build-depends: base >= 4.12 && < 5++ if flag(os-string)+ build-depends: os-string >= 2.0.0+ else+ build-depends: filepath >= 1.4.100.0+ test-suite test+ import: language+ import: rts+ type: exitcode-stdio-1.0 main-is: Main.hs++ hs-source-dirs: test+ other-modules: Posix , Windows- , Common- , TH- hs-source-dirs: test+ , Common.Posix+ , Common.Windows+ , TH.Posix+ , TH.Windows+ build-depends: aeson- , base >= 4.12 && < 5+ , base , bytestring- , filepath < 1.2.0.1 || >= 1.3+ , exceptions+ , filepath , hspec >= 2.0 && < 3- , mtl >= 2.0 && < 3 , path , template-haskell- if flag(dev)- ghc-options: -Wall -Werror- else- ghc-options: -O2 -Wall- default-language: Haskell2010 +test-suite test-ospath+ import: language+ import: rts++ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: test-ospath++ other-modules: Posix+ , Windows+ , Common.Posix+ , Common.Windows+ , TH.Posix+ , TH.Windows++ build-depends: base+ , exceptions+ , filepath+ , hspec >= 2.0 && < 3+ , path+ , path:os-string-compat+ , template-haskell+ test-suite validity-test+ import: language+ import: rts+ type: exitcode-stdio-1.0- main-is: ValidityTest.hs+ main-is: Main.hs+ hs-source-dirs: validity-test+ other-modules: Path.Gen- hs-source-dirs: test+ build-depends: QuickCheck- , aeson- , base >= 4.12 && < 5- , bytestring- , filepath < 1.2.0.1 || >= 1.3- , genvalidity >= 0.8- , genvalidity-property >= 0.4+ , base+ , filepath+ , genvalidity >= 1.0 , genvalidity-hspec >= 0.7 , hspec >= 2.0 && < 3- , mtl >= 2.0 && < 3 , path- , validity >= 0.8.0.0- default-language: Haskell2010- ghc-options: -threaded -rtsopts -with-rtsopts=-N++test-suite validity-test-ospath+ import: language+ import: rts++ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: validity-test-ospath++ other-modules: OsPath.Gen.Posix+ , OsPath.Gen.Windows+ , Posix+ , Windows++ build-depends: QuickCheck+ , base+ , filepath+ , genvalidity >= 1.0+ , genvalidity-hspec >= 0.7+ , hspec >= 2.0 && < 3+ , path+ , path:os-string-compat+ , validity-bytestring >=0.4.1.0 source-repository head type: git
+ src/OsPath.hs view
@@ -0,0 +1,15 @@+-- | This library provides a well-typed representation of paths in a filesystem+-- directory tree.+--+-- Both "Path.Posix" and "Path.Windows" provide the same interface. This+-- module will reexport the appropriate module for your platform.++{-# LANGUAGE CPP #-}++#if defined(mingw32_HOST_OS)+module OsPath(module OsPath.Windows) where+import OsPath.Windows+#else+module OsPath(module OsPath.Posix) where+import OsPath.Posix+#endif
+ src/OsPath/Include.hs view
@@ -0,0 +1,819 @@+-- This template expects CPP definitions for:+-- PLATFORM_NAME = Posix | Windows++-- | 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 BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}++module OsPath.PLATFORM_NAME+ (-- * Types+ Path+ ,Abs+ ,Rel+ ,File+ ,Dir+ ,SomeBase(..)+ -- * 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+ ,replaceProperPrefix+ ,parent+ ,filename+ ,dirname+ ,addExtension+ ,splitExtension+ ,fileExtension+ ,replaceExtension+ ,splitDrive+ ,takeDrive+ ,dropDrive+ ,isDrive+ ,mapSomeBase+ ,prjSomeBase+ -- * Parsing+ ,parseAbsDir+ ,parseRelDir+ ,parseAbsFile+ ,parseRelFile+ ,parseSomeDir+ ,parseSomeFile+ -- * Conversion+ ,toOsPath+ ,fromAbsDir+ ,fromRelDir+ ,fromAbsFile+ ,fromRelFile+ ,fromSomeBase+ ,fromSomeDir+ ,fromSomeFile+ -- * TemplateHaskell constructors+ -- | These require the TemplateHaskell language extension.+ ,mkAbsDir+ ,mkRelDir+ ,mkAbsFile+ ,mkRelFile+ -- * Deprecated+ ,PathParseException+ ,stripDir+ ,isParentOf+ ,addFileExtension+ ,(<.>)+ ,setFileExtension+ ,(-<.>)+ )+ where++import Control.Applicative (Alternative(..))+import Control.DeepSeq (NFData (..))+import Control.Exception (Exception(..))+import Control.Monad (unless, when, (<=<))+import Control.Monad.Catch (MonadThrow(..))+import Data.Coerce (coerce)+import Data.Data (Data, Typeable)+import Data.Hashable (Hashable (..))+import Data.Maybe (isJust, isNothing)+import GHC.Generics (Generic)+import Language.Haskell.TH (Exp, Q)+import Language.Haskell.TH.Syntax (lift)+import Language.Haskell.TH.Quote (QuasiQuoter(..))+import System.OsPath.PLATFORM_NAME (PLATFORM_PATH)+import qualified System.OsPath.PLATFORM_NAME as OsPath++import OsPath.Internal.PLATFORM_NAME+import System.OsString.Compat.PLATFORM_NAME (PLATFORM_STRING)+import qualified System.OsString.Compat.PLATFORM_NAME as OsString++--------------------------------------------------------------------------------+-- Types++-- | An absolute path.+data Abs deriving (Typeable, Data)++-- | 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, Data)++-- | A file path.+data File deriving (Typeable, Data)++-- | A directory path.+data Dir deriving (Typeable, Data)++-- | Exceptions that can occur during path operations.+--+-- @since 0.6.0+data PathException+ = InvalidAbsDir PLATFORM_PATH+ | InvalidRelDir PLATFORM_PATH+ | InvalidAbsFile PLATFORM_PATH+ | InvalidRelFile PLATFORM_PATH+ | InvalidFile PLATFORM_PATH+ | InvalidDir PLATFORM_PATH+ | NotAProperPrefix PLATFORM_PATH PLATFORM_PATH+ | HasNoExtension PLATFORM_PATH+ | InvalidExtension PLATFORM_STRING+ deriving (Show,Eq,Typeable)++instance Exception PathException where+ displayException (InvalidExtension ext) = concat+ [ "Invalid extension "+ , show 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 :: (PLATFORM_PATH -> Q Exp) -> QuasiQuoter+qq quoteExp' =+ QuasiQuoter+ { quoteExp = quoteExp' <=< OsPath.encodeUtf+ , 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 <> [pstr|/|] <> y))@+--+-- @$(mkAbsDir x) \<\/> $(mkRelFile y) = $(mkAbsFile (x <> [pstr|/|] <> y))@+--+-- @$(mkRelDir x) \<\/> $(mkRelDir y) = $(mkRelDir (x <> [pstr|/|] <> y))@+--+-- @$(mkRelDir x) \<\/> $(mkRelFile y) = $(mkRelFile (x <> [pstr|/|] <> 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 OsString.stripPrefix p l of+ Nothing -> throwM (NotAProperPrefix p l)+ Just result+ | OsString.null result -> throwM (NotAProperPrefix p l)+ | otherwise -> return (Path result)++-- | 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)++-- | Change from one directory prefix to another.+--+-- Throw 'NotAProperPrefix' if the first argument is not a proper prefix of the+-- path.+--+-- >>> replaceProperPrefix $(mkRelDir "foo") $(mkRelDir "bar") $(mkRelFile "foo/file.txt") == $(mkRelFile "bar/file.txt")+replaceProperPrefix :: MonadThrow m => Path b Dir -> Path b' Dir -> Path b t -> m (Path b' t)+replaceProperPrefix src dst fp = (dst </>) <$> stripProperPrefix src fp++-- | Take the parent path component from a path.+--+-- The following properties hold:+--+-- @+-- parent (x \<\/> y) == x+-- parent [pstr|\/x|] == [pstr|\/|]+-- parent [pstr|x|] == [pstr|.|]+-- @+--+-- On the root (absolute or relative), getting the parent is idempotent:+--+-- @+-- parent [pstr|\/|] = [pstr|\/|]+-- parent [pstr|\.|] = [pstr|\.|]+-- @+--+parent :: Path b t -> Path b Dir+parent (Path fp)+ | OsString.null fp = Path OsString.empty+ | OsPath.isDrive fp = Path fp+ | otherwise =+ Path+ $ normalizeDir+ $ OsPath.takeDirectory+ $ OsPath.dropTrailingPathSeparator fp++-- | Split an absolute path into a drive and, perhaps, a path. On POSIX, @/@ is+-- a drive.+splitDrive :: Path Abs t -> (Path Abs Dir, Maybe (Path Rel t))+splitDrive (Path fp) =+ let (d, rest) = OsPath.splitDrive fp+ mRest = if OsString.null rest then Nothing else Just (Path rest)+ in (Path d, mRest)++-- | Get the drive from an absolute path. On POSIX, @/@ is a drive.+--+-- > takeDrive x = fst (splitDrive x)+takeDrive :: Path Abs t -> Path Abs Dir+takeDrive = fst . splitDrive++-- | Drop the drive from an absolute path. May result in 'Nothing' if the path+-- is just a drive.+--+-- > dropDrive x = snd (splitDrive x)+dropDrive :: Path Abs t -> Maybe (Path Rel t)+dropDrive = snd . splitDrive++-- | Is an absolute directory path a drive?+isDrive :: Path Abs Dir -> Bool+isDrive = isNothing . dropDrive++-- | 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 (OsPath.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 l)+ | OsString.null l = Path OsString.empty+ | OsPath.isDrive l = Path OsString.empty+ | otherwise = Path (last (OsPath.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" ), [pstr|.foo|] )+-- >>> splitExtension $(mkRelFile "name.foo." ) == Just ($(mkRelFile "name" ), [pstr|.foo.|] )+-- >>> splitExtension $(mkRelFile "name.foo.." ) == Just ($(mkRelFile "name" ), [pstr|.foo..|])+-- >>> splitExtension $(mkRelFile "name.bar.foo" ) == Just ($(mkRelFile "name.bar"), [pstr|.foo|] )+-- >>> splitExtension $(mkRelFile ".name.foo" ) == Just ($(mkRelFile ".name" ), [pstr|.foo|] )+-- >>> splitExtension $(mkRelFile "name..foo" ) == Just ($(mkRelFile "name." ), [pstr|.foo|] )+-- >>> splitExtension $(mkRelFile "....foo" ) == Just ($(mkRelFile "..." ), [pstr|.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, PLATFORM_STRING)+splitExtension (Path ospath) =+ if OsString.null nameDot+ || OsString.null name+ || OsString.null ext+ || name == [OsString.pstr|.|]+ || name == [OsString.pstr|..|]+ then throwM $ HasNoExtension ospath+ else return ( Path (normalizeDrive drv <> dir <> name)+ , OsString.singleton OsPath.extSeparator <> ext+ )+ where++ -- trailing separators are ignored for the split and considered part of the+ -- second component in the split.+ splitLast isSep str =+ let (withoutTrailingSeps, trailingSeps) = OsString.spanEnd isSep str+ (oneSep, rest) = OsString.breakEnd isSep withoutTrailingSeps+ in (oneSep, rest <> trailingSeps)++ (drv, ospathRel) = OsPath.splitDrive ospath+ (dir, file) = splitLast OsPath.isPathSeparator ospathRel+ (nameDot, ext) = splitLast OsPath.isExtSeparator file+ name = OsString.init nameDot++-- | 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 PLATFORM_STRING+fileExtension = fmap snd . splitExtension++-- | Add extension to given file path.+--+-- >>> addExtension [pstr|.foo|] $(mkRelFile "name" ) == Just $(mkRelFile "name.foo" )+-- >>> addExtension [pstr|.foo.|] $(mkRelFile "name" ) == Just $(mkRelFile "name.foo." )+-- >>> addExtension [pstr|.foo..|] $(mkRelFile "name" ) == Just $(mkRelFile "name.foo.." )+-- >>> addExtension [pstr|.foo|] $(mkRelFile "name.bar" ) == Just $(mkRelFile "name.bar.foo")+-- >>> addExtension [pstr|.foo|] $(mkRelFile ".name" ) == Just $(mkRelFile ".name.foo" )+-- >>> addExtension [pstr|.foo|] $(mkRelFile "name." ) == Just $(mkRelFile "name..foo" )+-- >>> addExtension [pstr|.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 [pstr|foo|] $(mkRelFile "name")+-- >>> addExtension [pstr|..foo|] $(mkRelFile "name")+-- >>> addExtension [pstr|.foo.bar|] $(mkRelFile "name")+-- >>> addExtension [pstr|.foo/bar|] $(mkRelFile "name")+--+-- @since 0.7.0+addExtension :: MonadThrow m+ => PLATFORM_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+ (sep, xtn) <- case OsString.uncons ext of+ Nothing -> throwM $ InvalidExtension ext+ Just result -> pure result++ let withoutTrailingSeps = OsString.dropWhileEnd OsPath.isExtSeparator xtn++ -- Has to start with a "."+ unless (OsPath.isExtSeparator sep) $+ throwM $ InvalidExtension ext++ -- Cannot have path separators+ when (OsString.any OsPath.isPathSeparator xtn) $+ throwM $ InvalidExtension ext++ -- All "."s is not a valid extension+ when (OsString.null withoutTrailingSeps) $+ throwM $ InvalidExtension ext++ -- Cannot have "."s except in trailing position+ when (OsString.any OsPath.isExtSeparator withoutTrailingSeps) $+ throwM $ InvalidExtension ext++ -- Must be valid as a filename+ _ <- parseRelFile ext++ return $ Path (path <> ext)++-- | 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+ => PLATFORM_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)++--------------------------------------------------------------------------------+-- Parsers++-- | Convert an absolute PLATFORM_PATH_SINGLE 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 'OsPath.isValid')+--+parseAbsDir :: MonadThrow m+ => PLATFORM_PATH -> m (Path Abs Dir)+parseAbsDir ospath+ | isValidAbsDir ospath = return (Path (normalizeDir ospath))+ | otherwise = throwM (InvalidAbsDir ospath)++-- | Convert a relative PLATFORM_PATH_SINGLE 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 'OsPath.isValid')+-- * is all path separators+--+parseRelDir :: MonadThrow m+ => PLATFORM_PATH -> m (Path Rel Dir)+parseRelDir ospath+ | isValidRelDir ospath = return (Path (normalizeDir ospath))+ | otherwise = throwM (InvalidRelDir ospath)++-- | Convert an absolute PLATFORM_PATH_SINGLE 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 'OsPath.isValid')+--+parseAbsFile :: MonadThrow m+ => PLATFORM_PATH -> m (Path Abs File)+parseAbsFile ospath+ | isValidAbsFile ospath+ , let normalized = normalizeFile ospath+ , isValidAbsFile normalized = return (Path normalized)+ | otherwise = throwM (InvalidAbsFile ospath)++-- | Convert a relative PLATFORM_PATH_SINGLE 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 'OsPath.isValid')+--+parseRelFile :: MonadThrow m+ => PLATFORM_PATH -> m (Path Rel File)+parseRelFile ospath+ | isValidRelFile ospath+ , let normalized = normalizeFile ospath+ , isValidRelFile normalized = return (Path normalized)+ | otherwise = throwM (InvalidRelFile ospath)++--------------------------------------------------------------------------------+-- Conversion++-- | Convert absolute path to directory to PLATFORM_PATH_SINGLE type.+fromAbsDir :: Path Abs Dir -> PLATFORM_PATH+fromAbsDir = toOsPath++-- | Convert relative path to directory to PLATFORM_PATH_SINGLE type.+fromRelDir :: Path Rel Dir -> PLATFORM_PATH+fromRelDir = toOsPath++-- | Convert absolute path to file to PLATFORM_PATH_SINGLE type.+fromAbsFile :: Path Abs File -> PLATFORM_PATH+fromAbsFile = toOsPath++-- | Convert relative path to file to PLATFORM_PATH_SINGLE type.+fromRelFile :: Path Rel File -> PLATFORM_PATH+fromRelFile = toOsPath++--------------------------------------------------------------------------------+-- 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 :: PLATFORM_PATH -> Q Exp+mkAbsDir = either (fail . displayException) lift . parseAbsDir++-- | Make a 'Path' 'Rel' 'Dir'.+mkRelDir :: PLATFORM_PATH -> Q Exp+mkRelDir = either (fail . displayException) 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 :: PLATFORM_PATH -> Q Exp+mkAbsFile = either (fail . displayException) lift . parseAbsFile++-- | Make a 'Path' 'Rel' 'File'.+mkRelFile :: PLATFORM_PATH -> Q Exp+mkRelFile = either (fail . displayException) lift . parseRelFile++--------------------------------------------------------------------------------+-- Path of some type.++-- | Path of some type. @t@ represents the type, whether file or+-- directory. Pattern match to find whether the path is absolute or relative.+data SomeBase t = Abs (Path Abs t)+ | Rel (Path Rel t)+ deriving (Typeable, Generic, Eq, Ord)++instance NFData (SomeBase t) where+ rnf (Abs p) = rnf p+ rnf (Rel p) = rnf p++instance Show (SomeBase t) where+ show = show . fromSomeBase++instance Hashable (SomeBase t) where+ -- See 'Hashable' 'Path' instance for details.+ hashWithSalt n path = hashWithSalt n (fromSomeBase path)++-- | Helper to project the contents out of a SomeBase object.+--+-- >>> prjSomeBase toOsPath (Abs [absfile|/foo/bar/cow.moo|]) == [pstr|/foo/bar/cow.moo|]+--+prjSomeBase :: (forall b . Path b t -> a) -> SomeBase t -> a+prjSomeBase f = \case+ Abs a -> f a+ Rel r -> f r++-- | Helper to apply a function to the SomeBase object+--+-- >>> mapSomeBase parent (Abs [absfile|/foo/bar/cow.moo|]) == Abs [absdir|/foo/bar|]+--+mapSomeBase :: (forall b . Path b t -> Path b t') -> SomeBase t -> SomeBase t'+mapSomeBase f = \case+ Abs a -> Abs $ f a+ Rel r -> Rel $ f r++-- | Convert a valid path to a PLATFORM_PATH_SINGLE.+fromSomeBase :: SomeBase t -> PLATFORM_PATH+fromSomeBase = prjSomeBase toOsPath++-- | Convert a valid directory to a PLATFORM_PATH_SINGLE.+fromSomeDir :: SomeBase Dir -> PLATFORM_PATH+fromSomeDir = fromSomeBase++-- | Convert a valid file to a PLATFORM_PATH_SINGLE.+fromSomeFile :: SomeBase File -> PLATFORM_PATH+fromSomeFile = fromSomeBase++-- | Convert an absolute or relative PLATFORM_PATH_SINGLE to a normalized 'SomeBase'+-- representing a directory.+--+-- Throws: 'InvalidDir' when the supplied path:+--+-- * contains a @..@ path component representing the parent directory+-- * is not a valid path (See 'OsPath.isValid')+parseSomeDir :: MonadThrow m => PLATFORM_PATH -> m (SomeBase Dir)+parseSomeDir fp = maybe (throwM (InvalidDir fp)) pure+ $ (Abs <$> parseAbsDir fp)+ <|> (Rel <$> parseRelDir fp)++-- | Convert an absolute or relative PLATFORM_PATH_SINGLE to a normalized 'SomeBase'+-- representing a file.+--+-- Throws: 'InvalidFile' when the supplied 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 'OsPath.isValid')+parseSomeFile :: MonadThrow m => PLATFORM_PATH -> m (SomeBase File)+parseSomeFile fp = maybe (throwM (InvalidFile fp)) pure+ $ (Abs <$> parseAbsFile fp)+ <|> (Rel <$> parseRelFile fp)++--------------------------------------------------------------------------------+-- Deprecated++-- | Add extension to given file path. Throws if the+-- resulting filename does not parse.+--+-- >>> addFileExtension [pstr|txt|] $(mkRelFile "foo")+-- "foo.txt"+-- >>> addFileExtension [pstr|symbols|] $(mkRelFile "Data.List")+-- "Data.List.symbols"+-- >>> addFileExtension [pstr|.symbols|] $(mkRelFile "Data.List")+-- "Data.List.symbols"+-- >>> addFileExtension [pstr|symbols|] $(mkRelFile "Data.List.")+-- "Data.List..symbols"+-- >>> addFileExtension [pstr|.symbols|] $(mkRelFile "Data.List.")+-- "Data.List..symbols"+-- >>> addFileExtension [pstr|evil/|] $(mkRelFile "Data.List")+-- *** Exception: InvalidRelFile "Data.List.evil/"+--+-- @since 0.6.1+{-# DEPRECATED addFileExtension "Please use addExtension instead." #-}+addFileExtension :: MonadThrow m+ => PLATFORM_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 OsPath.isAbsolute path+ then coerce <$> parseAbsFile (OsPath.addExtension path ext)+ else coerce <$> parseRelFile (OsPath.addExtension path ext)++-- | A synonym for 'addFileExtension' in the form of an infix operator.+-- See more examples there.+--+-- >>> $(mkRelFile "Data.List") <.> [pstr|symbols|]+-- "Data.List.symbols"+-- >>> $(mkRelFile "Data.List") <.> [pstr|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+ -> PLATFORM_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+{-# DEPRECATED setFileExtension "Please use replaceExtension instead." #-}+setFileExtension :: MonadThrow m+ => PLATFORM_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 OsPath.isAbsolute path+ then coerce <$> parseAbsFile (OsPath.replaceExtension path ext)+ else coerce <$> parseRelFile (OsPath.replaceExtension path ext)++-- | 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+ -> PLATFORM_STRING -- ^ Extension to set+ -> m (Path b File) -- ^ New file name with the desired extension+(-<.>) = flip setFileExtension+++{-# 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
+ src/OsPath/Internal.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE CPP #-}++#if defined(mingw32_HOST_OS)+module OsPath.Internal(module OsPath.Internal.Windows) where+import OsPath.Internal.Windows+#else+module OsPath.Internal(module OsPath.Internal.Posix) where+import OsPath.Internal.Posix+#endif
+ src/OsPath/Internal/Include.hs view
@@ -0,0 +1,297 @@+-- This template expects CPP definitions for:+-- PLATFORM_NAME = Posix | Windows+-- PLATFORM_PATH = PosixPath | WindowsPath+-- PLATFORM_PATH_SINGLE = 'PosixPath' | 'WindowsPath'+-- IS_WINDOWS = 0 | 1++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Internal types and functions.++module OsPath.Internal.PLATFORM_NAME+ ( -- * The Path type+ Path(..)+ , toOsPath++ -- * Validation functions+ , isValidAbsDir+ , isValidAbsFile+ , isValidRelDir+ , isValidRelFile+ , hasParentDir++ -- * Normalizing functions+ , normalizeLeadingSeps+ , normalizeTrailingSeps+ , normalizeAllSeps+#if IS_WINDOWS+ , normalizeWindowsSeps+#endif+ , normalizeDrive+ , normalizeDir+ , normalizeFile++ -- * Other helper functions+ , extSep+ , pathSep+ , relRoot+ , isWindows+ )+ where++import Control.DeepSeq (NFData (..))+import GHC.Generics (Generic)+import Data.Data+import Data.Hashable+import qualified Language.Haskell.TH.Syntax as TH+import System.OsPath.PLATFORM_NAME (PLATFORM_PATH)+import qualified System.OsPath.PLATFORM_NAME as OsPath++import System.OsString.Compat.PLATFORM_NAME (PLATFORM_STRING)+import qualified System.OsString.Compat.PLATFORM_NAME as OsString++-- | Path of some base and type.+--+-- The type variables are:+--+-- * @b@ — base, the base location of the path; absolute or relative.+-- * @t@ — type, whether file or directory.+--+-- Internally it is a PLATFORM_PATH_SINGLE, which can be of two formats only:+--+-- 1. File format: @file.txt@, @foo\/bar.txt@, @\/foo\/bar.txt@+-- 2. Directory format: @foo\/@, @\/foo\/bar\/@+--+-- All directories end in a trailing separator. There are no duplicate+-- path separators @\/\/@, no @..@, no @.\/@, no @~\/@, etc.+newtype Path b t = Path PLATFORM_PATH+ deriving (Data, Typeable, Generic)++-- | String equality.+--+-- The following property holds:+--+-- @show x == show y ≡ x == y@+instance Eq (Path b t) where+ (==) (Path x) (Path y) = x == y+ {-# INLINE (==) #-}++-- | String ordering.+--+-- The following property holds:+--+-- @show x \`compare\` show y ≡ x \`compare\` y@+instance Ord (Path b t) where+ compare (Path x) (Path y) = compare x y+ {-# INLINE compare #-}++-- | Same as 'show . OsPath.toOsPath'.+--+-- The following property holds:+--+-- @x == y ≡ show x == show y@+instance Show (Path b t) where+ show = show . toOsPath+ {-# INLINE show #-}++instance NFData (Path b t) where+ rnf (Path x) = rnf x+ {-# INLINE rnf #-}++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+ -- reasonable hash we use "toFilePath" before hashing so that a "" gets+ -- converted back to a ".".+ hashWithSalt n path = hashWithSalt n (toOsPath path)+ {-# INLINE hashWithSalt #-}++instance forall b t. (Typeable b, Typeable t) => TH.Lift (Path b t) where+ lift (Path str) = do+ let b = TH.ConT $ getTCName (Proxy :: Proxy b)+ t = TH.ConT $ getTCName (Proxy :: Proxy t)+ [| Path $(TH.lift str) :: Path $(pure b) $(pure t) |]+ where+ getTCName :: Typeable a => proxy a -> TH.Name+ getTCName a = TH.Name occ flav+ where+ tc = typeRepTyCon (typeRep a)+ occ = TH.OccName (tyConName tc)+ flav = TH.NameG TH.TcClsName (TH.PkgName (tyConPackage tc)) (TH.ModName (tyConModule tc))++#if MIN_VERSION_template_haskell(2,17,0)+ liftTyped = TH.unsafeCodeCoerce . TH.lift+#elif MIN_VERSION_template_haskell(2,16,0)+ liftTyped = TH.unsafeTExpCoerce . TH.lift+#endif++-- | Convert to a PLATFORM_PATH type.+--+-- All directories have a trailing slash, so if you want no trailing+-- slash, you can use 'OsPath.dropTrailingPathSeparator' from+-- the filepath package.+toOsPath :: Path b t -> PLATFORM_PATH+toOsPath (Path ospath)+ | OsString.null ospath = relRoot+ | otherwise = ospath++--------------------------------------------------------------------------------+-- Validation functions++-- | Is the PLATFORM_PATH_SINGLE a valid absolute dir?+isValidAbsDir :: PLATFORM_PATH -> Bool+isValidAbsDir ospath =+ OsPath.isAbsolute ospath &&+ not (hasParentDir ospath) &&+ OsPath.isValid ospath++-- | Is the PLATFORM_PATH_SINGLE a valid absolute file?+isValidAbsFile :: PLATFORM_PATH -> Bool+isValidAbsFile ospath =+ OsPath.isAbsolute ospath &&+ not (OsPath.hasTrailingPathSeparator ospath) &&+ not (hasParentDir ospath) &&+ OsPath.isValid ospath++-- | Is the PLATFORM_PATH_SINGLE a valid relative dir?+isValidRelDir :: PLATFORM_PATH -> Bool+isValidRelDir ospath =+ not (OsPath.isAbsolute ospath) &&+ not (OsString.null ospath) &&+ not (hasParentDir ospath) &&+ not (OsString.all OsPath.isPathSeparator ospath) &&+ OsPath.isValid ospath++-- | Is the PLATFORM_PATH_SINGLE a valid relative file?+isValidRelFile :: PLATFORM_PATH -> Bool+isValidRelFile ospath =+ not (OsPath.isAbsolute ospath) &&+ not (OsString.null ospath) &&+ not (hasParentDir ospath) &&+ not (OsPath.hasTrailingPathSeparator ospath) &&+ ospath /= [OsPath.pstr|.|] &&+ OsPath.isValid ospath++-- | Helper function: check if the filepath has any parent directories in it.+-- This handles the logic of checking for different path separators on Windows.+hasParentDir :: PLATFORM_PATH -> Bool+hasParentDir ospath =+ (ospath' == [OsString.pstr|..|]) ||+ (prefix' `OsString.isPrefixOf` ospath') ||+ (infix' `OsString.isInfixOf` ospath') ||+ (suffix' `OsString.isSuffixOf` ospath')+ where+ prefix' = [OsString.pstr|..|] <> pathSep+ infix' = pathSep <> [OsString.pstr|..|] <> pathSep+ suffix' = pathSep <> [OsString.pstr|..|]++#if IS_WINDOWS+ ospath' = OsString.map normSep ospath+ normSep c+ | OsPath.isPathSeparator c = OsPath.pathSeparator+ | otherwise = c+#else+ ospath' = ospath+#endif++--------------------------------------------------------------------------------+-- Normalizing functions++-- | Normalizes seps only at the beginning of a path.+normalizeLeadingSeps :: PLATFORM_PATH -> PLATFORM_PATH+normalizeLeadingSeps path = normLeadingSep <> rest+ where (leadingSeps, rest) = OsString.span OsPath.isPathSeparator path+ normLeadingSep+ | OsString.null leadingSeps = OsString.empty+ | otherwise = OsString.singleton OsPath.pathSeparator++-- | Normalizes seps only at the end of a path.+normalizeTrailingSeps :: PLATFORM_PATH -> PLATFORM_PATH+normalizeTrailingSeps path = rest <> normTrailingSep+ where (rest, trailingSeps) = OsString.spanEnd OsPath.isPathSeparator path+ normTrailingSep+ | OsString.null trailingSeps = OsString.empty+ | otherwise = OsString.singleton OsPath.pathSeparator++-- | Replaces consecutive path seps with single sep and replaces alt sep with+-- standard sep.+normalizeAllSeps :: PLATFORM_PATH -> PLATFORM_PATH+normalizeAllSeps = go OsString.empty+ where go !acc ospath+ | OsString.null ospath = acc+ | otherwise =+ let (leadingSeps, withoutLeadingSeps) =+ OsString.span OsPath.isPathSeparator ospath+ (name, rest) =+ OsString.break OsPath.isPathSeparator withoutLeadingSeps+ sep = if OsString.null leadingSeps+ then OsString.empty+ else OsString.singleton OsPath.pathSeparator+ in go (acc <> sep <> name) rest++#if IS_WINDOWS+-- | 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 :: PLATFORM_PATH -> PLATFORM_PATH+normalizeWindowsSeps path = normLeadingSeps <> normalizeAllSeps rest+ where (leadingSeps, rest) = OsString.span OsPath.isPathSeparator path+ normLeadingSeps = OsString.replicate+ (min 2 (OsString.length leadingSeps))+ OsPath.pathSeparator+#endif++-- | Normalizes the drive of a PLATFORM_PATH_SINGLE.+normalizeDrive :: PLATFORM_PATH -> PLATFORM_PATH+#if IS_WINDOWS+normalizeDrive = normalizeTrailingSeps+#else+normalizeDrive = id+#endif++-- | Normalizes directory path with platform-specific rules.+normalizeDir :: PLATFORM_PATH -> PLATFORM_PATH+normalizeDir =+ normalizeRelDir+ . OsPath.addTrailingPathSeparator+ . normalizeFile+ where -- Represent a "." in relative dir path as "" internally so that it+ -- composes without having to renormalize the path.+ normalizeRelDir p+ | p == relRoot = OsString.empty+ | otherwise = p++-- | Applies platform-specific sep normalization following @OsPath.normalise@.+normalizeFile :: PLATFORM_PATH -> PLATFORM_PATH+#if IS_WINDOWS+normalizeFile = normalizeWindowsSeps . OsPath.normalise+#else+normalizeFile = normalizeLeadingSeps . OsPath.normalise+#endif++--------------------------------------------------------------------------------+-- Other helper functions++extSep :: PLATFORM_STRING+extSep = $(TH.lift (OsString.singleton OsPath.extSeparator))++pathSep :: PLATFORM_STRING+pathSep = $(TH.lift (OsString.singleton OsPath.pathSeparator))++-- | Normalized file path representation for the relative path root+relRoot :: PLATFORM_PATH+relRoot =+ $(TH.lift ([OsPath.pstr|.|] <> OsString.singleton OsPath.pathSeparator))++isWindows :: Bool+#if IS_WINDOWS+isWindows = True+#else+isWindows = False+#endif+{-# INLINE isWindows #-}
+ src/OsPath/Internal/Posix.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE CPP #-}+#define PLATFORM_NAME Posix+#define PLATFORM_PATH PosixPath+#define PLATFORM_PATH_SINGLE 'PosixPath'+#define PLATFORM_STRING PosixString+#define IS_WINDOWS 0+#include "Include.hs"
+ src/OsPath/Internal/Windows.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE CPP #-}+#define PLATFORM_NAME Windows+#define PLATFORM_PATH WindowsPath+#define PLATFORM_PATH_SINGLE 'WindowsPath'+#define PLATFORM_STRING WindowsString+#define IS_WINDOWS 1+#include "Include.hs"
+ src/OsPath/Posix.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE CPP #-}+#define PLATFORM_NAME Posix+#define PLATFORM_PATH PosixPath+#define PLATFORM_PATH_SINGLE 'PosixPath'+#define PLATFORM_STRING PosixString+#define PLATFORM_UTF_CODEC UTF8+#define IS_WINDOWS 0+#include "Include.hs"
+ src/OsPath/Windows.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE CPP #-}+#define PLATFORM_NAME Windows+#define PLATFORM_PATH WindowsPath+#define PLATFORM_PATH_SINGLE 'WindowsPath'+#define PLATFORM_STRING WindowsString+#define PLATFORM_UTF_CODEC UTF16-LE+#define IS_WINDOWS 1+#include "Include.hs"
src/Path/Include.hs view
@@ -1,6 +1,5 @@ -- 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.@@ -18,12 +17,14 @@ -- 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 DeriveGeneric #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-} module Path.PLATFORM_NAME (-- * Types@@ -53,6 +54,7 @@ ,(</>) ,stripProperPrefix ,isProperPrefixOf+ ,replaceProperPrefix ,parent ,filename ,dirname@@ -60,6 +62,12 @@ ,splitExtension ,fileExtension ,replaceExtension+ ,splitDrive+ ,takeDrive+ ,dropDrive+ ,isDrive+ ,mapSomeBase+ ,prjSomeBase -- * Parsing ,parseAbsDir ,parseRelDir@@ -108,24 +116,24 @@ import Language.Haskell.TH import Language.Haskell.TH.Syntax (lift) import Language.Haskell.TH.Quote (QuasiQuoter(..))-import Path.Internal+import Path.Internal.PLATFORM_NAME import qualified System.FilePath.PLATFORM_NAME as FilePath -------------------------------------------------------------------------------- -- Types -- | An absolute path.-data Abs deriving (Typeable)+data Abs deriving (Typeable, Data) -- | 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)+data Rel deriving (Typeable, Data) -- | A file path.-data File deriving (Typeable)+data File deriving (Typeable, Data) -- | A directory path.-data Dir deriving (Typeable)+data Dir deriving (Typeable, Data) instance FromJSON (Path Abs File) where parseJSON = parseJSONWith parseAbsFile@@ -337,6 +345,15 @@ isProperPrefixOf :: Path b Dir -> Path b t -> Bool isProperPrefixOf p l = isJust (stripProperPrefix p l) +-- | Change from one directory prefix to another.+--+-- Throw 'NotAProperPrefix' if the first argument is not a proper prefix of the+-- path.+--+-- >>> replaceProperPrefix $(mkRelDir "foo") $(mkRelDir "bar") $(mkRelFile "foo/file.txt") == $(mkRelFile "bar/file.txt")+replaceProperPrefix :: MonadThrow m => Path b Dir -> Path b' Dir -> Path b t -> m (Path b' t)+replaceProperPrefix src dst fp = (dst </>) <$> stripProperPrefix src fp+ -- | Take the parent path component from a path. -- -- The following properties hold:@@ -363,6 +380,31 @@ $ FilePath.takeDirectory $ FilePath.dropTrailingPathSeparator fp +-- | Split an absolute path into a drive and, perhaps, a path. On POSIX, @/@ is+-- a drive.+splitDrive :: Path Abs t -> (Path Abs Dir, Maybe (Path Rel t))+splitDrive (Path fp) =+ let (d, rest) = FilePath.splitDrive fp+ mRest = if null rest then Nothing else Just (Path rest)+ in (Path d, mRest)++-- | Get the drive from an absolute path. On POSIX, @/@ is a drive.+--+-- > takeDrive x = fst (splitDrive x)+takeDrive :: Path Abs t -> Path Abs Dir+takeDrive = fst . splitDrive++-- | Drop the drive from an absolute path. May result in 'Nothing' if the path+-- is just a drive.+--+-- > dropDrive x = snd (splitDrive x)+dropDrive :: Path Abs t -> Maybe (Path Rel t)+dropDrive = snd . splitDrive++-- | Is an absolute directory path a drive?+isDrive :: Path Abs Dir -> Bool+isDrive = isNothing . dropDrive+ -- | Extract the file part of a path. -- -- The following properties hold:@@ -440,8 +482,8 @@ xtn = (takeWhile notSep . dropWhile isSep) rstr in (reverse name, reverse xtn ++ trailingSeps) normalizeDrive- | IS_WINDOWS = normalizeTrailingSeps- | otherwise = id+ | isWindows = normalizeTrailingSeps+ | otherwise = id (drv, pth) = FilePath.splitDrive fpath (dir, file) = splitLast FilePath.isPathSeparator pth@@ -775,6 +817,16 @@ | p == relRootFP = "" | otherwise = p +-- | 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+ -- | Replaces consecutive path seps with single sep and replaces alt sep with standard sep. normalizeAllSeps :: FilePath -> FilePath normalizeAllSeps = foldr normSeps []@@ -791,21 +843,11 @@ 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+ | isWindows = normalizeWindowsSeps . FilePath.normalise+ | otherwise = normalizeLeadingSeps . FilePath.normalise -- | Path of some type. @t@ represents the type, whether file or -- directory. Pattern match to find whether the path is absolute or@@ -841,10 +883,27 @@ parseJSON = parseJSONWith parseSomeFile {-# INLINE parseJSON #-} +-- | Helper to project the contents out of a SomeBase object.+--+-- >>> prjSomeBase toFilePath (Abs [absfile|/foo/bar/cow.moo|]) == "/foo/bar/cow.moo"+--+prjSomeBase :: (forall b . Path b t -> a) -> SomeBase t -> a+prjSomeBase f = \case+ Abs a -> f a+ Rel r -> f r++-- | Helper to apply a function to the SomeBase object+--+-- >>> mapSomeBase parent (Abs [absfile|/foo/bar/cow.moo|]) == Abs [absdir|"/foo/bar"|]+--+mapSomeBase :: (forall b . Path b t -> Path b t') -> SomeBase t -> SomeBase t'+mapSomeBase f = \case+ Abs a -> Abs $ f a+ Rel r -> Rel $ f r+ -- | Convert a valid path to a 'FilePath'. fromSomeBase :: SomeBase t -> FilePath-fromSomeBase (Abs p) = toFilePath p-fromSomeBase (Rel p) = toFilePath p+fromSomeBase = prjSomeBase toFilePath -- | Convert a valid directory to a 'FilePath'. fromSomeDir :: SomeBase Dir -> FilePath
src/Path/Internal.hs view
@@ -1,138 +1,9 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE TemplateHaskell #-}---- | Internal types and functions.--module Path.Internal- ( Path(..)- , hasParentDir- , relRootFP- , toFilePath- )- where--import Control.DeepSeq (NFData (..))-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 qualified Data.List as L-import qualified Language.Haskell.TH.Syntax as TH-import qualified System.FilePath as FilePath---- | Path of some base and type.------ The type variables are:------ * @b@ — base, the base location of the path; absolute or relative.--- * @t@ — type, whether file or directory.------ Internally is a string. The string can be of two formats only:------ 1. File format: @file.txt@, @foo\/bar.txt@, @\/foo\/bar.txt@--- 2. Directory format: @foo\/@, @\/foo\/bar\/@------ All directories end in a trailing separator. There are no duplicate--- path separators @\/\/@, no @..@, no @.\/@, no @~\/@, etc.-newtype Path b t = Path FilePath- deriving (Data, Typeable, Generic)---- | String equality.------ The following property holds:------ @show x == show y ≡ x == y@-instance Eq (Path b t) where- (==) (Path x) (Path y) = x == y---- | String ordering.------ The following property holds:------ @show x \`compare\` show y ≡ x \`compare\` y@-instance Ord (Path b t) where- compare (Path x) (Path y) = compare x y---- | Normalized file path representation for the relative path root-relRootFP :: FilePath-relRootFP = '.' : [FilePath.pathSeparator]---- | Convert to a 'FilePath' type.------ All directories have a trailing slash, so if you want no trailing--- slash, you can use 'System.FilePath.dropTrailingPathSeparator' from--- the filepath package.-toFilePath :: Path b t -> FilePath-toFilePath (Path []) = relRootFP-toFilePath (Path x) = x---- | Same as 'show . Path.toFilePath'.------ The following property holds:------ @x == y ≡ show x == show y@-instance Show (Path b t) where- show = show . toFilePath--instance NFData (Path b t) where- rnf (Path x) = rnf x--instance ToJSON (Path b t) where- toJSON = toJSON . toFilePath- {-# INLINE toJSON #-}-#if MIN_VERSION_aeson(0,10,0)- toEncoding = toEncoding . toFilePath- {-# 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- -- reasonable hash we use "toFilePath" before hashing so that a "" gets- -- converted back to a ".".- hashWithSalt n path = hashWithSalt n (toFilePath path)---- | Helper function: check if the filepath has any parent directories in it.--- This handles the logic of checking for different path separators on Windows.-hasParentDir :: FilePath -> Bool-hasParentDir filepath' =- (filepath' == "..") ||- ("/.." `L.isSuffixOf` filepath) ||- ("/../" `L.isInfixOf` filepath) ||- ("../" `L.isPrefixOf` filepath)- where- filepath =- case FilePath.pathSeparator of- '/' -> filepath'- x -> map (\y -> if x == y then '/' else y) filepath'--instance (Typeable a, Typeable b) => TH.Lift (Path a b) where- lift p@(Path str) = do- let btc = typeRepTyCon $ typeRep $ mkBaseProxy p- ttc = typeRepTyCon $ typeRep $ mkTypeProxy p- bn <- lookupTypeNameThrow $ tyConName btc- tn <- lookupTypeNameThrow $ tyConName ttc- [|Path $(return (TH.LitE (TH.StringL str))) :: Path- $(return $ TH.ConT bn)- $(return $ TH.ConT tn)- |]- where- mkBaseProxy :: Path a b -> Proxy a- mkBaseProxy _ = Proxy-- mkTypeProxy :: Path a b -> Proxy b- mkTypeProxy _ = Proxy-- lookupTypeNameThrow n = TH.lookupTypeName n- >>= maybe (fail $ "Not in scope: type constructor ‘" ++ n ++ "’") return+{-# LANGUAGE CPP #-} -#if MIN_VERSION_template_haskell(2,16,0)- liftTyped = TH.unsafeTExpCoerce . TH.lift+#if defined(mingw32_HOST_OS)+module Path.Internal(module Path.Internal.Windows) where+import Path.Internal.Windows+#else+module Path.Internal(module Path.Internal.Posix) where+import Path.Internal.Posix #endif
+ src/Path/Internal/Include.hs view
@@ -0,0 +1,147 @@+-- This template expects CPP definitions for:+-- PLATFORM_NAME = Posix | Windows+-- IS_WINDOWS = 0 | 1++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Internal types and functions.++module Path.Internal.PLATFORM_NAME+ ( Path(..)+ , relRootFP+ , toFilePath+ , hasParentDir+ , isWindows+ )+ where++import Control.DeepSeq (NFData (..))+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 qualified Data.List as L+import qualified Language.Haskell.TH.Syntax as TH+import qualified System.FilePath.PLATFORM_NAME as FilePath++-- | Path of some base and type.+--+-- The type variables are:+--+-- * @b@ — base, the base location of the path; absolute or relative.+-- * @t@ — type, whether file or directory.+--+-- Internally is a string. The string can be of two formats only:+--+-- 1. File format: @file.txt@, @foo\/bar.txt@, @\/foo\/bar.txt@+-- 2. Directory format: @foo\/@, @\/foo\/bar\/@+--+-- All directories end in a trailing separator. There are no duplicate+-- path separators @\/\/@, no @..@, no @.\/@, no @~\/@, etc.+newtype Path b t = Path FilePath+ deriving (Data, Typeable, Generic)++-- | String equality.+--+-- The following property holds:+--+-- @show x == show y ≡ x == y@+instance Eq (Path b t) where+ (==) (Path x) (Path y) = x == y++-- | String ordering.+--+-- The following property holds:+--+-- @show x \`compare\` show y ≡ x \`compare\` y@+instance Ord (Path b t) where+ compare (Path x) (Path y) = compare x y++-- | Normalized file path representation for the relative path root+relRootFP :: FilePath+relRootFP = '.' : [FilePath.pathSeparator]++-- | Convert to a 'FilePath' type.+--+-- All directories have a trailing slash, so if you want no trailing+-- slash, you can use 'System.FilePath.dropTrailingPathSeparator' from+-- the filepath package.+toFilePath :: Path b t -> FilePath+toFilePath (Path []) = relRootFP+toFilePath (Path x) = x++-- | Helper function: check if the filepath has any parent directories in it.+-- This handles the logic of checking for different path separators on Windows.+hasParentDir :: FilePath -> Bool+hasParentDir filepath' =+ (filepath' == "..") ||+ ("/.." `L.isSuffixOf` filepath) ||+ ("/../" `L.isInfixOf` filepath) ||+ ("../" `L.isPrefixOf` filepath)+ where+ filepath =+ case FilePath.pathSeparator of+ '/' -> filepath'+ x -> map (\y -> if x == y then '/' else y) filepath'++-- | Same as 'show . Path.toFilePath'.+--+-- The following property holds:+--+-- @x == y ≡ show x == show y@+instance Show (Path b t) where+ show = show . toFilePath++instance NFData (Path b t) where+ rnf (Path x) = rnf x++instance ToJSON (Path b t) where+ toJSON = toJSON . toFilePath+ {-# INLINE toJSON #-}+#if MIN_VERSION_aeson(0,10,0)+ toEncoding = toEncoding . toFilePath+ {-# 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+ -- reasonable hash we use "toFilePath" before hashing so that a "" gets+ -- converted back to a ".".+ hashWithSalt n path = hashWithSalt n (toFilePath path)++instance forall b t. (Typeable b, Typeable t) => TH.Lift (Path b t) where+ lift (Path str) = do+ let b = TH.ConT $ getTCName (Proxy :: Proxy b)+ t = TH.ConT $ getTCName (Proxy :: Proxy t)+ [|Path $(pure (TH.LitE (TH.StringL str))) :: Path $(pure b) $(pure t) |]+ where+ getTCName :: Typeable a => proxy a -> TH.Name+ getTCName a = TH.Name occ flav+ where+ tc = typeRepTyCon (typeRep a)+ occ = TH.OccName (tyConName tc)+ flav = TH.NameG TH.TcClsName (TH.PkgName (tyConPackage tc)) (TH.ModName (tyConModule tc))++#if MIN_VERSION_template_haskell(2,17,0)+ liftTyped = TH.unsafeCodeCoerce . TH.lift+#elif MIN_VERSION_template_haskell(2,16,0)+ liftTyped = TH.unsafeTExpCoerce . TH.lift+#endif++isWindows :: Bool+#if IS_WINDOWS+isWindows = True+#else+isWindows = False+#endif+{-# INLINE isWindows #-}
+ src/Path/Internal/Posix.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE CPP #-}+#define PLATFORM_NAME Posix+#define IS_WINDOWS 0+#include "Include.hs"
+ src/Path/Internal/Windows.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE CPP #-}+#define PLATFORM_NAME Windows+#define IS_WINDOWS 1+#include "Include.hs"
src/Path/Posix.hs view
@@ -1,4 +1,3 @@ {-# LANGUAGE CPP #-} #define PLATFORM_NAME Posix-#define IS_WINDOWS False #include "Include.hs"
src/Path/Windows.hs view
@@ -1,4 +1,3 @@ {-# LANGUAGE CPP #-} #define PLATFORM_NAME Windows-#define IS_WINDOWS True #include "Include.hs"
+ test-ospath/Common/Include.hs view
@@ -0,0 +1,344 @@+-- This template expects CPP definitions for:+-- PLATFORM_NAME = Posix | Windows+-- PLATFORM_PATH = PosixPath | WindowsPath+-- PLATFORM_STRING = PosixString | WindowsString++{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Test functions that are common to Posix and Windows+module Common.PLATFORM_NAME+ (spec+ ,parseFails+ ,parseSucceeds+ ,parserTest+ ) where++import Control.Applicative ((<|>))+import Control.Monad (forM_, void)+import Control.Monad.Catch (MonadThrow)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Maybe (fromJust, isNothing)+import System.OsPath.PLATFORM_NAME (PLATFORM_PATH)+import qualified System.OsPath.PLATFORM_NAME as OsPath+import Test.Hspec++import OsPath.PLATFORM_NAME+import OsPath.Internal.PLATFORM_NAME+import System.OsString.Compat.PLATFORM_NAME (PLATFORM_STRING)+import qualified System.OsString.Compat.PLATFORM_NAME as OsString++currentDir :: Path Rel Dir+currentDir = (fromJust . parseRelDir) [OsString.pstr|.|]++drives :: NonEmpty (Path Abs Dir)+drives = (fromJust . traverse parseAbsDir) drives_++relDir :: Path Rel Dir+relDir = (fromJust . parseRelDir) [OsString.pstr|directory|]++relFile :: Path Rel File+relFile = (fromJust . parseRelFile) [OsString.pstr|file|]++spec :: Spec+spec = do+ describe "Operations: (</>)" operationAppend+ describe "Operations: dirname" operationDirname+ describe "Operations: filename" operationFilename+ describe "Operations: parent" operationParent+ describe "Operations: toOsPath" operationToOsPath+ describe "Operations: isProperPrefixOf" operationIsProperPrefixOf+ describe "Operations: stripProperPrefix" operationStripProperPrefix+ describe "Operations: isDrive" operationIsDrive+ describe "Operations: splitDrive" operationSplitDrive+ describe "Operations: extensions" extensionOperations++-- | The 'dirname' operation.+operationDirname :: Spec+operationDirname = do+ it+ "dirname (relDir </> relDir) == dirname relDir"+ (dirname (relDir </> relDir) == dirname relDir)+ it+ "dirname \".\" == dirname \".\""+ (dirname currentDir == currentDir)++ forDrives $ \drive -> do+ let absDir = drive </> relDir+ it+ "dirname (absDir </> relDir) == dirname relDir"+ (dirname (absDir </> relDir) == dirname relDir)+ it+ "dirname of a drive must be a Rel path"+ (isNothing (parseAbsDir . toOsPath . dirname $ drive))++-- | The 'filename' operation.+operationFilename :: Spec+operationFilename = do+ it+ "filename (relDir </> relFile) == filename relFile"+ (filename (relDir </> relFile) == filename relFile)++ forDrives $ \drive -> do+ let absDir = drive </> relDir+ it+ "filename (absDir </> relFile) == filename relFile"+ (filename (absDir </> relFile) == filename relFile)++-- | The 'parent' operation.+operationParent :: Spec+operationParent = do+ it+ "parent relDir == \".\""+ (parent relDir == currentDir)+ it+ "parent \".\" == \".\""+ (parent currentDir == currentDir)++ forDrives $ \drive -> do+ let absDir = drive </> relDir+ it+ "parent (absDir </> relDir) == absDir"+ (parent (absDir </> relDir) == absDir)+ it+ "parent \"/name\" == drive"+ (parent absDir == drive)+ it+ "parent drive == drive"+ (parent drive == drive)++-- | The 'splitDrive' operation.+operationSplitDrive :: Spec+operationSplitDrive = forDrives $ \drive -> do+ let absDir = drive </> relDir+ absFile = drive </> relFile+ it+ "splitDrive absDir == (drive, Just relDir)"+ (splitDrive absDir == (drive, Just relDir))+ it+ "splitDrive absFile == (drive, Just relFile)"+ (splitDrive absFile == (drive, Just relFile))+ it+ "splitDrive drive == (drive, Nothing)"+ (splitDrive drive == (drive, Nothing))++-- | The 'isDrive' operation.+operationIsDrive :: Spec+operationIsDrive = forDrives $ \drive -> do+ let absDir = drive </> relDir+ it+ "isDrive drive"+ (isDrive drive)+ it+ "not (isDrive absDir)"+ (not (isDrive absDir))++-- | The 'isProperPrefixOf' operation.+operationIsProperPrefixOf :: Spec+operationIsProperPrefixOf = do+ it+ "isProperPrefixOf relDir (relDir </> relDir)"+ (isProperPrefixOf relDir (relDir </> relDir))++ it+ "not (relDir `isProperPrefixOf` relDir)"+ (not (isProperPrefixOf relDir relDir))++ forDrives $ \drive -> do+ let absDir = drive </> relDir+ it+ "isProperPrefixOf absDir (absDir </> relDir)"+ (isProperPrefixOf absDir (absDir </> relDir))++ it+ "not (drive `isProperPrefixOf` drive)"+ (not (isProperPrefixOf drive drive))++-- | The 'stripProperPrefix' operation.+operationStripProperPrefix :: Spec+operationStripProperPrefix = do+ it+ "stripProperPrefix relDir (relDir </> relDir) == Just relDir"+ (stripProperPrefix relDir (relDir </> relDir) == Just relDir)++ forDrives $ \drive -> do+ let absDir = drive </> relDir+ it+ "stripProperPrefix absDir (absDir </> relDir) == Just relDir"+ (stripProperPrefix absDir (absDir </> relDir) == Just relDir)+ it+ "stripProperPrefix absDir absDir == Nothing"+ (isNothing (stripProperPrefix absDir absDir))++-- | The '</>' operation.+operationAppend :: Spec+operationAppend = do+ let Path relDir' = relDir+ Path relFile' = relFile+ it+ "RelDir + RelDir == RelDir"+ (relDir </> relDir == Path (relDir' OsPath.</> relDir'))+ it+ "\".\" + \".\" == \".\""+ (currentDir </> currentDir == currentDir)+ it+ "\".\" + relDir == relDir"+ (currentDir </> relDir == relDir)+ it+ "relDir + \".\" == x"+ (relDir </> currentDir == relDir)+ it+ "RelDir + RelFile == RelFile"+ (relDir </> relFile == Path (relDir' OsPath.</> relFile'))++ forDrives $ \drive -> do+ let absDir@(Path absDir') = drive </> relDir+ it+ "AbsDir + RelDir == AbsDir"+ (absDir </> relDir == Path (absDir' OsPath.</> relDir'))+ it+ "AbsDir + RelFile == AbsFile"+ (absDir </> relFile == Path (absDir' OsPath.</> relFile'))++-- | The 'toOsPath' operation.+operationToOsPath :: Spec+operationToOsPath = do+ let expected = relRoot+ it+ ("toOsPath \".\" == " ++ show expected)+ (toOsPath currentDir == expected)+ it+ ("show \".\" == " ++ (show . show) expected)+ (show currentDir == show expected)++-- | Testing operations related to extensions.+extensionOperations :: Spec+extensionOperations = do+ describe "Only filenames and extensions" $+ forM_ filenames $ \file -> do+ forM_ validExtensions $ \ext -> do+ runTests parseRelFile file ext++ describe "Relative dir paths" $+ forM_ dirnames $ \dir -> do+ forM_ filenames $ \file -> do+ forM_ validExtensions $ \ext -> do+ let ospath =+ dir <> OsString.singleton OsPath.pathSeparator <> file+ runTests parseRelFile ospath ext++ describe "Absolute dir paths" $+ forM_ drives_ $ \drive -> do+ forM_ dirnames $ \dir -> do+ forM_ filenames $ \file -> do+ forM_ validExtensions $ \ext -> do+ let ospath = drive <> dir <> pathSep <> file+ runTests parseAbsFile ospath ext++ -- Invalid extensions+ forM_ invalidExtensions $ \ext -> do+ it ("throws InvalidExtension when extension is " ++ show ext) $+ addExtension ext (Path [OsString.pstr|name|])+ `shouldThrow` (== InvalidExtension ext)++ where++ runTests :: (forall m . MonadThrow m => PLATFORM_PATH -> m (Path b File))+ -> PLATFORM_PATH+ -> PLATFORM_STRING+ -> Spec+ runTests parse file ext = do+ let maybePathFile = parse file+ let maybePathFileWithExt = parse (file <> ext)+ case (maybePathFile, maybePathFileWithExt) of+ (Just pathFile, Just pathFileWithExt) -> validExtensionsSpec ext pathFile pathFileWithExt+ _ -> it ("Files " ++ show file ++ " and/or " ++ show (file <> ext) ++ " should parse successfully.") $+ expectationFailure $+ show file ++ " parsed to " ++ show maybePathFile ++ ", "+ ++ show (file <> ext) ++ " parsed to " ++ show maybePathFileWithExt++ filenames :: [PLATFORM_PATH]+ filenames =+ [ [OsString.pstr|name|]+ , [OsString.pstr|name.|]+ , [OsString.pstr|name..|]+ , [OsString.pstr|.name|]+ , [OsString.pstr|..name|]+ , [OsString.pstr|name.name|]+ , [OsString.pstr|name..name|]+ , [OsString.pstr|...|]+ ]++ dirnames :: [PLATFORM_PATH]+ dirnames = filenames ++ [ [OsString.pstr|.|] ]++ invalidExtensions :: [PLATFORM_STRING]+ invalidExtensions =+ [ [OsString.pstr||]+ , [OsString.pstr|.|]+ , [OsString.pstr|x|]+ , [OsString.pstr|..|]+ , [OsString.pstr|...|]+ , [OsString.pstr|xy|]+ , [OsString.pstr|foo|]+ , [OsString.pstr|foo.|]+ , [OsString.pstr|foo..|]+ , [OsString.pstr|..foo|]+ , [OsString.pstr|...foo|]+ , [OsString.pstr|.foo.bar|]+ , [OsString.pstr|.foo|] <> pathSep <> [OsString.pstr|bar|]+ ]++ validExtensions :: [PLATFORM_STRING]+ validExtensions =+ [ [OsString.pstr|.foo|]+ , [OsString.pstr|.foo.|]+ , [OsString.pstr|.foo..|]+ ]++validExtensionsSpec :: PLATFORM_STRING -> Path b File -> Path b File -> Spec+validExtensionsSpec ext file fext = do+ let f = show $ toOsPath file+ let fx = show $ toOsPath fext++ it ("addExtension " ++ show ext ++ " " ++ f ++ " == " ++ fx) $+ addExtension ext file `shouldReturn` fext++ it ("fileExtension " ++ fx ++ " == " ++ show ext) $+ fileExtension fext `shouldReturn` ext++ it ("replaceExtension " ++ show ext ++ " " ++ fx ++ " == " ++ fx) $+ replaceExtension ext fext `shouldReturn` fext++forDrives :: (Path Abs Dir -> Spec) -> Spec+forDrives f = case drives of+ (drive :| []) -> f drive+ _ -> forM_ drives $ \drive ->+ describe ("Drive " ++ show drive) (f drive)++parseFails :: PLATFORM_PATH -> Spec+parseFails x = it (show x ++ " should be rejected")+ (isNothing (void (parseAbsDir x) <|>+ void (parseRelDir x) <|>+ void (parseAbsFile x) <|>+ void (parseRelFile x)))++parseSucceeds :: PLATFORM_PATH -> Path Rel Dir -> Spec+parseSucceeds x with = parserTest parseRelDir x (Just with)++-- | Parser test.+parserTest :: (Show a, Show b, Eq b)+ => (a -> Maybe b) -> a -> Maybe b -> Spec+parserTest parser input expected =+ it (message1 ++ "Parsing " ++ show input ++ " " ++ message2)+ (parser input `shouldBe` expected)+ where message1+ | isNothing expected = "Failing: "+ | otherwise = "Succeeding: "++ message2 = case expected of+ Nothing -> "should fail."+ Just x -> "should succeed with: " ++ show x
+ test-ospath/Common/Posix.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE CPP #-}++#define PLATFORM_NAME Posix+#define PLATFORM_PATH PosixPath+#define PLATFORM_STRING PosixString+#include "Include.hs"++drives_ :: NonEmpty PLATFORM_PATH+drives_ = NonEmpty.singleton [OsString.pstr|/|]
+ test-ospath/Common/Windows.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE CPP #-}++#define PLATFORM_NAME Windows+#define PLATFORM_PATH WindowsPath+#define PLATFORM_STRING WindowsString+#include "Include.hs"++-- See https://learn.microsoft.com/en-us/dotnet/standard/io/file-path-formats+drives_ :: NonEmpty PLATFORM_STRING+drives_ = NonEmpty.fromList+ [ [OsString.pstr|C:\|] -- Common+ , [OsString.pstr|C:/|] -- Common+ , [OsString.pstr|\\host|] -- UNC+ --, [OsString.pstr|\\.\C:\|] -- DOS Device Path+ , [OsString.pstr|\\?\C:\|] -- DOS Device Path+ --, [OsString.pstr|\\?\UNC\|] -- DOS Device Path+ --, [OsString.pstr|\\.\UNC\|] -- DOS Device Path+ ]
+ test-ospath/Main.hs view
@@ -0,0 +1,12 @@+module Main (main) where++import qualified Windows+import qualified Posix++import Test.Hspec++-- | Test suite entry point, returns exit failure if any test fails.+main :: IO ()+main = hspec $ do+ describe "Path.Windows" Windows.spec+ describe "Path.Posix" Posix.spec
+ test-ospath/Posix.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE QuasiQuotes #-}++-- | Test suite.++module Posix (spec) where++import Test.Hspec++import Common.Posix (parseFails, parseSucceeds, parserTest)+import qualified Common.Posix+import OsPath.Posix+import OsPath.Internal.Posix+import qualified System.OsString.Compat.Posix as OsString+import TH.Posix ()++-- | Test suite (Posix version).+spec :: Spec+spec =+ do describe "Parsing: Path Abs Dir" parseAbsDirSpec+ describe "Parsing: Path Rel Dir" parseRelDirSpec+ describe "Parsing: Path Abs File" parseAbsFileSpec+ describe "Parsing: Path Rel File" parseRelFileSpec+ Common.Posix.spec+ describe "Restrictions" restrictions+ describe "QuasiQuotes" quasiquotes++-- | Restricting the input of any tricks.+restrictions :: Spec+restrictions =+ do -- These ~ related ones below are now lifted:+ -- https://github.com/chrisdone/path/issues/19+ parseSucceeds [OsString.pstr|~/|] (Path [OsString.pstr|~/|])+ parseSucceeds [OsString.pstr|~/foo|] (Path [OsString.pstr|~/foo/|])+ parseSucceeds [OsString.pstr|~/foo/bar|] (Path [OsString.pstr|~/foo/bar/|])+ parseSucceeds [OsString.pstr|a..|] (Path [OsString.pstr|a../|])+ parseSucceeds [OsString.pstr|..a|] (Path [OsString.pstr|..a/|])+ --+ parseFails [OsString.pstr|../|]+ parseFails [OsString.pstr|..|]+ parseFails [OsString.pstr|/..|]+ parseFails [OsString.pstr|/foo/../bar/|]+ parseFails [OsString.pstr|/foo/bar/..|]++-- | Tests for the tokenizer.+parseAbsDirSpec :: Spec+parseAbsDirSpec =+ do failing [OsString.pstr||]+ failing [OsString.pstr|./|]+ failing [OsString.pstr|foo.txt|]+ succeeding [OsString.pstr|/|] (Path [OsString.pstr|/|])+ succeeding [OsString.pstr|//|] (Path [OsString.pstr|/|])+ succeeding [OsString.pstr|///foo//bar//mu/|] (Path [OsString.pstr|/foo/bar/mu/|])+ succeeding [OsString.pstr|///foo//bar////mu|] (Path [OsString.pstr|/foo/bar/mu/|])+ succeeding [OsString.pstr|///foo//bar/.//mu|] (Path [OsString.pstr|/foo/bar/mu/|])++ where failing x = parserTest parseAbsDir x Nothing+ succeeding x with = parserTest parseAbsDir x (Just with)++-- | Tests for the tokenizer.+parseRelDirSpec :: Spec+parseRelDirSpec =+ do failing [OsString.pstr||]+ failing [OsString.pstr|/|]+ failing [OsString.pstr|//|]+ succeeding [OsString.pstr|~/|] (Path [OsString.pstr|~/|]) -- https://github.com/chrisdone/path/issues/19+ failing [OsString.pstr|/|]+ succeeding [OsString.pstr|./|] (Path [OsString.pstr||])+ succeeding [OsString.pstr|././|] (Path [OsString.pstr||])+ failing [OsString.pstr|//|]+ failing [OsString.pstr|///foo//bar//mu/|]+ failing [OsString.pstr|///foo//bar////mu|]+ failing [OsString.pstr|///foo//bar/.//mu|]+ succeeding [OsString.pstr|...|] (Path [OsString.pstr|.../|])+ succeeding [OsString.pstr|foo.bak|] (Path [OsString.pstr|foo.bak/|])+ succeeding [OsString.pstr|./foo|] (Path [OsString.pstr|foo/|])+ succeeding [OsString.pstr|././foo|] (Path [OsString.pstr|foo/|])+ succeeding [OsString.pstr|./foo/./bar|] (Path [OsString.pstr|foo/bar/|])+ succeeding [OsString.pstr|foo//bar//mu//|] (Path [OsString.pstr|foo/bar/mu/|])+ succeeding [OsString.pstr|foo//bar////mu|] (Path [OsString.pstr|foo/bar/mu/|])+ succeeding [OsString.pstr|foo//bar/.//mu|] (Path [OsString.pstr|foo/bar/mu/|])++ where failing x = parserTest parseRelDir x Nothing+ succeeding x with = parserTest parseRelDir x (Just with)++-- | Tests for the tokenizer.+parseAbsFileSpec :: Spec+parseAbsFileSpec =+ do failing [OsString.pstr||]+ failing [OsString.pstr|./|]+ failing [OsString.pstr|/.|]+ failing [OsString.pstr|/foo/bar/.|]+ failing [OsString.pstr|~/|]+ failing [OsString.pstr|./foo.txt|]+ failing [OsString.pstr|/|]+ failing [OsString.pstr|//|]+ failing [OsString.pstr|///foo//bar//mu/|]+ succeeding [OsString.pstr|/...|] (Path [OsString.pstr|/...|])+ succeeding [OsString.pstr|/foo.txt|] (Path [OsString.pstr|/foo.txt|])+ succeeding [OsString.pstr|///foo//bar////mu.txt|] (Path [OsString.pstr|/foo/bar/mu.txt|])+ succeeding [OsString.pstr|///foo//bar/.//mu.txt|] (Path [OsString.pstr|/foo/bar/mu.txt|])++ where failing x = parserTest parseAbsFile x Nothing+ succeeding x with = parserTest parseAbsFile x (Just with)++-- | Tests for the tokenizer.+parseRelFileSpec :: Spec+parseRelFileSpec =+ do failing [OsString.pstr||]+ failing [OsString.pstr|/|]+ failing [OsString.pstr|//|]+ failing [OsString.pstr|~/|]+ failing [OsString.pstr|/|]+ failing [OsString.pstr|./|]+ failing [OsString.pstr|a/.|]+ failing [OsString.pstr|a/../b|]+ failing [OsString.pstr|a/..|]+ failing [OsString.pstr|../foo.txt|]+ failing [OsString.pstr|//|]+ failing [OsString.pstr|///foo//bar//mu/|]+ failing [OsString.pstr|///foo//bar////mu|]+ failing [OsString.pstr|///foo//bar/.//mu|]+ succeeding [OsString.pstr|a..|] (Path [OsString.pstr|a..|])+ succeeding [OsString.pstr|...|] (Path [OsString.pstr|...|])+ succeeding [OsString.pstr|foo.txt|] (Path [OsString.pstr|foo.txt|])+ succeeding [OsString.pstr|./foo.txt|] (Path [OsString.pstr|foo.txt|])+ succeeding [OsString.pstr|././foo.txt|] (Path [OsString.pstr|foo.txt|])+ succeeding [OsString.pstr|./foo/./bar.txt|] (Path [OsString.pstr|foo/bar.txt|])+ succeeding [OsString.pstr|foo//bar//mu.txt|] (Path [OsString.pstr|foo/bar/mu.txt|])+ succeeding [OsString.pstr|foo//bar////mu.txt|] (Path [OsString.pstr|foo/bar/mu.txt|])+ succeeding [OsString.pstr|foo//bar/.//mu.txt|] (Path [OsString.pstr|foo/bar/mu.txt|])++ where failing x = parserTest parseRelFile x Nothing+ succeeding x with = parserTest parseRelFile x (Just with)++-- | Test QuasiQuoters. Make sure they work the same as the $(mk*) constructors.+quasiquotes :: Spec+quasiquotes =+ do it "[absdir|/|] == $(mkAbsDir \"/\")"+ ([absdir|/|] `shouldBe` $(mkAbsDir [OsString.pstr|/|]))+ it "[absdir|/home|] == $(mkAbsDir \"/home\")"+ ([absdir|/home|] `shouldBe` $(mkAbsDir [OsString.pstr|/home|]))+ it "[reldir|foo|] == $(mkRelDir \"foo\")"+ ([reldir|foo|] `shouldBe` $(mkRelDir [OsString.pstr|foo|]))+ it "[reldir|foo/bar|] == $(mkRelDir \"foo/bar\")"+ ([reldir|foo/bar|] `shouldBe` $(mkRelDir [OsString.pstr|foo/bar|]))+ it "[absfile|/home/chris/foo.txt|] == $(mkAbsFile \"/home/chris/foo.txt\")"+ ([absfile|/home/chris/foo.txt|] `shouldBe` $(mkAbsFile [OsString.pstr|/home/chris/foo.txt|]))+ it "[relfile|foo|] == $(mkRelFile \"foo\")"+ ([relfile|foo|] `shouldBe` $(mkRelFile [OsString.pstr|foo|]))+ it "[relfile|chris/foo.txt|] == $(mkRelFile \"chris/foo.txt\")"+ ([relfile|chris/foo.txt|] `shouldBe` $(mkRelFile [OsString.pstr|chris/foo.txt|]))
+ test-ospath/TH/Posix.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE CPP #-}++#define PLATFORM_NAME Posix+#define PLATFORM_PATH PosixPath+#include "Include.hs"++qqAbsDir :: PLATFORM_PATH+qqAbsDir = checkInstantiated [absdir|/name/|]++qqAbsFile :: PLATFORM_PATH+qqAbsFile = checkInstantiated [absdir|/name|]++thAbsDir :: PLATFORM_PATH+thAbsDir = checkInstantiated $(mkAbsDir [OsString.pstr|/name/|])++thAbsFile :: PLATFORM_PATH+thAbsFile = checkInstantiated $(mkAbsFile [OsString.pstr|/name|])++liftAbsDir :: PLATFORM_PATH+liftAbsDir = checkInstantiated $(TH.lift (Path [OsString.pstr|/name/|] :: Path Abs Dir))++liftAbsFile :: PLATFORM_PATH+liftAbsFile = checkInstantiated $(TH.lift (Path [OsString.pstr|/name|] :: Path Abs File))
+ test-ospath/TH/Windows.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE CPP #-}++#define PLATFORM_NAME Windows+#define PLATFORM_PATH WindowsPath+#include "Include.hs"++qqAbsDir :: PLATFORM_PATH+qqAbsDir = checkInstantiated [absdir|C:\foo\|]++qqAbsFile :: PLATFORM_PATH+qqAbsFile = checkInstantiated [absdir|C:\foo|]++thAbsDir :: PLATFORM_PATH+thAbsDir = checkInstantiated $(mkAbsDir [OsString.pstr|C:\foo\|])++thAbsFile :: PLATFORM_PATH+thAbsFile = checkInstantiated $(mkAbsFile [OsString.pstr|C:\foo|])++liftAbsDir :: PLATFORM_PATH+liftAbsDir = checkInstantiated $(TH.lift (Path [OsString.pstr|C:\foo\|] :: Path Abs Dir))++liftAbsFile :: PLATFORM_PATH+liftAbsFile = checkInstantiated $(TH.lift (Path [OsString.pstr|C:\foo|] :: Path Abs File))
+ test-ospath/Windows.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Test suite.++module Windows (spec) where++import Test.Hspec++import Common.Windows (parseFails, parseSucceeds, parserTest)+import qualified Common.Windows+import OsPath.Windows+import OsPath.Internal.Windows+import qualified System.OsString.Compat.Windows as OsString+import TH.Windows ()++-- | Test suite (Windows version).+spec :: Spec+spec =+ do describe "Parsing: Path Abs Dir" parseAbsDirSpec+ describe "Parsing: Path Rel Dir" parseRelDirSpec+ describe "Parsing: Path Abs File" parseAbsFileSpec+ describe "Parsing: Path Rel File" parseRelFileSpec+ Common.Windows.spec+ describe "Restrictions" restrictions+ describe "QuasiQuotes" quasiquotes++-- | Restricting the input of any tricks.+restrictions :: Spec+restrictions =+ do parseFails [OsString.pstr|..\|]+ parseFails [OsString.pstr|..|]+ parseSucceeds [OsString.pstr|a..|] (Path [OsString.pstr|a..\|])+ parseSucceeds [OsString.pstr|..a|] (Path [OsString.pstr|..a\|])+ parseFails [OsString.pstr|\..|]+ parseFails [OsString.pstr|C:\foo\..\bar\|]+ parseFails [OsString.pstr|C:\foo\bar\..|]++-- | Tests for the tokenizer.+parseAbsDirSpec :: Spec+parseAbsDirSpec =+ do failing [OsString.pstr||]+ failing [OsString.pstr|.\|]+ failing [OsString.pstr|foo.txt|]+ failing [OsString.pstr|C:|]+ succeeding [OsString.pstr|C:\|] (Path [OsString.pstr|C:\|])+ succeeding [OsString.pstr|C:\\|] (Path [OsString.pstr|C:\|])+ succeeding [OsString.pstr|C:\\\foo\\bar\\mu\|] (Path [OsString.pstr|C:\foo\bar\mu\|])+ succeeding [OsString.pstr|C:\\\foo\\bar\\mu|] (Path [OsString.pstr|C:\foo\bar\mu\|])+ succeeding [OsString.pstr|C:\\\foo\\bar\.\\mu|] (Path [OsString.pstr|C:\foo\bar\mu\|])+ succeeding [OsString.pstr|\\unchost\share|] (Path [OsString.pstr|\\unchost\share\|])+ succeeding [OsString.pstr|\/unchost\share|] (Path [OsString.pstr|\\unchost\share\|])+ succeeding [OsString.pstr|\\unchost\share\\folder\|] (Path [OsString.pstr|\\unchost\share\folder\|])+ succeeding [OsString.pstr|\\?\C:\|] (Path [OsString.pstr|\\?\C:\|])+ succeeding [OsString.pstr|/\?\C:\|] (Path [OsString.pstr|\\?\C:\|])+ succeeding [OsString.pstr|\\?\C:\\\folder\\|] (Path [OsString.pstr|\\?\C:\folder\|])++ where failing x = parserTest parseAbsDir x Nothing+ succeeding x with = parserTest parseAbsDir x (Just with)++-- | Tests for the tokenizer.+parseRelDirSpec :: Spec+parseRelDirSpec =+ do failing [OsString.pstr||]+ failing [OsString.pstr|/|]+ failing [OsString.pstr|//|]+ failing [OsString.pstr|\|]+ failing [OsString.pstr|\\|]+ failing [OsString.pstr|\\\foo\\bar\\mu\|]+ failing [OsString.pstr|\\\foo\\bar\\\\mu|]+ failing [OsString.pstr|\\\foo\\bar\.\\mu|]+ failing [OsString.pstr|\\unchost\share|]+ failing [OsString.pstr|\\?\C:\|]+ succeeding [OsString.pstr|.\|] (Path [OsString.pstr||])+ succeeding [OsString.pstr|.\.\|] (Path [OsString.pstr||])+ succeeding [OsString.pstr|...|] (Path [OsString.pstr|...\|])+ succeeding [OsString.pstr|foo.bak|] (Path [OsString.pstr|foo.bak\|])+ succeeding [OsString.pstr|.\foo|] (Path [OsString.pstr|foo\|])+ succeeding [OsString.pstr|.\.\foo|] (Path [OsString.pstr|foo\|])+ succeeding [OsString.pstr|.\foo\.\bar|] (Path [OsString.pstr|foo\bar\|])+ succeeding [OsString.pstr|foo\\bar\\mu\\|] (Path [OsString.pstr|foo\bar\mu\|])+ succeeding [OsString.pstr|foo\\bar////mu|] (Path [OsString.pstr|foo\bar\mu\|])+ succeeding [OsString.pstr|foo\\bar\.\\mu|] (Path [OsString.pstr|foo\bar\mu\|])++ where failing x = parserTest parseRelDir x Nothing+ succeeding x with = parserTest parseRelDir x (Just with)++-- | Tests for the tokenizer.+parseAbsFileSpec :: Spec+parseAbsFileSpec =+ do failing [OsString.pstr||]+ failing [OsString.pstr|.\|]+ failing [OsString.pstr|\.|]+ failing [OsString.pstr|\foo\bar\.|]+ failing [OsString.pstr|~\|]+ failing [OsString.pstr|.\foo.txt|]+ failing [OsString.pstr|\|]+ failing [OsString.pstr|\\|]+ failing [OsString.pstr|\\\foo\\bar\\mu\|]+ failing [OsString.pstr|\...|]+ failing [OsString.pstr|\foo.txt|]+ succeeding [OsString.pstr|C:\\\foo\\bar\\\\mu.txt|] (Path [OsString.pstr|C:\foo\bar\mu.txt|])+ succeeding [OsString.pstr|C:\\\foo\\bar\.\\mu.txt|] (Path [OsString.pstr|C:\foo\bar\mu.txt|])+ succeeding [OsString.pstr|\\unchost\share\\file.txt|] (Path [OsString.pstr|\\unchost\share\file.txt|])+ succeeding [OsString.pstr|\/unchost\share\\file.txt|] (Path [OsString.pstr|\\unchost\share\file.txt|])+ succeeding [OsString.pstr|\\unchost\share\.\folder\\\file.txt|] (Path [OsString.pstr|\\unchost\share\folder\file.txt|])+ succeeding [OsString.pstr|\\?\C:\file.txt|] (Path [OsString.pstr|\\?\C:\file.txt|])+ succeeding [OsString.pstr|/\?\C:\file.txt|] (Path [OsString.pstr|\\?\C:\file.txt|])+ succeeding [OsString.pstr|\\?\C:\\\folder\.\\file.txt|] (Path [OsString.pstr|\\?\C:\folder\file.txt|])++ where failing x = parserTest parseAbsFile x Nothing+ succeeding x with = parserTest parseAbsFile x (Just with)++-- | Tests for the tokenizer.+parseRelFileSpec :: Spec+parseRelFileSpec =+ do failing [OsString.pstr||]+ failing [OsString.pstr|\|]+ failing [OsString.pstr|\\|]+ failing [OsString.pstr|~\|]+ failing [OsString.pstr|\|]+ failing [OsString.pstr|.\|]+ failing [OsString.pstr|a\.|]+ failing [OsString.pstr|a\..\b|]+ failing [OsString.pstr|a\..|]+ failing [OsString.pstr|..\foo.txt|]+ failing [OsString.pstr|\\|]+ failing [OsString.pstr|\\\foo\\bar\\mu\|]+ failing [OsString.pstr|\\\foo\\bar\\\\mu|]+ failing [OsString.pstr|\\\foo\\bar\.\\mu|]+ failing [OsString.pstr|\\unchost\share\\file.txt|]+ failing [OsString.pstr|\\?\C:\file.txt|]+ succeeding [OsString.pstr|a..|] (Path [OsString.pstr|a..|])+ succeeding [OsString.pstr|...|] (Path [OsString.pstr|...|])+ succeeding [OsString.pstr|foo.txt|] (Path [OsString.pstr|foo.txt|])+ succeeding [OsString.pstr|.\foo.txt|] (Path [OsString.pstr|foo.txt|])+ succeeding [OsString.pstr|.\.\foo.txt|] (Path [OsString.pstr|foo.txt|])+ succeeding [OsString.pstr|.\foo\.\bar.txt|] (Path [OsString.pstr|foo\bar.txt|])+ succeeding [OsString.pstr|foo\\bar\\mu.txt|] (Path [OsString.pstr|foo\bar\mu.txt|])+ succeeding [OsString.pstr|foo\\bar\\\\mu.txt|] (Path [OsString.pstr|foo\bar\mu.txt|])+ succeeding [OsString.pstr|foo\\bar\.\\mu.txt|] (Path [OsString.pstr|foo\bar\mu.txt|])++ where failing x = parserTest parseRelFile x Nothing+ succeeding x with = parserTest parseRelFile x (Just with)++-- | Test QuasiQuoters. Make sure they work the same as the $(mk*) constructors.+quasiquotes :: Spec+quasiquotes =+ do it "[absdir|C:\\|] == $(mkAbsDir \"C:\\\")"+ ([absdir|C:\|] `shouldBe` $(mkAbsDir [OsString.pstr|C:\|]))+ it "[absdir|C:\\chris\\|] == $(mkAbsDir \"C:\\chris\\\")"+ ([absdir|C:\chris\|] `shouldBe` $(mkAbsDir [OsString.pstr|C:\chris\|]))+ it "[reldir|foo|] == $(mkRelDir \"foo\")"+ ([reldir|foo|] `shouldBe` $(mkRelDir [OsString.pstr|foo|]))+ it "[reldir|foo\\bar|] == $(mkRelDir \"foo\\bar\")"+ ([reldir|foo\bar|] `shouldBe` $(mkRelDir [OsString.pstr|foo\bar|]))+ it "[absfile|C:\\chris\\foo.txt|] == $(mkAbsFile \"C:\\chris\\foo.txt\")"+ ([absfile|C:\chris\foo.txt|] `shouldBe` $(mkAbsFile [OsString.pstr|C:\chris\foo.txt|]))+ it "[relfile|foo.exe|] == $(mkRelFile \"foo.exe\")"+ ([relfile|foo.exe|] `shouldBe` $(mkRelFile [OsString.pstr|foo.exe|]))+ it "[relfile|chris\\foo.txt|] == $(mkRelFile \"chris\\foo.txt\")"+ ([relfile|chris\foo.txt|] `shouldBe` $(mkRelFile [OsString.pstr|chris\foo.txt|]))
− test/Common.hs
@@ -1,87 +0,0 @@-{-# 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"- ]
+ test/Common/Include.hs view
@@ -0,0 +1,335 @@+-- This template expects CPP definitions for:+-- PLATFORM_NAME = Posix | Windows++{-# LANGUAGE RankNTypes #-}++-- | Test functions that are common to Posix and Windows+module Common.PLATFORM_NAME+ (spec+ ,parseFails+ ,parseSucceeds+ ,parserTest+ ) where++import Control.Applicative ((<|>))+import Control.Monad (forM_, void)+import Control.Monad.Catch (MonadThrow)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Maybe (fromJust, isNothing)+import qualified System.FilePath.PLATFORM_NAME as FilePath+import Test.Hspec++import Path.Internal.PLATFORM_NAME+import Path.PLATFORM_NAME++currentDir :: Path Rel Dir+currentDir = (fromJust . parseRelDir) "."++drives :: NonEmpty (Path Abs Dir)+drives = (fromJust . traverse parseAbsDir) drives_++relDir :: Path Rel Dir+relDir = (fromJust . parseRelDir) "directory"++relFile :: Path Rel File+relFile = (fromJust . parseRelFile) "file"++spec :: Spec+spec = do+ describe "Operations: (</>)" operationAppend+ describe "Operations: dirname" operationDirname+ describe "Operations: filename" operationFilename+ describe "Operations: parent" operationParent+ describe "Operations: toFilePath" operationToFilePath+ describe "Operations: isProperPrefixOf" operationIsProperPrefixOf+ describe "Operations: stripProperPrefix" operationStripProperPrefix+ describe "Operations: isDrive" operationIsDrive+ describe "Operations: splitDrive" operationSplitDrive+ describe "Operations: extensions" extensionOperations++-- | The 'dirname' operation.+operationDirname :: Spec+operationDirname = do+ it+ "dirname (relDir </> relDir) == dirname relDir"+ (dirname (relDir </> relDir) == dirname relDir)+ it+ "dirname \".\" == dirname \".\""+ (dirname currentDir == currentDir)++ forDrives $ \drive -> do+ let absDir = drive </> relDir+ it+ "dirname (absDir </> relDir) == dirname relDir"+ (dirname (absDir </> relDir) == dirname relDir)+ it+ "dirname of a drive must be a Rel path"+ (isNothing (parseAbsDir . toFilePath . dirname $ drive))++-- | The 'filename' operation.+operationFilename :: Spec+operationFilename = do+ it+ "filename (relDir </> relFile) == filename relFile"+ (filename (relDir </> relFile) == filename relFile)++ forDrives $ \drive -> do+ let absDir = drive </> relDir+ it+ "filename (absDir </> relFile) == filename relFile"+ (filename (absDir </> relFile) == filename relFile)++-- | The 'parent' operation.+operationParent :: Spec+operationParent = do+ it+ "parent relDir == \".\""+ (parent relDir == currentDir)+ it+ "parent \".\" == \".\""+ (parent currentDir == currentDir)++ forDrives $ \drive -> do+ let absDir = drive </> relDir+ it+ "parent (absDir </> relDir) == absDir"+ (parent (absDir </> relDir) == absDir)+ it+ "parent absDir == drive"+ (parent absDir == drive)+ it+ "parent drive == drive"+ (parent drive == drive)++-- | The 'splitDrive' operation.+operationSplitDrive :: Spec+operationSplitDrive = forDrives $ \drive -> do+ let absDir = drive </> relDir+ absFile = drive </> relFile+ it+ "splitDrive absDir == (drive, Just relDir)"+ (splitDrive absDir == (drive, Just relDir))+ it+ "splitDrive absFile == (drive, Just relFile)"+ (splitDrive absFile == (drive, Just relFile))+ it+ "splitDrive drive == (drive, Nothing)"+ (splitDrive drive == (drive, Nothing))++-- | The 'isDrive' operation.+operationIsDrive :: Spec+operationIsDrive = forDrives $ \drive -> do+ let absDir = drive </> relDir+ it+ "isDrive drive"+ (isDrive drive)+ it+ "not (isDrive absDir)"+ (not (isDrive absDir))++-- | The 'isProperPrefixOf' operation.+operationIsProperPrefixOf :: Spec+operationIsProperPrefixOf = do+ it+ "isProperPrefixOf relDir (relDir </> relDir)"+ (isProperPrefixOf relDir (relDir </> relDir))++ it+ "not (relDir `isProperPrefixOf` relDir)"+ (not (isProperPrefixOf relDir relDir))++ forDrives $ \drive -> do+ let absDir = drive </> relDir+ it+ "isProperPrefixOf absDir (absDir </> relDir)"+ (isProperPrefixOf absDir (absDir </> relDir))++ it+ "not (drive `isProperPrefixOf` drive)"+ (not (isProperPrefixOf drive drive))++-- | The 'stripProperPrefix' operation.+operationStripProperPrefix :: Spec+operationStripProperPrefix = do+ it+ "stripProperPrefix relDir (relDir </> relDir) == relDir"+ (stripProperPrefix relDir (relDir </> relDir) == Just relDir)++ forDrives $ \drive -> do+ let absDir = drive </> relDir+ it+ "stripProperPrefix absDir (absDir </> relDir) == relDir"+ (stripProperPrefix absDir (absDir </> relDir) == Just relDir)+ it+ "stripProperPrefix absDir absDir == Nothing"+ (isNothing (stripProperPrefix absDir absDir))++-- | The '</>' operation.+operationAppend :: Spec+operationAppend = do+ let Path relDir' = relDir+ Path relFile' = relFile+ it+ "RelDir + RelDir == RelDir"+ (relDir </> relDir == Path (relDir' FilePath.</> relDir'))+ it+ "\".\" + \".\" == \".\""+ (currentDir </> currentDir == currentDir)+ it+ "\".\" + relDir == relDir"+ (currentDir </> relDir == relDir)+ it+ "relDir + \".\" == x"+ (relDir </> currentDir == relDir)+ it+ "RelDir + RelFile == RelFile"+ (relDir </> relFile == Path (relDir' FilePath.</> relFile'))++ forDrives $ \drive -> do+ let absDir@(Path absDir') = drive </> relDir+ it+ "AbsDir + RelDir == AbsDir"+ (absDir </> relDir == Path (absDir' FilePath.</> relDir'))+ it+ "AbsDir + RelFile == AbsFile"+ (absDir </> relFile == Path (absDir' FilePath.</> relFile'))++-- | The 'toFilePath operation.+operationToFilePath :: Spec+operationToFilePath = do+ let expected = "." ++ [FilePath.pathSeparator]+ it+ ("toFilePath \".\" == " ++ show expected)+ (toFilePath currentDir == expected)+ it+ ("show \".\" == " ++ (show . show) expected)+ (show currentDir == show expected)++-- | Testing operations related to extensions.+extensionOperations :: Spec+extensionOperations = do+ describe "Only filenames and extensions" $+ forM_ filenames $ \file -> do+ forM_ validExtensions $ \ext -> do+ runTests parseRelFile file ext++ describe "Relative dir paths" $+ forM_ dirnames $ \dir -> do+ forM_ filenames $ \file -> do+ forM_ validExtensions $ \ext -> do+ let filepath = dir ++ [FilePath.pathSeparator] ++ file+ runTests parseRelFile filepath ext++ describe "Absolute dir paths" $+ forM_ drives_ $ \drive -> do+ forM_ dirnames $ \dir -> do+ forM_ filenames $ \file -> do+ forM_ validExtensions $ \ext -> do+ let filepath = drive ++ dir ++ [FilePath.pathSeparator] ++ file+ runTests parseAbsFile filepath ext++ -- Invalid extensions+ forM_ invalidExtensions $ \ext -> do+ it ("throws InvalidExtension when extension is " ++ show ext) $+ addExtension ext (Path "name")+ `shouldThrow` (== InvalidExtension ext)++ where++ runTests :: (forall m . MonadThrow m => FilePath -> m (Path b File))+ -> FilePath+ -> FilePath+ -> Spec+ runTests parse file ext = do+ let maybePathFile = parse file+ let maybePathFileWithExt = parse (file ++ ext)+ case (maybePathFile, maybePathFileWithExt) of+ (Just pathFile, Just pathFileWithExt) -> validExtensionsSpec ext pathFile pathFileWithExt+ _ -> it ("Files " ++ show file ++ " and/or " ++ show (file ++ ext) ++ " should parse successfully.") $+ expectationFailure $+ show file ++ " parsed to " ++ show maybePathFile ++ ", "+ ++ show (file ++ ext) ++ " parsed to " ++ show maybePathFileWithExt++ filenames :: [FilePath]+ filenames =+ [ "name"+ , "name."+ , "name.."+ , ".name"+ , "..name"+ , "name.name"+ , "name..name"+ , "..."+ ]++ dirnames :: [FilePath]+ dirnames = filenames ++ ["."]++ invalidExtensions :: [String]+ invalidExtensions =+ [ ""+ , "."+ , "x"+ , ".."+ , "..."+ , "xy"+ , "foo"+ , "foo."+ , "foo.."+ , "..foo"+ , "...foo"+ , ".foo.bar"+ , ".foo" ++ [FilePath.pathSeparator] ++ "bar"+ ]++ validExtensions :: [String]+ validExtensions =+ [ ".foo"+ , ".foo."+ , ".foo.."+ ]++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++forDrives :: (Path Abs Dir -> Spec) -> Spec+forDrives f = case drives of+ (drive :| []) -> f drive+ _ -> forM_ drives $ \drive ->+ describe ("Drive " ++ show drive) (f drive)++parseFails :: FilePath -> Spec+parseFails x = it (show x ++ " should be rejected")+ (isNothing (void (parseAbsDir x) <|>+ void (parseRelDir x) <|>+ void (parseAbsFile x) <|>+ void (parseRelFile x)))++parseSucceeds :: FilePath -> Path Rel Dir -> Spec+parseSucceeds x with = parserTest parseRelDir x (Just with)++-- | Parser test.+parserTest :: (Show a, Show b, Eq b)+ => (a -> Maybe b) -> a -> Maybe b -> Spec+parserTest parser input expected =+ it (message1 ++ "Parsing " ++ show input ++ " " ++ message2)+ (parser input `shouldBe` expected)+ where message1+ | isNothing expected = "Failing: "+ | otherwise = "Succeeding: "++ message2 = case expected of+ Nothing -> "should fail."+ Just x -> "should succeed with: " ++ show x
+ test/Common/Posix.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE CPP #-}++#define PLATFORM_NAME Posix+#include "Include.hs"++drives_ :: NonEmpty FilePath+drives_ = NonEmpty.singleton "/"
+ test/Common/Windows.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE CPP #-}++#define PLATFORM_NAME Windows+#include "Include.hs"++-- See https://learn.microsoft.com/en-us/dotnet/standard/io/file-path-formats+drives_ :: NonEmpty FilePath+drives_ = NonEmpty.fromList+ [ "C:\\" -- Common+ , "C:/" -- Common+ , "\\\\host" -- UNC+ --, "\\\\.\\C:\\" -- DOS Device Path+ , "\\\\?\\C:\\" -- DOS Device Path+ --, "\\\\?\\UNC\\" -- DOS Device Path+ --, "\\\\.\\UNC\\" -- DOS Device Path+ ]
test/Main.hs view
@@ -1,15 +1,12 @@-{-# LANGUAGE CPP #-}- module Main (main) where -#ifdef mingw32_HOST_OS-import Windows (spec)-#else-import Posix (spec)-#endif+import qualified Windows+import qualified Posix import Test.Hspec -- | Test suite entry point, returns exit failure if any test fails. main :: IO ()-main = hspec spec+main = hspec $ do+ describe "Path.Windows" Windows.spec+ describe "Path.Posix" Posix.spec
− test/Path/Gen.hs
@@ -1,164 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TemplateHaskell #-}--module Path.Gen where--import Data.Functor-import Prelude--import Path-import Path.Internal--import qualified System.FilePath as FilePath--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- 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- 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- 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- 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) where- shrinkValid = shrinkValidWith parseAbsFile--instance GenUnchecked (Path Rel File) where- genUnchecked = Path <$> genFilePath--instance GenValid (Path Rel File) where- shrinkValid = shrinkValidWith parseRelFile--instance GenUnchecked (Path Abs Dir) where- genUnchecked = Path <$> genFilePath--instance GenValid (Path Abs Dir) where- shrinkValid = shrinkValidWith parseAbsDir--instance GenUnchecked (Path Rel Dir) where- genUnchecked = Path <$> genFilePath--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.-genFilePath :: Gen FilePath-genFilePath = listOf genPathyChar--genPathyChar :: Gen Char-genPathyChar = frequency [(2, choose (minBound, maxBound)), (1, elements "./\\")]--shrinkValidWith :: (FilePath -> Maybe (Path a b)) -> Path a b -> [Path a b]-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)
test/Posix.hs view
@@ -7,16 +7,15 @@ module Posix (spec) where -import Control.Applicative-import Control.Monad import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as LBS-import Data.Maybe-import Path.Posix-import Path.Internal import Test.Hspec -import Common (extensionOperations)+import Common.Posix (parseFails, parseSucceeds, parserTest)+import qualified Common.Posix+import Path.Posix+import Path.Internal.Posix+import TH.Posix () -- | Test suite (Posix version). spec :: Spec@@ -25,14 +24,7 @@ describe "Parsing: Path Rel Dir" parseRelDirSpec describe "Parsing: Path Abs File" parseAbsFileSpec describe "Parsing: Path Rel File" parseRelFileSpec- describe "Operations: (</>)" operationAppend- describe "Operations: toFilePath" operationToFilePath- describe "Operations: stripProperPrefix" operationStripProperPrefix- describe "Operations: isProperPrefixOf" operationIsProperPrefixOf- describe "Operations: parent" operationParent- describe "Operations: filename" operationFilename- describe "Operations: dirname" operationDirname- describe "Operations: extensions" (extensionOperations "/")+ Common.Posix.spec describe "Restrictions" restrictions describe "Aeson Instances" aesonInstances describe "QuasiQuotes" quasiquotes@@ -53,134 +45,7 @@ parseFails "/.." parseFails "/foo/../bar/" parseFails "/foo/bar/.."- where parseFails x =- it (show x ++ " should be rejected")- (isNothing (void (parseAbsDir x) <|>- void (parseRelDir x) <|>- void (parseAbsFile x) <|>- void (parseRelFile x)))- parseSucceeds x with =- parserTest parseRelDir x (Just with) --- | The 'dirname' operation.-operationDirname :: Spec-operationDirname = do- it- "dirname ($(mkAbsDir parent) </> $(mkRelFile dirname)) == dirname $(mkRelFile dirname) (unit test)"- (dirname ($(mkAbsDir "/home/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 / must be a Rel path"- ((parseAbsDir $ show $ dirname (fromJust (parseAbsDir "/"))- :: Maybe (Path Abs Dir)) == Nothing)---- | The 'filename' operation.-operationFilename :: Spec-operationFilename =- do it "filename ($(mkAbsDir parent) </> $(mkRelFile filename)) == filename $(mkRelFile filename) (unit test)"- (filename ($(mkAbsDir "/home/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"))---- | The 'parent' operation.-operationParent :: Spec-operationParent =- do it "parent (parent </> child) == parent"- (parent ($(mkAbsDir "/foo") </>- $(mkRelDir "bar")) ==- $(mkAbsDir "/foo"))- it "parent \"/\" == \"/\""- (parent $(mkAbsDir "/") == $(mkAbsDir "/"))- it "parent \"/x\" == \"/\""- (parent $(mkAbsDir "/x") == $(mkAbsDir "/"))- it "parent \"x\" == \".\""- (parent $(mkRelDir "x") == $(mkRelDir "."))- it "parent \".\" == \".\""- (parent $(mkRelDir ".") == $(mkRelDir "."))---- | The 'isProperPrefixOf' operation.-operationIsProperPrefixOf :: Spec-operationIsProperPrefixOf =- do it "isProperPrefixOf parent (parent </> child) (absolute)"- (isProperPrefixOf- $(mkAbsDir "///bar/")- ($(mkAbsDir "///bar/") </>- $(mkRelFile "bar/foo.txt")))-- it "isProperPrefixOf parent (parent </> child) (relative)"- (isProperPrefixOf- $(mkRelDir "bar/")- ($(mkRelDir "bar/") </>- $(mkRelFile "bob/foo.txt")))-- it "not (x `isProperPrefixOf` x)"- (not (isProperPrefixOf $(mkRelDir "x") $(mkRelDir "x")))-- it "not (/ `isProperPrefixOf` /)"- (not (isProperPrefixOf $(mkAbsDir "/") $(mkAbsDir "/")))---- | The 'stripProperPrefix' operation.-operationStripProperPrefix :: Spec-operationStripProperPrefix =- do it "stripProperPrefix parent (parent </> child) = child (unit test)"- (stripProperPrefix $(mkAbsDir "///bar/")- ($(mkAbsDir "///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"))-- it "stripProperPrefix parent parent = _|_"- (stripProperPrefix $(mkAbsDir "/home/chris/foo")- $(mkAbsDir "/home/chris/foo") ==- Nothing)---- | The '</>' operation.-operationAppend :: Spec-operationAppend =- do it "AbsDir + RelDir = AbsDir"- ($(mkAbsDir "/home/") </>- $(mkRelDir "chris") ==- $(mkAbsDir "/home/chris/"))- it "AbsDir + RelFile = AbsFile"- ($(mkAbsDir "/home/") </>- $(mkRelFile "chris/test.txt") ==- $(mkAbsFile "/home/chris/test.txt"))- it "RelDir + RelDir = RelDir"- ($(mkRelDir "home/") </>- $(mkRelDir "chris") ==- $(mkRelDir "home/chris"))- it ". + . = ."- ($(mkRelDir "./") </> $(mkRelDir ".") == $(mkRelDir "."))- it ". + x = x"- ($(mkRelDir ".") </> $(mkRelDir "x") == $(mkRelDir "x"))- it "x + . = x"- ($(mkRelDir "x") </> $(mkRelDir "./") == $(mkRelDir "x"))- it "RelDir + RelFile = RelFile"- ($(mkRelDir "home/") </>- $(mkRelFile "chris/test.txt") ==- $(mkRelFile "home/chris/test.txt"))--operationToFilePath :: Spec-operationToFilePath =- do it "toFilePath $(mkRelDir \".\") == \"./\""- (toFilePath $(mkRelDir ".") == "./")- it "show $(mkRelDir \".\") == \"\\\"./\\\"\""- (show $(mkRelDir ".") == "\"./\"")- -- | Tests for the tokenizer. parseAbsDirSpec :: Spec parseAbsDirSpec =@@ -271,22 +136,6 @@ where failing x = parserTest parseRelFile x Nothing succeeding x with = parserTest parseRelFile x (Just with)---- | Parser test.-parserTest :: (Show a1,Show a,Eq a1)- => (a -> Maybe a1) -> a -> Maybe a1 -> SpecWith ()-parserTest parser input expected =- it ((case expected of- Nothing -> "Failing: "- Just{} -> "Succeeding: ") ++- "Parsing " ++- show input ++- " " ++- case expected of- Nothing -> "should fail."- Just x -> "should succeed with: " ++ show x)- (actual `shouldBe` expected)- where actual = parser input -- | Tests for the 'ToJSON' and 'FromJSON' instances --
− test/TH.hs
@@ -1,58 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}--module TH where--import qualified Language.Haskell.TH.Syntax as TH-import Path-import Path.Internal----class Foo a b where- foo :: Path a b -> FilePath- foo = toFilePath--instance Foo Abs Dir-instance Foo Abs File-instance Foo Rel Dir-instance Foo Rel File----qqAbsDir :: FilePath-qqAbsDir = foo [absdir|/foo/|]--qqAbsFile :: FilePath-qqAbsFile = foo [absfile|/foo|]--qqRelDir :: FilePath-qqRelDir = foo [reldir|foo/|]--qqRelFile :: FilePath-qqRelFile = foo [relfile|foo|]--thAbsDir :: FilePath-thAbsDir = foo $(mkAbsDir "/foo/")--thAbsFile :: FilePath-thAbsFile = foo $(mkAbsFile "/foo")--thRelDir :: FilePath-thRelDir = foo $(mkRelDir "foo/")--thRelFile :: FilePath-thRelFile = foo $(mkRelFile "foo")--liftAbsDir :: FilePath-liftAbsDir = foo $(TH.lift (Path "/foo/" :: Path Abs Dir))--liftAbsFile :: FilePath-liftAbsFile = foo $(TH.lift (Path "/foo" :: Path Abs File))--liftRelDir :: FilePath-liftRelDir = foo $(TH.lift (Path "foo/" :: Path Rel Dir))--liftRelFile :: FilePath-liftRelFile = foo $(TH.lift (Path "foo" :: Path Rel File))
+ test/TH/Posix.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE CPP #-}++#define PLATFORM_NAME Posix+#include "Include.hs"++qqAbsDir :: FilePath+qqAbsDir = checkInstantiated [absdir|/name/|]++qqAbsFile :: FilePath+qqAbsFile = checkInstantiated [absdir|/name|]++thAbsDir :: FilePath+thAbsDir = checkInstantiated $(mkAbsDir "/name/")++thAbsFile :: FilePath+thAbsFile = checkInstantiated $(mkAbsFile "/name")++liftAbsDir :: FilePath+liftAbsDir = checkInstantiated $(TH.lift (Path "/name/" :: Path Abs Dir))++liftAbsFile :: FilePath+liftAbsFile = checkInstantiated $(TH.lift (Path "/name" :: Path Abs File))
+ test/TH/Windows.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE CPP #-}++#define PLATFORM_NAME Windows+#include "Include.hs"++qqAbsDir :: FilePath+qqAbsDir = checkInstantiated [absdir|C:\foo\|]++qqAbsFile :: FilePath+qqAbsFile = checkInstantiated [absdir|C:\foo|]++thAbsDir :: FilePath+thAbsDir = checkInstantiated $(mkAbsDir "C:\\foo\\")++thAbsFile :: FilePath+thAbsFile = checkInstantiated $(mkAbsFile "C:\\foo")++liftAbsDir :: FilePath+liftAbsDir = checkInstantiated $(TH.lift (Path "C:\\foo\\" :: Path Abs Dir))++liftAbsFile :: FilePath+liftAbsFile = checkInstantiated $(TH.lift (Path "C:\\foo" :: Path Abs File))
− test/ValidityTest.hs
@@ -1,220 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeApplications #-}---- | Test suite.-module Main where--import Control.Applicative-import Control.Monad-import Data.Aeson-import qualified Data.ByteString.Lazy.Char8 as LBS-import Data.Maybe-import Path-import Path.Internal-import Test.Hspec-import Test.Hspec.QuickCheck-import Test.QuickCheck-import Test.Validity--import Path.Gen---- | Test suite entry point, returns exit failure if any test fails.-main :: IO ()-main = hspec spec---- | Test suite.-spec :: Spec-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- 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)---- | 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)---- | The 'isProperPrefixOf' operation.-operationIsParentOf :: Spec-operationIsParentOf = do- 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- 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 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)--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--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--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" $- forAllShrink genFilePath shrinkUnchecked $ \path ->- case parser path of- Nothing -> pure ()- Just p ->- case prettyValidate p of- Left err -> expectationFailure err- Right _ -> pure ()
test/Windows.hs view
@@ -7,16 +7,15 @@ module Windows (spec) where -import Control.Applicative-import Control.Monad import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as LBS-import Data.Maybe-import Path.Windows-import Path.Internal import Test.Hspec -import Common (extensionOperations)+import Common.Windows (parseFails, parseSucceeds, parserTest)+import qualified Common.Windows+import Path.Windows+import Path.Internal.Windows+import TH.Windows () -- | Test suite (Windows version). spec :: Spec@@ -25,14 +24,7 @@ describe "Parsing: Path Rel Dir" parseRelDirSpec describe "Parsing: Path Abs File" parseAbsFileSpec describe "Parsing: Path Rel File" parseRelFileSpec- describe "Operations: (</>)" operationAppend- describe "Operations: toFilePath" operationToFilePath- describe "Operations: stripProperPrefix" operationStripProperPrefix- describe "Operations: isProperPrefixOf" operationIsProperPrefixOf- describe "Operations: parent" operationParent- describe "Operations: filename" operationFilename- describe "Operations: dirname" operationDirname- describe "Operations: extensions" (extensionOperations "C:\\")+ Common.Windows.spec describe "Restrictions" restrictions describe "Aeson Instances" aesonInstances describe "QuasiQuotes" quasiquotes@@ -47,187 +39,7 @@ parseFails "\\.." parseFails "C:\\foo\\..\\bar\\" parseFails "C:\\foo\\bar\\.."- where parseFails x =- it (show x ++ " should be rejected")- (isNothing (void (parseAbsDir x) <|>- void (parseRelDir x) <|>- void (parseAbsFile x) <|>- void (parseRelFile x)))- parseSucceeds x with =- parserTest parseRelDir x (Just with) --- | The 'dirname' operation.-operationDirname :: Spec-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 x y = dirname x == dirname y---- | The 'filename' operation.-operationFilename :: Spec-operationFilename =- 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 x y = filename x == filename y---- | The 'parent' operation.-operationParent :: Spec-operationParent =- do it "parent (parent </> child) == parent"- (parent ($(mkAbsDir "C:\\foo") </> $(mkRelDir "bar")) == $(mkAbsDir "C:\\foo"))- it "parent \"C:\\\" == \"C:\\\""- (parent $(mkAbsDir "C:\\") == $(mkAbsDir "C:\\"))- it "parent \"C:\\x\" == \"C:\\\""- (parent $(mkAbsDir "C:\\x") == $(mkAbsDir "C:\\"))- it "parent \"x\" == \".\""- (parent $(mkRelDir "x") == $(mkRelDir "."))- it "parent \".\" == \".\""- (parent $(mkRelDir ".") == $(mkRelDir "."))---- | The 'isProperPrefixOf' operation.-operationIsProperPrefixOf :: Spec-operationIsProperPrefixOf =- do it "isProperPrefixOf parent (parent </> child) (absolute)"- (isProperPrefixOf- $(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")))- 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 (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 = _|_"- (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"- (shouldBe- ($(mkAbsDir "C:\\home\\") </> $(mkRelDir "chris"))- $(mkAbsDir "C:\\home\\chris\\"))- it "AbsDir + RelFile = AbsFile"- (shouldBe- ($(mkAbsDir "C:\\home\\") </> $(mkRelFile "chris\\test.txt"))- $(mkAbsFile "C:\\home\\chris\\test.txt"))- it "RelDir + RelDir = RelDir"- (shouldBe- ($(mkRelDir "home\\") </> $(mkRelDir "chris"))- $(mkRelDir "home\\chris"))- it ". + . = ."- (shouldBe- ($(mkRelDir ".\\") </> $(mkRelDir "."))- $(mkRelDir "."))- it ". + x = x"- (shouldBe- ($(mkRelDir ".") </> $(mkRelDir "x"))- $(mkRelDir "x"))- it "x + . = x"- (shouldBe- ($(mkRelDir "x") </> $(mkRelDir ".\\"))- $(mkRelDir "x"))- it "RelDir + RelFile = RelFile"- (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 =- do it "toFilePath $(mkRelDir \".\") == \"./\""- (toFilePath $(mkRelDir ".") == ".\\")- it "show $(mkRelDir \".\") == \"\\\".\\\\\"\""- (show $(mkRelDir ".") == "\".\\\\\"")- -- | Tests for the tokenizer. parseAbsDirSpec :: Spec parseAbsDirSpec =@@ -334,22 +146,6 @@ where failing x = parserTest parseRelFile x Nothing succeeding x with = parserTest parseRelFile x (Just with)---- | Parser test.-parserTest :: (Show a1,Show a,Eq a1)- => (a -> Maybe a1) -> a -> Maybe a1 -> SpecWith ()-parserTest parser input expected =- it ((case expected of- Nothing -> "Failing: "- Just{} -> "Succeeding: ") ++- "Parsing " ++- show input ++- " " ++- case expected of- Nothing -> "should fail."- Just x -> "should succeed with: " ++ show x)- (actual `shouldBe` expected)- where actual = parser input -- | Tests for the 'ToJSON' and 'FromJSON' instances --
+ validity-test-ospath/Include.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wno-name-shadowing #-}++-- | Test suite.+module PLATFORM_NAME where++import OsPath.PLATFORM_NAME+import OsPath.Internal.PLATFORM_NAME+import System.OsPath.PLATFORM_NAME (PLATFORM_PATH)+import Test.Hspec+import Test.QuickCheck+import Test.Validity++import OsPath.Gen.PLATFORM_NAME ()+import qualified System.OsString.Compat.PLATFORM_NAME as OsString++-- | Test suite entry point, returns exit failure if any test fails.+main :: IO ()+main = hspec spec++-- | Test suite.+spec :: Spec+spec =+ describe PLATFORM_NAME_STRING $ 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)+ genValidSpec @(SomeBase Dir)+ shrinkValidSpec @(SomeBase Dir)+ genValidSpec @(SomeBase File)+ shrinkValidSpec @(SomeBase File)+ 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 "SomeBase Dir" (parserSpec parseSomeDir)+ describe "SomeBase file" (parserSpec parseSomeFile)+ describe "Operations" $ do+ describe "(</>)" operationAppend+ describe "stripProperPrefix" operationStripDir+ describe "isProperPrefixOf" operationIsParentOf+ describe "parent" operationParent+ describe "splitDrive" operationSplitDrive+ describe "takeDrive" operationTakeDrive+ describe "filename" operationFilename+ describe "dirname" operationDirname+ describe "Extensions" extensionsSpec++-- | The 'filename' operation.+operationFilename :: Spec+operationFilename = do+ forAllDirs "filename (parent </> $(mkRelFile filename)) == filename $(mkRelFile filename)" $ \parent ->+ forAllValid $ \file -> filename (parent </> file) `shouldBe` filename file+ forSomeDirs "filename (some:parent </> $(mkRelFile filename)) == filename $(mkRelFile filename)" $ \someParent ->+ forAllValid $ \file ->+ prjSomeBase filename (mapSomeBase (</> file) someParent) `shouldBe` filename file+ it "produces a valid path on when passed a valid absolute path" $ do+ producesValid (filename :: Path Abs File -> Path Rel File)+ it "produces a valid path on when passed a valid relative path" $ do+ producesValid (filename :: Path Rel File -> Path Rel File)+ it "produces a valid filename when passed some valid base path" $+ producesValid (prjSomeBase filename :: SomeBase 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 OsString.empty then pure () else dirname (parent </> dir) `shouldBe` dirname dir+ forSomeDirs "dirname (some:parent </> $(mkRelDir dirname)) == dirname $(mkRelDir dirname)" $ \someParent ->+ forAllValid $ \dir -> if dir == Path OsString.empty+ then pure ()+ else prjSomeBase dirname (mapSomeBase (</> dir) someParent) `shouldBe` dirname dir+ it "produces a valid path on when passed a valid absolute path" $ do+ producesValid (dirname :: Path Abs Dir -> Path Rel Dir)+ it "produces a valid path on when passed a valid relative path" $ do+ producesValid (dirname :: Path Rel Dir -> Path Rel Dir)+ it "produces a valid path when passed some valid longer path" $+ producesValid (prjSomeBase dirname :: SomeBase Dir -> Path Rel Dir)++-- | The 'parent' operation.+operationParent :: Spec+operationParent = do+ it "produces a valid path on when passed a valid file path" $ do+ producesValid (parent :: Path Abs File -> Path Abs Dir)+ it "produces a valid path on when passed a valid directory path" $ do+ producesValid (parent :: Path Abs Dir -> Path Abs Dir)+ it "produces a valid path on when passed a valid abs file path" $ do+ producesValid (parent :: Path Abs File -> Path Abs Dir)+ it "produces a valid path on when passed a valid rel file path" $ do+ producesValid (parent :: Path Rel File -> Path Rel Dir)+ it "produces a valid path on when passed a valid abs directory path" $ do+ producesValid (parent :: Path Abs Dir -> Path Abs Dir)+ it "produces a valid path on when passed a valid rel directory path" $ do+ producesValid (parent :: Path Rel Dir -> Path Rel Dir)++-- | The 'splitDrive' operation.+operationSplitDrive :: Spec+operationSplitDrive = do+ it "produces valid paths on when passed a valid directory path" $ do+ producesValid (splitDrive :: Path Abs Dir -> (Path Abs Dir, Maybe (Path Rel Dir)))+ it "produces valid paths on when passed a valid file path" $ do+ producesValid (splitDrive :: Path Abs File -> (Path Abs Dir, Maybe (Path Rel File)))++-- | The 'takeDrive' operation.+operationTakeDrive :: Spec+operationTakeDrive = do+ it "produces a valid path on when passed a valid directory path" $ do+ producesValid (takeDrive :: Path Abs Dir -> Path Abs Dir)+ it "produces a valid path on when passed a valid file path" $ do+ producesValid (takeDrive :: Path Abs File -> Path Abs Dir)++-- | The 'isProperPrefixOf' operation.+operationIsParentOf :: Spec+operationIsParentOf = do+ forAllParentsAndChildren "isProperPrefixOf parent (parent </> child)" $ \parent child ->+ if child == Path OsString.empty+ then True -- TODO do we always need this condition?+ else isProperPrefixOf parent (parent </> child)++-- | The 'stripProperPrefix' operation.+operationStripDir :: Spec+operationStripDir = do+ forAllParentsAndChildren "stripProperPrefix parent (parent </> child) = child" $ \parent child ->+ if child == Path OsString.empty+ 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+ producesValid2+ (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+ producesValid2+ (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+ producesValid2+ (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+ producesValid2+ (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+ producesValid2 ((</>) :: Path Abs Dir -> Path Rel File -> Path Abs File)+ it "produces a valid path on when creating valid absolute directory paths" $ do+ producesValid2 ((</>) :: Path Abs Dir -> Path Rel Dir -> Path Abs Dir)+ it "produces a valid path on when creating valid relative file paths" $ do+ producesValid2 ((</>) :: Path Rel Dir -> Path Rel File -> Path Rel File)+ it "produces a valid path on when creating valid relative directory paths" $ do+ producesValid2 ((</>) :: Path Rel Dir -> Path Rel Dir -> Path Rel Dir)++extensionsSpec :: Spec+extensionsSpec = do+ let addExtGensValidFile p =+ case addExtension p $(mkRelFile [OsString.pstr|x|]) of+ Nothing -> True+ Just _ ->+ case parseRelFile p of+ Nothing -> False+ _ -> True+ it "if addExtension a b succeeds then parseRelFile b succeeds - 1" $+ forAll genValid addExtGensValidFile+ -- skew the generated path towards a valid extension by prefixing a "."+ it "if addExtension a b succeeds then parseRelFile b succeeds - 2" $+ forAll genValid $ addExtGensValidFile . ([OsString.pstr|.|] <>)+ forAllFiles "Adding an extension is like adding the extension to the end if it succeeds" $ \file ->+ forAllValid $ \ext ->+ case addExtension ext file of+ Nothing -> pure () -- Fine+ Just p -> toOsPath p `shouldBe` toOsPath file <> ext+ forAllFiles "splitExtension output joins to result in the original file" $ \file ->+ case splitExtension file of+ Nothing -> pure ()+ Just (f, ext) -> toOsPath f <> ext `shouldBe` toOsPath 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 (toOsPath f) of+ Nothing ->+ case parseAbsFile (toOsPath 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 "an extension that was added can be split off again" $ \file ->+ forAllValid $ \ext ->+ case addExtension ext file of+ Nothing -> pure () -- Fine+ Just p -> splitExtension p `shouldBe` Just (file, ext)+ forAllFiles "fileExtension == (fmap snd) . splitExtension" $ \file ->+ case splitExtension file of+ Nothing -> pure ()+ Just (_, ext) -> fileExtension file `shouldBe` Just ext+ forAllFiles "an extension that was added is considered to be there" $ \file ->+ forAllValid $ \ext ->+ case addExtension ext file of+ Nothing -> pure () -- Fine+ Just p -> fileExtension p `shouldBe` Just ext+ forAllFiles "(fileExtension >=> flip replaceExtension file) file == return file" $ \file ->+ case fileExtension file of+ Nothing -> pure ()+ Just ext -> replaceExtension ext file `shouldBe` Just 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++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++forSomeDirs :: Testable a => String -> (SomeBase Dir -> a) -> Spec+forSomeDirs n func = do+ it (unwords [n, "SomeBase Dir"]) $ forAllValid $ \(parent :: SomeBase 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) => (PLATFORM_PATH -> Maybe p) -> Spec+parserSpec parser =+ it "Produces valid paths when it succeeds" $+ forAllShrink genValid shrinkValid $ \path ->+ case parser path of+ Nothing -> pure ()+ Just p ->+ case prettyValidate p of+ Left err -> expectationFailure err+ Right _ -> pure ()
+ validity-test-ospath/Main.hs view
@@ -0,0 +1,21 @@+-- | Test suite.+module Main (main) where++import Test.Hspec+import Test.Hspec.QuickCheck (modifyMaxShrinks)++import qualified Posix+--import qualified Windows++-- | Test suite entry point, returns exit failure if any test fails.+main :: IO ()+main = hspec spec++-- | Test suite.+spec :: Spec+spec =+ modifyMaxShrinks (const 100) $+ parallel $ do+ Posix.spec+ -- See https://github.com/commercialhaskell/path/issues/74+ -- Windows.spec
+ validity-test-ospath/OsPath/Gen/Include.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module OsPath.Gen.PLATFORM_NAME where++import Data.Functor+import Prelude++import OsPath.PLATFORM_NAME+import OsPath.Internal.PLATFORM_NAME++import Data.GenValidity+import Data.Maybe (mapMaybe)+import Data.Validity.ByteString ()+import Data.Word (PLATFORM_WORD)+import System.OsPath.PLATFORM_NAME (PLATFORM_PATH)+import qualified System.OsPath.PLATFORM_NAME as OsPath+import Test.QuickCheck++import System.OsString.Compat.PLATFORM_NAME (PLATFORM_CHAR(..))+import qualified System.OsString.Compat.PLATFORM_NAME as OsString++instance Validity (Path Abs File) where+ validate p@(Path fp) =+ mconcat+ [ validateCommon p,+ validateAbs p,+ validateFile p,+ declare "The path can be identically parsed as an absolute file path." $+ parseAbsFile fp == Just p+ ]++instance Validity (Path Rel File) where+ validate p@(Path fp) =+ mconcat+ [ validateCommon p,+ validateRel p,+ validateFile p,+ declare "The path can be identically parsed as a relative file path." $+ parseRelFile fp == Just p+ ]++instance Validity (Path Abs Dir) where+ validate p@(Path fp) =+ mconcat+ [ validateCommon p,+ validateAbs p,+ validateDirectory p,+ declare "The path can be identically parsed as an absolute directory path." $+ parseAbsDir fp == Just p+ ]++instance Validity (Path Rel Dir) where+ validate p@(Path fp) =+ mconcat+ [ validateCommon p,+ validateRel p,+ validateDirectory p,+ declare "The path can be identically parsed as a relative directory path if it's not empty." $+ parseRelDir fp == Just p || OsString.null fp+ ]++instance Validity (SomeBase Dir)++instance Validity (SomeBase File)++instance GenValid (Path Abs File) where+ genValid = (Path . ([OsString.pstr|/|] <>) <$> genValid) `suchThat` isValid+ shrinkValid = filter isValid . shrinkValidWith parseAbsFile++instance GenValid (Path Abs Dir) where+ genValid = (Path . ([OsString.pstr|/|] <>) . (<> OsString.singleton OsPath.pathSeparator) <$> genValid) `suchThat` isValid+ shrinkValid = filter isValid . shrinkValidWith parseAbsDir++instance GenValid (Path Rel File) where+ genValid = (Path <$> genValid) `suchThat` isValid+ shrinkValid = filter isValid . shrinkValidWith parseRelFile++instance GenValid (Path Rel Dir) where+ genValid = (Path . (<> OsString.singleton OsPath.pathSeparator) <$> genValid) `suchThat` isValid+ shrinkValid = filter isValid . shrinkValidWith parseRelDir++instance GenValid (SomeBase Dir) where+ genValid = genValidStructurallyWithoutExtraChecking+ shrinkValid = shrinkValidStructurallyWithoutExtraFiltering++instance GenValid (SomeBase File) where+ genValid = genValidStructurallyWithoutExtraChecking+ shrinkValid = shrinkValidStructurallyWithoutExtraFiltering++validateCommon :: Path b t -> Validation+validateCommon (Path fp) = mconcat+ [ declare "System.FilePath considers the path valid if it's not empty." $+ OsPath.isValid fp || OsString.null fp+ , declare "The path does not contain a '..' path component." $+ not (hasParentDir fp)+ ]++validateDirectory :: Path b Dir -> Validation+validateDirectory (Path fp) = mconcat+ [ declare "The path has a trailing path separator if it's not empty." $+ OsPath.hasTrailingPathSeparator fp || OsString.null fp+ ]++validateFile :: Path b File -> Validation+validateFile (Path fp) = mconcat+ [ declare "The path has no trailing path separator." $+ not (OsPath.hasTrailingPathSeparator fp)+ , declare "The path does not equal \".\"" $+ fp /= [OsString.pstr|.|]+ , declare "The path does not end in /." $+ not ([OsString.pstr|/.|] `OsString.isSuffixOf` fp)+ ]++validateAbs :: Path Abs t -> Validation+validateAbs (Path fp) = mconcat+ [ declare "The path is absolute." $+ OsPath.isAbsolute fp+ ]++validateRel :: Path Rel t -> Validation+validateRel (Path fp) = mconcat+ [ declare "The path is relative." $+ OsPath.isRelative fp+ ]++shrinkValidWith :: (PLATFORM_PATH -> Maybe (Path a b)) -> Path a b -> [Path a b]+shrinkValidWith fun (Path f) = filter (/= Path f) . mapMaybe fun $ shrinkValid f++--------------------------------------------------------------------------------+-- Orphan instances++deriving via PLATFORM_WORD instance GenValid PLATFORM_CHAR+deriving via PLATFORM_WORD instance Validity PLATFORM_CHAR++-- | Generates PLATFORM_PATH_SINGLE with a high occurence of+-- 'OsPath.extSeparator' and 'OsPath.pathSeparators' characters. The resulting+-- paths are not guaranteed to be valid in the sense of 'OsPath.isValid'.+instance GenValid PLATFORM_PATH where+ genValid = OsPath.pack <$> listOf (frequency+ [ (2, genValid)+ , (1, elements (OsPath.extSeparator : OsPath.pathSeparators))+ ]+ )+ shrinkValid ospath =+ let (drive, relative) = OsPath.splitDrive ospath+ shrinkedWithoutDrive =+ map OsPath.pack+ . shrinkValid+ . OsPath.unpack+ $ relative+ shrinkedWithDrive =+ if OsString.null drive+ then []+ else map (drive <>) shrinkedWithoutDrive+ in+ shrinkedWithDrive <> shrinkedWithoutDrive++instance Validity PLATFORM_PATH
+ validity-test-ospath/OsPath/Gen/Posix.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE CPP #-}++#define PLATFORM_NAME Posix+#define PLATFORM_PATH PosixPath+#define PLATFORM_PATH_SINGLE 'PosixPath'+#define PLATFORM_CHAR PosixChar+#define PLATFORM_WORD Word8+#include "Include.hs"
+ validity-test-ospath/OsPath/Gen/Windows.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE CPP #-}++#define PLATFORM_NAME Windows+#define PLATFORM_PATH WindowsPath+#define PLATFORM_PATH_SINGLE 'WindowsPath'+#define PLATFORM_CHAR WindowsChar+#define PLATFORM_WORD Word16+#include "Include.hs"
+ validity-test-ospath/Posix.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE CPP #-}++#define PLATFORM_NAME Posix+#define PLATFORM_NAME_STRING "Posix"+#define PLATFORM_PATH PosixPath+#include "Include.hs"
+ validity-test-ospath/Windows.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE CPP #-}++#define PLATFORM_NAME Windows+#define PLATFORM_NAME_STRING "Windows"+#define PLATFORM_PATH WindowsPath+#include "Include.hs"
+ validity-test/Main.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++-- | Test suite.+module Main (main) where++import Path+import Path.Internal+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck+import Test.Validity++import Path.Gen++-- | Test suite entry point, returns exit failure if any test fails.+main :: IO ()+main = hspec spec++-- | Test suite.+spec :: Spec+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)+ genValidSpec @(SomeBase Dir)+ shrinkValidSpec @(SomeBase Dir)+ genValidSpec @(SomeBase File)+ shrinkValidSpec @(SomeBase File)+ 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 "SomeBase Dir" (parserSpec parseSomeDir)+ describe "SomeBase file" (parserSpec parseSomeFile)+ describe "Operations" $ do+ describe "(</>)" operationAppend+ describe "stripProperPrefix" operationStripDir+ describe "isProperPrefixOf" operationIsParentOf+ describe "parent" operationParent+ describe "splitDrive" operationSplitDrive+ describe "takeDrive" operationTakeDrive+ describe "filename" operationFilename+ describe "dirname" operationDirname+ describe "Extensions" extensionsSpec++-- | The 'filename' operation.+operationFilename :: Spec+operationFilename = do+ forAllDirs "filename (parent </> $(mkRelFile filename)) == filename $(mkRelFile filename)" $ \parent ->+ forAllValid $ \file -> filename (parent </> file) `shouldBe` filename file+ forSomeDirs "filename (some:parent </> $(mkRelFile filename)) == filename $(mkRelFile filename)" $ \someParent ->+ forAllValid $ \file ->+ prjSomeBase filename (mapSomeBase (</> file) someParent) `shouldBe` filename file+ it "produces a valid path on when passed a valid absolute path" $ do+ producesValid (filename :: Path Abs File -> Path Rel File)+ it "produces a valid path on when passed a valid relative path" $ do+ producesValid (filename :: Path Rel File -> Path Rel File)+ it "produces a valid filename when passed some valid base path" $+ producesValid (prjSomeBase filename :: SomeBase 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+ forSomeDirs "dirname (some:parent </> $(mkRelDir dirname)) == dirname $(mkRelDir dirname)" $ \someParent ->+ forAllValid $ \dir -> if dir == Path []+ then pure ()+ else prjSomeBase dirname (mapSomeBase (</> dir) someParent) `shouldBe` dirname dir+ it "produces a valid path on when passed a valid absolute path" $ do+ producesValid (dirname :: Path Abs Dir -> Path Rel Dir)+ it "produces a valid path on when passed a valid relative path" $ do+ producesValid (dirname :: Path Rel Dir -> Path Rel Dir)+ it "produces a valid path when passed some valid longer path" $+ producesValid (prjSomeBase dirname :: SomeBase Dir -> Path Rel Dir)++-- | The 'parent' operation.+operationParent :: Spec+operationParent = do+ it "produces a valid path on when passed a valid file path" $ do+ producesValid (parent :: Path Abs File -> Path Abs Dir)+ it "produces a valid path on when passed a valid directory path" $ do+ producesValid (parent :: Path Abs Dir -> Path Abs Dir)+ it "produces a valid path on when passed a valid abs file path" $ do+ producesValid (parent :: Path Abs File -> Path Abs Dir)+ it "produces a valid path on when passed a valid rel file path" $ do+ producesValid (parent :: Path Rel File -> Path Rel Dir)+ it "produces a valid path on when passed a valid abs directory path" $ do+ producesValid (parent :: Path Abs Dir -> Path Abs Dir)+ it "produces a valid path on when passed a valid rel directory path" $ do+ producesValid (parent :: Path Rel Dir -> Path Rel Dir)++-- | The 'splitDrive' operation.+operationSplitDrive :: Spec+operationSplitDrive = do+ it "produces valid paths on when passed a valid directory path" $ do+ producesValid (splitDrive :: Path Abs Dir -> (Path Abs Dir, Maybe (Path Rel Dir)))+ it "produces valid paths on when passed a valid file path" $ do+ producesValid (splitDrive :: Path Abs File -> (Path Abs Dir, Maybe (Path Rel File)))++-- | The 'takeDrive' operation.+operationTakeDrive :: Spec+operationTakeDrive = do+ it "produces a valid path on when passed a valid directory path" $ do+ producesValid (takeDrive :: Path Abs Dir -> Path Abs Dir)+ it "produces a valid path on when passed a valid file path" $ do+ producesValid (takeDrive :: Path Abs File -> Path Abs Dir)++-- | The 'isProperPrefixOf' operation.+operationIsParentOf :: Spec+operationIsParentOf = do+ 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+ 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+ producesValid2+ (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+ producesValid2+ (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+ producesValid2+ (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+ producesValid2+ (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+ producesValid2 ((</>) :: Path Abs Dir -> Path Rel File -> Path Abs File)+ it "produces a valid path on when creating valid absolute directory paths" $ do+ producesValid2 ((</>) :: Path Abs Dir -> Path Rel Dir -> Path Abs Dir)+ it "produces a valid path on when creating valid relative file paths" $ do+ producesValid2 ((</>) :: Path Rel Dir -> Path Rel File -> Path Rel File)+ it "produces a valid path on when creating valid relative directory paths" $ do+ producesValid2 ((</>) :: Path Rel Dir -> Path Rel Dir -> Path Rel Dir)++extensionsSpec :: Spec+extensionsSpec = do+ let addExtGensValidFile p =+ case addExtension p $(mkRelFile "x") of+ Nothing -> True+ Just _ ->+ case parseRelFile p of+ Nothing -> False+ _ -> True+ 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 "Adding an extension is like adding the extension to the end if it succeeds" $ \file ->+ forAllValid $ \ext ->+ case addExtension ext file of+ Nothing -> pure () -- Fine+ Just p -> toFilePath p `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 "an extension that was added can be split off again" $ \file ->+ forAllValid $ \ext ->+ case addExtension ext file of+ Nothing -> pure () -- Fine+ Just p -> splitExtension p `shouldBe` Just (file, ext)+ forAllFiles "fileExtension == (fmap snd) . splitExtension" $ \file ->+ case splitExtension file of+ Nothing -> pure ()+ Just (_, ext) -> fileExtension file `shouldBe` Just ext+ forAllFiles "an extension that was added is considered to be there" $ \file ->+ forAllValid $ \ext ->+ case addExtension ext file of+ Nothing -> pure () -- Fine+ Just p -> fileExtension p `shouldBe` Just ext+ forAllFiles "(fileExtension >=> flip replaceExtension file) file == return file" $ \file ->+ case fileExtension file of+ Nothing -> pure ()+ Just ext -> replaceExtension ext file `shouldBe` Just 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++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++forSomeDirs :: Testable a => String -> (SomeBase Dir -> a) -> Spec+forSomeDirs n func = do+ it (unwords [n, "SomeBase Dir"]) $ forAllValid $ \(parent :: SomeBase 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++parserSpec :: (Show p, Validity p) => (FilePath -> Maybe p) -> Spec+parserSpec parser =+ it "Produces valid paths when it succeeds" $+ forAllShrink genFilePath shrinkValid $ \path ->+ case parser path of+ Nothing -> pure ()+ Just p ->+ case prettyValidate p of+ Left err -> expectationFailure err+ Right _ -> pure ()
+ validity-test/Path/Gen.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Path.Gen where++import Data.Functor+import Prelude++import Path+import Path.Internal++import qualified System.FilePath as FilePath++import Data.GenValidity+import Data.List (isSuffixOf)+import Data.Maybe (mapMaybe)++import Test.QuickCheck++instance Validity (Path Abs File) where+ validate p@(Path fp) =+ mconcat+ [ validateCommon p,+ validateAbs p,+ validateFile p,+ declare "The path can be identically parsed as an absolute file path." $+ parseAbsFile fp == Just p+ ]++instance Validity (Path Rel File) where+ validate p@(Path fp) =+ mconcat+ [ validateCommon p,+ validateRel p,+ validateFile p,+ declare "The path can be identically parsed as a relative file path." $+ parseRelFile fp == Just p+ ]++instance Validity (Path Abs Dir) where+ validate p@(Path fp) =+ mconcat+ [ validateCommon p,+ validateAbs p,+ validateDirectory p,+ declare "The path can be identically parsed as an absolute directory path." $+ parseAbsDir fp == Just p+ ]++instance Validity (Path Rel Dir) where+ validate p@(Path fp) =+ mconcat+ [ validateCommon p,+ validateRel p,+ validateDirectory p,+ declare "The path can be identically parsed as a relative directory path if it's not empty." $+ parseRelDir fp == Just p || fp == ""+ ]++instance Validity (SomeBase Dir)++instance Validity (SomeBase File)++validateCommon :: Path b t -> Validation+validateCommon (Path fp) = mconcat+ [ declare "System.FilePath considers the path valid if it's not empty." $ FilePath.isValid fp || fp == ""+ , declare "The path does not contain a '..' path component." $ not (hasParentDir fp)+ ]++validateDirectory :: Path b Dir -> Validation+validateDirectory (Path fp) = mconcat+ [ declare "The path has a trailing path separator if it's not empty." $ FilePath.hasTrailingPathSeparator fp || fp == ""+ ]++validateFile :: Path b File -> Validation+validateFile (Path fp) = mconcat+ [ declare "The path has no trailing path separator." $ not (FilePath.hasTrailingPathSeparator fp)+ , declare "The path does not equal \".\"" $ fp /= "."+ , declare "The path does not end in /." $ not ("/." `isSuffixOf` fp)+ ]++validateAbs :: Path Abs t -> Validation+validateAbs (Path fp) = mconcat+ [ declare "The path is absolute." $ FilePath.isAbsolute fp+ ]++validateRel :: Path Rel t -> Validation+validateRel (Path fp) = mconcat+ [ declare "The path is relative." $ FilePath.isRelative fp+ ]++instance GenValid (Path Abs File) where+ genValid = (Path . ('/' :) <$> genFilePath) `suchThat` isValid+ shrinkValid = filter isValid . shrinkValidWith parseAbsFile++instance GenValid (Path Abs Dir) where+ genValid = (Path . ('/' :) . (++ "/") <$> genFilePath) `suchThat` isValid+ shrinkValid = filter isValid . shrinkValidWith parseAbsDir++instance GenValid (Path Rel File) where+ genValid = (Path <$> genFilePath) `suchThat` isValid+ shrinkValid = filter isValid . shrinkValidWith parseRelFile++instance GenValid (Path Rel Dir) where+ genValid = (Path . (++ "/") <$> genFilePath) `suchThat` isValid+ shrinkValid = filter isValid . shrinkValidWith parseRelDir++instance GenValid (SomeBase Dir) where+ genValid = genValidStructurallyWithoutExtraChecking+ shrinkValid = shrinkValidStructurallyWithoutExtraFiltering++instance GenValid (SomeBase File) where+ genValid = genValidStructurallyWithoutExtraChecking+ shrinkValid = shrinkValidStructurallyWithoutExtraFiltering++-- | Generates 'FilePath's with a high occurence of @'.'@, @'\/'@ and+-- @'\\'@ characters. The resulting 'FilePath's are not guaranteed to+-- be valid.+genFilePath :: Gen FilePath+genFilePath = listOf genPathyChar++genPathyChar :: Gen Char+genPathyChar = frequency [(2, choose (minBound, maxBound)), (1, elements "./\\")]++shrinkValidWith :: (FilePath -> Maybe (Path a b)) -> Path a b -> [Path a b]+shrinkValidWith fun (Path f) = filter (/= (Path f)) . mapMaybe fun $ shrinkValid f