filepath 1.4.100.3 → 1.4.100.4
raw patch · 12 files changed
+123/−650 lines, 12 filesdep +quickcheck-classes-basedep +tasty-benchdep −checkersPVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
Dependencies added: quickcheck-classes-base, tasty-bench
Dependencies removed: checkers
API changes (from Hackage documentation)
+ System.OsPath.Data.ByteString.Short.Internal: compareByteArraysOff :: BA -> Int -> BA -> Int -> Int -> Int
Files
- HACKING.md +1/−3
- System/FilePath/Internal.hs +7/−3
- System/OsPath/Data/ByteString/Short/Internal.hs +34/−0
- System/OsPath/Data/ByteString/Short/Word16.hs +30/−10
- bench/BenchFilePath.hs +5/−71
- bench/TastyBench.hs +0/−526
- changelog.md +4/−0
- filepath.cabal +5/−9
- tests/abstract-filepath/Arbitrary.hs +0/−12
- tests/abstract-filepath/OsPathSpec.hs +12/−16
- tests/bytestring-tests/Properties/Common.hs +23/−0
- tests/filepath-tests/TestGen.hs +2/−0
HACKING.md view
@@ -13,9 +13,7 @@ * If `Valid x =>` appears at the start of a doc test, that means the property will only be tested with `x` passing the `isValid` predicate. -The tests can be generated by `make gen` in the root of the repo, and will be placed in `tests/TestGen.hs`.+The tests can be generated by `make gen` in the root of the repo, and will be placed in `tests/filepath-tests/TestGen.hs`. The `TestGen.hs` file is checked into the repo, and the CI scripts check that `TestGen.hs` is in sync with what would be generated a fresh - if you don't regenerate `TestGen.hs` the CI will fail. -The `.ghci` file is set up to allow you to type `ghci` to open the library, then `:go` will regenerate the-tests and run them.
System/FilePath/Internal.hs view
@@ -984,6 +984,7 @@ -- > Posix: normalise "./bob/fred/" == "bob/fred/" -- > Windows: normalise "c:\\file/bob\\" == "C:\\file\\bob\\" -- > Windows: normalise "c:\\" == "C:\\"+-- > Windows: normalise "c:\\\\\\\\" == "C:\\" -- > Windows: normalise "C:.\\" == "C:" -- > Windows: normalise "\\\\server\\test" == "\\\\server\\test" -- > Windows: normalise "//server/test" == "\\\\server\\test"@@ -1035,9 +1036,12 @@ normaliseDrive bs | null bs = mempty | isPosix = pack [pathSeparator]- | otherwise = if isJust $ readDriveLetter x2- then map toUpper x2- else x2+ | Just (drv, _) <- readDriveLetter x2+ = case unpack drv of+ (x:_:[]) -> pack [toUpper x, _colon]+ (x:_) -> pack [toUpper x, _colon, pathSeparator]+ _ -> P.error "impossible"+ | otherwise = x2 where x2 = map repSlash bs repSlash x = if isPathSeparator x then pathSeparator else x
System/OsPath/Data/ByteString/Short/Internal.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE UnliftedFFITypes #-} -- | -- Module : System.OsPath.Data.ByteString.Short.Internal@@ -25,6 +26,13 @@ #if !MIN_VERSION_base(4,11,0) import Data.Semigroup ( Semigroup((<>)) )+import Foreign.C.Types+ ( CSize(..)+ , CInt(..)+ )+import Data.ByteString.Internal+ ( accursedUnutterablePerformIO+ ) #endif #if !MIN_VERSION_bytestring(0,10,9) import Foreign.Marshal.Alloc (allocaBytes)@@ -441,3 +449,29 @@ moduleError :: HasCallStack => String -> String -> a moduleError fun msg = error (moduleErrorMsg fun msg) {-# NOINLINE moduleError #-}++compareByteArraysOff :: BA -- ^ array 1+ -> Int -- ^ offset for array 1+ -> BA -- ^ array 2+ -> Int -- ^ offset for array 2+ -> Int -- ^ length to compare+ -> Int -- ^ like memcmp+#if MIN_VERSION_base(4,11,0)+compareByteArraysOff (BA# ba1#) (I# ba1off#) (BA# ba2#) (I# ba2off#) (I# len#) =+ I# (compareByteArrays# ba1# ba1off# ba2# ba2off# len#)+#else+compareByteArraysOff (BA# ba1#) ba1off (BA# ba2#) ba2off len =+ assert (ba1off + len <= (I# (sizeofByteArray# ba1#)))+ $ assert (ba2off + len <= (I# (sizeofByteArray# ba2#)))+ $ fromIntegral $ accursedUnutterablePerformIO $+ c_memcmp_ByteArray ba1#+ ba1off+ ba2#+ ba2off+ (fromIntegral len)+++foreign import ccall unsafe "static sbs_memcmp_off"+ c_memcmp_ByteArray :: ByteArray# -> Int -> ByteArray# -> Int -> CSize -> IO CInt+#endif+
System/OsPath/Data/ByteString/Short/Word16.hs view
@@ -2,8 +2,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-name-shadowing -fexpose-all-unfoldings #-} @@ -143,31 +145,26 @@ useAsCWStringLen ) where-import System.OsPath.Data.ByteString.Short ( append, intercalate, concat, stripSuffix, stripPrefix, isInfixOf, isPrefixOf, isSuffixOf, breakSubstring, length, empty, null, ShortByteString(..), fromShort, toShort )+import System.OsPath.Data.ByteString.Short ( append, intercalate, concat, stripSuffix, stripPrefix, isPrefixOf, isSuffixOf, length, empty, null, ShortByteString(..), fromShort, toShort ) import System.OsPath.Data.ByteString.Short.Internal import Data.Bits- ( shiftR )+ ( shiftR+ ) import Data.Word import Prelude hiding- ( all+ ( Foldable(..)+ , all , any , reverse , break , concat , drop , dropWhile- , elem , filter- , foldl- , foldl1- , foldr- , foldr1 , head , init , last- , length , map- , null , replicate , span , splitAt@@ -178,6 +175,7 @@ import qualified Data.Foldable as Foldable import GHC.ST ( ST ) import GHC.Stack ( HasCallStack )+import GHC.Exts ( inline ) import qualified Data.ByteString.Short.Internal as BS import qualified Data.List as List@@ -651,6 +649,28 @@ (a, b) | BS.null b -> [a] | otherwise -> a : go (tail b)+++-- | Check whether one string is a substring of another.+isInfixOf :: ShortByteString -> ShortByteString -> Bool+isInfixOf sbs = \s -> null sbs || not (null $ snd $ GHC.Exts.inline breakSubstring sbs s)+++-- algorithm: https://github.com/haskell/filepath/issues/195#issuecomment-1605633713+breakSubstring :: ShortByteString -- ^ String to search for+ -> ShortByteString -- ^ String to search in+ -> (ShortByteString, ShortByteString) -- ^ Head and tail of string broken at substring+breakSubstring bPat@(asBA -> pat) bInp@(asBA -> inp) = go 0+ where+ lpat = BS.length bPat+ linp = BS.length bInp+ go ix+ | let ix' = ix * 2+ , linp >= ix' + lpat =+ if | compareByteArraysOff pat 0 inp ix' lpat == 0 -> splitAt ix bInp+ | otherwise -> go (ix + 1)+ | otherwise+ = (bInp, mempty) -- ---------------------------------------------------------------------
bench/BenchFilePath.hs view
@@ -6,14 +6,10 @@ import System.OsPath.Types import System.OsPath.Encoding ( ucs2le )-import System.Environment import qualified System.OsString.Internal.Types as OST import qualified Data.ByteString.Short as SBS -import TastyBench-import Data.List-import Data.Maybe-import GHC.IO.Encoding+import Test.Tasty.Bench import qualified System.FilePath.Posix as PF import qualified System.FilePath.Posix as WF@@ -22,45 +18,9 @@ import qualified System.OsPath.Posix as APF import qualified System.OsPath.Windows as AWF --data Config = Config {- format :: Format- , stdev :: Double- , timeout :: Integer- }--data Format = Print- | CSV- deriving (Read, Show)--defaultConfig :: Config-defaultConfig = Config defaultFormat defaultStdev defaultTimeout--defaultFormat :: Format-defaultFormat = Print--defaultStdev :: Double-defaultStdev = 0.02--defaultTimeout :: Integer-defaultTimeout = 800000--parseConfig :: [String] -> Config-parseConfig [] = defaultConfig-parseConfig xs =- let format' = maybe defaultFormat (read . fromJust . stripPrefix "--format=" ) $ find ("--format=" `isPrefixOf`) xs- stdev' = maybe defaultStdev (read . fromJust . stripPrefix "--stdev=" ) $ find ("--stdev=" `isPrefixOf`) xs- timeout' = maybe defaultTimeout (read . fromJust . stripPrefix "--timeout=") $ find ("--timeout=" `isPrefixOf`) xs- in Config format' stdev' timeout'-- main :: IO ()-main = do- setLocaleEncoding utf8- args <- getArgs- let config = parseConfig args- benchGroup config- [ ("filepath (string)",+main = defaultMain+ [ bgroup "filepath (string)" $ map (uncurry bench) [("splitExtension (posix)" , nf PF.splitExtension posixPath) ,("splitExtension (windows)" , nf WF.splitExtension windowsPath) ,("takeExtension (posix)" , nf PF.takeExtension posixPath)@@ -149,9 +109,8 @@ ,("splitSearchPath (posix)" , nf PF.splitSearchPath posixSearchPath) ,("splitSearchPath (windows)" , nf WF.splitSearchPath windowsSearchPath) ]- ) - , ("filepath (AFPP)",+ , bgroup "filepath (AFPP)" $ map (uncurry bench) [ ("splitExtension (posix)" , nf APF.splitExtension posixPathAFPP) , ("splitExtension (windows)" , nf AWF.splitExtension windowsPathAFPP) , ("takeExtension (posix)" , nf APF.takeExtension posixPathAFPP)@@ -240,9 +199,8 @@ , ("splitSearchPath (posix)" , nf APF.splitSearchPath posixSearchPathAFPP) , ("splitSearchPath (windows)" , nf AWF.splitSearchPath windowsSearchPathAFPP) ]- ) - , ("encoding/decoding",+ , bgroup "encoding/decoding" $ map (uncurry bench) [ ("decodeUtf (posix)" , nf (APF.decodeUtf @Maybe) posixPathAFPP) , ("decodeUtf (windows)" , nf (AWF.decodeUtf @Maybe) windowsPathAFPP) , ("decodeWith (windows)" , nf (AWF.decodeWith ucs2le) windowsPathAFPP)@@ -259,7 +217,6 @@ , ("fromBytes (posix)" , nf (OSP.fromBytes @Maybe) (SBS.fromShort . OST.getPosixString $ posixPathAFPP)) , ("fromBytes (windows)" , nf (WSP.fromBytes @Maybe) (SBS.fromShort . OST.getWindowsString $ windowsPathAFPP)) ]- ) ] @@ -286,26 +243,3 @@ windowsSearchPathAFPP :: WindowsString windowsSearchPathAFPP = [WSP.pstr|foo;bar;bath;baz;baz;tz;fooooooooooooooo;laaaaaaaaaaaaaaa;baaaaaaaaaaaaar;zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz;zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz;kkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkk;kkkkkkkkkkkkkkkkkk;h;h;h;a;s;r;a;h;gt;r;r;r;s;s.txt|]---benchGroup :: Config -> [(String, [(String, Benchmarkable)])] -> IO ()-benchGroup _ [] = pure ()-benchGroup format ((name, benchs):xs) = do- putStrLn name- bench format benchs- benchGroup format xs--bench :: Config -> [(String, Benchmarkable)] -> IO ()-bench _ [] = pure ()-bench config@Config{..} (x:xs) = do- let (name, benchmarkable) = x- case format of- CSV -> putStr (name ++ ",")- Print -> putStr (" " ++ name ++ ": ")- est <- measureUntil CpuTime False (Timeout timeout "") (RelStDev stdev) benchmarkable- case format of- CSV -> putStr $ csvEstimate est- Print -> putStr $ "\n " ++ prettyEstimate est- putStr "\n"- bench config xs-
− bench/TastyBench.hs
@@ -1,526 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}--module TastyBench where--import Prelude hiding (Int, Integer)-import qualified Prelude-import Control.DeepSeq (NFData, force)-import Control.Exception (evaluate)-import Data.Data (Typeable)-import Data.Word (Word64)-#if !MIN_VERSION_base(4,10,0)-import Data.Int ( Int64 )-#endif-#if MIN_VERSION_base(4,6,0)-import GHC.Stats-#endif-import System.CPUTime-import System.IO-import System.IO.Unsafe-import System.Mem-import Text.Printf (printf)---data Timeout- = Timeout- Prelude.Integer -- ^ number of microseconds (e. g., 200000)- String -- ^ textual representation (e. g., @"0.2s"@)- | NoTimeout- deriving (Show)----- | In addition to @--stdev@ command-line option,--- one can adjust target relative standard deviation--- for individual benchmarks and groups of benchmarks--- using 'adjustOption' and 'localOption'.------ E. g., set target relative standard deviation to 2% as follows:------ > import Test.Tasty (localOption)--- > localOption (RelStDev 0.02) (bgroup [...])------ If you set 'RelStDev' to infinity,--- a benchmark will be executed--- only once and its standard deviation will be recorded as zero.--- This is rather a blunt approach, but it might be a necessary evil--- for extremely long benchmarks. If you wish to run all benchmarks--- only once, use command-line option @--stdev@ @Infinity@.------ @since 0.2-newtype RelStDev = RelStDev Double- deriving (Show, Read, Typeable)---- | Whether to measure CPU time or wall-clock time.--- Normally 'CpuTime' is a better option (and default),--- but consider switching to 'WallTime'--- to measure multithreaded algorithms or time spent in external processes.------ One can switch the default measurement mode globally--- using @--time-mode@ command-line option,--- but it is usually better to adjust the mode locally:------ > import Test.Tasty (localOption)--- > localOption WallTime (bgroup [...])------ @since 0.3.2-data TimeMode = CpuTime- -- ^ Measure CPU time.- deriving (Typeable)---- | Something that can be benchmarked, produced by 'nf', 'whnf', 'nfIO', 'whnfIO',--- 'nfAppIO', 'whnfAppIO' below.------ Drop-in replacement for @Criterion.@'Criterion.Benchmarkable' and--- @Gauge.@'Gauge.Benchmarkable'.------ @since 0.1-newtype Benchmarkable =- -- | @since 0.3- Benchmarkable- { unBenchmarkable :: Word64 -> IO () -- ^ Run benchmark given number of times.- } deriving (Typeable)---data Measurement = Measurement- { measTime :: !Word64 -- ^ time in picoseconds- , measAllocs :: !Word64 -- ^ allocations in bytes- , measCopied :: !Word64 -- ^ copied bytes- , measMaxMem :: !Word64 -- ^ max memory in use- } deriving (Show, Read)--data Estimate = Estimate- { estMean :: !Measurement- , estStdev :: !Word64 -- ^ stdev in picoseconds- } deriving (Show, Read)---predict- :: Measurement -- ^ time for one run- -> Measurement -- ^ time for two runs- -> Estimate-predict (Measurement t1 a1 c1 m1) (Measurement t2 a2 c2 m2) = Estimate- { estMean = Measurement t (fit a1 a2) (fit c1 c2) (max m1 m2)- , estStdev = truncate (sqrt d :: Double)- }- where- fit x1 x2 = x1 `quot` 5 + 2 * (x2 `quot` 5)- t = fit t1 t2- sqr x = x * x- d = sqr (word64ToDouble t1 - word64ToDouble t)- + sqr (word64ToDouble t2 - 2 * word64ToDouble t)--predictPerturbed :: Measurement -> Measurement -> Estimate-predictPerturbed t1 t2 = Estimate- { estMean = estMean (predict t1 t2)- , estStdev = max- (estStdev (predict (lo t1) (hi t2)))- (estStdev (predict (hi t1) (lo t2)))- }- where- prec = max (fromInteger cpuTimePrecision) 1000000000 -- 1 ms- hi meas = meas { measTime = measTime meas + prec }- lo meas = meas { measTime = measTime meas - prec }--hasGCStats :: Bool-#if MIN_VERSION_base(4,10,0)-hasGCStats = unsafePerformIO getRTSStatsEnabled-#elif MIN_VERSION_base(4,6,0)-hasGCStats = unsafePerformIO getGCStatsEnabled-#else-hasGCStats = False-#endif--getAllocsAndCopied :: IO (Word64, Word64, Word64)-getAllocsAndCopied = do- if not hasGCStats then pure (0, 0, 0) else-#if MIN_VERSION_base(4,10,0)- (\s -> (allocated_bytes s, copied_bytes s, max_mem_in_use_bytes s)) <$> getRTSStats-#elif MIN_VERSION_base(4,6,0)- (\s -> (int64ToWord64 $ bytesAllocated s, int64ToWord64 $ bytesCopied s, int64ToWord64 $ peakMegabytesAllocated s * 1024 * 1024)) <$> getGCStats-#else- pure (0, 0, 0)-#endif--getTimePicoSecs :: TimeMode -> IO Word64-getTimePicoSecs timeMode = case timeMode of- CpuTime -> fromInteger <$> getCPUTime--measure :: TimeMode -> Word64 -> Benchmarkable -> IO Measurement-measure timeMode n (Benchmarkable act) = do- let getTimePicoSecs' = getTimePicoSecs timeMode- performGC- startTime <- getTimePicoSecs'- (startAllocs, startCopied, startMaxMemInUse) <- getAllocsAndCopied- act n- endTime <- getTimePicoSecs'- (endAllocs, endCopied, endMaxMemInUse) <- getAllocsAndCopied- let meas = Measurement- { measTime = endTime - startTime- , measAllocs = endAllocs - startAllocs- , measCopied = endCopied - startCopied- , measMaxMem = max endMaxMemInUse startMaxMemInUse- }- pure meas--measureUntil :: TimeMode -> Bool -> Timeout -> RelStDev -> Benchmarkable -> IO Estimate-measureUntil timeMode _ _ (RelStDev targetRelStDev) b- | isInfinite targetRelStDev, targetRelStDev > 0 = do- t1 <- measure timeMode 1 b- pure $ Estimate { estMean = t1, estStdev = 0 }-measureUntil timeMode warnIfNoTimeout timeout (RelStDev targetRelStDev) b = do- t1 <- measure' 1 b- go 1 t1 0- where- measure' = measure timeMode-- go :: Word64 -> Measurement -> Word64 -> IO Estimate- go n t1 sumOfTs = do- t2 <- measure' (2 * n) b-- let Estimate (Measurement meanN allocN copiedN maxMemN) stdevN = predictPerturbed t1 t2- isTimeoutSoon = case timeout of- NoTimeout -> False- -- multiplying by 12/10 helps to avoid accidental timeouts- Timeout micros _ -> (sumOfTs' + 3 * measTime t2) `quot` (1000000 * 10 `quot` 12) >= fromInteger micros- isStDevInTargetRange = stdevN < truncate (max 0 targetRelStDev * word64ToDouble meanN)- scale = (`quot` n)- sumOfTs' = sumOfTs + measTime t1-- case timeout of- NoTimeout | warnIfNoTimeout, sumOfTs' + measTime t2 > 100 * 1000000000000- -> hPutStrLn stderr "This benchmark takes more than 100 seconds. Consider setting --timeout, if this is unexpected (or to silence this warning)."- _ -> pure ()-- if isStDevInTargetRange || isTimeoutSoon- then pure $ Estimate- { estMean = Measurement (scale meanN) (scale allocN) (scale copiedN) maxMemN- , estStdev = scale stdevN }- else go (2 * n) t2 sumOfTs'---- | An internal routine to measure CPU execution time in seconds--- for a given timeout (put 'NoTimeout', or 'mkTimeout' 100000000 for 100 seconds)--- and a target relative standard deviation--- (put 'RelStDev' 0.05 for 5% or 'RelStDev' (1/0) to run only one iteration).------ 'Timeout' takes soft priority over 'RelStDev': this function prefers--- to finish in time even if at cost of precision. However, timeout is guidance--- not guarantee: 'measureCpuTime' can take longer, if there is not enough time--- to run at least thrice or an iteration takes unusually long.------ @since 0.3-measureCpuTime :: Timeout -> RelStDev -> Benchmarkable -> IO Double-measureCpuTime- = ((fmap ((/ 1e12) . word64ToDouble . measTime . estMean) .) .)- . measureUntil CpuTime False----funcToBench :: (b -> c) -> (a -> b) -> a -> Benchmarkable-funcToBench frc = (Benchmarkable .) . benchLoop- where- -- Here we rely on the fact that GHC (unless spurred by- -- -fstatic-argument-transformation) is not smart enough:- -- it does not notice that `f` and `x` arguments are loop invariant- -- and could be floated, and the whole `f x` expression shared.- -- If we create a closure with `f` and `x` bound in the environment,- -- then GHC is smart enough to share computation of `f x`.- --- -- For perspective, gauge and criterion < 1.4 mark similar functions as INLINE,- -- while criterion >= 1.4 switches to NOINLINE.- -- If we mark `benchLoop` NOINLINE then benchmark results are slightly larger- -- (noticeable in bench-fibo), because the loop body is slightly bigger,- -- since GHC does not unbox numbers or inline `Eq @Word64` dictionary.- --- -- This function is called `benchLoop` instead of, say, `go`,- -- so it is easier to spot in Core dumps.- benchLoop f x n- | n == 0 = pure ()- | otherwise = do- _ <- evaluate (frc (f x))- benchLoop f x (n - 1)-{-# INLINE funcToBench #-}---- | 'nf' @f@ @x@ measures time to compute--- a normal form (by means of 'force') of an application of @f@ to @x@.--- This does not include time to evaluate @f@ or @x@ themselves.--- Ideally @x@ should be a primitive data type like 'Data.Int.Int'.------ The same thunk of @x@ is shared by multiple calls of @f@. We cannot evaluate--- @x@ beforehand: there is no 'NFData' @a@ constraint, and potentially @x@ may--- be an infinite structure. Thus @x@ will be evaluated in course of the first--- application of @f@. This noisy measurement is to be discarded soon,--- but if @x@ is not a primitive data type, consider forcing its evaluation--- separately, e. g., via 'env' or 'withResource'.------ Here is a textbook anti-pattern: 'nf' 'sum' @[1..1000000]@.--- Since an input list is shared by multiple invocations of 'sum',--- it will be allocated in memory in full, putting immense pressure--- on garbage collector. Also no list fusion will happen.--- A better approach is 'nf' (@\\n@ @->@ 'sum' @[1..n]@) @1000000@.------ If you are measuring an inlinable function,--- it is prudent to ensure that its invocation is fully saturated,--- otherwise inlining will not happen. That's why one can often--- see 'nf' (@\\n@ @->@ @f@ @n@) @x@ instead of 'nf' @f@ @x@.--- Same applies to rewrite rules.------ While @tasty-bench@ is capable to perform micro- and even nanobenchmarks,--- such measurements are noisy and involve an overhead. Results are more reliable--- when @f@ @x@ takes at least several milliseconds.------ Note that forcing a normal form requires an additional--- traverse of the structure. In certain scenarios (imagine benchmarking 'tail'),--- especially when 'NFData' instance is badly written,--- this traversal may take non-negligible time and affect results.------ Drop-in replacement for @Criterion.@'Criterion.nf' and--- @Gauge.@'Gauge.nf'.------ @since 0.1-nf :: NFData b => (a -> b) -> a -> Benchmarkable-nf = funcToBench force-{-# INLINE nf #-}---- | 'whnf' @f@ @x@ measures time to compute--- a weak head normal form of an application of @f@ to @x@.--- This does not include time to evaluate @f@ or @x@ themselves.--- Ideally @x@ should be a primitive data type like 'Data.Int.Int'.------ The same thunk of @x@ is shared by multiple calls of @f@. We cannot evaluate--- @x@ beforehand: there is no 'NFData' @a@ constraint, and potentially @x@ may--- be an infinite structure. Thus @x@ will be evaluated in course of the first--- application of @f@. This noisy measurement is to be discarded soon,--- but if @x@ is not a primitive data type, consider forcing its evaluation--- separately, e. g., via 'env' or 'withResource'.------ Computing only a weak head normal form is--- rarely what intuitively is meant by "evaluation".--- Beware that many educational materials contain examples with 'whnf':--- this is a wrong default.--- Unless you understand precisely, what is measured,--- it is recommended to use 'nf' instead.------ Here is a textbook anti-pattern: 'whnf' ('Data.List.replicate' @1000000@) @1@.--- This will succeed in a matter of nanoseconds, because weak head--- normal form forces only the first element of the list.------ Drop-in replacement for @Criterion.@'Criterion.whnf' and @Gauge.@'Gauge.whnf'.------ @since 0.1-whnf :: (a -> b) -> a -> Benchmarkable-whnf = funcToBench id-{-# INLINE whnf #-}--ioToBench :: (b -> c) -> IO b -> Benchmarkable-ioToBench frc act = Benchmarkable go- where- go n- | n == 0 = pure ()- | otherwise = do- val <- act- _ <- evaluate (frc val)- go (n - 1)-{-# INLINE ioToBench #-}---- | 'nfIO' @x@ measures time to evaluate side-effects of @x@--- and compute its normal form (by means of 'force').------ Pure subexpression of an effectful computation @x@--- may be evaluated only once and get cached.--- To avoid surprising results it is usually preferable--- to use 'nfAppIO' instead.------ Note that forcing a normal form requires an additional--- traverse of the structure. In certain scenarios,--- especially when 'NFData' instance is badly written,--- this traversal may take non-negligible time and affect results.------ A typical use case is 'nfIO' ('readFile' @"foo.txt"@).--- However, if your goal is not to benchmark I\/O per se,--- but just read input data from a file, it is cleaner to--- use 'env' or 'withResource'.------ Drop-in replacement for @Criterion.@'Criterion.nfIO' and @Gauge.@'Gauge.nfIO'.------ @since 0.1-nfIO :: NFData a => IO a -> Benchmarkable-nfIO = ioToBench force-{-# INLINE nfIO #-}---- | 'whnfIO' @x@ measures time to evaluate side-effects of @x@--- and compute its weak head normal form.------ Pure subexpression of an effectful computation @x@--- may be evaluated only once and get cached.--- To avoid surprising results it is usually preferable--- to use 'whnfAppIO' instead.------ Computing only a weak head normal form is--- rarely what intuitively is meant by "evaluation".--- Unless you understand precisely, what is measured,--- it is recommended to use 'nfIO' instead.------ Lazy I\/O is treacherous.--- If your goal is not to benchmark I\/O per se,--- but just read input data from a file, it is cleaner to--- use 'env' or 'withResource'.------ Drop-in replacement for @Criterion.@'Criterion.whnfIO' and @Gauge.@'Gauge.whnfIO'.------ @since 0.1-whnfIO :: IO a -> Benchmarkable-whnfIO = ioToBench id-{-# INLINE whnfIO #-}--ioFuncToBench :: (b -> c) -> (a -> IO b) -> a -> Benchmarkable-ioFuncToBench frc = (Benchmarkable .) . go- where- go f x n- | n == 0 = pure ()- | otherwise = do- val <- f x- _ <- evaluate (frc val)- go f x (n - 1)-{-# INLINE ioFuncToBench #-}---- | 'nfAppIO' @f@ @x@ measures time to evaluate side-effects of--- an application of @f@ to @x@.--- and compute its normal form (by means of 'force').--- This does not include time to evaluate @f@ or @x@ themselves.--- Ideally @x@ should be a primitive data type like 'Data.Int.Int'.------ The same thunk of @x@ is shared by multiple calls of @f@. We cannot evaluate--- @x@ beforehand: there is no 'NFData' @a@ constraint, and potentially @x@ may--- be an infinite structure. Thus @x@ will be evaluated in course of the first--- application of @f@. This noisy measurement is to be discarded soon,--- but if @x@ is not a primitive data type, consider forcing its evaluation--- separately, e. g., via 'env' or 'withResource'.------ Note that forcing a normal form requires an additional--- traverse of the structure. In certain scenarios,--- especially when 'NFData' instance is badly written,--- this traversal may take non-negligible time and affect results.------ A typical use case is 'nfAppIO' 'readFile' @"foo.txt"@.--- However, if your goal is not to benchmark I\/O per se,--- but just read input data from a file, it is cleaner to--- use 'env' or 'withResource'.------ Drop-in replacement for @Criterion.@'Criterion.nfAppIO' and @Gauge.@'Gauge.nfAppIO'.------ @since 0.1-nfAppIO :: NFData b => (a -> IO b) -> a -> Benchmarkable-nfAppIO = ioFuncToBench force-{-# INLINE nfAppIO #-}---- | 'whnfAppIO' @f@ @x@ measures time to evaluate side-effects of--- an application of @f@ to @x@.--- and compute its weak head normal form.--- This does not include time to evaluate @f@ or @x@ themselves.--- Ideally @x@ should be a primitive data type like 'Data.Int.Int'.------ The same thunk of @x@ is shared by multiple calls of @f@. We cannot evaluate--- @x@ beforehand: there is no 'NFData' @a@ constraint, and potentially @x@ may--- be an infinite structure. Thus @x@ will be evaluated in course of the first--- application of @f@. This noisy measurement is to be discarded soon,--- but if @x@ is not a primitive data type, consider forcing its evaluation--- separately, e. g., via 'env' or 'withResource'.------ Computing only a weak head normal form is--- rarely what intuitively is meant by "evaluation".--- Unless you understand precisely, what is measured,--- it is recommended to use 'nfAppIO' instead.------ Lazy I\/O is treacherous.--- If your goal is not to benchmark I\/O per se,--- but just read input data from a file, it is cleaner to--- use 'env' or 'withResource'.------ Drop-in replacement for @Criterion.@'Criterion.whnfAppIO' and @Gauge.@'Gauge.whnfAppIO'.------ @since 0.1-whnfAppIO :: (a -> IO b) -> a -> Benchmarkable-whnfAppIO = ioFuncToBench id-{-# INLINE whnfAppIO #-}---word64ToDouble :: Word64 -> Double-word64ToDouble = fromIntegral--#if !MIN_VERSION_base(4,10,0) && MIN_VERSION_base(4,6,0)-int64ToWord64 :: Int64 -> Word64-int64ToWord64 = fromIntegral-#endif--prettyEstimate :: Estimate -> String-prettyEstimate (Estimate m stdev) =- showPicos4 (measTime m)- ++ (if stdev == 0 then " " else " ± " ++ showPicos3 (2 * stdev))---- | Show picoseconds, fitting number in 4 characters.-showPicos4 :: Word64 -> String-showPicos4 i- | t < 995 = printf "%3.0f ps" t- | t < 995e1 = printf "%4.2f ns" (t / 1e3)- | t < 995e2 = printf "%4.1f ns" (t / 1e3)- | t < 995e3 = printf "%3.0f ns" (t / 1e3)- | t < 995e4 = printf "%4.2f μs" (t / 1e6)- | t < 995e5 = printf "%4.1f μs" (t / 1e6)- | t < 995e6 = printf "%3.0f μs" (t / 1e6)- | t < 995e7 = printf "%4.2f ms" (t / 1e9)- | t < 995e8 = printf "%4.1f ms" (t / 1e9)- | t < 995e9 = printf "%3.0f ms" (t / 1e9)- | otherwise = printf "%4.3f s" (t / 1e12)- where- t = word64ToDouble i---- | Show picoseconds, fitting number in 3 characters.-showPicos3 :: Word64 -> String-showPicos3 i- | t < 995 = printf "%3.0f ps" t- | t < 995e1 = printf "%3.1f ns" (t / 1e3)- | t < 995e3 = printf "%3.0f ns" (t / 1e3)- | t < 995e4 = printf "%3.1f μs" (t / 1e6)- | t < 995e6 = printf "%3.0f μs" (t / 1e6)- | t < 995e7 = printf "%3.1f ms" (t / 1e9)- | t < 995e9 = printf "%3.0f ms" (t / 1e9)- | otherwise = printf "%4.2f s" (t / 1e12)- where- t = word64ToDouble i--prettyEstimateWithGC :: Estimate -> String-prettyEstimateWithGC (Estimate m stdev) =- showPicos4 (measTime m)- ++ (if stdev == 0 then ", " else " ± " ++ showPicos3 (2 * stdev) ++ ", ")- ++ showBytes (measAllocs m) ++ " allocated, "- ++ showBytes (measCopied m) ++ " copied, "- ++ showBytes (measMaxMem m) ++ " peak memory"--csvEstimate :: Estimate -> String-csvEstimate (Estimate m stdev) = show (measTime m) ++ "," ++ show (2 * stdev)--csvEstimateWithGC :: Estimate -> String-csvEstimateWithGC (Estimate m stdev) = show (measTime m) ++ "," ++ show (2 * stdev)- ++ "," ++ show (measAllocs m) ++ "," ++ show (measCopied m) ++ "," ++ show (measMaxMem m)--showBytes :: Word64 -> String-showBytes i- | t < 1000 = printf "%3.0f B " t- | t < 10189 = printf "%3.1f KB" (t / 1024)- | t < 1023488 = printf "%3.0f KB" (t / 1024)- | t < 10433332 = printf "%3.1f MB" (t / 1048576)- | t < 1048051712 = printf "%3.0f MB" (t / 1048576)- | t < 10683731149 = printf "%3.1f GB" (t / 1073741824)- | t < 1073204953088 = printf "%3.0f GB" (t / 1073741824)- | t < 10940140696372 = printf "%3.1f TB" (t / 1099511627776)- | t < 1098961871962112 = printf "%3.0f TB" (t / 1099511627776)- | t < 11202704073084108 = printf "%3.1f PB" (t / 1125899906842624)- | t < 1125336956889202624 = printf "%3.0f PB" (t / 1125899906842624)- | t < 11471568970838126592 = printf "%3.1f EB" (t / 1152921504606846976)- | otherwise = printf "%3.0f EB" (t / 1152921504606846976)- where- t = word64ToDouble i
changelog.md view
@@ -2,6 +2,10 @@ _Note: below all `FilePath` values are unquoted, so `\\` really means two backslashes._ +## 1.4.100.4 *Jul 2023*++* Fix isInfixOf and breakSubString in Word16, wrt [#195](https://github.com/haskell/filepath/issues/195)+ ## 1.4.100.3 *Feb 2023* * Fix a regression in `splitFileName` wrt [#189](https://github.com/haskell/filepath/pull/189)
filepath.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: filepath-version: 1.4.100.3+version: 1.4.100.4 -- NOTE: Don't forget to update ./changelog.md license: BSD-3-Clause@@ -103,7 +103,7 @@ default-language: Haskell2010 build-depends:- , base >=4.9 && <4.19+ , base >=4.9 && <4.20 , bytestring >=0.11.3.0 , deepseq , exceptions@@ -182,10 +182,10 @@ build-depends: , base , bytestring >=0.11.3.0- , checkers ^>=0.5.6 , deepseq , filepath , QuickCheck >=2.7 && <2.15+ , quickcheck-classes-base ^>=0.6.2 benchmark bench-filepath default-language: Haskell2010@@ -193,15 +193,11 @@ type: exitcode-stdio-1.0 main-is: BenchFilePath.hs hs-source-dirs: bench- other-modules: TastyBench build-depends: , base , bytestring >=0.11.3.0 , deepseq , filepath-- if impl(ghc >=8.10)- ghc-options: "-with-rtsopts=-A32m --nonmoving-gc"+ , tasty-bench - else- ghc-options: -with-rtsopts=-A32m+ ghc-options: -with-rtsopts=-A32m
tests/abstract-filepath/Arbitrary.hs view
@@ -12,27 +12,15 @@ import qualified Data.ByteString as ByteString import Test.QuickCheck -import Test.QuickCheck.Checkers -- instance Arbitrary OsString where arbitrary = fmap fromJust $ encodeUtf <$> listOf filepathChar -instance EqProp OsString where- (=-=) = eq- instance Arbitrary PosixString where arbitrary = fmap fromJust $ Posix.encodeUtf <$> listOf filepathChar -instance EqProp PosixString where- (=-=) = eq- instance Arbitrary WindowsString where arbitrary = fmap fromJust $ Windows.encodeUtf <$> listOf filepathChar--instance EqProp WindowsString where- (=-=) = eq newtype NonNullString = NonNullString { nonNullString :: String }
tests/abstract-filepath/OsPathSpec.hs view
@@ -21,8 +21,7 @@ import Data.ByteString ( ByteString ) import qualified Data.ByteString as BS import Test.QuickCheck-import Test.QuickCheck.Checkers-import qualified Test.QuickCheck.Classes as QC+import qualified Test.QuickCheck.Classes.Base as QC import GHC.IO.Encoding.UTF8 ( mkUTF8 ) import GHC.IO.Encoding.UTF16 ( mkUTF16le ) import GHC.IO.Encoding ( setFileSystemEncoding )@@ -33,6 +32,7 @@ import qualified System.OsPath.Data.ByteString.Short.Word16 as BS16 import qualified System.OsPath.Data.ByteString.Short as SBS import Data.Char ( ord )+import Data.Proxy ( Proxy(..) ) import Arbitrary @@ -233,24 +233,20 @@ ) - ] ++ testBatch (QC.ord (\(a :: OsPath) -> pure a))- ++ testBatch (QC.monoid (undefined :: OsPath))-- ++ testBatch (QC.ord (\(a :: OsString) -> pure a))- ++ testBatch (QC.monoid (undefined :: OsString))+ ] ++ QC.lawsProperties (QC.ordLaws (Proxy @OsPath))+ ++ QC.lawsProperties (QC.monoidLaws (Proxy @OsPath)) - ++ testBatch (QC.ord (\(a :: WindowsString) -> pure a))- ++ testBatch (QC.monoid (undefined :: WindowsString))+ ++ QC.lawsProperties (QC.ordLaws (Proxy @OsString))+ ++ QC.lawsProperties (QC.monoidLaws (Proxy @OsString)) - ++ testBatch (QC.ord (\(a :: PosixString) -> pure a))- ++ testBatch (QC.monoid (undefined :: PosixString))+ ++ QC.lawsProperties (QC.ordLaws (Proxy @WindowsString))+ ++ QC.lawsProperties (QC.monoidLaws (Proxy @WindowsString)) - ++ testBatch (QC.ord (\(a :: PlatformString) -> pure a))- ++ testBatch (QC.monoid (undefined :: PlatformString))+ ++ QC.lawsProperties (QC.ordLaws (Proxy @PosixString))+ ++ QC.lawsProperties (QC.monoidLaws (Proxy @PosixString)) --- | Allows to insert a 'TestBatch' into a Spec.-testBatch :: TestBatch -> [(String, Property)]-testBatch (_, tests') = tests'+ ++ QC.lawsProperties (QC.ordLaws (Proxy @PlatformString))+ ++ QC.lawsProperties (QC.monoidLaws (Proxy @PlatformString)) padEven :: ByteString -> ByteString
tests/bytestring-tests/Properties/Common.hs view
@@ -21,6 +21,7 @@ module Properties.ShortByteString.Word16 (tests) where import System.OsPath.Data.ByteString.Short.Internal (_nul, isSpace) import qualified System.OsPath.Data.ByteString.Short.Word16 as B+import qualified System.OsPath.Data.ByteString.Short as BS #else module Properties.ShortByteString (tests) where import qualified System.OsPath.Data.ByteString.Short as B@@ -147,6 +148,28 @@ once $ numWord mempty === 0) , ("mempty []", once $ B.unpack mempty === [])++#ifdef WORD16+ , ("isInfixOf works correctly under UTF16",+ once $+ let foo = BS.pack [0xbb, 0x03]+ foo' = BS.pack [0xd2, 0xbb]+ bar = BS.pack [0xd2, 0xbb, 0x03, 0xad]+ bar' = BS.pack [0xd2, 0xbb, 0x03, 0xad, 0xd2, 0xbb, 0x03, 0xad, 0xbb, 0x03, 0x00, 0x00]+ in [B.isInfixOf foo bar, B.isInfixOf foo' bar, B.isInfixOf foo bar'] === [False, True, True]+ )+#endif+ , ("break breakSubstring",+ property $ \(toElem -> c) x -> B.break (== c) x === B.breakSubstring (B.singleton c) x+ )+ , ("breakSubstring",+ property $ \x y -> not (B.null x) ==> B.null (snd (B.breakSubstring x y)) === not (B.isInfixOf x y)+ )+ , ("breakSubstring empty",+ property $ \x -> B.breakSubstring B.empty x === (B.empty, x)+ )+ , ("isInfixOf",+ property $ \x y -> B.isInfixOf x y === L.isInfixOf (B.unpack x) (B.unpack y)) , ("mconcat" , property $ \xs -> B.unpack (mconcat xs) === mconcat (map B.unpack xs))
tests/filepath-tests/TestGen.hs view
@@ -814,6 +814,8 @@ ,("AFP_W.normalise (\"c:\\\\file/bob\\\\\") == (\"C:\\\\file\\\\bob\\\\\")", property $ AFP_W.normalise ("c:\\file/bob\\") == ("C:\\file\\bob\\")) ,("W.normalise \"c:\\\\\" == \"C:\\\\\"", property $ W.normalise "c:\\" == "C:\\") ,("AFP_W.normalise (\"c:\\\\\") == (\"C:\\\\\")", property $ AFP_W.normalise ("c:\\") == ("C:\\"))+ ,("W.normalise \"c:\\\\\\\\\\\\\\\\\" == \"C:\\\\\"", property $ W.normalise "c:\\\\\\\\" == "C:\\")+ ,("AFP_W.normalise (\"c:\\\\\\\\\\\\\\\\\") == (\"C:\\\\\")", property $ AFP_W.normalise ("c:\\\\\\\\") == ("C:\\")) ,("W.normalise \"C:.\\\\\" == \"C:\"", property $ W.normalise "C:.\\" == "C:") ,("AFP_W.normalise (\"C:.\\\\\") == (\"C:\")", property $ AFP_W.normalise ("C:.\\") == ("C:")) ,("W.normalise \"\\\\\\\\server\\\\test\" == \"\\\\\\\\server\\\\test\"", property $ W.normalise "\\\\server\\test" == "\\\\server\\test")