diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,6 @@ # Path -[![Travis Build Status](https://travis-ci.org/commercialhaskell/path.svg)](https://travis-ci.org/commercialhaskell/path) -[![AppVeyor Build Status](https://ci.appveyor.com/api/projects/status/github/commercialhaskell/path?svg=true)](https://ci.appveyor.com/project/chrisdone/path) +![CI](https://github.com/commercialhaskell/path/workflows/CI/badge.svg?branch=master) [![Hackage](https://img.shields.io/hackage/v/path.svg)](https://hackage.haskell.org/package/path) [![Stackage LTS](http://stackage.org/package/path/badge/lts)](http://stackage.org/lts/package/path) [![Stackage Nightly](http://stackage.org/package/path/badge/nightly)](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 diff --git a/os-string-compat/System/OsString/Compat/Include.hs b/os-string-compat/System/OsString/Compat/Include.hs new file mode 100644 --- /dev/null +++ b/os-string-compat/System/OsString/Compat/Include.hs @@ -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 diff --git a/os-string-compat/System/OsString/Compat/Posix.hs b/os-string-compat/System/OsString/Compat/Posix.hs new file mode 100644 --- /dev/null +++ b/os-string-compat/System/OsString/Compat/Posix.hs @@ -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" diff --git a/os-string-compat/System/OsString/Compat/Windows.hs b/os-string-compat/System/OsString/Compat/Windows.hs new file mode 100644 --- /dev/null +++ b/os-string-compat/System/OsString/Compat/Windows.hs @@ -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" diff --git a/path.cabal b/path.cabal --- a/path.cabal +++ b/path.cabal @@ -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 maintainer: Chris Done 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 diff --git a/src/OsPath.hs b/src/OsPath.hs new file mode 100644 --- /dev/null +++ b/src/OsPath.hs @@ -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 diff --git a/src/OsPath/Include.hs b/src/OsPath/Include.hs new file mode 100644 --- /dev/null +++ b/src/OsPath/Include.hs @@ -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 diff --git a/src/OsPath/Internal.hs b/src/OsPath/Internal.hs new file mode 100644 --- /dev/null +++ b/src/OsPath/Internal.hs @@ -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 diff --git a/src/OsPath/Internal/Include.hs b/src/OsPath/Internal/Include.hs new file mode 100644 --- /dev/null +++ b/src/OsPath/Internal/Include.hs @@ -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 #-} diff --git a/src/OsPath/Internal/Posix.hs b/src/OsPath/Internal/Posix.hs new file mode 100644 --- /dev/null +++ b/src/OsPath/Internal/Posix.hs @@ -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" diff --git a/src/OsPath/Internal/Windows.hs b/src/OsPath/Internal/Windows.hs new file mode 100644 --- /dev/null +++ b/src/OsPath/Internal/Windows.hs @@ -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" diff --git a/src/OsPath/Posix.hs b/src/OsPath/Posix.hs new file mode 100644 --- /dev/null +++ b/src/OsPath/Posix.hs @@ -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" diff --git a/src/OsPath/Windows.hs b/src/OsPath/Windows.hs new file mode 100644 --- /dev/null +++ b/src/OsPath/Windows.hs @@ -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" diff --git a/src/Path/Include.hs b/src/Path/Include.hs --- a/src/Path/Include.hs +++ b/src/Path/Include.hs @@ -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 diff --git a/src/Path/Internal.hs b/src/Path/Internal.hs --- a/src/Path/Internal.hs +++ b/src/Path/Internal.hs @@ -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 diff --git a/src/Path/Internal/Include.hs b/src/Path/Internal/Include.hs new file mode 100644 --- /dev/null +++ b/src/Path/Internal/Include.hs @@ -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 #-} diff --git a/src/Path/Internal/Posix.hs b/src/Path/Internal/Posix.hs new file mode 100644 --- /dev/null +++ b/src/Path/Internal/Posix.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE CPP #-} +#define PLATFORM_NAME Posix +#define IS_WINDOWS 0 +#include "Include.hs" diff --git a/src/Path/Internal/Windows.hs b/src/Path/Internal/Windows.hs new file mode 100644 --- /dev/null +++ b/src/Path/Internal/Windows.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE CPP #-} +#define PLATFORM_NAME Windows +#define IS_WINDOWS 1 +#include "Include.hs" diff --git a/src/Path/Posix.hs b/src/Path/Posix.hs --- a/src/Path/Posix.hs +++ b/src/Path/Posix.hs @@ -1,4 +1,3 @@ {-# LANGUAGE CPP #-} #define PLATFORM_NAME Posix -#define IS_WINDOWS False #include "Include.hs" diff --git a/src/Path/Windows.hs b/src/Path/Windows.hs --- a/src/Path/Windows.hs +++ b/src/Path/Windows.hs @@ -1,4 +1,3 @@ {-# LANGUAGE CPP #-} #define PLATFORM_NAME Windows -#define IS_WINDOWS True #include "Include.hs" diff --git a/test-ospath/Common/Include.hs b/test-ospath/Common/Include.hs new file mode 100644 --- /dev/null +++ b/test-ospath/Common/Include.hs @@ -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 diff --git a/test-ospath/Common/Posix.hs b/test-ospath/Common/Posix.hs new file mode 100644 --- /dev/null +++ b/test-ospath/Common/Posix.hs @@ -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|/|] diff --git a/test-ospath/Common/Windows.hs b/test-ospath/Common/Windows.hs new file mode 100644 --- /dev/null +++ b/test-ospath/Common/Windows.hs @@ -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 + ] diff --git a/test-ospath/Main.hs b/test-ospath/Main.hs new file mode 100644 --- /dev/null +++ b/test-ospath/Main.hs @@ -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 diff --git a/test-ospath/Posix.hs b/test-ospath/Posix.hs new file mode 100644 --- /dev/null +++ b/test-ospath/Posix.hs @@ -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|])) diff --git a/test-ospath/TH/Posix.hs b/test-ospath/TH/Posix.hs new file mode 100644 --- /dev/null +++ b/test-ospath/TH/Posix.hs @@ -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)) diff --git a/test-ospath/TH/Windows.hs b/test-ospath/TH/Windows.hs new file mode 100644 --- /dev/null +++ b/test-ospath/TH/Windows.hs @@ -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)) diff --git a/test-ospath/Windows.hs b/test-ospath/Windows.hs new file mode 100644 --- /dev/null +++ b/test-ospath/Windows.hs @@ -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|])) diff --git a/test/Common.hs b/test/Common.hs deleted file mode 100644 --- a/test/Common.hs +++ /dev/null @@ -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" - ] diff --git a/test/Common/Include.hs b/test/Common/Include.hs new file mode 100644 --- /dev/null +++ b/test/Common/Include.hs @@ -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 diff --git a/test/Common/Posix.hs b/test/Common/Posix.hs new file mode 100644 --- /dev/null +++ b/test/Common/Posix.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE CPP #-} + +#define PLATFORM_NAME Posix +#include "Include.hs" + +drives_ :: NonEmpty FilePath +drives_ = NonEmpty.singleton "/" diff --git a/test/Common/Windows.hs b/test/Common/Windows.hs new file mode 100644 --- /dev/null +++ b/test/Common/Windows.hs @@ -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 + ] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 diff --git a/test/Path/Gen.hs b/test/Path/Gen.hs deleted file mode 100644 --- a/test/Path/Gen.hs +++ /dev/null @@ -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) diff --git a/test/Posix.hs b/test/Posix.hs --- a/test/Posix.hs +++ b/test/Posix.hs @@ -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 -- diff --git a/test/TH.hs b/test/TH.hs deleted file mode 100644 --- a/test/TH.hs +++ /dev/null @@ -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)) diff --git a/test/TH/Posix.hs b/test/TH/Posix.hs new file mode 100644 --- /dev/null +++ b/test/TH/Posix.hs @@ -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)) diff --git a/test/TH/Windows.hs b/test/TH/Windows.hs new file mode 100644 --- /dev/null +++ b/test/TH/Windows.hs @@ -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)) diff --git a/test/ValidityTest.hs b/test/ValidityTest.hs deleted file mode 100644 --- a/test/ValidityTest.hs +++ /dev/null @@ -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 () diff --git a/test/Windows.hs b/test/Windows.hs --- a/test/Windows.hs +++ b/test/Windows.hs @@ -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 -- diff --git a/validity-test-ospath/Include.hs b/validity-test-ospath/Include.hs new file mode 100644 --- /dev/null +++ b/validity-test-ospath/Include.hs @@ -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 () diff --git a/validity-test-ospath/Main.hs b/validity-test-ospath/Main.hs new file mode 100644 --- /dev/null +++ b/validity-test-ospath/Main.hs @@ -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 diff --git a/validity-test-ospath/OsPath/Gen/Include.hs b/validity-test-ospath/OsPath/Gen/Include.hs new file mode 100644 --- /dev/null +++ b/validity-test-ospath/OsPath/Gen/Include.hs @@ -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 diff --git a/validity-test-ospath/OsPath/Gen/Posix.hs b/validity-test-ospath/OsPath/Gen/Posix.hs new file mode 100644 --- /dev/null +++ b/validity-test-ospath/OsPath/Gen/Posix.hs @@ -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" diff --git a/validity-test-ospath/OsPath/Gen/Windows.hs b/validity-test-ospath/OsPath/Gen/Windows.hs new file mode 100644 --- /dev/null +++ b/validity-test-ospath/OsPath/Gen/Windows.hs @@ -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" diff --git a/validity-test-ospath/Posix.hs b/validity-test-ospath/Posix.hs new file mode 100644 --- /dev/null +++ b/validity-test-ospath/Posix.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE CPP #-} + +#define PLATFORM_NAME Posix +#define PLATFORM_NAME_STRING "Posix" +#define PLATFORM_PATH PosixPath +#include "Include.hs" diff --git a/validity-test-ospath/Windows.hs b/validity-test-ospath/Windows.hs new file mode 100644 --- /dev/null +++ b/validity-test-ospath/Windows.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE CPP #-} + +#define PLATFORM_NAME Windows +#define PLATFORM_NAME_STRING "Windows" +#define PLATFORM_PATH WindowsPath +#include "Include.hs" diff --git a/validity-test/Main.hs b/validity-test/Main.hs new file mode 100644 --- /dev/null +++ b/validity-test/Main.hs @@ -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 () diff --git a/validity-test/Path/Gen.hs b/validity-test/Path/Gen.hs new file mode 100644 --- /dev/null +++ b/validity-test/Path/Gen.hs @@ -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