From a266326c5c8e419cea226bbbabfd12a0d4f4354a Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Tue, 18 Jun 2024 15:10:05 +0200 Subject: [PATCH 01/52] Removed .ghci file --- .ghci | 2 -- 1 file changed, 2 deletions(-) delete mode 100755 .ghci diff --git a/.ghci b/.ghci deleted file mode 100755 index 01c3587..0000000 --- a/.ghci +++ /dev/null @@ -1,2 +0,0 @@ -:set -package HUnit -package hspec -:set -package template-haskell From 23afae14e204d295ab95f4fe93201a90490731c9 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Thu, 20 Jun 2024 23:06:12 +0200 Subject: [PATCH 02/52] Added hie.yaml --- hie.yaml | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 hie.yaml diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 0000000..462fad5 --- /dev/null +++ b/hie.yaml @@ -0,0 +1,10 @@ +cradle: + cabal: + - path: "src" + component: "lib:path" + + - path: "test" + component: "path:test:test" + + - path: "test" + component: "path:test:validity-test" From ad55906e12b80f921bf5cb9958a3e8020c50f039 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Tue, 18 Jun 2024 15:24:40 +0200 Subject: [PATCH 03/52] Moved sources of validity-test to own directory --- hie.yaml | 2 +- path.cabal | 4 ++-- test/ValidityTest.hs => validity-test/Main.hs | 2 +- {test => validity-test}/Path/Gen.hs | 0 4 files changed, 4 insertions(+), 4 deletions(-) rename test/ValidityTest.hs => validity-test/Main.hs (99%) rename {test => validity-test}/Path/Gen.hs (100%) diff --git a/hie.yaml b/hie.yaml index 462fad5..1834e4f 100644 --- a/hie.yaml +++ b/hie.yaml @@ -6,5 +6,5 @@ cradle: - path: "test" component: "path:test:test" - - path: "test" + - path: "validity-test" component: "path:test:validity-test" diff --git a/path.cabal b/path.cabal index 81e83cd..15e7590 100644 --- a/path.cabal +++ b/path.cabal @@ -73,9 +73,9 @@ test-suite test test-suite validity-test type: exitcode-stdio-1.0 - main-is: ValidityTest.hs + main-is: Main.hs other-modules: Path.Gen - hs-source-dirs: test + hs-source-dirs: validity-test build-depends: QuickCheck , aeson , base >= 4.12 && < 5 diff --git a/test/ValidityTest.hs b/validity-test/Main.hs similarity index 99% rename from test/ValidityTest.hs rename to validity-test/Main.hs index a221e0b..2bd88df 100644 --- a/test/ValidityTest.hs +++ b/validity-test/Main.hs @@ -5,7 +5,7 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -- | Test suite. -module Main where +module Main (main) where import Data.Maybe import Path diff --git a/test/Path/Gen.hs b/validity-test/Path/Gen.hs similarity index 100% rename from test/Path/Gen.hs rename to validity-test/Path/Gen.hs From 6e9ca2527572b23daaa108a02258f314eb224a82 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Tue, 18 Jun 2024 16:10:53 +0200 Subject: [PATCH 04/52] Better use of IS_WINDOWS Suppresses redundant patterns warnings. --- src/Path/Include.hs | 40 +++++++++++++++++++++++----------------- src/Path/Posix.hs | 2 +- src/Path/Windows.hs | 2 +- 3 files changed, 25 insertions(+), 19 deletions(-) diff --git a/src/Path/Include.hs b/src/Path/Include.hs index 82d71bb..1ca20ae 100644 --- a/src/Path/Include.hs +++ b/src/Path/Include.hs @@ -1,6 +1,6 @@ -- This template expects CPP definitions for: -- PLATFORM_NAME = Posix | Windows --- IS_WINDOWS = False | True +-- IS_WINDOWS = 0 | 1 -- | This library provides a well-typed representation of paths in a filesystem -- directory tree. @@ -482,9 +482,11 @@ splitExtension (Path fpath) = trailingSeps = takeWhile isSep rstr xtn = (takeWhile notSep . dropWhile isSep) rstr in (reverse name, reverse xtn ++ trailingSeps) - normalizeDrive - | IS_WINDOWS = normalizeTrailingSeps - | otherwise = id +#if IS_WINDOWS + normalizeDrive = normalizeTrailingSeps +#else + normalizeDrive = id +#endif (drv, pth) = FilePath.splitDrive fpath (dir, file) = splitLast FilePath.isPathSeparator pth @@ -818,6 +820,17 @@ normalizeDir = | 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 + +#if IS_WINDOWS +-- | 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 [] @@ -833,22 +846,15 @@ normalizeWindowsSeps :: FilePath -> FilePath normalizeWindowsSeps path = normLeadingSeps ++ normalizeAllSeps rest where (leadingSeps, rest) = span FilePath.isPathSeparator path normLeadingSeps = replicate (min 2 (length leadingSeps)) FilePath.pathSeparator - --- | Normalizes seps only at the beginning of a path. -normalizeLeadingSeps :: FilePath -> FilePath -normalizeLeadingSeps path = normLeadingSep ++ rest - where (leadingSeps, rest) = span FilePath.isPathSeparator path - normLeadingSep = replicate (min 1 (length leadingSeps)) FilePath.pathSeparator - --- | Normalizes seps only at the end of a path. -normalizeTrailingSeps :: FilePath -> FilePath -normalizeTrailingSeps = reverse . normalizeLeadingSeps . reverse +#endif -- | Applies platform-specific sep normalization following @FilePath.normalise@. normalizeFilePath :: FilePath -> FilePath -normalizeFilePath - | IS_WINDOWS = normalizeWindowsSeps . FilePath.normalise - | otherwise = normalizeLeadingSeps . FilePath.normalise +#if IS_WINDOWS +normalizeFilePath = normalizeWindowsSeps . FilePath.normalise +#else +normalizeFilePath = normalizeLeadingSeps . FilePath.normalise +#endif -- | Path of some type. @t@ represents the type, whether file or -- directory. Pattern match to find whether the path is absolute or diff --git a/src/Path/Posix.hs b/src/Path/Posix.hs index 25e35e1..23a1b40 100644 --- a/src/Path/Posix.hs +++ b/src/Path/Posix.hs @@ -1,4 +1,4 @@ {-# LANGUAGE CPP #-} #define PLATFORM_NAME Posix -#define IS_WINDOWS False +#define IS_WINDOWS 0 #include "Include.hs" diff --git a/src/Path/Windows.hs b/src/Path/Windows.hs index a8b5cbb..95b16e4 100644 --- a/src/Path/Windows.hs +++ b/src/Path/Windows.hs @@ -1,4 +1,4 @@ {-# LANGUAGE CPP #-} #define PLATFORM_NAME Windows -#define IS_WINDOWS True +#define IS_WINDOWS 1 #include "Include.hs" From 7030cb86b2406199fc8d16d385a3d3d59f43fd0e Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Thu, 20 Jun 2024 15:18:22 +0200 Subject: [PATCH 05/52] Renamed the Foo type class to CheckInstantiated --- test/Common/Include.hs | 32 ++++++++++++++++++-------------- test/Common/Posix.hs | 12 ++++++------ test/Common/Windows.hs | 13 +++++++------ 3 files changed, 31 insertions(+), 26 deletions(-) diff --git a/test/Common/Include.hs b/test/Common/Include.hs index 64b5969..d3e8d26 100644 --- a/test/Common/Include.hs +++ b/test/Common/Include.hs @@ -1,10 +1,10 @@ -- This template expects CPP definitions for: -- PLATFORM_NAME = Posix | Windows --- IS_WINDOWS = False | True {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} -- | Test functions that are common to Posix and Windows @@ -17,32 +17,36 @@ import Path.PLATFORM_NAME import System.FilePath.PLATFORM_NAME (pathSeparator) import Test.Hspec -class Foo a b where - foo :: Path a b -> FilePath - foo = toFilePath +-- | This is a helper type class that checks that splices produce a 'Path' with +-- all type variables instantiated to a type. +-- This ensures that bugs like https://github.com/commercialhaskell/path/issues/159 +-- cannot happen. +class CheckInstantiated a b where + checkInstantiated :: Path a b -> FilePath + checkInstantiated = toFilePath -instance Foo Abs Dir -instance Foo Abs File -instance Foo Rel Dir -instance Foo Rel File +instance CheckInstantiated Abs Dir +instance CheckInstantiated Abs File +instance CheckInstantiated Rel Dir +instance CheckInstantiated Rel File qqRelDir :: FilePath -qqRelDir = foo [reldir|foo/|] +qqRelDir = checkInstantiated [reldir|foo/|] qqRelFile :: FilePath -qqRelFile = foo [relfile|foo|] +qqRelFile = checkInstantiated [relfile|foo|] thRelDir :: FilePath -thRelDir = foo $(mkRelDir "foo/") +thRelDir = checkInstantiated $(mkRelDir "foo/") thRelFile :: FilePath -thRelFile = foo $(mkRelFile "foo") +thRelFile = checkInstantiated $(mkRelFile "foo") liftRelDir :: FilePath -liftRelDir = foo $(TH.lift (Path "foo/" :: Path Rel Dir)) +liftRelDir = checkInstantiated $(TH.lift (Path "foo/" :: Path Rel Dir)) liftRelFile :: FilePath -liftRelFile = foo $(TH.lift (Path "foo" :: Path Rel File)) +liftRelFile = checkInstantiated $(TH.lift (Path "foo" :: Path Rel File)) validExtensionsSpec :: String -> Path b File -> Path b File -> Spec validExtensionsSpec ext file fext = do diff --git a/test/Common/Posix.hs b/test/Common/Posix.hs index a7217d5..0525933 100644 --- a/test/Common/Posix.hs +++ b/test/Common/Posix.hs @@ -6,19 +6,19 @@ #include "Include.hs" qqAbsDir :: FilePath -qqAbsDir = foo [absdir|/foo/|] +qqAbsDir = checkInstantiated [absdir|/foo/|] qqAbsFile :: FilePath -qqAbsFile = foo [absdir|/foo|] +qqAbsFile = checkInstantiated [absdir|/foo|] thAbsDir :: FilePath -thAbsDir = foo $(mkAbsDir "/foo/") +thAbsDir = checkInstantiated $(mkAbsDir "/foo/") thAbsFile :: FilePath -thAbsFile = foo $(mkAbsFile "/foo") +thAbsFile = checkInstantiated $(mkAbsFile "/foo") liftAbsDir :: FilePath -liftAbsDir = foo $(TH.lift (Path "/foo/" :: Path Abs Dir)) +liftAbsDir = checkInstantiated $(TH.lift (Path "/foo/" :: Path Abs Dir)) liftAbsFile :: FilePath -liftAbsFile = foo $(TH.lift (Path "/foo" :: Path Abs File)) +liftAbsFile = checkInstantiated $(TH.lift (Path "/foo" :: Path Abs File)) diff --git a/test/Common/Windows.hs b/test/Common/Windows.hs index 2d72f5b..138c048 100644 --- a/test/Common/Windows.hs +++ b/test/Common/Windows.hs @@ -1,24 +1,25 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} + #define PLATFORM_NAME Windows #define IS_WINDOWS True #include "Include.hs" qqAbsDir :: FilePath -qqAbsDir = foo [absdir|C:\foo\|] +qqAbsDir = checkInstantiated [absdir|C:\foo\|] qqAbsFile :: FilePath -qqAbsFile = foo [absdir|C:\foo|] +qqAbsFile = checkInstantiated [absdir|C:\foo|] thAbsDir :: FilePath -thAbsDir = foo $(mkAbsDir "C:\\foo\\") +thAbsDir = checkInstantiated $(mkAbsDir "C:\\foo\\") thAbsFile :: FilePath -thAbsFile = foo $(mkAbsFile "C:\\foo") +thAbsFile = checkInstantiated $(mkAbsFile "C:\\foo") liftAbsDir :: FilePath -liftAbsDir = foo $(TH.lift (Path "C:\\foo\\" :: Path Abs Dir)) +liftAbsDir = checkInstantiated $(TH.lift (Path "C:\\foo\\" :: Path Abs Dir)) liftAbsFile :: FilePath -liftAbsFile = foo $(TH.lift (Path "C:\\foo" :: Path Abs File)) +liftAbsFile = checkInstantiated $(TH.lift (Path "C:\\foo" :: Path Abs File)) From 1467bd37eb5441153e965a06e7500da225a6785e Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Thu, 20 Jun 2024 23:56:55 +0200 Subject: [PATCH 06/52] Testsuite test: Moved TH stuff to own modules --- path.cabal | 2 ++ test/Common/Include.hs | 35 -------------------------------- test/Common/Posix.hs | 22 +------------------- test/Common/Windows.hs | 23 +-------------------- test/Posix.hs | 1 + test/TH/Include.hs | 46 ++++++++++++++++++++++++++++++++++++++++++ test/TH/Posix.hs | 22 ++++++++++++++++++++ test/TH/Windows.hs | 22 ++++++++++++++++++++ test/Windows.hs | 1 + 9 files changed, 96 insertions(+), 78 deletions(-) create mode 100644 test/TH/Include.hs create mode 100644 test/TH/Posix.hs create mode 100644 test/TH/Windows.hs diff --git a/path.cabal b/path.cabal index 15e7590..26ac58b 100644 --- a/path.cabal +++ b/path.cabal @@ -56,6 +56,8 @@ test-suite test , Windows , Common.Posix , Common.Windows + , TH.Posix + , TH.Windows hs-source-dirs: test build-depends: aeson , base >= 4.12 && < 5 diff --git a/test/Common/Include.hs b/test/Common/Include.hs index d3e8d26..cded09e 100644 --- a/test/Common/Include.hs +++ b/test/Common/Include.hs @@ -1,53 +1,18 @@ -- This template expects CPP definitions for: -- PLATFORM_NAME = Posix | Windows -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-unused-top-binds #-} -- | Test functions that are common to Posix and Windows module Common.PLATFORM_NAME (extensionOperations) where import Control.Monad -import qualified Language.Haskell.TH.Syntax as TH import Path.Internal.PLATFORM_NAME import Path.PLATFORM_NAME import System.FilePath.PLATFORM_NAME (pathSeparator) import Test.Hspec --- | This is a helper type class that checks that splices produce a 'Path' with --- all type variables instantiated to a type. --- This ensures that bugs like https://github.com/commercialhaskell/path/issues/159 --- cannot happen. -class CheckInstantiated a b where - checkInstantiated :: Path a b -> FilePath - checkInstantiated = toFilePath - -instance CheckInstantiated Abs Dir -instance CheckInstantiated Abs File -instance CheckInstantiated Rel Dir -instance CheckInstantiated Rel File - -qqRelDir :: FilePath -qqRelDir = checkInstantiated [reldir|foo/|] - -qqRelFile :: FilePath -qqRelFile = checkInstantiated [relfile|foo|] - -thRelDir :: FilePath -thRelDir = checkInstantiated $(mkRelDir "foo/") - -thRelFile :: FilePath -thRelFile = checkInstantiated $(mkRelFile "foo") - -liftRelDir :: FilePath -liftRelDir = checkInstantiated $(TH.lift (Path "foo/" :: Path Rel Dir)) - -liftRelFile :: FilePath -liftRelFile = checkInstantiated $(TH.lift (Path "foo" :: Path Rel File)) - validExtensionsSpec :: String -> Path b File -> Path b File -> Spec validExtensionsSpec ext file fext = do let f = show $ toFilePath file diff --git a/test/Common/Posix.hs b/test/Common/Posix.hs index 0525933..6273b4b 100644 --- a/test/Common/Posix.hs +++ b/test/Common/Posix.hs @@ -1,24 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE QuasiQuotes #-} -#define PLATFORM_NAME Posix -#define IS_WINDOWS False +#define PLATFORM_NAME Posix #include "Include.hs" - -qqAbsDir :: FilePath -qqAbsDir = checkInstantiated [absdir|/foo/|] - -qqAbsFile :: FilePath -qqAbsFile = checkInstantiated [absdir|/foo|] - -thAbsDir :: FilePath -thAbsDir = checkInstantiated $(mkAbsDir "/foo/") - -thAbsFile :: FilePath -thAbsFile = checkInstantiated $(mkAbsFile "/foo") - -liftAbsDir :: FilePath -liftAbsDir = checkInstantiated $(TH.lift (Path "/foo/" :: Path Abs Dir)) - -liftAbsFile :: FilePath -liftAbsFile = checkInstantiated $(TH.lift (Path "/foo" :: Path Abs File)) diff --git a/test/Common/Windows.hs b/test/Common/Windows.hs index 138c048..2016c41 100644 --- a/test/Common/Windows.hs +++ b/test/Common/Windows.hs @@ -1,25 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE QuasiQuotes #-} -#define PLATFORM_NAME Windows -#define IS_WINDOWS True +#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/Posix.hs b/test/Posix.hs index a1b104d..ad1a25e 100644 --- a/test/Posix.hs +++ b/test/Posix.hs @@ -17,6 +17,7 @@ import Path.Internal.Posix import Test.Hspec import Common.Posix (extensionOperations) +import TH.Posix () -- | Test suite (Posix version). spec :: Spec diff --git a/test/TH/Include.hs b/test/TH/Include.hs new file mode 100644 index 0000000..3e1bf30 --- /dev/null +++ b/test/TH/Include.hs @@ -0,0 +1,46 @@ +-- This template expects CPP definitions for: +-- PLATFORM_NAME = Posix | Windows + +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +-- | Test functions to check the template haskell bits. +module TH.PLATFORM_NAME where + +import qualified Language.Haskell.TH.Syntax as TH + +import Path.Internal.PLATFORM_NAME +import Path.PLATFORM_NAME + +-- | This is a helper type class that checks that splices produce a 'Path' with +-- all type variables instantiated to a type. +-- This ensures that bugs like https://github.com/commercialhaskell/path/issues/159 +-- cannot happen. +class CheckInstantiated a b where + checkInstantiated :: Path a b -> FilePath + checkInstantiated = toFilePath + +instance CheckInstantiated Abs Dir +instance CheckInstantiated Abs File +instance CheckInstantiated Rel Dir +instance CheckInstantiated Rel File + +qqRelDir :: FilePath +qqRelDir = checkInstantiated [reldir|name/|] + +qqRelFile :: FilePath +qqRelFile = checkInstantiated [relfile|name|] + +thRelDir :: FilePath +thRelDir = checkInstantiated $(mkRelDir "name/") + +thRelFile :: FilePath +thRelFile = checkInstantiated $(mkRelFile "name") + +liftRelDir :: FilePath +liftRelDir = checkInstantiated $(TH.lift (Path "name/" :: Path Rel Dir)) + +liftRelFile :: FilePath +liftRelFile = checkInstantiated $(TH.lift (Path "name" :: Path Rel File)) diff --git a/test/TH/Posix.hs b/test/TH/Posix.hs new file mode 100644 index 0000000..a193382 --- /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 index 0000000..acf5c77 --- /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/Windows.hs b/test/Windows.hs index 4eaa06a..53d1efa 100644 --- a/test/Windows.hs +++ b/test/Windows.hs @@ -17,6 +17,7 @@ import Path.Internal.Windows import Test.Hspec import Common.Windows (extensionOperations) +import TH.Windows () -- | Test suite (Windows version). spec :: Spec From e1b88b7b5df7b33fa6da45d1927d25478f284c78 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 21 Jun 2024 00:07:10 +0200 Subject: [PATCH 07/52] Testsuite test: Preliminary work to move more tests into the Common modules --- test/Common/Include.hs | 49 ++++++++++++++++++++++-------------------- test/Common/Posix.hs | 3 +++ test/Common/Windows.hs | 12 +++++++++++ test/Posix.hs | 2 +- test/Windows.hs | 2 +- 5 files changed, 43 insertions(+), 25 deletions(-) diff --git a/test/Common/Include.hs b/test/Common/Include.hs index cded09e..bbfeb98 100644 --- a/test/Common/Include.hs +++ b/test/Common/Include.hs @@ -4,31 +4,19 @@ {-# LANGUAGE TemplateHaskell #-} -- | Test functions that are common to Posix and Windows - module Common.PLATFORM_NAME (extensionOperations) where -import Control.Monad -import Path.Internal.PLATFORM_NAME -import Path.PLATFORM_NAME +import Control.Monad (forM_) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty import System.FilePath.PLATFORM_NAME (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 +import Path.Internal.PLATFORM_NAME +import Path.PLATFORM_NAME -extensionOperations :: String -> Spec -extensionOperations rootDrive = do +extensionOperations :: Spec +extensionOperations = do let extension = ".foo" let extensions = extension : [".foo.", ".foo.."] @@ -44,10 +32,11 @@ extensionOperations rootDrive = do runTests parseRelFile f1 extension describe "Absolute dir paths" $ - forM_ dirnames $ \d -> do - forM_ filenames $ \f -> do - let f1 = rootDrive ++ d ++ [pathSeparator] ++ f - runTests parseAbsFile f1 extension + forM_ drives $ \drive -> do + forM_ dirnames $ \dir -> do + forM_ filenames $ \file -> do + let filepath = drive ++ dir ++ [pathSeparator] ++ file + runTests parseAbsFile filepath extension -- Invalid extensions forM_ invalidExtensions $ \ext -> do @@ -93,3 +82,17 @@ extensionOperations rootDrive = do , ".foo.bar" , ".foo" ++ [pathSeparator] ++ "bar" ] + +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 diff --git a/test/Common/Posix.hs b/test/Common/Posix.hs index 6273b4b..65eea99 100644 --- a/test/Common/Posix.hs +++ b/test/Common/Posix.hs @@ -2,3 +2,6 @@ #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 index 2016c41..f744ae7 100644 --- a/test/Common/Windows.hs +++ b/test/Common/Windows.hs @@ -2,3 +2,15 @@ #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/Posix.hs b/test/Posix.hs index ad1a25e..47652bc 100644 --- a/test/Posix.hs +++ b/test/Posix.hs @@ -35,7 +35,7 @@ spec = describe "Operations: isDrive" operationIsDrive describe "Operations: filename" operationFilename describe "Operations: dirname" operationDirname - describe "Operations: extensions" (extensionOperations "/") + describe "Operations: extensions" extensionOperations describe "Restrictions" restrictions describe "Aeson Instances" aesonInstances describe "QuasiQuotes" quasiquotes diff --git a/test/Windows.hs b/test/Windows.hs index 53d1efa..ff72d0b 100644 --- a/test/Windows.hs +++ b/test/Windows.hs @@ -35,7 +35,7 @@ spec = describe "Operations: isDrive" operationIsDrive describe "Operations: filename" operationFilename describe "Operations: dirname" operationDirname - describe "Operations: extensions" (extensionOperations "C:\\") + describe "Operations: extensions" extensionOperations describe "Restrictions" restrictions describe "Aeson Instances" aesonInstances describe "QuasiQuotes" quasiquotes From 79f0740bdeb840afcb4de50fec95371528a2ec1d Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 21 Jun 2024 00:42:30 +0200 Subject: [PATCH 08/52] Testsuite test: Moved 'dirname' tests to Common modules --- test/Common/Include.hs | 51 ++++++++++++++++++++++++++++++++++++------ test/Common/Posix.hs | 4 ++-- test/Common/Windows.hs | 4 ++-- test/Posix.hs | 18 +-------------- test/Windows.hs | 29 +----------------------- 5 files changed, 50 insertions(+), 56 deletions(-) diff --git a/test/Common/Include.hs b/test/Common/Include.hs index bbfeb98..da445b8 100644 --- a/test/Common/Include.hs +++ b/test/Common/Include.hs @@ -4,17 +4,48 @@ {-# LANGUAGE TemplateHaskell #-} -- | Test functions that are common to Posix and Windows -module Common.PLATFORM_NAME (extensionOperations) where +module Common.PLATFORM_NAME + (operationDirname + ,extensionOperations + ) where import Control.Monad (forM_) -import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NonEmpty -import System.FilePath.PLATFORM_NAME (pathSeparator) +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" + +-- | 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 drive must be a Rel path" + (isNothing (parseAbsDir . toFilePath . dirname $ drive)) + extensionOperations :: Spec extensionOperations = do let extension = ".foo" @@ -28,14 +59,14 @@ extensionOperations = do describe "Relative dir paths" $ forM_ dirnames $ \d -> do forM_ filenames $ \f -> do - let f1 = d ++ [pathSeparator] ++ f + let f1 = d ++ [FilePath.pathSeparator] ++ f runTests parseRelFile f1 extension describe "Absolute dir paths" $ - forM_ drives $ \drive -> do + forM_ drives_ $ \drive -> do forM_ dirnames $ \dir -> do forM_ filenames $ \file -> do - let filepath = drive ++ dir ++ [pathSeparator] ++ file + let filepath = drive ++ dir ++ [FilePath.pathSeparator] ++ file runTests parseAbsFile filepath extension -- Invalid extensions @@ -80,7 +111,7 @@ extensionOperations = do , "..foo" , "...foo" , ".foo.bar" - , ".foo" ++ [pathSeparator] ++ "bar" + , ".foo" ++ [FilePath.pathSeparator] ++ "bar" ] validExtensionsSpec :: String -> Path b File -> Path b File -> Spec @@ -96,3 +127,9 @@ validExtensionsSpec ext file fext = do 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) diff --git a/test/Common/Posix.hs b/test/Common/Posix.hs index 65eea99..5da8b2d 100644 --- a/test/Common/Posix.hs +++ b/test/Common/Posix.hs @@ -3,5 +3,5 @@ #define PLATFORM_NAME Posix #include "Include.hs" -drives :: NonEmpty FilePath -drives = NonEmpty.singleton "/" +drives_ :: NonEmpty FilePath +drives_ = NonEmpty.singleton "/" diff --git a/test/Common/Windows.hs b/test/Common/Windows.hs index f744ae7..1cbc129 100644 --- a/test/Common/Windows.hs +++ b/test/Common/Windows.hs @@ -4,8 +4,8 @@ #include "Include.hs" -- See https://learn.microsoft.com/en-us/dotnet/standard/io/file-path-formats -drives :: NonEmpty FilePath -drives = NonEmpty.fromList +drives_ :: NonEmpty FilePath +drives_ = NonEmpty.fromList [ "C:\\" -- Common , "C:/" -- Common , "\\\\host" -- UNC diff --git a/test/Posix.hs b/test/Posix.hs index 47652bc..d8e64f5 100644 --- a/test/Posix.hs +++ b/test/Posix.hs @@ -16,7 +16,7 @@ import Path.Posix import Path.Internal.Posix import Test.Hspec -import Common.Posix (extensionOperations) +import Common.Posix import TH.Posix () -- | Test suite (Posix version). @@ -65,22 +65,6 @@ restrictions = 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 = diff --git a/test/Windows.hs b/test/Windows.hs index ff72d0b..c382ef6 100644 --- a/test/Windows.hs +++ b/test/Windows.hs @@ -16,7 +16,7 @@ import Path.Windows import Path.Internal.Windows import Test.Hspec -import Common.Windows (extensionOperations) +import Common.Windows import TH.Windows () -- | Test suite (Windows version). @@ -59,33 +59,6 @@ restrictions = 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 = From 25f480eee7b65ffef7b19008f037ffbe95060573 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 21 Jun 2024 00:51:06 +0200 Subject: [PATCH 09/52] Testsuite test: Moved 'filename' tests to Common modules --- test/Common/Include.hs | 20 +++++++++++++++++++- test/Posix.hs | 13 ------------- test/Windows.hs | 21 --------------------- 3 files changed, 19 insertions(+), 35 deletions(-) diff --git a/test/Common/Include.hs b/test/Common/Include.hs index da445b8..a8728f8 100644 --- a/test/Common/Include.hs +++ b/test/Common/Include.hs @@ -6,6 +6,7 @@ -- | Test functions that are common to Posix and Windows module Common.PLATFORM_NAME (operationDirname + ,operationFilename ,extensionOperations ) where @@ -28,6 +29,9 @@ drives = (fromJust . traverse parseAbsDir) drives_ relDir :: Path Rel Dir relDir = (fromJust . parseRelDir) "directory" +relFile :: Path Rel File +relFile = (fromJust . parseRelFile) "file" + -- | The 'dirname' operation. operationDirname :: Spec operationDirname = do @@ -37,15 +41,29 @@ operationDirname = do 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 drive must be a Rel path" + "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) + extensionOperations :: Spec extensionOperations = do let extension = ".foo" diff --git a/test/Posix.hs b/test/Posix.hs index d8e64f5..e6f25e3 100644 --- a/test/Posix.hs +++ b/test/Posix.hs @@ -65,19 +65,6 @@ restrictions = parseSucceeds x with = parserTest parseRelDir x (Just with) --- | 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 = diff --git a/test/Windows.hs b/test/Windows.hs index c382ef6..0473d01 100644 --- a/test/Windows.hs +++ b/test/Windows.hs @@ -59,27 +59,6 @@ restrictions = parseSucceeds x with = parserTest parseRelDir x (Just with) --- | 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 = From fa8c390dde44e80672685de9adeae56a55e87b78 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 21 Jun 2024 00:59:36 +0200 Subject: [PATCH 10/52] Testsuite test: Moved 'parent' tests to Common modules --- test/Common/Include.hs | 23 +++++++++++++++++++++++ test/Posix.hs | 16 ---------------- test/Windows.hs | 14 -------------- 3 files changed, 23 insertions(+), 30 deletions(-) diff --git a/test/Common/Include.hs b/test/Common/Include.hs index a8728f8..794524a 100644 --- a/test/Common/Include.hs +++ b/test/Common/Include.hs @@ -7,6 +7,7 @@ module Common.PLATFORM_NAME (operationDirname ,operationFilename + ,operationParent ,extensionOperations ) where @@ -64,6 +65,28 @@ operationFilename = do "filename (absDir relFile) == filename relFile" (filename (absDir relFile) == filename relFile) +-- | The 'parent' operation. +operationParent :: Spec +operationParent = do + it + "parent \"name\" == \".\"" + (parent relDir == currentDir) + it + "parent \".\" == \".\"" + (parent currentDir == currentDir) + + forDrives $ \drive -> do + let absDir = drive relDir + it + "parent (absDir \"name\") == absDir" + (parent (absDir relDir) == absDir) + it + "parent \"/name\" == drive" + (parent absDir == drive) + it + "parent drive == drive" + (parent drive == drive) + extensionOperations :: Spec extensionOperations = do let extension = ".foo" diff --git a/test/Posix.hs b/test/Posix.hs index e6f25e3..3d9cf78 100644 --- a/test/Posix.hs +++ b/test/Posix.hs @@ -65,22 +65,6 @@ restrictions = parseSucceeds x with = parserTest parseRelDir x (Just with) --- | 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 'splitDrive' operation. operationSplitDrive :: Spec operationSplitDrive = diff --git a/test/Windows.hs b/test/Windows.hs index 0473d01..2862b5e 100644 --- a/test/Windows.hs +++ b/test/Windows.hs @@ -59,20 +59,6 @@ restrictions = parseSucceeds x with = parserTest parseRelDir x (Just with) --- | 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 'splitDrive' operation. operationSplitDrive :: Spec operationSplitDrive = From fe559b99d95ac3e2199f1b0e958bc77e6374f054 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 21 Jun 2024 01:03:55 +0200 Subject: [PATCH 11/52] Testsuite test: Moved 'splitDrive' tests to Common modules --- test/Common/Include.hs | 16 ++++++++++++++++ test/Posix.hs | 10 ---------- test/Windows.hs | 16 ---------------- 3 files changed, 16 insertions(+), 26 deletions(-) diff --git a/test/Common/Include.hs b/test/Common/Include.hs index 794524a..df7d931 100644 --- a/test/Common/Include.hs +++ b/test/Common/Include.hs @@ -8,6 +8,7 @@ module Common.PLATFORM_NAME (operationDirname ,operationFilename ,operationParent + ,operationSplitDrive ,extensionOperations ) where @@ -87,6 +88,21 @@ operationParent = do "parent drive == drive" (parent drive == drive) +-- | The 'splitDrive' operation. +operationSplitDrive :: Spec +operationSplitDrive = forDrives $ \drive -> do + let absDir = drive relDir + absFile = drive relFile + it + "splitDrive \"/dir\" == (drive, Just \"dir\")" + (splitDrive absDir == (drive, Just relDir)) + it + "splitDrive \"/file\" == (drive, Just \"file\")" + (splitDrive absFile == (drive, Just relFile)) + it + "splitDrive drive == (drive, Nothing)" + (splitDrive drive == (drive, Nothing)) + extensionOperations :: Spec extensionOperations = do let extension = ".foo" diff --git a/test/Posix.hs b/test/Posix.hs index 3d9cf78..ae3d009 100644 --- a/test/Posix.hs +++ b/test/Posix.hs @@ -65,16 +65,6 @@ restrictions = parseSucceeds x with = parserTest parseRelDir x (Just with) --- | The 'splitDrive' operation. -operationSplitDrive :: Spec -operationSplitDrive = - do it "splitDrive \"/dir\" == (\"/\", Just \"dir\")" - (splitDrive $(mkAbsDir "/dir") == ($(mkAbsDir "/"), Just $(mkRelDir "dir"))) - it "splitDrive \"/file\" == (\"/\", Just \"file\")" - (splitDrive $(mkAbsFile "/file") == ($(mkAbsDir "/"), Just $(mkRelFile "file"))) - it "splitDrive \"/\" == (\"/\", Nothing)" - (splitDrive $(mkAbsDir "/") == ($(mkAbsDir "/"), Nothing)) - -- | The 'isDrive' operation. operationIsDrive :: Spec operationIsDrive = diff --git a/test/Windows.hs b/test/Windows.hs index 2862b5e..384859b 100644 --- a/test/Windows.hs +++ b/test/Windows.hs @@ -59,22 +59,6 @@ restrictions = parseSucceeds x with = parserTest parseRelDir x (Just with) --- | The 'splitDrive' operation. -operationSplitDrive :: Spec -operationSplitDrive = - do it "splitDrive \"C:/dir\" == (\"C:/\", Just \"dir\")" - (splitDrive $(mkAbsDir "C:/dir") == ($(mkAbsDir "C:/"), Just $(mkRelDir "dir"))) - it "splitDrive \"C:\\dir\" == (\"C:\\\", Just \"dir\")" - (splitDrive $(mkAbsDir "C:\\dir") == ($(mkAbsDir "C:\\"), Just $(mkRelDir "dir"))) - it "splitDrive \"C:/file\" == (\"C:/\", Just \"file\")" - (splitDrive $(mkAbsFile "C:/file") == ($(mkAbsDir "C:/"), Just $(mkRelFile "file"))) - it "splitDrive \"C:\\file\" == (\"C:\\\", Just \"file\")" - (splitDrive $(mkAbsFile "C:\\file") == ($(mkAbsDir "C:\\"), Just $(mkRelFile "file"))) - it "splitDrive \"C:/\" == (\"C:/\", Nothing)" - (splitDrive $(mkAbsDir "C:/") == ($(mkAbsDir "C:/"), Nothing)) - it "splitDrive \"C:\\\" == (\"C:\\\", Nothing)" - (splitDrive $(mkAbsDir "C:\\") == ($(mkAbsDir "C:\\"), Nothing)) - -- | The 'isDrive' operation. operationIsDrive :: Spec operationIsDrive = From 16de8407b6e7909d670dca854d5f51d2acb4c4e7 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 21 Jun 2024 01:13:42 +0200 Subject: [PATCH 12/52] Testsuite test: Moved 'isProperPrefixOf' tests to Common modules --- test/Common/Include.hs | 34 ++++++++++++++++++++++++++++++++++ test/Posix.hs | 29 ----------------------------- test/Windows.hs | 36 ------------------------------------ 3 files changed, 34 insertions(+), 65 deletions(-) diff --git a/test/Common/Include.hs b/test/Common/Include.hs index df7d931..8b8e70f 100644 --- a/test/Common/Include.hs +++ b/test/Common/Include.hs @@ -9,6 +9,8 @@ module Common.PLATFORM_NAME ,operationFilename ,operationParent ,operationSplitDrive + ,operationIsDrive + ,operationIsProperPrefixOf ,extensionOperations ) where @@ -103,6 +105,38 @@ operationSplitDrive = forDrives $ \drive -> do "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)) + extensionOperations :: Spec extensionOperations = do let extension = ".foo" diff --git a/test/Posix.hs b/test/Posix.hs index ae3d009..c9240b6 100644 --- a/test/Posix.hs +++ b/test/Posix.hs @@ -65,35 +65,6 @@ restrictions = parseSucceeds x with = parserTest parseRelDir x (Just with) --- | The 'isDrive' operation. -operationIsDrive :: Spec -operationIsDrive = - do it "isDrive \"/\" == True" - (isDrive $(mkAbsDir "/") == True) - it "isDrive \"/dir\" == False" - (isDrive $(mkAbsDir "/dir") == False) - --- | 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 = diff --git a/test/Windows.hs b/test/Windows.hs index 384859b..0283d26 100644 --- a/test/Windows.hs +++ b/test/Windows.hs @@ -59,42 +59,6 @@ restrictions = parseSucceeds x with = parserTest parseRelDir x (Just with) --- | The 'isDrive' operation. -operationIsDrive :: Spec -operationIsDrive = - do it "isDrive \"C:/\" == True" - (isDrive $(mkAbsDir "C:/") == True) - it "isDrive \"C:\\\" == True" - (isDrive $(mkAbsDir "C:\\") == True) - it "isDrive \"C:/dir\" == False" - (isDrive $(mkAbsDir "C:/dir") == False) - it "isDrive \"C:\\dir\" == False" - (isDrive $(mkAbsDir "C:\\dir") == False) - --- | 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 = From d5b1bd13d28f7437092448b855337138a2841399 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 21 Jun 2024 01:20:21 +0200 Subject: [PATCH 13/52] Testsuite test: Moved 'stripProperPrefix' tests to Common modules --- test/Common/Include.hs | 17 +++++++++++++++++ test/Posix.hs | 20 -------------------- test/Windows.hs | 31 ------------------------------- 3 files changed, 17 insertions(+), 51 deletions(-) diff --git a/test/Common/Include.hs b/test/Common/Include.hs index 8b8e70f..a6fa86a 100644 --- a/test/Common/Include.hs +++ b/test/Common/Include.hs @@ -11,6 +11,7 @@ module Common.PLATFORM_NAME ,operationSplitDrive ,operationIsDrive ,operationIsProperPrefixOf + ,operationStripProperPrefix ,extensionOperations ) where @@ -137,6 +138,22 @@ operationIsProperPrefixOf = do "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 == _|_" + (isNothing (stripProperPrefix absDir absDir)) + extensionOperations :: Spec extensionOperations = do let extension = ".foo" diff --git a/test/Posix.hs b/test/Posix.hs index c9240b6..ba7004b 100644 --- a/test/Posix.hs +++ b/test/Posix.hs @@ -65,26 +65,6 @@ restrictions = parseSucceeds x with = parserTest parseRelDir x (Just with) --- | 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 = diff --git a/test/Windows.hs b/test/Windows.hs index 0283d26..3db0e86 100644 --- a/test/Windows.hs +++ b/test/Windows.hs @@ -59,37 +59,6 @@ restrictions = parseSucceeds x with = parserTest parseRelDir x (Just with) --- | 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 = From 0fdb2e6033fb4517e9939f3843fa801a8173d840 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 21 Jun 2024 01:33:59 +0200 Subject: [PATCH 14/52] Testsuite test: Moved '' tests to Common modules --- test/Common/Include.hs | 31 +++++++++++++++++++++++++++ test/Posix.hs | 26 ----------------------- test/Windows.hs | 48 ------------------------------------------ 3 files changed, 31 insertions(+), 74 deletions(-) diff --git a/test/Common/Include.hs b/test/Common/Include.hs index a6fa86a..0960dd3 100644 --- a/test/Common/Include.hs +++ b/test/Common/Include.hs @@ -12,6 +12,7 @@ module Common.PLATFORM_NAME ,operationIsDrive ,operationIsProperPrefixOf ,operationStripProperPrefix + ,operationAppend ,extensionOperations ) where @@ -154,6 +155,36 @@ operationStripProperPrefix = do "stripProperPrefix absDir absDir == _|_" (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')) + extensionOperations :: Spec extensionOperations = do let extension = ".foo" diff --git a/test/Posix.hs b/test/Posix.hs index ba7004b..c5fea3b 100644 --- a/test/Posix.hs +++ b/test/Posix.hs @@ -65,32 +65,6 @@ restrictions = parseSucceeds x with = parserTest parseRelDir x (Just with) --- | 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 \".\") == \"./\"" diff --git a/test/Windows.hs b/test/Windows.hs index 3db0e86..eee58b3 100644 --- a/test/Windows.hs +++ b/test/Windows.hs @@ -59,54 +59,6 @@ restrictions = parseSucceeds x with = parserTest parseRelDir x (Just with) --- | 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 \".\") == \"./\"" From 532ae732a9de862ee5298878448a2dd32345c17f Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 21 Jun 2024 01:56:15 +0200 Subject: [PATCH 15/52] Testsuite test: Moved some utilities to Common modules --- test/Common/Include.hs | 63 +++++++++++++++++++++++++++++++++++------- test/Posix.hs | 52 ++++------------------------------ test/Windows.hs | 52 ++++------------------------------ 3 files changed, 63 insertions(+), 104 deletions(-) diff --git a/test/Common/Include.hs b/test/Common/Include.hs index 0960dd3..5bf3124 100644 --- a/test/Common/Include.hs +++ b/test/Common/Include.hs @@ -5,18 +5,14 @@ -- | Test functions that are common to Posix and Windows module Common.PLATFORM_NAME - (operationDirname - ,operationFilename - ,operationParent - ,operationSplitDrive - ,operationIsDrive - ,operationIsProperPrefixOf - ,operationStripProperPrefix - ,operationAppend - ,extensionOperations + (spec + ,parseFails + ,parseSucceeds + ,parserTest ) where -import Control.Monad (forM_) +import Control.Applicative ((<|>)) +import Control.Monad (forM_, void) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe (fromJust, isNothing) @@ -38,6 +34,19 @@ 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 @@ -185,6 +194,16 @@ operationAppend = do "AbsDir + RelFile == AbsFile" (absDir relFile == Path (absDir' FilePath. relFile')) +operationToFilePath :: Spec +operationToFilePath = do + let expected = "." ++ [FilePath.pathSeparator] + it + ("toFilePath \".\" == " ++ show expected) + (toFilePath currentDir == expected) + it + ("show \".\" == " ++ (show . show) expected) + (show currentDir == show expected) + extensionOperations :: Spec extensionOperations = do let extension = ".foo" @@ -272,3 +291,27 @@ 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/Posix.hs b/test/Posix.hs index c5fea3b..932ffaf 100644 --- a/test/Posix.hs +++ b/test/Posix.hs @@ -7,16 +7,14 @@ 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.Posix import Test.Hspec -import Common.Posix +import Common.Posix (parseFails, parseSucceeds, parserTest) +import qualified Common.Posix +import Path.Posix +import Path.Internal.Posix import TH.Posix () -- | Test suite (Posix version). @@ -26,16 +24,7 @@ spec = 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: splitDrive" operationSplitDrive - describe "Operations: isDrive" operationIsDrive - 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 @@ -56,21 +45,6 @@ restrictions = 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) - -operationToFilePath :: Spec -operationToFilePath = - do it "toFilePath $(mkRelDir \".\") == \"./\"" - (toFilePath $(mkRelDir ".") == "./") - it "show $(mkRelDir \".\") == \"\\\"./\\\"\"" - (show $(mkRelDir ".") == "\"./\"") -- | Tests for the tokenizer. parseAbsDirSpec :: Spec @@ -163,22 +137,6 @@ parseRelFileSpec = 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 -- -- Can't use overloaded strings due to some weird issue with bytestring-0.9.2.1 / ghc-7.4.2: diff --git a/test/Windows.hs b/test/Windows.hs index eee58b3..24f6075 100644 --- a/test/Windows.hs +++ b/test/Windows.hs @@ -7,16 +7,14 @@ 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.Windows import Test.Hspec -import Common.Windows +import Common.Windows (parseFails, parseSucceeds, parserTest) +import qualified Common.Windows +import Path.Windows +import Path.Internal.Windows import TH.Windows () -- | Test suite (Windows version). @@ -26,16 +24,7 @@ spec = 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: splitDrive" operationSplitDrive - describe "Operations: isDrive" operationIsDrive - describe "Operations: filename" operationFilename - describe "Operations: dirname" operationDirname - describe "Operations: extensions" extensionOperations + Common.Windows.spec describe "Restrictions" restrictions describe "Aeson Instances" aesonInstances describe "QuasiQuotes" quasiquotes @@ -50,21 +39,6 @@ restrictions = 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) - -operationToFilePath :: Spec -operationToFilePath = - do it "toFilePath $(mkRelDir \".\") == \"./\"" - (toFilePath $(mkRelDir ".") == ".\\") - it "show $(mkRelDir \".\") == \"\\\".\\\\\"\"" - (show $(mkRelDir ".") == "\".\\\\\"") -- | Tests for the tokenizer. parseAbsDirSpec :: Spec @@ -173,22 +147,6 @@ parseRelFileSpec = 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 -- -- Can't use overloaded strings due to some weird issue with bytestring-0.9.2.1 / ghc-7.4.2: From 9ef23400664504bfdfa94008b846e9f22f1306e8 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Tue, 18 Jun 2024 15:50:01 +0200 Subject: [PATCH 16/52] Replicated source code to OsPath namespace --- path.cabal | 8 + src/OsPath.hs | 15 + src/OsPath/Include.hs | 968 +++++++++++++++++++++++++++++++++ src/OsPath/Internal.hs | 9 + src/OsPath/Internal/Include.hs | 138 +++++ src/OsPath/Internal/Posix.hs | 4 + src/OsPath/Internal/Windows.hs | 4 + src/OsPath/Posix.hs | 4 + src/OsPath/Windows.hs | 4 + 9 files changed, 1154 insertions(+) create mode 100644 src/OsPath.hs create mode 100644 src/OsPath/Include.hs create mode 100644 src/OsPath/Internal.hs create mode 100644 src/OsPath/Internal/Include.hs create mode 100644 src/OsPath/Internal/Posix.hs create mode 100644 src/OsPath/Internal/Windows.hs create mode 100644 src/OsPath/Posix.hs create mode 100644 src/OsPath/Windows.hs diff --git a/path.cabal b/path.cabal index 26ac58b..0aa6185 100644 --- a/path.cabal +++ b/path.cabal @@ -15,6 +15,8 @@ extra-source-files: README.md , CHANGELOG , src/Path/Include.hs , src/Path/Internal/Include.hs + , src/OsPath/Include.hs + , src/OsPath/Internal/Include.hs , test/Common/Include.hs flag dev @@ -30,6 +32,12 @@ library , Path.Internal , Path.Internal.Posix , Path.Internal.Windows + , OsPath + , OsPath.Posix + , OsPath.Windows + , OsPath.Internal + , OsPath.Internal.Posix + , OsPath.Internal.Windows build-depends: aeson , base >= 4.12 && < 5 , deepseq diff --git a/src/OsPath.hs b/src/OsPath.hs new file mode 100644 index 0000000..dc8530f --- /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 index 0000000..16e9bf4 --- /dev/null +++ b/src/OsPath/Include.hs @@ -0,0 +1,968 @@ +-- This template expects CPP definitions for: +-- PLATFORM_NAME = Posix | Windows +-- IS_WINDOWS = 0 | 1 + +-- | 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 DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} + +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 + ,toFilePath + ,fromAbsDir + ,fromRelDir + ,fromAbsFile + ,fromRelFile + ,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 (liftM, when) +import Control.Monad.Catch (MonadThrow(..)) +import Data.Aeson (FromJSON (..), FromJSONKey(..), ToJSON(..)) +import qualified Data.Aeson.Types as Aeson +import Data.Data +import qualified Data.Text as T +import Data.Hashable +import qualified Data.List as L +import Data.Maybe +import GHC.Generics (Generic) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (lift) +import Language.Haskell.TH.Quote (QuasiQuoter(..)) +import Path.Internal.PLATFORM_NAME +import qualified System.FilePath.PLATFORM_NAME as FilePath + +-------------------------------------------------------------------------------- +-- 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) + +instance FromJSON (Path Abs File) where + parseJSON = parseJSONWith parseAbsFile + {-# INLINE parseJSON #-} + +instance FromJSON (Path Rel File) where + parseJSON = parseJSONWith parseRelFile + {-# INLINE parseJSON #-} + +instance FromJSON (Path Abs Dir) where + parseJSON = parseJSONWith parseAbsDir + {-# INLINE parseJSON #-} + +instance FromJSON (Path Rel Dir) where + parseJSON = parseJSONWith parseRelDir + {-# INLINE parseJSON #-} + +parseJSONWith :: (Show e, FromJSON a) + => (a -> Either e b) -> Aeson.Value -> Aeson.Parser b +parseJSONWith f x = + do fp <- parseJSON x + case f fp of + Right p -> return p + Left e -> fail (show e) +{-# INLINE parseJSONWith #-} + +instance FromJSONKey (Path Abs File) where + fromJSONKey = fromJSONKeyWith parseAbsFile + {-# INLINE fromJSONKey #-} + +instance FromJSONKey (Path Rel File) where + fromJSONKey = fromJSONKeyWith parseRelFile + {-# INLINE fromJSONKey #-} + +instance FromJSONKey (Path Abs Dir) where + fromJSONKey = fromJSONKeyWith parseAbsDir + {-# INLINE fromJSONKey #-} + +instance FromJSONKey (Path Rel Dir) where + fromJSONKey = fromJSONKeyWith parseRelDir + {-# INLINE fromJSONKey #-} + +fromJSONKeyWith :: (Show e) + => (String -> Either e b) -> Aeson.FromJSONKeyFunction b +fromJSONKeyWith f = + Aeson.FromJSONKeyTextParser $ \t -> + case f (T.unpack t) of + Left e -> fail (show e) + Right rf -> pure rf + +{-# INLINE fromJSONKeyWith #-} + +-- | Exceptions that can occur during path operations. +-- +-- @since 0.6.0 +data PathException + = InvalidAbsDir FilePath + | InvalidRelDir FilePath + | InvalidAbsFile FilePath + | InvalidRelFile FilePath + | InvalidFile FilePath + | InvalidDir FilePath + | NotAProperPrefix FilePath FilePath + | HasNoExtension FilePath + | InvalidExtension String + deriving (Show,Eq,Typeable) + +instance Exception PathException where + displayException (InvalidExtension ext) = concat + [ "Invalid extension [" + , ext + , "]. A valid extension starts with a '.' followed by one or more " + , "characters other than '.', and it must be a valid filename, " + , "notably it cannot include a path separator." + ] + displayException x = show x + +-------------------------------------------------------------------------------- +-- QuasiQuoters + +qq :: (String -> Q Exp) -> QuasiQuoter +qq quoteExp' = + QuasiQuoter + { quoteExp = quoteExp' + , quotePat = \_ -> + fail "illegal QuasiQuote (allowed as expression only, used as a pattern)" + , quoteType = \_ -> + fail "illegal QuasiQuote (allowed as expression only, used as a type)" + , quoteDec = \_ -> + fail "illegal QuasiQuote (allowed as expression only, used as a declaration)" + } + +-- | Construct a 'Path' 'Abs' 'Dir' using QuasiQuotes. +-- +-- @ +-- [absdir|/|] +-- +-- [absdir|\/home\/chris|] +-- @ +-- +-- Remember: due to the nature of absolute paths a path like @[absdir|\/home\/chris|]@ +-- may compile on your platform, but it may not compile on another +-- platform (Windows). +-- +-- @since 0.5.13 +absdir :: QuasiQuoter +absdir = qq mkAbsDir + +-- | Construct a 'Path' 'Rel' 'Dir' using QuasiQuotes. +-- +-- @ +-- [absdir|\/home|]\<\/>[reldir|chris|] +-- @ +-- +-- @since 0.5.13 +reldir :: QuasiQuoter +reldir = qq mkRelDir + +-- | Construct a 'Path' 'Abs' 'File' using QuasiQuotes. +-- +-- @ +-- [absfile|\/home\/chris\/foo.txt|] +-- @ +-- +-- Remember: due to the nature of absolute paths a path like @[absdir|\/home\/chris\/foo.txt|]@ +-- may compile on your platform, but it may not compile on another +-- platform (Windows). +-- +-- @since 0.5.13 +absfile :: QuasiQuoter +absfile = qq mkAbsFile + +-- | Construct a 'Path' 'Rel' 'File' using QuasiQuotes. +-- +-- @ +-- [absdir|\/home\/chris|]\<\/>[relfile|foo.txt|] +-- @ +-- +-- @since 0.5.13 +relfile :: QuasiQuoter +relfile = qq mkRelFile + +-------------------------------------------------------------------------------- +-- Operations + +-- | Append two paths. +-- +-- The following cases are valid and the equalities hold: +-- +-- @$(mkAbsDir x) \<\/> $(mkRelDir y) = $(mkAbsDir (x ++ \"/\" ++ y))@ +-- +-- @$(mkAbsDir x) \<\/> $(mkRelFile y) = $(mkAbsFile (x ++ \"/\" ++ y))@ +-- +-- @$(mkRelDir x) \<\/> $(mkRelDir y) = $(mkRelDir (x ++ \"/\" ++ y))@ +-- +-- @$(mkRelDir x) \<\/> $(mkRelFile y) = $(mkRelFile (x ++ \"/\" ++ y))@ +-- +-- The following are proven not possible to express: +-- +-- @$(mkAbsFile …) \<\/> x@ +-- +-- @$(mkRelFile …) \<\/> x@ +-- +-- @x \<\/> $(mkAbsFile …)@ +-- +-- @x \<\/> $(mkAbsDir …)@ +-- +infixr 5 +() :: Path b Dir -> Path Rel t -> Path b t +() (Path a) (Path b) = Path (a ++ b) + +-- | If the directory in the first argument is a proper prefix of the path in +-- the second argument strip it from the second argument, generating a path +-- relative to the directory. +-- Throws 'NotAProperPrefix' if the directory is not a proper prefix of the +-- path. +-- +-- The following properties hold: +-- +-- @stripProperPrefix x (x \<\/> y) = y@ +-- +-- Cases which are proven not possible: +-- +-- @stripProperPrefix (a :: Path Abs …) (b :: Path Rel …)@ +-- +-- @stripProperPrefix (a :: Path Rel …) (b :: Path Abs …)@ +-- +-- In other words the bases must match. +-- +-- @since 0.6.0 +stripProperPrefix :: MonadThrow m + => Path b Dir -> Path b t -> m (Path Rel t) +stripProperPrefix (Path p) (Path l) = + case L.stripPrefix p l of + Nothing -> throwM (NotAProperPrefix p l) + Just "" -> throwM (NotAProperPrefix p l) + Just ok -> return (Path ok) + +-- | Determines if the path in the first parameter is a proper prefix of the +-- path in the second parameter. +-- +-- The following properties hold: +-- +-- @not (x \`isProperPrefixOf\` x)@ +-- +-- @x \`isProperPrefixOf\` (x \<\/\> y)@ +-- +-- @since 0.6.0 +isProperPrefixOf :: Path b Dir -> Path b t -> Bool +isProperPrefixOf p l = isJust (stripProperPrefix p l) + +-- | 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 \"\/x\" == \"\/\" +-- parent \"x\" == \".\" +-- @ +-- +-- On the root (absolute or relative), getting the parent is idempotent: +-- +-- @ +-- parent \"\/\" = \"\/\" +-- parent \"\.\" = \"\.\" +-- @ +-- +parent :: Path b t -> Path b Dir +parent (Path "") = Path "" +parent (Path fp) | FilePath.isDrive fp = Path fp +parent (Path fp) = + Path + $ normalizeDir + $ FilePath.takeDirectory + $ FilePath.dropTrailingPathSeparator fp + +-- | 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: +-- +-- @filename (p \<\/> a) == filename a@ +-- +filename :: Path b File -> Path Rel File +filename (Path l) = + Path (FilePath.takeFileName l) + +-- | Extract the last directory name of a path. +-- +-- The following properties hold: +-- +-- @dirname $(mkRelDir ".") == $(mkRelDir ".")@ +-- +-- @dirname (p \<\/> a) == dirname a@ +-- +dirname :: Path b Dir -> Path Rel Dir +dirname (Path "") = Path "" +dirname (Path l) | FilePath.isDrive l = Path "" +dirname (Path l) = Path (last (FilePath.splitPath l)) + +-- | 'splitExtension' is the inverse of 'addExtension'. It splits the given +-- file path into a valid filename and a valid extension. +-- +-- >>> splitExtension $(mkRelFile "name.foo" ) == Just ($(mkRelFile "name" ), ".foo" ) +-- >>> splitExtension $(mkRelFile "name.foo." ) == Just ($(mkRelFile "name" ), ".foo." ) +-- >>> splitExtension $(mkRelFile "name.foo.." ) == Just ($(mkRelFile "name" ), ".foo..") +-- >>> splitExtension $(mkRelFile "name.bar.foo" ) == Just ($(mkRelFile "name.bar"), ".foo" ) +-- >>> splitExtension $(mkRelFile ".name.foo" ) == Just ($(mkRelFile ".name" ), ".foo" ) +-- >>> splitExtension $(mkRelFile "name..foo" ) == Just ($(mkRelFile "name." ), ".foo" ) +-- >>> splitExtension $(mkRelFile "....foo" ) == Just ($(mkRelFile "..." ), ".foo" ) +-- +-- Throws 'HasNoExtension' exception if the filename does not have an extension +-- or in other words it cannot be split into a valid filename and a valid +-- extension. The following cases throw an exception, please note that "." and +-- ".." are not valid filenames: +-- +-- >>> splitExtension $(mkRelFile "name" ) +-- >>> splitExtension $(mkRelFile "name." ) +-- >>> splitExtension $(mkRelFile "name.." ) +-- >>> splitExtension $(mkRelFile ".name" ) +-- >>> splitExtension $(mkRelFile "..name" ) +-- >>> splitExtension $(mkRelFile "...name") +-- +-- 'splitExtension' and 'addExtension' are inverses of each other, the +-- following laws hold: +-- +-- @ +-- uncurry addExtension . swap >=> splitExtension == return +-- splitExtension >=> uncurry addExtension . swap == return +-- @ +-- +-- @since 0.7.0 +splitExtension :: MonadThrow m => Path b File -> m (Path b File, String) +splitExtension (Path fpath) = + if nameDot == [] || ext == [] + then throwM $ HasNoExtension fpath + else let fname = init nameDot + in if fname == [] || fname == "." || fname == ".." + then throwM $ HasNoExtension fpath + else return ( Path (normalizeDrive drv ++ dir ++ fname) + , FilePath.extSeparator : ext + ) + where + + -- trailing separators are ignored for the split and considered part of the + -- second component in the split. + splitLast isSep str = + let rstr = reverse str + notSep = not . isSep + name = (dropWhile notSep . dropWhile isSep) rstr + trailingSeps = takeWhile isSep rstr + xtn = (takeWhile notSep . dropWhile isSep) rstr + in (reverse name, reverse xtn ++ trailingSeps) +#if IS_WINDOWS + normalizeDrive = normalizeTrailingSeps +#else + normalizeDrive = id +#endif + + (drv, pth) = FilePath.splitDrive fpath + (dir, file) = splitLast FilePath.isPathSeparator pth + (nameDot, ext) = splitLast FilePath.isExtSeparator file + +-- | Get extension from given file path. Throws 'HasNoExtension' exception if +-- the file does not have an extension. The following laws hold: +-- +-- @ +-- flip addExtension file >=> fileExtension == return +-- fileExtension == (fmap snd) . splitExtension +-- @ +-- +-- @since 0.5.11 +fileExtension :: MonadThrow m => Path b File -> m String +fileExtension = (liftM snd) . splitExtension + +-- | Add extension to given file path. +-- +-- >>> addExtension ".foo" $(mkRelFile "name" ) == Just $(mkRelFile "name.foo" ) +-- >>> addExtension ".foo." $(mkRelFile "name" ) == Just $(mkRelFile "name.foo." ) +-- >>> addExtension ".foo.." $(mkRelFile "name" ) == Just $(mkRelFile "name.foo.." ) +-- >>> addExtension ".foo" $(mkRelFile "name.bar" ) == Just $(mkRelFile "name.bar.foo") +-- >>> addExtension ".foo" $(mkRelFile ".name" ) == Just $(mkRelFile ".name.foo" ) +-- >>> addExtension ".foo" $(mkRelFile "name." ) == Just $(mkRelFile "name..foo" ) +-- >>> addExtension ".foo" $(mkRelFile "..." ) == Just $(mkRelFile "....foo" ) +-- +-- Throws an 'InvalidExtension' exception if the extension is not valid. A +-- valid extension starts with a @.@ followed by one or more characters not +-- including @.@ followed by zero or more @.@ in trailing position. Moreover, +-- an extension must be a valid filename, notably it cannot include path +-- separators. Particularly, @.foo.bar@ is an invalid extension, instead you +-- have to first set @.foo@ and then @.bar@ individually. Some examples of +-- invalid extensions are: +-- +-- >>> addExtension "foo" $(mkRelFile "name") +-- >>> addExtension "..foo" $(mkRelFile "name") +-- >>> addExtension ".foo.bar" $(mkRelFile "name") +-- >>> addExtension ".foo/bar" $(mkRelFile "name") +-- +-- @since 0.7.0 +addExtension :: MonadThrow m + => String -- ^ Extension to add + -> Path b File -- ^ Old file name + -> m (Path b File) -- ^ New file name with the desired extension added at the end +addExtension ext (Path path) = do + validateExtension ext + return $ Path (path ++ ext) + + where + + validateExtension ex@(sep:xs) = do + -- has to start with a "." + when (not $ FilePath.isExtSeparator sep) $ + throwM $ InvalidExtension ex + + -- just a "." is not a valid extension + when (xs == []) $ + throwM $ InvalidExtension ex + + -- cannot have path separators + when (any FilePath.isPathSeparator xs) $ + throwM $ InvalidExtension ex + + -- All "."s is not a valid extension + let ys = dropWhile FilePath.isExtSeparator (reverse xs) + when (ys == []) $ + throwM $ InvalidExtension ex + + -- Cannot have "."s except in trailing position + when (any FilePath.isExtSeparator ys) $ + throwM $ InvalidExtension ex + + -- must be valid as a filename + _ <- parseRelFile ex + return () + validateExtension ex = throwM $ InvalidExtension ex + +-- | Add extension to given file path. Throws if the +-- resulting filename does not parse. +-- +-- >>> addFileExtension "txt $(mkRelFile "foo") +-- "foo.txt" +-- >>> addFileExtension "symbols" $(mkRelFile "Data.List") +-- "Data.List.symbols" +-- >>> addFileExtension ".symbols" $(mkRelFile "Data.List") +-- "Data.List.symbols" +-- >>> addFileExtension "symbols" $(mkRelFile "Data.List.") +-- "Data.List..symbols" +-- >>> addFileExtension ".symbols" $(mkRelFile "Data.List.") +-- "Data.List..symbols" +-- >>> addFileExtension "evil/" $(mkRelFile "Data.List") +-- *** Exception: InvalidRelFile "Data.List.evil/" +-- +-- @since 0.6.1 +{-# DEPRECATED addFileExtension "Please use addExtension instead." #-} +addFileExtension :: MonadThrow m + => String -- ^ Extension to add + -> Path b File -- ^ Old file name + -> m (Path b File) -- ^ New file name with the desired extension added at the end +addFileExtension ext (Path path) = + if FilePath.isAbsolute path + then liftM coercePath (parseAbsFile (FilePath.addExtension path ext)) + else liftM coercePath (parseRelFile (FilePath.addExtension path ext)) + where coercePath :: Path a b -> Path a' b' + coercePath (Path a) = Path a + +-- | A synonym for 'addFileExtension' in the form of an infix operator. +-- See more examples there. +-- +-- >>> $(mkRelFile "Data.List") <.> "symbols" +-- "Data.List.symbols" +-- >>> $(mkRelFile "Data.List") <.> "evil/" +-- *** Exception: InvalidRelFile "Data.List.evil/" +-- +-- @since 0.6.1 +infixr 7 <.> +{-# DEPRECATED (<.>) "Please use addExtension instead." #-} +(<.>) :: MonadThrow m + => Path b File -- ^ Old file name + -> String -- ^ Extension to add + -> m (Path b File) -- ^ New file name with the desired extension added at the end +(<.>) = flip addFileExtension + +-- | If the file has an extension replace it with the given extension otherwise +-- add the new extension to it. Throws an 'InvalidExtension' exception if the +-- new extension is not a valid extension (see 'fileExtension' for validity +-- rules). +-- +-- The following law holds: +-- +-- @(fileExtension >=> flip replaceExtension file) file == return file@ +-- +-- @since 0.7.0 +replaceExtension :: MonadThrow m + => String -- ^ Extension to set + -> Path b File -- ^ Old file name + -> m (Path b File) -- ^ New file name with the desired extension +replaceExtension ext path = + addExtension ext (maybe path fst $ splitExtension path) + +-- | Replace\/add extension to given file path. Throws if the +-- resulting filename does not parse. +-- +-- @since 0.5.11 +{-# DEPRECATED setFileExtension "Please use replaceExtension instead." #-} +setFileExtension :: MonadThrow m + => String -- ^ Extension to set + -> Path b File -- ^ Old file name + -> m (Path b File) -- ^ New file name with the desired extension +setFileExtension ext (Path path) = + if FilePath.isAbsolute path + then liftM coercePath (parseAbsFile (FilePath.replaceExtension path ext)) + else liftM coercePath (parseRelFile (FilePath.replaceExtension path ext)) + where coercePath :: Path a b -> Path a' b' + coercePath (Path a) = Path a + +-- | A synonym for 'setFileExtension' in the form of an operator. +-- +-- @since 0.6.0 +infixr 7 -<.> +{-# DEPRECATED (-<.>) "Please use replaceExtension instead." #-} +(-<.>) :: MonadThrow m + => Path b File -- ^ Old file name + -> String -- ^ Extension to set + -> m (Path b File) -- ^ New file name with the desired extension +(-<.>) = flip setFileExtension + +-------------------------------------------------------------------------------- +-- Parsers + +-- | Convert an absolute 'FilePath' to a normalized absolute dir 'Path'. +-- +-- Throws: 'InvalidAbsDir' when the supplied path: +-- +-- * is not an absolute path +-- * contains a @..@ path component representing the parent directory +-- * is not a valid path (See 'FilePath.isValid') +-- +parseAbsDir :: MonadThrow m + => FilePath -> m (Path Abs Dir) +parseAbsDir filepath = + if FilePath.isAbsolute filepath && + not (hasParentDir filepath) && + FilePath.isValid filepath + then return (Path (normalizeDir filepath)) + else throwM (InvalidAbsDir filepath) + +-- | Convert a relative 'FilePath' to a normalized relative dir 'Path'. +-- +-- Throws: 'InvalidRelDir' when the supplied path: +-- +-- * is not a relative path +-- * is @""@ +-- * contains a @..@ path component representing the parent directory +-- * is not a valid path (See 'FilePath.isValid') +-- * is all path separators +-- +parseRelDir :: MonadThrow m + => FilePath -> m (Path Rel Dir) +parseRelDir filepath = + if not (FilePath.isAbsolute filepath) && + not (hasParentDir filepath) && + not (null filepath) && + not (all FilePath.isPathSeparator filepath) && + FilePath.isValid filepath + then return (Path (normalizeDir filepath)) + else throwM (InvalidRelDir filepath) + +-- | Convert an absolute 'FilePath' to a normalized absolute file 'Path'. +-- +-- Throws: 'InvalidAbsFile' when the supplied path: +-- +-- * is not an absolute path +-- * is a directory path i.e. +-- +-- * has a trailing path separator +-- * is @.@ or ends in @/.@ +-- +-- * contains a @..@ path component representing the parent directory +-- * is not a valid path (See 'FilePath.isValid') +-- +parseAbsFile :: MonadThrow m + => FilePath -> m (Path Abs File) +parseAbsFile filepath = + case validAbsFile filepath of + True + | normalized <- normalizeFilePath filepath + , validAbsFile normalized -> + return (Path normalized) + _ -> throwM (InvalidAbsFile filepath) + +-- | Is the string a valid absolute file? +validAbsFile :: FilePath -> Bool +validAbsFile filepath = + FilePath.isAbsolute filepath && + not (FilePath.hasTrailingPathSeparator filepath) && + not (hasParentDir filepath) && + FilePath.isValid filepath + +-- | Convert a relative 'FilePath' to a normalized relative file 'Path'. +-- +-- Throws: 'InvalidRelFile' when the supplied path: +-- +-- * is not a relative path +-- * is @""@ +-- * is a directory path i.e. +-- +-- * has a trailing path separator +-- * is @.@ or ends in @/.@ +-- +-- * contains a @..@ path component representing the parent directory +-- * is not a valid path (See 'FilePath.isValid') +-- +parseRelFile :: MonadThrow m + => FilePath -> m (Path Rel File) +parseRelFile filepath = + case validRelFile filepath of + True + | normalized <- normalizeFilePath filepath + , validRelFile normalized -> return (Path normalized) + _ -> throwM (InvalidRelFile filepath) + +-- | Is the string a valid relative file? +validRelFile :: FilePath -> Bool +validRelFile filepath = + not + (FilePath.isAbsolute filepath || FilePath.hasTrailingPathSeparator filepath) && + not (null filepath) && + not (hasParentDir filepath) && + filepath /= "." && FilePath.isValid filepath + +-------------------------------------------------------------------------------- +-- Conversion + +-- | Convert absolute path to directory to 'FilePath' type. +fromAbsDir :: Path Abs Dir -> FilePath +fromAbsDir = toFilePath + +-- | Convert relative path to directory to 'FilePath' type. +fromRelDir :: Path Rel Dir -> FilePath +fromRelDir = toFilePath + +-- | Convert absolute path to file to 'FilePath' type. +fromAbsFile :: Path Abs File -> FilePath +fromAbsFile = toFilePath + +-- | Convert relative path to file to 'FilePath' type. +fromRelFile :: Path Rel File -> FilePath +fromRelFile = toFilePath + +-------------------------------------------------------------------------------- +-- Constructors + +-- | Make a 'Path' 'Abs' 'Dir'. +-- +-- Remember: due to the nature of absolute paths this (e.g. @\/home\/foo@) +-- may compile on your platform, but it may not compile on another +-- platform (Windows). +mkAbsDir :: FilePath -> Q Exp +mkAbsDir = either (error . show) lift . parseAbsDir + +-- | Make a 'Path' 'Rel' 'Dir'. +mkRelDir :: FilePath -> Q Exp +mkRelDir = either (error . show) lift . parseRelDir + +-- | Make a 'Path' 'Abs' 'File'. +-- +-- Remember: due to the nature of absolute paths this (e.g. @\/home\/foo@) +-- may compile on your platform, but it may not compile on another +-- platform (Windows). +mkAbsFile :: FilePath -> Q Exp +mkAbsFile = either (error . show) lift . parseAbsFile + +-- | Make a 'Path' 'Rel' 'File'. +mkRelFile :: FilePath -> Q Exp +mkRelFile = either (error . show) lift . parseRelFile + +-------------------------------------------------------------------------------- +-- Internal functions + +-- | Normalizes directory path with platform-specific rules. +normalizeDir :: FilePath -> FilePath +normalizeDir = + normalizeRelDir + . FilePath.addTrailingPathSeparator + . normalizeFilePath + where -- Represent a "." in relative dir path as "" internally so that it + -- composes without having to renormalize the path. + normalizeRelDir p + | p == relRootFP = "" + | otherwise = p + +-- | 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 + +#if IS_WINDOWS +-- | 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 [] + where normSeps ch [] = [ch] + normSeps ch path@(p0:_) + | FilePath.isPathSeparator ch && FilePath.isPathSeparator p0 = path + | FilePath.isPathSeparator ch = FilePath.pathSeparator:path + | otherwise = ch:path + +-- | Normalizes seps in whole path, but if there are 2+ seps at the beginning, +-- they are normalized to exactly 2 to preserve UNC and Unicode prefixed paths. +normalizeWindowsSeps :: FilePath -> FilePath +normalizeWindowsSeps path = normLeadingSeps ++ normalizeAllSeps rest + where (leadingSeps, rest) = span FilePath.isPathSeparator path + normLeadingSeps = replicate (min 2 (length leadingSeps)) FilePath.pathSeparator +#endif + +-- | Applies platform-specific sep normalization following @FilePath.normalise@. +normalizeFilePath :: FilePath -> FilePath +#if IS_WINDOWS +normalizeFilePath = normalizeWindowsSeps . FilePath.normalise +#else +normalizeFilePath = normalizeLeadingSeps . FilePath.normalise +#endif + +-- | 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 ToJSON (SomeBase t) where + toJSON = toJSON . fromSomeBase + {-# INLINE toJSON #-} +#if MIN_VERSION_aeson(0,10,0) + toEncoding = toEncoding . fromSomeBase + {-# INLINE toEncoding #-} +#endif + +instance Hashable (SomeBase t) where + -- See 'Hashable' 'Path' instance for details. + hashWithSalt n path = hashWithSalt n (fromSomeBase path) + +instance FromJSON (SomeBase Dir) where + parseJSON = parseJSONWith parseSomeDir + {-# INLINE parseJSON #-} + +instance FromJSON (SomeBase File) where + 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 = prjSomeBase toFilePath + +-- | Convert a valid directory to a 'FilePath'. +fromSomeDir :: SomeBase Dir -> FilePath +fromSomeDir = fromSomeBase + +-- | Convert a valid file to a 'FilePath'. +fromSomeFile :: SomeBase File -> FilePath +fromSomeFile = fromSomeBase + +-- | Convert an absolute or relative 'FilePath' 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 'FilePath.isValid') +parseSomeDir :: MonadThrow m => FilePath -> m (SomeBase Dir) +parseSomeDir fp = maybe (throwM (InvalidDir fp)) pure + $ (Abs <$> parseAbsDir fp) + <|> (Rel <$> parseRelDir fp) + +-- | Convert an absolute or relative 'FilePath' 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 'FilePath.isValid') +parseSomeFile :: MonadThrow m => FilePath -> m (SomeBase File) +parseSomeFile fp = maybe (throwM (InvalidFile fp)) pure + $ (Abs <$> parseAbsFile fp) + <|> (Rel <$> parseRelFile fp) + +-------------------------------------------------------------------------------- +-- Deprecated + +{-# DEPRECATED PathParseException "Please use PathException instead." #-} +-- | Same as 'PathException'. +type PathParseException = PathException + +{-# DEPRECATED stripDir "Please use stripProperPrefix instead." #-} +-- | Same as 'stripProperPrefix'. +stripDir :: MonadThrow m + => Path b Dir -> Path b t -> m (Path Rel t) +stripDir = stripProperPrefix + +{-# DEPRECATED isParentOf "Please use isProperPrefixOf instead." #-} +-- | Same as 'isProperPrefixOf'. +isParentOf :: Path b Dir -> Path b t -> Bool +isParentOf = isProperPrefixOf diff --git a/src/OsPath/Internal.hs b/src/OsPath/Internal.hs new file mode 100644 index 0000000..0a2b90a --- /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 index 0000000..e04c93d --- /dev/null +++ b/src/OsPath/Internal/Include.hs @@ -0,0 +1,138 @@ +-- This template expects CPP definitions for: +-- PLATFORM_NAME = Posix | Windows +-- IS_WINDOWS = False | True + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Internal types and functions. + +module OsPath.Internal.PLATFORM_NAME + ( Path(..) + , relRootFP + , toFilePath + , hasParentDir + ) + 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 diff --git a/src/OsPath/Internal/Posix.hs b/src/OsPath/Internal/Posix.hs new file mode 100644 index 0000000..25e35e1 --- /dev/null +++ b/src/OsPath/Internal/Posix.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE CPP #-} +#define PLATFORM_NAME Posix +#define IS_WINDOWS False +#include "Include.hs" diff --git a/src/OsPath/Internal/Windows.hs b/src/OsPath/Internal/Windows.hs new file mode 100644 index 0000000..a8b5cbb --- /dev/null +++ b/src/OsPath/Internal/Windows.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE CPP #-} +#define PLATFORM_NAME Windows +#define IS_WINDOWS True +#include "Include.hs" diff --git a/src/OsPath/Posix.hs b/src/OsPath/Posix.hs new file mode 100644 index 0000000..23a1b40 --- /dev/null +++ b/src/OsPath/Posix.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE CPP #-} +#define PLATFORM_NAME Posix +#define IS_WINDOWS 0 +#include "Include.hs" diff --git a/src/OsPath/Windows.hs b/src/OsPath/Windows.hs new file mode 100644 index 0000000..95b16e4 --- /dev/null +++ b/src/OsPath/Windows.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE CPP #-} +#define PLATFORM_NAME Windows +#define IS_WINDOWS 1 +#include "Include.hs" From 4db62ad7f904d853940c259048b48189d748765e Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Tue, 18 Jun 2024 15:52:50 +0200 Subject: [PATCH 17/52] Adjusted version constraints and added os-string dependency --- path.cabal | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/path.cabal b/path.cabal index 0aa6185..fc7ffcc 100644 --- a/path.cabal +++ b/path.cabal @@ -42,8 +42,9 @@ library , base >= 4.12 && < 5 , deepseq , exceptions >= 0.4 && < 0.11 - , filepath < 1.2.0.1 || >= 1.3 + , filepath >= 1.5.0.0 , hashable >= 1.2 && < 1.5 + , os-string >= 2.0.0 , text , template-haskell if flag(dev) @@ -68,9 +69,9 @@ test-suite test , TH.Windows hs-source-dirs: test build-depends: aeson - , base >= 4.12 && < 5 + , base , bytestring - , filepath < 1.2.0.1 || >= 1.3 + , filepath , hspec >= 2.0 && < 3 , mtl >= 2.0 && < 3 , path @@ -88,9 +89,9 @@ test-suite validity-test hs-source-dirs: validity-test build-depends: QuickCheck , aeson - , base >= 4.12 && < 5 + , base , bytestring - , filepath < 1.2.0.1 || >= 1.3 + , filepath , genvalidity >= 1.0 , genvalidity-property >= 0.4 , genvalidity-hspec >= 0.7 From b5b88336d7b139db5ad4d1caa28b0525281e8d26 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Tue, 18 Jun 2024 16:35:05 +0200 Subject: [PATCH 18/52] Use platform filepaths in OsPath.Internal modules --- src/OsPath/Internal/Include.hs | 79 ++++++++++++++++++++++++++-------- src/OsPath/Internal/Posix.hs | 4 +- src/OsPath/Internal/Windows.hs | 4 +- 3 files changed, 68 insertions(+), 19 deletions(-) diff --git a/src/OsPath/Internal/Include.hs b/src/OsPath/Internal/Include.hs index e04c93d..a059896 100644 --- a/src/OsPath/Internal/Include.hs +++ b/src/OsPath/Internal/Include.hs @@ -1,33 +1,48 @@ -- This template expects CPP definitions for: -- PLATFORM_NAME = Posix | Windows --- IS_WINDOWS = False | True +-- PLATFORM_PATH = PosixPath | WindowsPath +-- IS_WINDOWS = 0 | 1 -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -Wno-orphans #-} -- | Internal types and functions. module OsPath.Internal.PLATFORM_NAME ( Path(..) - , relRootFP , toFilePath + , toOsPath + + -- * Other helper functions + , extSep + , pathSep , hasParentDir + , relRoot + , isWindows ) where import Control.DeepSeq (NFData (..)) import Data.Aeson (ToJSON (..), ToJSONKey(..)) import Data.Aeson.Types (toJSONKeyText) -import qualified Data.Text as T (pack) +import qualified Data.Text as Text (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 +import System.IO.Unsafe (unsafeDupablePerformIO) +import System.OsPath.PLATFORM_NAME (PLATFORM_PATH) +import qualified System.OsPath.PLATFORM_NAME as OsPath +import System.OsString.Internal.Types (PLATFORM_STRING(..)) +import qualified System.OsString.PLATFORM_NAME as OsString -- | Path of some base and type. -- @@ -36,14 +51,14 @@ import qualified System.FilePath.PLATFORM_NAME as FilePath -- * @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: +-- Internally it is a byte string. The byte 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 +newtype Path b t = Path PLATFORM_PATH deriving (Data, Typeable, Generic) -- | String equality. @@ -62,18 +77,23 @@ instance Eq (Path b t) where 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 +toFilePath = unsafeDupablePerformIO . OsPath.decodeFS . toOsPath + +-- | 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 -- | Helper function: check if the filepath has any parent directories in it. -- This handles the logic of checking for different path separators on Windows. @@ -109,7 +129,7 @@ instance ToJSON (Path b t) where #endif instance ToJSONKey (Path b t) where - toJSONKey = toJSONKeyText $ T.pack . toFilePath + toJSONKey = toJSONKeyText (Text.pack . toFilePath) instance Hashable (Path b t) where -- A "." is represented as an empty string ("") internally. Hashing "" @@ -122,7 +142,7 @@ 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) |] + [| Path $(TH.lift str) :: Path $(pure b) $(pure t) |] where getTCName :: Typeable a => proxy a -> TH.Name getTCName a = TH.Name occ flav @@ -136,3 +156,28 @@ instance forall b t. (Typeable b, Typeable t) => TH.Lift (Path b t) where #elif MIN_VERSION_template_haskell(2,16,0) liftTyped = TH.unsafeTExpCoerce . TH.lift #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 + +-------------------------------------------------------------------------------- +-- Orphan instances + +deriving instance Data PLATFORM_STRING diff --git a/src/OsPath/Internal/Posix.hs b/src/OsPath/Internal/Posix.hs index 25e35e1..0ab6377 100644 --- a/src/OsPath/Internal/Posix.hs +++ b/src/OsPath/Internal/Posix.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} #define PLATFORM_NAME Posix -#define IS_WINDOWS False +#define PLATFORM_PATH 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 index a8b5cbb..869f5b9 100644 --- a/src/OsPath/Internal/Windows.hs +++ b/src/OsPath/Internal/Windows.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} #define PLATFORM_NAME Windows -#define IS_WINDOWS True +#define PLATFORM_PATH WindowsPath +#define PLATFORM_STRING WindowsString +#define IS_WINDOWS 1 #include "Include.hs" From 7a253353bb1101f1a970e85a109aa0228d284dde Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Thu, 20 Jun 2024 03:57:13 +0200 Subject: [PATCH 19/52] Use platform filepaths in the OsPath modules of the public API --- src/OsPath/Include.hs | 718 +++++++++++++++++---------------- src/OsPath/Internal/Include.hs | 33 +- src/OsPath/Internal/Posix.hs | 9 +- src/OsPath/Internal/Windows.hs | 9 +- src/OsPath/Posix.hs | 7 +- src/OsPath/Windows.hs | 7 +- 6 files changed, 417 insertions(+), 366 deletions(-) diff --git a/src/OsPath/Include.hs b/src/OsPath/Include.hs index 16e9bf4..b8a934b 100644 --- a/src/OsPath/Include.hs +++ b/src/OsPath/Include.hs @@ -18,12 +18,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 BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} @@ -104,21 +106,25 @@ module OsPath.PLATFORM_NAME import Control.Applicative (Alternative(..)) import Control.DeepSeq (NFData (..)) import Control.Exception (Exception(..)) -import Control.Monad (liftM, when) +import Control.Monad (liftM, when, (<=<)) import Control.Monad.Catch (MonadThrow(..)) import Data.Aeson (FromJSON (..), FromJSONKey(..), ToJSON(..)) import qualified Data.Aeson.Types as Aeson -import Data.Data -import qualified Data.Text as T -import Data.Hashable -import qualified Data.List as L -import Data.Maybe +import Data.Data (Data, Typeable) +import qualified Data.Text as Text +import Data.Hashable (Hashable (..)) +import Data.Maybe (isJust, isNothing) import GHC.Generics (Generic) -import Language.Haskell.TH +import Language.Haskell.TH (Exp, Q) import Language.Haskell.TH.Syntax (lift) import Language.Haskell.TH.Quote (QuasiQuoter(..)) -import Path.Internal.PLATFORM_NAME -import qualified System.FilePath.PLATFORM_NAME as FilePath +import System.IO.Unsafe (unsafeDupablePerformIO) +import System.OsPath.PLATFORM_NAME (PLATFORM_PATH) +import qualified System.OsPath.PLATFORM_NAME as OsPath +import System.OsString.PLATFORM_NAME (PLATFORM_STRING) +import qualified System.OsString.PLATFORM_NAME as OsString + +import OsPath.Internal.PLATFORM_NAME -------------------------------------------------------------------------------- -- Types @@ -152,11 +158,13 @@ instance FromJSON (Path Rel Dir) where parseJSON = parseJSONWith parseRelDir {-# INLINE parseJSON #-} -parseJSONWith :: (Show e, FromJSON a) - => (a -> Either e b) -> Aeson.Value -> Aeson.Parser b +parseJSONWith :: (forall m . MonadThrow m => PLATFORM_PATH -> m a) + -> Aeson.Value + -> Aeson.Parser a parseJSONWith f x = do fp <- parseJSON x - case f fp of + let ospath = unsafeDupablePerformIO (OsString.encodeFS fp) + case f ospath of Right p -> return p Left e -> fail (show e) {-# INLINE parseJSONWith #-} @@ -177,36 +185,35 @@ instance FromJSONKey (Path Rel Dir) where fromJSONKey = fromJSONKeyWith parseRelDir {-# INLINE fromJSONKey #-} -fromJSONKeyWith :: (Show e) - => (String -> Either e b) -> Aeson.FromJSONKeyFunction b +fromJSONKeyWith :: (forall m . MonadThrow m => PLATFORM_PATH -> m b) + -> Aeson.FromJSONKeyFunction b fromJSONKeyWith f = - Aeson.FromJSONKeyTextParser $ \t -> - case f (T.unpack t) of - Left e -> fail (show e) - Right rf -> pure rf - + Aeson.FromJSONKeyTextParser $ \text -> + either (fail . displayException) return $ do + ospath <- (OsPath.encodeUtf . Text.unpack) text + f ospath {-# INLINE fromJSONKeyWith #-} -- | Exceptions that can occur during path operations. -- -- @since 0.6.0 data PathException - = InvalidAbsDir FilePath - | InvalidRelDir FilePath - | InvalidAbsFile FilePath - | InvalidRelFile FilePath - | InvalidFile FilePath - | InvalidDir FilePath - | NotAProperPrefix FilePath FilePath - | HasNoExtension FilePath - | InvalidExtension String + = 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 [" - , ext - , "]. A valid extension starts with a '.' followed by one or more " + [ "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." ] @@ -215,10 +222,10 @@ instance Exception PathException where -------------------------------------------------------------------------------- -- QuasiQuoters -qq :: (String -> Q Exp) -> QuasiQuoter +qq :: (PLATFORM_PATH -> Q Exp) -> QuasiQuoter qq quoteExp' = QuasiQuoter - { quoteExp = quoteExp' + { quoteExp = quoteExp' <=< OsPath.encodeUtf , quotePat = \_ -> fail "illegal QuasiQuote (allowed as expression only, used as a pattern)" , quoteType = \_ -> @@ -284,13 +291,13 @@ relfile = qq mkRelFile -- -- The following cases are valid and the equalities hold: -- --- @$(mkAbsDir x) \<\/> $(mkRelDir y) = $(mkAbsDir (x ++ \"/\" ++ y))@ +-- @$(mkAbsDir x) \<\/> $(mkRelDir y) = $(mkAbsDir (x <> [pstr|/|] <> y))@ -- --- @$(mkAbsDir x) \<\/> $(mkRelFile y) = $(mkAbsFile (x ++ \"/\" ++ y))@ +-- @$(mkAbsDir x) \<\/> $(mkRelFile y) = $(mkAbsFile (x <> [pstr|/|] <> y))@ -- --- @$(mkRelDir x) \<\/> $(mkRelDir y) = $(mkRelDir (x ++ \"/\" ++ y))@ +-- @$(mkRelDir x) \<\/> $(mkRelDir y) = $(mkRelDir (x <> [pstr|/|] <> y))@ -- --- @$(mkRelDir x) \<\/> $(mkRelFile y) = $(mkRelFile (x ++ \"/\" ++ y))@ +-- @$(mkRelDir x) \<\/> $(mkRelFile y) = $(mkRelFile (x <> [pstr|/|] <> y))@ -- -- The following are proven not possible to express: -- @@ -304,7 +311,7 @@ relfile = qq mkRelFile -- infixr 5 () :: Path b Dir -> Path Rel t -> Path b t -() (Path a) (Path b) = Path (a ++ b) +() (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 @@ -328,10 +335,11 @@ infixr 5 stripProperPrefix :: MonadThrow m => Path b Dir -> Path b t -> m (Path Rel t) stripProperPrefix (Path p) (Path l) = - case L.stripPrefix p l of + case OsString.stripPrefix p l of Nothing -> throwM (NotAProperPrefix p l) - Just "" -> throwM (NotAProperPrefix p l) - Just ok -> return (Path ok) + 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. @@ -361,32 +369,33 @@ replaceProperPrefix src dst fp = (dst ) <$> stripProperPrefix src fp -- -- @ -- parent (x \<\/> y) == x --- parent \"\/x\" == \"\/\" --- parent \"x\" == \".\" +-- parent [pstr|\/x|] == [pstr|\/|] +-- parent [pstr|x|] == [pstr|.|] -- @ -- -- On the root (absolute or relative), getting the parent is idempotent: -- -- @ --- parent \"\/\" = \"\/\" --- parent \"\.\" = \"\.\" +-- parent [pstr|\/|] = [pstr|\/|] +-- parent [pstr|\.|] = [pstr|\.|] -- @ -- parent :: Path b t -> Path b Dir -parent (Path "") = Path "" -parent (Path fp) | FilePath.isDrive fp = Path fp -parent (Path fp) = - Path - $ normalizeDir - $ FilePath.takeDirectory - $ FilePath.dropTrailingPathSeparator fp +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) = FilePath.splitDrive fp - mRest = if null rest then Nothing else Just (Path rest) + 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. @@ -414,7 +423,7 @@ isDrive = isNothing . dropDrive -- filename :: Path b File -> Path Rel File filename (Path l) = - Path (FilePath.takeFileName l) + Path (OsPath.takeFileName l) -- | Extract the last directory name of a path. -- @@ -425,20 +434,21 @@ filename (Path l) = -- @dirname (p \<\/> a) == dirname a@ -- dirname :: Path b Dir -> Path Rel Dir -dirname (Path "") = Path "" -dirname (Path l) | FilePath.isDrive l = Path "" -dirname (Path l) = Path (last (FilePath.splitPath l)) +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" ), ".foo" ) --- >>> splitExtension $(mkRelFile "name.foo." ) == Just ($(mkRelFile "name" ), ".foo." ) --- >>> splitExtension $(mkRelFile "name.foo.." ) == Just ($(mkRelFile "name" ), ".foo..") --- >>> splitExtension $(mkRelFile "name.bar.foo" ) == Just ($(mkRelFile "name.bar"), ".foo" ) --- >>> splitExtension $(mkRelFile ".name.foo" ) == Just ($(mkRelFile ".name" ), ".foo" ) --- >>> splitExtension $(mkRelFile "name..foo" ) == Just ($(mkRelFile "name." ), ".foo" ) --- >>> splitExtension $(mkRelFile "....foo" ) == Just ($(mkRelFile "..." ), ".foo" ) +-- >>> 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 @@ -461,36 +471,30 @@ dirname (Path l) = Path (last (FilePath.splitPath l)) -- @ -- -- @since 0.7.0 -splitExtension :: MonadThrow m => Path b File -> m (Path b File, String) -splitExtension (Path fpath) = - if nameDot == [] || ext == [] - then throwM $ HasNoExtension fpath - else let fname = init nameDot - in if fname == [] || fname == "." || fname == ".." - then throwM $ HasNoExtension fpath - else return ( Path (normalizeDrive drv ++ dir ++ fname) - , FilePath.extSeparator : ext - ) +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 rstr = reverse str - notSep = not . isSep - name = (dropWhile notSep . dropWhile isSep) rstr - trailingSeps = takeWhile isSep rstr - xtn = (takeWhile notSep . dropWhile isSep) rstr - in (reverse name, reverse xtn ++ trailingSeps) -#if IS_WINDOWS - normalizeDrive = normalizeTrailingSeps -#else - normalizeDrive = id -#endif + let (withoutTrailingSeps, trailingSeps) = OsString.spanEnd isSep str + (oneSep, rest) = OsString.breakEnd isSep withoutTrailingSeps + in (oneSep, rest <> trailingSeps) - (drv, pth) = FilePath.splitDrive fpath - (dir, file) = splitLast FilePath.isPathSeparator pth - (nameDot, ext) = splitLast FilePath.isExtSeparator file + (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: @@ -501,18 +505,18 @@ splitExtension (Path fpath) = -- @ -- -- @since 0.5.11 -fileExtension :: MonadThrow m => Path b File -> m String +fileExtension :: MonadThrow m => Path b File -> m PLATFORM_STRING fileExtension = (liftM snd) . splitExtension -- | Add extension to given file path. -- --- >>> addExtension ".foo" $(mkRelFile "name" ) == Just $(mkRelFile "name.foo" ) --- >>> addExtension ".foo." $(mkRelFile "name" ) == Just $(mkRelFile "name.foo." ) --- >>> addExtension ".foo.." $(mkRelFile "name" ) == Just $(mkRelFile "name.foo.." ) --- >>> addExtension ".foo" $(mkRelFile "name.bar" ) == Just $(mkRelFile "name.bar.foo") --- >>> addExtension ".foo" $(mkRelFile ".name" ) == Just $(mkRelFile ".name.foo" ) --- >>> addExtension ".foo" $(mkRelFile "name." ) == Just $(mkRelFile "name..foo" ) --- >>> addExtension ".foo" $(mkRelFile "..." ) == Just $(mkRelFile "....foo" ) +-- >>> 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 @@ -522,94 +526,43 @@ fileExtension = (liftM snd) . splitExtension -- have to first set @.foo@ and then @.bar@ individually. Some examples of -- invalid extensions are: -- --- >>> addExtension "foo" $(mkRelFile "name") --- >>> addExtension "..foo" $(mkRelFile "name") --- >>> addExtension ".foo.bar" $(mkRelFile "name") --- >>> addExtension ".foo/bar" $(mkRelFile "name") +-- >>> 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 - => String -- ^ Extension to add + => 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 - validateExtension ext - return $ Path (path ++ ext) + (sep, xtn) <- case OsString.uncons ext of + Nothing -> throwM $ InvalidExtension ext + Just result -> pure result - where + let withoutTrailingSeps = OsString.dropWhileEnd OsPath.isExtSeparator xtn - validateExtension ex@(sep:xs) = do - -- has to start with a "." - when (not $ FilePath.isExtSeparator sep) $ - throwM $ InvalidExtension ex + -- Has to start with a "." + when (not $ OsPath.isExtSeparator sep) $ + throwM $ InvalidExtension ext - -- just a "." is not a valid extension - when (xs == []) $ - throwM $ InvalidExtension ex + -- Cannot have path separators + when (OsString.any OsPath.isPathSeparator xtn) $ + throwM $ InvalidExtension ext - -- cannot have path separators - when (any FilePath.isPathSeparator xs) $ - throwM $ InvalidExtension ex + -- All "."s is not a valid extension + when (OsString.null withoutTrailingSeps) $ + throwM $ InvalidExtension ext - -- All "."s is not a valid extension - let ys = dropWhile FilePath.isExtSeparator (reverse xs) - when (ys == []) $ - throwM $ InvalidExtension ex + -- Cannot have "."s except in trailing position + when (OsString.any OsPath.isExtSeparator withoutTrailingSeps) $ + throwM $ InvalidExtension ext - -- Cannot have "."s except in trailing position - when (any FilePath.isExtSeparator ys) $ - throwM $ InvalidExtension ex - - -- must be valid as a filename - _ <- parseRelFile ex - return () - validateExtension ex = throwM $ InvalidExtension ex - --- | Add extension to given file path. Throws if the --- resulting filename does not parse. --- --- >>> addFileExtension "txt $(mkRelFile "foo") --- "foo.txt" --- >>> addFileExtension "symbols" $(mkRelFile "Data.List") --- "Data.List.symbols" --- >>> addFileExtension ".symbols" $(mkRelFile "Data.List") --- "Data.List.symbols" --- >>> addFileExtension "symbols" $(mkRelFile "Data.List.") --- "Data.List..symbols" --- >>> addFileExtension ".symbols" $(mkRelFile "Data.List.") --- "Data.List..symbols" --- >>> addFileExtension "evil/" $(mkRelFile "Data.List") --- *** Exception: InvalidRelFile "Data.List.evil/" --- --- @since 0.6.1 -{-# DEPRECATED addFileExtension "Please use addExtension instead." #-} -addFileExtension :: MonadThrow m - => String -- ^ Extension to add - -> Path b File -- ^ Old file name - -> m (Path b File) -- ^ New file name with the desired extension added at the end -addFileExtension ext (Path path) = - if FilePath.isAbsolute path - then liftM coercePath (parseAbsFile (FilePath.addExtension path ext)) - else liftM coercePath (parseRelFile (FilePath.addExtension path ext)) - where coercePath :: Path a b -> Path a' b' - coercePath (Path a) = Path a + -- Must be valid as a filename + _ <- parseRelFile ext --- | A synonym for 'addFileExtension' in the form of an infix operator. --- See more examples there. --- --- >>> $(mkRelFile "Data.List") <.> "symbols" --- "Data.List.symbols" --- >>> $(mkRelFile "Data.List") <.> "evil/" --- *** Exception: InvalidRelFile "Data.List.evil/" --- --- @since 0.6.1 -infixr 7 <.> -{-# DEPRECATED (<.>) "Please use addExtension instead." #-} -(<.>) :: MonadThrow m - => Path b File -- ^ Old file name - -> String -- ^ Extension to add - -> m (Path b File) -- ^ New file name with the desired extension added at the end -(<.>) = flip addFileExtension + 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 @@ -622,81 +575,65 @@ infixr 7 <.> -- -- @since 0.7.0 replaceExtension :: MonadThrow m - => String -- ^ Extension to set + => 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) --- | Replace\/add extension to given file path. Throws if the --- resulting filename does not parse. --- --- @since 0.5.11 -{-# DEPRECATED setFileExtension "Please use replaceExtension instead." #-} -setFileExtension :: MonadThrow m - => String -- ^ Extension to set - -> Path b File -- ^ Old file name - -> m (Path b File) -- ^ New file name with the desired extension -setFileExtension ext (Path path) = - if FilePath.isAbsolute path - then liftM coercePath (parseAbsFile (FilePath.replaceExtension path ext)) - else liftM coercePath (parseRelFile (FilePath.replaceExtension path ext)) - where coercePath :: Path a b -> Path a' b' - coercePath (Path a) = Path a - --- | A synonym for 'setFileExtension' in the form of an operator. --- --- @since 0.6.0 -infixr 7 -<.> -{-# DEPRECATED (-<.>) "Please use replaceExtension instead." #-} -(-<.>) :: MonadThrow m - => Path b File -- ^ Old file name - -> String -- ^ Extension to set - -> m (Path b File) -- ^ New file name with the desired extension -(-<.>) = flip setFileExtension - -------------------------------------------------------------------------------- -- Parsers --- | Convert an absolute 'FilePath' to a normalized absolute dir 'Path'. +-- | 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 'FilePath.isValid') +-- * is not a valid path (See 'OsPath.isValid') -- parseAbsDir :: MonadThrow m - => FilePath -> m (Path Abs Dir) -parseAbsDir filepath = - if FilePath.isAbsolute filepath && - not (hasParentDir filepath) && - FilePath.isValid filepath - then return (Path (normalizeDir filepath)) - else throwM (InvalidAbsDir filepath) + => PLATFORM_PATH -> m (Path Abs Dir) +parseAbsDir ospath + | validAbsDir ospath = return (Path (normalizeDir ospath)) + | otherwise = throwM (InvalidAbsDir ospath) --- | Convert a relative 'FilePath' to a normalized relative dir 'Path'. +-- | Is the string a valid absolute dir? +validAbsDir :: PLATFORM_PATH -> Bool +validAbsDir ospath = + OsPath.isAbsolute ospath && + not (hasParentDir ospath) && + OsPath.isValid 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 'FilePath.isValid') +-- * is not a valid path (See 'OsPath.isValid') -- * is all path separators -- parseRelDir :: MonadThrow m - => FilePath -> m (Path Rel Dir) -parseRelDir filepath = - if not (FilePath.isAbsolute filepath) && - not (hasParentDir filepath) && - not (null filepath) && - not (all FilePath.isPathSeparator filepath) && - FilePath.isValid filepath - then return (Path (normalizeDir filepath)) - else throwM (InvalidRelDir filepath) - --- | Convert an absolute 'FilePath' to a normalized absolute file 'Path'. + => PLATFORM_PATH -> m (Path Rel Dir) +parseRelDir ospath + | validRelDir ospath = return (Path (normalizeDir ospath)) + | otherwise = throwM (InvalidRelDir ospath) + +-- | Is the string a valid relative dir? +validRelDir :: PLATFORM_PATH -> Bool +validRelDir ospath = + not (OsPath.isAbsolute ospath) && + not (OsString.null ospath) && + not (hasParentDir ospath) && + not (OsString.all OsPath.isPathSeparator ospath) && + OsPath.isValid ospath + +-- | Convert an absolute PLATFORM_PATH_SINGLE to a normalized absolute file +-- 'Path'. -- -- Throws: 'InvalidAbsFile' when the supplied path: -- @@ -707,27 +644,26 @@ parseRelDir filepath = -- * is @.@ or ends in @/.@ -- -- * contains a @..@ path component representing the parent directory --- * is not a valid path (See 'FilePath.isValid') +-- * is not a valid path (See 'OsPath.isValid') -- parseAbsFile :: MonadThrow m - => FilePath -> m (Path Abs File) -parseAbsFile filepath = - case validAbsFile filepath of - True - | normalized <- normalizeFilePath filepath - , validAbsFile normalized -> - return (Path normalized) - _ -> throwM (InvalidAbsFile filepath) + => PLATFORM_PATH -> m (Path Abs File) +parseAbsFile ospath + | validAbsFile ospath + , let normalized = normalizeFilePath ospath + , validAbsFile normalized = return (Path normalized) + | otherwise = throwM (InvalidAbsFile ospath) -- | Is the string a valid absolute file? -validAbsFile :: FilePath -> Bool -validAbsFile filepath = - FilePath.isAbsolute filepath && - not (FilePath.hasTrailingPathSeparator filepath) && - not (hasParentDir filepath) && - FilePath.isValid filepath +validAbsFile :: PLATFORM_PATH -> Bool +validAbsFile ospath = + OsPath.isAbsolute ospath && + not (OsPath.hasTrailingPathSeparator ospath) && + not (hasParentDir ospath) && + OsPath.isValid ospath --- | Convert a relative 'FilePath' to a normalized relative file 'Path'. +-- | Convert a relative PLATFORM_PATH_SINGLE to a normalized relative file +-- 'Path'. -- -- Throws: 'InvalidRelFile' when the supplied path: -- @@ -739,44 +675,44 @@ validAbsFile filepath = -- * is @.@ or ends in @/.@ -- -- * contains a @..@ path component representing the parent directory --- * is not a valid path (See 'FilePath.isValid') +-- * is not a valid path (See 'OsPath.isValid') -- parseRelFile :: MonadThrow m - => FilePath -> m (Path Rel File) -parseRelFile filepath = - case validRelFile filepath of - True - | normalized <- normalizeFilePath filepath - , validRelFile normalized -> return (Path normalized) - _ -> throwM (InvalidRelFile filepath) + => PLATFORM_PATH -> m (Path Rel File) +parseRelFile ospath + | validRelFile ospath + , let normalized = normalizeFilePath ospath + , validRelFile normalized = return (Path normalized) + | otherwise = throwM (InvalidRelFile ospath) -- | Is the string a valid relative file? -validRelFile :: FilePath -> Bool -validRelFile filepath = - not - (FilePath.isAbsolute filepath || FilePath.hasTrailingPathSeparator filepath) && - not (null filepath) && - not (hasParentDir filepath) && - filepath /= "." && FilePath.isValid filepath +validRelFile :: PLATFORM_PATH -> Bool +validRelFile ospath = + not (OsPath.isAbsolute ospath) && + not (OsString.null ospath) && + not (hasParentDir ospath) && + not (OsPath.hasTrailingPathSeparator ospath) && + ospath /= [OsPath.pstr|.|] && + OsPath.isValid ospath -------------------------------------------------------------------------------- -- Conversion --- | Convert absolute path to directory to 'FilePath' type. -fromAbsDir :: Path Abs Dir -> FilePath -fromAbsDir = toFilePath +-- | Convert absolute path to directory to PLATFORM_PATH_SINGLE type. +fromAbsDir :: Path Abs Dir -> PLATFORM_PATH +fromAbsDir = toOsPath --- | Convert relative path to directory to 'FilePath' type. -fromRelDir :: Path Rel Dir -> FilePath -fromRelDir = toFilePath +-- | Convert relative path to directory to PLATFORM_PATH_SINGLE type. +fromRelDir :: Path Rel Dir -> PLATFORM_PATH +fromRelDir = toOsPath --- | Convert absolute path to file to 'FilePath' type. -fromAbsFile :: Path Abs File -> FilePath -fromAbsFile = toFilePath +-- | Convert absolute path to file to PLATFORM_PATH_SINGLE type. +fromAbsFile :: Path Abs File -> PLATFORM_PATH +fromAbsFile = toOsPath --- | Convert relative path to file to 'FilePath' type. -fromRelFile :: Path Rel File -> FilePath -fromRelFile = toFilePath +-- | Convert relative path to file to PLATFORM_PATH_SINGLE type. +fromRelFile :: Path Rel File -> PLATFORM_PATH +fromRelFile = toOsPath -------------------------------------------------------------------------------- -- Constructors @@ -786,79 +722,30 @@ fromRelFile = toFilePath -- Remember: due to the nature of absolute paths this (e.g. @\/home\/foo@) -- may compile on your platform, but it may not compile on another -- platform (Windows). -mkAbsDir :: FilePath -> Q Exp -mkAbsDir = either (error . show) lift . parseAbsDir +mkAbsDir :: PLATFORM_PATH -> Q Exp +mkAbsDir = either (fail . displayException) lift . parseAbsDir -- | Make a 'Path' 'Rel' 'Dir'. -mkRelDir :: FilePath -> Q Exp -mkRelDir = either (error . show) lift . parseRelDir +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 :: FilePath -> Q Exp -mkAbsFile = either (error . show) lift . parseAbsFile +mkAbsFile :: PLATFORM_PATH -> Q Exp +mkAbsFile = either (fail . displayException) lift . parseAbsFile -- | Make a 'Path' 'Rel' 'File'. -mkRelFile :: FilePath -> Q Exp -mkRelFile = either (error . show) lift . parseRelFile +mkRelFile :: PLATFORM_PATH -> Q Exp +mkRelFile = either (fail . displayException) lift . parseRelFile -------------------------------------------------------------------------------- --- Internal functions - --- | Normalizes directory path with platform-specific rules. -normalizeDir :: FilePath -> FilePath -normalizeDir = - normalizeRelDir - . FilePath.addTrailingPathSeparator - . normalizeFilePath - where -- Represent a "." in relative dir path as "" internally so that it - -- composes without having to renormalize the path. - normalizeRelDir p - | p == relRootFP = "" - | otherwise = p - --- | 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 - -#if IS_WINDOWS --- | 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 [] - where normSeps ch [] = [ch] - normSeps ch path@(p0:_) - | FilePath.isPathSeparator ch && FilePath.isPathSeparator p0 = path - | FilePath.isPathSeparator ch = FilePath.pathSeparator:path - | otherwise = ch:path - --- | Normalizes seps in whole path, but if there are 2+ seps at the beginning, --- they are normalized to exactly 2 to preserve UNC and Unicode prefixed paths. -normalizeWindowsSeps :: FilePath -> FilePath -normalizeWindowsSeps path = normLeadingSeps ++ normalizeAllSeps rest - where (leadingSeps, rest) = span FilePath.isPathSeparator path - normLeadingSeps = replicate (min 2 (length leadingSeps)) FilePath.pathSeparator -#endif - --- | Applies platform-specific sep normalization following @FilePath.normalise@. -normalizeFilePath :: FilePath -> FilePath -#if IS_WINDOWS -normalizeFilePath = normalizeWindowsSeps . FilePath.normalise -#else -normalizeFilePath = normalizeLeadingSeps . FilePath.normalise -#endif +-- 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. +-- 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) @@ -871,10 +758,10 @@ instance Show (SomeBase t) where show = show . fromSomeBase instance ToJSON (SomeBase t) where - toJSON = toJSON . fromSomeBase + toJSON = prjSomeBase toJSON {-# INLINE toJSON #-} #if MIN_VERSION_aeson(0,10,0) - toEncoding = toEncoding . fromSomeBase + toEncoding = prjSomeBase toEncoding {-# INLINE toEncoding #-} #endif @@ -892,7 +779,7 @@ instance FromJSON (SomeBase File) where -- | Helper to project the contents out of a SomeBase object. -- --- >>> prjSomeBase toFilePath (Abs [absfile|/foo/bar/cow.moo|]) == "/foo/bar/cow.moo" +-- >>> 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 @@ -901,38 +788,38 @@ prjSomeBase f = \case -- | Helper to apply a function to the SomeBase object -- --- >>> mapSomeBase parent (Abs [absfile|/foo/bar/cow.moo|]) == Abs [absdir|"/foo/bar"|] +-- >>> 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 = prjSomeBase toFilePath +-- | Convert a valid path to a PLATFORM_PATH_SINGLE. +fromSomeBase :: SomeBase t -> PLATFORM_PATH +fromSomeBase = prjSomeBase toOsPath --- | Convert a valid directory to a 'FilePath'. -fromSomeDir :: SomeBase Dir -> FilePath +-- | Convert a valid directory to a PLATFORM_PATH_SINGLE. +fromSomeDir :: SomeBase Dir -> PLATFORM_PATH fromSomeDir = fromSomeBase --- | Convert a valid file to a 'FilePath'. -fromSomeFile :: SomeBase File -> FilePath +-- | Convert a valid file to a PLATFORM_PATH_SINGLE. +fromSomeFile :: SomeBase File -> PLATFORM_PATH fromSomeFile = fromSomeBase --- | Convert an absolute or relative 'FilePath' to a normalized 'SomeBase' +-- | 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 'FilePath.isValid') -parseSomeDir :: MonadThrow m => FilePath -> m (SomeBase Dir) +-- * 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 'FilePath' to a normalized 'SomeBase' +-- | Convert an absolute or relative PLATFORM_PATH_SINGLE to a normalized 'SomeBase' -- representing a file. -- -- Throws: 'InvalidFile' when the supplied path: @@ -943,15 +830,164 @@ parseSomeDir fp = maybe (throwM (InvalidDir fp)) pure -- * is @.@ or ends in @/.@ -- -- * contains a @..@ path component representing the parent directory --- * is not a valid path (See 'FilePath.isValid') -parseSomeFile :: MonadThrow m => FilePath -> m (SomeBase File) +-- * 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) +-------------------------------------------------------------------------------- +-- Internal functions + +-- | Normalizes directory path with platform-specific rules. +normalizeDir :: PLATFORM_PATH -> PLATFORM_PATH +normalizeDir = + normalizeRelDir + . OsPath.addTrailingPathSeparator + . normalizeFilePath + 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 + +#if !IS_WINDOWS +-- | 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 +#else +-- | 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 + +-- | 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 + +-- | Applies platform-specific sep normalization following @OsPath.normalise@. +normalizeFilePath :: PLATFORM_PATH -> PLATFORM_PATH +#if IS_WINDOWS +normalizeFilePath = normalizeWindowsSeps . OsPath.normalise +#else +normalizeFilePath = normalizeLeadingSeps . OsPath.normalise +#endif + -------------------------------------------------------------------------------- -- 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 liftM coercePath (parseAbsFile (OsPath.addExtension path ext)) + else liftM coercePath (parseRelFile (OsPath.addExtension path ext)) + where coercePath :: Path a b -> Path a' b' + coercePath (Path a) = Path a + +-- | A synonym for 'addFileExtension' in the form of an infix operator. +-- See more examples there. +-- +-- >>> $(mkRelFile "Data.List") <.> [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 liftM coercePath (parseAbsFile (OsPath.replaceExtension path ext)) + else liftM coercePath (parseRelFile (OsPath.replaceExtension path ext)) + where coercePath :: Path a b -> Path a' b' + coercePath (Path a) = Path a + +-- | A synonym for 'setFileExtension' in the form of an operator. +-- +-- @since 0.6.0 +infixr 7 -<.> +{-# DEPRECATED (-<.>) "Please use replaceExtension instead." #-} +(-<.>) :: MonadThrow m + => Path b File -- ^ Old file name + -> 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 diff --git a/src/OsPath/Internal/Include.hs b/src/OsPath/Internal/Include.hs index a059896..23a3de5 100644 --- a/src/OsPath/Internal/Include.hs +++ b/src/OsPath/Internal/Include.hs @@ -1,6 +1,7 @@ -- This template expects CPP definitions for: -- PLATFORM_NAME = Posix | Windows -- PLATFORM_PATH = PosixPath | WindowsPath +-- PLATFORM_PATH_SINGLE = 'PosixPath' | 'WindowsPath' -- IS_WINDOWS = 0 | 1 {-# LANGUAGE DeriveGeneric #-} @@ -35,9 +36,7 @@ import qualified Data.Text as Text (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 import System.IO.Unsafe (unsafeDupablePerformIO) import System.OsPath.PLATFORM_NAME (PLATFORM_PATH) import qualified System.OsPath.PLATFORM_NAME as OsPath @@ -51,7 +50,7 @@ import qualified System.OsString.PLATFORM_NAME as OsString -- * @b@ — base, the base location of the path; absolute or relative. -- * @t@ — type, whether file or directory. -- --- Internally it is a byte string. The byte string can be of two formats only: +-- 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\/@ @@ -97,17 +96,25 @@ toOsPath (Path 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 :: FilePath -> Bool -hasParentDir filepath' = - (filepath' == "..") || - ("/.." `L.isSuffixOf` filepath) || - ("/../" `L.isInfixOf` filepath) || - ("../" `L.isPrefixOf` filepath) +hasParentDir :: PLATFORM_PATH -> Bool +hasParentDir ospath = + (ospath' == [OsString.pstr|..|]) || + (prefix' `OsString.isPrefixOf` ospath') || + (infix' `OsString.isInfixOf` ospath') || + (suffix' `OsString.isSuffixOf` ospath') where - filepath = - case FilePath.pathSeparator of - '/' -> filepath' - x -> map (\y -> if x == y then '/' else y) filepath' + 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 -- | Same as 'show . Path.toFilePath'. -- diff --git a/src/OsPath/Internal/Posix.hs b/src/OsPath/Internal/Posix.hs index 0ab6377..233afc5 100644 --- a/src/OsPath/Internal/Posix.hs +++ b/src/OsPath/Internal/Posix.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} -#define PLATFORM_NAME Posix -#define PLATFORM_PATH PosixPath -#define PLATFORM_STRING PosixString -#define IS_WINDOWS 0 +#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 index 869f5b9..75a6249 100644 --- a/src/OsPath/Internal/Windows.hs +++ b/src/OsPath/Internal/Windows.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} -#define PLATFORM_NAME Windows -#define PLATFORM_PATH WindowsPath -#define PLATFORM_STRING WindowsString -#define IS_WINDOWS 1 +#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 index 23a1b40..233afc5 100644 --- a/src/OsPath/Posix.hs +++ b/src/OsPath/Posix.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-} -#define PLATFORM_NAME Posix -#define IS_WINDOWS 0 +#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/Windows.hs b/src/OsPath/Windows.hs index 95b16e4..75a6249 100644 --- a/src/OsPath/Windows.hs +++ b/src/OsPath/Windows.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-} -#define PLATFORM_NAME Windows -#define IS_WINDOWS 1 +#define PLATFORM_NAME Windows +#define PLATFORM_PATH WindowsPath +#define PLATFORM_PATH_SINGLE 'WindowsPath' +#define PLATFORM_STRING WindowsString +#define IS_WINDOWS 1 #include "Include.hs" From c04a1870291afda2c354fea9b5c51a24181ffd1b Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Thu, 20 Jun 2024 03:59:09 +0200 Subject: [PATCH 20/52] Replicated test testsuite to test-ospath testsuite --- hie.yaml | 3 + path.cabal | 24 +++ test-ospath/Common/Include.hs | 317 ++++++++++++++++++++++++++++++++++ test-ospath/Common/Posix.hs | 7 + test-ospath/Common/Windows.hs | 16 ++ test-ospath/Main.hs | 12 ++ test-ospath/Posix.hs | 169 ++++++++++++++++++ test-ospath/TH/Include.hs | 46 +++++ test-ospath/TH/Posix.hs | 22 +++ test-ospath/TH/Windows.hs | 22 +++ test-ospath/Windows.hs | 179 +++++++++++++++++++ 11 files changed, 817 insertions(+) create mode 100644 test-ospath/Common/Include.hs create mode 100644 test-ospath/Common/Posix.hs create mode 100644 test-ospath/Common/Windows.hs create mode 100644 test-ospath/Main.hs create mode 100644 test-ospath/Posix.hs create mode 100644 test-ospath/TH/Include.hs create mode 100644 test-ospath/TH/Posix.hs create mode 100644 test-ospath/TH/Windows.hs create mode 100644 test-ospath/Windows.hs diff --git a/hie.yaml b/hie.yaml index 1834e4f..896c82d 100644 --- a/hie.yaml +++ b/hie.yaml @@ -6,5 +6,8 @@ cradle: - path: "test" component: "path:test:test" + - path: "test-ospath" + component: "path:test:test-ospath" + - path: "validity-test" component: "path:test:validity-test" diff --git a/path.cabal b/path.cabal index fc7ffcc..4026ceb 100644 --- a/path.cabal +++ b/path.cabal @@ -82,6 +82,30 @@ test-suite test ghc-options: -O2 -Wall default-language: Haskell2010 +test-suite test-ospath + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: Posix + , Windows + , Common.Posix + , Common.Windows + , TH.Posix + , TH.Windows + hs-source-dirs: test-ospath + build-depends: aeson + , base + , bytestring + , 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 validity-test type: exitcode-stdio-1.0 main-is: Main.hs diff --git a/test-ospath/Common/Include.hs b/test-ospath/Common/Include.hs new file mode 100644 index 0000000..5bf3124 --- /dev/null +++ b/test-ospath/Common/Include.hs @@ -0,0 +1,317 @@ +-- This template expects CPP definitions for: +-- PLATFORM_NAME = Posix | Windows + +{-# 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 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 \"name\" == \".\"" + (parent relDir == currentDir) + it + "parent \".\" == \".\"" + (parent currentDir == currentDir) + + forDrives $ \drive -> do + let absDir = drive relDir + it + "parent (absDir \"name\") == 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 \"/dir\" == (drive, Just \"dir\")" + (splitDrive absDir == (drive, Just relDir)) + it + "splitDrive \"/file\" == (drive, Just \"file\")" + (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 == _|_" + (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')) + +operationToFilePath :: Spec +operationToFilePath = do + let expected = "." ++ [FilePath.pathSeparator] + it + ("toFilePath \".\" == " ++ show expected) + (toFilePath currentDir == expected) + it + ("show \".\" == " ++ (show . show) expected) + (show currentDir == show expected) + +extensionOperations :: Spec +extensionOperations = do + let extension = ".foo" + let extensions = extension : [".foo.", ".foo.."] + + describe "Only filenames and extensions" $ + forM_ extensions $ \ext -> + forM_ filenames $ \f -> do + runTests parseRelFile f ext + + describe "Relative dir paths" $ + forM_ dirnames $ \d -> do + forM_ filenames $ \f -> do + let f1 = d ++ [FilePath.pathSeparator] ++ f + runTests parseRelFile f1 extension + + describe "Absolute dir paths" $ + forM_ drives_ $ \drive -> do + forM_ dirnames $ \dir -> do + forM_ filenames $ \file -> do + let filepath = drive ++ dir ++ [FilePath.pathSeparator] ++ file + runTests parseAbsFile filepath extension + + -- Invalid extensions + forM_ invalidExtensions $ \ext -> do + it ("throws InvalidExtension when extension is [" ++ ext ++ "]") $ + addExtension ext $(mkRelFile "name") + `shouldThrow` (== InvalidExtension ext) + + where + + 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 = + [ "name" + , "name." + , "name.." + , ".name" + , "..name" + , "name.name" + , "name..name" + , "..." + ] + dirnames = filenames ++ ["."] + invalidExtensions = + [ "" + , "." + , "x" + , ".." + , "..." + , "xy" + , "foo" + , "foo." + , "foo.." + , "..foo" + , "...foo" + , ".foo.bar" + , ".foo" ++ [FilePath.pathSeparator] ++ "bar" + ] + +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-ospath/Common/Posix.hs b/test-ospath/Common/Posix.hs new file mode 100644 index 0000000..5da8b2d --- /dev/null +++ b/test-ospath/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-ospath/Common/Windows.hs b/test-ospath/Common/Windows.hs new file mode 100644 index 0000000..1cbc129 --- /dev/null +++ b/test-ospath/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-ospath/Main.hs b/test-ospath/Main.hs new file mode 100644 index 0000000..a026e1c --- /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 index 0000000..932ffaf --- /dev/null +++ b/test-ospath/Posix.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE QuasiQuotes #-} + +-- | Test suite. + +module Posix (spec) where + +import Data.Aeson +import qualified Data.ByteString.Lazy.Char8 as LBS +import Test.Hspec + +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 +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 "Aeson Instances" aesonInstances + 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 "~/" (Path "~/") + parseSucceeds "~/foo" (Path "~/foo/") + parseSucceeds "~/foo/bar" (Path "~/foo/bar/") + parseSucceeds "a.." (Path "a../") + parseSucceeds "..a" (Path "..a/") + -- + parseFails "../" + parseFails ".." + parseFails "/.." + parseFails "/foo/../bar/" + parseFails "/foo/bar/.." + +-- | Tests for the tokenizer. +parseAbsDirSpec :: Spec +parseAbsDirSpec = + do failing "" + failing "./" + failing "foo.txt" + succeeding "/" (Path "/") + succeeding "//" (Path "/") + succeeding "///foo//bar//mu/" (Path "/foo/bar/mu/") + succeeding "///foo//bar////mu" (Path "/foo/bar/mu/") + succeeding "///foo//bar/.//mu" (Path "/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 "" + failing "/" + failing "//" + succeeding "~/" (Path "~/") -- https://github.com/chrisdone/path/issues/19 + failing "/" + succeeding "./" (Path "") + succeeding "././" (Path "") + failing "//" + failing "///foo//bar//mu/" + failing "///foo//bar////mu" + failing "///foo//bar/.//mu" + succeeding "..." (Path ".../") + succeeding "foo.bak" (Path "foo.bak/") + succeeding "./foo" (Path "foo/") + succeeding "././foo" (Path "foo/") + succeeding "./foo/./bar" (Path "foo/bar/") + succeeding "foo//bar//mu//" (Path "foo/bar/mu/") + succeeding "foo//bar////mu" (Path "foo/bar/mu/") + succeeding "foo//bar/.//mu" (Path "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 "" + failing "./" + failing "/." + failing "/foo/bar/." + failing "~/" + failing "./foo.txt" + failing "/" + failing "//" + failing "///foo//bar//mu/" + succeeding "/..." (Path "/...") + succeeding "/foo.txt" (Path "/foo.txt") + succeeding "///foo//bar////mu.txt" (Path "/foo/bar/mu.txt") + succeeding "///foo//bar/.//mu.txt" (Path "/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 "" + failing "/" + failing "//" + failing "~/" + failing "/" + failing "./" + failing "a/." + failing "a/../b" + failing "a/.." + failing "../foo.txt" + failing "//" + failing "///foo//bar//mu/" + failing "///foo//bar////mu" + failing "///foo//bar/.//mu" + succeeding "a.." (Path "a..") + succeeding "..." (Path "...") + succeeding "foo.txt" (Path "foo.txt") + succeeding "./foo.txt" (Path "foo.txt") + succeeding "././foo.txt" (Path "foo.txt") + succeeding "./foo/./bar.txt" (Path "foo/bar.txt") + succeeding "foo//bar//mu.txt" (Path "foo/bar/mu.txt") + succeeding "foo//bar////mu.txt" (Path "foo/bar/mu.txt") + succeeding "foo//bar/.//mu.txt" (Path "foo/bar/mu.txt") + + where failing x = parserTest parseRelFile x Nothing + succeeding x with = parserTest parseRelFile x (Just with) + +-- | Tests for the 'ToJSON' and 'FromJSON' instances +-- +-- Can't use overloaded strings due to some weird issue with bytestring-0.9.2.1 / ghc-7.4.2: +-- https://travis-ci.org/sjakobi/path/jobs/138399072#L989 +aesonInstances :: Spec +aesonInstances = + do it "Decoding \"[\"/foo/bar\"]\" as a [Path Abs Dir] should succeed." $ + eitherDecode (LBS.pack "[\"/foo/bar\"]") `shouldBe` Right [Path "/foo/bar/" :: Path Abs Dir] + it "Decoding \"[\"/foo/bar\"]\" as a [Path Rel Dir] should fail." $ + decode (LBS.pack "[\"/foo/bar\"]") `shouldBe` (Nothing :: Maybe [Path Rel Dir]) + it "Encoding \"[\"/foo/bar/mu.txt\"]\" should succeed." $ + encode [Path "/foo/bar/mu.txt" :: Path Abs File] `shouldBe` (LBS.pack "[\"/foo/bar/mu.txt\"]") + +-- | Test QuasiQuoters. Make sure they work the same as the $(mk*) constructors. +quasiquotes :: Spec +quasiquotes = + do it "[absdir|/|] == $(mkAbsDir \"/\")" + ([absdir|/|] `shouldBe` $(mkAbsDir "/")) + it "[absdir|/home|] == $(mkAbsDir \"/home\")" + ([absdir|/home|] `shouldBe` $(mkAbsDir "/home")) + it "[reldir|foo|] == $(mkRelDir \"foo\")" + ([reldir|foo|] `shouldBe` $(mkRelDir "foo")) + it "[reldir|foo/bar|] == $(mkRelDir \"foo/bar\")" + ([reldir|foo/bar|] `shouldBe` $(mkRelDir "foo/bar")) + it "[absfile|/home/chris/foo.txt|] == $(mkAbsFile \"/home/chris/foo.txt\")" + ([absfile|/home/chris/foo.txt|] `shouldBe` $(mkAbsFile "/home/chris/foo.txt")) + it "[relfile|foo|] == $(mkRelFile \"foo\")" + ([relfile|foo|] `shouldBe` $(mkRelFile "foo")) + it "[relfile|chris/foo.txt|] == $(mkRelFile \"chris/foo.txt\")" + ([relfile|chris/foo.txt|] `shouldBe` $(mkRelFile "chris/foo.txt")) diff --git a/test-ospath/TH/Include.hs b/test-ospath/TH/Include.hs new file mode 100644 index 0000000..3e1bf30 --- /dev/null +++ b/test-ospath/TH/Include.hs @@ -0,0 +1,46 @@ +-- This template expects CPP definitions for: +-- PLATFORM_NAME = Posix | Windows + +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +-- | Test functions to check the template haskell bits. +module TH.PLATFORM_NAME where + +import qualified Language.Haskell.TH.Syntax as TH + +import Path.Internal.PLATFORM_NAME +import Path.PLATFORM_NAME + +-- | This is a helper type class that checks that splices produce a 'Path' with +-- all type variables instantiated to a type. +-- This ensures that bugs like https://github.com/commercialhaskell/path/issues/159 +-- cannot happen. +class CheckInstantiated a b where + checkInstantiated :: Path a b -> FilePath + checkInstantiated = toFilePath + +instance CheckInstantiated Abs Dir +instance CheckInstantiated Abs File +instance CheckInstantiated Rel Dir +instance CheckInstantiated Rel File + +qqRelDir :: FilePath +qqRelDir = checkInstantiated [reldir|name/|] + +qqRelFile :: FilePath +qqRelFile = checkInstantiated [relfile|name|] + +thRelDir :: FilePath +thRelDir = checkInstantiated $(mkRelDir "name/") + +thRelFile :: FilePath +thRelFile = checkInstantiated $(mkRelFile "name") + +liftRelDir :: FilePath +liftRelDir = checkInstantiated $(TH.lift (Path "name/" :: Path Rel Dir)) + +liftRelFile :: FilePath +liftRelFile = checkInstantiated $(TH.lift (Path "name" :: Path Rel File)) diff --git a/test-ospath/TH/Posix.hs b/test-ospath/TH/Posix.hs new file mode 100644 index 0000000..a193382 --- /dev/null +++ b/test-ospath/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-ospath/TH/Windows.hs b/test-ospath/TH/Windows.hs new file mode 100644 index 0000000..acf5c77 --- /dev/null +++ b/test-ospath/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-ospath/Windows.hs b/test-ospath/Windows.hs new file mode 100644 index 0000000..24f6075 --- /dev/null +++ b/test-ospath/Windows.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Test suite. + +module Windows (spec) where + +import Data.Aeson +import qualified Data.ByteString.Lazy.Char8 as LBS +import Test.Hspec + +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 +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 "Aeson Instances" aesonInstances + describe "QuasiQuotes" quasiquotes + +-- | Restricting the input of any tricks. +restrictions :: Spec +restrictions = + do parseFails "..\\" + parseFails ".." + parseSucceeds "a.." (Path "a..\\") + parseSucceeds "..a" (Path "..a\\") + parseFails "\\.." + parseFails "C:\\foo\\..\\bar\\" + parseFails "C:\\foo\\bar\\.." + +-- | Tests for the tokenizer. +parseAbsDirSpec :: Spec +parseAbsDirSpec = + do failing "" + failing ".\\" + failing "foo.txt" + failing "C:" + succeeding "C:\\" (Path "C:\\") + succeeding "C:\\\\" (Path "C:\\") + succeeding "C:\\\\\\foo\\\\bar\\\\mu\\" (Path "C:\\foo\\bar\\mu\\") + succeeding "C:\\\\\\foo\\\\bar\\\\mu" (Path "C:\\foo\\bar\\mu\\") + succeeding "C:\\\\\\foo\\\\bar\\.\\\\mu" (Path "C:\\foo\\bar\\mu\\") + succeeding "\\\\unchost\\share" (Path "\\\\unchost\\share\\") + succeeding "\\/unchost\\share" (Path "\\\\unchost\\share\\") + succeeding "\\\\unchost\\share\\\\folder\\" (Path "\\\\unchost\\share\\folder\\") + succeeding "\\\\?\\C:\\" (Path "\\\\?\\C:\\") + succeeding "/\\?\\C:\\" (Path "\\\\?\\C:\\") + succeeding "\\\\?\\C:\\\\\\folder\\\\" (Path "\\\\?\\C:\\folder\\") + + where failing x = parserTest parseAbsDir x Nothing + succeeding x with = parserTest parseAbsDir x (Just with) + +-- | Tests for the tokenizer. +parseRelDirSpec :: Spec +parseRelDirSpec = + do failing "" + failing "/" + failing "//" + failing "\\" + failing "\\\\" + failing "\\\\\\foo\\\\bar\\\\mu\\" + failing "\\\\\\foo\\\\bar\\\\\\\\mu" + failing "\\\\\\foo\\\\bar\\.\\\\mu" + failing "\\\\unchost\\share" + failing "\\\\?\\C:\\" + succeeding ".\\" (Path "") + succeeding ".\\.\\" (Path "") + succeeding "..." (Path "...\\") + succeeding "foo.bak" (Path "foo.bak\\") + succeeding ".\\foo" (Path "foo\\") + succeeding ".\\.\\foo" (Path "foo\\") + succeeding ".\\foo\\.\\bar" (Path "foo\\bar\\") + succeeding "foo\\\\bar\\\\mu\\\\" (Path "foo\\bar\\mu\\") + succeeding "foo\\\\bar////mu" (Path "foo\\bar\\mu\\") + succeeding "foo\\\\bar\\.\\\\mu" (Path "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 "" + failing ".\\" + failing "\\." + failing "\\foo\\bar\\." + failing "~\\" + failing ".\\foo.txt" + failing "\\" + failing "\\\\" + failing "\\\\\\foo\\\\bar\\\\mu\\" + failing "\\..." + failing "\\foo.txt" + succeeding "C:\\\\\\foo\\\\bar\\\\\\\\mu.txt" (Path "C:\\foo\\bar\\mu.txt") + succeeding "C:\\\\\\foo\\\\bar\\.\\\\mu.txt" (Path "C:\\foo\\bar\\mu.txt") + succeeding "\\\\unchost\\share\\\\file.txt" (Path "\\\\unchost\\share\\file.txt") + succeeding "\\/unchost\\share\\\\file.txt" (Path "\\\\unchost\\share\\file.txt") + succeeding "\\\\unchost\\share\\.\\folder\\\\\\file.txt" (Path "\\\\unchost\\share\\folder\\file.txt") + succeeding "\\\\?\\C:\\file.txt" (Path "\\\\?\\C:\\file.txt") + succeeding "/\\?\\C:\\file.txt" (Path "\\\\?\\C:\\file.txt") + succeeding "\\\\?\\C:\\\\\\folder\\.\\\\file.txt" (Path "\\\\?\\C:\\folder\\file.txt") + + where failing x = parserTest parseAbsFile x Nothing + succeeding x with = parserTest parseAbsFile x (Just with) + +-- | Tests for the tokenizer. +parseRelFileSpec :: Spec +parseRelFileSpec = + do failing "" + failing "\\" + failing "\\\\" + failing "~\\" + failing "\\" + failing ".\\" + failing "a\\." + failing "a\\..\\b" + failing "a\\.." + failing "..\\foo.txt" + failing "\\\\" + failing "\\\\\\foo\\\\bar\\\\mu\\" + failing "\\\\\\foo\\\\bar\\\\\\\\mu" + failing "\\\\\\foo\\\\bar\\.\\\\mu" + failing "\\\\unchost\\share\\\\file.txt" + failing "\\\\?\\C:\\file.txt" + succeeding "a.." (Path "a..") + succeeding "..." (Path "...") + succeeding "foo.txt" (Path "foo.txt") + succeeding ".\\foo.txt" (Path "foo.txt") + succeeding ".\\.\\foo.txt" (Path "foo.txt") + succeeding ".\\foo\\.\\bar.txt" (Path "foo\\bar.txt") + succeeding "foo\\\\bar\\\\mu.txt" (Path "foo\\bar\\mu.txt") + succeeding "foo\\\\bar\\\\\\\\mu.txt" (Path "foo\\bar\\mu.txt") + succeeding "foo\\\\bar\\.\\\\mu.txt" (Path "foo\\bar\\mu.txt") + + where failing x = parserTest parseRelFile x Nothing + succeeding x with = parserTest parseRelFile x (Just with) + +-- | Tests for the 'ToJSON' and 'FromJSON' instances +-- +-- Can't use overloaded strings due to some weird issue with bytestring-0.9.2.1 / ghc-7.4.2: +-- https://travis-ci.org/sjakobi/path/jobs/138399072#L989 +aesonInstances :: Spec +aesonInstances = + do it "Decoding \"[\"C:\\\\foo\\\\bar\"]\" as a [Path Abs Dir] should succeed." $ + eitherDecode (LBS.pack "[\"C:\\\\foo\\\\bar\"]") `shouldBe` Right [Path "C:\\foo\\bar\\" :: Path Abs Dir] + it "Decoding \"[\"C:\\foo\\bar\"]\" as a [Path Rel Dir] should fail." $ + decode (LBS.pack "[\"C:\\foo\\bar\"]") `shouldBe` (Nothing :: Maybe [Path Rel Dir]) + it "Encoding \"[\"C:\\foo\\bar\\mu.txt\"]\" should succeed." $ + encode [Path "C:\\foo\\bar\\mu.txt" :: Path Abs File] `shouldBe` (LBS.pack "[\"C:\\\\foo\\\\bar\\\\mu.txt\"]") + +-- | 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 "C:\\")) + it "[absdir|C:\\chris\\|] == $(mkAbsDir \"C:\\chris\\\")" + ([absdir|C:\chris\|] `shouldBe` $(mkAbsDir "C:\\chris\\")) + it "[reldir|foo|] == $(mkRelDir \"foo\")" + ([reldir|foo|] `shouldBe` $(mkRelDir "foo")) + it "[reldir|foo\\bar|] == $(mkRelDir \"foo\\bar\")" + ([reldir|foo\bar|] `shouldBe` $(mkRelDir "foo\\bar")) + it "[absfile|C:\\chris\\foo.txt|] == $(mkAbsFile \"C:\\chris\\foo.txt\")" + ([absfile|C:\chris\foo.txt|] `shouldBe` $(mkAbsFile "C:\\chris\\foo.txt")) + it "[relfile|foo.exe|] == $(mkRelFile \"foo.exe\")" + ([relfile|foo.exe|] `shouldBe` $(mkRelFile "foo.exe")) + it "[relfile|chris\\foo.txt|] == $(mkRelFile \"chris\\foo.txt\")" + ([relfile|chris\foo.txt|] `shouldBe` $(mkRelFile "chris\\foo.txt")) From 588b90cc15e4f3c08ee2c3ad9a61dfbbfc982747 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Thu, 20 Jun 2024 12:13:02 +0200 Subject: [PATCH 21/52] Use OsPath modules in test-ospath --- path.cabal | 2 + test-ospath/Common/Include.hs | 125 +++++++++++++--------- test-ospath/Common/Posix.hs | 6 +- test-ospath/Common/Windows.hs | 18 ++-- test-ospath/Posix.hs | 169 ++++++++++++++--------------- test-ospath/TH/Include.hs | 13 +-- test-ospath/TH/Posix.hs | 8 +- test-ospath/TH/Windows.hs | 8 +- test-ospath/Windows.hs | 195 +++++++++++++++++----------------- 9 files changed, 288 insertions(+), 256 deletions(-) diff --git a/path.cabal b/path.cabal index 4026ceb..3111197 100644 --- a/path.cabal +++ b/path.cabal @@ -95,9 +95,11 @@ test-suite test-ospath build-depends: aeson , base , bytestring + , exceptions , filepath , hspec >= 2.0 && < 3 , mtl >= 2.0 && < 3 + , os-string , path , template-haskell if flag(dev) diff --git a/test-ospath/Common/Include.hs b/test-ospath/Common/Include.hs index 5bf3124..7df61ef 100644 --- a/test-ospath/Common/Include.hs +++ b/test-ospath/Common/Include.hs @@ -1,6 +1,11 @@ -- 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 @@ -13,26 +18,31 @@ module Common.PLATFORM_NAME 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 System.OsPath.PLATFORM_NAME (PLATFORM_PATH) +import qualified System.OsPath.PLATFORM_NAME as OsPath +import System.OsString.PLATFORM_NAME (PLATFORM_STRING) +import qualified System.OsString.PLATFORM_NAME as OsString import Test.Hspec -import Path.Internal.PLATFORM_NAME -import Path.PLATFORM_NAME +import OsPath.PLATFORM_NAME +import OsPath.Internal.PLATFORM_NAME currentDir :: Path Rel Dir -currentDir = (fromJust . parseRelDir) "." +currentDir = (fromJust . parseRelDir) [OsString.pstr|.|] drives :: NonEmpty (Path Abs Dir) drives = (fromJust . traverse parseAbsDir) drives_ relDir :: Path Rel Dir -relDir = (fromJust . parseRelDir) "directory" +relDir = (fromJust . parseRelDir) [OsString.pstr|directory|] relFile :: Path Rel File -relFile = (fromJust . parseRelFile) "file" +relFile = (fromJust . parseRelFile) [OsString.pstr|file|] spec :: Spec spec = do @@ -64,7 +74,7 @@ operationDirname = do (dirname (absDir relDir) == dirname relDir) it "dirname of a drive must be a Rel path" - (isNothing (parseAbsDir . toFilePath . dirname $ drive)) + (isNothing (parseAbsDir . toOsPath . dirname $ drive)) -- | The 'filename' operation. operationFilename :: Spec @@ -171,7 +181,7 @@ operationAppend = do Path relFile' = relFile it "RelDir + RelDir == RelDir" - (relDir relDir == Path (relDir' FilePath. relDir')) + (relDir relDir == Path (relDir' OsPath. relDir')) it "\".\" + \".\" == \".\"" (currentDir currentDir == currentDir) @@ -183,16 +193,16 @@ operationAppend = do (relDir currentDir == relDir) it "RelDir + RelFile == RelFile" - (relDir relFile == Path (relDir' FilePath. relFile')) + (relDir relFile == Path (relDir' OsPath. relFile')) forDrives $ \drive -> do let absDir@(Path absDir') = drive relDir it "AbsDir + RelDir == AbsDir" - (absDir relDir == Path (absDir' FilePath. relDir')) + (absDir relDir == Path (absDir' OsPath. relDir')) it "AbsDir + RelFile == AbsFile" - (absDir relFile == Path (absDir' FilePath. relFile')) + (absDir relFile == Path (absDir' OsPath. relFile')) operationToFilePath :: Spec operationToFilePath = do @@ -206,73 +216,86 @@ operationToFilePath = do extensionOperations :: Spec extensionOperations = do - let extension = ".foo" - let extensions = extension : [".foo.", ".foo.."] + let extension = [OsString.pstr|.foo|] + let extensions = + [ extension + , [OsString.pstr|.foo.|] + , [OsString.pstr|.foo..|] + ] describe "Only filenames and extensions" $ forM_ extensions $ \ext -> - forM_ filenames $ \f -> do - runTests parseRelFile f ext + forM_ filenames $ \file -> do + runTests parseRelFile file ext describe "Relative dir paths" $ - forM_ dirnames $ \d -> do - forM_ filenames $ \f -> do - let f1 = d ++ [FilePath.pathSeparator] ++ f - runTests parseRelFile f1 extension + forM_ dirnames $ \dir -> do + forM_ filenames $ \file -> do + let ospath = dir <> OsString.singleton OsPath.pathSeparator <> file + runTests parseRelFile ospath extension describe "Absolute dir paths" $ forM_ drives_ $ \drive -> do forM_ dirnames $ \dir -> do forM_ filenames $ \file -> do - let filepath = drive ++ dir ++ [FilePath.pathSeparator] ++ file - runTests parseAbsFile filepath extension + let ospath = drive <> dir <> pathSep <> file + runTests parseAbsFile ospath extension -- Invalid extensions forM_ invalidExtensions $ \ext -> do - it ("throws InvalidExtension when extension is [" ++ ext ++ "]") $ - addExtension ext $(mkRelFile "name") + it ("throws InvalidExtension when extension is " ++ show ext) $ + addExtension ext $(mkRelFile [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) + 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.") $ + _ -> 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 + ++ show (file <> ext) ++ " parsed to " ++ show maybePathFileWithExt + filenames :: [PLATFORM_PATH] filenames = - [ "name" - , "name." - , "name.." - , ".name" - , "..name" - , "name.name" - , "name..name" - , "..." + [ [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 = filenames ++ ["."] + + dirnames :: [PLATFORM_PATH] + dirnames = filenames ++ [ [OsString.pstr|.|] ] + + invalidExtensions :: [PLATFORM_STRING] invalidExtensions = - [ "" - , "." - , "x" - , ".." - , "..." - , "xy" - , "foo" - , "foo." - , "foo.." - , "..foo" - , "...foo" - , ".foo.bar" - , ".foo" ++ [FilePath.pathSeparator] ++ "bar" + [ [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|] ] -validExtensionsSpec :: String -> Path b File -> Path b File -> Spec +validExtensionsSpec :: PLATFORM_STRING -> Path b File -> Path b File -> Spec validExtensionsSpec ext file fext = do let f = show $ toFilePath file let fx = show $ toFilePath fext @@ -280,7 +303,7 @@ validExtensionsSpec ext file fext = do it ("addExtension " ++ show ext ++ " " ++ f ++ " == " ++ fx) $ addExtension ext file `shouldReturn` fext - it ("fileExtension " ++ fx ++ " == " ++ ext) $ + it ("fileExtension " ++ fx ++ " == " ++ show ext) $ fileExtension fext `shouldReturn` ext it ("replaceExtension " ++ show ext ++ " " ++ fx ++ " == " ++ fx) $ @@ -292,14 +315,14 @@ forDrives f = case drives of _ -> forM_ drives $ \drive -> describe ("Drive " ++ show drive) (f drive) -parseFails :: FilePath -> Spec +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 :: FilePath -> Path Rel Dir -> Spec +parseSucceeds :: PLATFORM_PATH -> Path Rel Dir -> Spec parseSucceeds x with = parserTest parseRelDir x (Just with) -- | Parser test. diff --git a/test-ospath/Common/Posix.hs b/test-ospath/Common/Posix.hs index 5da8b2d..d9bfde3 100644 --- a/test-ospath/Common/Posix.hs +++ b/test-ospath/Common/Posix.hs @@ -1,7 +1,9 @@ {-# LANGUAGE CPP #-} #define PLATFORM_NAME Posix +#define PLATFORM_PATH PosixPath +#define PLATFORM_STRING PosixString #include "Include.hs" -drives_ :: NonEmpty FilePath -drives_ = NonEmpty.singleton "/" +drives_ :: NonEmpty PLATFORM_PATH +drives_ = NonEmpty.singleton [OsString.pstr|/|] diff --git a/test-ospath/Common/Windows.hs b/test-ospath/Common/Windows.hs index 1cbc129..9aa84f4 100644 --- a/test-ospath/Common/Windows.hs +++ b/test-ospath/Common/Windows.hs @@ -1,16 +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 FilePath +drives_ :: NonEmpty PLATFORM_STRING 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 + [ [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/Posix.hs b/test-ospath/Posix.hs index 932ffaf..c4192dc 100644 --- a/test-ospath/Posix.hs +++ b/test-ospath/Posix.hs @@ -9,12 +9,13 @@ module Posix (spec) where import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified System.OsString.Posix as OsString import Test.Hspec import Common.Posix (parseFails, parseSucceeds, parserTest) import qualified Common.Posix -import Path.Posix -import Path.Internal.Posix +import OsPath.Posix +import OsPath.Internal.Posix import TH.Posix () -- | Test suite (Posix version). @@ -34,29 +35,29 @@ restrictions :: Spec restrictions = do -- These ~ related ones below are now lifted: -- https://github.com/chrisdone/path/issues/19 - parseSucceeds "~/" (Path "~/") - parseSucceeds "~/foo" (Path "~/foo/") - parseSucceeds "~/foo/bar" (Path "~/foo/bar/") - parseSucceeds "a.." (Path "a../") - parseSucceeds "..a" (Path "..a/") + 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 "../" - parseFails ".." - parseFails "/.." - parseFails "/foo/../bar/" - parseFails "/foo/bar/.." + 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 "" - failing "./" - failing "foo.txt" - succeeding "/" (Path "/") - succeeding "//" (Path "/") - succeeding "///foo//bar//mu/" (Path "/foo/bar/mu/") - succeeding "///foo//bar////mu" (Path "/foo/bar/mu/") - succeeding "///foo//bar/.//mu" (Path "/foo/bar/mu/") + 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) @@ -64,25 +65,25 @@ parseAbsDirSpec = -- | Tests for the tokenizer. parseRelDirSpec :: Spec parseRelDirSpec = - do failing "" - failing "/" - failing "//" - succeeding "~/" (Path "~/") -- https://github.com/chrisdone/path/issues/19 - failing "/" - succeeding "./" (Path "") - succeeding "././" (Path "") - failing "//" - failing "///foo//bar//mu/" - failing "///foo//bar////mu" - failing "///foo//bar/.//mu" - succeeding "..." (Path ".../") - succeeding "foo.bak" (Path "foo.bak/") - succeeding "./foo" (Path "foo/") - succeeding "././foo" (Path "foo/") - succeeding "./foo/./bar" (Path "foo/bar/") - succeeding "foo//bar//mu//" (Path "foo/bar/mu/") - succeeding "foo//bar////mu" (Path "foo/bar/mu/") - succeeding "foo//bar/.//mu" (Path "foo/bar/mu/") + 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) @@ -90,19 +91,19 @@ parseRelDirSpec = -- | Tests for the tokenizer. parseAbsFileSpec :: Spec parseAbsFileSpec = - do failing "" - failing "./" - failing "/." - failing "/foo/bar/." - failing "~/" - failing "./foo.txt" - failing "/" - failing "//" - failing "///foo//bar//mu/" - succeeding "/..." (Path "/...") - succeeding "/foo.txt" (Path "/foo.txt") - succeeding "///foo//bar////mu.txt" (Path "/foo/bar/mu.txt") - succeeding "///foo//bar/.//mu.txt" (Path "/foo/bar/mu.txt") + 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) @@ -110,29 +111,29 @@ parseAbsFileSpec = -- | Tests for the tokenizer. parseRelFileSpec :: Spec parseRelFileSpec = - do failing "" - failing "/" - failing "//" - failing "~/" - failing "/" - failing "./" - failing "a/." - failing "a/../b" - failing "a/.." - failing "../foo.txt" - failing "//" - failing "///foo//bar//mu/" - failing "///foo//bar////mu" - failing "///foo//bar/.//mu" - succeeding "a.." (Path "a..") - succeeding "..." (Path "...") - succeeding "foo.txt" (Path "foo.txt") - succeeding "./foo.txt" (Path "foo.txt") - succeeding "././foo.txt" (Path "foo.txt") - succeeding "./foo/./bar.txt" (Path "foo/bar.txt") - succeeding "foo//bar//mu.txt" (Path "foo/bar/mu.txt") - succeeding "foo//bar////mu.txt" (Path "foo/bar/mu.txt") - succeeding "foo//bar/.//mu.txt" (Path "foo/bar/mu.txt") + 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) @@ -144,26 +145,26 @@ parseRelFileSpec = aesonInstances :: Spec aesonInstances = do it "Decoding \"[\"/foo/bar\"]\" as a [Path Abs Dir] should succeed." $ - eitherDecode (LBS.pack "[\"/foo/bar\"]") `shouldBe` Right [Path "/foo/bar/" :: Path Abs Dir] + eitherDecode (LBS.pack "[\"/foo/bar\"]") `shouldBe` Right [Path [OsString.pstr|/foo/bar/|] :: Path Abs Dir] it "Decoding \"[\"/foo/bar\"]\" as a [Path Rel Dir] should fail." $ decode (LBS.pack "[\"/foo/bar\"]") `shouldBe` (Nothing :: Maybe [Path Rel Dir]) it "Encoding \"[\"/foo/bar/mu.txt\"]\" should succeed." $ - encode [Path "/foo/bar/mu.txt" :: Path Abs File] `shouldBe` (LBS.pack "[\"/foo/bar/mu.txt\"]") + encode [Path [OsString.pstr|/foo/bar/mu.txt|] :: Path Abs File] `shouldBe` LBS.pack "[\"/foo/bar/mu.txt\"]" -- | Test QuasiQuoters. Make sure they work the same as the $(mk*) constructors. quasiquotes :: Spec quasiquotes = do it "[absdir|/|] == $(mkAbsDir \"/\")" - ([absdir|/|] `shouldBe` $(mkAbsDir "/")) + ([absdir|/|] `shouldBe` $(mkAbsDir [OsString.pstr|/|])) it "[absdir|/home|] == $(mkAbsDir \"/home\")" - ([absdir|/home|] `shouldBe` $(mkAbsDir "/home")) + ([absdir|/home|] `shouldBe` $(mkAbsDir [OsString.pstr|/home|])) it "[reldir|foo|] == $(mkRelDir \"foo\")" - ([reldir|foo|] `shouldBe` $(mkRelDir "foo")) + ([reldir|foo|] `shouldBe` $(mkRelDir [OsString.pstr|foo|])) it "[reldir|foo/bar|] == $(mkRelDir \"foo/bar\")" - ([reldir|foo/bar|] `shouldBe` $(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 "/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 "foo")) + ([relfile|foo|] `shouldBe` $(mkRelFile [OsString.pstr|foo|])) it "[relfile|chris/foo.txt|] == $(mkRelFile \"chris/foo.txt\")" - ([relfile|chris/foo.txt|] `shouldBe` $(mkRelFile "chris/foo.txt")) + ([relfile|chris/foo.txt|] `shouldBe` $(mkRelFile [OsString.pstr|chris/foo.txt|])) diff --git a/test-ospath/TH/Include.hs b/test-ospath/TH/Include.hs index 3e1bf30..71add0e 100644 --- a/test-ospath/TH/Include.hs +++ b/test-ospath/TH/Include.hs @@ -10,9 +10,10 @@ module TH.PLATFORM_NAME where import qualified Language.Haskell.TH.Syntax as TH +import qualified System.OsString.PLATFORM_NAME as OsString -import Path.Internal.PLATFORM_NAME -import Path.PLATFORM_NAME +import OsPath.Internal.PLATFORM_NAME +import OsPath.PLATFORM_NAME -- | This is a helper type class that checks that splices produce a 'Path' with -- all type variables instantiated to a type. @@ -34,13 +35,13 @@ qqRelFile :: FilePath qqRelFile = checkInstantiated [relfile|name|] thRelDir :: FilePath -thRelDir = checkInstantiated $(mkRelDir "name/") +thRelDir = checkInstantiated $(mkRelDir [OsString.pstr|name/|]) thRelFile :: FilePath -thRelFile = checkInstantiated $(mkRelFile "name") +thRelFile = checkInstantiated $(mkRelFile [OsString.pstr|name|]) liftRelDir :: FilePath -liftRelDir = checkInstantiated $(TH.lift (Path "name/" :: Path Rel Dir)) +liftRelDir = checkInstantiated $(TH.lift (Path [OsString.pstr|name/|] :: Path Rel Dir)) liftRelFile :: FilePath -liftRelFile = checkInstantiated $(TH.lift (Path "name" :: Path Rel File)) +liftRelFile = checkInstantiated $(TH.lift (Path [OsString.pstr|name|] :: Path Rel File)) diff --git a/test-ospath/TH/Posix.hs b/test-ospath/TH/Posix.hs index a193382..1fa18d1 100644 --- a/test-ospath/TH/Posix.hs +++ b/test-ospath/TH/Posix.hs @@ -10,13 +10,13 @@ qqAbsFile :: FilePath qqAbsFile = checkInstantiated [absdir|/name|] thAbsDir :: FilePath -thAbsDir = checkInstantiated $(mkAbsDir "/name/") +thAbsDir = checkInstantiated $(mkAbsDir [OsString.pstr|/name/|]) thAbsFile :: FilePath -thAbsFile = checkInstantiated $(mkAbsFile "/name") +thAbsFile = checkInstantiated $(mkAbsFile [OsString.pstr|/name|]) liftAbsDir :: FilePath -liftAbsDir = checkInstantiated $(TH.lift (Path "/name/" :: Path Abs Dir)) +liftAbsDir = checkInstantiated $(TH.lift (Path [OsString.pstr|/name/|] :: Path Abs Dir)) liftAbsFile :: FilePath -liftAbsFile = checkInstantiated $(TH.lift (Path "/name" :: Path Abs File)) +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 index acf5c77..5344db4 100644 --- a/test-ospath/TH/Windows.hs +++ b/test-ospath/TH/Windows.hs @@ -10,13 +10,13 @@ qqAbsFile :: FilePath qqAbsFile = checkInstantiated [absdir|C:\foo|] thAbsDir :: FilePath -thAbsDir = checkInstantiated $(mkAbsDir "C:\\foo\\") +thAbsDir = checkInstantiated $(mkAbsDir [OsString.pstr|C:\foo\|]) thAbsFile :: FilePath -thAbsFile = checkInstantiated $(mkAbsFile "C:\\foo") +thAbsFile = checkInstantiated $(mkAbsFile [OsString.pstr|C:\foo|]) liftAbsDir :: FilePath -liftAbsDir = checkInstantiated $(TH.lift (Path "C:\\foo\\" :: Path Abs Dir)) +liftAbsDir = checkInstantiated $(TH.lift (Path [OsString.pstr|C:\foo\|] :: Path Abs Dir)) liftAbsFile :: FilePath -liftAbsFile = checkInstantiated $(TH.lift (Path "C:\\foo" :: Path Abs File)) +liftAbsFile = checkInstantiated $(TH.lift (Path [OsString.pstr|C:\foo|] :: Path Abs File)) diff --git a/test-ospath/Windows.hs b/test-ospath/Windows.hs index 24f6075..d376b9b 100644 --- a/test-ospath/Windows.hs +++ b/test-ospath/Windows.hs @@ -9,12 +9,13 @@ module Windows (spec) where import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified System.OsString.Windows as OsString import Test.Hspec import Common.Windows (parseFails, parseSucceeds, parserTest) import qualified Common.Windows -import Path.Windows -import Path.Internal.Windows +import OsPath.Windows +import OsPath.Internal.Windows import TH.Windows () -- | Test suite (Windows version). @@ -32,32 +33,32 @@ spec = -- | Restricting the input of any tricks. restrictions :: Spec restrictions = - do parseFails "..\\" - parseFails ".." - parseSucceeds "a.." (Path "a..\\") - parseSucceeds "..a" (Path "..a\\") - parseFails "\\.." - parseFails "C:\\foo\\..\\bar\\" - parseFails "C:\\foo\\bar\\.." + 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 "" - failing ".\\" - failing "foo.txt" - failing "C:" - succeeding "C:\\" (Path "C:\\") - succeeding "C:\\\\" (Path "C:\\") - succeeding "C:\\\\\\foo\\\\bar\\\\mu\\" (Path "C:\\foo\\bar\\mu\\") - succeeding "C:\\\\\\foo\\\\bar\\\\mu" (Path "C:\\foo\\bar\\mu\\") - succeeding "C:\\\\\\foo\\\\bar\\.\\\\mu" (Path "C:\\foo\\bar\\mu\\") - succeeding "\\\\unchost\\share" (Path "\\\\unchost\\share\\") - succeeding "\\/unchost\\share" (Path "\\\\unchost\\share\\") - succeeding "\\\\unchost\\share\\\\folder\\" (Path "\\\\unchost\\share\\folder\\") - succeeding "\\\\?\\C:\\" (Path "\\\\?\\C:\\") - succeeding "/\\?\\C:\\" (Path "\\\\?\\C:\\") - succeeding "\\\\?\\C:\\\\\\folder\\\\" (Path "\\\\?\\C:\\folder\\") + 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) @@ -65,26 +66,26 @@ parseAbsDirSpec = -- | Tests for the tokenizer. parseRelDirSpec :: Spec parseRelDirSpec = - do failing "" - failing "/" - failing "//" - failing "\\" - failing "\\\\" - failing "\\\\\\foo\\\\bar\\\\mu\\" - failing "\\\\\\foo\\\\bar\\\\\\\\mu" - failing "\\\\\\foo\\\\bar\\.\\\\mu" - failing "\\\\unchost\\share" - failing "\\\\?\\C:\\" - succeeding ".\\" (Path "") - succeeding ".\\.\\" (Path "") - succeeding "..." (Path "...\\") - succeeding "foo.bak" (Path "foo.bak\\") - succeeding ".\\foo" (Path "foo\\") - succeeding ".\\.\\foo" (Path "foo\\") - succeeding ".\\foo\\.\\bar" (Path "foo\\bar\\") - succeeding "foo\\\\bar\\\\mu\\\\" (Path "foo\\bar\\mu\\") - succeeding "foo\\\\bar////mu" (Path "foo\\bar\\mu\\") - succeeding "foo\\\\bar\\.\\\\mu" (Path "foo\\bar\\mu\\") + 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) @@ -92,25 +93,25 @@ parseRelDirSpec = -- | Tests for the tokenizer. parseAbsFileSpec :: Spec parseAbsFileSpec = - do failing "" - failing ".\\" - failing "\\." - failing "\\foo\\bar\\." - failing "~\\" - failing ".\\foo.txt" - failing "\\" - failing "\\\\" - failing "\\\\\\foo\\\\bar\\\\mu\\" - failing "\\..." - failing "\\foo.txt" - succeeding "C:\\\\\\foo\\\\bar\\\\\\\\mu.txt" (Path "C:\\foo\\bar\\mu.txt") - succeeding "C:\\\\\\foo\\\\bar\\.\\\\mu.txt" (Path "C:\\foo\\bar\\mu.txt") - succeeding "\\\\unchost\\share\\\\file.txt" (Path "\\\\unchost\\share\\file.txt") - succeeding "\\/unchost\\share\\\\file.txt" (Path "\\\\unchost\\share\\file.txt") - succeeding "\\\\unchost\\share\\.\\folder\\\\\\file.txt" (Path "\\\\unchost\\share\\folder\\file.txt") - succeeding "\\\\?\\C:\\file.txt" (Path "\\\\?\\C:\\file.txt") - succeeding "/\\?\\C:\\file.txt" (Path "\\\\?\\C:\\file.txt") - succeeding "\\\\?\\C:\\\\\\folder\\.\\\\file.txt" (Path "\\\\?\\C:\\folder\\file.txt") + 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) @@ -118,31 +119,31 @@ parseAbsFileSpec = -- | Tests for the tokenizer. parseRelFileSpec :: Spec parseRelFileSpec = - do failing "" - failing "\\" - failing "\\\\" - failing "~\\" - failing "\\" - failing ".\\" - failing "a\\." - failing "a\\..\\b" - failing "a\\.." - failing "..\\foo.txt" - failing "\\\\" - failing "\\\\\\foo\\\\bar\\\\mu\\" - failing "\\\\\\foo\\\\bar\\\\\\\\mu" - failing "\\\\\\foo\\\\bar\\.\\\\mu" - failing "\\\\unchost\\share\\\\file.txt" - failing "\\\\?\\C:\\file.txt" - succeeding "a.." (Path "a..") - succeeding "..." (Path "...") - succeeding "foo.txt" (Path "foo.txt") - succeeding ".\\foo.txt" (Path "foo.txt") - succeeding ".\\.\\foo.txt" (Path "foo.txt") - succeeding ".\\foo\\.\\bar.txt" (Path "foo\\bar.txt") - succeeding "foo\\\\bar\\\\mu.txt" (Path "foo\\bar\\mu.txt") - succeeding "foo\\\\bar\\\\\\\\mu.txt" (Path "foo\\bar\\mu.txt") - succeeding "foo\\\\bar\\.\\\\mu.txt" (Path "foo\\bar\\mu.txt") + 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) @@ -154,26 +155,26 @@ parseRelFileSpec = aesonInstances :: Spec aesonInstances = do it "Decoding \"[\"C:\\\\foo\\\\bar\"]\" as a [Path Abs Dir] should succeed." $ - eitherDecode (LBS.pack "[\"C:\\\\foo\\\\bar\"]") `shouldBe` Right [Path "C:\\foo\\bar\\" :: Path Abs Dir] + eitherDecode (LBS.pack "[\"C:\\\\foo\\\\bar\"]") `shouldBe` Right [Path [OsString.pstr|C:\foo\bar\|] :: Path Abs Dir] it "Decoding \"[\"C:\\foo\\bar\"]\" as a [Path Rel Dir] should fail." $ decode (LBS.pack "[\"C:\\foo\\bar\"]") `shouldBe` (Nothing :: Maybe [Path Rel Dir]) it "Encoding \"[\"C:\\foo\\bar\\mu.txt\"]\" should succeed." $ - encode [Path "C:\\foo\\bar\\mu.txt" :: Path Abs File] `shouldBe` (LBS.pack "[\"C:\\\\foo\\\\bar\\\\mu.txt\"]") + encode [Path [OsString.pstr|C:\foo\bar\mu.txt|] :: Path Abs File] `shouldBe` (LBS.pack "[\"C:\\\\foo\\\\bar\\\\mu.txt\"]") -- | 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 "C:\\")) + ([absdir|C:\|] `shouldBe` $(mkAbsDir [OsString.pstr|C:\|])) it "[absdir|C:\\chris\\|] == $(mkAbsDir \"C:\\chris\\\")" - ([absdir|C:\chris\|] `shouldBe` $(mkAbsDir "C:\\chris\\")) + ([absdir|C:\chris\|] `shouldBe` $(mkAbsDir [OsString.pstr|C:\chris\|])) it "[reldir|foo|] == $(mkRelDir \"foo\")" - ([reldir|foo|] `shouldBe` $(mkRelDir "foo")) + ([reldir|foo|] `shouldBe` $(mkRelDir [OsString.pstr|foo|])) it "[reldir|foo\\bar|] == $(mkRelDir \"foo\\bar\")" - ([reldir|foo\bar|] `shouldBe` $(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 "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 "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 "chris\\foo.txt")) + ([relfile|chris\foo.txt|] `shouldBe` $(mkRelFile [OsString.pstr|chris\foo.txt|])) From b2a0cac8a144d7d54e426b3b5189a84c2aa83c3a Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Thu, 20 Jun 2024 13:35:58 +0200 Subject: [PATCH 22/52] Moved normalization functions to Internal modules --- src/OsPath/Include.hs | 79 +-------------- src/OsPath/Internal/Include.hs | 170 +++++++++++++++++++++++++-------- 2 files changed, 131 insertions(+), 118 deletions(-) diff --git a/src/OsPath/Include.hs b/src/OsPath/Include.hs index b8a934b..ca1c20e 100644 --- a/src/OsPath/Include.hs +++ b/src/OsPath/Include.hs @@ -650,7 +650,7 @@ parseAbsFile :: MonadThrow m => PLATFORM_PATH -> m (Path Abs File) parseAbsFile ospath | validAbsFile ospath - , let normalized = normalizeFilePath ospath + , let normalized = normalizeFile ospath , validAbsFile normalized = return (Path normalized) | otherwise = throwM (InvalidAbsFile ospath) @@ -681,7 +681,7 @@ parseRelFile :: MonadThrow m => PLATFORM_PATH -> m (Path Rel File) parseRelFile ospath | validRelFile ospath - , let normalized = normalizeFilePath ospath + , let normalized = normalizeFile ospath , validRelFile normalized = return (Path normalized) | otherwise = throwM (InvalidRelFile ospath) @@ -836,81 +836,6 @@ parseSomeFile fp = maybe (throwM (InvalidFile fp)) pure $ (Abs <$> parseAbsFile fp) <|> (Rel <$> parseRelFile fp) --------------------------------------------------------------------------------- --- Internal functions - --- | Normalizes directory path with platform-specific rules. -normalizeDir :: PLATFORM_PATH -> PLATFORM_PATH -normalizeDir = - normalizeRelDir - . OsPath.addTrailingPathSeparator - . normalizeFilePath - 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 - -#if !IS_WINDOWS --- | 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 -#else --- | 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 - --- | 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 - --- | Applies platform-specific sep normalization following @OsPath.normalise@. -normalizeFilePath :: PLATFORM_PATH -> PLATFORM_PATH -#if IS_WINDOWS -normalizeFilePath = normalizeWindowsSeps . OsPath.normalise -#else -normalizeFilePath = normalizeLeadingSeps . OsPath.normalise -#endif - -------------------------------------------------------------------------------- -- Deprecated diff --git a/src/OsPath/Internal/Include.hs b/src/OsPath/Internal/Include.hs index 23a3de5..e143f41 100644 --- a/src/OsPath/Internal/Include.hs +++ b/src/OsPath/Internal/Include.hs @@ -4,6 +4,7 @@ -- PLATFORM_PATH_SINGLE = 'PosixPath' | 'WindowsPath' -- IS_WINDOWS = 0 | 1 +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE QuasiQuotes #-} @@ -16,10 +17,22 @@ -- | Internal types and functions. module OsPath.Internal.PLATFORM_NAME - ( Path(..) + ( -- * The Path type + Path(..) , toFilePath , toOsPath + -- * Normalizing functions + , normalizeLeadingSeps + , normalizeTrailingSeps + , normalizeAllSeps +#if IS_WINDOWS + , normalizeWindowsSeps +#endif + , normalizeDrive + , normalizeDir + , normalizeFile + -- * Other helper functions , extSep , pathSep @@ -76,46 +89,6 @@ instance Eq (Path b t) where instance Ord (Path b t) where compare (Path x) (Path y) = compare x y --- | 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 = unsafeDupablePerformIO . OsPath.decodeFS . toOsPath - --- | 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 - --- | 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 - -- | Same as 'show . Path.toFilePath'. -- -- The following property holds: @@ -164,6 +137,99 @@ instance forall b t. (Typeable b, Typeable t) => TH.Lift (Path b t) where liftTyped = TH.unsafeTExpCoerce . TH.lift #endif +-- | 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 = unsafeDupablePerformIO . OsPath.decodeFS . toOsPath + +-- | 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 + +-------------------------------------------------------------------------------- +-- 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 @@ -173,6 +239,28 @@ extSep = $(TH.lift (OsString.singleton OsPath.extSeparator)) pathSep :: PLATFORM_STRING pathSep = $(TH.lift (OsString.singleton OsPath.pathSeparator)) +-- | 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 + -- | Normalized file path representation for the relative path root relRoot :: PLATFORM_PATH relRoot = $(TH.lift ([OsPath.pstr|.|] <> OsString.singleton OsPath.pathSeparator)) From 1a527deb7beea0dfc2e56b3ca40d8c802278b2d8 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Thu, 20 Jun 2024 13:43:26 +0200 Subject: [PATCH 23/52] Moved validation functions to Internal modules --- src/OsPath/Include.hs | 46 +++--------------- src/OsPath/Internal/Include.hs | 89 +++++++++++++++++++++++++--------- 2 files changed, 72 insertions(+), 63 deletions(-) diff --git a/src/OsPath/Include.hs b/src/OsPath/Include.hs index ca1c20e..40eb928 100644 --- a/src/OsPath/Include.hs +++ b/src/OsPath/Include.hs @@ -596,16 +596,9 @@ replaceExtension ext path = parseAbsDir :: MonadThrow m => PLATFORM_PATH -> m (Path Abs Dir) parseAbsDir ospath - | validAbsDir ospath = return (Path (normalizeDir ospath)) + | isValidAbsDir ospath = return (Path (normalizeDir ospath)) | otherwise = throwM (InvalidAbsDir ospath) --- | Is the string a valid absolute dir? -validAbsDir :: PLATFORM_PATH -> Bool -validAbsDir ospath = - OsPath.isAbsolute ospath && - not (hasParentDir ospath) && - OsPath.isValid ospath - -- | Convert a relative PLATFORM_PATH_SINGLE to a normalized relative dir -- 'Path'. -- @@ -620,18 +613,9 @@ validAbsDir ospath = parseRelDir :: MonadThrow m => PLATFORM_PATH -> m (Path Rel Dir) parseRelDir ospath - | validRelDir ospath = return (Path (normalizeDir ospath)) + | isValidRelDir ospath = return (Path (normalizeDir ospath)) | otherwise = throwM (InvalidRelDir ospath) --- | Is the string a valid relative dir? -validRelDir :: PLATFORM_PATH -> Bool -validRelDir ospath = - not (OsPath.isAbsolute ospath) && - not (OsString.null ospath) && - not (hasParentDir ospath) && - not (OsString.all OsPath.isPathSeparator ospath) && - OsPath.isValid ospath - -- | Convert an absolute PLATFORM_PATH_SINGLE to a normalized absolute file -- 'Path'. -- @@ -649,19 +633,11 @@ validRelDir ospath = parseAbsFile :: MonadThrow m => PLATFORM_PATH -> m (Path Abs File) parseAbsFile ospath - | validAbsFile ospath + | isValidAbsFile ospath , let normalized = normalizeFile ospath - , validAbsFile normalized = return (Path normalized) + , isValidAbsFile normalized = return (Path normalized) | otherwise = throwM (InvalidAbsFile ospath) --- | Is the string a valid absolute file? -validAbsFile :: PLATFORM_PATH -> Bool -validAbsFile ospath = - OsPath.isAbsolute ospath && - not (OsPath.hasTrailingPathSeparator ospath) && - not (hasParentDir ospath) && - OsPath.isValid ospath - -- | Convert a relative PLATFORM_PATH_SINGLE to a normalized relative file -- 'Path'. -- @@ -680,21 +656,11 @@ validAbsFile ospath = parseRelFile :: MonadThrow m => PLATFORM_PATH -> m (Path Rel File) parseRelFile ospath - | validRelFile ospath + | isValidRelFile ospath , let normalized = normalizeFile ospath - , validRelFile normalized = return (Path normalized) + , isValidRelFile normalized = return (Path normalized) | otherwise = throwM (InvalidRelFile ospath) --- | Is the string a valid relative file? -validRelFile :: PLATFORM_PATH -> Bool -validRelFile ospath = - not (OsPath.isAbsolute ospath) && - not (OsString.null ospath) && - not (hasParentDir ospath) && - not (OsPath.hasTrailingPathSeparator ospath) && - ospath /= [OsPath.pstr|.|] && - OsPath.isValid ospath - -------------------------------------------------------------------------------- -- Conversion diff --git a/src/OsPath/Internal/Include.hs b/src/OsPath/Internal/Include.hs index e143f41..55d9608 100644 --- a/src/OsPath/Internal/Include.hs +++ b/src/OsPath/Internal/Include.hs @@ -22,6 +22,13 @@ module OsPath.Internal.PLATFORM_NAME , toFilePath , toOsPath + -- * Validation functions + , isValidAbsDir + , isValidAbsFile + , isValidRelDir + , isValidRelFile + , hasParentDir + -- * Normalizing functions , normalizeLeadingSeps , normalizeTrailingSeps @@ -36,7 +43,6 @@ module OsPath.Internal.PLATFORM_NAME -- * Other helper functions , extSep , pathSep - , hasParentDir , relRoot , isWindows ) @@ -155,6 +161,65 @@ 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 @@ -239,28 +304,6 @@ extSep = $(TH.lift (OsString.singleton OsPath.extSeparator)) pathSep :: PLATFORM_STRING pathSep = $(TH.lift (OsString.singleton OsPath.pathSeparator)) --- | 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 - -- | Normalized file path representation for the relative path root relRoot :: PLATFORM_PATH relRoot = $(TH.lift ([OsPath.pstr|.|] <> OsString.singleton OsPath.pathSeparator)) From 202529e771916bf2a3e02e9d6a202245453126c3 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Thu, 20 Jun 2024 13:59:58 +0200 Subject: [PATCH 24/52] Replicated validity-test testsuite to validity-test-ospath testsuite --- hie.yaml | 3 + path.cabal | 21 +++ validity-test-ospath/Main.hs | 267 +++++++++++++++++++++++++++++ validity-test-ospath/OsPath/Gen.hs | 127 ++++++++++++++ 4 files changed, 418 insertions(+) create mode 100644 validity-test-ospath/Main.hs create mode 100644 validity-test-ospath/OsPath/Gen.hs diff --git a/hie.yaml b/hie.yaml index 896c82d..eff25a6 100644 --- a/hie.yaml +++ b/hie.yaml @@ -11,3 +11,6 @@ cradle: - path: "validity-test" component: "path:test:validity-test" + + - path: "validity-test-ospath" + component: "path:test:validity-test-ospath" diff --git a/path.cabal b/path.cabal index 3111197..73bb67a 100644 --- a/path.cabal +++ b/path.cabal @@ -18,6 +18,7 @@ extra-source-files: README.md , src/OsPath/Include.hs , src/OsPath/Internal/Include.hs , test/Common/Include.hs + , test-ospath/Common/Include.hs flag dev description: Turn on development settings. @@ -128,6 +129,26 @@ test-suite validity-test default-language: Haskell2010 ghc-options: -threaded -rtsopts -with-rtsopts=-N +test-suite validity-test-ospath + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: OsPath.Gen + hs-source-dirs: validity-test-ospath + build-depends: QuickCheck + , aeson + , base + , bytestring + , filepath + , genvalidity >= 1.0 + , genvalidity-property >= 0.4 + , 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 + source-repository head type: git location: https://github.com/commercialhaskell/path.git diff --git a/validity-test-ospath/Main.hs b/validity-test-ospath/Main.hs new file mode 100644 index 0000000..66074f1 --- /dev/null +++ b/validity-test-ospath/Main.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +-- | Test suite. +module Main where + +import Data.Maybe +import Path +import Path.Internal +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck +import Test.Validity + +import OsPath.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 + +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 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/OsPath/Gen.hs b/validity-test-ospath/OsPath/Gen.hs new file mode 100644 index 0000000..2ed7227 --- /dev/null +++ b/validity-test-ospath/OsPath/Gen.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module OsPath.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, isInfixOf) +import Data.Maybe (isJust, 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 From 296930fa38dac97264e20856e1071aff20f2e008 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Thu, 20 Jun 2024 14:24:56 +0200 Subject: [PATCH 25/52] validity-test-ospath: Different modules for different platforms --- path.cabal | 7 +- validity-test-ospath/Include.hs | 266 ++++++++++++++++++ validity-test-ospath/Main.hs | 252 +---------------- .../OsPath/{Gen.hs => Gen/Include.hs} | 2 +- validity-test-ospath/OsPath/Gen/Posix.hs | 8 + validity-test-ospath/OsPath/Gen/Windows.hs | 8 + validity-test-ospath/Posix.hs | 5 + validity-test-ospath/Windows.hs | 5 + 8 files changed, 304 insertions(+), 249 deletions(-) create mode 100644 validity-test-ospath/Include.hs rename validity-test-ospath/OsPath/{Gen.hs => Gen/Include.hs} (99%) create mode 100644 validity-test-ospath/OsPath/Gen/Posix.hs create mode 100644 validity-test-ospath/OsPath/Gen/Windows.hs create mode 100644 validity-test-ospath/Posix.hs create mode 100644 validity-test-ospath/Windows.hs diff --git a/path.cabal b/path.cabal index 73bb67a..a10d67d 100644 --- a/path.cabal +++ b/path.cabal @@ -19,6 +19,8 @@ extra-source-files: README.md , 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. @@ -132,7 +134,10 @@ test-suite validity-test test-suite validity-test-ospath type: exitcode-stdio-1.0 main-is: Main.hs - other-modules: OsPath.Gen + other-modules: OsPath.Gen.Posix + , OsPath.Gen.Windows + , Posix + , Windows hs-source-dirs: validity-test-ospath build-depends: QuickCheck , aeson diff --git a/validity-test-ospath/Include.hs b/validity-test-ospath/Include.hs new file mode 100644 index 0000000..5717670 --- /dev/null +++ b/validity-test-ospath/Include.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +-- | Test suite. +module PLATFORM_NAME where + +import Data.Maybe +import Path +import Path.Internal +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck +import Test.Validity + +import OsPath.Gen.PLATFORM_NAME + +-- | 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 [] 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 + +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 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 index 66074f1..c49db9d 100644 --- a/validity-test-ospath/Main.hs +++ b/validity-test-ospath/Main.hs @@ -1,11 +1,5 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} - -- | Test suite. -module Main where +module Main (main) where import Data.Maybe import Path @@ -15,7 +9,8 @@ import Test.Hspec.QuickCheck import Test.QuickCheck import Test.Validity -import OsPath.Gen +import qualified Posix +import qualified Windows -- | Test suite entry point, returns exit failure if any test fails. main :: IO () @@ -26,242 +21,5 @@ 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 - -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 shrinkValid $ \path -> - case parser path of - Nothing -> pure () - Just p -> - case prettyValidate p of - Left err -> expectationFailure err - Right _ -> pure () + Posix.spec + Windows.spec diff --git a/validity-test-ospath/OsPath/Gen.hs b/validity-test-ospath/OsPath/Gen/Include.hs similarity index 99% rename from validity-test-ospath/OsPath/Gen.hs rename to validity-test-ospath/OsPath/Gen/Include.hs index 2ed7227..65b8efe 100644 --- a/validity-test-ospath/OsPath/Gen.hs +++ b/validity-test-ospath/OsPath/Gen/Include.hs @@ -2,7 +2,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module OsPath.Gen where +module OsPath.Gen.PLATFORM_NAME where import Data.Functor import Prelude diff --git a/validity-test-ospath/OsPath/Gen/Posix.hs b/validity-test-ospath/OsPath/Gen/Posix.hs new file mode 100644 index 0000000..8760956 --- /dev/null +++ b/validity-test-ospath/OsPath/Gen/Posix.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE CPP #-} + +#define PLATFORM_NAME Posix +-- #define PLATFORM_NAME_STRING "Posix" +#define PLATFORM_PATH PosixPath +-- #define PLATFORM_STRING PosixString +-- #define IS_WINDOWS 0 +#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 index 0000000..4a4f8b8 --- /dev/null +++ b/validity-test-ospath/OsPath/Gen/Windows.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE CPP #-} + +#define PLATFORM_NAME Windows +-- #define PLATFORM_NAME_STRING "Windows" +#define PLATFORM_PATH WindowsPath +-- #define PLATFORM_STRING WindowsString +-- #define IS_WINDOWS 1 +#include "Include.hs" diff --git a/validity-test-ospath/Posix.hs b/validity-test-ospath/Posix.hs new file mode 100644 index 0000000..4e27e9f --- /dev/null +++ b/validity-test-ospath/Posix.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE CPP #-} + +#define PLATFORM_NAME Posix +#define PLATFORM_NAME_STRING "Posix" +#include "Include.hs" diff --git a/validity-test-ospath/Windows.hs b/validity-test-ospath/Windows.hs new file mode 100644 index 0000000..d353113 --- /dev/null +++ b/validity-test-ospath/Windows.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE CPP #-} + +#define PLATFORM_NAME Windows +#define PLATFORM_NAME_STRING "Windows" +#include "Include.hs" From f48c66e28536e7e360416aca4b3601e430f8f076 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Thu, 20 Jun 2024 14:32:01 +0200 Subject: [PATCH 26/52] Added orphan instance for OsPath paths to validity-test-ospath --- path.cabal | 1 + validity-test-ospath/OsPath/Gen/Include.hs | 27 +++++++++++++++++++--- 2 files changed, 25 insertions(+), 3 deletions(-) diff --git a/path.cabal b/path.cabal index a10d67d..5da6bd8 100644 --- a/path.cabal +++ b/path.cabal @@ -149,6 +149,7 @@ test-suite validity-test-ospath , genvalidity-hspec >= 0.7 , hspec >= 2.0 && < 3 , mtl >= 2.0 && < 3 + , os-string , path , validity >= 0.8.0.0 default-language: Haskell2010 diff --git a/validity-test-ospath/OsPath/Gen/Include.hs b/validity-test-ospath/OsPath/Gen/Include.hs index 65b8efe..8bf7edb 100644 --- a/validity-test-ospath/OsPath/Gen/Include.hs +++ b/validity-test-ospath/OsPath/Gen/Include.hs @@ -10,12 +10,14 @@ import Prelude import Path import Path.Internal -import qualified System.FilePath as FilePath - +import Data.Char (chr, ord) import Data.GenValidity import Data.List (isSuffixOf, isInfixOf) import Data.Maybe (isJust, mapMaybe) - +import qualified System.FilePath as FilePath +import System.OsPath.PLATFORM_NAME (PLATFORM_PATH) +import qualified System.OsPath.PLATFORM_NAME as OsPath +import qualified System.OsString.PLATFORM_NAME as OsString import Test.QuickCheck instance Validity (Path Abs File) where @@ -125,3 +127,22 @@ 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 + +-------------------------------------------------------------------------------- +-- Orphan instances + +-- | Generates 'PLATFORM_PATH with a high occurence of @'.'@, @'\/'@ and +-- @'\\'@ characters. The resulting 'FilePath's are not guaranteed to +-- be valid. +instance GenValid PLATFORM_PATH where + -- We also need to exclude UTF-16 surrogates. + genValid = mconcat <$> listOf (OsString.unsafeEncodeUtf . (:[]) . chr <$> frequency + [ (2, choose (0x0, 0xD800 - 1)) + , (2, choose (0xDFFF + 1, 0x10FFFF)) + , (1, elements (map ord "./\\")) + ] + ) + shrinkValid _ = [] -- TODO: Not yet implemented + +instance Validity PLATFORM_PATH where + validate = trivialValidation -- TODO: Not yet implemented From 5200bbdada6ca2bc7e39020690e21305a00c9abb Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Thu, 20 Jun 2024 15:00:56 +0200 Subject: [PATCH 27/52] Use OsPath modules in validity-test-ospath --- validity-test-ospath/Include.hs | 33 ++++---- validity-test-ospath/Main.hs | 3 +- validity-test-ospath/OsPath/Gen/Include.hs | 90 +++++++++++----------- validity-test-ospath/OsPath/Gen/Posix.hs | 3 - validity-test-ospath/OsPath/Gen/Windows.hs | 3 - validity-test-ospath/Posix.hs | 1 + validity-test-ospath/Windows.hs | 1 + 7 files changed, 66 insertions(+), 68 deletions(-) diff --git a/validity-test-ospath/Include.hs b/validity-test-ospath/Include.hs index 5717670..85e9f04 100644 --- a/validity-test-ospath/Include.hs +++ b/validity-test-ospath/Include.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} @@ -8,8 +9,10 @@ module PLATFORM_NAME where import Data.Maybe -import Path -import Path.Internal +import OsPath.PLATFORM_NAME +import OsPath.Internal.PLATFORM_NAME +import System.OsPath.PLATFORM_NAME (PLATFORM_PATH) +import qualified System.OsString.PLATFORM_NAME as OsString import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck @@ -74,9 +77,9 @@ operationFilename = do 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 + 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 [] + 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 @@ -122,7 +125,7 @@ operationTakeDrive = do operationIsParentOf :: Spec operationIsParentOf = do forAllParentsAndChildren "isProperPrefixOf parent (parent child)" $ \parent child -> - if child == Path [] + if child == Path OsString.empty then True -- TODO do we always need this condition? else isProperPrefixOf parent (parent child) @@ -130,7 +133,7 @@ operationIsParentOf = do operationStripDir :: Spec operationStripDir = do forAllParentsAndChildren "stripProperPrefix parent (parent child) = child" $ \parent child -> - if child == Path [] + 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 @@ -161,26 +164,26 @@ operationAppend = do extensionsSpec :: Spec extensionsSpec = do let addExtGensValidFile p = - case addExtension p $(mkRelFile "x") of + 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 genFilePath addExtGensValidFile + 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 genFilePath $ addExtGensValidFile . ("." ++) + 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 -> toFilePath p `shouldBe` toFilePath file ++ ext + 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) -> toFilePath f ++ ext `shouldBe` toFilePath file + 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 @@ -188,9 +191,9 @@ extensionsSpec = do case parseRelFile ext of Nothing -> False Just _ -> - case parseRelFile (toFilePath f) of + case parseRelFile (toOsPath f) of Nothing -> - case parseAbsFile (toFilePath f) of + case parseAbsFile (toOsPath f) of Nothing -> False Just _ -> True Just _ -> True @@ -254,10 +257,10 @@ forAllPaths n func = do 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 :: (Show p, Validity p) => (PLATFORM_PATH -> Maybe p) -> Spec parserSpec parser = it "Produces valid paths when it succeeds" $ - forAllShrink genFilePath shrinkValid $ \path -> + forAllShrink genValid shrinkValid $ \path -> case parser path of Nothing -> pure () Just p -> diff --git a/validity-test-ospath/Main.hs b/validity-test-ospath/Main.hs index c49db9d..e26d47f 100644 --- a/validity-test-ospath/Main.hs +++ b/validity-test-ospath/Main.hs @@ -22,4 +22,5 @@ spec = modifyMaxShrinks (const 100) $ parallel $ do Posix.spec - Windows.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 index 8bf7edb..55c9880 100644 --- a/validity-test-ospath/OsPath/Gen/Include.hs +++ b/validity-test-ospath/OsPath/Gen/Include.hs @@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module OsPath.Gen.PLATFORM_NAME where @@ -7,14 +7,13 @@ module OsPath.Gen.PLATFORM_NAME where import Data.Functor import Prelude -import Path -import Path.Internal +import OsPath.PLATFORM_NAME +import OsPath.Internal.PLATFORM_NAME import Data.Char (chr, ord) import Data.GenValidity import Data.List (isSuffixOf, isInfixOf) import Data.Maybe (isJust, mapMaybe) -import qualified System.FilePath as FilePath import System.OsPath.PLATFORM_NAME (PLATFORM_PATH) import qualified System.OsPath.PLATFORM_NAME as OsPath import qualified System.OsString.PLATFORM_NAME as OsString @@ -57,55 +56,27 @@ instance Validity (Path Rel Dir) where 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 == "" + parseRelDir fp == Just p || OsString.null 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 + genValid = (Path . ([OsString.pstr|/|] <>) <$> genValid) `suchThat` isValid shrinkValid = filter isValid . shrinkValidWith parseAbsFile instance GenValid (Path Abs Dir) where - genValid = (Path . ('/' :) . (++ "/") <$> genFilePath) `suchThat` isValid + genValid = (Path . ([OsString.pstr|/|] <>) . (<> OsString.singleton OsPath.pathSeparator) <$> genValid) `suchThat` isValid shrinkValid = filter isValid . shrinkValidWith parseAbsDir instance GenValid (Path Rel File) where - genValid = (Path <$> genFilePath) `suchThat` isValid + genValid = (Path <$> genValid) `suchThat` isValid shrinkValid = filter isValid . shrinkValidWith parseRelFile instance GenValid (Path Rel Dir) where - genValid = (Path . (++ "/") <$> genFilePath) `suchThat` isValid + genValid = (Path . (<> OsString.singleton OsPath.pathSeparator) <$> genValid) `suchThat` isValid shrinkValid = filter isValid . shrinkValidWith parseRelDir instance GenValid (SomeBase Dir) where @@ -116,17 +87,44 @@ 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 +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 + ] -genPathyChar :: Gen Char -genPathyChar = frequency [(2, choose (minBound, maxBound)), (1, elements "./\\")] +validateRel :: Path Rel t -> Validation +validateRel (Path fp) = mconcat + [ declare "The path is relative." $ + OsPath.isRelative fp + ] -shrinkValidWith :: (FilePath -> Maybe (Path a b)) -> Path a b -> [Path a b] -shrinkValidWith fun (Path f) = filter (/= (Path f)) . mapMaybe fun $ shrinkValid f +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 diff --git a/validity-test-ospath/OsPath/Gen/Posix.hs b/validity-test-ospath/OsPath/Gen/Posix.hs index 8760956..94f2448 100644 --- a/validity-test-ospath/OsPath/Gen/Posix.hs +++ b/validity-test-ospath/OsPath/Gen/Posix.hs @@ -1,8 +1,5 @@ {-# LANGUAGE CPP #-} #define PLATFORM_NAME Posix --- #define PLATFORM_NAME_STRING "Posix" #define PLATFORM_PATH PosixPath --- #define PLATFORM_STRING PosixString --- #define IS_WINDOWS 0 #include "Include.hs" diff --git a/validity-test-ospath/OsPath/Gen/Windows.hs b/validity-test-ospath/OsPath/Gen/Windows.hs index 4a4f8b8..1285bd3 100644 --- a/validity-test-ospath/OsPath/Gen/Windows.hs +++ b/validity-test-ospath/OsPath/Gen/Windows.hs @@ -1,8 +1,5 @@ {-# LANGUAGE CPP #-} #define PLATFORM_NAME Windows --- #define PLATFORM_NAME_STRING "Windows" #define PLATFORM_PATH WindowsPath --- #define PLATFORM_STRING WindowsString --- #define IS_WINDOWS 1 #include "Include.hs" diff --git a/validity-test-ospath/Posix.hs b/validity-test-ospath/Posix.hs index 4e27e9f..56c03cc 100644 --- a/validity-test-ospath/Posix.hs +++ b/validity-test-ospath/Posix.hs @@ -2,4 +2,5 @@ #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 index d353113..8b60713 100644 --- a/validity-test-ospath/Windows.hs +++ b/validity-test-ospath/Windows.hs @@ -2,4 +2,5 @@ #define PLATFORM_NAME Windows #define PLATFORM_NAME_STRING "Windows" +#define PLATFORM_PATH WindowsPath #include "Include.hs" From 8f2ba1cb74388cf154bc6699f72062c4b9baad46 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 21 Jun 2024 04:10:37 +0200 Subject: [PATCH 28/52] Updated Stack configuration --- stack.yaml | 8 +++++++- stack.yaml.lock | 38 +++++++++++++++++++++++++++++++++----- 2 files changed, 40 insertions(+), 6 deletions(-) diff --git a/stack.yaml b/stack.yaml index 9d76b09..61822bc 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1 +1,7 @@ -resolver: nightly-2023-10-16 # GHC 9.6.3 +resolver: lts-22.26 # GHC 9.6.5 + +extra-deps: + - directory-1.3.7.1 + - filepath-1.5.2.0@sha256:8af7a843cba7eddc8d44ae94002b766ee8c23cbcd3ecdb2cc79ee6e0a694419a,5178 + - process-1.6.20.0@sha256:2a9393de33f18415fb8f4826957a87a94ffe8840ca8472a9b69dca6de45aca03,2790 + - unix-2.7.3 diff --git a/stack.yaml.lock b/stack.yaml.lock index c167fde..c5908aa 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -3,10 +3,38 @@ # For more information, please see the documentation at: # https://docs.haskellstack.org/en/stable/lock_files -packages: [] +packages: +- completed: + hackage: directory-1.3.7.1@sha256:b27bac1b0f6f8c8cb7212ef8b94438e6b0ceb3001fc156253b41556ec4c85c90,2971 + pantry-tree: + sha256: b1b11efbe172f84e7cbd67d89a630ccb2793695ca5f223313a820518f38ce58a + size: 3503 + original: + hackage: directory-1.3.7.1 +- completed: + hackage: filepath-1.5.2.0@sha256:8af7a843cba7eddc8d44ae94002b766ee8c23cbcd3ecdb2cc79ee6e0a694419a,5178 + pantry-tree: + sha256: 8886e236bfc70fc290bdc711f986a871f9e175d4355c7b1307b565c40c596c77 + size: 2196 + original: + hackage: filepath-1.5.2.0@sha256:8af7a843cba7eddc8d44ae94002b766ee8c23cbcd3ecdb2cc79ee6e0a694419a,5178 +- completed: + hackage: process-1.6.20.0@sha256:2a9393de33f18415fb8f4826957a87a94ffe8840ca8472a9b69dca6de45aca03,2790 + pantry-tree: + sha256: 14d1e9a5ec731766e43c7eb9c2dc59a7da48d98d43374d9d83e725d8891c6173 + size: 1789 + original: + hackage: process-1.6.20.0@sha256:2a9393de33f18415fb8f4826957a87a94ffe8840ca8472a9b69dca6de45aca03,2790 +- completed: + hackage: unix-2.7.3@sha256:4f2c9d76be97caa9b58d4fe33f22d226b01623410b88855c903f42173d15cbb8,6308 + pantry-tree: + sha256: 4869adc2c291e83f0a849d0dd345a5506f7acefe3ba6f96e31d7433d7451910d + size: 4485 + original: + hackage: unix-2.7.3 snapshots: - completed: - sha256: f5d3c5c93b456d34be5809bc113f9e2d7401c44ca2f9b19cdeb3f9db6ca7c444 - size: 695109 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2023/10/16.yaml - original: nightly-2023-10-16 + sha256: 8e7996960d864443a66eb4105338bbdd6830377b9f6f99cd5527ef73c10c01e7 + size: 719128 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/26.yaml + original: lts-22.26 From d22abd4fe49537819021f5f89ea918066835dbbd Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 21 Jun 2024 04:23:57 +0200 Subject: [PATCH 29/52] Updated Stack configuration again --- stack.yaml | 10 ++++++++-- stack.yaml.lock | 16 ++++++++-------- 2 files changed, 16 insertions(+), 10 deletions(-) diff --git a/stack.yaml b/stack.yaml index 61822bc..5ed13a2 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,7 +1,13 @@ resolver: lts-22.26 # GHC 9.6.5 extra-deps: - - directory-1.3.7.1 + - directory-1.3.8.5@sha256:fbeec9ec346e5272167f63dcb86af513b457a7b9fc36dc818e4c7b81608d612b,3166 - filepath-1.5.2.0@sha256:8af7a843cba7eddc8d44ae94002b766ee8c23cbcd3ecdb2cc79ee6e0a694419a,5178 - process-1.6.20.0@sha256:2a9393de33f18415fb8f4826957a87a94ffe8840ca8472a9b69dca6de45aca03,2790 - - unix-2.7.3 + - unix-2.8.5.1@sha256:3f702a252a313a7bcb56e3908a14e7f9f1b40e41b7bdc8ae8a9605a1a8686f06,9808 + +flags: + directory: + os-string: true + unix: + os-string: true diff --git a/stack.yaml.lock b/stack.yaml.lock index c5908aa..76ff848 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -5,12 +5,12 @@ packages: - completed: - hackage: directory-1.3.7.1@sha256:b27bac1b0f6f8c8cb7212ef8b94438e6b0ceb3001fc156253b41556ec4c85c90,2971 + hackage: directory-1.3.8.5@sha256:fbeec9ec346e5272167f63dcb86af513b457a7b9fc36dc818e4c7b81608d612b,3166 pantry-tree: - sha256: b1b11efbe172f84e7cbd67d89a630ccb2793695ca5f223313a820518f38ce58a - size: 3503 + sha256: d11130a0ca9e7c8720ed1ceef4e2f0d9be4b446e67e7d15d634763a5c952877e + size: 3519 original: - hackage: directory-1.3.7.1 + hackage: directory-1.3.8.5@sha256:fbeec9ec346e5272167f63dcb86af513b457a7b9fc36dc818e4c7b81608d612b,3166 - completed: hackage: filepath-1.5.2.0@sha256:8af7a843cba7eddc8d44ae94002b766ee8c23cbcd3ecdb2cc79ee6e0a694419a,5178 pantry-tree: @@ -26,12 +26,12 @@ packages: original: hackage: process-1.6.20.0@sha256:2a9393de33f18415fb8f4826957a87a94ffe8840ca8472a9b69dca6de45aca03,2790 - completed: - hackage: unix-2.7.3@sha256:4f2c9d76be97caa9b58d4fe33f22d226b01623410b88855c903f42173d15cbb8,6308 + hackage: unix-2.8.5.1@sha256:3f702a252a313a7bcb56e3908a14e7f9f1b40e41b7bdc8ae8a9605a1a8686f06,9808 pantry-tree: - sha256: 4869adc2c291e83f0a849d0dd345a5506f7acefe3ba6f96e31d7433d7451910d - size: 4485 + sha256: b961320db69795a16c4ef4eebb0a3e7ddbbbe506fa1e22dde95ee8d8501bfbe5 + size: 5821 original: - hackage: unix-2.7.3 + hackage: unix-2.8.5.1@sha256:3f702a252a313a7bcb56e3908a14e7f9f1b40e41b7bdc8ae8a9605a1a8686f06,9808 snapshots: - completed: sha256: 8e7996960d864443a66eb4105338bbdd6830377b9f6f99cd5527ef73c10c01e7 From 06dc7e48102e72052b16d59fb343a51927f0f5a1 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Mon, 24 Jun 2024 04:16:30 +0200 Subject: [PATCH 30/52] Applied suggestions - Removed 'OsPath.Internal.toFilePath' - Assume Unicode encoding for Aeson type class instances - Stack build works with --pedantic flag --- src/OsPath/Include.hs | 10 ++--- src/OsPath/Internal/Include.hs | 46 ++++++++++++++-------- test-ospath/Common/Include.hs | 17 ++++---- test-ospath/TH/Include.hs | 18 +++++---- test-ospath/TH/Posix.hs | 13 +++--- test-ospath/TH/Windows.hs | 13 +++--- validity-test-ospath/Include.hs | 4 +- validity-test-ospath/Main.hs | 9 +---- validity-test-ospath/OsPath/Gen/Include.hs | 3 +- validity-test/Main.hs | 8 ---- validity-test/Path/Gen.hs | 5 +-- 11 files changed, 72 insertions(+), 74 deletions(-) diff --git a/src/OsPath/Include.hs b/src/OsPath/Include.hs index 40eb928..d2cb1e6 100644 --- a/src/OsPath/Include.hs +++ b/src/OsPath/Include.hs @@ -79,7 +79,7 @@ module OsPath.PLATFORM_NAME ,parseSomeDir ,parseSomeFile -- * Conversion - ,toFilePath + ,toOsPath ,fromAbsDir ,fromRelDir ,fromAbsFile @@ -118,7 +118,6 @@ import GHC.Generics (Generic) import Language.Haskell.TH (Exp, Q) import Language.Haskell.TH.Syntax (lift) import Language.Haskell.TH.Quote (QuasiQuoter(..)) -import System.IO.Unsafe (unsafeDupablePerformIO) import System.OsPath.PLATFORM_NAME (PLATFORM_PATH) import qualified System.OsPath.PLATFORM_NAME as OsPath import System.OsString.PLATFORM_NAME (PLATFORM_STRING) @@ -163,10 +162,9 @@ parseJSONWith :: (forall m . MonadThrow m => PLATFORM_PATH -> m a) -> Aeson.Parser a parseJSONWith f x = do fp <- parseJSON x - let ospath = unsafeDupablePerformIO (OsString.encodeFS fp) - case f ospath of - Right p -> return p - Left e -> fail (show e) + either (fail . displayException) return $ do + ospath <- OsString.encodeUtf fp + f ospath {-# INLINE parseJSONWith #-} instance FromJSONKey (Path Abs File) where diff --git a/src/OsPath/Internal/Include.hs b/src/OsPath/Internal/Include.hs index 55d9608..de6069d 100644 --- a/src/OsPath/Internal/Include.hs +++ b/src/OsPath/Internal/Include.hs @@ -19,7 +19,6 @@ module OsPath.Internal.PLATFORM_NAME ( -- * The Path type Path(..) - , toFilePath , toOsPath -- * Validation functions @@ -49,6 +48,7 @@ module OsPath.Internal.PLATFORM_NAME where import Control.DeepSeq (NFData (..)) +import Control.Exception (displayException) import Data.Aeson (ToJSON (..), ToJSONKey(..)) import Data.Aeson.Types (toJSONKeyText) import qualified Data.Text as Text (pack) @@ -56,7 +56,6 @@ import GHC.Generics (Generic) import Data.Data import Data.Hashable import qualified Language.Haskell.TH.Syntax as TH -import System.IO.Unsafe (unsafeDupablePerformIO) import System.OsPath.PLATFORM_NAME (PLATFORM_PATH) import qualified System.OsPath.PLATFORM_NAME as OsPath import System.OsString.Internal.Types (PLATFORM_STRING(..)) @@ -86,6 +85,7 @@ newtype Path b t = Path PLATFORM_PATH -- @show x == show y ≡ x == y@ instance Eq (Path b t) where (==) (Path x) (Path y) = x == y + {-# INLINE (==) #-} -- | String ordering. -- @@ -94,35 +94,57 @@ instance Eq (Path b t) where -- @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 . Path.toFilePath'. +-- | Same as 'show . OsPath.toOsPath'. -- -- The following property holds: -- -- @x == y ≡ show x == show y@ instance Show (Path b t) where - show = show . toFilePath + show = show . toOsPath + {-# INLINE show #-} instance NFData (Path b t) where rnf (Path x) = rnf x + {-# INLINE rnf #-} instance ToJSON (Path b t) where - toJSON = toJSON . toFilePath + toJSON = + either (error . displayException) toJSON + . OsPath.decodeUtf + . toOsPath {-# INLINE toJSON #-} #if MIN_VERSION_aeson(0,10,0) - toEncoding = toEncoding . toFilePath + toEncoding = + either (error . displayException) toEncoding + . OsPath.decodeUtf + . toOsPath {-# INLINE toEncoding #-} #endif +#if IS_WINDOWS +-- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is UTF-16LE +-- encoded. If decoding fails a runtime error will be thrown. +#else +-- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is UTF-8 +-- encoded. If decoding fails a runtime error will be thrown. +#endif instance ToJSONKey (Path b t) where - toJSONKey = toJSONKeyText (Text.pack . toFilePath) + toJSONKey = toJSONKeyText + ( either (error . displayException) Text.pack + . OsPath.decodeUtf + . toOsPath + ) + {-# INLINE toJSONKey #-} 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) + 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 @@ -143,14 +165,6 @@ instance forall b t. (Typeable b, Typeable t) => TH.Lift (Path b t) where liftTyped = TH.unsafeTExpCoerce . TH.lift #endif --- | 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 = unsafeDupablePerformIO . OsPath.decodeFS . toOsPath - -- | Convert to a PLATFORM_PATH type. -- -- All directories have a trailing slash, so if you want no trailing diff --git a/test-ospath/Common/Include.hs b/test-ospath/Common/Include.hs index 7df61ef..169ade1 100644 --- a/test-ospath/Common/Include.hs +++ b/test-ospath/Common/Include.hs @@ -22,7 +22,6 @@ 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 System.OsPath.PLATFORM_NAME (PLATFORM_PATH) import qualified System.OsPath.PLATFORM_NAME as OsPath import System.OsString.PLATFORM_NAME (PLATFORM_STRING) @@ -50,7 +49,7 @@ spec = do describe "Operations: dirname" operationDirname describe "Operations: filename" operationFilename describe "Operations: parent" operationParent - describe "Operations: toFilePath" operationToFilePath + describe "Operations: toOsPath" operationToOsPath describe "Operations: isProperPrefixOf" operationIsProperPrefixOf describe "Operations: stripProperPrefix" operationStripProperPrefix describe "Operations: isDrive" operationIsDrive @@ -204,12 +203,12 @@ operationAppend = do "AbsDir + RelFile == AbsFile" (absDir relFile == Path (absDir' OsPath. relFile')) -operationToFilePath :: Spec -operationToFilePath = do - let expected = "." ++ [FilePath.pathSeparator] +operationToOsPath :: Spec +operationToOsPath = do + let expected = relRoot it - ("toFilePath \".\" == " ++ show expected) - (toFilePath currentDir == expected) + ("toOsPath \".\" == " ++ show expected) + (toOsPath currentDir == expected) it ("show \".\" == " ++ (show . show) expected) (show currentDir == show expected) @@ -297,8 +296,8 @@ extensionOperations = do validExtensionsSpec :: PLATFORM_STRING -> Path b File -> Path b File -> Spec validExtensionsSpec ext file fext = do - let f = show $ toFilePath file - let fx = show $ toFilePath fext + let f = show $ toOsPath file + let fx = show $ toOsPath fext it ("addExtension " ++ show ext ++ " " ++ f ++ " == " ++ fx) $ addExtension ext file `shouldReturn` fext diff --git a/test-ospath/TH/Include.hs b/test-ospath/TH/Include.hs index 71add0e..ed4c083 100644 --- a/test-ospath/TH/Include.hs +++ b/test-ospath/TH/Include.hs @@ -1,5 +1,6 @@ -- This template expects CPP definitions for: -- PLATFORM_NAME = Posix | Windows +-- PLATFORM_PATH = PosixPath | WindowsPath {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes #-} @@ -10,6 +11,7 @@ module TH.PLATFORM_NAME where import qualified Language.Haskell.TH.Syntax as TH +import System.OsPath.PLATFORM_NAME (PLATFORM_PATH) import qualified System.OsString.PLATFORM_NAME as OsString import OsPath.Internal.PLATFORM_NAME @@ -20,28 +22,28 @@ import OsPath.PLATFORM_NAME -- This ensures that bugs like https://github.com/commercialhaskell/path/issues/159 -- cannot happen. class CheckInstantiated a b where - checkInstantiated :: Path a b -> FilePath - checkInstantiated = toFilePath + checkInstantiated :: Path a b -> PLATFORM_PATH + checkInstantiated = toOsPath instance CheckInstantiated Abs Dir instance CheckInstantiated Abs File instance CheckInstantiated Rel Dir instance CheckInstantiated Rel File -qqRelDir :: FilePath +qqRelDir :: PLATFORM_PATH qqRelDir = checkInstantiated [reldir|name/|] -qqRelFile :: FilePath +qqRelFile :: PLATFORM_PATH qqRelFile = checkInstantiated [relfile|name|] -thRelDir :: FilePath +thRelDir :: PLATFORM_PATH thRelDir = checkInstantiated $(mkRelDir [OsString.pstr|name/|]) -thRelFile :: FilePath +thRelFile :: PLATFORM_PATH thRelFile = checkInstantiated $(mkRelFile [OsString.pstr|name|]) -liftRelDir :: FilePath +liftRelDir :: PLATFORM_PATH liftRelDir = checkInstantiated $(TH.lift (Path [OsString.pstr|name/|] :: Path Rel Dir)) -liftRelFile :: FilePath +liftRelFile :: PLATFORM_PATH liftRelFile = checkInstantiated $(TH.lift (Path [OsString.pstr|name|] :: Path Rel File)) diff --git a/test-ospath/TH/Posix.hs b/test-ospath/TH/Posix.hs index 1fa18d1..9bd904c 100644 --- a/test-ospath/TH/Posix.hs +++ b/test-ospath/TH/Posix.hs @@ -1,22 +1,23 @@ {-# LANGUAGE CPP #-} #define PLATFORM_NAME Posix +#define PLATFORM_PATH PosixPath #include "Include.hs" -qqAbsDir :: FilePath +qqAbsDir :: PLATFORM_PATH qqAbsDir = checkInstantiated [absdir|/name/|] -qqAbsFile :: FilePath +qqAbsFile :: PLATFORM_PATH qqAbsFile = checkInstantiated [absdir|/name|] -thAbsDir :: FilePath +thAbsDir :: PLATFORM_PATH thAbsDir = checkInstantiated $(mkAbsDir [OsString.pstr|/name/|]) -thAbsFile :: FilePath +thAbsFile :: PLATFORM_PATH thAbsFile = checkInstantiated $(mkAbsFile [OsString.pstr|/name|]) -liftAbsDir :: FilePath +liftAbsDir :: PLATFORM_PATH liftAbsDir = checkInstantiated $(TH.lift (Path [OsString.pstr|/name/|] :: Path Abs Dir)) -liftAbsFile :: FilePath +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 index 5344db4..aec6cdc 100644 --- a/test-ospath/TH/Windows.hs +++ b/test-ospath/TH/Windows.hs @@ -1,22 +1,23 @@ {-# LANGUAGE CPP #-} #define PLATFORM_NAME Windows +#define PLATFORM_PATH WindowsPath #include "Include.hs" -qqAbsDir :: FilePath +qqAbsDir :: PLATFORM_PATH qqAbsDir = checkInstantiated [absdir|C:\foo\|] -qqAbsFile :: FilePath +qqAbsFile :: PLATFORM_PATH qqAbsFile = checkInstantiated [absdir|C:\foo|] -thAbsDir :: FilePath +thAbsDir :: PLATFORM_PATH thAbsDir = checkInstantiated $(mkAbsDir [OsString.pstr|C:\foo\|]) -thAbsFile :: FilePath +thAbsFile :: PLATFORM_PATH thAbsFile = checkInstantiated $(mkAbsFile [OsString.pstr|C:\foo|]) -liftAbsDir :: FilePath +liftAbsDir :: PLATFORM_PATH liftAbsDir = checkInstantiated $(TH.lift (Path [OsString.pstr|C:\foo\|] :: Path Abs Dir)) -liftAbsFile :: FilePath +liftAbsFile :: PLATFORM_PATH liftAbsFile = checkInstantiated $(TH.lift (Path [OsString.pstr|C:\foo|] :: Path Abs File)) diff --git a/validity-test-ospath/Include.hs b/validity-test-ospath/Include.hs index 85e9f04..6324201 100644 --- a/validity-test-ospath/Include.hs +++ b/validity-test-ospath/Include.hs @@ -8,17 +8,15 @@ -- | Test suite. module PLATFORM_NAME where -import Data.Maybe import OsPath.PLATFORM_NAME import OsPath.Internal.PLATFORM_NAME import System.OsPath.PLATFORM_NAME (PLATFORM_PATH) import qualified System.OsString.PLATFORM_NAME as OsString import Test.Hspec -import Test.Hspec.QuickCheck import Test.QuickCheck import Test.Validity -import OsPath.Gen.PLATFORM_NAME +import OsPath.Gen.PLATFORM_NAME () -- | Test suite entry point, returns exit failure if any test fails. main :: IO () diff --git a/validity-test-ospath/Main.hs b/validity-test-ospath/Main.hs index e26d47f..3518cfe 100644 --- a/validity-test-ospath/Main.hs +++ b/validity-test-ospath/Main.hs @@ -1,16 +1,11 @@ -- | Test suite. module Main (main) where -import Data.Maybe -import Path -import Path.Internal import Test.Hspec -import Test.Hspec.QuickCheck -import Test.QuickCheck -import Test.Validity +import Test.Hspec.QuickCheck (modifyMaxShrinks) import qualified Posix -import qualified Windows +--import qualified Windows -- | Test suite entry point, returns exit failure if any test fails. main :: IO () diff --git a/validity-test-ospath/OsPath/Gen/Include.hs b/validity-test-ospath/OsPath/Gen/Include.hs index 55c9880..2e7e186 100644 --- a/validity-test-ospath/OsPath/Gen/Include.hs +++ b/validity-test-ospath/OsPath/Gen/Include.hs @@ -12,8 +12,7 @@ import OsPath.Internal.PLATFORM_NAME import Data.Char (chr, ord) import Data.GenValidity -import Data.List (isSuffixOf, isInfixOf) -import Data.Maybe (isJust, mapMaybe) +import Data.Maybe (mapMaybe) import System.OsPath.PLATFORM_NAME (PLATFORM_PATH) import qualified System.OsPath.PLATFORM_NAME as OsPath import qualified System.OsString.PLATFORM_NAME as OsString diff --git a/validity-test/Main.hs b/validity-test/Main.hs index 2bd88df..b1d5129 100644 --- a/validity-test/Main.hs +++ b/validity-test/Main.hs @@ -7,7 +7,6 @@ -- | Test suite. module Main (main) where -import Data.Maybe import Path import Path.Internal import Test.Hspec @@ -248,13 +247,6 @@ forAllParentsAndChildren n func = do 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" $ diff --git a/validity-test/Path/Gen.hs b/validity-test/Path/Gen.hs index 396103e..e141a9d 100644 --- a/validity-test/Path/Gen.hs +++ b/validity-test/Path/Gen.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Path.Gen where @@ -13,8 +12,8 @@ import Path.Internal import qualified System.FilePath as FilePath import Data.GenValidity -import Data.List (isSuffixOf, isInfixOf) -import Data.Maybe (isJust, mapMaybe) +import Data.List (isSuffixOf) +import Data.Maybe (mapMaybe) import Test.QuickCheck From 3cf6556439be42ac8d2d0cdb167cae40d03b9aba Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Tue, 25 Jun 2024 17:56:55 +0200 Subject: [PATCH 31/52] Better documentation for FromJSON/ToJSON instances --- src/OsPath/Include.hs | 19 ++++++++++++++++++- src/OsPath/Internal/Include.hs | 12 +++++------- src/OsPath/Internal/Posix.hs | 1 + src/OsPath/Internal/Windows.hs | 1 + src/OsPath/Posix.hs | 1 + src/OsPath/Windows.hs | 1 + 6 files changed, 27 insertions(+), 8 deletions(-) diff --git a/src/OsPath/Include.hs b/src/OsPath/Include.hs index d2cb1e6..79d914d 100644 --- a/src/OsPath/Include.hs +++ b/src/OsPath/Include.hs @@ -1,6 +1,7 @@ -- This template expects CPP definitions for: -- PLATFORM_NAME = Posix | Windows --- IS_WINDOWS = 0 | 1 +-- PLATFORM_UTF_CODEC = UTF8 | UTF16-LE +-- IS_WINDOWS = 0 | 1 -- | This library provides a well-typed representation of paths in a filesystem -- directory tree. @@ -141,18 +142,26 @@ data File deriving (Typeable, Data) -- | A directory path. data Dir deriving (Typeable, Data) +-- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is +-- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. instance FromJSON (Path Abs File) where parseJSON = parseJSONWith parseAbsFile {-# INLINE parseJSON #-} +-- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is +-- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. instance FromJSON (Path Rel File) where parseJSON = parseJSONWith parseRelFile {-# INLINE parseJSON #-} +-- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is +-- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. instance FromJSON (Path Abs Dir) where parseJSON = parseJSONWith parseAbsDir {-# INLINE parseJSON #-} +-- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is +-- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. instance FromJSON (Path Rel Dir) where parseJSON = parseJSONWith parseRelDir {-# INLINE parseJSON #-} @@ -167,18 +176,26 @@ parseJSONWith f x = f ospath {-# INLINE parseJSONWith #-} +-- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is +-- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. instance FromJSONKey (Path Abs File) where fromJSONKey = fromJSONKeyWith parseAbsFile {-# INLINE fromJSONKey #-} +-- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is +-- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. instance FromJSONKey (Path Rel File) where fromJSONKey = fromJSONKeyWith parseRelFile {-# INLINE fromJSONKey #-} +-- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is +-- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. instance FromJSONKey (Path Abs Dir) where fromJSONKey = fromJSONKeyWith parseAbsDir {-# INLINE fromJSONKey #-} +-- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is +-- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. instance FromJSONKey (Path Rel Dir) where fromJSONKey = fromJSONKeyWith parseRelDir {-# INLINE fromJSONKey #-} diff --git a/src/OsPath/Internal/Include.hs b/src/OsPath/Internal/Include.hs index de6069d..0545665 100644 --- a/src/OsPath/Internal/Include.hs +++ b/src/OsPath/Internal/Include.hs @@ -2,6 +2,7 @@ -- PLATFORM_NAME = Posix | Windows -- PLATFORM_PATH = PosixPath | WindowsPath -- PLATFORM_PATH_SINGLE = 'PosixPath' | 'WindowsPath' +-- PLATFORM_UTF_CODEC = UTF8 | UTF16-LE -- IS_WINDOWS = 0 | 1 {-# LANGUAGE BangPatterns #-} @@ -109,6 +110,8 @@ instance NFData (Path b t) where rnf (Path x) = rnf x {-# INLINE rnf #-} +-- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is +-- PLATFORM_UTF_CODEC encoded. If encoding fails a runtime error will be thrown. instance ToJSON (Path b t) where toJSON = either (error . displayException) toJSON @@ -123,13 +126,8 @@ instance ToJSON (Path b t) where {-# INLINE toEncoding #-} #endif -#if IS_WINDOWS --- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is UTF-16LE --- encoded. If decoding fails a runtime error will be thrown. -#else --- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is UTF-8 --- encoded. If decoding fails a runtime error will be thrown. -#endif +-- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is +-- PLATFORM_UTF_CODEC encoded. If encoding fails a runtime error will be thrown. instance ToJSONKey (Path b t) where toJSONKey = toJSONKeyText ( either (error . displayException) Text.pack diff --git a/src/OsPath/Internal/Posix.hs b/src/OsPath/Internal/Posix.hs index 233afc5..bcc72fb 100644 --- a/src/OsPath/Internal/Posix.hs +++ b/src/OsPath/Internal/Posix.hs @@ -3,5 +3,6 @@ #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/Internal/Windows.hs b/src/OsPath/Internal/Windows.hs index 75a6249..7d58bfb 100644 --- a/src/OsPath/Internal/Windows.hs +++ b/src/OsPath/Internal/Windows.hs @@ -3,5 +3,6 @@ #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/OsPath/Posix.hs b/src/OsPath/Posix.hs index 233afc5..bcc72fb 100644 --- a/src/OsPath/Posix.hs +++ b/src/OsPath/Posix.hs @@ -3,5 +3,6 @@ #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 index 75a6249..7d58bfb 100644 --- a/src/OsPath/Windows.hs +++ b/src/OsPath/Windows.hs @@ -3,5 +3,6 @@ #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" From 55fe3bddf5ed18f2e2ecb2fd5c9626aac481906a Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Tue, 25 Jun 2024 20:24:33 +0200 Subject: [PATCH 32/52] Better GenValid instance for PosixPath/WindowsPath --- validity-test-ospath/OsPath/Gen/Include.hs | 36 ++++++++++++++++------ validity-test-ospath/OsPath/Gen/Posix.hs | 3 ++ validity-test-ospath/OsPath/Gen/Windows.hs | 3 ++ 3 files changed, 32 insertions(+), 10 deletions(-) diff --git a/validity-test-ospath/OsPath/Gen/Include.hs b/validity-test-ospath/OsPath/Gen/Include.hs index 2e7e186..2b73979 100644 --- a/validity-test-ospath/OsPath/Gen/Include.hs +++ b/validity-test-ospath/OsPath/Gen/Include.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module OsPath.Gen.PLATFORM_NAME where @@ -10,11 +12,12 @@ import Prelude import OsPath.PLATFORM_NAME import OsPath.Internal.PLATFORM_NAME -import Data.Char (chr, ord) import Data.GenValidity import Data.Maybe (mapMaybe) +import Data.Word (PLATFORM_WORD) import System.OsPath.PLATFORM_NAME (PLATFORM_PATH) import qualified System.OsPath.PLATFORM_NAME as OsPath +import System.OsString.Internal.Types (PLATFORM_CHAR(..)) import qualified System.OsString.PLATFORM_NAME as OsString import Test.QuickCheck @@ -128,18 +131,31 @@ shrinkValidWith fun (Path f) = filter (/= Path f) . mapMaybe fun $ shrinkValid f -------------------------------------------------------------------------------- -- Orphan instances --- | Generates 'PLATFORM_PATH with a high occurence of @'.'@, @'\/'@ and --- @'\\'@ characters. The resulting 'FilePath's are not guaranteed to --- be valid. +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 - -- We also need to exclude UTF-16 surrogates. - genValid = mconcat <$> listOf (OsString.unsafeEncodeUtf . (:[]) . chr <$> frequency - [ (2, choose (0x0, 0xD800 - 1)) - , (2, choose (0xDFFF + 1, 0x10FFFF)) - , (1, elements (map ord "./\\")) + genValid = OsPath.pack <$> listOf (frequency + [ (2, genValid) + , (1, elements (OsPath.extSeparator : OsPath.pathSeparators)) ] ) - shrinkValid _ = [] -- TODO: Not yet implemented + 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 where validate = trivialValidation -- TODO: Not yet implemented diff --git a/validity-test-ospath/OsPath/Gen/Posix.hs b/validity-test-ospath/OsPath/Gen/Posix.hs index 94f2448..8f24aee 100644 --- a/validity-test-ospath/OsPath/Gen/Posix.hs +++ b/validity-test-ospath/OsPath/Gen/Posix.hs @@ -2,4 +2,7 @@ #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 index 1285bd3..903e8b2 100644 --- a/validity-test-ospath/OsPath/Gen/Windows.hs +++ b/validity-test-ospath/OsPath/Gen/Windows.hs @@ -2,4 +2,7 @@ #define PLATFORM_NAME Windows #define PLATFORM_PATH WindowsPath +#define PLATFORM_PATH_SINGLE 'WindowsPath' +#define PLATFORM_CHAR WindowsChar +#define PLATFORM_WORD Word16 #include "Include.hs" From 3f4c4504514aeccb1cb4a55747dfc345f859f404 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Tue, 25 Jun 2024 20:55:41 +0200 Subject: [PATCH 33/52] Moved aeson instances of OsPath to OsPath.Aeson namespace --- path.cabal | 4 + src/OsPath/Aeson.hs | 10 +++ src/OsPath/Aeson/Include.hs | 130 +++++++++++++++++++++++++++++++++ src/OsPath/Aeson/Posix.hs | 6 ++ src/OsPath/Aeson/Windows.hs | 6 ++ src/OsPath/Include.hs | 89 ---------------------- src/OsPath/Internal/Include.hs | 31 -------- src/OsPath/Internal/Posix.hs | 1 - src/OsPath/Internal/Windows.hs | 1 - test-ospath/Common/Include.hs | 1 + 10 files changed, 157 insertions(+), 122 deletions(-) create mode 100644 src/OsPath/Aeson.hs create mode 100644 src/OsPath/Aeson/Include.hs create mode 100644 src/OsPath/Aeson/Posix.hs create mode 100644 src/OsPath/Aeson/Windows.hs diff --git a/path.cabal b/path.cabal index 5da6bd8..2c4f546 100644 --- a/path.cabal +++ b/path.cabal @@ -15,6 +15,7 @@ extra-source-files: README.md , CHANGELOG , src/Path/Include.hs , src/Path/Internal/Include.hs + , src/OsPath/Aeson/Include.hs , src/OsPath/Include.hs , src/OsPath/Internal/Include.hs , test/Common/Include.hs @@ -36,6 +37,9 @@ library , Path.Internal.Posix , Path.Internal.Windows , OsPath + , OsPath.Aeson + , OsPath.Aeson.Posix + , OsPath.Aeson.Windows , OsPath.Posix , OsPath.Windows , OsPath.Internal diff --git a/src/OsPath/Aeson.hs b/src/OsPath/Aeson.hs new file mode 100644 index 0000000..d65ea30 --- /dev/null +++ b/src/OsPath/Aeson.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-dodgy-exports #-} + +#if defined(mingw32_HOST_OS) +module OsPath.Aeson(module OsPath.Aeson.Windows) where +import OsPath.Aeson.Windows () +#else +module OsPath.Aeson(module OsPath.Aeson.Posix) where +import OsPath.Aeson.Posix () +#endif diff --git a/src/OsPath/Aeson/Include.hs b/src/OsPath/Aeson/Include.hs new file mode 100644 index 0000000..7a715c8 --- /dev/null +++ b/src/OsPath/Aeson/Include.hs @@ -0,0 +1,130 @@ +-- This template expects CPP definitions for: +-- PLATFORM_NAME = Posix | Windows +-- PLATFORM_PATH = PosixPath | WindowsPath +-- PLATFORM_PATH_SINGLE = 'PosixPath' | 'WindowsPath' +-- PLATFORM_UTF_CODEC = UTF8 | UTF16-LE + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module OsPath.Aeson.PLATFORM_NAME () where + +import Control.Exception (displayException) +import Control.Monad.Catch (MonadThrow) +import Data.Aeson (FromJSON (..), FromJSONKey (..), ToJSON (..), ToJSONKey (..)) +import qualified Data.Aeson.Types as Aeson +import qualified Data.Text as Text +import System.OsPath.PLATFORM_NAME (PLATFORM_PATH) +import qualified System.OsPath.PLATFORM_NAME as OsPath + +import OsPath.PLATFORM_NAME + +-- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is +-- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. +instance FromJSON (Path Abs File) where + parseJSON = parseJSONWith parseAbsFile + {-# INLINE parseJSON #-} + +-- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is +-- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. +instance FromJSON (Path Rel File) where + parseJSON = parseJSONWith parseRelFile + {-# INLINE parseJSON #-} + +-- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is +-- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. +instance FromJSON (Path Abs Dir) where + parseJSON = parseJSONWith parseAbsDir + {-# INLINE parseJSON #-} + +-- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is +-- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. +instance FromJSON (Path Rel Dir) where + parseJSON = parseJSONWith parseRelDir + {-# INLINE parseJSON #-} + +parseJSONWith :: (forall m . MonadThrow m => PLATFORM_PATH -> m a) + -> Aeson.Value + -> Aeson.Parser a +parseJSONWith f x = + do fp <- parseJSON x + either (fail . displayException) return $ do + ospath <- OsPath.encodeUtf fp + f ospath +{-# INLINE parseJSONWith #-} + +-- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is +-- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. +instance FromJSONKey (Path Abs File) where + fromJSONKey = fromJSONKeyWith parseAbsFile + {-# INLINE fromJSONKey #-} + +-- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is +-- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. +instance FromJSONKey (Path Rel File) where + fromJSONKey = fromJSONKeyWith parseRelFile + {-# INLINE fromJSONKey #-} + +-- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is +-- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. +instance FromJSONKey (Path Abs Dir) where + fromJSONKey = fromJSONKeyWith parseAbsDir + {-# INLINE fromJSONKey #-} + +-- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is +-- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. +instance FromJSONKey (Path Rel Dir) where + fromJSONKey = fromJSONKeyWith parseRelDir + {-# INLINE fromJSONKey #-} + +fromJSONKeyWith :: (forall m . MonadThrow m => PLATFORM_PATH -> m b) + -> Aeson.FromJSONKeyFunction b +fromJSONKeyWith f = + Aeson.FromJSONKeyTextParser $ \text -> + either (fail . displayException) return $ do + ospath <- (OsPath.encodeUtf . Text.unpack) text + f ospath +{-# INLINE fromJSONKeyWith #-} + +-- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is +-- PLATFORM_UTF_CODEC encoded. If encoding fails a runtime error will be thrown. +instance ToJSON (Path b t) where + toJSON = + either (error . displayException) toJSON + . OsPath.decodeUtf + . toOsPath + {-# INLINE toJSON #-} +#if MIN_VERSION_aeson(0,10,0) + toEncoding = + either (error . displayException) toEncoding + . OsPath.decodeUtf + . toOsPath + {-# INLINE toEncoding #-} +#endif + +-- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is +-- PLATFORM_UTF_CODEC encoded. If encoding fails a runtime error will be thrown. +instance ToJSONKey (Path b t) where + toJSONKey = Aeson.toJSONKeyText + ( either (error . displayException) Text.pack + . OsPath.decodeUtf + . toOsPath + ) + {-# INLINE toJSONKey #-} + +instance FromJSON (SomeBase Dir) where + parseJSON = parseJSONWith parseSomeDir + {-# INLINE parseJSON #-} + +instance FromJSON (SomeBase File) where + parseJSON = parseJSONWith parseSomeFile + {-# INLINE parseJSON #-} + +instance ToJSON (SomeBase t) where + toJSON = prjSomeBase toJSON + {-# INLINE toJSON #-} +#if MIN_VERSION_aeson(0,10,0) + toEncoding = prjSomeBase toEncoding + {-# INLINE toEncoding #-} +#endif diff --git a/src/OsPath/Aeson/Posix.hs b/src/OsPath/Aeson/Posix.hs new file mode 100644 index 0000000..b31ac49 --- /dev/null +++ b/src/OsPath/Aeson/Posix.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE CPP #-} +#define PLATFORM_NAME Posix +#define PLATFORM_PATH PosixPath +#define PLATFORM_PATH_SINGLE 'PosixPath' +#define PLATFORM_UTF_CODEC UTF8 +#include "Include.hs" diff --git a/src/OsPath/Aeson/Windows.hs b/src/OsPath/Aeson/Windows.hs new file mode 100644 index 0000000..baaf781 --- /dev/null +++ b/src/OsPath/Aeson/Windows.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE CPP #-} +#define PLATFORM_NAME Windows +#define PLATFORM_PATH WindowsPath +#define PLATFORM_PATH_SINGLE 'WindowsPath' +#define PLATFORM_UTF_CODEC UTF16-LE +#include "Include.hs" diff --git a/src/OsPath/Include.hs b/src/OsPath/Include.hs index 79d914d..8952d1a 100644 --- a/src/OsPath/Include.hs +++ b/src/OsPath/Include.hs @@ -1,7 +1,5 @@ -- This template expects CPP definitions for: -- PLATFORM_NAME = Posix | Windows --- PLATFORM_UTF_CODEC = UTF8 | UTF16-LE --- IS_WINDOWS = 0 | 1 -- | This library provides a well-typed representation of paths in a filesystem -- directory tree. @@ -28,7 +26,6 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} module OsPath.PLATFORM_NAME (-- * Types @@ -109,10 +106,7 @@ import Control.DeepSeq (NFData (..)) import Control.Exception (Exception(..)) import Control.Monad (liftM, when, (<=<)) import Control.Monad.Catch (MonadThrow(..)) -import Data.Aeson (FromJSON (..), FromJSONKey(..), ToJSON(..)) -import qualified Data.Aeson.Types as Aeson import Data.Data (Data, Typeable) -import qualified Data.Text as Text import Data.Hashable (Hashable (..)) import Data.Maybe (isJust, isNothing) import GHC.Generics (Generic) @@ -142,73 +136,6 @@ data File deriving (Typeable, Data) -- | A directory path. data Dir deriving (Typeable, Data) --- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is --- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. -instance FromJSON (Path Abs File) where - parseJSON = parseJSONWith parseAbsFile - {-# INLINE parseJSON #-} - --- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is --- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. -instance FromJSON (Path Rel File) where - parseJSON = parseJSONWith parseRelFile - {-# INLINE parseJSON #-} - --- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is --- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. -instance FromJSON (Path Abs Dir) where - parseJSON = parseJSONWith parseAbsDir - {-# INLINE parseJSON #-} - --- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is --- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. -instance FromJSON (Path Rel Dir) where - parseJSON = parseJSONWith parseRelDir - {-# INLINE parseJSON #-} - -parseJSONWith :: (forall m . MonadThrow m => PLATFORM_PATH -> m a) - -> Aeson.Value - -> Aeson.Parser a -parseJSONWith f x = - do fp <- parseJSON x - either (fail . displayException) return $ do - ospath <- OsString.encodeUtf fp - f ospath -{-# INLINE parseJSONWith #-} - --- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is --- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. -instance FromJSONKey (Path Abs File) where - fromJSONKey = fromJSONKeyWith parseAbsFile - {-# INLINE fromJSONKey #-} - --- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is --- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. -instance FromJSONKey (Path Rel File) where - fromJSONKey = fromJSONKeyWith parseRelFile - {-# INLINE fromJSONKey #-} - --- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is --- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. -instance FromJSONKey (Path Abs Dir) where - fromJSONKey = fromJSONKeyWith parseAbsDir - {-# INLINE fromJSONKey #-} - --- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is --- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. -instance FromJSONKey (Path Rel Dir) where - fromJSONKey = fromJSONKeyWith parseRelDir - {-# INLINE fromJSONKey #-} - -fromJSONKeyWith :: (forall m . MonadThrow m => PLATFORM_PATH -> m b) - -> Aeson.FromJSONKeyFunction b -fromJSONKeyWith f = - Aeson.FromJSONKeyTextParser $ \text -> - either (fail . displayException) return $ do - ospath <- (OsPath.encodeUtf . Text.unpack) text - f ospath -{-# INLINE fromJSONKeyWith #-} - -- | Exceptions that can occur during path operations. -- -- @since 0.6.0 @@ -738,26 +665,10 @@ instance NFData (SomeBase t) where instance Show (SomeBase t) where show = show . fromSomeBase -instance ToJSON (SomeBase t) where - toJSON = prjSomeBase toJSON - {-# INLINE toJSON #-} -#if MIN_VERSION_aeson(0,10,0) - toEncoding = prjSomeBase toEncoding - {-# INLINE toEncoding #-} -#endif - instance Hashable (SomeBase t) where -- See 'Hashable' 'Path' instance for details. hashWithSalt n path = hashWithSalt n (fromSomeBase path) -instance FromJSON (SomeBase Dir) where - parseJSON = parseJSONWith parseSomeDir - {-# INLINE parseJSON #-} - -instance FromJSON (SomeBase File) where - parseJSON = parseJSONWith parseSomeFile - {-# INLINE parseJSON #-} - -- | Helper to project the contents out of a SomeBase object. -- -- >>> prjSomeBase toOsPath (Abs [absfile|/foo/bar/cow.moo|]) == [pstr|/foo/bar/cow.moo|] diff --git a/src/OsPath/Internal/Include.hs b/src/OsPath/Internal/Include.hs index 0545665..9ac9b2b 100644 --- a/src/OsPath/Internal/Include.hs +++ b/src/OsPath/Internal/Include.hs @@ -2,7 +2,6 @@ -- PLATFORM_NAME = Posix | Windows -- PLATFORM_PATH = PosixPath | WindowsPath -- PLATFORM_PATH_SINGLE = 'PosixPath' | 'WindowsPath' --- PLATFORM_UTF_CODEC = UTF8 | UTF16-LE -- IS_WINDOWS = 0 | 1 {-# LANGUAGE BangPatterns #-} @@ -49,10 +48,6 @@ module OsPath.Internal.PLATFORM_NAME where import Control.DeepSeq (NFData (..)) -import Control.Exception (displayException) -import Data.Aeson (ToJSON (..), ToJSONKey(..)) -import Data.Aeson.Types (toJSONKeyText) -import qualified Data.Text as Text (pack) import GHC.Generics (Generic) import Data.Data import Data.Hashable @@ -110,32 +105,6 @@ instance NFData (Path b t) where rnf (Path x) = rnf x {-# INLINE rnf #-} --- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is --- PLATFORM_UTF_CODEC encoded. If encoding fails a runtime error will be thrown. -instance ToJSON (Path b t) where - toJSON = - either (error . displayException) toJSON - . OsPath.decodeUtf - . toOsPath - {-# INLINE toJSON #-} -#if MIN_VERSION_aeson(0,10,0) - toEncoding = - either (error . displayException) toEncoding - . OsPath.decodeUtf - . toOsPath - {-# INLINE toEncoding #-} -#endif - --- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is --- PLATFORM_UTF_CODEC encoded. If encoding fails a runtime error will be thrown. -instance ToJSONKey (Path b t) where - toJSONKey = toJSONKeyText - ( either (error . displayException) Text.pack - . OsPath.decodeUtf - . toOsPath - ) - {-# INLINE toJSONKey #-} - 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 diff --git a/src/OsPath/Internal/Posix.hs b/src/OsPath/Internal/Posix.hs index bcc72fb..233afc5 100644 --- a/src/OsPath/Internal/Posix.hs +++ b/src/OsPath/Internal/Posix.hs @@ -3,6 +3,5 @@ #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/Internal/Windows.hs b/src/OsPath/Internal/Windows.hs index 7d58bfb..75a6249 100644 --- a/src/OsPath/Internal/Windows.hs +++ b/src/OsPath/Internal/Windows.hs @@ -3,6 +3,5 @@ #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/test-ospath/Common/Include.hs b/test-ospath/Common/Include.hs index 169ade1..917f494 100644 --- a/test-ospath/Common/Include.hs +++ b/test-ospath/Common/Include.hs @@ -29,6 +29,7 @@ import qualified System.OsString.PLATFORM_NAME as OsString import Test.Hspec import OsPath.PLATFORM_NAME +import OsPath.Aeson.PLATFORM_NAME () import OsPath.Internal.PLATFORM_NAME currentDir :: Path Rel Dir From e73559b0815aaa11c61111f79c7c0ac0c86be2c5 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Wed, 26 Jun 2024 00:42:23 +0200 Subject: [PATCH 34/52] Provide newtype wrappers to control the decoding/encoding in OsPath aeson instances --- path.cabal | 1 + src/OsPath/Aeson/Include.hs | 358 ++++++++++++++++++++++++++++------- src/OsPath/Aeson/Internal.hs | 22 +++ src/OsPath/Aeson/Posix.hs | 3 + src/OsPath/Aeson/Windows.hs | 3 + src/OsPath/Include.hs | 19 +- 6 files changed, 328 insertions(+), 78 deletions(-) create mode 100644 src/OsPath/Aeson/Internal.hs diff --git a/path.cabal b/path.cabal index 2c4f546..093ad9a 100644 --- a/path.cabal +++ b/path.cabal @@ -38,6 +38,7 @@ library , Path.Internal.Windows , OsPath , OsPath.Aeson + , OsPath.Aeson.Internal , OsPath.Aeson.Posix , OsPath.Aeson.Windows , OsPath.Posix diff --git a/src/OsPath/Aeson/Include.hs b/src/OsPath/Aeson/Include.hs index 7a715c8..09de31f 100644 --- a/src/OsPath/Aeson/Include.hs +++ b/src/OsPath/Aeson/Include.hs @@ -2,129 +2,353 @@ -- PLATFORM_NAME = Posix | Windows -- PLATFORM_PATH = PosixPath | WindowsPath -- PLATFORM_PATH_SINGLE = 'PosixPath' | 'WindowsPath' +-- PLATFORM_CHAR = PosixChar | WindowsChar +-- PLATFORM_WORD = Word8 | Word16 -- PLATFORM_UTF_CODEC = UTF8 | UTF16-LE +-- IS_WINDOWS = 0 | 1 +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -module OsPath.Aeson.PLATFORM_NAME () where +module OsPath.Aeson.PLATFORM_NAME + ( AsBinary(..) + , AsText(..) + , IsTextEncoding + , Unicode + , Utf8 + , Utf16LE + ) where import Control.Exception (displayException) import Control.Monad.Catch (MonadThrow) import Data.Aeson (FromJSON (..), FromJSONKey (..), ToJSON (..), ToJSONKey (..)) +import Data.Aeson.Types (Parser, Value) import qualified Data.Aeson.Types as Aeson +import Data.Coerce (coerce) +import Data.Functor.Contravariant +import Data.Text (Text) import qualified Data.Text as Text +import Data.Word (PLATFORM_WORD) import System.OsPath.PLATFORM_NAME (PLATFORM_PATH) import qualified System.OsPath.PLATFORM_NAME as OsPath +import System.OsString.Internal.Types (PLATFORM_CHAR(..)) import OsPath.PLATFORM_NAME +import OsPath.Aeson.Internal +import OsPath.Internal.PLATFORM_NAME + +-------------------------------------------------------------------------------- +-- Default instances +-------------------------------------------------------------------------------- -- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is -- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. -instance FromJSON (Path Abs File) where - parseJSON = parseJSONWith parseAbsFile +instance FromJSON (AsText (Path b t) Unicode) => FromJSON (Path b t) where + parseJSON = fmap (asText @(Path b t) @Unicode) . parseJSON {-# INLINE parseJSON #-} -- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is --- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. -instance FromJSON (Path Rel File) where - parseJSON = parseJSONWith parseRelFile - {-# INLINE parseJSON #-} +-- PLATFORM_UTF_CODEC encoded. If encoding fails a runtime error will be thrown. +instance ToJSON (Path b t) where + toJSON = toJSON . AsText @(Path b t) @Unicode + {-# INLINE toJSON #-} +#if MIN_VERSION_aeson(0,10,0) + toEncoding = toEncoding . AsText @(Path b t) @Unicode + {-# INLINE toEncoding #-} +#endif +#if MIN_VERSION_aeson(1,0,0) -- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is -- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. -instance FromJSON (Path Abs Dir) where - parseJSON = parseJSONWith parseAbsDir - {-# INLINE parseJSON #-} +instance (FromJSON (AsText (Path b t) Unicode), FromJSONKey (AsText (Path b t) Unicode)) => FromJSONKey (Path b t) where + fromJSONKey = asText @(Path b t) @Unicode <$> fromJSONKey + {-# INLINE fromJSONKey #-} -- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is --- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. -instance FromJSON (Path Rel Dir) where - parseJSON = parseJSONWith parseRelDir +-- PLATFORM_UTF_CODEC encoded. If encoding fails a runtime error will be thrown. +instance ToJSONKey (Path b t) where + toJSONKey = AsText @(Path b t) @Unicode >$< toJSONKey + {-# INLINE toJSONKey #-} +#endif + +instance FromJSON (AsText (SomeBase t) Unicode) => FromJSON (SomeBase t) where + parseJSON = fmap (asText @(SomeBase t) @Unicode) . parseJSON {-# INLINE parseJSON #-} -parseJSONWith :: (forall m . MonadThrow m => PLATFORM_PATH -> m a) - -> Aeson.Value - -> Aeson.Parser a -parseJSONWith f x = - do fp <- parseJSON x - either (fail . displayException) return $ do - ospath <- OsPath.encodeUtf fp - f ospath -{-# INLINE parseJSONWith #-} +instance ToJSON (SomeBase t) where + toJSON = toJSON . AsText @(SomeBase t) @Unicode + {-# INLINE toJSON #-} +#if MIN_VERSION_aeson(0,10,0) + toEncoding = toEncoding . AsText @(SomeBase t) @Unicode + {-# INLINE toEncoding #-} +#endif +#if MIN_VERSION_aeson(1,0,0) -- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is -- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. -instance FromJSONKey (Path Abs File) where - fromJSONKey = fromJSONKeyWith parseAbsFile +instance (FromJSON (AsText (SomeBase t) Unicode), FromJSONKey (AsText (SomeBase t) Unicode)) => FromJSONKey (SomeBase t) where + fromJSONKey = asText @(SomeBase t) @Unicode <$> fromJSONKey {-# INLINE fromJSONKey #-} -- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is --- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. -instance FromJSONKey (Path Rel File) where - fromJSONKey = fromJSONKeyWith parseRelFile - {-# INLINE fromJSONKey #-} +-- PLATFORM_UTF_CODEC encoded. If encoding fails a runtime error will be thrown. +instance ToJSONKey (SomeBase t) where + toJSONKey = AsText @(SomeBase t) @Unicode >$< toJSONKey + {-# INLINE toJSONKey #-} +#endif --- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is --- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. -instance FromJSONKey (Path Abs Dir) where - fromJSONKey = fromJSONKeyWith parseAbsDir - {-# INLINE fromJSONKey #-} +-------------------------------------------------------------------------------- +-- Instances for newtype wrappers +-------------------------------------------------------------------------------- --- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is --- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. -instance FromJSONKey (Path Rel Dir) where - fromJSONKey = fromJSONKeyWith parseRelDir - {-# INLINE fromJSONKey #-} +#if IS_WINDOWS +type Unicode = Utf16LE +#else +type Unicode = Utf8 +#endif -fromJSONKeyWith :: (forall m . MonadThrow m => PLATFORM_PATH -> m b) - -> Aeson.FromJSONKeyFunction b -fromJSONKeyWith f = - Aeson.FromJSONKeyTextParser $ \text -> - either (fail . displayException) return $ do - ospath <- (OsPath.encodeUtf . Text.unpack) text - f ospath -{-# INLINE fromJSONKeyWith #-} + ---------------------------------------- + -- Instances for PLATFORM_PATH + ---------------------------------------- --- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is --- PLATFORM_UTF_CODEC encoded. If encoding fails a runtime error will be thrown. -instance ToJSON (Path b t) where +instance FromJSON (AsBinary PLATFORM_PATH) where + parseJSON value = + AsBinary . OsPath.pack . coerce @[PLATFORM_WORD] @[PLATFORM_CHAR] + <$> parseJSON value + {-# INLINE parseJSON #-} + +instance IsTextEncoding encoding => FromJSON (AsText PLATFORM_PATH encoding) where + parseJSON value = + either (fail . displayException) (pure . AsText) + . OsPath.encodeWith (textEncoding @encoding) + =<< parseJSON value + {-# INLINE parseJSON #-} + +instance ToJSON (AsBinary PLATFORM_PATH) where + toJSON = + toJSON + . coerce @[PLATFORM_CHAR] @[PLATFORM_WORD] + . OsPath.unpack + . asBinary + {-# INLINE toJSON #-} +#if MIN_VERSION_aeson(0,10,0) + toEncoding = + toEncoding + . coerce @[PLATFORM_CHAR] @[PLATFORM_WORD] + . OsPath.unpack + . asBinary + {-# INLINE toEncoding #-} +#endif + +instance IsTextEncoding encoding => ToJSON (AsText PLATFORM_PATH encoding) where toJSON = either (error . displayException) toJSON - . OsPath.decodeUtf - . toOsPath + . OsPath.decodeWith (textEncoding @encoding) + . asText {-# INLINE toJSON #-} #if MIN_VERSION_aeson(0,10,0) toEncoding = either (error . displayException) toEncoding - . OsPath.decodeUtf - . toOsPath + . OsPath.decodeWith (textEncoding @encoding) + . asText {-# INLINE toEncoding #-} #endif --- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is --- PLATFORM_UTF_CODEC encoded. If encoding fails a runtime error will be thrown. -instance ToJSONKey (Path b t) where - toJSONKey = Aeson.toJSONKeyText - ( either (error . displayException) Text.pack - . OsPath.decodeUtf - . toOsPath +#if MIN_VERSION_aeson(1,0,0) +instance FromJSONKey (AsBinary PLATFORM_PATH) where + fromJSONKey = Aeson.FromJSONKeyValue parseJSON + {-# INLINE fromJSONKey #-} + +instance IsTextEncoding encoding => FromJSONKey (AsText PLATFORM_PATH encoding) where + fromJSONKey = Aeson.FromJSONKeyTextParser + ( either (fail . displayException) (pure . AsText) + . OsPath.encodeWith (textEncoding @encoding) + . Text.unpack ) + {-# INLINE fromJSONKey #-} + +instance ToJSONKey (AsBinary PLATFORM_PATH) where + toJSONKey = Aeson.ToJSONKeyValue toJSON toEncoding {-# INLINE toJSONKey #-} -instance FromJSON (SomeBase Dir) where - parseJSON = parseJSONWith parseSomeDir +instance IsTextEncoding encoding => ToJSONKey (AsText PLATFORM_PATH encoding) where + toJSONKey = Aeson.toJSONKeyText decodeAsText + {-# INLINE toJSONKey #-} + +decodeAsText :: forall encoding . + IsTextEncoding encoding => AsText PLATFORM_PATH encoding -> Text +decodeAsText = + either (error . displayException) Text.pack + . OsPath.decodeWith (textEncoding @encoding) + . asText +{-# INLINE decodeAsText #-} +#endif + + ---------------------------------------- + -- Instances for Path + ---------------------------------------- + +instance FromJSON (AsBinary (Path Abs Dir)) where + parseJSON = parseAsBinary parseAbsDir {-# INLINE parseJSON #-} -instance FromJSON (SomeBase File) where - parseJSON = parseJSONWith parseSomeFile +instance FromJSON (AsBinary (Path Abs File)) where + parseJSON = parseAsBinary parseAbsFile {-# INLINE parseJSON #-} -instance ToJSON (SomeBase t) where - toJSON = prjSomeBase toJSON +instance FromJSON (AsBinary (Path Rel Dir)) where + parseJSON = parseAsBinary parseRelDir + {-# INLINE parseJSON #-} + +instance FromJSON (AsBinary (Path Rel File)) where + parseJSON = parseAsBinary parseRelFile + {-# INLINE parseJSON #-} + +instance IsTextEncoding encoding => FromJSON (AsText (Path Abs Dir) encoding) where + parseJSON = parseAsText parseAbsDir + {-# INLINE parseJSON #-} + +instance IsTextEncoding encoding => FromJSON (AsText (Path Abs File) encoding) where + parseJSON = parseAsText parseAbsFile + {-# INLINE parseJSON #-} + +instance IsTextEncoding encoding => FromJSON (AsText (Path Rel Dir) encoding) where + parseJSON = parseAsText parseRelDir + {-# INLINE parseJSON #-} + +instance IsTextEncoding encoding => FromJSON (AsText (Path Rel File) encoding) where + parseJSON = parseAsText parseRelFile + {-# INLINE parseJSON #-} + +deriving via (AsBinary PLATFORM_PATH) instance ToJSON (AsBinary (Path b t)) +deriving via (AsText PLATFORM_PATH encoding) instance IsTextEncoding encoding => ToJSON (AsText (Path b t) encoding) + +#if MIN_VERSION_aeson(1,0,0) +instance FromJSONKey (AsBinary (Path Abs Dir)) where + fromJSONKey = Aeson.FromJSONKeyValue parseJSON + {-# INLINE fromJSONKey #-} + +instance FromJSONKey (AsBinary (Path Abs File)) where + fromJSONKey = Aeson.FromJSONKeyValue parseJSON + {-# INLINE fromJSONKey #-} + +instance FromJSONKey (AsBinary (Path Rel Dir)) where + fromJSONKey = Aeson.FromJSONKeyValue parseJSON + {-# INLINE fromJSONKey #-} + +instance FromJSONKey (AsBinary (Path Rel File)) where + fromJSONKey = Aeson.FromJSONKeyValue parseJSON + {-# INLINE fromJSONKey #-} + +instance IsTextEncoding encoding => FromJSONKey (AsText (Path Abs Dir) encoding) where + fromJSONKey = Aeson.FromJSONKeyTextParser (parseKeyAsText parseAbsDir) + {-# INLINE fromJSONKey #-} + +instance IsTextEncoding encoding => FromJSONKey (AsText (Path Abs File) encoding) where + fromJSONKey = Aeson.FromJSONKeyTextParser (parseKeyAsText parseAbsFile) + {-# INLINE fromJSONKey #-} + +instance IsTextEncoding encoding => FromJSONKey (AsText (Path Rel Dir) encoding) where + fromJSONKey = Aeson.FromJSONKeyTextParser (parseKeyAsText parseRelDir) + {-# INLINE fromJSONKey #-} + +instance IsTextEncoding encoding => FromJSONKey (AsText (Path Rel File) encoding) where + fromJSONKey = Aeson.FromJSONKeyTextParser (parseKeyAsText parseRelFile) + {-# INLINE fromJSONKey #-} + +deriving via (AsBinary PLATFORM_PATH) instance ToJSONKey (AsBinary (Path b t)) +deriving via (AsText PLATFORM_PATH encoding) instance IsTextEncoding encoding => ToJSONKey (AsText (Path b t) encoding) +#endif + + ---------------------------------------- + -- Instances for SomeBase + ---------------------------------------- + +instance FromJSON (AsBinary (SomeBase Dir)) where + parseJSON = parseAsBinary parseSomeDir + {-# INLINE parseJSON #-} + +instance FromJSON (AsBinary (SomeBase File)) where + parseJSON = parseAsBinary parseSomeFile + {-# INLINE parseJSON #-} + +instance IsTextEncoding encoding => FromJSON (AsText (SomeBase Dir) encoding) where + parseJSON = parseAsText parseSomeDir + {-# INLINE parseJSON #-} + +instance IsTextEncoding encoding => FromJSON (AsText (SomeBase File) encoding) where + parseJSON = parseAsText parseSomeFile + {-# INLINE parseJSON #-} + +instance ToJSON (AsBinary (SomeBase t)) where + toJSON = prjSomeBase (toJSON . AsBinary) . asBinary {-# INLINE toJSON #-} #if MIN_VERSION_aeson(0,10,0) - toEncoding = prjSomeBase toEncoding + toEncoding = prjSomeBase (toEncoding . AsBinary) . asBinary {-# INLINE toEncoding #-} #endif + +instance IsTextEncoding encoding => ToJSON (AsText (SomeBase t) encoding) where + toJSON = prjSomeBase (toJSON . AsText @_ @encoding) . asText + {-# INLINE toJSON #-} +#if MIN_VERSION_aeson(0,10,0) + toEncoding = prjSomeBase (toEncoding . AsText @_ @encoding) . asText + {-# INLINE toEncoding #-} +#endif + +#if MIN_VERSION_aeson(1,0,0) +instance ToJSONKey (AsBinary (SomeBase t)) where + toJSONKey = Aeson.ToJSONKeyValue toJSON toEncoding + {-# INLINE toJSONKey #-} + +instance IsTextEncoding encoding => ToJSONKey (AsText (SomeBase t) encoding) where + toJSONKey = Aeson.toJSONKeyText + ( prjSomeBase (decodeAsText . AsText @PLATFORM_PATH @encoding . toOsPath) + . asText + ) + {-# INLINE toJSONKey #-} +#endif + +-------------------------------------------------------------------------------- +-- Internal helpers +-------------------------------------------------------------------------------- + +parseAsBinary :: (forall m . MonadThrow m => PLATFORM_PATH -> m a) + -> Value + -> Parser (AsBinary a) +parseAsBinary parse value = + either (fail . displayException) (pure . AsBinary) + . parse + . asBinary + =<< parseJSON value +{-# INLINE parseAsBinary #-} + +parseAsText :: forall encoding a . IsTextEncoding encoding + => (forall m . MonadThrow m => PLATFORM_PATH -> m a) + -> Value + -> Parser (AsText a encoding) +parseAsText parse value = + either (fail . displayException) (pure . AsText) + . parse + . asText @_ @encoding + =<< parseJSON value +{-# INLINE parseAsText #-} + +parseKeyAsText :: forall encoding a . IsTextEncoding encoding + => (forall m . MonadThrow m => PLATFORM_PATH -> m a) + -> Text + -> Parser (AsText a encoding) +parseKeyAsText parse text = do + ospath <- either (fail . displayException) pure + . OsPath.encodeWith (textEncoding @encoding) + . Text.unpack + $ text + either (fail . displayException) (pure . AsText) (parse ospath) +{-# INLINE parseKeyAsText #-} diff --git a/src/OsPath/Aeson/Internal.hs b/src/OsPath/Aeson/Internal.hs new file mode 100644 index 0000000..fc07e5d --- /dev/null +++ b/src/OsPath/Aeson/Internal.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +module OsPath.Aeson.Internal where + +import System.IO + +newtype AsBinary path = AsBinary { asBinary :: path } + +newtype AsText path encoding = AsText { asText :: path } + +class IsTextEncoding a where + textEncoding :: TextEncoding + +data Utf8 + +instance IsTextEncoding Utf8 where + textEncoding = utf8 + +data Utf16LE + +instance IsTextEncoding Utf16LE where + textEncoding = utf16le diff --git a/src/OsPath/Aeson/Posix.hs b/src/OsPath/Aeson/Posix.hs index b31ac49..f4949a5 100644 --- a/src/OsPath/Aeson/Posix.hs +++ b/src/OsPath/Aeson/Posix.hs @@ -2,5 +2,8 @@ #define PLATFORM_NAME Posix #define PLATFORM_PATH PosixPath #define PLATFORM_PATH_SINGLE 'PosixPath' +#define PLATFORM_CHAR PosixChar +#define PLATFORM_WORD Word8 #define PLATFORM_UTF_CODEC UTF8 +#define IS_WINDOWS 0 #include "Include.hs" diff --git a/src/OsPath/Aeson/Windows.hs b/src/OsPath/Aeson/Windows.hs index baaf781..fd3a762 100644 --- a/src/OsPath/Aeson/Windows.hs +++ b/src/OsPath/Aeson/Windows.hs @@ -2,5 +2,8 @@ #define PLATFORM_NAME Windows #define PLATFORM_PATH WindowsPath #define PLATFORM_PATH_SINGLE 'WindowsPath' +#define PLATFORM_CHAR WindowsChar +#define PLATFORM_WORD Word16 #define PLATFORM_UTF_CODEC UTF16-LE +#define IS_WINDOWS 1 #include "Include.hs" diff --git a/src/OsPath/Include.hs b/src/OsPath/Include.hs index 8952d1a..7eb6bf5 100644 --- a/src/OsPath/Include.hs +++ b/src/OsPath/Include.hs @@ -104,8 +104,9 @@ module OsPath.PLATFORM_NAME import Control.Applicative (Alternative(..)) import Control.DeepSeq (NFData (..)) import Control.Exception (Exception(..)) -import Control.Monad (liftM, when, (<=<)) +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) @@ -448,7 +449,7 @@ splitExtension (Path ospath) = -- -- @since 0.5.11 fileExtension :: MonadThrow m => Path b File -> m PLATFORM_STRING -fileExtension = (liftM snd) . splitExtension +fileExtension = fmap snd . splitExtension -- | Add extension to given file path. -- @@ -486,7 +487,7 @@ addExtension ext (Path path) = do let withoutTrailingSeps = OsString.dropWhileEnd OsPath.isExtSeparator xtn -- Has to start with a "." - when (not $ OsPath.isExtSeparator sep) $ + unless (OsPath.isExtSeparator sep) $ throwM $ InvalidExtension ext -- Cannot have path separators @@ -755,10 +756,8 @@ addFileExtension :: MonadThrow m -> m (Path b File) -- ^ New file name with the desired extension added at the end addFileExtension ext (Path path) = if OsPath.isAbsolute path - then liftM coercePath (parseAbsFile (OsPath.addExtension path ext)) - else liftM coercePath (parseRelFile (OsPath.addExtension path ext)) - where coercePath :: Path a b -> Path a' b' - coercePath (Path a) = Path a + 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. @@ -788,10 +787,8 @@ setFileExtension :: MonadThrow m -> m (Path b File) -- ^ New file name with the desired extension setFileExtension ext (Path path) = if OsPath.isAbsolute path - then liftM coercePath (parseAbsFile (OsPath.replaceExtension path ext)) - else liftM coercePath (parseRelFile (OsPath.replaceExtension path ext)) - where coercePath :: Path a b -> Path a' b' - coercePath (Path a) = Path a + then coerce <$> parseAbsFile (OsPath.replaceExtension path ext) + else coerce <$> parseRelFile (OsPath.replaceExtension path ext) -- | A synonym for 'setFileExtension' in the form of an operator. -- From 32c140ef34b6128bdd30b322f03e012235256459 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Wed, 26 Jun 2024 00:50:32 +0200 Subject: [PATCH 35/52] Added Path.Internal.{Posix,Windows}.isWindows and removed some CPP from Path include file --- src/OsPath/Internal/Include.hs | 1 + src/Path/Include.hs | 19 ++++++------------- src/Path/Internal/Include.hs | 11 ++++++++++- src/Path/Internal/Posix.hs | 2 +- src/Path/Internal/Windows.hs | 2 +- src/Path/Posix.hs | 1 - src/Path/Windows.hs | 1 - 7 files changed, 19 insertions(+), 18 deletions(-) diff --git a/src/OsPath/Internal/Include.hs b/src/OsPath/Internal/Include.hs index 9ac9b2b..7adf4ed 100644 --- a/src/OsPath/Internal/Include.hs +++ b/src/OsPath/Internal/Include.hs @@ -295,6 +295,7 @@ isWindows = True #else isWindows = False #endif +{-# INLINE isWindows #-} -------------------------------------------------------------------------------- -- Orphan instances diff --git a/src/Path/Include.hs b/src/Path/Include.hs index 1ca20ae..76ae14e 100644 --- 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 = 0 | 1 -- | This library provides a well-typed representation of paths in a filesystem -- directory tree. @@ -482,11 +481,9 @@ splitExtension (Path fpath) = trailingSeps = takeWhile isSep rstr xtn = (takeWhile notSep . dropWhile isSep) rstr in (reverse name, reverse xtn ++ trailingSeps) -#if IS_WINDOWS - normalizeDrive = normalizeTrailingSeps -#else - normalizeDrive = id -#endif + normalizeDrive + | isWindows = normalizeTrailingSeps + | otherwise = id (drv, pth) = FilePath.splitDrive fpath (dir, file) = splitLast FilePath.isPathSeparator pth @@ -826,7 +823,6 @@ normalizeLeadingSeps path = normLeadingSep ++ rest where (leadingSeps, rest) = span FilePath.isPathSeparator path normLeadingSep = replicate (min 1 (length leadingSeps)) FilePath.pathSeparator -#if IS_WINDOWS -- | Normalizes seps only at the end of a path. normalizeTrailingSeps :: FilePath -> FilePath normalizeTrailingSeps = reverse . normalizeLeadingSeps . reverse @@ -846,15 +842,12 @@ normalizeWindowsSeps :: FilePath -> FilePath normalizeWindowsSeps path = normLeadingSeps ++ normalizeAllSeps rest where (leadingSeps, rest) = span FilePath.isPathSeparator path normLeadingSeps = replicate (min 2 (length leadingSeps)) FilePath.pathSeparator -#endif -- | Applies platform-specific sep normalization following @FilePath.normalise@. normalizeFilePath :: FilePath -> FilePath -#if IS_WINDOWS -normalizeFilePath = normalizeWindowsSeps . FilePath.normalise -#else -normalizeFilePath = normalizeLeadingSeps . FilePath.normalise -#endif +normalizeFilePath + | 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 diff --git a/src/Path/Internal/Include.hs b/src/Path/Internal/Include.hs index f91fd23..aa9035b 100644 --- a/src/Path/Internal/Include.hs +++ b/src/Path/Internal/Include.hs @@ -1,6 +1,6 @@ -- This template expects CPP definitions for: -- PLATFORM_NAME = Posix | Windows --- IS_WINDOWS = False | True +-- IS_WINDOWS = 0 | 1 {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} @@ -15,6 +15,7 @@ module Path.Internal.PLATFORM_NAME , relRootFP , toFilePath , hasParentDir + , isWindows ) where @@ -136,3 +137,11 @@ instance forall b t. (Typeable b, Typeable t) => TH.Lift (Path b t) where #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 index 25e35e1..23a1b40 100644 --- a/src/Path/Internal/Posix.hs +++ b/src/Path/Internal/Posix.hs @@ -1,4 +1,4 @@ {-# LANGUAGE CPP #-} #define PLATFORM_NAME Posix -#define IS_WINDOWS False +#define IS_WINDOWS 0 #include "Include.hs" diff --git a/src/Path/Internal/Windows.hs b/src/Path/Internal/Windows.hs index a8b5cbb..95b16e4 100644 --- a/src/Path/Internal/Windows.hs +++ b/src/Path/Internal/Windows.hs @@ -1,4 +1,4 @@ {-# LANGUAGE CPP #-} #define PLATFORM_NAME Windows -#define IS_WINDOWS True +#define IS_WINDOWS 1 #include "Include.hs" diff --git a/src/Path/Posix.hs b/src/Path/Posix.hs index 23a1b40..49b09ea 100644 --- a/src/Path/Posix.hs +++ b/src/Path/Posix.hs @@ -1,4 +1,3 @@ {-# LANGUAGE CPP #-} #define PLATFORM_NAME Posix -#define IS_WINDOWS 0 #include "Include.hs" diff --git a/src/Path/Windows.hs b/src/Path/Windows.hs index 95b16e4..5a09ca7 100644 --- a/src/Path/Windows.hs +++ b/src/Path/Windows.hs @@ -1,4 +1,3 @@ {-# LANGUAGE CPP #-} #define PLATFORM_NAME Windows -#define IS_WINDOWS 1 #include "Include.hs" From 5a16815182ed21093b2199f6dd068aecaffff023 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Wed, 26 Jun 2024 17:20:22 +0200 Subject: [PATCH 36/52] Added explicit conversion functions to OsPath.Aeson modules - Also started with documentation. - Expose 'OsPath.fromSomeBase' - Require aeson >=1.0.0.0 to avoid tons of CPP --- path.cabal | 2 +- src/OsPath/Aeson/Include.hs | 632 ++++++++++++++++++++++++++--------- src/OsPath/Aeson/Internal.hs | 11 +- src/OsPath/Aeson/Posix.hs | 2 + src/OsPath/Aeson/Windows.hs | 2 + src/OsPath/Include.hs | 1 + 6 files changed, 493 insertions(+), 157 deletions(-) diff --git a/path.cabal b/path.cabal index 093ad9a..0954fbe 100644 --- a/path.cabal +++ b/path.cabal @@ -46,7 +46,7 @@ library , OsPath.Internal , OsPath.Internal.Posix , OsPath.Internal.Windows - build-depends: aeson + build-depends: aeson >= 1.0.0.0 , base >= 4.12 && < 5 , deepseq , exceptions >= 0.4 && < 0.11 diff --git a/src/OsPath/Aeson/Include.hs b/src/OsPath/Aeson/Include.hs index 09de31f..42797b2 100644 --- a/src/OsPath/Aeson/Include.hs +++ b/src/OsPath/Aeson/Include.hs @@ -3,10 +3,13 @@ -- PLATFORM_PATH = PosixPath | WindowsPath -- PLATFORM_PATH_SINGLE = 'PosixPath' | 'WindowsPath' -- PLATFORM_CHAR = PosixChar | WindowsChar +-- PLATFORM_CHAR_SINGLE = 'PosixChar' | 'WindowsChar' -- PLATFORM_WORD = Word8 | Word16 +-- PLATFORM_WORD_SINGLE = 'Word8' | 'Word16' -- PLATFORM_UTF_CODEC = UTF8 | UTF16-LE -- IS_WINDOWS = 0 | 1 +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -17,25 +20,137 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} +-- | This module provides the necessary tools to decode\/encode a 'Path' +-- from\/to a 'Value'. +-- +-- __Background:__ +-- In earlier versions of this library there was only the @Path.Path@ type. The +-- underlying representation of this type is a 'FilePath', and for that type we +-- know the encoding: It is a simple sequence of Unicode codepoints. So there is +-- are \"obivous\" 'FromJSON' and 'ToJSON' instances: We convert from/to a JSON +-- 'Data.Aeson.String'. +-- +-- The @OsPath.Path@ type however uses the types found in @System.OsPath@ of the +-- @filepath@ package. These filepaths are represented as a bunch of bytes with +-- no encoding information attached. That means that if a 'Path' is for example +-- passed to 'toJSON' as an argument it is not clear which representation JSON +-- we can choose for JSON. If the path was Unicode-encoded we could convert it +-- to a JSON 'Aeson.String' as before, but we cannot assume that anymore. +-- Hence there are no \"obvious\" 'FromJSON' and 'ToJSON' for 'Path'. +-- +-- __What this module provides:__ +-- This module defines functions and types suitable to convert a 'Path' from\/to +-- two JSON representations: +-- +-- * The /binary/ representation encodes\/decodes a 'Path' as a sequence of +-- numbers in JSON, where each number represents the numeric encoding of one +-- PLATFORM_CHAR_SINGLE of the underlying PLATFORM_PATH_SINGLE: +-- +-- >>> Data.Aeson.encode (relFileAsBinary [relfile|foo/bar|]) +-- "[102,111,111,92,98,97,114]" +-- +-- Note that this is a total encoding since every PLATFORM_PATH_SINGLE can +-- be represented as a bytestring and vice versa. +-- +-- * The /textual/ representation tries to encode\/decode a 'Path' as a string +-- in JSON. In order to do that we also have to provide an encoding. +-- +-- Some functions in this module take a 'System.IO.TextEncoding' as an +-- argument and you use those defined in "System.IO" or +-- "System.OsString.Encoding": +-- +-- >>> Data.Aeson.encode (relFileAsTextWith unicode [relfile|foo/bar|]) +-- "\"foo/bar\"" +-- +-- Other functions expect that the encoding is passed on the type-level +-- (you need the @TypeApplications@ language extensions for this to work): +-- +-- >>> Data.Aeson.encode (relFileAsText @Unicode [relfile|foo/bar|]) +-- "\"foo/bar\"" +-- +-- This module provides the encoding types 'Utf8', 'Utf16LE' and 'Unicode', +-- where the latter one of the former two dependenting on the platform. +-- +-- __WARNING:__ Decoding and encoding may fail with a +-- 'System.OsPath.EncodingException'! +-- The examples above work because 'relfile' encodes to the proper Unicode +-- encoding for the particular platform. module OsPath.Aeson.PLATFORM_NAME - ( AsBinary(..) + ( -- * Conversion functions + + -- ** Binary representation + -- $binary-rep + + -- *** From JSON + absDirFromBinary + , absFileFromBinary + , relDirFromBinary + , relFileFromBinary + , someDirFromBinary + , someFileFromBinary + + -- *** To JSON + , pathToBinary + , absDirToBinary + , absFileToBinary + , relDirToBinary + , relFileToBinary + , someBaseToBinary + , someDirToBinary + , someFileToBinary + + -- ** Textual representation + -- $textual-rep + + -- *** From JSON + , pathFromText + , pathFromTextWith + , absDirFromText + , absFileFromText + , relDirFromText + , relFileFromText + , someBaseFromText + , someBaseFromTextWith + , someDirFromText + , someFileFromText + + -- *** To JSON + , pathToText + , pathToTextWith + , absDirToText + , absFileToText + , relDirToText + , relFileToText + , someBaseToText + , someBaseToTextWith + , someDirToText + , someFileToText + + -- * Conversion using newtype wrappers + -- $newtype-wrappers + , AsBinary(..) , AsText(..) + + -- * Text encodings , IsTextEncoding , Unicode , Utf8 , Utf16LE + , unicode ) where import Control.Exception (displayException) +import Control.Monad ((<=<)) import Control.Monad.Catch (MonadThrow) import Data.Aeson (FromJSON (..), FromJSONKey (..), ToJSON (..), ToJSONKey (..)) -import Data.Aeson.Types (Parser, Value) +import Data.Aeson.Types (Encoding, Parser, Value) import qualified Data.Aeson.Types as Aeson import Data.Coerce (coerce) import Data.Functor.Contravariant import Data.Text (Text) import qualified Data.Text as Text import Data.Word (PLATFORM_WORD) +import System.IO import System.OsPath.PLATFORM_NAME (PLATFORM_PATH) import qualified System.OsPath.PLATFORM_NAME as OsPath import System.OsString.Internal.Types (PLATFORM_CHAR(..)) @@ -44,70 +159,306 @@ import OsPath.PLATFORM_NAME import OsPath.Aeson.Internal import OsPath.Internal.PLATFORM_NAME +-------------------------------------------------------------------------------- +-- Conversion functions +-------------------------------------------------------------------------------- + +unicode :: TextEncoding +#if IS_WINDOWS +unicode = utf16le +#else +unicode = utf8 +#endif + + ---------------------------------------- + -- Functions for PLATFORM_PATH + ---------------------------------------- + +platformPathFromBinary :: Value -> Parser PLATFORM_PATH +platformPathFromBinary value = + OsPath.pack . coerce @[PLATFORM_WORD] @[PLATFORM_CHAR] <$> parseJSON value +{-# INLINE platformPathFromBinary #-} + +platformPathFromText :: forall enc . IsTextEncoding enc + => Value + -> Parser PLATFORM_PATH +platformPathFromText = platformPathFromTextWith (textEncoding @enc) +{-# INLINE platformPathFromText #-} + +platformPathFromTextWith :: TextEncoding + -> Value + -> Parser PLATFORM_PATH +platformPathFromTextWith enc = unsafeEncodeWith enc <=< parseJSON +{-# INLINE platformPathFromTextWith #-} + +platformPathToBinary :: PLATFORM_PATH -> Value +platformPathToBinary = + toJSON + . coerce @[PLATFORM_CHAR] @[PLATFORM_WORD] + . OsPath.unpack +{-# INLINE platformPathToBinary #-} + +platformPathToBinaryEncoding :: PLATFORM_PATH -> Encoding +platformPathToBinaryEncoding = + toEncoding + . coerce @[PLATFORM_CHAR] @[PLATFORM_WORD] + . OsPath.unpack +{-# INLINE platformPathToBinaryEncoding #-} + +platformPathToText :: forall enc . IsTextEncoding enc + => PLATFORM_PATH + -> Value +platformPathToText = platformPathToTextWith (textEncoding @enc) +{-# INLINE platformPathToText #-} + +platformPathToTextWith :: TextEncoding -> PLATFORM_PATH -> Value +platformPathToTextWith enc = toJSON . unsafeDecodeWith enc +{-# INLINE platformPathToTextWith #-} + +platformPathToTextEncoding :: forall enc . IsTextEncoding enc + => PLATFORM_PATH + -> Encoding +platformPathToTextEncoding = platformPathToTextEncodingWith (textEncoding @enc) +{-# INLINE platformPathToTextEncoding #-} + +platformPathToTextEncodingWith :: TextEncoding -> PLATFORM_PATH -> Encoding +platformPathToTextEncodingWith enc = toEncoding . unsafeDecodeWith enc +{-# INLINE platformPathToTextEncodingWith #-} + + ---------------------------------------- + -- Functions for Path + ---------------------------------------- + +absDirFromBinary :: Value -> Parser (Path Abs Dir) +absDirFromBinary = parseAsBinary parseAbsDir +{-# INLINE absDirFromBinary #-} + +absFileFromBinary :: Value -> Parser (Path Abs File) +absFileFromBinary = parseAsBinary parseAbsFile +{-# INLINE absFileFromBinary #-} + +relDirFromBinary :: Value -> Parser (Path Rel Dir) +relDirFromBinary = parseAsBinary parseRelDir +{-# INLINE relDirFromBinary #-} + +relFileFromBinary :: Value -> Parser (Path Rel File) +relFileFromBinary = parseAsBinary parseRelFile +{-# INLINE relFileFromBinary #-} + +pathFromText :: forall enc b t . IsTextEncoding enc + => (forall m . MonadThrow m => PLATFORM_PATH -> m (Path b t)) + -> Value + -> Parser (Path b t) +pathFromText = pathFromTextWith (textEncoding @enc) +{-# INLINE pathFromText #-} + +pathFromTextWith :: TextEncoding + -> (forall m . MonadThrow m => PLATFORM_PATH -> m (Path b t)) + -> Value + -> Parser (Path b t) +pathFromTextWith = parseTextWith +{-# INLINE pathFromTextWith #-} + +absDirFromText :: forall enc . IsTextEncoding enc + => Value + -> Parser (Path Abs Dir) +absDirFromText = pathFromText @enc parseAbsDir +{-# INLINE absDirFromText #-} + +absFileFromText :: forall enc . IsTextEncoding enc + => Value + -> Parser (Path Abs File) +absFileFromText = pathFromText @enc parseAbsFile +{-# INLINE absFileFromText #-} + +relDirFromText :: forall enc . IsTextEncoding enc + => Value + -> Parser (Path Rel Dir) +relDirFromText = pathFromText @enc parseRelDir +{-# INLINE relDirFromText #-} + +relFileFromText :: forall enc . IsTextEncoding enc + => Value + -> Parser (Path Rel File) +relFileFromText = pathFromText @enc parseRelFile +{-# INLINE relFileFromText #-} + +pathToBinary :: Path b t -> Value +pathToBinary = platformPathToBinary . toOsPath +{-# INLINE pathToBinary #-} + +absDirToBinary :: Path Abs Dir -> Value +absDirToBinary = pathToBinary +{-# INLINE absDirToBinary #-} + +absFileToBinary :: Path Abs File -> Value +absFileToBinary = pathToBinary +{-# INLINE absFileToBinary #-} + +relDirToBinary :: Path Rel Dir -> Value +relDirToBinary = pathToBinary +{-# INLINE relDirToBinary #-} + +relFileToBinary :: Path Rel File -> Value +relFileToBinary = pathToBinary +{-# INLINE relFileToBinary #-} + +pathToText :: forall enc b t . IsTextEncoding enc => Path b t -> Value +pathToText = platformPathToText @enc . toOsPath +{-# INLINE pathToText #-} + +pathToTextWith :: TextEncoding -> Path b t -> Value +pathToTextWith enc = platformPathToTextWith enc . toOsPath +{-# INLINE pathToTextWith #-} + +absDirToText :: forall enc . IsTextEncoding enc => Path Abs Dir -> Value +absDirToText = pathToText @enc +{-# INLINE absDirToText #-} + +absFileToText :: forall enc . IsTextEncoding enc => Path Abs File -> Value +absFileToText = pathToText @enc +{-# INLINE absFileToText #-} + +relDirToText :: forall enc . IsTextEncoding enc => Path Rel Dir -> Value +relDirToText = pathToText @enc +{-# INLINE relDirToText #-} + +relFileToText :: forall enc . IsTextEncoding enc => Path Rel File -> Value +relFileToText = pathToText @enc +{-# INLINE relFileToText #-} + + ---------------------------------------- + -- Functions for SomeBase + ---------------------------------------- + +someDirFromBinary :: Value -> Parser (SomeBase Dir) +someDirFromBinary = parseAsBinary parseSomeDir +{-# INLINE someDirFromBinary #-} + +someFileFromBinary :: Value -> Parser (SomeBase File) +someFileFromBinary = parseAsBinary parseSomeFile +{-# INLINE someFileFromBinary #-} + +someBaseFromText :: forall enc t . IsTextEncoding enc + => (forall m . MonadThrow m => PLATFORM_PATH -> m (SomeBase t)) + -> Value + -> Parser (SomeBase t) +someBaseFromText = someBaseFromTextWith (textEncoding @enc) +{-# INLINE someBaseFromText #-} + +someBaseFromTextWith :: TextEncoding + -> (forall m . MonadThrow m => PLATFORM_PATH -> m (SomeBase t)) + -> Value + -> Parser (SomeBase t) +someBaseFromTextWith = parseTextWith +{-# INLINE someBaseFromTextWith #-} + +someDirFromText :: forall enc . IsTextEncoding enc + => Value + -> Parser (SomeBase Dir) +someDirFromText = someBaseFromText @enc parseSomeDir +{-# INLINE someDirFromText #-} + +someFileFromText :: forall enc . IsTextEncoding enc + => Value + -> Parser (SomeBase File) +someFileFromText = someBaseFromText @enc parseSomeFile +{-# INLINE someFileFromText #-} + +someBaseToBinary :: SomeBase t -> Value +someBaseToBinary = platformPathToBinary . fromSomeBase +{-# INLINE someBaseToBinary #-} + +someDirToBinary :: SomeBase Dir -> Value +someDirToBinary = someBaseToBinary +{-# INLINE someDirToBinary #-} + +someFileToBinary :: SomeBase File -> Value +someFileToBinary = someBaseToBinary +{-# INLINE someFileToBinary #-} + +someBaseToText :: forall enc t . IsTextEncoding enc => SomeBase t -> Value +someBaseToText = platformPathToText @enc . fromSomeBase +{-# INLINE someBaseToText #-} + +someBaseToTextWith :: TextEncoding -> SomeBase t -> Value +someBaseToTextWith enc = platformPathToTextWith enc . fromSomeBase +{-# INLINE someBaseToTextWith #-} + +someDirToText :: forall enc . IsTextEncoding enc => SomeBase Dir -> Value +someDirToText = someBaseToText @enc +{-# INLINE someDirToText #-} + +someFileToText :: forall enc . IsTextEncoding enc => SomeBase Dir -> Value +someFileToText = someBaseToText @enc +{-# INLINE someFileToText #-} + -------------------------------------------------------------------------------- -- Default instances -------------------------------------------------------------------------------- -- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is -- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. -instance FromJSON (AsText (Path b t) Unicode) => FromJSON (Path b t) where - parseJSON = fmap (asText @(Path b t) @Unicode) . parseJSON - {-# INLINE parseJSON #-} +deriving via (AsText Unicode (Path b t)) instance FromJSON (AsText Unicode (Path b t)) => FromJSON (Path b t) -- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is -- PLATFORM_UTF_CODEC encoded. If encoding fails a runtime error will be thrown. -instance ToJSON (Path b t) where - toJSON = toJSON . AsText @(Path b t) @Unicode - {-# INLINE toJSON #-} -#if MIN_VERSION_aeson(0,10,0) - toEncoding = toEncoding . AsText @(Path b t) @Unicode - {-# INLINE toEncoding #-} -#endif +deriving via (AsText Unicode (Path b t)) instance ToJSON (AsText Unicode (Path b t)) => ToJSON (Path b t) -#if MIN_VERSION_aeson(1,0,0) -- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is -- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. -instance (FromJSON (AsText (Path b t) Unicode), FromJSONKey (AsText (Path b t) Unicode)) => FromJSONKey (Path b t) where - fromJSONKey = asText @(Path b t) @Unicode <$> fromJSONKey - {-# INLINE fromJSONKey #-} +deriving via (AsText Unicode (Path b t)) instance FromJSONKey (AsText Unicode (Path b t)) => FromJSONKey (Path b t) -- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is -- PLATFORM_UTF_CODEC encoded. If encoding fails a runtime error will be thrown. -instance ToJSONKey (Path b t) where - toJSONKey = AsText @(Path b t) @Unicode >$< toJSONKey - {-# INLINE toJSONKey #-} -#endif +deriving via (AsText Unicode (Path b t)) instance ToJSONKey (AsText Unicode (Path b t)) => ToJSONKey (Path b t) -instance FromJSON (AsText (SomeBase t) Unicode) => FromJSON (SomeBase t) where - parseJSON = fmap (asText @(SomeBase t) @Unicode) . parseJSON - {-# INLINE parseJSON #-} +-- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is +-- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. +deriving via (AsText Unicode (SomeBase t)) instance FromJSON (AsText Unicode (SomeBase t)) => FromJSON (SomeBase t) -instance ToJSON (SomeBase t) where - toJSON = toJSON . AsText @(SomeBase t) @Unicode - {-# INLINE toJSON #-} -#if MIN_VERSION_aeson(0,10,0) - toEncoding = toEncoding . AsText @(SomeBase t) @Unicode - {-# INLINE toEncoding #-} -#endif +-- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is +-- PLATFORM_UTF_CODEC encoded. If encoding fails a runtime error will be thrown. +deriving via (AsText Unicode (SomeBase t)) instance ToJSON (SomeBase t) -#if MIN_VERSION_aeson(1,0,0) -- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is -- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. -instance (FromJSON (AsText (SomeBase t) Unicode), FromJSONKey (AsText (SomeBase t) Unicode)) => FromJSONKey (SomeBase t) where - fromJSONKey = asText @(SomeBase t) @Unicode <$> fromJSONKey - {-# INLINE fromJSONKey #-} +deriving via (AsText Unicode (SomeBase t)) instance FromJSONKey (AsText Unicode (SomeBase t)) => FromJSONKey (SomeBase t) -- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is -- PLATFORM_UTF_CODEC encoded. If encoding fails a runtime error will be thrown. -instance ToJSONKey (SomeBase t) where - toJSONKey = AsText @(SomeBase t) @Unicode >$< toJSONKey - {-# INLINE toJSONKey #-} -#endif +deriving via (AsText Unicode (SomeBase t)) instance ToJSONKey (SomeBase t) -------------------------------------------------------------------------------- -- Instances for newtype wrappers -------------------------------------------------------------------------------- +-- $newtype-wrappers +-- This module defines two newtype wrappers to control the conversion between +-- JSON value and a 'Path': +-- +-- * 'AsBinary' represents a 'Path' as a sequence of PLATFORM_WORD_SINGLE in +-- JSON. For example: +-- +-- >>> Data.Aeson.encode (AsBinary [relfile|foo/bar|]) +-- "[102,111,111,92,98,97,114]" +-- +-- Note that this is a total encoding since every PLATFORM_PATH_SINGLE can be +-- represented as a byte array and vice versa. +-- +-- * 'AsText' tries to represent a 'Path' as a string in JSON. In order to do +-- that we also have to provide an encoding. Those are represented as by +-- 'Utf8', 'Utf16LE' and 'Unicode', where the latter is a type synonym for +-- 'Utf8' for POSIX paths and 'Utf16LE' for Windows paths. +-- Note that this may fail with a runtime error if the underlying +-- PLATFORM_PATH_SINGLE uses a different encoding! +-- Since 'relfile' uses a unicode encoding the previous example displays as +-- follows (you need the @TypeApplications@ language extensions for this to +-- work): +-- +-- >>> Data.Aeson.encode (AsText @Unicode [relfile|foo/bar|]) +-- "foo/bar" + #if IS_WINDOWS type Unicode = Utf16LE #else @@ -119,118 +470,80 @@ type Unicode = Utf8 ---------------------------------------- instance FromJSON (AsBinary PLATFORM_PATH) where - parseJSON value = - AsBinary . OsPath.pack . coerce @[PLATFORM_WORD] @[PLATFORM_CHAR] - <$> parseJSON value + parseJSON value = AsBinary <$> platformPathFromBinary value {-# INLINE parseJSON #-} -instance IsTextEncoding encoding => FromJSON (AsText PLATFORM_PATH encoding) where - parseJSON value = - either (fail . displayException) (pure . AsText) - . OsPath.encodeWith (textEncoding @encoding) - =<< parseJSON value +instance IsTextEncoding enc => FromJSON (AsText enc PLATFORM_PATH) where + parseJSON value = AsText <$> platformPathFromText @enc value {-# INLINE parseJSON #-} instance ToJSON (AsBinary PLATFORM_PATH) where - toJSON = - toJSON - . coerce @[PLATFORM_CHAR] @[PLATFORM_WORD] - . OsPath.unpack - . asBinary + toJSON = platformPathToBinary . asBinary {-# INLINE toJSON #-} -#if MIN_VERSION_aeson(0,10,0) - toEncoding = - toEncoding - . coerce @[PLATFORM_CHAR] @[PLATFORM_WORD] - . OsPath.unpack - . asBinary + toEncoding = platformPathToBinaryEncoding . asBinary {-# INLINE toEncoding #-} -#endif -instance IsTextEncoding encoding => ToJSON (AsText PLATFORM_PATH encoding) where - toJSON = - either (error . displayException) toJSON - . OsPath.decodeWith (textEncoding @encoding) - . asText +instance IsTextEncoding enc => ToJSON (AsText enc PLATFORM_PATH) where + toJSON = platformPathToText @enc . asText {-# INLINE toJSON #-} -#if MIN_VERSION_aeson(0,10,0) - toEncoding = - either (error . displayException) toEncoding - . OsPath.decodeWith (textEncoding @encoding) - . asText + toEncoding = platformPathToTextEncoding @enc . asText {-# INLINE toEncoding #-} -#endif -#if MIN_VERSION_aeson(1,0,0) instance FromJSONKey (AsBinary PLATFORM_PATH) where fromJSONKey = Aeson.FromJSONKeyValue parseJSON {-# INLINE fromJSONKey #-} -instance IsTextEncoding encoding => FromJSONKey (AsText PLATFORM_PATH encoding) where - fromJSONKey = Aeson.FromJSONKeyTextParser - ( either (fail . displayException) (pure . AsText) - . OsPath.encodeWith (textEncoding @encoding) - . Text.unpack - ) +instance IsTextEncoding enc => FromJSONKey (AsText enc PLATFORM_PATH) where + fromJSONKey = Aeson.FromJSONKeyTextParser (parseKeyAsText pure) {-# INLINE fromJSONKey #-} instance ToJSONKey (AsBinary PLATFORM_PATH) where toJSONKey = Aeson.ToJSONKeyValue toJSON toEncoding {-# INLINE toJSONKey #-} -instance IsTextEncoding encoding => ToJSONKey (AsText PLATFORM_PATH encoding) where +instance IsTextEncoding enc => ToJSONKey (AsText enc PLATFORM_PATH) where toJSONKey = Aeson.toJSONKeyText decodeAsText {-# INLINE toJSONKey #-} -decodeAsText :: forall encoding . - IsTextEncoding encoding => AsText PLATFORM_PATH encoding -> Text -decodeAsText = - either (error . displayException) Text.pack - . OsPath.decodeWith (textEncoding @encoding) - . asText -{-# INLINE decodeAsText #-} -#endif - ---------------------------------------- -- Instances for Path ---------------------------------------- instance FromJSON (AsBinary (Path Abs Dir)) where - parseJSON = parseAsBinary parseAbsDir + parseJSON value = AsBinary <$> absDirFromBinary value {-# INLINE parseJSON #-} instance FromJSON (AsBinary (Path Abs File)) where - parseJSON = parseAsBinary parseAbsFile + parseJSON value = AsBinary <$> absFileFromBinary value {-# INLINE parseJSON #-} instance FromJSON (AsBinary (Path Rel Dir)) where - parseJSON = parseAsBinary parseRelDir + parseJSON value = AsBinary <$> relDirFromBinary value {-# INLINE parseJSON #-} instance FromJSON (AsBinary (Path Rel File)) where - parseJSON = parseAsBinary parseRelFile + parseJSON value = AsBinary <$> relFileFromBinary value {-# INLINE parseJSON #-} -instance IsTextEncoding encoding => FromJSON (AsText (Path Abs Dir) encoding) where - parseJSON = parseAsText parseAbsDir +instance IsTextEncoding enc => FromJSON (AsText enc (Path Abs Dir)) where + parseJSON value = AsText <$> absDirFromText @enc value {-# INLINE parseJSON #-} -instance IsTextEncoding encoding => FromJSON (AsText (Path Abs File) encoding) where - parseJSON = parseAsText parseAbsFile +instance IsTextEncoding enc => FromJSON (AsText enc (Path Abs File)) where + parseJSON value = AsText <$> absFileFromText @enc value {-# INLINE parseJSON #-} -instance IsTextEncoding encoding => FromJSON (AsText (Path Rel Dir) encoding) where - parseJSON = parseAsText parseRelDir +instance IsTextEncoding enc => FromJSON (AsText enc (Path Rel Dir)) where + parseJSON value = AsText <$> relDirFromText @enc value {-# INLINE parseJSON #-} -instance IsTextEncoding encoding => FromJSON (AsText (Path Rel File) encoding) where - parseJSON = parseAsText parseRelFile +instance IsTextEncoding enc => FromJSON (AsText enc (Path Rel File)) where + parseJSON value = AsText <$> relFileFromText @enc value {-# INLINE parseJSON #-} deriving via (AsBinary PLATFORM_PATH) instance ToJSON (AsBinary (Path b t)) -deriving via (AsText PLATFORM_PATH encoding) instance IsTextEncoding encoding => ToJSON (AsText (Path b t) encoding) +deriving via (AsText enc PLATFORM_PATH) instance IsTextEncoding enc => ToJSON (AsText enc (Path b t)) -#if MIN_VERSION_aeson(1,0,0) instance FromJSONKey (AsBinary (Path Abs Dir)) where fromJSONKey = Aeson.FromJSONKeyValue parseJSON {-# INLINE fromJSONKey #-} @@ -247,108 +560,121 @@ instance FromJSONKey (AsBinary (Path Rel File)) where fromJSONKey = Aeson.FromJSONKeyValue parseJSON {-# INLINE fromJSONKey #-} -instance IsTextEncoding encoding => FromJSONKey (AsText (Path Abs Dir) encoding) where +instance IsTextEncoding enc => FromJSONKey (AsText enc (Path Abs Dir)) where fromJSONKey = Aeson.FromJSONKeyTextParser (parseKeyAsText parseAbsDir) {-# INLINE fromJSONKey #-} -instance IsTextEncoding encoding => FromJSONKey (AsText (Path Abs File) encoding) where +instance IsTextEncoding enc => FromJSONKey (AsText enc (Path Abs File)) where fromJSONKey = Aeson.FromJSONKeyTextParser (parseKeyAsText parseAbsFile) {-# INLINE fromJSONKey #-} -instance IsTextEncoding encoding => FromJSONKey (AsText (Path Rel Dir) encoding) where +instance IsTextEncoding enc => FromJSONKey (AsText enc (Path Rel Dir)) where fromJSONKey = Aeson.FromJSONKeyTextParser (parseKeyAsText parseRelDir) {-# INLINE fromJSONKey #-} -instance IsTextEncoding encoding => FromJSONKey (AsText (Path Rel File) encoding) where +instance IsTextEncoding enc => FromJSONKey (AsText enc (Path Rel File)) where fromJSONKey = Aeson.FromJSONKeyTextParser (parseKeyAsText parseRelFile) {-# INLINE fromJSONKey #-} deriving via (AsBinary PLATFORM_PATH) instance ToJSONKey (AsBinary (Path b t)) -deriving via (AsText PLATFORM_PATH encoding) instance IsTextEncoding encoding => ToJSONKey (AsText (Path b t) encoding) -#endif +deriving via (AsText enc PLATFORM_PATH) instance IsTextEncoding enc => ToJSONKey (AsText enc (Path b t)) ---------------------------------------- -- Instances for SomeBase ---------------------------------------- instance FromJSON (AsBinary (SomeBase Dir)) where - parseJSON = parseAsBinary parseSomeDir + parseJSON value = AsBinary <$> someDirFromBinary value {-# INLINE parseJSON #-} instance FromJSON (AsBinary (SomeBase File)) where - parseJSON = parseAsBinary parseSomeFile + parseJSON value = AsBinary <$> someFileFromBinary value {-# INLINE parseJSON #-} -instance IsTextEncoding encoding => FromJSON (AsText (SomeBase Dir) encoding) where - parseJSON = parseAsText parseSomeDir +instance IsTextEncoding enc => FromJSON (AsText enc (SomeBase Dir)) where + parseJSON value = AsText <$> someDirFromText @enc value {-# INLINE parseJSON #-} -instance IsTextEncoding encoding => FromJSON (AsText (SomeBase File) encoding) where - parseJSON = parseAsText parseSomeFile +instance IsTextEncoding enc => FromJSON (AsText enc (SomeBase File)) where + parseJSON value = AsText <$> someFileFromText @enc value {-# INLINE parseJSON #-} instance ToJSON (AsBinary (SomeBase t)) where - toJSON = prjSomeBase (toJSON . AsBinary) . asBinary + toJSON = toJSON . fmap fromSomeBase {-# INLINE toJSON #-} -#if MIN_VERSION_aeson(0,10,0) - toEncoding = prjSomeBase (toEncoding . AsBinary) . asBinary + toEncoding = toEncoding . fmap fromSomeBase {-# INLINE toEncoding #-} -#endif -instance IsTextEncoding encoding => ToJSON (AsText (SomeBase t) encoding) where - toJSON = prjSomeBase (toJSON . AsText @_ @encoding) . asText +instance IsTextEncoding enc => ToJSON (AsText enc (SomeBase t)) where + toJSON = toJSON . fmap fromSomeBase {-# INLINE toJSON #-} -#if MIN_VERSION_aeson(0,10,0) - toEncoding = prjSomeBase (toEncoding . AsText @_ @encoding) . asText + toEncoding = toEncoding . fmap fromSomeBase {-# INLINE toEncoding #-} -#endif -#if MIN_VERSION_aeson(1,0,0) +instance FromJSONKey (AsBinary (SomeBase Dir)) where + fromJSONKey = Aeson.FromJSONKeyValue parseJSON + {-# INLINE fromJSONKey #-} + +instance FromJSONKey (AsBinary (SomeBase File)) where + fromJSONKey = Aeson.FromJSONKeyValue parseJSON + {-# INLINE fromJSONKey #-} + +instance IsTextEncoding enc => FromJSONKey (AsText enc (SomeBase Dir)) where + fromJSONKey = Aeson.FromJSONKeyTextParser (parseKeyAsText parseSomeDir) + {-# INLINE fromJSONKey #-} + +instance IsTextEncoding enc => FromJSONKey (AsText enc (SomeBase File)) where + fromJSONKey = Aeson.FromJSONKeyTextParser (parseKeyAsText parseSomeFile) + {-# INLINE fromJSONKey #-} + instance ToJSONKey (AsBinary (SomeBase t)) where toJSONKey = Aeson.ToJSONKeyValue toJSON toEncoding {-# INLINE toJSONKey #-} -instance IsTextEncoding encoding => ToJSONKey (AsText (SomeBase t) encoding) where - toJSONKey = Aeson.toJSONKeyText - ( prjSomeBase (decodeAsText . AsText @PLATFORM_PATH @encoding . toOsPath) - . asText - ) +instance IsTextEncoding enc => ToJSONKey (AsText enc (SomeBase t)) where + toJSONKey = fmap fromSomeBase >$< toJSONKey {-# INLINE toJSONKey #-} -#endif -------------------------------------------------------------------------------- -- Internal helpers -------------------------------------------------------------------------------- +unsafeDecodeWith :: TextEncoding -> PLATFORM_PATH -> String +unsafeDecodeWith enc = + either (error . displayException) id . OsPath.decodeWith enc +{-# INLINE unsafeDecodeWith #-} + +unsafeEncodeWith :: TextEncoding -> String -> Parser PLATFORM_PATH +unsafeEncodeWith enc = + either (fail . displayException) pure . OsPath.encodeWith enc +{-# INLINE unsafeEncodeWith #-} + +decodeAsText :: forall enc . IsTextEncoding enc + => AsText enc PLATFORM_PATH + -> Text +decodeAsText = Text.pack . unsafeDecodeWith (textEncoding @enc) . asText +{-# INLINE decodeAsText #-} + parseAsBinary :: (forall m . MonadThrow m => PLATFORM_PATH -> m a) -> Value - -> Parser (AsBinary a) -parseAsBinary parse value = - either (fail . displayException) (pure . AsBinary) - . parse - . asBinary - =<< parseJSON value + -> Parser a +parseAsBinary parse = + either (fail . displayException) pure . parse <=< platformPathFromBinary {-# INLINE parseAsBinary #-} -parseAsText :: forall encoding a . IsTextEncoding encoding - => (forall m . MonadThrow m => PLATFORM_PATH -> m a) - -> Value - -> Parser (AsText a encoding) -parseAsText parse value = - either (fail . displayException) (pure . AsText) - . parse - . asText @_ @encoding - =<< parseJSON value -{-# INLINE parseAsText #-} - -parseKeyAsText :: forall encoding a . IsTextEncoding encoding +parseTextWith :: TextEncoding + -> (forall m . MonadThrow m => PLATFORM_PATH -> m a) + -> Value + -> Parser a +parseTextWith enc parse = + either (fail . displayException) pure . parse <=< platformPathFromTextWith enc +{-# INLINE parseTextWith #-} + +parseKeyAsText :: forall enc a . IsTextEncoding enc => (forall m . MonadThrow m => PLATFORM_PATH -> m a) -> Text - -> Parser (AsText a encoding) -parseKeyAsText parse text = do - ospath <- either (fail . displayException) pure - . OsPath.encodeWith (textEncoding @encoding) - . Text.unpack - $ text - either (fail . displayException) (pure . AsText) (parse ospath) + -> Parser (AsText enc a) +parseKeyAsText parse = + either (fail . displayException) (pure . AsText) . parse + <=< unsafeEncodeWith (textEncoding @enc) . Text.unpack {-# INLINE parseKeyAsText #-} diff --git a/src/OsPath/Aeson/Internal.hs b/src/OsPath/Aeson/Internal.hs index fc07e5d..6c4f96a 100644 --- a/src/OsPath/Aeson/Internal.hs +++ b/src/OsPath/Aeson/Internal.hs @@ -1,12 +1,15 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveTraversable #-} module OsPath.Aeson.Internal where -import System.IO +import System.IO (TextEncoding, utf8, utf16le) -newtype AsBinary path = AsBinary { asBinary :: path } +newtype AsBinary a = AsBinary { asBinary :: a } + deriving (Foldable, Functor, Traversable) -newtype AsText path encoding = AsText { asText :: path } +newtype AsText encoding a = AsText { asText :: a } + deriving (Foldable, Functor, Traversable) class IsTextEncoding a where textEncoding :: TextEncoding @@ -15,8 +18,10 @@ data Utf8 instance IsTextEncoding Utf8 where textEncoding = utf8 + {-# INLINE textEncoding #-} data Utf16LE instance IsTextEncoding Utf16LE where textEncoding = utf16le + {-# INLINE textEncoding #-} diff --git a/src/OsPath/Aeson/Posix.hs b/src/OsPath/Aeson/Posix.hs index f4949a5..1a84017 100644 --- a/src/OsPath/Aeson/Posix.hs +++ b/src/OsPath/Aeson/Posix.hs @@ -3,7 +3,9 @@ #define PLATFORM_PATH PosixPath #define PLATFORM_PATH_SINGLE 'PosixPath' #define PLATFORM_CHAR PosixChar +#define PLATFORM_CHAR_SINGLE 'PosixChar' #define PLATFORM_WORD Word8 +#define PLATFORM_WORD_SINGLE 'Word8' #define PLATFORM_UTF_CODEC UTF8 #define IS_WINDOWS 0 #include "Include.hs" diff --git a/src/OsPath/Aeson/Windows.hs b/src/OsPath/Aeson/Windows.hs index fd3a762..57b54b8 100644 --- a/src/OsPath/Aeson/Windows.hs +++ b/src/OsPath/Aeson/Windows.hs @@ -3,7 +3,9 @@ #define PLATFORM_PATH WindowsPath #define PLATFORM_PATH_SINGLE 'WindowsPath' #define PLATFORM_CHAR WindowsChar +#define PLATFORM_CHAR_SINGLE 'WindowsChar' #define PLATFORM_WORD Word16 +#define PLATFORM_WORD_SINGLE 'Word16' #define PLATFORM_UTF_CODEC UTF16-LE #define IS_WINDOWS 1 #include "Include.hs" diff --git a/src/OsPath/Include.hs b/src/OsPath/Include.hs index 7eb6bf5..8e75c0a 100644 --- a/src/OsPath/Include.hs +++ b/src/OsPath/Include.hs @@ -82,6 +82,7 @@ module OsPath.PLATFORM_NAME ,fromRelDir ,fromAbsFile ,fromRelFile + ,fromSomeBase ,fromSomeDir ,fromSomeFile -- * TemplateHaskell constructors From db0807f1ba06d091633947cecba423f05ab95acf Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Sun, 14 Jul 2024 15:43:00 +0200 Subject: [PATCH 37/52] Removed Aeson instances for OsPath --- path.cabal | 5 - src/OsPath/Aeson.hs | 10 - src/OsPath/Aeson/Include.hs | 680 ---------------------------------- src/OsPath/Aeson/Internal.hs | 27 -- src/OsPath/Aeson/Posix.hs | 11 - src/OsPath/Aeson/Windows.hs | 11 - test-ospath/Common/Include.hs | 1 - test-ospath/Posix.hs | 16 - test-ospath/Windows.hs | 16 - 9 files changed, 777 deletions(-) delete mode 100644 src/OsPath/Aeson.hs delete mode 100644 src/OsPath/Aeson/Include.hs delete mode 100644 src/OsPath/Aeson/Internal.hs delete mode 100644 src/OsPath/Aeson/Posix.hs delete mode 100644 src/OsPath/Aeson/Windows.hs diff --git a/path.cabal b/path.cabal index 0954fbe..e8a2667 100644 --- a/path.cabal +++ b/path.cabal @@ -15,7 +15,6 @@ extra-source-files: README.md , CHANGELOG , src/Path/Include.hs , src/Path/Internal/Include.hs - , src/OsPath/Aeson/Include.hs , src/OsPath/Include.hs , src/OsPath/Internal/Include.hs , test/Common/Include.hs @@ -37,10 +36,6 @@ library , Path.Internal.Posix , Path.Internal.Windows , OsPath - , OsPath.Aeson - , OsPath.Aeson.Internal - , OsPath.Aeson.Posix - , OsPath.Aeson.Windows , OsPath.Posix , OsPath.Windows , OsPath.Internal diff --git a/src/OsPath/Aeson.hs b/src/OsPath/Aeson.hs deleted file mode 100644 index d65ea30..0000000 --- a/src/OsPath/Aeson.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wno-dodgy-exports #-} - -#if defined(mingw32_HOST_OS) -module OsPath.Aeson(module OsPath.Aeson.Windows) where -import OsPath.Aeson.Windows () -#else -module OsPath.Aeson(module OsPath.Aeson.Posix) where -import OsPath.Aeson.Posix () -#endif diff --git a/src/OsPath/Aeson/Include.hs b/src/OsPath/Aeson/Include.hs deleted file mode 100644 index 42797b2..0000000 --- a/src/OsPath/Aeson/Include.hs +++ /dev/null @@ -1,680 +0,0 @@ --- This template expects CPP definitions for: --- PLATFORM_NAME = Posix | Windows --- PLATFORM_PATH = PosixPath | WindowsPath --- PLATFORM_PATH_SINGLE = 'PosixPath' | 'WindowsPath' --- PLATFORM_CHAR = PosixChar | WindowsChar --- PLATFORM_CHAR_SINGLE = 'PosixChar' | 'WindowsChar' --- PLATFORM_WORD = Word8 | Word16 --- PLATFORM_WORD_SINGLE = 'Word8' | 'Word16' --- PLATFORM_UTF_CODEC = UTF8 | UTF16-LE --- IS_WINDOWS = 0 | 1 - -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} - --- | This module provides the necessary tools to decode\/encode a 'Path' --- from\/to a 'Value'. --- --- __Background:__ --- In earlier versions of this library there was only the @Path.Path@ type. The --- underlying representation of this type is a 'FilePath', and for that type we --- know the encoding: It is a simple sequence of Unicode codepoints. So there is --- are \"obivous\" 'FromJSON' and 'ToJSON' instances: We convert from/to a JSON --- 'Data.Aeson.String'. --- --- The @OsPath.Path@ type however uses the types found in @System.OsPath@ of the --- @filepath@ package. These filepaths are represented as a bunch of bytes with --- no encoding information attached. That means that if a 'Path' is for example --- passed to 'toJSON' as an argument it is not clear which representation JSON --- we can choose for JSON. If the path was Unicode-encoded we could convert it --- to a JSON 'Aeson.String' as before, but we cannot assume that anymore. --- Hence there are no \"obvious\" 'FromJSON' and 'ToJSON' for 'Path'. --- --- __What this module provides:__ --- This module defines functions and types suitable to convert a 'Path' from\/to --- two JSON representations: --- --- * The /binary/ representation encodes\/decodes a 'Path' as a sequence of --- numbers in JSON, where each number represents the numeric encoding of one --- PLATFORM_CHAR_SINGLE of the underlying PLATFORM_PATH_SINGLE: --- --- >>> Data.Aeson.encode (relFileAsBinary [relfile|foo/bar|]) --- "[102,111,111,92,98,97,114]" --- --- Note that this is a total encoding since every PLATFORM_PATH_SINGLE can --- be represented as a bytestring and vice versa. --- --- * The /textual/ representation tries to encode\/decode a 'Path' as a string --- in JSON. In order to do that we also have to provide an encoding. --- --- Some functions in this module take a 'System.IO.TextEncoding' as an --- argument and you use those defined in "System.IO" or --- "System.OsString.Encoding": --- --- >>> Data.Aeson.encode (relFileAsTextWith unicode [relfile|foo/bar|]) --- "\"foo/bar\"" --- --- Other functions expect that the encoding is passed on the type-level --- (you need the @TypeApplications@ language extensions for this to work): --- --- >>> Data.Aeson.encode (relFileAsText @Unicode [relfile|foo/bar|]) --- "\"foo/bar\"" --- --- This module provides the encoding types 'Utf8', 'Utf16LE' and 'Unicode', --- where the latter one of the former two dependenting on the platform. --- --- __WARNING:__ Decoding and encoding may fail with a --- 'System.OsPath.EncodingException'! --- The examples above work because 'relfile' encodes to the proper Unicode --- encoding for the particular platform. -module OsPath.Aeson.PLATFORM_NAME - ( -- * Conversion functions - - -- ** Binary representation - -- $binary-rep - - -- *** From JSON - absDirFromBinary - , absFileFromBinary - , relDirFromBinary - , relFileFromBinary - , someDirFromBinary - , someFileFromBinary - - -- *** To JSON - , pathToBinary - , absDirToBinary - , absFileToBinary - , relDirToBinary - , relFileToBinary - , someBaseToBinary - , someDirToBinary - , someFileToBinary - - -- ** Textual representation - -- $textual-rep - - -- *** From JSON - , pathFromText - , pathFromTextWith - , absDirFromText - , absFileFromText - , relDirFromText - , relFileFromText - , someBaseFromText - , someBaseFromTextWith - , someDirFromText - , someFileFromText - - -- *** To JSON - , pathToText - , pathToTextWith - , absDirToText - , absFileToText - , relDirToText - , relFileToText - , someBaseToText - , someBaseToTextWith - , someDirToText - , someFileToText - - -- * Conversion using newtype wrappers - -- $newtype-wrappers - , AsBinary(..) - , AsText(..) - - -- * Text encodings - , IsTextEncoding - , Unicode - , Utf8 - , Utf16LE - , unicode - ) where - -import Control.Exception (displayException) -import Control.Monad ((<=<)) -import Control.Monad.Catch (MonadThrow) -import Data.Aeson (FromJSON (..), FromJSONKey (..), ToJSON (..), ToJSONKey (..)) -import Data.Aeson.Types (Encoding, Parser, Value) -import qualified Data.Aeson.Types as Aeson -import Data.Coerce (coerce) -import Data.Functor.Contravariant -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Word (PLATFORM_WORD) -import System.IO -import System.OsPath.PLATFORM_NAME (PLATFORM_PATH) -import qualified System.OsPath.PLATFORM_NAME as OsPath -import System.OsString.Internal.Types (PLATFORM_CHAR(..)) - -import OsPath.PLATFORM_NAME -import OsPath.Aeson.Internal -import OsPath.Internal.PLATFORM_NAME - --------------------------------------------------------------------------------- --- Conversion functions --------------------------------------------------------------------------------- - -unicode :: TextEncoding -#if IS_WINDOWS -unicode = utf16le -#else -unicode = utf8 -#endif - - ---------------------------------------- - -- Functions for PLATFORM_PATH - ---------------------------------------- - -platformPathFromBinary :: Value -> Parser PLATFORM_PATH -platformPathFromBinary value = - OsPath.pack . coerce @[PLATFORM_WORD] @[PLATFORM_CHAR] <$> parseJSON value -{-# INLINE platformPathFromBinary #-} - -platformPathFromText :: forall enc . IsTextEncoding enc - => Value - -> Parser PLATFORM_PATH -platformPathFromText = platformPathFromTextWith (textEncoding @enc) -{-# INLINE platformPathFromText #-} - -platformPathFromTextWith :: TextEncoding - -> Value - -> Parser PLATFORM_PATH -platformPathFromTextWith enc = unsafeEncodeWith enc <=< parseJSON -{-# INLINE platformPathFromTextWith #-} - -platformPathToBinary :: PLATFORM_PATH -> Value -platformPathToBinary = - toJSON - . coerce @[PLATFORM_CHAR] @[PLATFORM_WORD] - . OsPath.unpack -{-# INLINE platformPathToBinary #-} - -platformPathToBinaryEncoding :: PLATFORM_PATH -> Encoding -platformPathToBinaryEncoding = - toEncoding - . coerce @[PLATFORM_CHAR] @[PLATFORM_WORD] - . OsPath.unpack -{-# INLINE platformPathToBinaryEncoding #-} - -platformPathToText :: forall enc . IsTextEncoding enc - => PLATFORM_PATH - -> Value -platformPathToText = platformPathToTextWith (textEncoding @enc) -{-# INLINE platformPathToText #-} - -platformPathToTextWith :: TextEncoding -> PLATFORM_PATH -> Value -platformPathToTextWith enc = toJSON . unsafeDecodeWith enc -{-# INLINE platformPathToTextWith #-} - -platformPathToTextEncoding :: forall enc . IsTextEncoding enc - => PLATFORM_PATH - -> Encoding -platformPathToTextEncoding = platformPathToTextEncodingWith (textEncoding @enc) -{-# INLINE platformPathToTextEncoding #-} - -platformPathToTextEncodingWith :: TextEncoding -> PLATFORM_PATH -> Encoding -platformPathToTextEncodingWith enc = toEncoding . unsafeDecodeWith enc -{-# INLINE platformPathToTextEncodingWith #-} - - ---------------------------------------- - -- Functions for Path - ---------------------------------------- - -absDirFromBinary :: Value -> Parser (Path Abs Dir) -absDirFromBinary = parseAsBinary parseAbsDir -{-# INLINE absDirFromBinary #-} - -absFileFromBinary :: Value -> Parser (Path Abs File) -absFileFromBinary = parseAsBinary parseAbsFile -{-# INLINE absFileFromBinary #-} - -relDirFromBinary :: Value -> Parser (Path Rel Dir) -relDirFromBinary = parseAsBinary parseRelDir -{-# INLINE relDirFromBinary #-} - -relFileFromBinary :: Value -> Parser (Path Rel File) -relFileFromBinary = parseAsBinary parseRelFile -{-# INLINE relFileFromBinary #-} - -pathFromText :: forall enc b t . IsTextEncoding enc - => (forall m . MonadThrow m => PLATFORM_PATH -> m (Path b t)) - -> Value - -> Parser (Path b t) -pathFromText = pathFromTextWith (textEncoding @enc) -{-# INLINE pathFromText #-} - -pathFromTextWith :: TextEncoding - -> (forall m . MonadThrow m => PLATFORM_PATH -> m (Path b t)) - -> Value - -> Parser (Path b t) -pathFromTextWith = parseTextWith -{-# INLINE pathFromTextWith #-} - -absDirFromText :: forall enc . IsTextEncoding enc - => Value - -> Parser (Path Abs Dir) -absDirFromText = pathFromText @enc parseAbsDir -{-# INLINE absDirFromText #-} - -absFileFromText :: forall enc . IsTextEncoding enc - => Value - -> Parser (Path Abs File) -absFileFromText = pathFromText @enc parseAbsFile -{-# INLINE absFileFromText #-} - -relDirFromText :: forall enc . IsTextEncoding enc - => Value - -> Parser (Path Rel Dir) -relDirFromText = pathFromText @enc parseRelDir -{-# INLINE relDirFromText #-} - -relFileFromText :: forall enc . IsTextEncoding enc - => Value - -> Parser (Path Rel File) -relFileFromText = pathFromText @enc parseRelFile -{-# INLINE relFileFromText #-} - -pathToBinary :: Path b t -> Value -pathToBinary = platformPathToBinary . toOsPath -{-# INLINE pathToBinary #-} - -absDirToBinary :: Path Abs Dir -> Value -absDirToBinary = pathToBinary -{-# INLINE absDirToBinary #-} - -absFileToBinary :: Path Abs File -> Value -absFileToBinary = pathToBinary -{-# INLINE absFileToBinary #-} - -relDirToBinary :: Path Rel Dir -> Value -relDirToBinary = pathToBinary -{-# INLINE relDirToBinary #-} - -relFileToBinary :: Path Rel File -> Value -relFileToBinary = pathToBinary -{-# INLINE relFileToBinary #-} - -pathToText :: forall enc b t . IsTextEncoding enc => Path b t -> Value -pathToText = platformPathToText @enc . toOsPath -{-# INLINE pathToText #-} - -pathToTextWith :: TextEncoding -> Path b t -> Value -pathToTextWith enc = platformPathToTextWith enc . toOsPath -{-# INLINE pathToTextWith #-} - -absDirToText :: forall enc . IsTextEncoding enc => Path Abs Dir -> Value -absDirToText = pathToText @enc -{-# INLINE absDirToText #-} - -absFileToText :: forall enc . IsTextEncoding enc => Path Abs File -> Value -absFileToText = pathToText @enc -{-# INLINE absFileToText #-} - -relDirToText :: forall enc . IsTextEncoding enc => Path Rel Dir -> Value -relDirToText = pathToText @enc -{-# INLINE relDirToText #-} - -relFileToText :: forall enc . IsTextEncoding enc => Path Rel File -> Value -relFileToText = pathToText @enc -{-# INLINE relFileToText #-} - - ---------------------------------------- - -- Functions for SomeBase - ---------------------------------------- - -someDirFromBinary :: Value -> Parser (SomeBase Dir) -someDirFromBinary = parseAsBinary parseSomeDir -{-# INLINE someDirFromBinary #-} - -someFileFromBinary :: Value -> Parser (SomeBase File) -someFileFromBinary = parseAsBinary parseSomeFile -{-# INLINE someFileFromBinary #-} - -someBaseFromText :: forall enc t . IsTextEncoding enc - => (forall m . MonadThrow m => PLATFORM_PATH -> m (SomeBase t)) - -> Value - -> Parser (SomeBase t) -someBaseFromText = someBaseFromTextWith (textEncoding @enc) -{-# INLINE someBaseFromText #-} - -someBaseFromTextWith :: TextEncoding - -> (forall m . MonadThrow m => PLATFORM_PATH -> m (SomeBase t)) - -> Value - -> Parser (SomeBase t) -someBaseFromTextWith = parseTextWith -{-# INLINE someBaseFromTextWith #-} - -someDirFromText :: forall enc . IsTextEncoding enc - => Value - -> Parser (SomeBase Dir) -someDirFromText = someBaseFromText @enc parseSomeDir -{-# INLINE someDirFromText #-} - -someFileFromText :: forall enc . IsTextEncoding enc - => Value - -> Parser (SomeBase File) -someFileFromText = someBaseFromText @enc parseSomeFile -{-# INLINE someFileFromText #-} - -someBaseToBinary :: SomeBase t -> Value -someBaseToBinary = platformPathToBinary . fromSomeBase -{-# INLINE someBaseToBinary #-} - -someDirToBinary :: SomeBase Dir -> Value -someDirToBinary = someBaseToBinary -{-# INLINE someDirToBinary #-} - -someFileToBinary :: SomeBase File -> Value -someFileToBinary = someBaseToBinary -{-# INLINE someFileToBinary #-} - -someBaseToText :: forall enc t . IsTextEncoding enc => SomeBase t -> Value -someBaseToText = platformPathToText @enc . fromSomeBase -{-# INLINE someBaseToText #-} - -someBaseToTextWith :: TextEncoding -> SomeBase t -> Value -someBaseToTextWith enc = platformPathToTextWith enc . fromSomeBase -{-# INLINE someBaseToTextWith #-} - -someDirToText :: forall enc . IsTextEncoding enc => SomeBase Dir -> Value -someDirToText = someBaseToText @enc -{-# INLINE someDirToText #-} - -someFileToText :: forall enc . IsTextEncoding enc => SomeBase Dir -> Value -someFileToText = someBaseToText @enc -{-# INLINE someFileToText #-} - --------------------------------------------------------------------------------- --- Default instances --------------------------------------------------------------------------------- - --- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is --- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. -deriving via (AsText Unicode (Path b t)) instance FromJSON (AsText Unicode (Path b t)) => FromJSON (Path b t) - --- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is --- PLATFORM_UTF_CODEC encoded. If encoding fails a runtime error will be thrown. -deriving via (AsText Unicode (Path b t)) instance ToJSON (AsText Unicode (Path b t)) => ToJSON (Path b t) - --- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is --- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. -deriving via (AsText Unicode (Path b t)) instance FromJSONKey (AsText Unicode (Path b t)) => FromJSONKey (Path b t) - --- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is --- PLATFORM_UTF_CODEC encoded. If encoding fails a runtime error will be thrown. -deriving via (AsText Unicode (Path b t)) instance ToJSONKey (AsText Unicode (Path b t)) => ToJSONKey (Path b t) - --- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is --- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. -deriving via (AsText Unicode (SomeBase t)) instance FromJSON (AsText Unicode (SomeBase t)) => FromJSON (SomeBase t) - --- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is --- PLATFORM_UTF_CODEC encoded. If encoding fails a runtime error will be thrown. -deriving via (AsText Unicode (SomeBase t)) instance ToJSON (SomeBase t) - --- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is --- PLATFORM_UTF_CODEC encoded. If decoding fails a runtime error will be thrown. -deriving via (AsText Unicode (SomeBase t)) instance FromJSONKey (AsText Unicode (SomeBase t)) => FromJSONKey (SomeBase t) - --- | This instance assumes that the underlying PLATFORM_PATH_SINGLE is --- PLATFORM_UTF_CODEC encoded. If encoding fails a runtime error will be thrown. -deriving via (AsText Unicode (SomeBase t)) instance ToJSONKey (SomeBase t) - --------------------------------------------------------------------------------- --- Instances for newtype wrappers --------------------------------------------------------------------------------- - --- $newtype-wrappers --- This module defines two newtype wrappers to control the conversion between --- JSON value and a 'Path': --- --- * 'AsBinary' represents a 'Path' as a sequence of PLATFORM_WORD_SINGLE in --- JSON. For example: --- --- >>> Data.Aeson.encode (AsBinary [relfile|foo/bar|]) --- "[102,111,111,92,98,97,114]" --- --- Note that this is a total encoding since every PLATFORM_PATH_SINGLE can be --- represented as a byte array and vice versa. --- --- * 'AsText' tries to represent a 'Path' as a string in JSON. In order to do --- that we also have to provide an encoding. Those are represented as by --- 'Utf8', 'Utf16LE' and 'Unicode', where the latter is a type synonym for --- 'Utf8' for POSIX paths and 'Utf16LE' for Windows paths. --- Note that this may fail with a runtime error if the underlying --- PLATFORM_PATH_SINGLE uses a different encoding! --- Since 'relfile' uses a unicode encoding the previous example displays as --- follows (you need the @TypeApplications@ language extensions for this to --- work): --- --- >>> Data.Aeson.encode (AsText @Unicode [relfile|foo/bar|]) --- "foo/bar" - -#if IS_WINDOWS -type Unicode = Utf16LE -#else -type Unicode = Utf8 -#endif - - ---------------------------------------- - -- Instances for PLATFORM_PATH - ---------------------------------------- - -instance FromJSON (AsBinary PLATFORM_PATH) where - parseJSON value = AsBinary <$> platformPathFromBinary value - {-# INLINE parseJSON #-} - -instance IsTextEncoding enc => FromJSON (AsText enc PLATFORM_PATH) where - parseJSON value = AsText <$> platformPathFromText @enc value - {-# INLINE parseJSON #-} - -instance ToJSON (AsBinary PLATFORM_PATH) where - toJSON = platformPathToBinary . asBinary - {-# INLINE toJSON #-} - toEncoding = platformPathToBinaryEncoding . asBinary - {-# INLINE toEncoding #-} - -instance IsTextEncoding enc => ToJSON (AsText enc PLATFORM_PATH) where - toJSON = platformPathToText @enc . asText - {-# INLINE toJSON #-} - toEncoding = platformPathToTextEncoding @enc . asText - {-# INLINE toEncoding #-} - -instance FromJSONKey (AsBinary PLATFORM_PATH) where - fromJSONKey = Aeson.FromJSONKeyValue parseJSON - {-# INLINE fromJSONKey #-} - -instance IsTextEncoding enc => FromJSONKey (AsText enc PLATFORM_PATH) where - fromJSONKey = Aeson.FromJSONKeyTextParser (parseKeyAsText pure) - {-# INLINE fromJSONKey #-} - -instance ToJSONKey (AsBinary PLATFORM_PATH) where - toJSONKey = Aeson.ToJSONKeyValue toJSON toEncoding - {-# INLINE toJSONKey #-} - -instance IsTextEncoding enc => ToJSONKey (AsText enc PLATFORM_PATH) where - toJSONKey = Aeson.toJSONKeyText decodeAsText - {-# INLINE toJSONKey #-} - - ---------------------------------------- - -- Instances for Path - ---------------------------------------- - -instance FromJSON (AsBinary (Path Abs Dir)) where - parseJSON value = AsBinary <$> absDirFromBinary value - {-# INLINE parseJSON #-} - -instance FromJSON (AsBinary (Path Abs File)) where - parseJSON value = AsBinary <$> absFileFromBinary value - {-# INLINE parseJSON #-} - -instance FromJSON (AsBinary (Path Rel Dir)) where - parseJSON value = AsBinary <$> relDirFromBinary value - {-# INLINE parseJSON #-} - -instance FromJSON (AsBinary (Path Rel File)) where - parseJSON value = AsBinary <$> relFileFromBinary value - {-# INLINE parseJSON #-} - -instance IsTextEncoding enc => FromJSON (AsText enc (Path Abs Dir)) where - parseJSON value = AsText <$> absDirFromText @enc value - {-# INLINE parseJSON #-} - -instance IsTextEncoding enc => FromJSON (AsText enc (Path Abs File)) where - parseJSON value = AsText <$> absFileFromText @enc value - {-# INLINE parseJSON #-} - -instance IsTextEncoding enc => FromJSON (AsText enc (Path Rel Dir)) where - parseJSON value = AsText <$> relDirFromText @enc value - {-# INLINE parseJSON #-} - -instance IsTextEncoding enc => FromJSON (AsText enc (Path Rel File)) where - parseJSON value = AsText <$> relFileFromText @enc value - {-# INLINE parseJSON #-} - -deriving via (AsBinary PLATFORM_PATH) instance ToJSON (AsBinary (Path b t)) -deriving via (AsText enc PLATFORM_PATH) instance IsTextEncoding enc => ToJSON (AsText enc (Path b t)) - -instance FromJSONKey (AsBinary (Path Abs Dir)) where - fromJSONKey = Aeson.FromJSONKeyValue parseJSON - {-# INLINE fromJSONKey #-} - -instance FromJSONKey (AsBinary (Path Abs File)) where - fromJSONKey = Aeson.FromJSONKeyValue parseJSON - {-# INLINE fromJSONKey #-} - -instance FromJSONKey (AsBinary (Path Rel Dir)) where - fromJSONKey = Aeson.FromJSONKeyValue parseJSON - {-# INLINE fromJSONKey #-} - -instance FromJSONKey (AsBinary (Path Rel File)) where - fromJSONKey = Aeson.FromJSONKeyValue parseJSON - {-# INLINE fromJSONKey #-} - -instance IsTextEncoding enc => FromJSONKey (AsText enc (Path Abs Dir)) where - fromJSONKey = Aeson.FromJSONKeyTextParser (parseKeyAsText parseAbsDir) - {-# INLINE fromJSONKey #-} - -instance IsTextEncoding enc => FromJSONKey (AsText enc (Path Abs File)) where - fromJSONKey = Aeson.FromJSONKeyTextParser (parseKeyAsText parseAbsFile) - {-# INLINE fromJSONKey #-} - -instance IsTextEncoding enc => FromJSONKey (AsText enc (Path Rel Dir)) where - fromJSONKey = Aeson.FromJSONKeyTextParser (parseKeyAsText parseRelDir) - {-# INLINE fromJSONKey #-} - -instance IsTextEncoding enc => FromJSONKey (AsText enc (Path Rel File)) where - fromJSONKey = Aeson.FromJSONKeyTextParser (parseKeyAsText parseRelFile) - {-# INLINE fromJSONKey #-} - -deriving via (AsBinary PLATFORM_PATH) instance ToJSONKey (AsBinary (Path b t)) -deriving via (AsText enc PLATFORM_PATH) instance IsTextEncoding enc => ToJSONKey (AsText enc (Path b t)) - - ---------------------------------------- - -- Instances for SomeBase - ---------------------------------------- - -instance FromJSON (AsBinary (SomeBase Dir)) where - parseJSON value = AsBinary <$> someDirFromBinary value - {-# INLINE parseJSON #-} - -instance FromJSON (AsBinary (SomeBase File)) where - parseJSON value = AsBinary <$> someFileFromBinary value - {-# INLINE parseJSON #-} - -instance IsTextEncoding enc => FromJSON (AsText enc (SomeBase Dir)) where - parseJSON value = AsText <$> someDirFromText @enc value - {-# INLINE parseJSON #-} - -instance IsTextEncoding enc => FromJSON (AsText enc (SomeBase File)) where - parseJSON value = AsText <$> someFileFromText @enc value - {-# INLINE parseJSON #-} - -instance ToJSON (AsBinary (SomeBase t)) where - toJSON = toJSON . fmap fromSomeBase - {-# INLINE toJSON #-} - toEncoding = toEncoding . fmap fromSomeBase - {-# INLINE toEncoding #-} - -instance IsTextEncoding enc => ToJSON (AsText enc (SomeBase t)) where - toJSON = toJSON . fmap fromSomeBase - {-# INLINE toJSON #-} - toEncoding = toEncoding . fmap fromSomeBase - {-# INLINE toEncoding #-} - -instance FromJSONKey (AsBinary (SomeBase Dir)) where - fromJSONKey = Aeson.FromJSONKeyValue parseJSON - {-# INLINE fromJSONKey #-} - -instance FromJSONKey (AsBinary (SomeBase File)) where - fromJSONKey = Aeson.FromJSONKeyValue parseJSON - {-# INLINE fromJSONKey #-} - -instance IsTextEncoding enc => FromJSONKey (AsText enc (SomeBase Dir)) where - fromJSONKey = Aeson.FromJSONKeyTextParser (parseKeyAsText parseSomeDir) - {-# INLINE fromJSONKey #-} - -instance IsTextEncoding enc => FromJSONKey (AsText enc (SomeBase File)) where - fromJSONKey = Aeson.FromJSONKeyTextParser (parseKeyAsText parseSomeFile) - {-# INLINE fromJSONKey #-} - -instance ToJSONKey (AsBinary (SomeBase t)) where - toJSONKey = Aeson.ToJSONKeyValue toJSON toEncoding - {-# INLINE toJSONKey #-} - -instance IsTextEncoding enc => ToJSONKey (AsText enc (SomeBase t)) where - toJSONKey = fmap fromSomeBase >$< toJSONKey - {-# INLINE toJSONKey #-} - --------------------------------------------------------------------------------- --- Internal helpers --------------------------------------------------------------------------------- - -unsafeDecodeWith :: TextEncoding -> PLATFORM_PATH -> String -unsafeDecodeWith enc = - either (error . displayException) id . OsPath.decodeWith enc -{-# INLINE unsafeDecodeWith #-} - -unsafeEncodeWith :: TextEncoding -> String -> Parser PLATFORM_PATH -unsafeEncodeWith enc = - either (fail . displayException) pure . OsPath.encodeWith enc -{-# INLINE unsafeEncodeWith #-} - -decodeAsText :: forall enc . IsTextEncoding enc - => AsText enc PLATFORM_PATH - -> Text -decodeAsText = Text.pack . unsafeDecodeWith (textEncoding @enc) . asText -{-# INLINE decodeAsText #-} - -parseAsBinary :: (forall m . MonadThrow m => PLATFORM_PATH -> m a) - -> Value - -> Parser a -parseAsBinary parse = - either (fail . displayException) pure . parse <=< platformPathFromBinary -{-# INLINE parseAsBinary #-} - -parseTextWith :: TextEncoding - -> (forall m . MonadThrow m => PLATFORM_PATH -> m a) - -> Value - -> Parser a -parseTextWith enc parse = - either (fail . displayException) pure . parse <=< platformPathFromTextWith enc -{-# INLINE parseTextWith #-} - -parseKeyAsText :: forall enc a . IsTextEncoding enc - => (forall m . MonadThrow m => PLATFORM_PATH -> m a) - -> Text - -> Parser (AsText enc a) -parseKeyAsText parse = - either (fail . displayException) (pure . AsText) . parse - <=< unsafeEncodeWith (textEncoding @enc) . Text.unpack -{-# INLINE parseKeyAsText #-} diff --git a/src/OsPath/Aeson/Internal.hs b/src/OsPath/Aeson/Internal.hs deleted file mode 100644 index 6c4f96a..0000000 --- a/src/OsPath/Aeson/Internal.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DeriveTraversable #-} - -module OsPath.Aeson.Internal where - -import System.IO (TextEncoding, utf8, utf16le) - -newtype AsBinary a = AsBinary { asBinary :: a } - deriving (Foldable, Functor, Traversable) - -newtype AsText encoding a = AsText { asText :: a } - deriving (Foldable, Functor, Traversable) - -class IsTextEncoding a where - textEncoding :: TextEncoding - -data Utf8 - -instance IsTextEncoding Utf8 where - textEncoding = utf8 - {-# INLINE textEncoding #-} - -data Utf16LE - -instance IsTextEncoding Utf16LE where - textEncoding = utf16le - {-# INLINE textEncoding #-} diff --git a/src/OsPath/Aeson/Posix.hs b/src/OsPath/Aeson/Posix.hs deleted file mode 100644 index 1a84017..0000000 --- a/src/OsPath/Aeson/Posix.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE CPP #-} -#define PLATFORM_NAME Posix -#define PLATFORM_PATH PosixPath -#define PLATFORM_PATH_SINGLE 'PosixPath' -#define PLATFORM_CHAR PosixChar -#define PLATFORM_CHAR_SINGLE 'PosixChar' -#define PLATFORM_WORD Word8 -#define PLATFORM_WORD_SINGLE 'Word8' -#define PLATFORM_UTF_CODEC UTF8 -#define IS_WINDOWS 0 -#include "Include.hs" diff --git a/src/OsPath/Aeson/Windows.hs b/src/OsPath/Aeson/Windows.hs deleted file mode 100644 index 57b54b8..0000000 --- a/src/OsPath/Aeson/Windows.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE CPP #-} -#define PLATFORM_NAME Windows -#define PLATFORM_PATH WindowsPath -#define PLATFORM_PATH_SINGLE 'WindowsPath' -#define PLATFORM_CHAR WindowsChar -#define PLATFORM_CHAR_SINGLE 'WindowsChar' -#define PLATFORM_WORD Word16 -#define PLATFORM_WORD_SINGLE 'Word16' -#define PLATFORM_UTF_CODEC UTF16-LE -#define IS_WINDOWS 1 -#include "Include.hs" diff --git a/test-ospath/Common/Include.hs b/test-ospath/Common/Include.hs index 917f494..169ade1 100644 --- a/test-ospath/Common/Include.hs +++ b/test-ospath/Common/Include.hs @@ -29,7 +29,6 @@ import qualified System.OsString.PLATFORM_NAME as OsString import Test.Hspec import OsPath.PLATFORM_NAME -import OsPath.Aeson.PLATFORM_NAME () import OsPath.Internal.PLATFORM_NAME currentDir :: Path Rel Dir diff --git a/test-ospath/Posix.hs b/test-ospath/Posix.hs index c4192dc..b72f9e6 100644 --- a/test-ospath/Posix.hs +++ b/test-ospath/Posix.hs @@ -7,8 +7,6 @@ module Posix (spec) where -import Data.Aeson -import qualified Data.ByteString.Lazy.Char8 as LBS import qualified System.OsString.Posix as OsString import Test.Hspec @@ -27,7 +25,6 @@ spec = describe "Parsing: Path Rel File" parseRelFileSpec Common.Posix.spec describe "Restrictions" restrictions - describe "Aeson Instances" aesonInstances describe "QuasiQuotes" quasiquotes -- | Restricting the input of any tricks. @@ -138,19 +135,6 @@ parseRelFileSpec = where failing x = parserTest parseRelFile x Nothing succeeding x with = parserTest parseRelFile x (Just with) --- | Tests for the 'ToJSON' and 'FromJSON' instances --- --- Can't use overloaded strings due to some weird issue with bytestring-0.9.2.1 / ghc-7.4.2: --- https://travis-ci.org/sjakobi/path/jobs/138399072#L989 -aesonInstances :: Spec -aesonInstances = - do it "Decoding \"[\"/foo/bar\"]\" as a [Path Abs Dir] should succeed." $ - eitherDecode (LBS.pack "[\"/foo/bar\"]") `shouldBe` Right [Path [OsString.pstr|/foo/bar/|] :: Path Abs Dir] - it "Decoding \"[\"/foo/bar\"]\" as a [Path Rel Dir] should fail." $ - decode (LBS.pack "[\"/foo/bar\"]") `shouldBe` (Nothing :: Maybe [Path Rel Dir]) - it "Encoding \"[\"/foo/bar/mu.txt\"]\" should succeed." $ - encode [Path [OsString.pstr|/foo/bar/mu.txt|] :: Path Abs File] `shouldBe` LBS.pack "[\"/foo/bar/mu.txt\"]" - -- | Test QuasiQuoters. Make sure they work the same as the $(mk*) constructors. quasiquotes :: Spec quasiquotes = diff --git a/test-ospath/Windows.hs b/test-ospath/Windows.hs index d376b9b..ba73545 100644 --- a/test-ospath/Windows.hs +++ b/test-ospath/Windows.hs @@ -7,8 +7,6 @@ module Windows (spec) where -import Data.Aeson -import qualified Data.ByteString.Lazy.Char8 as LBS import qualified System.OsString.Windows as OsString import Test.Hspec @@ -27,7 +25,6 @@ spec = describe "Parsing: Path Rel File" parseRelFileSpec Common.Windows.spec describe "Restrictions" restrictions - describe "Aeson Instances" aesonInstances describe "QuasiQuotes" quasiquotes -- | Restricting the input of any tricks. @@ -148,19 +145,6 @@ parseRelFileSpec = where failing x = parserTest parseRelFile x Nothing succeeding x with = parserTest parseRelFile x (Just with) --- | Tests for the 'ToJSON' and 'FromJSON' instances --- --- Can't use overloaded strings due to some weird issue with bytestring-0.9.2.1 / ghc-7.4.2: --- https://travis-ci.org/sjakobi/path/jobs/138399072#L989 -aesonInstances :: Spec -aesonInstances = - do it "Decoding \"[\"C:\\\\foo\\\\bar\"]\" as a [Path Abs Dir] should succeed." $ - eitherDecode (LBS.pack "[\"C:\\\\foo\\\\bar\"]") `shouldBe` Right [Path [OsString.pstr|C:\foo\bar\|] :: Path Abs Dir] - it "Decoding \"[\"C:\\foo\\bar\"]\" as a [Path Rel Dir] should fail." $ - decode (LBS.pack "[\"C:\\foo\\bar\"]") `shouldBe` (Nothing :: Maybe [Path Rel Dir]) - it "Encoding \"[\"C:\\foo\\bar\\mu.txt\"]\" should succeed." $ - encode [Path [OsString.pstr|C:\foo\bar\mu.txt|] :: Path Abs File] `shouldBe` (LBS.pack "[\"C:\\\\foo\\\\bar\\\\mu.txt\"]") - -- | Test QuasiQuoters. Make sure they work the same as the $(mk*) constructors. quasiquotes :: Spec quasiquotes = From 9de73aba054a1a8b0b75df48b36ac8200f15761f Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 19 Jul 2024 02:14:52 +0200 Subject: [PATCH 38/52] Empty `Validity PLATFORM_PATH` instance --- path.cabal | 1 + validity-test-ospath/OsPath/Gen/Include.hs | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/path.cabal b/path.cabal index e8a2667..f5b43d9 100644 --- a/path.cabal +++ b/path.cabal @@ -152,6 +152,7 @@ test-suite validity-test-ospath , os-string , path , validity >= 0.8.0.0 + , validity-bytestring >=0.4.1.0 default-language: Haskell2010 ghc-options: -threaded -rtsopts -with-rtsopts=-N diff --git a/validity-test-ospath/OsPath/Gen/Include.hs b/validity-test-ospath/OsPath/Gen/Include.hs index 2b73979..756fbfa 100644 --- a/validity-test-ospath/OsPath/Gen/Include.hs +++ b/validity-test-ospath/OsPath/Gen/Include.hs @@ -14,6 +14,7 @@ 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 @@ -157,5 +158,4 @@ instance GenValid PLATFORM_PATH where in shrinkedWithDrive <> shrinkedWithoutDrive -instance Validity PLATFORM_PATH where - validate = trivialValidation -- TODO: Not yet implemented +instance Validity PLATFORM_PATH From f8ded6a5a11ebae1e9277d6a096874ecf4709fa6 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Mon, 29 Jul 2024 15:24:14 +0200 Subject: [PATCH 39/52] Some small, final changes --- path.cabal | 1 + test-ospath/Common/Include.hs | 52 +++++++++++++++-------------- test/Common/Include.hs | 62 ++++++++++++++++++++++------------- 3 files changed, 69 insertions(+), 46 deletions(-) diff --git a/path.cabal b/path.cabal index f5b43d9..604e0f8 100644 --- a/path.cabal +++ b/path.cabal @@ -74,6 +74,7 @@ test-suite test build-depends: aeson , base , bytestring + , exceptions , filepath , hspec >= 2.0 && < 3 , mtl >= 2.0 && < 3 diff --git a/test-ospath/Common/Include.hs b/test-ospath/Common/Include.hs index 169ade1..485b9d4 100644 --- a/test-ospath/Common/Include.hs +++ b/test-ospath/Common/Include.hs @@ -92,7 +92,7 @@ operationFilename = do operationParent :: Spec operationParent = do it - "parent \"name\" == \".\"" + "parent relDir == \".\"" (parent relDir == currentDir) it "parent \".\" == \".\"" @@ -101,7 +101,7 @@ operationParent = do forDrives $ \drive -> do let absDir = drive relDir it - "parent (absDir \"name\") == absDir" + "parent (absDir relDir) == absDir" (parent (absDir relDir) == absDir) it "parent \"/name\" == drive" @@ -116,10 +116,10 @@ operationSplitDrive = forDrives $ \drive -> do let absDir = drive relDir absFile = drive relFile it - "splitDrive \"/dir\" == (drive, Just \"dir\")" + "splitDrive absDir == (drive, Just relDir)" (splitDrive absDir == (drive, Just relDir)) it - "splitDrive \"/file\" == (drive, Just \"file\")" + "splitDrive absFile == (drive, Just relFile)" (splitDrive absFile == (drive, Just relFile)) it "splitDrive drive == (drive, Nothing)" @@ -161,16 +161,16 @@ operationIsProperPrefixOf = do operationStripProperPrefix :: Spec operationStripProperPrefix = do it - "stripProperPrefix relDir (relDir relDir) == relDir" + "stripProperPrefix relDir (relDir relDir) == Just 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" (stripProperPrefix absDir (absDir relDir) == Just relDir) it - "stripProperPrefix absDir absDir == _|_" + "stripProperPrefix absDir absDir == Nothing" (isNothing (stripProperPrefix absDir absDir)) -- | The '' operation. @@ -203,6 +203,7 @@ operationAppend = do "AbsDir + RelFile == AbsFile" (absDir relFile == Path (absDir' OsPath. relFile')) +-- | The 'toOsPath' operation. operationToOsPath :: Spec operationToOsPath = do let expected = relRoot @@ -213,38 +214,34 @@ operationToOsPath = do ("show \".\" == " ++ (show . show) expected) (show currentDir == show expected) +-- | Testing operations related to extensions. extensionOperations :: Spec extensionOperations = do - let extension = [OsString.pstr|.foo|] - let extensions = - [ extension - , [OsString.pstr|.foo.|] - , [OsString.pstr|.foo..|] - ] - describe "Only filenames and extensions" $ - forM_ extensions $ \ext -> - forM_ filenames $ \file -> do - runTests parseRelFile file ext + 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_ filenames $ \file -> do + forM_ validExtensions $ \ext -> do let ospath = dir <> OsString.singleton OsPath.pathSeparator <> file - runTests parseRelFile ospath extension + runTests parseRelFile ospath ext describe "Absolute dir paths" $ forM_ drives_ $ \drive -> do forM_ dirnames $ \dir -> do forM_ filenames $ \file -> do - let ospath = drive <> dir <> pathSep <> file - runTests parseAbsFile ospath extension + 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 $(mkRelFile [OsString.pstr|name|]) - `shouldThrow` (== InvalidExtension ext) + it ("throws InvalidExtension when extension is " ++ show ext) $ + addExtension ext (Path [OsString.pstr|name|]) + `shouldThrow` (== InvalidExtension ext) where @@ -294,6 +291,13 @@ extensionOperations = do , [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 diff --git a/test/Common/Include.hs b/test/Common/Include.hs index 5bf3124..ea44cfe 100644 --- a/test/Common/Include.hs +++ b/test/Common/Include.hs @@ -1,7 +1,7 @@ -- This template expects CPP definitions for: -- PLATFORM_NAME = Posix | Windows -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RankNTypes #-} -- | Test functions that are common to Posix and Windows module Common.PLATFORM_NAME @@ -13,6 +13,7 @@ module Common.PLATFORM_NAME 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) @@ -83,7 +84,7 @@ operationFilename = do operationParent :: Spec operationParent = do it - "parent \"name\" == \".\"" + "parent relDir == \".\"" (parent relDir == currentDir) it "parent \".\" == \".\"" @@ -92,10 +93,10 @@ operationParent = do forDrives $ \drive -> do let absDir = drive relDir it - "parent (absDir \"name\") == absDir" + "parent (absDir relDir) == absDir" (parent (absDir relDir) == absDir) it - "parent \"/name\" == drive" + "parent absDir == drive" (parent absDir == drive) it "parent drive == drive" @@ -107,10 +108,10 @@ operationSplitDrive = forDrives $ \drive -> do let absDir = drive relDir absFile = drive relFile it - "splitDrive \"/dir\" == (drive, Just \"dir\")" + "splitDrive absDir == (drive, Just relDir)" (splitDrive absDir == (drive, Just relDir)) it - "splitDrive \"/file\" == (drive, Just \"file\")" + "splitDrive absFile == (drive, Just relFile)" (splitDrive absFile == (drive, Just relFile)) it "splitDrive drive == (drive, Nothing)" @@ -161,7 +162,7 @@ operationStripProperPrefix = do "stripProperPrefix absDir (absDir relDir) == relDir" (stripProperPrefix absDir (absDir relDir) == Just relDir) it - "stripProperPrefix absDir absDir == _|_" + "stripProperPrefix absDir absDir == Nothing" (isNothing (stripProperPrefix absDir absDir)) -- | The '' operation. @@ -194,6 +195,7 @@ operationAppend = do "AbsDir + RelFile == AbsFile" (absDir relFile == Path (absDir' FilePath. relFile')) +-- | The 'toFilePath operation. operationToFilePath :: Spec operationToFilePath = do let expected = "." ++ [FilePath.pathSeparator] @@ -204,37 +206,41 @@ operationToFilePath = do ("show \".\" == " ++ (show . show) expected) (show currentDir == show expected) +-- | Testing operations related to extensions. extensionOperations :: Spec extensionOperations = do - let extension = ".foo" - let extensions = extension : [".foo.", ".foo.."] - describe "Only filenames and extensions" $ - forM_ extensions $ \ext -> - forM_ filenames $ \f -> do - runTests parseRelFile f ext + forM_ filenames $ \file -> do + forM_ validExtensions $ \ext -> do + runTests parseRelFile file ext describe "Relative dir paths" $ - forM_ dirnames $ \d -> do - forM_ filenames $ \f -> do - let f1 = d ++ [FilePath.pathSeparator] ++ f - runTests parseRelFile f1 extension + 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 - let filepath = drive ++ dir ++ [FilePath.pathSeparator] ++ file - runTests parseAbsFile filepath extension + 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 [" ++ ext ++ "]") $ - addExtension ext $(mkRelFile "name") - `shouldThrow` (== InvalidExtension ext) + 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) @@ -245,6 +251,7 @@ extensionOperations = do show file ++ " parsed to " ++ show maybePathFile ++ ", " ++ show (file ++ ext) ++ " parsed to " ++ show maybePathFileWithExt + filenames :: [FilePath] filenames = [ "name" , "name." @@ -255,7 +262,11 @@ extensionOperations = do , "name..name" , "..." ] + + dirnames :: [FilePath] dirnames = filenames ++ ["."] + + invalidExtensions :: [String] invalidExtensions = [ "" , "." @@ -272,6 +283,13 @@ extensionOperations = do , ".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 From 179f6ef7b21fee1d09d3f483bdc8c5f780f88d9f Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Mon, 29 Jul 2024 18:04:23 +0200 Subject: [PATCH 40/52] Updated CI, tested-with and removed some dependencies --- path.cabal | 22 ++++------------------ 1 file changed, 4 insertions(+), 18 deletions(-) diff --git a/path.cabal b/path.cabal index 604e0f8..0cc7e7e 100644 --- a/path.cabal +++ b/path.cabal @@ -1,3 +1,4 @@ +cabal-version: 1.18 name: path version: 0.9.5 synopsis: Support for well-typed paths @@ -9,8 +10,7 @@ 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.4, 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 , src/Path/Include.hs @@ -42,7 +42,7 @@ library , OsPath.Internal.Posix , OsPath.Internal.Windows build-depends: aeson >= 1.0.0.0 - , base >= 4.12 && < 5 + , base >= 4.12 && < 5 , deepseq , exceptions >= 0.4 && < 0.11 , filepath >= 1.5.0.0 @@ -77,7 +77,6 @@ test-suite test , exceptions , filepath , hspec >= 2.0 && < 3 - , mtl >= 2.0 && < 3 , path , template-haskell if flag(dev) @@ -96,13 +95,10 @@ test-suite test-ospath , TH.Posix , TH.Windows hs-source-dirs: test-ospath - build-depends: aeson - , base - , bytestring + build-depends: base , exceptions , filepath , hspec >= 2.0 && < 3 - , mtl >= 2.0 && < 3 , os-string , path , template-haskell @@ -118,17 +114,12 @@ test-suite validity-test other-modules: Path.Gen hs-source-dirs: validity-test build-depends: QuickCheck - , aeson , base - , bytestring , filepath , genvalidity >= 1.0 - , genvalidity-property >= 0.4 , 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 @@ -141,18 +132,13 @@ test-suite validity-test-ospath , Windows hs-source-dirs: validity-test-ospath build-depends: QuickCheck - , aeson , base - , bytestring , filepath , genvalidity >= 1.0 - , genvalidity-property >= 0.4 , genvalidity-hspec >= 0.7 , hspec >= 2.0 && < 3 - , mtl >= 2.0 && < 3 , os-string , path - , validity >= 0.8.0.0 , validity-bytestring >=0.4.1.0 default-language: Haskell2010 ghc-options: -threaded -rtsopts -with-rtsopts=-N From e2c1ec9f9953e253414f6141a2fde0d7ac425fba Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Mon, 29 Jul 2024 20:20:49 +0200 Subject: [PATCH 41/52] Support for filepath >=1.4.100.0 && <1.5 --- .github/workflows/ci.yaml | 11 +- compat/System/OsString/Compat/Include.hs | 137 +++++++++++++++++++++ compat/System/OsString/Compat/Posix.hs | 6 + compat/System/OsString/Compat/Windows.hs | 6 + path.cabal | 113 ++++++++++++----- src/OsPath/Include.hs | 39 +++--- src/OsPath/Internal/Include.hs | 59 ++++----- test-ospath/Common/Include.hs | 5 +- test-ospath/Posix.hs | 2 + test-ospath/TH/Include.hs | 2 + test-ospath/Windows.hs | 2 + validity-test-ospath/Include.hs | 13 +- validity-test-ospath/OsPath/Gen/Include.hs | 20 +-- 13 files changed, 318 insertions(+), 97 deletions(-) create mode 100644 compat/System/OsString/Compat/Include.hs create mode 100644 compat/System/OsString/Compat/Posix.hs create mode 100644 compat/System/OsString/Compat/Windows.hs diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index aceeb2a..b186798 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -13,15 +13,14 @@ jobs: strategy: matrix: os: [ubuntu-latest, macOS-latest, windows-latest] - cabal: ["3.10"] + cabal: ["3.12"] ghc: # GHC versions listed as current stable releases - "9.2.8" - - "9.4.7" - - "9.6.3" - # GHC 9.8 only works with cabal-install >= 3.10.2.0, which is not - # available from haskell-actions/setup (or on Hackage) - # - "9.8.1" + - "9.4.8" + - "9.6.6" + - "9.8.2" + - "9.10.1" steps: - uses: actions/checkout@v4 diff --git a/compat/System/OsString/Compat/Include.hs b/compat/System/OsString/Compat/Include.hs new file mode 100644 index 0000000..7e1ec50 --- /dev/null +++ b/compat/System/OsString/Compat/Include.hs @@ -0,0 +1,137 @@ +-- This template expects CPP definitions for: +-- PLATFORM_NAME = Posix | Windows +-- PLATFORM_STRING = PosixString | WindowsString +-- PLATFORM_CHAR = PosixChar | WindowsChar +-- IS_WINDOWS = 0 | 1 + +{-# OPTIONS_GHC -Wno-deprecations #-} + +module System.OsString.Compat.PLATFORM_NAME +#if MIN_VERSION_os_string(2,0,0) + ( OsString.all + , OsString.any + , OsString.break + , OsString.breakEnd + , OsString.dropWhileEnd + , OsString.empty + , OsString.init + , OsString.isInfixOf + , OsString.isPrefixOf + , OsString.isSuffixOf + , OsString.length + , OsString.map + , OsString.null + , OsString.replicate + , OsString.singleton + , OsString.span + , OsString.spanEnd + , OsString.stripPrefix + , OsString.uncons + ) +#else + ( 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 System.OsString.Internal.Types (PLATFORM_STRING(..), PLATFORM_CHAR(..)) +import System.OsString.PLATFORM_NAME as OsString + +#if !MIN_VERSION_os_string(2,0,0) +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 + +#if !MIN_VERSION_os_string(2,0,0) +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/compat/System/OsString/Compat/Posix.hs b/compat/System/OsString/Compat/Posix.hs new file mode 100644 index 0000000..bd213a0 --- /dev/null +++ b/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/compat/System/OsString/Compat/Windows.hs b/compat/System/OsString/Compat/Windows.hs new file mode 100644 index 0000000..9bcea5c --- /dev/null +++ b/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 index 0cc7e7e..0aebf83 100644 --- a/path.cabal +++ b/path.cabal @@ -1,9 +1,9 @@ -cabal-version: 1.18 +cabal-version: 3.0 name: path version: 0.9.5 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 @@ -17,6 +17,7 @@ extra-source-files: README.md , src/Path/Internal/Include.hs , src/OsPath/Include.hs , src/OsPath/Internal/Include.hs + , src/System/OsString/Compat/Include.hs , test/Common/Include.hs , test-ospath/Common/Include.hs , validity-test-ospath/Include.hs @@ -27,8 +28,34 @@ flag dev manual: True default: False +flag old-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.Posix , Path.Windows @@ -41,36 +68,57 @@ library , 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.5.0.0 , hashable >= 1.2 && < 1.5 - , os-string >= 2.0.0 + , path:compat , text , template-haskell - if flag(dev) - ghc-options: -Wall -Werror + + if flag(old-os-string) + build-depends: filepath >= 1.5.0.0 + , os-string >= 2.0.0 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 + , os-string < 2.0.0 + +library compat + import: language + + hs-source-dirs: compat + visibility: private + + exposed-modules: System.OsString.Compat.Posix + , System.OsString.Compat.Windows + + build-depends: base >= 4.12 && < 5 + + if flag(old-os-string) + build-depends: filepath >= 1.5.0.0 + , os-string >= 2.0.0 + else + build-depends: filepath >= 1.4.100.0 + , os-string < 2.0.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.Posix , Common.Windows , TH.Posix , TH.Windows - hs-source-dirs: test + build-depends: aeson , base , bytestring @@ -79,40 +127,41 @@ test-suite test , hspec >= 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 - hs-source-dirs: test-ospath + build-depends: base , exceptions , filepath , hspec >= 2.0 && < 3 , os-string , path + , path:compat , template-haskell - if flag(dev) - ghc-options: -Wall -Werror - else - ghc-options: -O2 -Wall - default-language: Haskell2010 test-suite validity-test + import: language + import: rts + type: exitcode-stdio-1.0 main-is: Main.hs - other-modules: Path.Gen hs-source-dirs: validity-test + + other-modules: Path.Gen + build-depends: QuickCheck , base , filepath @@ -120,17 +169,20 @@ test-suite validity-test , genvalidity-hspec >= 0.7 , hspec >= 2.0 && < 3 , path - 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 - hs-source-dirs: validity-test-ospath + build-depends: QuickCheck , base , filepath @@ -139,9 +191,8 @@ test-suite validity-test-ospath , hspec >= 2.0 && < 3 , os-string , path + , path:compat , validity-bytestring >=0.4.1.0 - default-language: Haskell2010 - ghc-options: -threaded -rtsopts -with-rtsopts=-N source-repository head type: git diff --git a/src/OsPath/Include.hs b/src/OsPath/Include.hs index 8e75c0a..0bb373d 100644 --- a/src/OsPath/Include.hs +++ b/src/OsPath/Include.hs @@ -27,6 +27,8 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + module OsPath.PLATFORM_NAME (-- * Types Path @@ -121,6 +123,7 @@ import System.OsString.PLATFORM_NAME (PLATFORM_STRING) import qualified System.OsString.PLATFORM_NAME as OsString import OsPath.Internal.PLATFORM_NAME +import qualified System.OsString.Compat.PLATFORM_NAME as OsString.Compat -------------------------------------------------------------------------------- -- Types @@ -279,10 +282,10 @@ infixr 5 stripProperPrefix :: MonadThrow m => Path b Dir -> Path b t -> m (Path Rel t) stripProperPrefix (Path p) (Path l) = - case OsString.stripPrefix p l of + case OsString.Compat.stripPrefix p l of Nothing -> throwM (NotAProperPrefix p l) Just result - | OsString.null result -> throwM (NotAProperPrefix p l) + | OsString.Compat.null result -> throwM (NotAProperPrefix p l) | otherwise -> return (Path result) -- | Determines if the path in the first parameter is a proper prefix of the @@ -326,7 +329,7 @@ replaceProperPrefix src dst fp = (dst ) <$> stripProperPrefix src fp -- parent :: Path b t -> Path b Dir parent (Path fp) - | OsString.null fp = Path OsString.empty + | OsString.Compat.null fp = Path OsString.Compat.empty | OsPath.isDrive fp = Path fp | otherwise = Path @@ -339,7 +342,7 @@ parent (Path fp) 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) + mRest = if OsString.Compat.null rest then Nothing else Just (Path rest) in (Path d, mRest) -- | Get the drive from an absolute path. On POSIX, @/@ is a drive. @@ -379,8 +382,8 @@ filename (Path l) = -- dirname :: Path b Dir -> Path Rel Dir dirname (Path l) - | OsString.null l = Path OsString.empty - | OsPath.isDrive l = Path OsString.empty + | OsString.Compat.null l = Path OsString.Compat.empty + | OsPath.isDrive l = Path OsString.Compat.empty | otherwise = Path (last (OsPath.splitPath l)) -- | 'splitExtension' is the inverse of 'addExtension'. It splits the given @@ -417,28 +420,28 @@ dirname (Path l) -- @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 + if OsString.Compat.null nameDot + || OsString.Compat.null name + || OsString.Compat.null ext || name == [OsString.pstr|.|] || name == [OsString.pstr|..|] then throwM $ HasNoExtension ospath else return ( Path (normalizeDrive drv <> dir <> name) - , OsString.singleton OsPath.extSeparator <> ext + , OsString.Compat.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 + let (withoutTrailingSeps, trailingSeps) = OsString.Compat.spanEnd isSep str + (oneSep, rest) = OsString.Compat.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 + name = OsString.Compat.init nameDot -- | Get extension from given file path. Throws 'HasNoExtension' exception if -- the file does not have an extension. The following laws hold: @@ -481,26 +484,26 @@ addExtension :: MonadThrow m -> 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 + (sep, xtn) <- case OsString.Compat.uncons ext of Nothing -> throwM $ InvalidExtension ext Just result -> pure result - let withoutTrailingSeps = OsString.dropWhileEnd OsPath.isExtSeparator xtn + let withoutTrailingSeps = OsString.Compat.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) $ + when (OsString.Compat.any OsPath.isPathSeparator xtn) $ throwM $ InvalidExtension ext -- All "."s is not a valid extension - when (OsString.null withoutTrailingSeps) $ + when (OsString.Compat.null withoutTrailingSeps) $ throwM $ InvalidExtension ext -- Cannot have "."s except in trailing position - when (OsString.any OsPath.isExtSeparator withoutTrailingSeps) $ + when (OsString.Compat.any OsPath.isExtSeparator withoutTrailingSeps) $ throwM $ InvalidExtension ext -- Must be valid as a filename diff --git a/src/OsPath/Internal/Include.hs b/src/OsPath/Internal/Include.hs index 7adf4ed..7c85ceb 100644 --- a/src/OsPath/Internal/Include.hs +++ b/src/OsPath/Internal/Include.hs @@ -12,6 +12,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-deprecations #-} {-# OPTIONS_GHC -Wno-orphans #-} -- | Internal types and functions. @@ -57,6 +58,8 @@ import qualified System.OsPath.PLATFORM_NAME as OsPath import System.OsString.Internal.Types (PLATFORM_STRING(..)) import qualified System.OsString.PLATFORM_NAME as OsString +import qualified System.OsString.Compat.PLATFORM_NAME as OsString.Compat + -- | Path of some base and type. -- -- The type variables are: @@ -139,7 +142,7 @@ instance forall b t. (Typeable b, Typeable t) => TH.Lift (Path b t) where -- the filepath package. toOsPath :: Path b t -> PLATFORM_PATH toOsPath (Path ospath) - | OsString.null ospath = relRoot + | OsString.Compat.null ospath = relRoot | otherwise = ospath -------------------------------------------------------------------------------- @@ -164,16 +167,16 @@ isValidAbsFile ospath = isValidRelDir :: PLATFORM_PATH -> Bool isValidRelDir ospath = not (OsPath.isAbsolute ospath) && - not (OsString.null ospath) && + not (OsString.Compat.null ospath) && not (hasParentDir ospath) && - not (OsString.all OsPath.isPathSeparator ospath) && + not (OsString.Compat.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 (OsString.Compat.null ospath) && not (hasParentDir ospath) && not (OsPath.hasTrailingPathSeparator ospath) && ospath /= [OsPath.pstr|.|] && @@ -184,16 +187,16 @@ isValidRelFile ospath = hasParentDir :: PLATFORM_PATH -> Bool hasParentDir ospath = (ospath' == [OsString.pstr|..|]) || - (prefix' `OsString.isPrefixOf` ospath') || - (infix' `OsString.isInfixOf` ospath') || - (suffix' `OsString.isSuffixOf` ospath') + (prefix' `OsString.Compat.isPrefixOf` ospath') || + (infix' `OsString.Compat.isInfixOf` ospath') || + (suffix' `OsString.Compat.isSuffixOf` ospath') where prefix' = [OsString.pstr|..|] <> pathSep infix' = pathSep <> [OsString.pstr|..|] <> pathSep suffix' = pathSep <> [OsString.pstr|..|] #if IS_WINDOWS - ospath' = OsString.map normSep ospath + ospath' = OsString.Compat.map normSep ospath normSep c | OsPath.isPathSeparator c = OsPath.pathSeparator | otherwise = c @@ -207,33 +210,33 @@ hasParentDir ospath = -- | 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 + where (leadingSeps, rest) = OsString.Compat.span OsPath.isPathSeparator path normLeadingSep - | OsString.null leadingSeps = OsString.empty - | otherwise = OsString.singleton OsPath.pathSeparator + | OsString.Compat.null leadingSeps = OsString.Compat.empty + | otherwise = OsString.Compat.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 + where (rest, trailingSeps) = OsString.Compat.spanEnd OsPath.isPathSeparator path normTrailingSep - | OsString.null trailingSeps = OsString.empty - | otherwise = OsString.singleton OsPath.pathSeparator + | OsString.Compat.null trailingSeps = OsString.Compat.empty + | otherwise = OsString.Compat.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 +normalizeAllSeps = go OsString.Compat.empty where go !acc ospath - | OsString.null ospath = acc + | OsString.Compat.null ospath = acc | otherwise = let (leadingSeps, withoutLeadingSeps) = - OsString.span OsPath.isPathSeparator ospath + OsString.Compat.span OsPath.isPathSeparator ospath (name, rest) = - OsString.break OsPath.isPathSeparator withoutLeadingSeps - sep = if OsString.null leadingSeps - then OsString.empty - else OsString.singleton OsPath.pathSeparator + OsString.Compat.break OsPath.isPathSeparator withoutLeadingSeps + sep = if OsString.Compat.null leadingSeps + then OsString.Compat.empty + else OsString.Compat.singleton OsPath.pathSeparator in go (acc <> sep <> name) rest #if IS_WINDOWS @@ -242,9 +245,9 @@ normalizeAllSeps = go OsString.empty -- 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)) + where (leadingSeps, rest) = OsString.Compat.span OsPath.isPathSeparator path + normLeadingSeps = OsString.Compat.replicate + (min 2 (OsString.Compat.length leadingSeps)) OsPath.pathSeparator #endif @@ -265,7 +268,7 @@ normalizeDir = 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 + | p == relRoot = OsString.Compat.empty | otherwise = p -- | Applies platform-specific sep normalization following @OsPath.normalise@. @@ -280,14 +283,14 @@ normalizeFile = normalizeLeadingSeps . OsPath.normalise -- Other helper functions extSep :: PLATFORM_STRING -extSep = $(TH.lift (OsString.singleton OsPath.extSeparator)) +extSep = $(TH.lift (OsString.Compat.singleton OsPath.extSeparator)) pathSep :: PLATFORM_STRING -pathSep = $(TH.lift (OsString.singleton OsPath.pathSeparator)) +pathSep = $(TH.lift (OsString.Compat.singleton OsPath.pathSeparator)) -- | Normalized file path representation for the relative path root relRoot :: PLATFORM_PATH -relRoot = $(TH.lift ([OsPath.pstr|.|] <> OsString.singleton OsPath.pathSeparator)) +relRoot = $(TH.lift ([OsPath.pstr|.|] <> OsString.Compat.singleton OsPath.pathSeparator)) isWindows :: Bool #if IS_WINDOWS diff --git a/test-ospath/Common/Include.hs b/test-ospath/Common/Include.hs index 485b9d4..96f3523 100644 --- a/test-ospath/Common/Include.hs +++ b/test-ospath/Common/Include.hs @@ -8,6 +8,8 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + -- | Test functions that are common to Posix and Windows module Common.PLATFORM_NAME (spec @@ -30,6 +32,7 @@ import Test.Hspec import OsPath.PLATFORM_NAME import OsPath.Internal.PLATFORM_NAME +import qualified System.OsString.Compat.PLATFORM_NAME as OsString.Compat currentDir :: Path Rel Dir currentDir = (fromJust . parseRelDir) [OsString.pstr|.|] @@ -226,7 +229,7 @@ extensionOperations = do forM_ dirnames $ \dir -> do forM_ filenames $ \file -> do forM_ validExtensions $ \ext -> do - let ospath = dir <> OsString.singleton OsPath.pathSeparator <> file + let ospath = dir <> OsString.Compat.singleton OsPath.pathSeparator <> file runTests parseRelFile ospath ext describe "Absolute dir paths" $ diff --git a/test-ospath/Posix.hs b/test-ospath/Posix.hs index b72f9e6..dd18c1b 100644 --- a/test-ospath/Posix.hs +++ b/test-ospath/Posix.hs @@ -3,6 +3,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuasiQuotes #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + -- | Test suite. module Posix (spec) where diff --git a/test-ospath/TH/Include.hs b/test-ospath/TH/Include.hs index ed4c083..f9f524f 100644 --- a/test-ospath/TH/Include.hs +++ b/test-ospath/TH/Include.hs @@ -5,6 +5,8 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -Wno-deprecations #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} -- | Test functions to check the template haskell bits. diff --git a/test-ospath/Windows.hs b/test-ospath/Windows.hs index ba73545..592ba8c 100644 --- a/test-ospath/Windows.hs +++ b/test-ospath/Windows.hs @@ -3,6 +3,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + -- | Test suite. module Windows (spec) where diff --git a/validity-test-ospath/Include.hs b/validity-test-ospath/Include.hs index 6324201..9c0666d 100644 --- a/validity-test-ospath/Include.hs +++ b/validity-test-ospath/Include.hs @@ -3,7 +3,9 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +{-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} -- | Test suite. module PLATFORM_NAME where @@ -17,6 +19,7 @@ import Test.QuickCheck import Test.Validity import OsPath.Gen.PLATFORM_NAME () +import qualified System.OsString.Compat.PLATFORM_NAME as OsString.Compat -- | Test suite entry point, returns exit failure if any test fails. main :: IO () @@ -75,9 +78,9 @@ operationFilename = do 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 + forAllValid $ \dir -> if dir == Path OsString.Compat.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 + forAllValid $ \dir -> if dir == Path OsString.Compat.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 @@ -123,7 +126,7 @@ operationTakeDrive = do operationIsParentOf :: Spec operationIsParentOf = do forAllParentsAndChildren "isProperPrefixOf parent (parent child)" $ \parent child -> - if child == Path OsString.empty + if child == Path OsString.Compat.empty then True -- TODO do we always need this condition? else isProperPrefixOf parent (parent child) @@ -131,7 +134,7 @@ operationIsParentOf = do operationStripDir :: Spec operationStripDir = do forAllParentsAndChildren "stripProperPrefix parent (parent child) = child" $ \parent child -> - if child == Path OsString.empty + if child == Path OsString.Compat.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 diff --git a/validity-test-ospath/OsPath/Gen/Include.hs b/validity-test-ospath/OsPath/Gen/Include.hs index 756fbfa..3b62c81 100644 --- a/validity-test-ospath/OsPath/Gen/Include.hs +++ b/validity-test-ospath/OsPath/Gen/Include.hs @@ -2,7 +2,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_GHC -Wno-orphans #-} module OsPath.Gen.PLATFORM_NAME where @@ -22,6 +24,8 @@ import System.OsString.Internal.Types (PLATFORM_CHAR(..)) import qualified System.OsString.PLATFORM_NAME as OsString import Test.QuickCheck +import qualified System.OsString.Compat.PLATFORM_NAME as OsString.Compat + instance Validity (Path Abs File) where validate p@(Path fp) = mconcat @@ -59,7 +63,7 @@ instance Validity (Path Rel Dir) where 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 + parseRelDir fp == Just p || OsString.Compat.null fp ] instance Validity (SomeBase Dir) @@ -71,7 +75,7 @@ instance GenValid (Path Abs File) where shrinkValid = filter isValid . shrinkValidWith parseAbsFile instance GenValid (Path Abs Dir) where - genValid = (Path . ([OsString.pstr|/|] <>) . (<> OsString.singleton OsPath.pathSeparator) <$> genValid) `suchThat` isValid + genValid = (Path . ([OsString.pstr|/|] <>) . (<> OsString.Compat.singleton OsPath.pathSeparator) <$> genValid) `suchThat` isValid shrinkValid = filter isValid . shrinkValidWith parseAbsDir instance GenValid (Path Rel File) where @@ -79,7 +83,7 @@ instance GenValid (Path Rel File) where shrinkValid = filter isValid . shrinkValidWith parseRelFile instance GenValid (Path Rel Dir) where - genValid = (Path . (<> OsString.singleton OsPath.pathSeparator) <$> genValid) `suchThat` isValid + genValid = (Path . (<> OsString.Compat.singleton OsPath.pathSeparator) <$> genValid) `suchThat` isValid shrinkValid = filter isValid . shrinkValidWith parseRelDir instance GenValid (SomeBase Dir) where @@ -93,7 +97,7 @@ instance GenValid (SomeBase File) where 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 + OsPath.isValid fp || OsString.Compat.null fp , declare "The path does not contain a '..' path component." $ not (hasParentDir fp) ] @@ -101,7 +105,7 @@ validateCommon (Path fp) = mconcat 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 + OsPath.hasTrailingPathSeparator fp || OsString.Compat.null fp ] validateFile :: Path b File -> Validation @@ -111,7 +115,7 @@ validateFile (Path fp) = mconcat , declare "The path does not equal \".\"" $ fp /= [OsString.pstr|.|] , declare "The path does not end in /." $ - not ([OsString.pstr|/.|] `OsString.isSuffixOf` fp) + not ([OsString.pstr|/.|] `OsString.Compat.isSuffixOf` fp) ] validateAbs :: Path Abs t -> Validation @@ -152,7 +156,7 @@ instance GenValid PLATFORM_PATH where . OsPath.unpack $ relative shrinkedWithDrive = - if OsString.null drive + if OsString.Compat.null drive then [] else map (drive <>) shrinkedWithoutDrive in From b2d8b954ed3e0b861e8debfb2fe6e47e8eff8201 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Mon, 29 Jul 2024 21:17:34 +0200 Subject: [PATCH 42/52] Fixed Cabal conditionals, stack setup and HIE configuration --- .github/workflows/ci.yaml | 6 +++--- compat/System/OsString/Compat/Include.hs | 2 +- hie.yaml | 3 +++ path.cabal | 14 +++++++------- stack.yaml | 6 ++++-- stack.yaml.lock | 16 ++++++++-------- 6 files changed, 26 insertions(+), 21 deletions(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index b186798..08577ae 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -62,14 +62,14 @@ jobs: # run: | # cabal test path:validity-test - # As of 2023-10-16, the GitHub-hosted runner on ubuntu-latest comes with - # Stack 2.13.1 and GHC 9.6.3. + # As of 2024-07-29, the GitHub-hosted runner on ubuntu-latest comes with + # Stack 2.15.7 and GHC 9.10.1. stack: name: stack / ghc ${{ matrix.ghc }} runs-on: ubuntu-latest strategy: matrix: - ghc: ["9.6.3"] + ghc: ["9.10.1"] steps: - name: Clone project diff --git a/compat/System/OsString/Compat/Include.hs b/compat/System/OsString/Compat/Include.hs index 7e1ec50..788d9ea 100644 --- a/compat/System/OsString/Compat/Include.hs +++ b/compat/System/OsString/Compat/Include.hs @@ -52,11 +52,11 @@ module System.OsString.Compat.PLATFORM_NAME #endif where -import System.OsString.Internal.Types (PLATFORM_STRING(..), PLATFORM_CHAR(..)) import System.OsString.PLATFORM_NAME as OsString #if !MIN_VERSION_os_string(2,0,0) import Data.Coerce (coerce) +import System.OsString.Internal.Types (PLATFORM_STRING(..), PLATFORM_CHAR(..)) #if IS_WINDOWS import qualified System.OsPath.Data.ByteString.Short.Word16 as BSP diff --git a/hie.yaml b/hie.yaml index eff25a6..7b72a31 100644 --- a/hie.yaml +++ b/hie.yaml @@ -3,6 +3,9 @@ cradle: - path: "src" component: "lib:path" + - path: "compat" + component: "path:lib:compat" + - path: "test" component: "path:test:test" diff --git a/path.cabal b/path.cabal index 0aebf83..d8a2570 100644 --- a/path.cabal +++ b/path.cabal @@ -13,11 +13,11 @@ build-type: Simple 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 + , compat/System/OsString/Compat/Include.hs , src/Path/Include.hs , src/Path/Internal/Include.hs , src/OsPath/Include.hs , src/OsPath/Internal/Include.hs - , src/System/OsString/Compat/Include.hs , test/Common/Include.hs , test-ospath/Common/Include.hs , validity-test-ospath/Include.hs @@ -79,11 +79,11 @@ library , template-haskell if flag(old-os-string) - build-depends: filepath >= 1.5.0.0 - , os-string >= 2.0.0 - else build-depends: filepath >= 1.4.100.0 , os-string < 2.0.0 + else + build-depends: filepath >= 1.5.0.0 + , os-string >= 2.0.0 library compat import: language @@ -97,11 +97,11 @@ library compat build-depends: base >= 4.12 && < 5 if flag(old-os-string) - build-depends: filepath >= 1.5.0.0 - , os-string >= 2.0.0 - else build-depends: filepath >= 1.4.100.0 , os-string < 2.0.0 + else + build-depends: filepath >= 1.5.0.0 + , os-string >= 2.0.0 test-suite test import: language diff --git a/stack.yaml b/stack.yaml index 5ed13a2..36be99a 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,13 +1,15 @@ -resolver: lts-22.26 # GHC 9.6.5 +resolver: lts-22.31 # GHC 9.6.6 extra-deps: - directory-1.3.8.5@sha256:fbeec9ec346e5272167f63dcb86af513b457a7b9fc36dc818e4c7b81608d612b,3166 - - filepath-1.5.2.0@sha256:8af7a843cba7eddc8d44ae94002b766ee8c23cbcd3ecdb2cc79ee6e0a694419a,5178 + - filepath-1.5.3.0@sha256:0c64bc9a4f5946c86a8f0527bf40c8ba51e2c02d36eea0e20ea558c8d94166e8,4945 - process-1.6.20.0@sha256:2a9393de33f18415fb8f4826957a87a94ffe8840ca8472a9b69dca6de45aca03,2790 - unix-2.8.5.1@sha256:3f702a252a313a7bcb56e3908a14e7f9f1b40e41b7bdc8ae8a9605a1a8686f06,9808 flags: directory: os-string: true + path: + old-os-string: false unix: os-string: true diff --git a/stack.yaml.lock b/stack.yaml.lock index 76ff848..cf92b1f 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -12,12 +12,12 @@ packages: original: hackage: directory-1.3.8.5@sha256:fbeec9ec346e5272167f63dcb86af513b457a7b9fc36dc818e4c7b81608d612b,3166 - completed: - hackage: filepath-1.5.2.0@sha256:8af7a843cba7eddc8d44ae94002b766ee8c23cbcd3ecdb2cc79ee6e0a694419a,5178 + hackage: filepath-1.5.3.0@sha256:0c64bc9a4f5946c86a8f0527bf40c8ba51e2c02d36eea0e20ea558c8d94166e8,4945 pantry-tree: - sha256: 8886e236bfc70fc290bdc711f986a871f9e175d4355c7b1307b565c40c596c77 - size: 2196 + sha256: a5feb33f17ff131a5bba009abae35761594d62ba6873b2f70992a48db160c9b7 + size: 2274 original: - hackage: filepath-1.5.2.0@sha256:8af7a843cba7eddc8d44ae94002b766ee8c23cbcd3ecdb2cc79ee6e0a694419a,5178 + hackage: filepath-1.5.3.0@sha256:0c64bc9a4f5946c86a8f0527bf40c8ba51e2c02d36eea0e20ea558c8d94166e8,4945 - completed: hackage: process-1.6.20.0@sha256:2a9393de33f18415fb8f4826957a87a94ffe8840ca8472a9b69dca6de45aca03,2790 pantry-tree: @@ -34,7 +34,7 @@ packages: hackage: unix-2.8.5.1@sha256:3f702a252a313a7bcb56e3908a14e7f9f1b40e41b7bdc8ae8a9605a1a8686f06,9808 snapshots: - completed: - sha256: 8e7996960d864443a66eb4105338bbdd6830377b9f6f99cd5527ef73c10c01e7 - size: 719128 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/26.yaml - original: lts-22.26 + sha256: acaab6ca693211938d1542abcb1c83a2f298b9f6b571854a9d38febe39b6408e + size: 719577 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/31.yaml + original: lts-22.31 From fe1eae91a1b6763ad324e16d2567cee095bd9ca1 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Tue, 30 Jul 2024 09:44:49 +0200 Subject: [PATCH 43/52] Better compat sublibrary --- .../System/OsString/Compat/Include.hs | 36 ++++------ .../System/OsString/Compat/Posix.hs | 0 .../System/OsString/Compat/Windows.hs | 0 path.cabal | 25 +++---- src/OsPath/Include.hs | 43 ++++++----- src/OsPath/Internal/Include.hs | 71 ++++++++----------- test-ospath/Common/Include.hs | 10 ++- test-ospath/Posix.hs | 4 +- test-ospath/TH/Include.hs | 3 +- test-ospath/Windows.hs | 4 +- validity-test-ospath/Include.hs | 12 ++-- validity-test-ospath/OsPath/Gen/Include.hs | 20 +++--- 12 files changed, 95 insertions(+), 133 deletions(-) rename {compat => os-string-compat}/System/OsString/Compat/Include.hs (88%) rename {compat => os-string-compat}/System/OsString/Compat/Posix.hs (100%) rename {compat => os-string-compat}/System/OsString/Compat/Windows.hs (100%) diff --git a/compat/System/OsString/Compat/Include.hs b/os-string-compat/System/OsString/Compat/Include.hs similarity index 88% rename from compat/System/OsString/Compat/Include.hs rename to os-string-compat/System/OsString/Compat/Include.hs index 788d9ea..d5a6640 100644 --- a/compat/System/OsString/Compat/Include.hs +++ b/os-string-compat/System/OsString/Compat/Include.hs @@ -4,32 +4,23 @@ -- PLATFORM_CHAR = PosixChar | WindowsChar -- IS_WINDOWS = 0 | 1 +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} + {-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_GHC -Wno-orphans #-} module System.OsString.Compat.PLATFORM_NAME #if MIN_VERSION_os_string(2,0,0) - ( OsString.all - , OsString.any - , OsString.break - , OsString.breakEnd - , OsString.dropWhileEnd - , OsString.empty - , OsString.init - , OsString.isInfixOf - , OsString.isPrefixOf - , OsString.isSuffixOf - , OsString.length - , OsString.map - , OsString.null - , OsString.replicate - , OsString.singleton - , OsString.span - , OsString.spanEnd - , OsString.stripPrefix - , OsString.uncons + ( PLATFORM_STRING(..) + , PLATFORM_CHAR(..) + , module OsString ) #else - ( System.OsString.Compat.PLATFORM_NAME.all + ( 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 @@ -52,11 +43,12 @@ module System.OsString.Compat.PLATFORM_NAME #endif where +import Data.Data (Data) +import System.OsString.Internal.Types (PLATFORM_STRING(..), PLATFORM_CHAR(..)) import System.OsString.PLATFORM_NAME as OsString #if !MIN_VERSION_os_string(2,0,0) import Data.Coerce (coerce) -import System.OsString.Internal.Types (PLATFORM_STRING(..), PLATFORM_CHAR(..)) #if IS_WINDOWS import qualified System.OsPath.Data.ByteString.Short.Word16 as BSP @@ -65,6 +57,8 @@ import qualified System.OsPath.Data.ByteString.Short as BSP #endif #endif +deriving instance Data PLATFORM_STRING + #if !MIN_VERSION_os_string(2,0,0) all :: (PLATFORM_CHAR -> Bool) -> PLATFORM_STRING -> Bool all = coerce BSP.all diff --git a/compat/System/OsString/Compat/Posix.hs b/os-string-compat/System/OsString/Compat/Posix.hs similarity index 100% rename from compat/System/OsString/Compat/Posix.hs rename to os-string-compat/System/OsString/Compat/Posix.hs diff --git a/compat/System/OsString/Compat/Windows.hs b/os-string-compat/System/OsString/Compat/Windows.hs similarity index 100% rename from compat/System/OsString/Compat/Windows.hs rename to os-string-compat/System/OsString/Compat/Windows.hs diff --git a/path.cabal b/path.cabal index d8a2570..da2d17e 100644 --- a/path.cabal +++ b/path.cabal @@ -13,7 +13,7 @@ build-type: Simple 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 - , compat/System/OsString/Compat/Include.hs + , os-string-compat/System/OsString/Compat/Include.hs , src/Path/Include.hs , src/Path/Internal/Include.hs , src/OsPath/Include.hs @@ -74,21 +74,15 @@ library , deepseq , exceptions >= 0.4 && < 0.11 , hashable >= 1.2 && < 1.5 - , path:compat + , path:os-string-compat , text , template-haskell + , filepath >= 1.4.100.0 - if flag(old-os-string) - build-depends: filepath >= 1.4.100.0 - , os-string < 2.0.0 - else - build-depends: filepath >= 1.5.0.0 - , os-string >= 2.0.0 - -library compat +library os-string-compat import: language - hs-source-dirs: compat + hs-source-dirs: os-string-compat visibility: private exposed-modules: System.OsString.Compat.Posix @@ -100,8 +94,7 @@ library compat build-depends: filepath >= 1.4.100.0 , os-string < 2.0.0 else - build-depends: filepath >= 1.5.0.0 - , os-string >= 2.0.0 + build-depends: os-string >= 2.0.0 test-suite test import: language @@ -147,9 +140,8 @@ test-suite test-ospath , exceptions , filepath , hspec >= 2.0 && < 3 - , os-string , path - , path:compat + , path:os-string-compat , template-haskell test-suite validity-test @@ -189,9 +181,8 @@ test-suite validity-test-ospath , genvalidity >= 1.0 , genvalidity-hspec >= 0.7 , hspec >= 2.0 && < 3 - , os-string , path - , path:compat + , path:os-string-compat , validity-bytestring >=0.4.1.0 source-repository head diff --git a/src/OsPath/Include.hs b/src/OsPath/Include.hs index 0bb373d..3c7684d 100644 --- a/src/OsPath/Include.hs +++ b/src/OsPath/Include.hs @@ -27,8 +27,6 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} -{-# OPTIONS_GHC -Wno-deprecations #-} - module OsPath.PLATFORM_NAME (-- * Types Path @@ -119,11 +117,10 @@ 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 System.OsString.PLATFORM_NAME (PLATFORM_STRING) -import qualified System.OsString.PLATFORM_NAME as OsString import OsPath.Internal.PLATFORM_NAME -import qualified System.OsString.Compat.PLATFORM_NAME as OsString.Compat +import System.OsString.Compat.PLATFORM_NAME (PLATFORM_STRING) +import qualified System.OsString.Compat.PLATFORM_NAME as OsString -------------------------------------------------------------------------------- -- Types @@ -282,10 +279,10 @@ infixr 5 stripProperPrefix :: MonadThrow m => Path b Dir -> Path b t -> m (Path Rel t) stripProperPrefix (Path p) (Path l) = - case OsString.Compat.stripPrefix p l of + case OsString.stripPrefix p l of Nothing -> throwM (NotAProperPrefix p l) Just result - | OsString.Compat.null result -> throwM (NotAProperPrefix p l) + | 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 @@ -329,7 +326,7 @@ replaceProperPrefix src dst fp = (dst ) <$> stripProperPrefix src fp -- parent :: Path b t -> Path b Dir parent (Path fp) - | OsString.Compat.null fp = Path OsString.Compat.empty + | OsString.null fp = Path OsString.empty | OsPath.isDrive fp = Path fp | otherwise = Path @@ -342,7 +339,7 @@ parent (Path fp) splitDrive :: Path Abs t -> (Path Abs Dir, Maybe (Path Rel t)) splitDrive (Path fp) = let (d, rest) = OsPath.splitDrive fp - mRest = if OsString.Compat.null rest then Nothing else Just (Path rest) + 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. @@ -382,8 +379,8 @@ filename (Path l) = -- dirname :: Path b Dir -> Path Rel Dir dirname (Path l) - | OsString.Compat.null l = Path OsString.Compat.empty - | OsPath.isDrive l = Path OsString.Compat.empty + | 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 @@ -420,28 +417,28 @@ dirname (Path l) -- @since 0.7.0 splitExtension :: MonadThrow m => Path b File -> m (Path b File, PLATFORM_STRING) splitExtension (Path ospath) = - if OsString.Compat.null nameDot - || OsString.Compat.null name - || OsString.Compat.null ext + 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.Compat.singleton OsPath.extSeparator <> ext + , 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.Compat.spanEnd isSep str - (oneSep, rest) = OsString.Compat.breakEnd isSep withoutTrailingSeps + 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.Compat.init nameDot + 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: @@ -484,26 +481,26 @@ addExtension :: MonadThrow m -> 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.Compat.uncons ext of + (sep, xtn) <- case OsString.uncons ext of Nothing -> throwM $ InvalidExtension ext Just result -> pure result - let withoutTrailingSeps = OsString.Compat.dropWhileEnd OsPath.isExtSeparator xtn + 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.Compat.any OsPath.isPathSeparator xtn) $ + when (OsString.any OsPath.isPathSeparator xtn) $ throwM $ InvalidExtension ext -- All "."s is not a valid extension - when (OsString.Compat.null withoutTrailingSeps) $ + when (OsString.null withoutTrailingSeps) $ throwM $ InvalidExtension ext -- Cannot have "."s except in trailing position - when (OsString.Compat.any OsPath.isExtSeparator withoutTrailingSeps) $ + when (OsString.any OsPath.isExtSeparator withoutTrailingSeps) $ throwM $ InvalidExtension ext -- Must be valid as a filename diff --git a/src/OsPath/Internal/Include.hs b/src/OsPath/Internal/Include.hs index 7c85ceb..765015d 100644 --- a/src/OsPath/Internal/Include.hs +++ b/src/OsPath/Internal/Include.hs @@ -9,12 +9,8 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-deprecations #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -- | Internal types and functions. module OsPath.Internal.PLATFORM_NAME @@ -55,10 +51,9 @@ 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.Internal.Types (PLATFORM_STRING(..)) -import qualified System.OsString.PLATFORM_NAME as OsString -import qualified System.OsString.Compat.PLATFORM_NAME as OsString.Compat +import System.OsString.Compat.PLATFORM_NAME (PLATFORM_STRING) +import qualified System.OsString.Compat.PLATFORM_NAME as OsString -- | Path of some base and type. -- @@ -142,7 +137,7 @@ instance forall b t. (Typeable b, Typeable t) => TH.Lift (Path b t) where -- the filepath package. toOsPath :: Path b t -> PLATFORM_PATH toOsPath (Path ospath) - | OsString.Compat.null ospath = relRoot + | OsString.null ospath = relRoot | otherwise = ospath -------------------------------------------------------------------------------- @@ -167,16 +162,16 @@ isValidAbsFile ospath = isValidRelDir :: PLATFORM_PATH -> Bool isValidRelDir ospath = not (OsPath.isAbsolute ospath) && - not (OsString.Compat.null ospath) && + not (OsString.null ospath) && not (hasParentDir ospath) && - not (OsString.Compat.all OsPath.isPathSeparator 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.Compat.null ospath) && + not (OsString.null ospath) && not (hasParentDir ospath) && not (OsPath.hasTrailingPathSeparator ospath) && ospath /= [OsPath.pstr|.|] && @@ -187,16 +182,16 @@ isValidRelFile ospath = hasParentDir :: PLATFORM_PATH -> Bool hasParentDir ospath = (ospath' == [OsString.pstr|..|]) || - (prefix' `OsString.Compat.isPrefixOf` ospath') || - (infix' `OsString.Compat.isInfixOf` ospath') || - (suffix' `OsString.Compat.isSuffixOf` ospath') + (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.Compat.map normSep ospath + ospath' = OsString.map normSep ospath normSep c | OsPath.isPathSeparator c = OsPath.pathSeparator | otherwise = c @@ -210,33 +205,33 @@ hasParentDir ospath = -- | Normalizes seps only at the beginning of a path. normalizeLeadingSeps :: PLATFORM_PATH -> PLATFORM_PATH normalizeLeadingSeps path = normLeadingSep <> rest - where (leadingSeps, rest) = OsString.Compat.span OsPath.isPathSeparator path + where (leadingSeps, rest) = OsString.span OsPath.isPathSeparator path normLeadingSep - | OsString.Compat.null leadingSeps = OsString.Compat.empty - | otherwise = OsString.Compat.singleton OsPath.pathSeparator + | 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.Compat.spanEnd OsPath.isPathSeparator path + where (rest, trailingSeps) = OsString.spanEnd OsPath.isPathSeparator path normTrailingSep - | OsString.Compat.null trailingSeps = OsString.Compat.empty - | otherwise = OsString.Compat.singleton OsPath.pathSeparator + | 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.Compat.empty +normalizeAllSeps = go OsString.empty where go !acc ospath - | OsString.Compat.null ospath = acc + | OsString.null ospath = acc | otherwise = let (leadingSeps, withoutLeadingSeps) = - OsString.Compat.span OsPath.isPathSeparator ospath + OsString.span OsPath.isPathSeparator ospath (name, rest) = - OsString.Compat.break OsPath.isPathSeparator withoutLeadingSeps - sep = if OsString.Compat.null leadingSeps - then OsString.Compat.empty - else OsString.Compat.singleton OsPath.pathSeparator + 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 @@ -245,9 +240,9 @@ normalizeAllSeps = go OsString.Compat.empty -- paths. normalizeWindowsSeps :: PLATFORM_PATH -> PLATFORM_PATH normalizeWindowsSeps path = normLeadingSeps <> normalizeAllSeps rest - where (leadingSeps, rest) = OsString.Compat.span OsPath.isPathSeparator path - normLeadingSeps = OsString.Compat.replicate - (min 2 (OsString.Compat.length leadingSeps)) + where (leadingSeps, rest) = OsString.span OsPath.isPathSeparator path + normLeadingSeps = OsString.replicate + (min 2 (OsString.length leadingSeps)) OsPath.pathSeparator #endif @@ -268,7 +263,7 @@ normalizeDir = where -- Represent a "." in relative dir path as "" internally so that it -- composes without having to renormalize the path. normalizeRelDir p - | p == relRoot = OsString.Compat.empty + | p == relRoot = OsString.empty | otherwise = p -- | Applies platform-specific sep normalization following @OsPath.normalise@. @@ -283,14 +278,15 @@ normalizeFile = normalizeLeadingSeps . OsPath.normalise -- Other helper functions extSep :: PLATFORM_STRING -extSep = $(TH.lift (OsString.Compat.singleton OsPath.extSeparator)) +extSep = $(TH.lift (OsString.singleton OsPath.extSeparator)) pathSep :: PLATFORM_STRING -pathSep = $(TH.lift (OsString.Compat.singleton OsPath.pathSeparator)) +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.Compat.singleton OsPath.pathSeparator)) +relRoot = + $(TH.lift ([OsPath.pstr|.|] <> OsString.singleton OsPath.pathSeparator)) isWindows :: Bool #if IS_WINDOWS @@ -299,8 +295,3 @@ isWindows = True isWindows = False #endif {-# INLINE isWindows #-} - --------------------------------------------------------------------------------- --- Orphan instances - -deriving instance Data PLATFORM_STRING diff --git a/test-ospath/Common/Include.hs b/test-ospath/Common/Include.hs index 96f3523..cce3510 100644 --- a/test-ospath/Common/Include.hs +++ b/test-ospath/Common/Include.hs @@ -8,8 +8,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-deprecations #-} - -- | Test functions that are common to Posix and Windows module Common.PLATFORM_NAME (spec @@ -26,13 +24,12 @@ 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 System.OsString.PLATFORM_NAME (PLATFORM_STRING) -import qualified System.OsString.PLATFORM_NAME as OsString import Test.Hspec import OsPath.PLATFORM_NAME import OsPath.Internal.PLATFORM_NAME -import qualified System.OsString.Compat.PLATFORM_NAME as OsString.Compat +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|.|] @@ -229,7 +226,8 @@ extensionOperations = do forM_ dirnames $ \dir -> do forM_ filenames $ \file -> do forM_ validExtensions $ \ext -> do - let ospath = dir <> OsString.Compat.singleton OsPath.pathSeparator <> file + let ospath = + dir <> OsString.singleton OsPath.pathSeparator <> file runTests parseRelFile ospath ext describe "Absolute dir paths" $ diff --git a/test-ospath/Posix.hs b/test-ospath/Posix.hs index dd18c1b..eaa1484 100644 --- a/test-ospath/Posix.hs +++ b/test-ospath/Posix.hs @@ -3,19 +3,17 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuasiQuotes #-} -{-# OPTIONS_GHC -Wno-deprecations #-} - -- | Test suite. module Posix (spec) where -import qualified System.OsString.Posix as OsString 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). diff --git a/test-ospath/TH/Include.hs b/test-ospath/TH/Include.hs index f9f524f..8fc564b 100644 --- a/test-ospath/TH/Include.hs +++ b/test-ospath/TH/Include.hs @@ -6,7 +6,6 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-deprecations #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} -- | Test functions to check the template haskell bits. @@ -14,10 +13,10 @@ module TH.PLATFORM_NAME where import qualified Language.Haskell.TH.Syntax as TH import System.OsPath.PLATFORM_NAME (PLATFORM_PATH) -import qualified System.OsString.PLATFORM_NAME as OsString import OsPath.Internal.PLATFORM_NAME import OsPath.PLATFORM_NAME +import qualified System.OsString.Compat.PLATFORM_NAME as OsString -- | This is a helper type class that checks that splices produce a 'Path' with -- all type variables instantiated to a type. diff --git a/test-ospath/Windows.hs b/test-ospath/Windows.hs index 592ba8c..5f10c5c 100644 --- a/test-ospath/Windows.hs +++ b/test-ospath/Windows.hs @@ -3,19 +3,17 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-deprecations #-} - -- | Test suite. module Windows (spec) where -import qualified System.OsString.Windows as OsString 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). diff --git a/validity-test-ospath/Include.hs b/validity-test-ospath/Include.hs index 9c0666d..c0885bd 100644 --- a/validity-test-ospath/Include.hs +++ b/validity-test-ospath/Include.hs @@ -4,7 +4,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wno-deprecations #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} -- | Test suite. @@ -13,13 +12,12 @@ module PLATFORM_NAME where import OsPath.PLATFORM_NAME import OsPath.Internal.PLATFORM_NAME import System.OsPath.PLATFORM_NAME (PLATFORM_PATH) -import qualified System.OsString.PLATFORM_NAME as OsString import Test.Hspec import Test.QuickCheck import Test.Validity import OsPath.Gen.PLATFORM_NAME () -import qualified System.OsString.Compat.PLATFORM_NAME as OsString.Compat +import qualified System.OsString.Compat.PLATFORM_NAME as OsString -- | Test suite entry point, returns exit failure if any test fails. main :: IO () @@ -78,9 +76,9 @@ operationFilename = do operationDirname :: Spec operationDirname = do forAllDirs "dirname parent $(mkRelDir dirname)) == dirname $(mkRelDir dirname)" $ \parent -> - forAllValid $ \dir -> if dir == Path OsString.Compat.empty then pure () else dirname (parent dir) `shouldBe` dirname dir + 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.Compat.empty + 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 @@ -126,7 +124,7 @@ operationTakeDrive = do operationIsParentOf :: Spec operationIsParentOf = do forAllParentsAndChildren "isProperPrefixOf parent (parent child)" $ \parent child -> - if child == Path OsString.Compat.empty + if child == Path OsString.empty then True -- TODO do we always need this condition? else isProperPrefixOf parent (parent child) @@ -134,7 +132,7 @@ operationIsParentOf = do operationStripDir :: Spec operationStripDir = do forAllParentsAndChildren "stripProperPrefix parent (parent child) = child" $ \parent child -> - if child == Path OsString.Compat.empty + 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 diff --git a/validity-test-ospath/OsPath/Gen/Include.hs b/validity-test-ospath/OsPath/Gen/Include.hs index 3b62c81..9b5639e 100644 --- a/validity-test-ospath/OsPath/Gen/Include.hs +++ b/validity-test-ospath/OsPath/Gen/Include.hs @@ -3,7 +3,6 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -Wno-deprecations #-} {-# OPTIONS_GHC -Wno-orphans #-} module OsPath.Gen.PLATFORM_NAME where @@ -20,11 +19,10 @@ 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 System.OsString.Internal.Types (PLATFORM_CHAR(..)) -import qualified System.OsString.PLATFORM_NAME as OsString import Test.QuickCheck -import qualified System.OsString.Compat.PLATFORM_NAME as OsString.Compat +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) = @@ -63,7 +61,7 @@ instance Validity (Path Rel Dir) where 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.Compat.null fp + parseRelDir fp == Just p || OsString.null fp ] instance Validity (SomeBase Dir) @@ -75,7 +73,7 @@ instance GenValid (Path Abs File) where shrinkValid = filter isValid . shrinkValidWith parseAbsFile instance GenValid (Path Abs Dir) where - genValid = (Path . ([OsString.pstr|/|] <>) . (<> OsString.Compat.singleton OsPath.pathSeparator) <$> genValid) `suchThat` isValid + genValid = (Path . ([OsString.pstr|/|] <>) . (<> OsString.singleton OsPath.pathSeparator) <$> genValid) `suchThat` isValid shrinkValid = filter isValid . shrinkValidWith parseAbsDir instance GenValid (Path Rel File) where @@ -83,7 +81,7 @@ instance GenValid (Path Rel File) where shrinkValid = filter isValid . shrinkValidWith parseRelFile instance GenValid (Path Rel Dir) where - genValid = (Path . (<> OsString.Compat.singleton OsPath.pathSeparator) <$> genValid) `suchThat` isValid + genValid = (Path . (<> OsString.singleton OsPath.pathSeparator) <$> genValid) `suchThat` isValid shrinkValid = filter isValid . shrinkValidWith parseRelDir instance GenValid (SomeBase Dir) where @@ -97,7 +95,7 @@ instance GenValid (SomeBase File) where 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.Compat.null fp + OsPath.isValid fp || OsString.null fp , declare "The path does not contain a '..' path component." $ not (hasParentDir fp) ] @@ -105,7 +103,7 @@ validateCommon (Path fp) = mconcat 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.Compat.null fp + OsPath.hasTrailingPathSeparator fp || OsString.null fp ] validateFile :: Path b File -> Validation @@ -115,7 +113,7 @@ validateFile (Path fp) = mconcat , declare "The path does not equal \".\"" $ fp /= [OsString.pstr|.|] , declare "The path does not end in /." $ - not ([OsString.pstr|/.|] `OsString.Compat.isSuffixOf` fp) + not ([OsString.pstr|/.|] `OsString.isSuffixOf` fp) ] validateAbs :: Path Abs t -> Validation @@ -156,7 +154,7 @@ instance GenValid PLATFORM_PATH where . OsPath.unpack $ relative shrinkedWithDrive = - if OsString.Compat.null drive + if OsString.null drive then [] else map (drive <>) shrinkedWithoutDrive in From 37061452b1efa4e91b064ba5ef3a0b9355972a87 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Tue, 30 Jul 2024 10:13:49 +0200 Subject: [PATCH 44/52] Conditional filepath dependency for main library --- path.cabal | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/path.cabal b/path.cabal index da2d17e..46567f3 100644 --- a/path.cabal +++ b/path.cabal @@ -77,7 +77,11 @@ library , path:os-string-compat , text , template-haskell - , filepath >= 1.4.100.0 + + if flag(old-os-string) + build-depends: filepath >= 1.4.100.0 && <1.5 + else + build-depends: filepath >= 1.5 library os-string-compat import: language From 56fb8cb7582159fd1f5a95cc93d871ff7fb8ea89 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Tue, 30 Jul 2024 10:25:05 +0200 Subject: [PATCH 45/52] Added Stack configuration for +old-os-string --- stack.old.yaml | 13 +++++++++++ stack.old.yaml.lock | 54 +++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 67 insertions(+) create mode 100644 stack.old.yaml create mode 100644 stack.old.yaml.lock diff --git a/stack.old.yaml b/stack.old.yaml new file mode 100644 index 0000000..0a55d9f --- /dev/null +++ b/stack.old.yaml @@ -0,0 +1,13 @@ +resolver: lts-22.31 # GHC 9.6.6 + +extra-deps: + - data-fix-0.3.2 + - hashable-1.4.3.0 + - semialign-1.3 + - text-short-0.1.5 + - these-1.2 + - os-string-1.0.0@sha256:f1582da15c52761681da87d98c854a0db54049f34d59f74cfec4cc56ad8fbc05,1852 + +flags: + path: + old-os-string: true diff --git a/stack.old.yaml.lock b/stack.old.yaml.lock new file mode 100644 index 0000000..f186c46 --- /dev/null +++ b/stack.old.yaml.lock @@ -0,0 +1,54 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: data-fix-0.3.2@sha256:cd7d6ff8b68aca3b51d8116870fc8ccdbc557989562cd3d5c941e4f0b7bc5af1,1734 + pantry-tree: + sha256: 39ea2bb3ace2b61bf72e7df77948f7fccc67c70d12a11e35dd20744eec5dd0bf + size: 262 + original: + hackage: data-fix-0.3.2 +- completed: + hackage: hashable-1.4.3.0@sha256:f3bf68acfa0df7a064a378ef2cdcfeb55e6fb96100675f4c593556dcbf3d7194,4718 + pantry-tree: + sha256: abef0611d6a717ba351317bdb603ef536659e7767a49ba81b2dbe20994065c7d + size: 1248 + original: + hackage: hashable-1.4.3.0 +- completed: + hackage: semialign-1.3@sha256:7be9ef5ca1d6b052991f68c053aab68b9d1ab3b1938c9557ac84c97937815223,2888 + pantry-tree: + sha256: e5daa7e0023dabb1b21a04bf084364b94e45e81b380e950b90f51294a1990b87 + size: 537 + original: + hackage: semialign-1.3 +- completed: + hackage: text-short-0.1.5@sha256:9c73c9c9182ca69ee92ce3758f515b1c078cd167d882ccc8c46f92f68c65e190,3216 + pantry-tree: + sha256: d3dcfee9029cd3624a788a0e65f0dea588ae0446a8a75a27d6b6164b8ee0fd57 + size: 727 + original: + hackage: text-short-0.1.5 +- completed: + hackage: these-1.2@sha256:011e22f6891ca028f87c04ea48796696c92d593313a9c699f7ff4f9ffd7aec6e,2882 + pantry-tree: + sha256: 37483703ce7326c07608b06f2f741fb0f708cb06bd10ec57d87108d068046b05 + size: 351 + original: + hackage: these-1.2 +- completed: + hackage: os-string-1.0.0@sha256:f1582da15c52761681da87d98c854a0db54049f34d59f74cfec4cc56ad8fbc05,1852 + pantry-tree: + sha256: 75321cadad8a67becb5fc36bdd974a6db3746dcbe0235bf9ec0f0baaad7b4a23 + size: 207 + original: + hackage: os-string-1.0.0@sha256:f1582da15c52761681da87d98c854a0db54049f34d59f74cfec4cc56ad8fbc05,1852 +snapshots: +- completed: + sha256: acaab6ca693211938d1542abcb1c83a2f298b9f6b571854a9d38febe39b6408e + size: 719577 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/31.yaml + original: lts-22.31 From 0fb94c9bd166c4d9fc0fcd5a0848c42278117c84 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 9 Aug 2024 23:01:47 +0200 Subject: [PATCH 46/52] Better backwards compatibility --- .../System/OsString/Compat/Include.hs | 14 +++-- path.cabal | 16 +++--- stack.old.yaml | 13 ----- stack.old.yaml.lock | 54 ------------------- stack.os-string.yaml | 15 ++++++ stack.os-string.yaml.lock | 40 ++++++++++++++ stack.yaml | 19 +++---- stack.yaml.lock | 47 +++++++++------- 8 files changed, 107 insertions(+), 111 deletions(-) delete mode 100644 stack.old.yaml delete mode 100644 stack.old.yaml.lock create mode 100644 stack.os-string.yaml create mode 100644 stack.os-string.yaml.lock diff --git a/os-string-compat/System/OsString/Compat/Include.hs b/os-string-compat/System/OsString/Compat/Include.hs index d5a6640..9828f71 100644 --- a/os-string-compat/System/OsString/Compat/Include.hs +++ b/os-string-compat/System/OsString/Compat/Include.hs @@ -10,8 +10,16 @@ {-# OPTIONS_GHC -Wno-deprecations #-} {-# OPTIONS_GHC -Wno-orphans #-} -module System.OsString.Compat.PLATFORM_NAME +#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 @@ -47,7 +55,7 @@ import Data.Data (Data) import System.OsString.Internal.Types (PLATFORM_STRING(..), PLATFORM_CHAR(..)) import System.OsString.PLATFORM_NAME as OsString -#if !MIN_VERSION_os_string(2,0,0) +#if !USE_os_string import Data.Coerce (coerce) #if IS_WINDOWS @@ -59,7 +67,7 @@ import qualified System.OsPath.Data.ByteString.Short as BSP deriving instance Data PLATFORM_STRING -#if !MIN_VERSION_os_string(2,0,0) +#if !USE_os_string all :: (PLATFORM_CHAR -> Bool) -> PLATFORM_STRING -> Bool all = coerce BSP.all diff --git a/path.cabal b/path.cabal index 46567f3..6561a16 100644 --- a/path.cabal +++ b/path.cabal @@ -28,7 +28,7 @@ flag dev manual: True default: False -flag old-os-string +flag os-string description: Use an older version of the os-string library. manual: False default: False @@ -78,10 +78,10 @@ library , text , template-haskell - if flag(old-os-string) - build-depends: filepath >= 1.4.100.0 && <1.5 - else + if flag(os-string) build-depends: filepath >= 1.5 + else + build-depends: filepath >= 1.4.100.0 && <1.5 library os-string-compat import: language @@ -94,11 +94,11 @@ library os-string-compat build-depends: base >= 4.12 && < 5 - if flag(old-os-string) - build-depends: filepath >= 1.4.100.0 - , os-string < 2.0.0 - else + if flag(os-string) build-depends: os-string >= 2.0.0 + else + build-depends: filepath >= 1.4.100.0 + -- , os-string < 2.0.0 test-suite test import: language diff --git a/stack.old.yaml b/stack.old.yaml deleted file mode 100644 index 0a55d9f..0000000 --- a/stack.old.yaml +++ /dev/null @@ -1,13 +0,0 @@ -resolver: lts-22.31 # GHC 9.6.6 - -extra-deps: - - data-fix-0.3.2 - - hashable-1.4.3.0 - - semialign-1.3 - - text-short-0.1.5 - - these-1.2 - - os-string-1.0.0@sha256:f1582da15c52761681da87d98c854a0db54049f34d59f74cfec4cc56ad8fbc05,1852 - -flags: - path: - old-os-string: true diff --git a/stack.old.yaml.lock b/stack.old.yaml.lock deleted file mode 100644 index f186c46..0000000 --- a/stack.old.yaml.lock +++ /dev/null @@ -1,54 +0,0 @@ -# This file was autogenerated by Stack. -# You should not edit this file by hand. -# For more information, please see the documentation at: -# https://docs.haskellstack.org/en/stable/lock_files - -packages: -- completed: - hackage: data-fix-0.3.2@sha256:cd7d6ff8b68aca3b51d8116870fc8ccdbc557989562cd3d5c941e4f0b7bc5af1,1734 - pantry-tree: - sha256: 39ea2bb3ace2b61bf72e7df77948f7fccc67c70d12a11e35dd20744eec5dd0bf - size: 262 - original: - hackage: data-fix-0.3.2 -- completed: - hackage: hashable-1.4.3.0@sha256:f3bf68acfa0df7a064a378ef2cdcfeb55e6fb96100675f4c593556dcbf3d7194,4718 - pantry-tree: - sha256: abef0611d6a717ba351317bdb603ef536659e7767a49ba81b2dbe20994065c7d - size: 1248 - original: - hackage: hashable-1.4.3.0 -- completed: - hackage: semialign-1.3@sha256:7be9ef5ca1d6b052991f68c053aab68b9d1ab3b1938c9557ac84c97937815223,2888 - pantry-tree: - sha256: e5daa7e0023dabb1b21a04bf084364b94e45e81b380e950b90f51294a1990b87 - size: 537 - original: - hackage: semialign-1.3 -- completed: - hackage: text-short-0.1.5@sha256:9c73c9c9182ca69ee92ce3758f515b1c078cd167d882ccc8c46f92f68c65e190,3216 - pantry-tree: - sha256: d3dcfee9029cd3624a788a0e65f0dea588ae0446a8a75a27d6b6164b8ee0fd57 - size: 727 - original: - hackage: text-short-0.1.5 -- completed: - hackage: these-1.2@sha256:011e22f6891ca028f87c04ea48796696c92d593313a9c699f7ff4f9ffd7aec6e,2882 - pantry-tree: - sha256: 37483703ce7326c07608b06f2f741fb0f708cb06bd10ec57d87108d068046b05 - size: 351 - original: - hackage: these-1.2 -- completed: - hackage: os-string-1.0.0@sha256:f1582da15c52761681da87d98c854a0db54049f34d59f74cfec4cc56ad8fbc05,1852 - pantry-tree: - sha256: 75321cadad8a67becb5fc36bdd974a6db3746dcbe0235bf9ec0f0baaad7b4a23 - size: 207 - original: - hackage: os-string-1.0.0@sha256:f1582da15c52761681da87d98c854a0db54049f34d59f74cfec4cc56ad8fbc05,1852 -snapshots: -- completed: - sha256: acaab6ca693211938d1542abcb1c83a2f298b9f6b571854a9d38febe39b6408e - size: 719577 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/31.yaml - original: lts-22.31 diff --git a/stack.os-string.yaml b/stack.os-string.yaml new file mode 100644 index 0000000..cd45341 --- /dev/null +++ b/stack.os-string.yaml @@ -0,0 +1,15 @@ +resolver: lts-22.32 # GHC 9.6.6 + +extra-deps: + - directory-1.3.8.5@sha256:fbeec9ec346e5272167f63dcb86af513b457a7b9fc36dc818e4c7b81608d612b,3166 + - filepath-1.5.3.0@sha256:0c64bc9a4f5946c86a8f0527bf40c8ba51e2c02d36eea0e20ea558c8d94166e8,4945 + - process-1.6.20.0@sha256:2a9393de33f18415fb8f4826957a87a94ffe8840ca8472a9b69dca6de45aca03,2790 + - unix-2.8.5.1@sha256:3f702a252a313a7bcb56e3908a14e7f9f1b40e41b7bdc8ae8a9605a1a8686f06,9808 + +flags: + directory: + os-string: true + path: + os-string: true + unix: + os-string: true diff --git a/stack.os-string.yaml.lock b/stack.os-string.yaml.lock new file mode 100644 index 0000000..a491c94 --- /dev/null +++ b/stack.os-string.yaml.lock @@ -0,0 +1,40 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: directory-1.3.8.5@sha256:fbeec9ec346e5272167f63dcb86af513b457a7b9fc36dc818e4c7b81608d612b,3166 + pantry-tree: + sha256: d11130a0ca9e7c8720ed1ceef4e2f0d9be4b446e67e7d15d634763a5c952877e + size: 3519 + original: + hackage: directory-1.3.8.5@sha256:fbeec9ec346e5272167f63dcb86af513b457a7b9fc36dc818e4c7b81608d612b,3166 +- completed: + hackage: filepath-1.5.3.0@sha256:0c64bc9a4f5946c86a8f0527bf40c8ba51e2c02d36eea0e20ea558c8d94166e8,4945 + pantry-tree: + sha256: a5feb33f17ff131a5bba009abae35761594d62ba6873b2f70992a48db160c9b7 + size: 2274 + original: + hackage: filepath-1.5.3.0@sha256:0c64bc9a4f5946c86a8f0527bf40c8ba51e2c02d36eea0e20ea558c8d94166e8,4945 +- completed: + hackage: process-1.6.20.0@sha256:2a9393de33f18415fb8f4826957a87a94ffe8840ca8472a9b69dca6de45aca03,2790 + pantry-tree: + sha256: 14d1e9a5ec731766e43c7eb9c2dc59a7da48d98d43374d9d83e725d8891c6173 + size: 1789 + original: + hackage: process-1.6.20.0@sha256:2a9393de33f18415fb8f4826957a87a94ffe8840ca8472a9b69dca6de45aca03,2790 +- completed: + hackage: unix-2.8.5.1@sha256:3f702a252a313a7bcb56e3908a14e7f9f1b40e41b7bdc8ae8a9605a1a8686f06,9808 + pantry-tree: + sha256: b961320db69795a16c4ef4eebb0a3e7ddbbbe506fa1e22dde95ee8d8501bfbe5 + size: 5821 + original: + hackage: unix-2.8.5.1@sha256:3f702a252a313a7bcb56e3908a14e7f9f1b40e41b7bdc8ae8a9605a1a8686f06,9808 +snapshots: +- completed: + sha256: 417fa04a2ed8916cdae74c475ff97ac80857fed5000f19dce4f9564b5e635294 + size: 720000 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/32.yaml + original: lts-22.32 diff --git a/stack.yaml b/stack.yaml index 36be99a..32ff23b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,15 +1,8 @@ -resolver: lts-22.31 # GHC 9.6.6 +resolver: lts-22.32 # GHC 9.6.6 extra-deps: - - directory-1.3.8.5@sha256:fbeec9ec346e5272167f63dcb86af513b457a7b9fc36dc818e4c7b81608d612b,3166 - - filepath-1.5.3.0@sha256:0c64bc9a4f5946c86a8f0527bf40c8ba51e2c02d36eea0e20ea558c8d94166e8,4945 - - process-1.6.20.0@sha256:2a9393de33f18415fb8f4826957a87a94ffe8840ca8472a9b69dca6de45aca03,2790 - - unix-2.8.5.1@sha256:3f702a252a313a7bcb56e3908a14e7f9f1b40e41b7bdc8ae8a9605a1a8686f06,9808 - -flags: - directory: - os-string: true - path: - old-os-string: false - unix: - os-string: true + - data-fix-0.3.2 + - hashable-1.4.3.0 + - semialign-1.3 + - text-short-0.1.5 + - these-1.2 diff --git a/stack.yaml.lock b/stack.yaml.lock index cf92b1f..6977cff 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -5,36 +5,43 @@ packages: - completed: - hackage: directory-1.3.8.5@sha256:fbeec9ec346e5272167f63dcb86af513b457a7b9fc36dc818e4c7b81608d612b,3166 + hackage: data-fix-0.3.2@sha256:cd7d6ff8b68aca3b51d8116870fc8ccdbc557989562cd3d5c941e4f0b7bc5af1,1734 pantry-tree: - sha256: d11130a0ca9e7c8720ed1ceef4e2f0d9be4b446e67e7d15d634763a5c952877e - size: 3519 + sha256: 39ea2bb3ace2b61bf72e7df77948f7fccc67c70d12a11e35dd20744eec5dd0bf + size: 262 original: - hackage: directory-1.3.8.5@sha256:fbeec9ec346e5272167f63dcb86af513b457a7b9fc36dc818e4c7b81608d612b,3166 + hackage: data-fix-0.3.2 - completed: - hackage: filepath-1.5.3.0@sha256:0c64bc9a4f5946c86a8f0527bf40c8ba51e2c02d36eea0e20ea558c8d94166e8,4945 + hackage: hashable-1.4.3.0@sha256:f3bf68acfa0df7a064a378ef2cdcfeb55e6fb96100675f4c593556dcbf3d7194,4718 pantry-tree: - sha256: a5feb33f17ff131a5bba009abae35761594d62ba6873b2f70992a48db160c9b7 - size: 2274 + sha256: abef0611d6a717ba351317bdb603ef536659e7767a49ba81b2dbe20994065c7d + size: 1248 original: - hackage: filepath-1.5.3.0@sha256:0c64bc9a4f5946c86a8f0527bf40c8ba51e2c02d36eea0e20ea558c8d94166e8,4945 + hackage: hashable-1.4.3.0 - completed: - hackage: process-1.6.20.0@sha256:2a9393de33f18415fb8f4826957a87a94ffe8840ca8472a9b69dca6de45aca03,2790 + hackage: semialign-1.3@sha256:7be9ef5ca1d6b052991f68c053aab68b9d1ab3b1938c9557ac84c97937815223,2888 pantry-tree: - sha256: 14d1e9a5ec731766e43c7eb9c2dc59a7da48d98d43374d9d83e725d8891c6173 - size: 1789 + sha256: e5daa7e0023dabb1b21a04bf084364b94e45e81b380e950b90f51294a1990b87 + size: 537 original: - hackage: process-1.6.20.0@sha256:2a9393de33f18415fb8f4826957a87a94ffe8840ca8472a9b69dca6de45aca03,2790 + hackage: semialign-1.3 - completed: - hackage: unix-2.8.5.1@sha256:3f702a252a313a7bcb56e3908a14e7f9f1b40e41b7bdc8ae8a9605a1a8686f06,9808 + hackage: text-short-0.1.5@sha256:9c73c9c9182ca69ee92ce3758f515b1c078cd167d882ccc8c46f92f68c65e190,3216 pantry-tree: - sha256: b961320db69795a16c4ef4eebb0a3e7ddbbbe506fa1e22dde95ee8d8501bfbe5 - size: 5821 + sha256: d3dcfee9029cd3624a788a0e65f0dea588ae0446a8a75a27d6b6164b8ee0fd57 + size: 727 original: - hackage: unix-2.8.5.1@sha256:3f702a252a313a7bcb56e3908a14e7f9f1b40e41b7bdc8ae8a9605a1a8686f06,9808 + hackage: text-short-0.1.5 +- completed: + hackage: these-1.2@sha256:011e22f6891ca028f87c04ea48796696c92d593313a9c699f7ff4f9ffd7aec6e,2882 + pantry-tree: + sha256: 37483703ce7326c07608b06f2f741fb0f708cb06bd10ec57d87108d068046b05 + size: 351 + original: + hackage: these-1.2 snapshots: - completed: - sha256: acaab6ca693211938d1542abcb1c83a2f298b9f6b571854a9d38febe39b6408e - size: 719577 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/31.yaml - original: lts-22.31 + sha256: 417fa04a2ed8916cdae74c475ff97ac80857fed5000f19dce4f9564b5e635294 + size: 720000 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/32.yaml + original: lts-22.32 From 1c000eedb4ad721ca9082b038872f9783563384e Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 9 Aug 2024 23:06:55 +0200 Subject: [PATCH 47/52] Updated CI: Test Stack build with os-string flag --- .github/workflows/ci.yaml | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 08577ae..5e14b85 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -70,6 +70,9 @@ jobs: strategy: matrix: ghc: ["9.10.1"] + stack-yaml: + - "stack.yaml" + - "stack.os-string.yaml" steps: - name: Clone project @@ -83,15 +86,15 @@ jobs: - name: Install dependencies run: | - stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --only-dependencies + stack --stack-yaml "${{ matrix.stack-yaml }}" build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --only-dependencies - name: Build run: | - stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks + stack --stack-yaml "${{ matrix.stack-yaml }}" build --system-ghc --test --bench --no-run-tests --no-run-benchmarks - name: Test the test-suite test run: | - stack test path:test:test --system-ghc + stack --stack-yaml "${{ matrix.stack-yaml }}" test path:test:test --system-ghc # - name: Test the test-suite validity-test # run: | From c105f7617ccf045ca5b88fa5a3e360b4bc8afa7f Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 9 Aug 2024 23:15:00 +0200 Subject: [PATCH 48/52] Updated CI: Better cache keys --- .github/workflows/ci.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 5e14b85..1d85179 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -44,7 +44,7 @@ jobs: name: Cache ~/.cabal/store with: path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} - key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} + key: ${{ runner.os }}-${{ matrix.ghc }}-cabal-${{ hashFiles('cabal.project.freeze') }} - name: Install dependencies run: | @@ -82,7 +82,7 @@ jobs: uses: actions/cache@v3 with: path: ~/.stack - key: ${{ runner.os }}-${{ matrix.ghc }}-stack + key: ${{ runner.os }}-${{ matrix.ghc }}-stack-${{ hashFiles(format('{0}.lock', matrix.stack-yaml)) }} - name: Install dependencies run: | From 383ce37312295a61a2bba510affa1fbcbd14fa8c Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 9 Aug 2024 23:16:38 +0200 Subject: [PATCH 49/52] Updated CI: Better naming of stack jobs --- .github/workflows/ci.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 1d85179..cfe8cee 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -65,7 +65,7 @@ jobs: # As of 2024-07-29, the GitHub-hosted runner on ubuntu-latest comes with # Stack 2.15.7 and GHC 9.10.1. stack: - name: stack / ghc ${{ matrix.ghc }} + name: "stack / ghc ${{ matrix.ghc }} (${{ matrix.stack-yaml }})" runs-on: ubuntu-latest strategy: matrix: From 9b2bbe143f49ef4ec1bdb3dc3ea51573dd0cfa21 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 9 Aug 2024 23:36:08 +0200 Subject: [PATCH 50/52] Updated CI: Use actions/cache@v4 --- .github/workflows/ci.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index cfe8cee..65ea339 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -40,7 +40,7 @@ jobs: run: | cabal freeze - - uses: actions/cache@v3 + - uses: actions/cache@v4 name: Cache ~/.cabal/store with: path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} @@ -79,7 +79,7 @@ jobs: uses: actions/checkout@v4 - name: Cache Stack root - uses: actions/cache@v3 + uses: actions/cache@v4 with: path: ~/.stack key: ${{ runner.os }}-${{ matrix.ghc }}-stack-${{ hashFiles(format('{0}.lock', matrix.stack-yaml)) }} From 7e1bf0697b97258c3757ef323b8b9acb7f1026ef Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 9 Aug 2024 23:42:05 +0200 Subject: [PATCH 51/52] Removed extra-deps from stack.yaml --- stack.os-string.yaml | 2 +- stack.os-string.yaml.lock | 8 ++++---- stack.yaml | 7 ------- stack.yaml.lock | 37 +------------------------------------ 4 files changed, 6 insertions(+), 48 deletions(-) diff --git a/stack.os-string.yaml b/stack.os-string.yaml index cd45341..a8fd199 100644 --- a/stack.os-string.yaml +++ b/stack.os-string.yaml @@ -3,7 +3,7 @@ resolver: lts-22.32 # GHC 9.6.6 extra-deps: - directory-1.3.8.5@sha256:fbeec9ec346e5272167f63dcb86af513b457a7b9fc36dc818e4c7b81608d612b,3166 - filepath-1.5.3.0@sha256:0c64bc9a4f5946c86a8f0527bf40c8ba51e2c02d36eea0e20ea558c8d94166e8,4945 - - process-1.6.20.0@sha256:2a9393de33f18415fb8f4826957a87a94ffe8840ca8472a9b69dca6de45aca03,2790 + - process-1.6.21.0@sha256:685bc68759da31b5f152092fe664e1644e84f6dc0ae7a6c143e8564a1d6dafe8,2644 - unix-2.8.5.1@sha256:3f702a252a313a7bcb56e3908a14e7f9f1b40e41b7bdc8ae8a9605a1a8686f06,9808 flags: diff --git a/stack.os-string.yaml.lock b/stack.os-string.yaml.lock index a491c94..216ac26 100644 --- a/stack.os-string.yaml.lock +++ b/stack.os-string.yaml.lock @@ -19,12 +19,12 @@ packages: original: hackage: filepath-1.5.3.0@sha256:0c64bc9a4f5946c86a8f0527bf40c8ba51e2c02d36eea0e20ea558c8d94166e8,4945 - completed: - hackage: process-1.6.20.0@sha256:2a9393de33f18415fb8f4826957a87a94ffe8840ca8472a9b69dca6de45aca03,2790 + hackage: process-1.6.21.0@sha256:685bc68759da31b5f152092fe664e1644e84f6dc0ae7a6c143e8564a1d6dafe8,2644 pantry-tree: - sha256: 14d1e9a5ec731766e43c7eb9c2dc59a7da48d98d43374d9d83e725d8891c6173 - size: 1789 + sha256: 20d200008cf22d2f0402f900e0f26df17e355947689784852a10c28f03fbbca0 + size: 1790 original: - hackage: process-1.6.20.0@sha256:2a9393de33f18415fb8f4826957a87a94ffe8840ca8472a9b69dca6de45aca03,2790 + hackage: process-1.6.21.0@sha256:685bc68759da31b5f152092fe664e1644e84f6dc0ae7a6c143e8564a1d6dafe8,2644 - completed: hackage: unix-2.8.5.1@sha256:3f702a252a313a7bcb56e3908a14e7f9f1b40e41b7bdc8ae8a9605a1a8686f06,9808 pantry-tree: diff --git a/stack.yaml b/stack.yaml index 32ff23b..6bd54bd 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,8 +1 @@ resolver: lts-22.32 # GHC 9.6.6 - -extra-deps: - - data-fix-0.3.2 - - hashable-1.4.3.0 - - semialign-1.3 - - text-short-0.1.5 - - these-1.2 diff --git a/stack.yaml.lock b/stack.yaml.lock index 6977cff..db7978f 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -3,42 +3,7 @@ # For more information, please see the documentation at: # https://docs.haskellstack.org/en/stable/lock_files -packages: -- completed: - hackage: data-fix-0.3.2@sha256:cd7d6ff8b68aca3b51d8116870fc8ccdbc557989562cd3d5c941e4f0b7bc5af1,1734 - pantry-tree: - sha256: 39ea2bb3ace2b61bf72e7df77948f7fccc67c70d12a11e35dd20744eec5dd0bf - size: 262 - original: - hackage: data-fix-0.3.2 -- completed: - hackage: hashable-1.4.3.0@sha256:f3bf68acfa0df7a064a378ef2cdcfeb55e6fb96100675f4c593556dcbf3d7194,4718 - pantry-tree: - sha256: abef0611d6a717ba351317bdb603ef536659e7767a49ba81b2dbe20994065c7d - size: 1248 - original: - hackage: hashable-1.4.3.0 -- completed: - hackage: semialign-1.3@sha256:7be9ef5ca1d6b052991f68c053aab68b9d1ab3b1938c9557ac84c97937815223,2888 - pantry-tree: - sha256: e5daa7e0023dabb1b21a04bf084364b94e45e81b380e950b90f51294a1990b87 - size: 537 - original: - hackage: semialign-1.3 -- completed: - hackage: text-short-0.1.5@sha256:9c73c9c9182ca69ee92ce3758f515b1c078cd167d882ccc8c46f92f68c65e190,3216 - pantry-tree: - sha256: d3dcfee9029cd3624a788a0e65f0dea588ae0446a8a75a27d6b6164b8ee0fd57 - size: 727 - original: - hackage: text-short-0.1.5 -- completed: - hackage: these-1.2@sha256:011e22f6891ca028f87c04ea48796696c92d593313a9c699f7ff4f9ffd7aec6e,2882 - pantry-tree: - sha256: 37483703ce7326c07608b06f2f741fb0f708cb06bd10ec57d87108d068046b05 - size: 351 - original: - hackage: these-1.2 +packages: [] snapshots: - completed: sha256: 417fa04a2ed8916cdae74c475ff97ac80857fed5000f19dce4f9564b5e635294 From 36a6cdfb551eda6e00650e228993d07eecf7ed1b Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Sun, 11 Aug 2024 13:45:48 +0200 Subject: [PATCH 52/52] Applied suggestions --- path.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/path.cabal b/path.cabal index 6561a16..6b57dda 100644 --- a/path.cabal +++ b/path.cabal @@ -98,7 +98,6 @@ library os-string-compat build-depends: os-string >= 2.0.0 else build-depends: filepath >= 1.4.100.0 - -- , os-string < 2.0.0 test-suite test import: language