diff --git a/Generate.hs b/Generate.hs --- a/Generate.hs +++ b/Generate.hs @@ -35,10 +35,10 @@ ,"import GHC.IO.Encoding.UTF16 ( mkUTF16le )" ,"import GHC.IO.Encoding.UTF8 ( mkUTF8 )" ,"import System.OsString.Internal.Types" - ,"import System.OsPath.Encoding.Internal" + ,"import System.OsString.Encoding.Internal" ,"import qualified Data.Char as C" - ,"import qualified System.OsPath.Data.ByteString.Short as SBS" - ,"import qualified System.OsPath.Data.ByteString.Short.Word16 as SBS16" + ,"import qualified System.OsString.Data.ByteString.Short as SBS" + ,"import qualified System.OsString.Data.ByteString.Short.Word16 as SBS16" ,"import qualified System.FilePath.Windows as W" ,"import qualified System.FilePath.Posix as P" #ifdef GHC_MAKE diff --git a/System/FilePath/Internal.hs b/System/FilePath/Internal.hs --- a/System/FilePath/Internal.hs +++ b/System/FilePath/Internal.hs @@ -129,19 +129,18 @@ #define STRING String #define FILEPATH FilePath #else -import System.OsPath.Encoding.Internal.Hidden ( trySafe ) -import Prelude (fromIntegral) -import Control.Exception ( SomeException, evaluate, displayException ) +import Prelude (fromIntegral, return, IO, Either(..)) +import Control.Exception ( catch, displayException, evaluate, fromException, toException, throwIO, Exception, SomeAsyncException(..), SomeException ) import Control.DeepSeq (force) -import GHC.IO (unsafePerformIO) +import System.IO.Unsafe (unsafePerformIO) import qualified Data.Char as C #ifdef WINDOWS import GHC.IO.Encoding.Failure ( CodingFailureMode(..) ) import GHC.IO.Encoding.UTF16 ( mkUTF16le ) import qualified GHC.Foreign as GHC import Data.Word ( Word16 ) -import System.OsPath.Data.ByteString.Short.Word16.Hidden -import System.OsPath.Data.ByteString.Short.Hidden ( packCStringLen ) +import System.OsString.Data.ByteString.Short.Word16 +import System.OsString.Data.ByteString.Short ( packCStringLen ) #define CHAR Word16 #define STRING ShortByteString #define FILEPATH ShortByteString @@ -150,7 +149,7 @@ import qualified GHC.Foreign as GHC import GHC.IO.Encoding.UTF8 ( mkUTF8 ) import Data.Word ( Word8 ) -import System.OsPath.Data.ByteString.Short.Hidden +import System.OsString.Data.ByteString.Short #define CHAR Word8 #define STRING ShortByteString #define FILEPATH ShortByteString @@ -427,7 +426,6 @@ -- > splitExtensions "file.tar.gz" == ("file",".tar.gz") -- > uncurry (<>) (splitExtensions x) == x -- > Valid x => uncurry addExtension (splitExtensions x) == x --- > splitExtensions "file.tar.gz" == ("file",".tar.gz") splitExtensions :: FILEPATH -> (FILEPATH, STRING) splitExtensions x = (a <> c, d) where @@ -697,6 +695,7 @@ -- -- > dropFileName "/directory/file.ext" == "/directory/" -- > dropFileName x == fst (splitFileName x) +-- > isPrefixOf (takeDrive x) (dropFileName x) dropFileName :: FILEPATH -> FILEPATH dropFileName = fst . splitFileName @@ -1271,6 +1270,22 @@ snoc str = \c -> str <> [c] #else +-- | Like 'try', but rethrows async exceptions. +trySafe :: Exception e => IO a -> IO (Either e a) +trySafe ioA = catch action eHandler + where + action = do + v <- ioA + return (Right v) + eHandler e + | isAsyncException e = throwIO e + | otherwise = return (Left e) + +isAsyncException :: Exception e => e -> Bool +isAsyncException e = + case fromException (toException e) of + Just (SomeAsyncException _) -> True + Nothing -> False #ifdef WINDOWS fromString :: P.String -> STRING fromString str = P.either (P.error . P.show) P.id $ unsafePerformIO $ do diff --git a/System/OsPath/Common.hs b/System/OsPath/Common.hs --- a/System/OsPath/Common.hs +++ b/System/OsPath/Common.hs @@ -42,8 +42,9 @@ #endif -- * Filepath construction , PS.encodeUtf + , PS.unsafeEncodeUtf , PS.encodeWith - , PS.encodeFS + , encodeFS #if defined(WINDOWS) || defined(POSIX) , pstr #else @@ -54,7 +55,7 @@ -- * Filepath deconstruction , PS.decodeUtf , PS.decodeWith - , PS.decodeFS + , decodeFS , PS.unpack -- * Word construction @@ -109,48 +110,60 @@ #ifdef WINDOWS import System.OsPath.Types -import System.OsString.Windows.Hidden as PS +import System.OsString.Windows as PS ( unsafeFromChar , toChar , decodeUtf , decodeWith - , decodeFS , pack , encodeUtf + , unsafeEncodeUtf , encodeWith - , encodeFS , unpack ) import Data.Bifunctor ( bimap ) import qualified System.OsPath.Windows.Internal as C import GHC.IO.Encoding.UTF16 ( mkUTF16le ) -import Language.Haskell.TH.Quote +#if __GLASGOW_HASKELL__ >= 914 +import Language.Haskell.TH.Lift + ( Lift(..), lift ) +import Language.Haskell.TH.QuasiQuoter ( QuasiQuoter (..) ) +#else import Language.Haskell.TH.Syntax - ( Lift (..), lift ) + ( Lift(..), lift ) +import Language.Haskell.TH.Quote + ( QuasiQuoter (..) ) +#endif import GHC.IO.Encoding.Failure ( CodingFailureMode(..) ) import Control.Monad ( when ) #elif defined(POSIX) import GHC.IO.Encoding.Failure ( CodingFailureMode(..) ) import Control.Monad ( when ) -import Language.Haskell.TH.Quote +#if __GLASGOW_HASKELL__ >= 914 +import Language.Haskell.TH.Lift + ( Lift(..), lift ) +import Language.Haskell.TH.QuasiQuoter ( QuasiQuoter (..) ) +#else import Language.Haskell.TH.Syntax - ( Lift (..), lift ) + ( Lift(..), lift ) +import Language.Haskell.TH.Quote + ( QuasiQuoter (..) ) +#endif import GHC.IO.Encoding.UTF8 ( mkUTF8 ) import System.OsPath.Types -import System.OsString.Posix.Hidden as PS +import System.OsString.Posix as PS ( unsafeFromChar , toChar , decodeUtf , decodeWith - , decodeFS , pack , encodeUtf + , unsafeEncodeUtf , encodeWith - , encodeFS , unpack ) import Data.Bifunctor ( bimap ) @@ -162,16 +175,15 @@ ( osp , decodeUtf , decodeWith - , decodeFS , pack , encodeUtf + , unsafeEncodeUtf , encodeWith - , encodeFS , unpack ) import System.OsPath.Types ( OsPath ) -import System.OsString.Internal.Hidden ( unsafeFromChar, toChar ) +import System.OsString ( unsafeFromChar, toChar ) #if defined(mingw32_HOST_OS) || defined(__MINGW32__) import qualified System.OsPath.Windows as C @@ -182,7 +194,8 @@ import Data.Bifunctor ( bimap ) #endif -import System.OsString.Internal.Types.Hidden +import System.OsString.Internal.Types +import System.OsString.Encoding.Internal ------------------------ @@ -1435,3 +1448,36 @@ -- > isAbsolute x == not (isRelative x) isAbsolute :: FILEPATH_NAME -> Bool isAbsolute (OSSTRING_NAME x) = C.isAbsolute x + + +-- things not defined in os-string + +#ifdef WINDOWS +encodeFS :: String -> IO WindowsPath +encodeFS = fmap WindowsString . encodeWithBaseWindows + +decodeFS :: WindowsPath -> IO String +decodeFS (WindowsString x) = decodeWithBaseWindows x +#elif defined(POSIX) +encodeFS :: String -> IO PosixPath +encodeFS = fmap PosixString . encodeWithBasePosix + +decodeFS :: PosixPath -> IO String +decodeFS (PosixString x) = decodeWithBasePosix x +#else +encodeFS :: String -> IO OsPath +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +encodeFS = fmap (OsString . WindowsString) . encodeWithBaseWindows +#else +encodeFS = fmap (OsString . PosixString) . encodeWithBasePosix +#endif + +decodeFS :: OsPath -> IO String +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +decodeFS (OsString (WindowsString x)) = decodeWithBaseWindows x +#else +decodeFS (OsString (PosixString x)) = decodeWithBasePosix x +#endif + +#endif + diff --git a/System/OsPath/Data/ByteString/Short.hs b/System/OsPath/Data/ByteString/Short.hs deleted file mode 100644 --- a/System/OsPath/Data/ByteString/Short.hs +++ /dev/null @@ -1,178 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} --- | --- Module : System.OsPath.Data.ByteString.Short --- Copyright : (c) Duncan Coutts 2012-2013, Julian Ospald 2022 --- License : BSD-style --- --- Maintainer : hasufell@posteo.de --- Stability : stable --- Portability : ghc only --- --- A compact representation suitable for storing short byte strings in memory. --- --- In typical use cases it can be imported alongside "Data.ByteString", e.g. --- --- > import qualified Data.ByteString as B --- > import qualified Data.ByteString.Short as B --- > (ShortByteString, toShort, fromShort) --- --- Other 'ShortByteString' operations clash with "Data.ByteString" or "Prelude" --- functions however, so they should be imported @qualified@ with a different --- alias e.g. --- --- > import qualified Data.ByteString.Short as B.Short --- -module System.OsPath.Data.ByteString.Short {-# DEPRECATED "Use System.OsString.Data.ByteString.Short from os-string >= 2.0.0 package instead. This module will be removed in filepath >= 1.5." #-} - - ( - - -- * The @ShortByteString@ type - - ShortByteString(..), - - -- ** Memory overhead - -- | With GHC, the memory overheads are as follows, expressed in words and - -- in bytes (words are 4 and 8 bytes on 32 or 64bit machines respectively). - -- - -- * 'B.ByteString' unshared: 8 words; 32 or 64 bytes. - -- - -- * 'B.ByteString' shared substring: 4 words; 16 or 32 bytes. - -- - -- * 'ShortByteString': 4 words; 16 or 32 bytes. - -- - -- For the string data itself, both 'ShortByteString' and 'B.ByteString' use - -- one byte per element, rounded up to the nearest word. For example, - -- including the overheads, a length 10 'ShortByteString' would take - -- @16 + 12 = 28@ bytes on a 32bit platform and @32 + 16 = 48@ bytes on a - -- 64bit platform. - -- - -- These overheads can all be reduced by 1 word (4 or 8 bytes) when the - -- 'ShortByteString' or 'B.ByteString' is unpacked into another constructor. - -- - -- For example: - -- - -- > data ThingId = ThingId {-# UNPACK #-} !Int - -- > {-# UNPACK #-} !ShortByteString - -- - -- This will take @1 + 1 + 3@ words (the @ThingId@ constructor + - -- unpacked @Int@ + unpacked @ShortByteString@), plus the words for the - -- string data. - - -- ** Heap fragmentation - -- | With GHC, the 'B.ByteString' representation uses /pinned/ memory, - -- meaning it cannot be moved by the GC. This is usually the right thing to - -- do for larger strings, but for small strings using pinned memory can - -- lead to heap fragmentation which wastes space. The 'ShortByteString' - -- type (and the @Text@ type from the @text@ package) use /unpinned/ memory - -- so they do not contribute to heap fragmentation. In addition, with GHC, - -- small unpinned strings are allocated in the same way as normal heap - -- allocations, rather than in a separate pinned area. - - -- * Introducing and eliminating 'ShortByteString's - empty, - singleton, - pack, - unpack, - fromShort, - toShort, - - -- * Basic interface - snoc, - cons, - append, - last, - tail, - uncons, - uncons2, - head, - init, - unsnoc, - null, - length, - - -- * Transforming ShortByteStrings - map, - reverse, - intercalate, - - -- * Reducing 'ShortByteString's (folds) - foldl, - foldl', - foldl1, - foldl1', - - foldr, - foldr', - foldr1, - foldr1', - - -- ** Special folds - all, - any, - concat, - - -- ** Generating and unfolding ByteStrings - replicate, - unfoldr, - unfoldrN, - - -- * Substrings - - -- ** Breaking strings - take, - takeEnd, - takeWhileEnd, - takeWhile, - drop, - dropEnd, - dropWhile, - dropWhileEnd, - breakEnd, - break, - span, - spanEnd, - splitAt, - split, - splitWith, - stripSuffix, - stripPrefix, - - -- * Predicates - isInfixOf, - isPrefixOf, - isSuffixOf, - - -- ** Search for arbitrary substrings - breakSubstring, - - -- * Searching ShortByteStrings - - -- ** Searching by equality - elem, - - -- ** Searching with a predicate - find, - filter, - partition, - - -- * Indexing ShortByteStrings - index, - indexMaybe, - (!?), - elemIndex, - elemIndices, - count, - findIndex, - findIndices, - - -- * Low level conversions - -- ** Packing 'Foreign.C.String.CString's and pointers - packCString, - packCStringLen, - - -- ** Using ShortByteStrings as 'Foreign.C.String.CString's - useAsCString, - useAsCStringLen, - ) where - -import System.OsPath.Data.ByteString.Short.Hidden diff --git a/System/OsPath/Data/ByteString/Short/Hidden.hs b/System/OsPath/Data/ByteString/Short/Hidden.hs deleted file mode 100644 --- a/System/OsPath/Data/ByteString/Short/Hidden.hs +++ /dev/null @@ -1,193 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NoImplicitPrelude #-} --- | --- Module : System.OsPath.Data.ByteString.Short.Hidden --- Copyright : (c) Duncan Coutts 2012-2013, Julian Ospald 2022 --- License : BSD-style --- --- Maintainer : hasufell@posteo.de --- Stability : stable --- Portability : ghc only --- --- A compact representation suitable for storing short byte strings in memory. --- --- In typical use cases it can be imported alongside "Data.ByteString", e.g. --- --- > import qualified Data.ByteString as B --- > import qualified Data.ByteString.Short as B --- > (ShortByteString, toShort, fromShort) --- --- Other 'ShortByteString' operations clash with "Data.ByteString" or "Prelude" --- functions however, so they should be imported @qualified@ with a different --- alias e.g. --- --- > import qualified Data.ByteString.Short as B.Short --- -module System.OsPath.Data.ByteString.Short.Hidden - - ( - - -- * The @ShortByteString@ type - - ShortByteString(..), - - -- ** Memory overhead - -- | With GHC, the memory overheads are as follows, expressed in words and - -- in bytes (words are 4 and 8 bytes on 32 or 64bit machines respectively). - -- - -- * 'B.ByteString' unshared: 8 words; 32 or 64 bytes. - -- - -- * 'B.ByteString' shared substring: 4 words; 16 or 32 bytes. - -- - -- * 'ShortByteString': 4 words; 16 or 32 bytes. - -- - -- For the string data itself, both 'ShortByteString' and 'B.ByteString' use - -- one byte per element, rounded up to the nearest word. For example, - -- including the overheads, a length 10 'ShortByteString' would take - -- @16 + 12 = 28@ bytes on a 32bit platform and @32 + 16 = 48@ bytes on a - -- 64bit platform. - -- - -- These overheads can all be reduced by 1 word (4 or 8 bytes) when the - -- 'ShortByteString' or 'B.ByteString' is unpacked into another constructor. - -- - -- For example: - -- - -- > data ThingId = ThingId {-# UNPACK #-} !Int - -- > {-# UNPACK #-} !ShortByteString - -- - -- This will take @1 + 1 + 3@ words (the @ThingId@ constructor + - -- unpacked @Int@ + unpacked @ShortByteString@), plus the words for the - -- string data. - - -- ** Heap fragmentation - -- | With GHC, the 'B.ByteString' representation uses /pinned/ memory, - -- meaning it cannot be moved by the GC. This is usually the right thing to - -- do for larger strings, but for small strings using pinned memory can - -- lead to heap fragmentation which wastes space. The 'ShortByteString' - -- type (and the @Text@ type from the @text@ package) use /unpinned/ memory - -- so they do not contribute to heap fragmentation. In addition, with GHC, - -- small unpinned strings are allocated in the same way as normal heap - -- allocations, rather than in a separate pinned area. - - -- * Introducing and eliminating 'ShortByteString's - empty, - singleton, - pack, - unpack, - fromShort, - toShort, - - -- * Basic interface - snoc, - cons, - append, - last, - tail, - uncons, - uncons2, - head, - init, - unsnoc, - null, - length, - - -- * Transforming ShortByteStrings - map, - reverse, - intercalate, - - -- * Reducing 'ShortByteString's (folds) - foldl, - foldl', - foldl1, - foldl1', - - foldr, - foldr', - foldr1, - foldr1', - - -- ** Special folds - all, - any, - concat, - - -- ** Generating and unfolding ByteStrings - replicate, - unfoldr, - unfoldrN, - - -- * Substrings - - -- ** Breaking strings - take, - takeEnd, - takeWhileEnd, - takeWhile, - drop, - dropEnd, - dropWhile, - dropWhileEnd, - breakEnd, - break, - span, - spanEnd, - splitAt, - split, - splitWith, - stripSuffix, - stripPrefix, - - -- * Predicates - isInfixOf, - isPrefixOf, - isSuffixOf, - - -- ** Search for arbitrary substrings - breakSubstring, - - -- * Searching ShortByteStrings - - -- ** Searching by equality - elem, - - -- ** Searching with a predicate - find, - filter, - partition, - - -- * Indexing ShortByteStrings - index, - indexMaybe, - (!?), - elemIndex, - elemIndices, - count, - findIndex, - findIndices, - - -- * Low level conversions - -- ** Packing 'Foreign.C.String.CString's and pointers - packCString, - packCStringLen, - - -- ** Using ShortByteStrings as 'Foreign.C.String.CString's - useAsCString, - useAsCStringLen, - ) where - -import Data.ByteString.Short.Internal -import System.OsPath.Data.ByteString.Short.Internal.Hidden - -import Prelude (Maybe(..), Ord(..), Num(..), ($), otherwise) -import Data.Word (Word8) - -uncons2 :: ShortByteString -> Maybe (Word8, Word8, ShortByteString) -uncons2 = \sbs -> - let l = length sbs - nl = l - 2 - in if | l <= 1 -> Nothing - | otherwise -> let h = indexWord8Array (asBA sbs) 0 - h' = indexWord8Array (asBA sbs) 1 - t = create nl $ \mba -> copyByteArray (asBA sbs) 1 mba 0 nl - in Just (h, h', t) diff --git a/System/OsPath/Data/ByteString/Short/Internal.hs b/System/OsPath/Data/ByteString/Short/Internal.hs deleted file mode 100644 --- a/System/OsPath/Data/ByteString/Short/Internal.hs +++ /dev/null @@ -1,17 +0,0 @@ --- | --- Module : System.OsPath.Data.ByteString.Short.Internal --- Copyright : © 2022 Julian Ospald --- License : MIT --- --- Maintainer : Julian Ospald --- Stability : experimental --- Portability : portable --- --- Internal low-level utilities mostly for 'System.OsPath.Data.ByteString.Short.Word16', --- such as byte-array operations and other stuff not meant to be exported from Word16 module. -module System.OsPath.Data.ByteString.Short.Internal {-# DEPRECATED "Use System.OsString.Data.ByteString.Short.Internal from os-string >= 2.0.0 package instead. This module will be removed in filepath >= 1.5." #-} - ( module System.OsPath.Data.ByteString.Short.Internal.Hidden - ) - where - -import System.OsPath.Data.ByteString.Short.Internal.Hidden diff --git a/System/OsPath/Data/ByteString/Short/Internal/Hidden.hs b/System/OsPath/Data/ByteString/Short/Internal/Hidden.hs deleted file mode 100644 --- a/System/OsPath/Data/ByteString/Short/Internal/Hidden.hs +++ /dev/null @@ -1,481 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE UnliftedFFITypes #-} - --- | --- Module : System.OsPath.Data.ByteString.Short.Internal.Hidden --- Copyright : © 2022 Julian Ospald --- License : MIT --- --- Maintainer : Julian Ospald --- Stability : experimental --- Portability : portable --- --- Internal low-level utilities mostly for 'System.OsPath.Data.ByteString.Short.Word16', --- such as byte-array operations and other stuff not meant to be exported from Word16 module. -module System.OsPath.Data.ByteString.Short.Internal.Hidden where - -import Control.Monad.ST -import Control.Exception (assert, throwIO) -import Data.Bits (Bits(..)) -import Data.ByteString.Short.Internal (ShortByteString(..), length) -#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) -import Foreign.C.String ( CString, CStringLen ) -import Foreign.C.Types ( CSize(..) ) -import Foreign.Storable (pokeByteOff) -#endif -import Foreign.Marshal.Array (withArray0, peekArray0, newArray0, withArrayLen, peekArray) -import GHC.Exts -import GHC.Word -import GHC.ST - ( ST (ST) ) -import GHC.Stack ( HasCallStack ) -import Prelude hiding - ( length ) - -import qualified Data.ByteString.Short.Internal as BS -import qualified Data.Char as C -import qualified Data.List as List - - -_nul :: Word16 -_nul = 0x00 - -isSpace :: Word16 -> Bool -isSpace = C.isSpace . word16ToChar - --- | Total conversion to char. -word16ToChar :: Word16 -> Char -word16ToChar = C.chr . fromIntegral - -create :: Int -> (forall s. MBA s -> ST s ()) -> ShortByteString -create len fill = - runST $ do - mba <- newByteArray len - fill mba - BA# ba# <- unsafeFreezeByteArray mba - return (SBS ba#) -{-# INLINE create #-} - - -asBA :: ShortByteString -> BA -asBA (SBS ba#) = BA# ba# - - - -data BA = BA# ByteArray# -data MBA s = MBA# (MutableByteArray# s) - - -newPinnedByteArray :: Int -> ST s (MBA s) -newPinnedByteArray (I# len#) = - ST $ \s -> case newPinnedByteArray# len# s of - (# s', mba# #) -> (# s', MBA# mba# #) - -newByteArray :: Int -> ST s (MBA s) -newByteArray (I# len#) = - ST $ \s -> case newByteArray# len# s of - (# s', mba# #) -> (# s', MBA# mba# #) - -copyByteArray :: BA -> Int -> MBA s -> Int -> Int -> ST s () -copyByteArray (BA# src#) (I# src_off#) (MBA# dst#) (I# dst_off#) (I# len#) = - ST $ \s -> case copyByteArray# src# src_off# dst# dst_off# len# s of - s' -> (# s', () #) - -unsafeFreezeByteArray :: MBA s -> ST s BA -unsafeFreezeByteArray (MBA# mba#) = - ST $ \s -> case unsafeFreezeByteArray# mba# s of - (# s', ba# #) -> (# s', BA# ba# #) - -copyAddrToByteArray :: Ptr a -> MBA RealWorld -> Int -> Int -> ST RealWorld () -copyAddrToByteArray (Ptr src#) (MBA# dst#) (I# dst_off#) (I# len#) = - ST $ \s -> case copyAddrToByteArray# src# dst# dst_off# len# s of - s' -> (# s', () #) - - --- this is a copy-paste from bytestring -#if !MIN_VERSION_bytestring(0,10,9) ------------------------------------------------------------------------- --- Primop replacements - --- --------------------------------------------------------------------- --- --- Standard C functions --- - -foreign import ccall unsafe "string.h strlen" c_strlen - :: CString -> IO CSize - - --- --------------------------------------------------------------------- --- --- Uses our C code --- - --- | /O(n)./ Construct a new @ShortByteString@ from a @CString@. The --- resulting @ShortByteString@ is an immutable copy of the original --- @CString@, and is managed on the Haskell heap. The original --- @CString@ must be null terminated. --- --- @since 0.10.10.0 -packCString :: CString -> IO ShortByteString -packCString cstr = do - len <- c_strlen cstr - packCStringLen (cstr, fromIntegral len) - --- | /O(n)./ Construct a new @ShortByteString@ from a @CStringLen@. The --- resulting @ShortByteString@ is an immutable copy of the original @CStringLen@. --- The @ShortByteString@ is a normal Haskell value and will be managed on the --- Haskell heap. --- --- @since 0.10.10.0 -packCStringLen :: CStringLen -> IO ShortByteString -packCStringLen (cstr, len) | len >= 0 = BS.createFromPtr cstr len -packCStringLen (_, len) = - moduleErrorIO "packCStringLen" ("negative length: " ++ show len) - --- | /O(n) construction./ Use a @ShortByteString@ with a function requiring a --- null-terminated @CString@. The @CString@ is a copy and will be freed --- automatically; it must not be stored or used after the --- subcomputation finishes. --- --- @since 0.10.10.0 -useAsCString :: ShortByteString -> (CString -> IO a) -> IO a -useAsCString bs action = - allocaBytes (l+1) $ \buf -> do - BS.copyToPtr bs 0 buf (fromIntegral l) - pokeByteOff buf l (0::Word8) - action buf - where l = length bs - --- | /O(n) construction./ Use a @ShortByteString@ with a function requiring a 'CStringLen'. --- As for 'useAsCString' this function makes a copy of the original @ShortByteString@. --- It must not be stored or used after the subcomputation finishes. --- --- Beware that this function does not add a terminating @\NUL@ byte at the end of 'CStringLen'. --- If you need to construct a pointer to a null-terminated sequence, use 'useAsCString' --- (and measure length independently if desired). --- --- @since 0.10.10.0 -useAsCStringLen :: ShortByteString -> (CStringLen -> IO a) -> IO a -useAsCStringLen bs action = - allocaBytes l $ \buf -> do - BS.copyToPtr bs 0 buf (fromIntegral l) - action (buf, l) - where l = length bs - - -#endif - - --- | /O(n)./ Construct a new @ShortByteString@ from a @CWString@. The --- resulting @ShortByteString@ is an immutable copy of the original --- @CWString@, and is managed on the Haskell heap. The original --- @CWString@ must be null terminated. --- --- @since 0.10.10.0 -packCWString :: Ptr Word16 -> IO ShortByteString -packCWString cwstr = do - cs <- peekArray0 _nul cwstr - return (packWord16 cs) - --- | /O(n)./ Construct a new @ShortByteString@ from a @CWStringLen@. The --- resulting @ShortByteString@ is an immutable copy of the original @CWStringLen@. --- The @ShortByteString@ is a normal Haskell value and will be managed on the --- Haskell heap. --- --- @since 0.10.10.0 -packCWStringLen :: (Ptr Word16, Int) -> IO ShortByteString -packCWStringLen (cp, len) = do - cs <- peekArray len cp - return (packWord16 cs) - - --- | /O(n) construction./ Use a @ShortByteString@ with a function requiring a --- null-terminated @CWString@. The @CWString@ is a copy and will be freed --- automatically; it must not be stored or used after the --- subcomputation finishes. --- --- @since 0.10.10.0 -useAsCWString :: ShortByteString -> (Ptr Word16 -> IO a) -> IO a -useAsCWString = withArray0 _nul . unpackWord16 - --- | /O(n) construction./ Use a @ShortByteString@ with a function requiring a @CWStringLen@. --- As for @useAsCWString@ this function makes a copy of the original @ShortByteString@. --- It must not be stored or used after the subcomputation finishes. --- --- @since 0.10.10.0 -useAsCWStringLen :: ShortByteString -> ((Ptr Word16, Int) -> IO a) -> IO a -useAsCWStringLen bs action = withArrayLen (unpackWord16 bs) $ \ len ptr -> action (ptr, len) - --- | /O(n) construction./ Use a @ShortByteString@ with a function requiring a @CWStringLen@. --- As for @useAsCWString@ this function makes a copy of the original @ShortByteString@. --- It must not be stored or used after the subcomputation finishes. --- --- @since 0.10.10.0 -newCWString :: ShortByteString -> IO (Ptr Word16) -newCWString = newArray0 _nul . unpackWord16 - - - - - -- --------------------------------------------------------------------- --- Internal utilities - -moduleErrorIO :: String -> String -> IO a -moduleErrorIO fun msg = throwIO . userError $ moduleErrorMsg fun msg -{-# NOINLINE moduleErrorIO #-} - -moduleErrorMsg :: String -> String -> String -moduleErrorMsg fun msg = "System.OsPath.Data.ByteString.Short." ++ fun ++ ':':' ':msg - -packWord16 :: [Word16] -> ShortByteString -packWord16 cs = packLenWord16 (List.length cs) cs - -packLenWord16 :: Int -> [Word16] -> ShortByteString -packLenWord16 len ws0 = - create (len * 2) (\mba -> go mba 0 ws0) - where - go :: MBA s -> Int -> [Word16] -> ST s () - go !_ !_ [] = return () - go !mba !i (w:ws) = do - writeWord16Array mba i w - go mba (i+2) ws - - -unpackWord16 :: ShortByteString -> [Word16] -unpackWord16 sbs = go len [] - where - len = length sbs - go !i !acc - | i < 1 = acc - | otherwise = let !w = indexWord16Array (asBA sbs) (i - 2) - in go (i - 2) (w:acc) - -packWord16Rev :: [Word16] -> ShortByteString -packWord16Rev cs = packLenWord16Rev (List.length cs * 2) cs - -packLenWord16Rev :: Int -> [Word16] -> ShortByteString -packLenWord16Rev len ws0 = - create len (\mba -> go mba len ws0) - where - go :: MBA s -> Int -> [Word16] -> ST s () - go !_ !_ [] = return () - go !mba !i (w:ws) = do - writeWord16Array mba (i - 2) w - go mba (i - 2) ws - - --- | This isn't strictly Word16 array write. Instead it's two consecutive Word8 array --- writes to avoid endianness issues due to primops doing automatic alignment based --- on host platform. We want to always write LE to the byte array. -writeWord16Array :: MBA s - -> Int -- ^ Word8 index (not Word16) - -> Word16 - -> ST s () -writeWord16Array (MBA# mba#) (I# i#) (W16# w#) = - case encodeWord16LE# w# of - (# lsb#, msb# #) -> - ST (\s -> case writeWord8Array# mba# i# lsb# s of - s' -> (# s', () #)) >> - ST (\s -> case writeWord8Array# mba# (i# +# 1#) msb# s of - s' -> (# s', () #)) - -indexWord8Array :: BA - -> Int -- ^ Word8 index - -> Word8 -indexWord8Array (BA# ba#) (I# i#) = W8# (indexWord8Array# ba# i#) - --- | This isn't strictly Word16 array read. Instead it's two Word8 array reads --- to avoid endianness issues due to primops doing automatic alignment based --- on host platform. We expect the byte array to be LE always. -indexWord16Array :: BA - -> Int -- ^ Word8 index (not Word16) - -> Word16 -indexWord16Array ba i = fromIntegral lsb .|. (fromIntegral msb `shiftL` 8) - where - lsb = indexWord8Array ba i - msb = indexWord8Array ba (i + 1) - -#if !MIN_VERSION_base(4,16,0) - -encodeWord16LE# :: Word# -- ^ Word16 - -> (# Word#, Word# #) -- ^ Word8 (LSB, MSB) -encodeWord16LE# x# = (# x# `and#` int2Word# 0xff# - , x# `and#` int2Word# 0xff00# `shiftRL#` 8# #) - -decodeWord16LE# :: (# Word#, Word# #) -- ^ Word8 (LSB, MSB) - -> Word# -- ^ Word16 -decodeWord16LE# (# lsb#, msb# #) = msb# `shiftL#` 8# `or#` lsb# - -#else - -encodeWord16LE# :: Word16# -- ^ Word16 - -> (# Word8#, Word8# #) -- ^ Word8 (LSB, MSB) -encodeWord16LE# x# = (# word16ToWord8# x# - , word16ToWord8# (x# `uncheckedShiftRLWord16#` 8#) #) - where - word16ToWord8# y = wordToWord8# (word16ToWord# y) - -decodeWord16LE# :: (# Word8#, Word8# #) -- ^ Word8 (LSB, MSB) - -> Word16# -- ^ Word16 -decodeWord16LE# (# lsb#, msb# #) = ((word8ToWord16# msb# `uncheckedShiftLWord16#` 8#) `orWord16#` word8ToWord16# lsb#) - where - word8ToWord16# y = wordToWord16# (word8ToWord# y) - -#endif - -setByteArray :: MBA s -> Int -> Int -> Int -> ST s () -setByteArray (MBA# dst#) (I# off#) (I# len#) (I# c#) = - ST $ \s -> case setByteArray# dst# off# len# c# s of - s' -> (# s', () #) - -copyMutableByteArray :: MBA s -> Int -> MBA s -> Int -> Int -> ST s () -copyMutableByteArray (MBA# src#) (I# src_off#) (MBA# dst#) (I# dst_off#) (I# len#) = - ST $ \s -> case copyMutableByteArray# src# src_off# dst# dst_off# len# s of - s' -> (# s', () #) - --- | Given the maximum size needed and a function to make the contents --- of a ShortByteString, createAndTrim makes the 'ShortByteString'. --- The generating function is required to return the actual final size --- (<= the maximum size) and the result value. The resulting byte array --- is realloced to this size. -createAndTrim :: Int -> (forall s. MBA s -> ST s (Int, a)) -> (ShortByteString, a) -createAndTrim l fill = - runST $ do - mba <- newByteArray l - (l', res) <- fill mba - if assert (l' <= l) $ l' >= l - then do - BA# ba# <- unsafeFreezeByteArray mba - return (SBS ba#, res) - else do - mba2 <- newByteArray l' - copyMutableByteArray mba 0 mba2 0 l' - BA# ba# <- unsafeFreezeByteArray mba2 - return (SBS ba#, res) -{-# INLINE createAndTrim #-} - -createAndTrim' :: Int -> (forall s. MBA s -> ST s Int) -> ShortByteString -createAndTrim' l fill = - runST $ do - mba <- newByteArray l - l' <- fill mba - if assert (l' <= l) $ l' >= l - then do - BA# ba# <- unsafeFreezeByteArray mba - return (SBS ba#) - else do - mba2 <- newByteArray l' - copyMutableByteArray mba 0 mba2 0 l' - BA# ba# <- unsafeFreezeByteArray mba2 - return (SBS ba#) -{-# INLINE createAndTrim' #-} - -createAndTrim'' :: Int -> (forall s. MBA s -> MBA s -> ST s (Int, Int)) -> (ShortByteString, ShortByteString) -createAndTrim'' l fill = - runST $ do - mba1 <- newByteArray l - mba2 <- newByteArray l - (l1, l2) <- fill mba1 mba2 - sbs1 <- freeze' l1 mba1 - sbs2 <- freeze' l2 mba2 - pure (sbs1, sbs2) - where - freeze' :: Int -> MBA s -> ST s ShortByteString - freeze' l' mba = - if assert (l' <= l) $ l' >= l - then do - BA# ba# <- unsafeFreezeByteArray mba - return (SBS ba#) - else do - mba2 <- newByteArray l' - copyMutableByteArray mba 0 mba2 0 l' - BA# ba# <- unsafeFreezeByteArray mba2 - return (SBS ba#) -{-# INLINE createAndTrim'' #-} - --- Returns the index of the first match or the length of the whole --- bytestring if nothing matched. -findIndexOrLength :: (Word16 -> Bool) -> ShortByteString -> Int -findIndexOrLength k (assertEven -> sbs) = go 0 - where - l = BS.length sbs - ba = asBA sbs - w = indexWord16Array ba - go !n | n >= l = l `div` 2 - | k (w n) = n `div` 2 - | otherwise = go (n + 2) -{-# INLINE findIndexOrLength #-} - - --- | Returns the length of the substring matching, not the index. --- If no match, returns 0. -findFromEndUntil :: (Word16 -> Bool) -> ShortByteString -> Int -findFromEndUntil k sbs = go (BS.length sbs - 2) - where - ba = asBA sbs - w = indexWord16Array ba - go !n | n < 0 = 0 - | k (w n) = (n `div` 2) + 1 - | otherwise = go (n - 2) -{-# INLINE findFromEndUntil #-} - - -assertEven :: ShortByteString -> ShortByteString -assertEven sbs@(SBS barr#) - | even (I# (sizeofByteArray# barr#)) = sbs - | otherwise = error ("Uneven number of bytes: " <> show (BS.length sbs) <> ". This is not a Word16 bytestream.") - - --- Common up near identical calls to `error' to reduce the number --- constant strings created when compiled: -errorEmptySBS :: HasCallStack => String -> a -errorEmptySBS fun = moduleError fun "empty ShortByteString" -{-# NOINLINE errorEmptySBS #-} - -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 - diff --git a/System/OsPath/Data/ByteString/Short/Word16.hs b/System/OsPath/Data/ByteString/Short/Word16.hs deleted file mode 100644 --- a/System/OsPath/Data/ByteString/Short/Word16.hs +++ /dev/null @@ -1,159 +0,0 @@ --- | --- Module : System.OsPath.Data.ByteString.Short.Word16 --- Copyright : © 2022 Julian Ospald --- License : MIT --- --- Maintainer : Julian Ospald --- Stability : experimental --- Portability : portable --- --- ShortByteStrings encoded as UTF16-LE, suitable for windows FFI calls. --- --- Word16s are *always* in BE encoding (both input and output), so e.g. 'pack' --- takes a list of BE encoded @[Word16]@ and produces a UTF16-LE encoded ShortByteString. --- --- Likewise, 'unpack' takes a UTF16-LE encoded ShortByteString and produces a list of BE encoded @[Word16]@. --- --- Indices and lengths are always in respect to Word16, not Word8. --- --- All functions will error out if the input string is not a valid UTF16 stream (uneven number of bytes). --- So use this module with caution. -module System.OsPath.Data.ByteString.Short.Word16 {-# DEPRECATED "Use System.OsString.Data.ByteString.Short.Word16 from os-string >= 2.0.0 package instead. This module will be removed in filepath >= 1.5." #-} ( - -- * The @ShortByteString@ type and representation - ShortByteString(..), - - -- * Introducing and eliminating 'ShortByteString's - empty, - singleton, - pack, - unpack, - fromShort, - toShort, - - -- * Basic interface - snoc, - cons, - append, - last, - tail, - uncons, - uncons2, - head, - init, - unsnoc, - null, - length, - numWord16, - - -- * Transforming ShortByteStrings - map, - reverse, - intercalate, - - -- * Reducing 'ShortByteString's (folds) - foldl, - foldl', - foldl1, - foldl1', - - foldr, - foldr', - foldr1, - foldr1', - - -- ** Special folds - all, - any, - concat, - - -- ** Generating and unfolding ByteStrings - replicate, - unfoldr, - unfoldrN, - - -- * Substrings - - -- ** Breaking strings - take, - takeEnd, - takeWhileEnd, - takeWhile, - drop, - dropEnd, - dropWhile, - dropWhileEnd, - breakEnd, - break, - span, - spanEnd, - splitAt, - split, - splitWith, - stripSuffix, - stripPrefix, - - -- * Predicates - isInfixOf, - isPrefixOf, - isSuffixOf, - - -- ** Search for arbitrary substrings - breakSubstring, - - -- * Searching ShortByteStrings - - -- ** Searching by equality - elem, - - -- ** Searching with a predicate - find, - filter, - partition, - - -- * Indexing ShortByteStrings - index, - indexMaybe, - (!?), - elemIndex, - elemIndices, - count, - findIndex, - findIndices, - - -- ** Encoding validation - -- isValidUtf8, - - -- * Low level conversions - -- ** Packing 'CString's and pointers - packCWString, - packCWStringLen, - newCWString, - - -- ** Using ShortByteStrings as 'CString's - useAsCWString, - useAsCWStringLen - ) -where - -import Prelude hiding - ( Foldable(..) - , all - , any - , reverse - , break - , concat - , drop - , dropWhile - , filter - , head - , init - , last - , map - , replicate - , span - , splitAt - , tail - , take - , takeWhile - ) -import System.OsPath.Data.ByteString.Short.Word16.Hidden diff --git a/System/OsPath/Data/ByteString/Short/Word16/Hidden.hs b/System/OsPath/Data/ByteString/Short/Word16/Hidden.hs deleted file mode 100644 --- a/System/OsPath/Data/ByteString/Short/Word16/Hidden.hs +++ /dev/null @@ -1,895 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} - -{-# OPTIONS_GHC -fno-warn-name-shadowing -fexpose-all-unfoldings #-} - --- | --- Module : System.OsPath.Data.ByteString.Short.Word16.Hidden --- Copyright : © 2022 Julian Ospald --- License : MIT --- --- Maintainer : Julian Ospald --- Stability : experimental --- Portability : portable --- --- ShortByteStrings encoded as UTF16-LE, suitable for windows FFI calls. --- --- Word16s are *always* in BE encoding (both input and output), so e.g. 'pack' --- takes a list of BE encoded @[Word16]@ and produces a UTF16-LE encoded ShortByteString. --- --- Likewise, 'unpack' takes a UTF16-LE encoded ShortByteString and produces a list of BE encoded @[Word16]@. --- --- Indices and lengths are always in respect to Word16, not Word8. --- --- All functions will error out if the input string is not a valid UTF16 stream (uneven number of bytes). --- So use this module with caution. -module System.OsPath.Data.ByteString.Short.Word16.Hidden ( - -- * The @ShortByteString@ type and representation - ShortByteString(..), - - -- * Introducing and eliminating 'ShortByteString's - empty, - singleton, - pack, - unpack, - fromShort, - toShort, - - -- * Basic interface - snoc, - cons, - append, - last, - tail, - uncons, - uncons2, - head, - init, - unsnoc, - null, - length, - numWord16, - - -- * Transforming ShortByteStrings - map, - reverse, - intercalate, - - -- * Reducing 'ShortByteString's (folds) - foldl, - foldl', - foldl1, - foldl1', - - foldr, - foldr', - foldr1, - foldr1', - - -- ** Special folds - all, - any, - concat, - - -- ** Generating and unfolding ByteStrings - replicate, - unfoldr, - unfoldrN, - - -- * Substrings - - -- ** Breaking strings - take, - takeEnd, - takeWhileEnd, - takeWhile, - drop, - dropEnd, - dropWhile, - dropWhileEnd, - breakEnd, - break, - span, - spanEnd, - splitAt, - split, - splitWith, - stripSuffix, - stripPrefix, - - -- * Predicates - isInfixOf, - isPrefixOf, - isSuffixOf, - - -- ** Search for arbitrary substrings - breakSubstring, - - -- * Searching ShortByteStrings - - -- ** Searching by equality - elem, - - -- ** Searching with a predicate - find, - filter, - partition, - - -- * Indexing ShortByteStrings - index, - indexMaybe, - (!?), - elemIndex, - elemIndices, - count, - findIndex, - findIndices, - - -- ** Encoding validation - -- isValidUtf8, - - -- * Low level conversions - -- ** Packing 'CString's and pointers - packCWString, - packCWStringLen, - newCWString, - - -- ** Using ShortByteStrings as 'CString's - useAsCWString, - useAsCWStringLen - ) -where -import System.OsPath.Data.ByteString.Short.Hidden ( append, intercalate, concat, stripSuffix, stripPrefix, isPrefixOf, isSuffixOf, length, empty, null, ShortByteString(..), fromShort, toShort ) -import System.OsPath.Data.ByteString.Short.Internal.Hidden -import Data.Bits - ( shiftR - ) -import Data.Word -import Prelude hiding - ( Foldable(..) - , all - , any - , reverse - , break - , concat - , drop - , dropWhile - , filter - , head - , init - , last - , map - , replicate - , span - , splitAt - , tail - , take - , takeWhile - ) -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 - - --- ----------------------------------------------------------------------------- --- Introducing and eliminating 'ShortByteString's - --- | /O(1)/ Convert a 'Word16' into a 'ShortByteString' -singleton :: Word16 -> ShortByteString -singleton = \w -> create 2 (\mba -> writeWord16Array mba 0 w) - - --- | /O(n)/. Convert a list into a 'ShortByteString' -pack :: [Word16] -> ShortByteString -pack = packWord16 - - --- | /O(n)/. Convert a 'ShortByteString' into a list. -unpack :: ShortByteString -> [Word16] -unpack = unpackWord16 . assertEven - - --- --------------------------------------------------------------------- --- Basic interface - --- | This is like 'length', but the number of 'Word16', not 'Word8'. -numWord16 :: ShortByteString -> Int -numWord16 = (`shiftR` 1) . BS.length . assertEven - -infixr 5 `cons` --same as list (:) -infixl 5 `snoc` - --- | /O(n)/ Append a Word16 to the end of a 'ShortByteString' --- --- Note: copies the entire byte array -snoc :: ShortByteString -> Word16 -> ShortByteString -snoc = \(assertEven -> sbs) c -> let l = BS.length sbs - nl = l + 2 - in create nl $ \mba -> do - copyByteArray (asBA sbs) 0 mba 0 l - writeWord16Array mba l c - --- | /O(n)/ 'cons' is analogous to (:) for lists. --- --- Note: copies the entire byte array -cons :: Word16 -> ShortByteString -> ShortByteString -cons c = \(assertEven -> sbs) -> let l = BS.length sbs - nl = l + 2 - in create nl $ \mba -> do - writeWord16Array mba 0 c - copyByteArray (asBA sbs) 0 mba 2 l - --- | /O(1)/ Extract the last element of a ShortByteString, which must be finite and at least one Word16. --- An exception will be thrown in the case of an empty ShortByteString. -last :: HasCallStack => ShortByteString -> Word16 -last = \(assertEven -> sbs) -> case null sbs of - True -> errorEmptySBS "last" - False -> indexWord16Array (asBA sbs) (BS.length sbs - 2) - --- | /O(n)/ Extract the elements after the head of a ShortByteString, which must at least one Word16. --- An exception will be thrown in the case of an empty ShortByteString. --- --- Note: copies the entire byte array -tail :: HasCallStack => ShortByteString -> ShortByteString -tail = \(assertEven -> sbs) -> - let l = BS.length sbs - nl = l - 2 - in if - | l <= 0 -> errorEmptySBS "tail" - | otherwise -> create nl $ \mba -> copyByteArray (asBA sbs) 2 mba 0 nl - --- | /O(n)/ Extract the head and tail of a ByteString, returning Nothing --- if it is empty. -uncons :: ShortByteString -> Maybe (Word16, ShortByteString) -uncons = \(assertEven -> sbs) -> - let l = BS.length sbs - nl = l - 2 - in if | l <= 0 -> Nothing - | otherwise -> let h = indexWord16Array (asBA sbs) 0 - t = create nl $ \mba -> copyByteArray (asBA sbs) 2 mba 0 nl - in Just (h, t) - --- | /O(n)/ Extract first two elements and the rest of a ByteString, --- returning Nothing if it is shorter than two elements. -uncons2 :: ShortByteString -> Maybe (Word16, Word16, ShortByteString) -uncons2 = \(assertEven -> sbs) -> - let l = BS.length sbs - nl = l - 4 - in if | l <= 2 -> Nothing - | otherwise -> let h = indexWord16Array (asBA sbs) 0 - h' = indexWord16Array (asBA sbs) 2 - t = create nl $ \mba -> copyByteArray (asBA sbs) 4 mba 0 nl - in Just (h, h', t) - --- | /O(1)/ Extract the first element of a ShortByteString, which must be at least one Word16. --- An exception will be thrown in the case of an empty ShortByteString. -head :: HasCallStack => ShortByteString -> Word16 -head = \(assertEven -> sbs) -> case null sbs of - True -> errorEmptySBS "last" - False -> indexWord16Array (asBA sbs) 0 - --- | /O(n)/ Return all the elements of a 'ShortByteString' except the last one. --- An exception will be thrown in the case of an empty ShortByteString. --- --- Note: copies the entire byte array -init :: HasCallStack => ShortByteString -> ShortByteString -init = \(assertEven -> sbs) -> - let l = BS.length sbs - nl = l - 2 - in if - | l <= 0 -> errorEmptySBS "tail" - | otherwise -> create nl $ \mba -> copyByteArray (asBA sbs) 0 mba 0 nl - --- | /O(n)/ Extract the 'init' and 'last' of a ByteString, returning Nothing --- if it is empty. -unsnoc :: ShortByteString -> Maybe (ShortByteString, Word16) -unsnoc = \(assertEven -> sbs) -> - let l = BS.length sbs - nl = l - 2 - in if | l <= 0 -> Nothing - | otherwise -> let l' = indexWord16Array (asBA sbs) (l - 2) - i = create nl $ \mba -> copyByteArray (asBA sbs) 0 mba 0 nl - in Just (i, l') - - --- --------------------------------------------------------------------- --- Transformations - --- | /O(n)/ 'map' @f xs@ is the ShortByteString obtained by applying @f@ to each --- element of @xs@. -map :: (Word16 -> Word16) -> ShortByteString -> ShortByteString -map f = \(assertEven -> sbs) -> - let l = BS.length sbs - ba = asBA sbs - in create l (\mba -> go ba mba 0 l) - where - go :: BA -> MBA s -> Int -> Int -> ST s () - go !ba !mba !i !l - | i >= l = return () - | otherwise = do - let w = indexWord16Array ba i - writeWord16Array mba i (f w) - go ba mba (i+2) l - --- TODO: implement more efficiently --- | /O(n)/ 'reverse' @xs@ efficiently returns the elements of @xs@ in reverse order. -reverse :: ShortByteString -> ShortByteString -reverse = \(assertEven -> sbs) -> - let l = BS.length sbs - ba = asBA sbs - in create l (\mba -> go ba mba 0 l) - where - go :: BA -> MBA s -> Int -> Int -> ST s () - go !ba !mba !i !l - | i >= l = return () - | otherwise = do - let w = indexWord16Array ba i - writeWord16Array mba (l - 2 - i) w - go ba mba (i+2) l - - --- --------------------------------------------------------------------- --- Special folds - --- | /O(n)/ Applied to a predicate and a 'ShortByteString', 'all' determines --- if all elements of the 'ShortByteString' satisfy the predicate. -all :: (Word16 -> Bool) -> ShortByteString -> Bool -all k = \(assertEven -> sbs) -> - let l = BS.length sbs - ba = asBA sbs - w = indexWord16Array ba - go !n | n >= l = True - | otherwise = k (w n) && go (n + 2) - in go 0 - - --- | /O(n)/ Applied to a predicate and a ByteString, 'any' determines if --- any element of the 'ByteString' satisfies the predicate. -any :: (Word16 -> Bool) -> ShortByteString -> Bool -any k = \(assertEven -> sbs) -> - let l = BS.length sbs - ba = asBA sbs - w = indexWord16Array ba - go !n | n >= l = False - | otherwise = k (w n) || go (n + 2) - in go 0 - - --- --------------------------------------------------------------------- --- Unfolds and replicates - - --- | /O(n)/ 'replicate' @n x@ is a ByteString of length @n@ with @x@ --- the value of every element. The following holds: --- --- > replicate w c = unfoldr w (\u -> Just (u,u)) c -replicate :: Int -> Word16 -> ShortByteString -replicate w c - | w <= 0 = empty - -- can't use setByteArray here, because we write UTF-16LE - | otherwise = create (w * 2) (`go` 0) - where - go mba ix - | ix < 0 || ix >= w * 2 = pure () - | otherwise = writeWord16Array mba ix c >> go mba (ix + 2) - --- | /O(n)/, where /n/ is the length of the result. The 'unfoldr' --- function is analogous to the List \'unfoldr\'. 'unfoldr' builds a --- ShortByteString from a seed value. The function takes the element and --- returns 'Nothing' if it is done producing the ShortByteString or returns --- 'Just' @(a,b)@, in which case, @a@ is the next byte in the string, --- and @b@ is the seed value for further production. --- --- This function is not efficient/safe. It will build a list of @[Word16]@ --- and run the generator until it returns `Nothing`, otherwise recurse infinitely, --- then finally create a 'ShortByteString'. --- --- Examples: --- --- > unfoldr (\x -> if x <= 5 then Just (x, x + 1) else Nothing) 0 --- > == pack [0, 1, 2, 3, 4, 5] --- -unfoldr :: (a -> Maybe (Word16, a)) -> a -> ShortByteString -unfoldr f x0 = packWord16Rev $ go x0 mempty - where - go x words' = case f x of - Nothing -> words' - Just (w, x') -> go x' (w:words') - --- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a ShortByteString from a seed --- value. However, the length of the result is limited by the first --- argument to 'unfoldrN'. This function is more efficient than 'unfoldr' --- when the maximum length of the result is known. --- --- The following equation relates 'unfoldrN' and 'unfoldr': --- --- > fst (unfoldrN n f s) == take n (unfoldr f s) --- -unfoldrN :: forall a. - Int -- ^ number of 'Word16' - -> (a -> Maybe (Word16, a)) - -> a - -> (ShortByteString, Maybe a) -unfoldrN i f = \x0 -> - if | i < 0 -> (empty, Just x0) - | otherwise -> createAndTrim (i * 2) $ \mba -> go mba x0 0 - - where - go :: forall s. MBA s -> a -> Int -> ST s (Int, Maybe a) - go !mba !x !n = go' x n - where - go' :: a -> Int -> ST s (Int, Maybe a) - go' !x' !n' - | n' == i * 2 = return (n', Just x') - | otherwise = case f x' of - Nothing -> return (n', Nothing) - Just (w, x'') -> do - writeWord16Array mba n' w - go' x'' (n'+2) - - --- -------------------------------------------------------------------- --- Predicates - - - --- --------------------------------------------------------------------- --- Substrings - --- | /O(n)/ 'take' @n@, applied to a ShortByteString @xs@, returns the prefix --- of @xs@ of length @n@, or @xs@ itself if @n > 'length' xs@. --- --- Note: copies the entire byte array -take :: Int -- ^ number of Word16 - -> ShortByteString - -> ShortByteString -take = \n (assertEven -> sbs) -> - let sl = numWord16 sbs - len8 = n * 2 - in if | n >= sl -> sbs - | n <= 0 -> empty - | otherwise -> - create len8 $ \mba -> copyByteArray (asBA sbs) 0 mba 0 len8 - - --- | /O(1)/ @'takeEnd' n xs@ is equivalent to @'drop' ('length' xs - n) xs@. --- Takes @n@ elements from end of bytestring. --- --- >>> takeEnd 3 "a\NULb\NULc\NULd\NULe\NULf\NULg\NUL" --- "e\NULf\NULg\NUL" --- >>> takeEnd 0 "a\NULb\NULc\NULd\NULe\NULf\NULg\NUL" --- "" --- >>> takeEnd 4 "a\NULb\NULc\NUL" --- "a\NULb\NULc\NUL" -takeEnd :: Int -- ^ number of 'Word16' - -> ShortByteString - -> ShortByteString -takeEnd n = \(assertEven -> sbs) -> - let sl = BS.length sbs - n2 = n * 2 - in if | n2 >= sl -> sbs - | n2 <= 0 -> empty - | otherwise -> create n2 $ \mba -> copyByteArray (asBA sbs) (max 0 (sl - n2)) mba 0 n2 - --- | Similar to 'P.takeWhile', --- returns the longest (possibly empty) prefix of elements --- satisfying the predicate. -takeWhile :: (Word16 -> Bool) -> ShortByteString -> ShortByteString -takeWhile f ps = take (findIndexOrLength (not . f) ps) ps - --- | Returns the longest (possibly empty) suffix of elements --- satisfying the predicate. --- --- @'takeWhileEnd' p@ is equivalent to @'reverse' . 'takeWhile' p . 'reverse'@. -takeWhileEnd :: (Word16 -> Bool) -> ShortByteString -> ShortByteString -takeWhileEnd f ps = drop (findFromEndUntil (not . f) ps) ps - - --- | /O(n)/ 'drop' @n@ @xs@ returns the suffix of @xs@ after the first n elements, or @[]@ if @n > 'length' xs@. --- --- Note: copies the entire byte array -drop :: Int -- ^ number of 'Word16' - -> ShortByteString - -> ShortByteString -drop = \n' (assertEven -> sbs) -> - let len = BS.length sbs - n = n' * 2 - in if | n <= 0 -> sbs - | n >= len -> empty - | otherwise -> - let newLen = len - n - in create newLen $ \mba -> copyByteArray (asBA sbs) n mba 0 newLen - --- | /O(1)/ @'dropEnd' n xs@ is equivalent to @'take' ('length' xs - n) xs@. --- Drops @n@ elements from end of bytestring. --- --- >>> dropEnd 3 "a\NULb\NULc\NULd\NULe\NULf\NULg\NUL" --- "a\NULb\NULc\NULd\NUL" --- >>> dropEnd 0 "a\NULb\NULc\NULd\NULe\NULf\NULg\NUL" --- "a\NULb\NULc\NULd\NULe\NULf\NULg\NUL" --- >>> dropEnd 4 "a\NULb\NULc\NUL" --- "" -dropEnd :: Int -- ^ number of 'Word16' - -> ShortByteString - -> ShortByteString -dropEnd n' = \(assertEven -> sbs) -> - let sl = BS.length sbs - nl = sl - n - n = n' * 2 - in if | n >= sl -> empty - | n <= 0 -> sbs - | otherwise -> create nl $ \mba -> copyByteArray (asBA sbs) 0 mba 0 nl - --- | Similar to 'P.dropWhile', --- drops the longest (possibly empty) prefix of elements --- satisfying the predicate and returns the remainder. --- --- Note: copies the entire byte array -dropWhile :: (Word16 -> Bool) -> ShortByteString -> ShortByteString -dropWhile f = \(assertEven -> ps) -> drop (findIndexOrLength (not . f) ps) ps - --- | Similar to 'P.dropWhileEnd', --- drops the longest (possibly empty) suffix of elements --- satisfying the predicate and returns the remainder. --- --- @'dropWhileEnd' p@ is equivalent to @'reverse' . 'dropWhile' p . 'reverse'@. --- --- @since 0.10.12.0 -dropWhileEnd :: (Word16 -> Bool) -> ShortByteString -> ShortByteString -dropWhileEnd f = \(assertEven -> ps) -> take (findFromEndUntil (not . f) ps) ps - --- | Returns the longest (possibly empty) suffix of elements which __do not__ --- satisfy the predicate and the remainder of the string. --- --- 'breakEnd' @p@ is equivalent to @'spanEnd' (not . p)@ and to @('takeWhileEnd' (not . p) &&& 'dropWhileEnd' (not . p))@. -breakEnd :: (Word16 -> Bool) -> ShortByteString -> (ShortByteString, ShortByteString) -breakEnd p = \(assertEven -> sbs) -> splitAt (findFromEndUntil p sbs) sbs - --- | Similar to 'P.break', --- returns the longest (possibly empty) prefix of elements which __do not__ --- satisfy the predicate and the remainder of the string. --- --- 'break' @p@ is equivalent to @'span' (not . p)@ and to @('takeWhile' (not . p) &&& 'dropWhile' (not . p))@. -break :: (Word16 -> Bool) -> ShortByteString -> (ShortByteString, ShortByteString) -break = \p (assertEven -> ps) -> case findIndexOrLength p ps of n -> splitAt n ps - --- | Similar to 'P.span', --- returns the longest (possibly empty) prefix of elements --- satisfying the predicate and the remainder of the string. --- --- 'span' @p@ is equivalent to @'break' (not . p)@ and to @('takeWhile' p &&& 'dropWhile' p)@. --- -span :: (Word16 -> Bool) -> ShortByteString -> (ShortByteString, ShortByteString) -{- HLINT ignore "Use span" -} -span p = break (not . p) . assertEven - --- | Returns the longest (possibly empty) suffix of elements --- satisfying the predicate and the remainder of the string. --- --- 'spanEnd' @p@ is equivalent to @'breakEnd' (not . p)@ and to @('takeWhileEnd' p &&& 'dropWhileEnd' p)@. --- --- We have --- --- > spanEnd (not . isSpace) "x y z" == ("x y ", "z") --- --- and --- --- > spanEnd (not . isSpace) ps --- > == --- > let (x, y) = span (not . isSpace) (reverse ps) in (reverse y, reverse x) --- -spanEnd :: (Word16 -> Bool) -> ShortByteString -> (ShortByteString, ShortByteString) -spanEnd p = \(assertEven -> ps) -> splitAt (findFromEndUntil (not.p) ps) ps - --- | /O(n)/ 'splitAt' @n xs@ is equivalent to @('take' n xs, 'drop' n xs)@. --- --- Note: copies the substrings -splitAt :: Int -- ^ number of Word16 - -> ShortByteString - -> (ShortByteString, ShortByteString) -splitAt n' = \(assertEven -> sbs) -> if - | n <= 0 -> (empty, sbs) - | otherwise -> - let slen = BS.length sbs - in if | n >= BS.length sbs -> (sbs, empty) - | otherwise -> - let llen = min slen (max 0 n) - rlen = max 0 (slen - max 0 n) - lsbs = create llen $ \mba -> copyByteArray (asBA sbs) 0 mba 0 llen - rsbs = create rlen $ \mba -> copyByteArray (asBA sbs) n mba 0 rlen - in (lsbs, rsbs) - where - n = n' * 2 - --- | /O(n)/ Break a 'ShortByteString' into pieces separated by the byte --- argument, consuming the delimiter. I.e. --- --- > split 10 "a\nb\nd\ne" == ["a","b","d","e"] -- fromEnum '\n' == 10 --- > split 97 "aXaXaXa" == ["","X","X","X",""] -- fromEnum 'a' == 97 --- > split 120 "x" == ["",""] -- fromEnum 'x' == 120 --- > split undefined "" == [] -- and not [""] --- --- and --- --- > intercalate [c] . split c == id --- > split == splitWith . (==) --- --- Note: copies the substrings -split :: Word16 -> ShortByteString -> [ShortByteString] -split w = splitWith (== w) . assertEven - - --- | /O(n)/ Splits a 'ShortByteString' into components delimited by --- separators, where the predicate returns True for a separator element. --- The resulting components do not contain the separators. Two adjacent --- separators result in an empty component in the output. eg. --- --- > splitWith (==97) "aabbaca" == ["","","bb","c",""] -- fromEnum 'a' == 97 --- > splitWith undefined "" == [] -- and not [""] --- -splitWith :: (Word16 -> Bool) -> ShortByteString -> [ShortByteString] -splitWith p = \(assertEven -> sbs) -> if - | BS.null sbs -> [] - | otherwise -> go sbs - where - go sbs' - | BS.null sbs' = [mempty] - | otherwise = - case break p sbs' of - (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) - - --- --------------------------------------------------------------------- --- Reducing 'ByteString's - --- | 'foldl', applied to a binary operator, a starting value (typically --- the left-identity of the operator), and a ShortByteString, reduces the --- ShortByteString using the binary operator, from left to right. --- -foldl :: (a -> Word16 -> a) -> a -> ShortByteString -> a -foldl f v = List.foldl f v . unpack . assertEven - --- | 'foldl'' is like 'foldl', but strict in the accumulator. --- -foldl' :: (a -> Word16 -> a) -> a -> ShortByteString -> a -foldl' f v = List.foldl' f v . unpack . assertEven - --- | 'foldr', applied to a binary operator, a starting value --- (typically the right-identity of the operator), and a ShortByteString, --- reduces the ShortByteString using the binary operator, from right to left. -foldr :: (Word16 -> a -> a) -> a -> ShortByteString -> a -foldr f v = List.foldr f v . unpack . assertEven - --- | 'foldr'' is like 'foldr', but strict in the accumulator. -foldr' :: (Word16 -> a -> a) -> a -> ShortByteString -> a -foldr' k v = Foldable.foldr' k v . unpack . assertEven - --- | 'foldl1' is a variant of 'foldl' that has no starting value --- argument, and thus must be applied to non-empty 'ShortByteString's. --- An exception will be thrown in the case of an empty ShortByteString. -foldl1 :: HasCallStack => (Word16 -> Word16 -> Word16) -> ShortByteString -> Word16 -foldl1 k = List.foldl1 k . unpack . assertEven - --- | 'foldl1'' is like 'foldl1', but strict in the accumulator. --- An exception will be thrown in the case of an empty ShortByteString. -foldl1' :: HasCallStack => (Word16 -> Word16 -> Word16) -> ShortByteString -> Word16 -foldl1' k = List.foldl1' k . unpack . assertEven - --- | 'foldr1' is a variant of 'foldr' that has no starting value argument, --- and thus must be applied to non-empty 'ShortByteString's --- An exception will be thrown in the case of an empty ShortByteString. -foldr1 :: HasCallStack => (Word16 -> Word16 -> Word16) -> ShortByteString -> Word16 -foldr1 k = List.foldr1 k . unpack . assertEven - --- | 'foldr1'' is a variant of 'foldr1', but is strict in the --- accumulator. -foldr1' :: HasCallStack => (Word16 -> Word16 -> Word16) -> ShortByteString -> Word16 -foldr1' k = \(assertEven -> sbs) -> if null sbs then errorEmptySBS "foldr1'" else foldr' k (last sbs) (init sbs) - - --- -------------------------------------------------------------------- --- Searching ShortByteString - --- | /O(1)/ 'ShortByteString' index (subscript) operator, starting from 0. -index :: HasCallStack - => ShortByteString - -> Int -- ^ number of 'Word16' - -> Word16 -index = \(assertEven -> sbs) i -> if - | i >= 0 && i < numWord16 sbs -> unsafeIndex sbs i - | otherwise -> indexError sbs i - --- | /O(1)/ 'ShortByteString' index, starting from 0, that returns 'Just' if: --- --- > 0 <= n < length bs --- --- @since 0.11.0.0 -indexMaybe :: ShortByteString - -> Int -- ^ number of 'Word16' - -> Maybe Word16 -indexMaybe = \(assertEven -> sbs) i -> if - | i >= 0 && i < numWord16 sbs -> Just $! unsafeIndex sbs i - | otherwise -> Nothing -{-# INLINE indexMaybe #-} - -unsafeIndex :: ShortByteString - -> Int -- ^ number of 'Word16' - -> Word16 -unsafeIndex sbs i = indexWord16Array (asBA sbs) (i * 2) - -indexError :: HasCallStack => ShortByteString -> Int -> a -indexError sbs i = - moduleError "index" $ "error in array index: " ++ show i - ++ " not in range [0.." ++ show (numWord16 sbs) ++ "]" - --- | /O(1)/ 'ShortByteString' index, starting from 0, that returns 'Just' if: --- --- > 0 <= n < length bs --- --- @since 0.11.0.0 -(!?) :: ShortByteString - -> Int -- ^ number of 'Word16' - -> Maybe Word16 -(!?) = indexMaybe -{-# INLINE (!?) #-} - --- | /O(n)/ 'elem' is the 'ShortByteString' membership predicate. -elem :: Word16 -> ShortByteString -> Bool -elem c = \(assertEven -> sbs) -> case elemIndex c sbs of Nothing -> False ; _ -> True - --- | /O(n)/ 'filter', applied to a predicate and a ByteString, --- returns a ByteString containing those characters that satisfy the --- predicate. -filter :: (Word16 -> Bool) -> ShortByteString -> ShortByteString -filter k = \(assertEven -> sbs) -> - let l = BS.length sbs - in if | l <= 0 -> sbs - | otherwise -> createAndTrim' l $ \mba -> go mba (asBA sbs) l - where - go :: forall s. MBA s -- mutable output bytestring - -> BA -- input bytestring - -> Int -- length of input bytestring - -> ST s Int - go !mba ba !l = go' 0 0 - where - go' :: Int -- bytes read - -> Int -- bytes written - -> ST s Int - go' !br !bw - | br >= l = return bw - | otherwise = do - let w = indexWord16Array ba br - if k w - then do - writeWord16Array mba bw w - go' (br+2) (bw+2) - else - go' (br+2) bw - --- | /O(n)/ The 'find' function takes a predicate and a ByteString, --- and returns the first element in matching the predicate, or 'Nothing' --- if there is no such element. --- --- > find f p = case findIndex f p of Just n -> Just (p ! n) ; _ -> Nothing --- -find :: (Word16 -> Bool) -> ShortByteString -> Maybe Word16 -find f = \(assertEven -> sbs) -> case findIndex f sbs of - Just n -> Just (sbs `index` n) - _ -> Nothing - --- | /O(n)/ The 'partition' function takes a predicate a ByteString and returns --- the pair of ByteStrings with elements which do and do not satisfy the --- predicate, respectively; i.e., --- --- > partition p bs == (filter p xs, filter (not . p) xs) --- -partition :: (Word16 -> Bool) -> ShortByteString -> (ShortByteString, ShortByteString) -partition k = \(assertEven -> sbs) -> - let l = BS.length sbs - in if | l <= 0 -> (sbs, sbs) - | otherwise -> createAndTrim'' l $ \mba1 mba2 -> go mba1 mba2 (asBA sbs) l - where - go :: forall s. - MBA s -- mutable output bytestring1 - -> MBA s -- mutable output bytestring2 - -> BA -- input bytestring - -> Int -- length of input bytestring - -> ST s (Int, Int) -- (length mba1, length mba2) - go !mba1 !mba2 ba !l = go' 0 0 - where - go' :: Int -- bytes read - -> Int -- bytes written to bytestring 1 - -> ST s (Int, Int) -- (length mba1, length mba2) - go' !br !bw1 - | br >= l = return (bw1, br - bw1) - | otherwise = do - let w = indexWord16Array ba br - if k w - then do - writeWord16Array mba1 bw1 w - go' (br+2) (bw1+2) - else do - writeWord16Array mba2 (br - bw1) w - go' (br+2) bw1 - --- -------------------------------------------------------------------- --- Indexing ShortByteString - --- | /O(n)/ The 'elemIndex' function returns the index of the first --- element in the given 'ShortByteString' which is equal to the query --- element, or 'Nothing' if there is no such element. -elemIndex :: Word16 - -> ShortByteString - -> Maybe Int -- ^ number of 'Word16' -{- HLINT ignore "Use elemIndex" -} -elemIndex k = findIndex (==k) . assertEven - --- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by returning --- the indices of all elements equal to the query element, in ascending order. -elemIndices :: Word16 -> ShortByteString -> [Int] -{- HLINT ignore "Use elemIndices" -} -elemIndices k = findIndices (==k) . assertEven - --- | count returns the number of times its argument appears in the ShortByteString -count :: Word16 -> ShortByteString -> Int -count w = List.length . elemIndices w . assertEven - --- | /O(n)/ The 'findIndex' function takes a predicate and a 'ShortByteString' and --- returns the index of the first element in the ByteString --- satisfying the predicate. -findIndex :: (Word16 -> Bool) -> ShortByteString -> Maybe Int -findIndex k = \(assertEven -> sbs) -> - let l = BS.length sbs - ba = asBA sbs - w = indexWord16Array ba - go !n | n >= l = Nothing - | k (w n) = Just (n `shiftR` 1) - | otherwise = go (n + 2) - in go 0 - --- | /O(n)/ The 'findIndices' function extends 'findIndex', by returning the --- indices of all elements satisfying the predicate, in ascending order. -findIndices :: (Word16 -> Bool) -> ShortByteString -> [Int] -findIndices k = \(assertEven -> sbs) -> - let l = BS.length sbs - ba = asBA sbs - w = indexWord16Array ba - go !n | n >= l = [] - | k (w n) = (n `shiftR` 1) : go (n + 2) - | otherwise = go (n + 2) - in go 0 - diff --git a/System/OsPath/Encoding.hs b/System/OsPath/Encoding.hs --- a/System/OsPath/Encoding.hs +++ b/System/OsPath/Encoding.hs @@ -28,4 +28,4 @@ ) where -import System.OsPath.Encoding.Internal.Hidden +import System.OsString.Encoding.Internal diff --git a/System/OsPath/Encoding/Internal.hs b/System/OsPath/Encoding/Internal.hs deleted file mode 100644 --- a/System/OsPath/Encoding/Internal.hs +++ /dev/null @@ -1,6 +0,0 @@ -module System.OsPath.Encoding.Internal {-# DEPRECATED "Use System.OsString.Encoding.Internal from os-string >= 2.0.0 package instead. This module will be removed in filepath >= 1.5." #-} - ( module System.OsPath.Encoding.Internal.Hidden - ) - where - -import System.OsPath.Encoding.Internal.Hidden diff --git a/System/OsPath/Encoding/Internal/Hidden.hs b/System/OsPath/Encoding/Internal/Hidden.hs deleted file mode 100644 --- a/System/OsPath/Encoding/Internal/Hidden.hs +++ /dev/null @@ -1,370 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude - , BangPatterns - , TypeApplications - , MultiWayIf - #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} - - -module System.OsPath.Encoding.Internal.Hidden where - -import qualified System.OsPath.Data.ByteString.Short.Hidden as BS8 -import qualified System.OsPath.Data.ByteString.Short.Word16.Hidden as BS16 - -import GHC.Base -import GHC.Real -import GHC.Num --- import GHC.IO -import GHC.IO.Buffer -import GHC.IO.Encoding.Failure -import GHC.IO.Encoding.Types -import Data.Bits -import Control.Exception (SomeException, try, Exception (displayException), evaluate, SomeAsyncException(..), catch, fromException, toException, throwIO) -import qualified GHC.Foreign as GHC -import Data.Either (Either) -import GHC.IO (unsafePerformIO) -import Control.DeepSeq (force, NFData (rnf)) -import Data.Bifunctor (first) -import Data.Data (Typeable) -import GHC.Show (Show (show)) -import Numeric (showHex) -import Foreign.C (CStringLen) -import Data.Char (chr) -import Foreign -import Prelude (FilePath, Either(..)) -import GHC.IO.Encoding (getFileSystemEncoding) - --- ----------------------------------------------------------------------------- --- UCS-2 LE --- - -ucs2le :: TextEncoding -ucs2le = mkUcs2le ErrorOnCodingFailure - -mkUcs2le :: CodingFailureMode -> TextEncoding -mkUcs2le cfm = TextEncoding { textEncodingName = "UCS-2LE", - mkTextDecoder = ucs2le_DF cfm, - mkTextEncoder = ucs2le_EF cfm } - -ucs2le_DF :: CodingFailureMode -> IO (TextDecoder ()) -ucs2le_DF cfm = - return (BufferCodec { - encode = ucs2le_decode, - recover = recoverDecode cfm, - close = return (), - getState = return (), - setState = const $ return () - }) - -ucs2le_EF :: CodingFailureMode -> IO (TextEncoder ()) -ucs2le_EF cfm = - return (BufferCodec { - encode = ucs2le_encode, - recover = recoverEncode cfm, - close = return (), - getState = return (), - setState = const $ return () - }) - - -ucs2le_decode :: DecodeBuffer -ucs2le_decode - input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } - output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } - = let - loop !ir !ow - | ow >= os = done OutputUnderflow ir ow - | ir >= iw = done InputUnderflow ir ow - | ir + 1 == iw = done InputUnderflow ir ow - | otherwise = do - c0 <- readWord8Buf iraw ir - c1 <- readWord8Buf iraw (ir+1) - let x1 = fromIntegral c1 `shiftL` 8 + fromIntegral c0 - ow' <- writeCharBuf oraw ow (unsafeChr x1) - loop (ir+2) ow' - - -- lambda-lifted, to avoid thunks being built in the inner-loop: - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) - in - loop ir0 ow0 - - -ucs2le_encode :: EncodeBuffer -ucs2le_encode - input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } - output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } - = let - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) - loop !ir !ow - | ir >= iw = done InputUnderflow ir ow - | os - ow < 2 = done OutputUnderflow ir ow - | otherwise = do - (c,ir') <- readCharBuf iraw ir - case ord c of - x | x < 0x10000 -> do - writeWord8Buf oraw ow (fromIntegral x) - writeWord8Buf oraw (ow+1) (fromIntegral (x `shiftR` 8)) - loop ir' (ow+2) - | otherwise -> done InvalidSequence ir ow - in - loop ir0 ow0 - --- ----------------------------------------------------------------------------- --- UTF-16b --- - --- | Mimics the base encoding for filesystem operations. This should be total on all inputs (word16 byte arrays). --- --- Note that this has a subtle difference to 'encodeWithBaseWindows'/'decodeWithBaseWindows': it doesn't care for --- the @0x0000@ end marker and will as such produce different results. Use @takeWhile (/= '\NUL')@ on the input --- to recover this behavior. -utf16le_b :: TextEncoding -utf16le_b = mkUTF16le_b ErrorOnCodingFailure - -mkUTF16le_b :: CodingFailureMode -> TextEncoding -mkUTF16le_b cfm = TextEncoding { textEncodingName = "UTF-16LE_b", - mkTextDecoder = utf16le_b_DF cfm, - mkTextEncoder = utf16le_b_EF cfm } - -utf16le_b_DF :: CodingFailureMode -> IO (TextDecoder ()) -utf16le_b_DF cfm = - return (BufferCodec { - encode = utf16le_b_decode, - recover = recoverDecode cfm, - close = return (), - getState = return (), - setState = const $ return () - }) - -utf16le_b_EF :: CodingFailureMode -> IO (TextEncoder ()) -utf16le_b_EF cfm = - return (BufferCodec { - encode = utf16le_b_encode, - recover = recoverEncode cfm, - close = return (), - getState = return (), - setState = const $ return () - }) - - -utf16le_b_decode :: DecodeBuffer -utf16le_b_decode - input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } - output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } - = let - loop !ir !ow - | ow >= os = done OutputUnderflow ir ow - | ir >= iw = done InputUnderflow ir ow - | ir + 1 == iw = done InputUnderflow ir ow - | otherwise = do - c0 <- readWord8Buf iraw ir - c1 <- readWord8Buf iraw (ir+1) - let x1 = fromIntegral c1 `shiftL` 8 + fromIntegral c0 - if | iw - ir >= 4 -> do - c2 <- readWord8Buf iraw (ir+2) - c3 <- readWord8Buf iraw (ir+3) - let x2 = fromIntegral c3 `shiftL` 8 + fromIntegral c2 - if | 0xd800 <= x1 && x1 <= 0xdbff - , 0xdc00 <= x2 && x2 <= 0xdfff -> do - ow' <- writeCharBuf oraw ow (unsafeChr ((x1 - 0xd800)*0x400 + (x2 - 0xdc00) + 0x10000)) - loop (ir+4) ow' - | otherwise -> do - ow' <- writeCharBuf oraw ow (unsafeChr x1) - loop (ir+2) ow' - | iw - ir >= 2 -> do - ow' <- writeCharBuf oraw ow (unsafeChr x1) - loop (ir+2) ow' - | otherwise -> done InputUnderflow ir ow - - -- lambda-lifted, to avoid thunks being built in the inner-loop: - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) - in - loop ir0 ow0 - - -utf16le_b_encode :: EncodeBuffer -utf16le_b_encode - input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } - output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } - = let - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) - loop !ir !ow - | ir >= iw = done InputUnderflow ir ow - | os - ow < 2 = done OutputUnderflow ir ow - | otherwise = do - (c,ir') <- readCharBuf iraw ir - case ord c of - x | x < 0x10000 -> do - writeWord8Buf oraw ow (fromIntegral x) - writeWord8Buf oraw (ow+1) (fromIntegral (x `shiftR` 8)) - loop ir' (ow+2) - | otherwise -> - if os - ow < 4 then done OutputUnderflow ir ow else do - let x' = x - 0x10000 - w1 = x' `div` 0x400 + 0xd800 - w2 = x' `mod` 0x400 + 0xdc00 - writeWord8Buf oraw ow (fromIntegral w1) - writeWord8Buf oraw (ow+1) (fromIntegral (w1 `shiftR` 8)) - writeWord8Buf oraw (ow+2) (fromIntegral w2) - writeWord8Buf oraw (ow+3) (fromIntegral (w2 `shiftR` 8)) - loop ir' (ow+4) - in - loop ir0 ow0 - --- ----------------------------------------------------------------------------- --- Windows encoding (ripped off from base) --- - -cWcharsToChars_UCS2 :: [Word16] -> [Char] -cWcharsToChars_UCS2 = map (chr . fromIntegral) - - --- On Windows, wchar_t is 16 bits wide and CWString uses the UTF-16 encoding. - --- coding errors generate Chars in the surrogate range -cWcharsToChars :: [Word16] -> [Char] -cWcharsToChars = map chr . fromUTF16 . map fromIntegral - where - fromUTF16 :: [Int] -> [Int] - fromUTF16 (c1:c2:wcs) - | 0xd800 <= c1 && c1 <= 0xdbff && 0xdc00 <= c2 && c2 <= 0xdfff = - ((c1 - 0xd800)*0x400 + (c2 - 0xdc00) + 0x10000) : fromUTF16 wcs - fromUTF16 (c:wcs) = c : fromUTF16 wcs - fromUTF16 [] = [] - -charsToCWchars :: [Char] -> [Word16] -charsToCWchars = foldr (utf16Char . ord) [] - where - utf16Char :: Int -> [Word16] -> [Word16] - utf16Char c wcs - | c < 0x10000 = fromIntegral c : wcs - | otherwise = let c' = c - 0x10000 in - fromIntegral (c' `div` 0x400 + 0xd800) : - fromIntegral (c' `mod` 0x400 + 0xdc00) : wcs - --- ----------------------------------------------------------------------------- - --- ----------------------------------------------------------------------------- --- FFI --- - -withFilePathWin :: FilePath -> (Int -> Ptr Word16 -> IO a) -> IO a -withFilePathWin = withArrayLen . charsToCWchars - -peekFilePathWin :: (Ptr Word16, Int) -> IO FilePath -peekFilePathWin (cp, l) = do - cs <- peekArray l cp - return (cWcharsToChars cs) - -withFilePathPosix :: FilePath -> (CStringLen -> IO a) -> IO a -withFilePathPosix fp f = getFileSystemEncoding >>= \enc -> GHC.withCStringLen enc fp f - -peekFilePathPosix :: CStringLen -> IO FilePath -peekFilePathPosix fp = getFileSystemEncoding >>= \enc -> GHC.peekCStringLen enc fp - --- | Decode with the given 'TextEncoding'. -decodeWithTE :: TextEncoding -> BS8.ShortByteString -> Either EncodingException String -decodeWithTE enc ba = unsafePerformIO $ do - r <- trySafe @SomeException $ BS8.useAsCStringLen ba $ \fp -> GHC.peekCStringLen enc fp - evaluate $ force $ first (flip EncodingError Nothing . displayException) r - --- | Encode with the given 'TextEncoding'. -encodeWithTE :: TextEncoding -> String -> Either EncodingException BS8.ShortByteString -encodeWithTE enc str = unsafePerformIO $ do - r <- trySafe @SomeException $ GHC.withCStringLen enc str $ \cstr -> BS8.packCStringLen cstr - evaluate $ force $ first (flip EncodingError Nothing . displayException) r - --- ----------------------------------------------------------------------------- --- Encoders / decoders --- - --- | This mimics the filepath decoder base uses on unix, --- with the small distinction that we're not truncating at NUL bytes (because we're not at --- the outer FFI layer). -decodeWithBasePosix :: BS8.ShortByteString -> IO String -decodeWithBasePosix ba = BS8.useAsCStringLen ba $ \fp -> peekFilePathPosix fp - --- | This mimics the filepath dencoder base uses on unix, --- with the small distinction that we're not truncating at NUL bytes (because we're not at --- the outer FFI layer). -encodeWithBasePosix :: String -> IO BS8.ShortByteString -encodeWithBasePosix str = withFilePathPosix str $ \cstr -> BS8.packCStringLen cstr - --- | This mimics the filepath decoder base uses on windows, --- with the small distinction that we're not truncating at NUL bytes (because we're not at --- the outer FFI layer). -decodeWithBaseWindows :: BS16.ShortByteString -> IO String -decodeWithBaseWindows ba = BS16.useAsCWStringLen ba $ \fp -> peekFilePathWin fp - --- | This mimics the filepath dencoder base uses on windows, --- with the small distinction that we're not truncating at NUL bytes (because we're not at --- the outer FFI layer). -encodeWithBaseWindows :: String -> IO BS16.ShortByteString -encodeWithBaseWindows str = withFilePathWin str $ \l cstr -> BS16.packCWStringLen (cstr, l) - - --- ----------------------------------------------------------------------------- --- Types --- - -data EncodingException = - EncodingError String (Maybe Word8) - -- ^ Could not decode a byte sequence because it was invalid under - -- the given encoding, or ran out of input in mid-decode. - deriving (Eq, Typeable) - - -showEncodingException :: EncodingException -> String -showEncodingException (EncodingError desc (Just w)) - = "Cannot decode byte '\\x" ++ showHex w ("': " ++ desc) -showEncodingException (EncodingError desc Nothing) - = "Cannot decode input: " ++ desc - -instance Show EncodingException where - show = showEncodingException - -instance Exception EncodingException - -instance NFData EncodingException where - rnf (EncodingError desc w) = rnf desc `seq` rnf w - - --- ----------------------------------------------------------------------------- --- Words --- - -wNUL :: Word16 -wNUL = 0x00 - --- ----------------------------------------------------------------------------- --- Exceptions --- - --- | Like 'try', but rethrows async exceptions. -trySafe :: Exception e => IO a -> IO (Either e a) -trySafe ioA = catch action eHandler - where - action = do - v <- ioA - return (Right v) - eHandler e - | isAsyncException e = throwIO e - | otherwise = return (Left e) - -isAsyncException :: Exception e => e -> Bool -isAsyncException e = - case fromException (toException e) of - Just (SomeAsyncException _) -> True - Nothing -> False diff --git a/System/OsPath/Internal.hs b/System/OsPath/Internal.hs --- a/System/OsPath/Internal.hs +++ b/System/OsPath/Internal.hs @@ -1,29 +1,42 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE ViewPatterns #-} -- needed to quote a view pattern module System.OsPath.Internal where import {-# SOURCE #-} System.OsPath ( isValid ) import System.OsPath.Types -import qualified System.OsString.Internal.Hidden as OS +import qualified System.OsString.Internal as OS import Control.Monad.Catch ( MonadThrow ) import Data.ByteString ( ByteString ) -import Language.Haskell.TH.Quote +#if __GLASGOW_HASKELL__ >= 914 +import Language.Haskell.TH.Lift + ( Lift(..), lift ) +import Language.Haskell.TH.QuasiQuoter ( QuasiQuoter (..) ) +#else import Language.Haskell.TH.Syntax - ( Lift (..), lift ) + ( Lift(..), lift ) +import Language.Haskell.TH.Quote + ( QuasiQuoter (..) ) +#endif import GHC.IO.Encoding.Failure ( CodingFailureMode(..) ) -import System.OsString.Internal.Types.Hidden +import System.OsString.Internal.Types import System.OsPath.Encoding import Control.Monad (when) +#if !defined(__MHS__) import System.IO ( TextEncoding ) +#else +import GHC.IO.Encoding.Types ( TextEncoding ) +#endif #if defined(mingw32_HOST_OS) || defined(__MINGW32__) import qualified System.OsPath.Windows as PF @@ -32,6 +45,7 @@ import qualified System.OsPath.Posix as PF import GHC.IO.Encoding.UTF8 ( mkUTF8 ) #endif +import GHC.Stack (HasCallStack) @@ -40,13 +54,25 @@ -- On windows this encodes as UTF16-LE (strictly), which is a pretty good guess. -- On unix this encodes as UTF8 (strictly), which is a good guess. -- --- Throws a 'EncodingException' if encoding fails. +-- Throws an 'EncodingException' if encoding fails. If the input does not +-- contain surrogate chars, you can use 'unsafeEncodeUtf'. encodeUtf :: MonadThrow m => FilePath -> m OsPath encodeUtf = OS.encodeUtf +-- | Unsafe unicode friendly encoding. +-- +-- Like 'encodeUtf', except it crashes when the input contains +-- surrogate chars. For sanitized input, this can be useful. +unsafeEncodeUtf :: HasCallStack => String -> OsString +unsafeEncodeUtf = OS.unsafeEncodeUtf + -- | Encode a 'FilePath' with the specified encoding. +-- +-- Note: on windows, we expect a "wide char" encoding (e.g. UCS-2 or UTF-16). Anything +-- that works with @Word16@ boundaries. Picking an incompatible encoding may crash +-- filepath operations. encodeWith :: TextEncoding -- ^ unix text encoding - -> TextEncoding -- ^ windows text encoding + -> TextEncoding -- ^ windows text encoding (wide char) -> FilePath -> Either EncodingException OsPath encodeWith = OS.encodeWith @@ -109,9 +135,11 @@ +#if defined(MIN_VERSION_template_haskell) || defined(MIN_VERSION_template_haskell_quasiquoter) -- | QuasiQuote an 'OsPath'. This accepts Unicode characters -- and encodes as UTF-8 on unix and UTF-16LE on windows. Runs 'isValid' --- on the input. +-- on the input. If used as a pattern, requires turning on the @ViewPatterns@ +-- extension. osp :: QuasiQuoter osp = QuasiQuoter #if defined(mingw32_HOST_OS) || defined(__MINGW32__) @@ -119,26 +147,34 @@ osp' <- either (fail . show) (pure . OsString) . PF.encodeWith (mkUTF16le ErrorOnCodingFailure) $ s when (not $ isValid osp') $ fail ("filepath not valid: " ++ show osp') lift osp' - , quotePat = \_ -> - fail "illegal QuasiQuote (allowed as expression only, used as a pattern)" + , quotePat = \s -> do + osp' <- either (fail . show) (pure . OsString) . PF.encodeWith (mkUTF16le ErrorOnCodingFailure) $ s + when (not $ isValid osp') $ fail ("filepath not valid: " ++ show osp') + [p|((==) osp' -> True)|] , quoteType = \_ -> - fail "illegal QuasiQuote (allowed as expression only, used as a type)" + fail "illegal QuasiQuote (allowed as expression or pattern only, used as a type)" , quoteDec = \_ -> - fail "illegal QuasiQuote (allowed as expression only, used as a declaration)" + fail "illegal QuasiQuote (allowed as expression or pattern only, used as a declaration)" } #else { quoteExp = \s -> do osp' <- either (fail . show) (pure . OsString) . PF.encodeWith (mkUTF8 ErrorOnCodingFailure) $ s when (not $ isValid osp') $ fail ("filepath not valid: " ++ show osp') lift osp' - , quotePat = \_ -> - fail "illegal QuasiQuote (allowed as expression only, used as a pattern)" + , quotePat = \s -> do + osp' <- either (fail . show) (pure . OsString) . PF.encodeWith (mkUTF8 ErrorOnCodingFailure) $ s + when (not $ isValid osp') $ fail ("filepath not valid: " ++ show osp') + [p|((==) osp' -> True)|] , quoteType = \_ -> - fail "illegal QuasiQuote (allowed as expression only, used as a type)" + fail "illegal QuasiQuote (allowed as expression or pattern only, used as a type)" , quoteDec = \_ -> - fail "illegal QuasiQuote (allowed as expression only, used as a declaration)" + fail "illegal QuasiQuote (allowed as expression or pattern only, used as a declaration)" } #endif +#else +osp :: a +osp = error "System.OsPath.Internal.ostr: no Template Haskell" +#endif /* defined(MIN_VERSION_template_haskell) || defined(MIN_VERSION_template_haskell_quasiquoter) */ -- | Unpack an 'OsPath' to a list of 'OsChar'. diff --git a/System/OsPath/Posix.hs b/System/OsPath/Posix.hs --- a/System/OsPath/Posix.hs +++ b/System/OsPath/Posix.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE ViewPatterns #-} #undef WINDOWS #define POSIX @@ -9,6 +11,7 @@ #include "Common.hs" +#if defined(MIN_VERSION_template_haskell) || defined(MIN_VERSION_template_haskell_quasiquoter) -- | QuasiQuote a 'PosixPath'. This accepts Unicode characters -- and encodes as UTF-8. Runs 'isValid' on the input. pstr :: QuasiQuoter @@ -18,10 +21,17 @@ ps <- either (fail . show) pure $ encodeWith (mkUTF8 ErrorOnCodingFailure) s when (not $ isValid ps) $ fail ("filepath not valid: " ++ show ps) lift ps - , quotePat = \_ -> - fail "illegal QuasiQuote (allowed as expression only, used as a pattern)" + , quotePat = \s -> do + osp' <- either (fail . show) pure . encodeWith (mkUTF8 ErrorOnCodingFailure) $ s + when (not $ isValid osp') $ fail ("filepath not valid: " ++ show osp') + [p|((==) osp' -> True)|] , quoteType = \_ -> - fail "illegal QuasiQuote (allowed as expression only, used as a type)" + fail "illegal QuasiQuote (allowed as expression or pattern only, used as a type)" , quoteDec = \_ -> - fail "illegal QuasiQuote (allowed as expression only, used as a declaration)" + fail "illegal QuasiQuote (allowed as expression or pattern only, used as a declaration)" } +#else +pstr :: a +pstr = error "System.OsPath.Posix.pstr: no Template Haskell" +#endif /* defined(MIN_VERSION_template_haskell) || defined(MIN_VERSION_template_haskell_quasiquoter) */ + diff --git a/System/OsPath/Types.hs b/System/OsPath/Types.hs --- a/System/OsPath/Types.hs +++ b/System/OsPath/Types.hs @@ -18,7 +18,7 @@ ) where -import System.OsString.Internal.Types.Hidden +import System.OsString.Internal.Types -- | Filepaths are @wchar_t*@ data on windows as passed to syscalls. diff --git a/System/OsPath/Windows.hs b/System/OsPath/Windows.hs --- a/System/OsPath/Windows.hs +++ b/System/OsPath/Windows.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE ViewPatterns #-} #undef POSIX #define IS_WINDOWS True @@ -9,7 +11,7 @@ #include "Common.hs" - +#if defined(MIN_VERSION_template_haskell) || defined(MIN_VERSION_template_haskell_quasiquoter) -- | QuasiQuote a 'WindowsPath'. This accepts Unicode characters -- and encodes as UTF-16LE. Runs 'isValid' on the input. pstr :: QuasiQuoter @@ -19,10 +21,16 @@ ps <- either (fail . show) pure $ encodeWith (mkUTF16le ErrorOnCodingFailure) s when (not $ isValid ps) $ fail ("filepath not valid: " ++ show ps) lift ps - , quotePat = \_ -> - fail "illegal QuasiQuote (allowed as expression only, used as a pattern)" + , quotePat = \s -> do + osp' <- either (fail . show) pure . encodeWith (mkUTF16le ErrorOnCodingFailure) $ s + when (not $ isValid osp') $ fail ("filepath not valid: " ++ show osp') + [p|((==) osp' -> True)|] , quoteType = \_ -> - fail "illegal QuasiQuote (allowed as expression only, used as a type)" + fail "illegal QuasiQuote (allowed as expression or pattern only, used as a type)" , quoteDec = \_ -> - fail "illegal QuasiQuote (allowed as expression only, used as a declaration)" + fail "illegal QuasiQuote (allowed as expression or pattern only, used as a declaration)" } +#else +pstr :: a +pstr = error "Systen.OsPath.Windows.pstr: no Template Haskell" +#endif /* defined(MIN_VERSION_template_haskell) || defined(MIN_VERSION_template_haskellquasi_quoter) */ diff --git a/System/OsString.hs b/System/OsString.hs deleted file mode 100644 --- a/System/OsString.hs +++ /dev/null @@ -1,60 +0,0 @@ --- | --- Module : OsString --- Copyright : © 2021 Julian Ospald --- License : MIT --- --- Maintainer : Julian Ospald --- Stability : experimental --- Portability : portable --- --- An implementation of platform specific short 'OsString', which is: --- --- 1. on windows wide char bytes (@[Word16]@) --- 2. on unix char bytes (@[Word8]@) --- --- It captures the notion of syscall specific encoding (or the lack thereof) to avoid roundtrip issues --- and memory fragmentation by using unpinned byte arrays. Bytes are not touched or interpreted. -module System.OsString {-# DEPRECATED "Use System.OsString from os-string >= 2.0.0 package instead. This module will be removed in filepath >= 1.5." #-} - ( - -- * String types - OsString - - -- * OsString construction - , encodeUtf - , encodeWith - , encodeFS - , osstr - , pack - - -- * OsString deconstruction - , decodeUtf - , decodeWith - , decodeFS - , unpack - - -- * Word types - , OsChar - - -- * Word construction - , unsafeFromChar - - -- * Word deconstruction - , toChar - ) -where - -import System.OsString.Internal.Hidden - ( unsafeFromChar - , toChar - , encodeUtf - , encodeWith - , encodeFS - , osstr - , pack - , decodeUtf - , decodeWith - , decodeFS - , unpack - ) -import System.OsString.Internal.Types.Hidden - ( OsString, OsChar ) diff --git a/System/OsString/Common.hs b/System/OsString/Common.hs deleted file mode 100644 --- a/System/OsString/Common.hs +++ /dev/null @@ -1,315 +0,0 @@ -{- HLINT ignore "Unused LANGUAGE pragma" -} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE PatternSynonyms #-} --- This template expects CPP definitions for: --- MODULE_NAME = Posix | Windows --- IS_WINDOWS = False | True --- -#if defined(WINDOWS) -#define WINDOWS_DOC -#else -#define POSIX_DOC -#endif - -module System.OsString.MODULE_NAME.Hidden - ( - -- * Types -#ifdef WINDOWS - WindowsString - , WindowsChar -#else - PosixString - , PosixChar -#endif - - -- * String construction - , encodeUtf - , encodeWith - , encodeFS - , fromBytes - , pstr - , pack - - -- * String deconstruction - , decodeUtf - , decodeWith - , decodeFS - , unpack - - -- * Word construction - , unsafeFromChar - - -- * Word deconstruction - , toChar - ) -where - - - -import System.OsString.Internal.Types.Hidden ( -#ifdef WINDOWS - WindowsString(..), WindowsChar(..) -#else - PosixString(..), PosixChar(..) -#endif - ) - -import Data.Char -import Control.Monad.Catch - ( MonadThrow, throwM ) -import Data.ByteString.Internal - ( ByteString ) -import Control.Exception - ( SomeException, displayException ) -import Control.DeepSeq ( force ) -import Data.Bifunctor ( first ) -import GHC.IO - ( evaluate, unsafePerformIO ) -import qualified GHC.Foreign as GHC -import Language.Haskell.TH.Quote - ( QuasiQuoter (..) ) -import Language.Haskell.TH.Syntax - ( Lift (..), lift ) -import System.OsPath.Encoding.Internal.Hidden ( trySafe ) - -import GHC.IO.Encoding.Failure ( CodingFailureMode(..) ) -#ifdef WINDOWS -import System.OsPath.Encoding -import System.IO - ( TextEncoding, utf16le ) -import GHC.IO.Encoding.UTF16 ( mkUTF16le ) -import qualified System.OsPath.Data.ByteString.Short.Word16.Hidden as BS16 -import qualified System.OsPath.Data.ByteString.Short.Hidden as BS8 -#else -import System.OsPath.Encoding -import System.IO - ( TextEncoding, utf8 ) -import GHC.IO.Encoding.UTF8 ( mkUTF8 ) -import qualified System.OsPath.Data.ByteString.Short.Hidden as BS -#endif - - - -#ifdef WINDOWS_DOC --- | Partial unicode friendly encoding. --- --- This encodes as UTF16-LE (strictly), which is a pretty good guess. --- --- Throws an 'EncodingException' if encoding fails. -#else --- | Partial unicode friendly encoding. --- --- This encodes as UTF8 (strictly), which is a good guess. --- --- Throws an 'EncodingException' if encoding fails. -#endif -encodeUtf :: MonadThrow m => String -> m PLATFORM_STRING -#ifdef WINDOWS -encodeUtf = either throwM pure . encodeWith utf16le -#else -encodeUtf = either throwM pure . encodeWith utf8 -#endif - --- | Encode a 'String' with the specified encoding. -encodeWith :: TextEncoding - -> String - -> Either EncodingException PLATFORM_STRING -encodeWith enc str = unsafePerformIO $ do -#ifdef WINDOWS - r <- trySafe @SomeException $ GHC.withCStringLen enc str $ \cstr -> WindowsString <$> BS8.packCStringLen cstr - evaluate $ force $ first (flip EncodingError Nothing . displayException) r -#else - r <- trySafe @SomeException $ GHC.withCStringLen enc str $ \cstr -> PosixString <$> BS.packCStringLen cstr - evaluate $ force $ first (flip EncodingError Nothing . displayException) r -#endif - -#ifdef WINDOWS_DOC --- | This mimics the behavior of the base library when doing filesystem --- operations, which does permissive UTF-16 encoding, where coding errors generate --- Chars in the surrogate range. --- --- The reason this is in IO is because it unifies with the Posix counterpart, --- which does require IO. This is safe to 'unsafePerformIO'/'unsafeDupablePerformIO'. -#else --- | This mimics the behavior of the base library when doing filesystem --- operations, which uses shady PEP 383 style encoding (based on the current locale, --- but PEP 383 only works properly on UTF-8 encodings, so good luck). --- --- Looking up the locale requires IO. If you're not worried about calls --- to 'setFileSystemEncoding', then 'unsafePerformIO' may be feasible (make sure --- to deeply evaluate the result to catch exceptions). -#endif -encodeFS :: String -> IO PLATFORM_STRING -#ifdef WINDOWS -encodeFS = fmap WindowsString . encodeWithBaseWindows -#else -encodeFS = fmap PosixString . encodeWithBasePosix -#endif - - -#ifdef WINDOWS_DOC --- | Partial unicode friendly decoding. --- --- This decodes as UTF16-LE (strictly), which is a pretty good. --- --- Throws a 'EncodingException' if decoding fails. -#else --- | Partial unicode friendly decoding. --- --- This decodes as UTF8 (strictly), which is a good guess. Note that --- filenames on unix are encoding agnostic char arrays. --- --- Throws a 'EncodingException' if decoding fails. -#endif -decodeUtf :: MonadThrow m => PLATFORM_STRING -> m String -#ifdef WINDOWS -decodeUtf = either throwM pure . decodeWith utf16le -#else -decodeUtf = either throwM pure . decodeWith utf8 -#endif - -#ifdef WINDOWS --- | Decode a 'WindowsString' with the specified encoding. --- --- The String is forced into memory to catch all exceptions. -decodeWith :: TextEncoding - -> PLATFORM_STRING - -> Either EncodingException String -decodeWith winEnc (WindowsString ba) = unsafePerformIO $ do - r <- trySafe @SomeException $ BS8.useAsCStringLen ba $ \fp -> GHC.peekCStringLen winEnc fp - evaluate $ force $ first (flip EncodingError Nothing . displayException) r -#else --- | Decode a 'PosixString' with the specified encoding. --- --- The String is forced into memory to catch all exceptions. -decodeWith :: TextEncoding - -> PLATFORM_STRING - -> Either EncodingException String -decodeWith unixEnc (PosixString ba) = unsafePerformIO $ do - r <- trySafe @SomeException $ BS.useAsCStringLen ba $ \fp -> GHC.peekCStringLen unixEnc fp - evaluate $ force $ first (flip EncodingError Nothing . displayException) r -#endif - - -#ifdef WINDOWS_DOC --- | Like 'decodeUtf', except this mimics the behavior of the base library when doing filesystem --- operations, which does permissive UTF-16 encoding, where coding errors generate --- Chars in the surrogate range. --- --- The reason this is in IO is because it unifies with the Posix counterpart, --- which does require IO. 'unsafePerformIO'/'unsafeDupablePerformIO' are safe, however. -#else --- | This mimics the behavior of the base library when doing filesystem --- operations, which uses shady PEP 383 style encoding (based on the current locale, --- but PEP 383 only works properly on UTF-8 encodings, so good luck). --- --- Looking up the locale requires IO. If you're not worried about calls --- to 'setFileSystemEncoding', then 'unsafePerformIO' may be feasible (make sure --- to deeply evaluate the result to catch exceptions). -#endif -decodeFS :: PLATFORM_STRING -> IO String -#ifdef WINDOWS -decodeFS (WindowsString ba) = decodeWithBaseWindows ba -#else -decodeFS (PosixString ba) = decodeWithBasePosix ba -#endif - - -#ifdef WINDOWS_DOC --- | Constructs a platform string from a ByteString. --- --- This ensures valid UCS-2LE. --- Note that this doesn't expand Word8 to Word16 on windows, so you may get invalid UTF-16. --- --- Throws 'EncodingException' on invalid UCS-2LE (although unlikely). -#else --- | Constructs a platform string from a ByteString. --- --- This is a no-op. -#endif -fromBytes :: MonadThrow m - => ByteString - -> m PLATFORM_STRING -#ifdef WINDOWS -fromBytes bs = - let ws = WindowsString . BS16.toShort $ bs - in either throwM (const . pure $ ws) $ decodeWith ucs2le ws -#else -fromBytes = pure . PosixString . BS.toShort -#endif - - -#ifdef WINDOWS_DOC --- | QuasiQuote a 'WindowsString'. This accepts Unicode characters --- and encodes as UTF-16LE on windows. -#else --- | QuasiQuote a 'PosixString'. This accepts Unicode characters --- and encodes as UTF-8 on unix. -#endif -pstr :: QuasiQuoter -pstr = - QuasiQuoter -#ifdef WINDOWS - { quoteExp = \s -> do - ps <- either (fail . show) pure $ encodeWith (mkUTF16le ErrorOnCodingFailure) s - lift ps - , 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)" - } -#else - { quoteExp = \s -> do - ps <- either (fail . show) pure $ encodeWith (mkUTF8 ErrorOnCodingFailure) s - lift ps - , 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)" - } -#endif - - --- | Unpack a platform string to a list of platform words. -unpack :: PLATFORM_STRING -> [PLATFORM_WORD] -#ifdef WINDOWS -unpack (WindowsString ba) = WindowsChar <$> BS16.unpack ba -#else -unpack (PosixString ba) = PosixChar <$> BS.unpack ba -#endif - - --- | Pack a list of platform words to a platform string. --- --- Note that using this in conjunction with 'unsafeFromChar' to --- convert from @[Char]@ to platform string is probably not what --- you want, because it will truncate unicode code points. -pack :: [PLATFORM_WORD] -> PLATFORM_STRING -#ifdef WINDOWS -pack = WindowsString . BS16.pack . fmap (\(WindowsChar w) -> w) -#else -pack = PosixString . BS.pack . fmap (\(PosixChar w) -> w) -#endif - - -#ifdef WINDOWS --- | Truncates to 2 octets. -unsafeFromChar :: Char -> PLATFORM_WORD -unsafeFromChar = WindowsChar . fromIntegral . fromEnum -#else --- | Truncates to 1 octet. -unsafeFromChar :: Char -> PLATFORM_WORD -unsafeFromChar = PosixChar . fromIntegral . fromEnum -#endif - --- | Converts back to a unicode codepoint (total). -toChar :: PLATFORM_WORD -> Char -#ifdef WINDOWS -toChar (WindowsChar w) = chr $ fromIntegral w -#else -toChar (PosixChar w) = chr $ fromIntegral w -#endif diff --git a/System/OsString/Internal.hs b/System/OsString/Internal.hs deleted file mode 100644 --- a/System/OsString/Internal.hs +++ /dev/null @@ -1,6 +0,0 @@ -module System.OsString.Internal {-# DEPRECATED "Use System.OsString.Internal from os-string >= 2.0.0 package instead. This module will be removed in filepath >= 1.5." #-} - ( module System.OsString.Internal.Hidden - ) - where - -import System.OsString.Internal.Hidden diff --git a/System/OsString/Internal/Hidden.hs b/System/OsString/Internal/Hidden.hs deleted file mode 100644 --- a/System/OsString/Internal/Hidden.hs +++ /dev/null @@ -1,174 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE UnliftedFFITypes #-} - -module System.OsString.Internal.Hidden where - -import System.OsString.Internal.Types.Hidden - -import Control.Monad.Catch - ( MonadThrow ) -import Data.ByteString - ( ByteString ) -import Data.Char -import Language.Haskell.TH.Quote - ( QuasiQuoter (..) ) -import Language.Haskell.TH.Syntax - ( Lift (..), lift ) -import System.IO - ( TextEncoding ) - -import System.OsPath.Encoding ( EncodingException(..) ) -import GHC.IO.Encoding.Failure ( CodingFailureMode(..) ) -#if defined(mingw32_HOST_OS) || defined(__MINGW32__) -import GHC.IO.Encoding.UTF16 ( mkUTF16le ) -import qualified System.OsString.Windows.Hidden as PF -#else -import GHC.IO.Encoding.UTF8 ( mkUTF8 ) -import qualified System.OsString.Posix.Hidden as PF -#endif - - - - --- | Partial unicode friendly encoding. --- --- On windows this encodes as UTF16-LE (strictly), which is a pretty good guess. --- On unix this encodes as UTF8 (strictly), which is a good guess. --- --- Throws a 'EncodingException' if encoding fails. -encodeUtf :: MonadThrow m => String -> m OsString -encodeUtf = fmap OsString . PF.encodeUtf - --- | Encode an 'OsString' given the platform specific encodings. -encodeWith :: TextEncoding -- ^ unix text encoding - -> TextEncoding -- ^ windows text encoding - -> String - -> Either EncodingException OsString -#if defined(mingw32_HOST_OS) || defined(__MINGW32__) -encodeWith _ winEnc str = OsString <$> PF.encodeWith winEnc str -#else -encodeWith unixEnc _ str = OsString <$> PF.encodeWith unixEnc str -#endif - --- | Like 'encodeUtf', except this mimics the behavior of the base library when doing filesystem --- operations, which is: --- --- 1. on unix, uses shady PEP 383 style encoding (based on the current locale, --- but PEP 383 only works properly on UTF-8 encodings, so good luck) --- 2. on windows does permissive UTF-16 encoding, where coding errors generate --- Chars in the surrogate range --- --- Looking up the locale requires IO. If you're not worried about calls --- to 'setFileSystemEncoding', then 'unsafePerformIO' may be feasible (make sure --- to deeply evaluate the result to catch exceptions). -encodeFS :: String -> IO OsString -encodeFS = fmap OsString . PF.encodeFS - - --- | Partial unicode friendly decoding. --- --- On windows this decodes as UTF16-LE (strictly), which is a pretty good guess. --- On unix this decodes as UTF8 (strictly), which is a good guess. Note that --- filenames on unix are encoding agnostic char arrays. --- --- Throws a 'EncodingException' if decoding fails. -decodeUtf :: MonadThrow m => OsString -> m String -decodeUtf (OsString x) = PF.decodeUtf x - --- | Decode an 'OsString' with the specified encoding. --- --- The String is forced into memory to catch all exceptions. -decodeWith :: TextEncoding -- ^ unix text encoding - -> TextEncoding -- ^ windows text encoding - -> OsString - -> Either EncodingException String -#if defined(mingw32_HOST_OS) || defined(__MINGW32__) -decodeWith _ winEnc (OsString x) = PF.decodeWith winEnc x -#else -decodeWith unixEnc _ (OsString x) = PF.decodeWith unixEnc x -#endif - - --- | Like 'decodeUtf', except this mimics the behavior of the base library when doing filesystem --- operations, which is: --- --- 1. on unix, uses shady PEP 383 style encoding (based on the current locale, --- but PEP 383 only works properly on UTF-8 encodings, so good luck) --- 2. on windows does permissive UTF-16 encoding, where coding errors generate --- Chars in the surrogate range --- --- Looking up the locale requires IO. If you're not worried about calls --- to 'setFileSystemEncoding', then 'unsafePerformIO' may be feasible (make sure --- to deeply evaluate the result to catch exceptions). -decodeFS :: OsString -> IO String -decodeFS (OsString x) = PF.decodeFS x - - --- | Constructs an @OsString@ from a ByteString. --- --- On windows, this ensures valid UCS-2LE, on unix it is passed unchanged/unchecked. --- --- Throws 'EncodingException' on invalid UCS-2LE on windows (although unlikely). -fromBytes :: MonadThrow m - => ByteString - -> m OsString -fromBytes = fmap OsString . PF.fromBytes - - --- | QuasiQuote an 'OsString'. This accepts Unicode characters --- and encodes as UTF-8 on unix and UTF-16 on windows. -osstr :: QuasiQuoter -osstr = - QuasiQuoter -#if defined(mingw32_HOST_OS) || defined(__MINGW32__) - { quoteExp = \s -> do - osp <- either (fail . show) (pure . OsString) . PF.encodeWith (mkUTF16le ErrorOnCodingFailure) $ s - lift osp - , 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)" - } -#else - { quoteExp = \s -> do - osp <- either (fail . show) (pure . OsString) . PF.encodeWith (mkUTF8 ErrorOnCodingFailure) $ s - lift osp - , 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)" - } -#endif - - --- | Unpack an 'OsString' to a list of 'OsChar'. -unpack :: OsString -> [OsChar] -unpack (OsString x) = OsChar <$> PF.unpack x - - --- | Pack a list of 'OsChar' to an 'OsString' --- --- Note that using this in conjunction with 'unsafeFromChar' to --- convert from @[Char]@ to 'OsString' is probably not what --- you want, because it will truncate unicode code points. -pack :: [OsChar] -> OsString -pack = OsString . PF.pack . fmap (\(OsChar x) -> x) - - --- | Truncates on unix to 1 and on Windows to 2 octets. -unsafeFromChar :: Char -> OsChar -unsafeFromChar = OsChar . PF.unsafeFromChar - --- | Converts back to a unicode codepoint (total). -toChar :: OsChar -> Char -#if defined(mingw32_HOST_OS) || defined(__MINGW32__) -toChar (OsChar (WindowsChar w)) = chr $ fromIntegral w -#else -toChar (OsChar (PosixChar w)) = chr $ fromIntegral w -#endif - diff --git a/System/OsString/Internal/Types.hs b/System/OsString/Internal/Types.hs deleted file mode 100644 --- a/System/OsString/Internal/Types.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -module System.OsString.Internal.Types {-# DEPRECATED "Use System.OsString.Internal.Types from os-string >= 2.0.0 package instead. This module will be removed in filepath >= 1.5." #-} - ( - WindowsString(..) - , pattern WS - , unWS - , PosixString(..) - , unPS - , pattern PS - , PlatformString - , WindowsChar(..) - , unWW - , pattern WW - , PosixChar(..) - , unPW - , pattern PW - , PlatformChar - , OsString(..) - , OsChar(..) - ) -where - -import System.OsString.Internal.Types.Hidden diff --git a/System/OsString/Internal/Types/Hidden.hs b/System/OsString/Internal/Types/Hidden.hs deleted file mode 100644 --- a/System/OsString/Internal/Types/Hidden.hs +++ /dev/null @@ -1,246 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE PatternSynonyms #-} - -module System.OsString.Internal.Types.Hidden - ( - WindowsString(..) - , pattern WS - , unWS - , PosixString(..) - , unPS - , pattern PS - , PlatformString - , WindowsChar(..) - , unWW - , pattern WW - , PosixChar(..) - , unPW - , pattern PW - , PlatformChar - , OsString(..) - , OsChar(..) - ) -where - - -import Control.DeepSeq -import Data.Data -import Data.Word -import Language.Haskell.TH.Syntax - ( Lift (..), lift ) -#if !MIN_VERSION_base(4,11,0) -import Data.Semigroup -#endif -import GHC.Generics (Generic) - -import System.OsPath.Encoding.Internal.Hidden -import qualified System.OsPath.Data.ByteString.Short.Hidden as BS -import qualified System.OsPath.Data.ByteString.Short.Word16.Hidden as BS16 -#if MIN_VERSION_template_haskell(2,16,0) -import qualified Language.Haskell.TH.Syntax as TH -#endif - --- Using unpinned bytearrays to avoid Heap fragmentation and --- which are reasonably cheap to pass to FFI calls --- wrapped with typeclass-friendly types allowing to avoid CPP --- --- Note that, while unpinned bytearrays incur a memcpy on each --- FFI call, this overhead is generally much preferable to --- the memory fragmentation of pinned bytearrays - --- | Commonly used windows string as wide character bytes. -newtype WindowsString = WindowsString { getWindowsString :: BS.ShortByteString } - deriving (Eq, Ord, Semigroup, Monoid, Typeable, Generic, NFData) - --- | Decodes as UCS-2. -instance Show WindowsString where - -- cWcharsToChars_UCS2 is total - show = show . cWcharsToChars_UCS2 . BS16.unpack . getWindowsString - --- | Just a short bidirectional synonym for 'WindowsString' constructor. -pattern WS :: BS.ShortByteString -> WindowsString -pattern WS { unWS } <- WindowsString unWS where - WS a = WindowsString a -#if __GLASGOW_HASKELL__ >= 802 -{-# COMPLETE WS #-} -#endif - - -instance Lift WindowsString where - lift (WindowsString bs) - = [| WindowsString (BS.pack $(lift $ BS.unpack bs)) :: WindowsString |] -#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 - --- | Commonly used Posix string as uninterpreted @char[]@ --- array. -newtype PosixString = PosixString { getPosixString :: BS.ShortByteString } - deriving (Eq, Ord, Semigroup, Monoid, Typeable, Generic, NFData) - --- | Prints the raw bytes without decoding. -instance Show PosixString where - show (PosixString ps) = show ps - --- | Just a short bidirectional synonym for 'PosixString' constructor. -pattern PS :: BS.ShortByteString -> PosixString -pattern PS { unPS } <- PosixString unPS where - PS a = PosixString a -#if __GLASGOW_HASKELL__ >= 802 -{-# COMPLETE PS #-} -#endif - -instance Lift PosixString where - lift (PosixString bs) - = [| PosixString (BS.pack $(lift $ BS.unpack bs)) :: PosixString |] -#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 - - -#if defined(mingw32_HOST_OS) || defined(__MINGW32__) -type PlatformString = WindowsString -#else -type PlatformString = PosixString -#endif - -newtype WindowsChar = WindowsChar { getWindowsChar :: Word16 } - deriving (Eq, Ord, Typeable, Generic, NFData) - -instance Show WindowsChar where - show (WindowsChar wc) = show wc - -newtype PosixChar = PosixChar { getPosixChar :: Word8 } - deriving (Eq, Ord, Typeable, Generic, NFData) - -instance Show PosixChar where - show (PosixChar pc) = show pc - --- | Just a short bidirectional synonym for 'WindowsChar' constructor. -pattern WW :: Word16 -> WindowsChar -pattern WW { unWW } <- WindowsChar unWW where - WW a = WindowsChar a -#if __GLASGOW_HASKELL__ >= 802 -{-# COMPLETE WW #-} -#endif - --- | Just a short bidirectional synonym for 'PosixChar' constructor. -pattern PW :: Word8 -> PosixChar -pattern PW { unPW } <- PosixChar unPW where - PW a = PosixChar a -#if __GLASGOW_HASKELL__ >= 802 -{-# COMPLETE PW #-} -#endif - -#if defined(mingw32_HOST_OS) || defined(__MINGW32__) -type PlatformChar = WindowsChar -#else -type PlatformChar = PosixChar -#endif - - --- | Newtype representing short operating system specific strings. --- --- Internally this is either 'WindowsString' or 'PosixString', --- depending on the platform. Both use unpinned --- 'ShortByteString' for efficiency. --- --- The constructor is only exported via "System.OsString.Internal.Types", since --- dealing with the internals isn't generally recommended, but supported --- in case you need to write platform specific code. -newtype OsString = OsString { getOsString :: PlatformString } - deriving (Typeable, Generic, NFData) - --- | On windows, decodes as UCS-2. On unix prints the raw bytes without decoding. -instance Show OsString where - show (OsString os) = show os - --- | Byte equality of the internal representation. -instance Eq OsString where - (OsString a) == (OsString b) = a == b - --- | Byte ordering of the internal representation. -instance Ord OsString where - compare (OsString a) (OsString b) = compare a b - - --- | \"String-Concatenation\" for 'OsString'. This is __not__ the same --- as '()'. -instance Monoid OsString where -#if defined(mingw32_HOST_OS) || defined(__MINGW32__) - mempty = OsString (WindowsString BS.empty) -#if MIN_VERSION_base(4,16,0) - mappend = (<>) -#else - mappend (OsString (WindowsString a)) (OsString (WindowsString b)) - = OsString (WindowsString (mappend a b)) -#endif -#else - mempty = OsString (PosixString BS.empty) -#if MIN_VERSION_base(4,16,0) - mappend = (<>) -#else - mappend (OsString (PosixString a)) (OsString (PosixString b)) - = OsString (PosixString (mappend a b)) -#endif -#endif -#if MIN_VERSION_base(4,11,0) -instance Semigroup OsString where -#if MIN_VERSION_base(4,16,0) -#if defined(mingw32_HOST_OS) || defined(__MINGW32__) - (<>) (OsString (WindowsString a)) (OsString (WindowsString b)) - = OsString (WindowsString (mappend a b)) -#else - (<>) (OsString (PosixString a)) (OsString (PosixString b)) - = OsString (PosixString (mappend a b)) -#endif -#else - (<>) = mappend -#endif -#endif - - -instance Lift OsString where -#if defined(mingw32_HOST_OS) || defined(__MINGW32__) - lift (OsString (WindowsString bs)) - = [| OsString (WindowsString (BS.pack $(lift $ BS.unpack bs))) :: OsString |] -#else - lift (OsString (PosixString bs)) - = [| OsString (PosixString (BS.pack $(lift $ BS.unpack bs))) :: OsString |] -#endif -#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 - - --- | Newtype representing a code unit. --- --- On Windows, this is restricted to two-octet codepoints 'Word16', --- on POSIX one-octet ('Word8'). -newtype OsChar = OsChar { getOsChar :: PlatformChar } - deriving (Typeable, Generic, NFData) - -instance Show OsChar where - show (OsChar pc) = show pc - --- | Byte equality of the internal representation. -instance Eq OsChar where - (OsChar a) == (OsChar b) = a == b - --- | Byte ordering of the internal representation. -instance Ord OsChar where - compare (OsChar a) (OsChar b) = compare a b - diff --git a/System/OsString/Posix.hs b/System/OsString/Posix.hs deleted file mode 100644 --- a/System/OsString/Posix.hs +++ /dev/null @@ -1,6 +0,0 @@ -module System.OsString.Posix {-# DEPRECATED "Use System.OsString.Posix from os-string >= 2.0.0 package instead. This module will be removed in filepath >= 1.5." #-} - ( module System.OsString.Posix.Hidden - ) - where - -import System.OsString.Posix.Hidden diff --git a/System/OsString/Posix/Hidden.hs b/System/OsString/Posix/Hidden.hs deleted file mode 100644 --- a/System/OsString/Posix/Hidden.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE CPP #-} -#undef WINDOWS -#define MODULE_NAME Posix -#define PLATFORM_STRING PosixString -#define PLATFORM_WORD PosixChar -#define IS_WINDOWS False -#include "../Common.hs" diff --git a/System/OsString/Windows.hs b/System/OsString/Windows.hs deleted file mode 100644 --- a/System/OsString/Windows.hs +++ /dev/null @@ -1,6 +0,0 @@ -module System.OsString.Windows {-# DEPRECATED "Use System.OsString.Posix from os-string >= 2.0.0 package instead. This module will be removed in filepath >= 1.5." #-} - ( module System.OsString.Windows.Hidden - ) - where - -import System.OsString.Windows.Hidden diff --git a/System/OsString/Windows/Hidden.hs b/System/OsString/Windows/Hidden.hs deleted file mode 100644 --- a/System/OsString/Windows/Hidden.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE CPP #-} -#undef POSIX -#define MODULE_NAME Windows -#define PLATFORM_STRING WindowsString -#define PLATFORM_WORD WindowsChar -#define IS_WINDOWS True -#define WINDOWS -#include "../Common.hs" -#undef MODULE_NAME -#undef FILEPATH_NAME -#undef OSSTRING_NAME -#undef IS_WINDOWS -#undef WINDOWS diff --git a/bench/BenchFilePath.hs b/bench/BenchFilePath.hs --- a/bench/BenchFilePath.hs +++ b/bench/BenchFilePath.hs @@ -6,15 +6,15 @@ import System.OsPath.Types import System.OsPath.Encoding ( ucs2le ) -import qualified System.OsString.Internal.Types.Hidden as OST +import qualified System.OsString.Internal.Types as OST import qualified Data.ByteString.Short as SBS import Test.Tasty.Bench import qualified System.FilePath.Posix as PF import qualified System.FilePath.Posix as WF -import qualified System.OsString.Posix.Hidden as OSP -import qualified System.OsString.Windows.Hidden as WSP +import qualified System.OsString.Posix as OSP +import qualified System.OsString.Windows as WSP import qualified System.OsPath.Posix as APF import qualified System.OsPath.Windows as AWF diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -2,21 +2,28 @@ _Note: below all `FilePath` values are unquoted, so `\\` really means two backslashes._ -## 1.4.301.0 *Nov 2024* +## 1.5.5.0 *Jan 2026* +* support MicroHS wrt [#257](https://github.com/haskell/filepath/pull/257) +* Switch from template-haskell to template-haskell-quasiquoter and -lift wrt [#258](https://github.com/haskell/filepath/pull/258) + +## 1.5.4.0 *Nov 2024* + * Don't catch async exceptions in internal functions wrt https://github.com/haskell/os-string/issues/22 -## 1.4.300.2 *Apr 2024* +## 1.5.3.0 *Jun 2024* -* Fix compabitiliby with GHC 9.10 +* Adjust for `encodeFS`/`decodedFS` deprecation in os-string -## 1.4.300.1 *Jan 2024* +## 1.5.2.0 *Jan 2024* -* Backport bugfix for [`splitFileName`](https://github.com/haskell/filepath/issues/219) on windows +* Fix a bug in `[splitFileName](https://github.com/haskell/filepath/issues/219)` +* make `osp :: QuasiQuoter` valid as a pattern wrt [#210](https://github.com/haskell/filepath/pull/210) +* Add `unsafeEncodeUtf` from os-string -## 1.4.200.1 *Dec 2023* +## 1.5.0.0 *Nov 2023* -* Improve deprecation warnings wrt [#209](https://github.com/haskell/filepath/issues/209) +* remove `OsString` modules ## 1.4.200.0 *Nov 2023* diff --git a/filepath.cabal b/filepath.cabal --- a/filepath.cabal +++ b/filepath.cabal @@ -1,13 +1,13 @@ cabal-version: 2.2 name: filepath -version: 1.4.301.0 +version: 1.5.5.0 -- NOTE: Don't forget to update ./changelog.md license: BSD-3-Clause license-file: LICENSE author: Neil Mitchell maintainer: Julian Ospald -copyright: Neil Mitchell 2005-2020, Julain Ospald 2021-2022 +copyright: Neil Mitchell 2005-2020, Julian Ospald 2021-2022 bug-reports: https://github.com/haskell/filepath/issues homepage: https://github.com/haskell/filepath/blob/master/README.md @@ -16,14 +16,14 @@ build-type: Simple synopsis: Library for manipulating FilePaths in a cross platform way. tested-with: - GHC ==8.0.2 - || ==8.2.2 - || ==8.4.4 - || ==8.6.5 + GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 - || ==9.2.3 + || ==9.2.8 + || ==9.4.8 + || ==9.6.3 + || ==9.8.1 description: This package provides functionality for manipulating @FilePath@ values, and is shipped with . It provides two variants for filepaths: @@ -42,8 +42,7 @@ . * "System.FilePath" / "System.OsPath" for dealing with current platform-specific filepaths . - "System.OsString" is like "System.OsPath", but more general purpose. Refer to the documentation of - those modules for more information. + For more powerful string manipulation of @OsPath@, you can use the (@OsPath@ is a type synonym for @OsString@). . An introduction into the new API can be found in this . @@ -54,8 +53,6 @@ Makefile System/FilePath/Internal.hs System/OsPath/Common.hs - System/OsString/Common.hs - tests/bytestring-tests/Properties/Common.hs extra-doc-files: changelog.md @@ -77,33 +74,14 @@ System.FilePath.Posix System.FilePath.Windows System.OsPath - System.OsPath.Data.ByteString.Short - System.OsPath.Data.ByteString.Short.Internal - System.OsPath.Data.ByteString.Short.Word16 System.OsPath.Encoding - System.OsPath.Encoding.Internal System.OsPath.Internal System.OsPath.Posix System.OsPath.Posix.Internal System.OsPath.Types System.OsPath.Windows System.OsPath.Windows.Internal - System.OsString - System.OsString.Internal - System.OsString.Internal.Types - System.OsString.Posix - System.OsString.Windows - other-modules: - System.OsPath.Data.ByteString.Short.Hidden - System.OsPath.Data.ByteString.Short.Internal.Hidden - System.OsPath.Data.ByteString.Short.Word16.Hidden - System.OsPath.Encoding.Internal.Hidden - System.OsString.Internal.Hidden - System.OsString.Internal.Types.Hidden - System.OsString.Posix.Hidden - System.OsString.Windows.Hidden - other-extensions: CPP PatternGuards @@ -113,11 +91,20 @@ default-language: Haskell2010 build-depends: - , base >=4.9 && <4.22 + , base >=4.12.0.0 && <4.23 , bytestring >=0.11.3.0 , deepseq , exceptions - , template-haskell + , os-string >=2.0.1 + -- template-haskell-lift was added as a boot library in GHC-9.14 + -- once we no longer wish to backport releases to older major releases, + -- this conditional can be dropped + if impl(ghc < 9.14) + build-depends: template-haskell + elif impl(ghc) + build-depends: + , template-haskell-lift >=0.1 && <0.2 + , template-haskell-quasiquoter >=0.1 && <0.2 ghc-options: -Wall @@ -137,7 +124,9 @@ , base , bytestring >=0.11.3.0 , filepath - , QuickCheck >=2.7 && <2.15 + , os-string >=2.0.1 + , tasty + , tasty-quickcheck default-language: Haskell2010 ghc-options: -Wall @@ -153,29 +142,18 @@ Legacy.System.FilePath.Posix Legacy.System.FilePath.Windows TestUtil - - build-depends: - , base - , bytestring >=0.11.3.0 - , filepath - , QuickCheck >=2.7 && <2.15 - -test-suite bytestring-tests - default-language: Haskell2010 - ghc-options: -Wall - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: tests tests/bytestring-tests - other-modules: - Properties.ShortByteString - Properties.ShortByteString.Word16 - TestUtil + Gen build-depends: , base , bytestring >=0.11.3.0 , filepath - , QuickCheck >=2.7 && <2.15 + , generic-random + , generic-deriving + , os-string >=2.0.1 + , tasty + , tasty-quickcheck + , QuickCheck test-suite abstract-filepath default-language: Haskell2010 @@ -185,7 +163,6 @@ hs-source-dirs: tests tests/abstract-filepath other-modules: Arbitrary - EncodingSpec OsPathSpec TestUtil @@ -194,8 +171,10 @@ , bytestring >=0.11.3.0 , deepseq , filepath - , QuickCheck >=2.7 && <2.15 + , os-string >=2.0.1 , quickcheck-classes-base ^>=0.6.2 + , tasty + , tasty-quickcheck benchmark bench-filepath default-language: Haskell2010 @@ -208,6 +187,7 @@ , bytestring >=0.11.3.0 , deepseq , filepath + , os-string >=2.0.1 , tasty-bench ghc-options: -with-rtsopts=-A32m diff --git a/tests/TestUtil.hs b/tests/TestUtil.hs --- a/tests/TestUtil.hs +++ b/tests/TestUtil.hs @@ -4,12 +4,12 @@ module TestUtil( module TestUtil, - module Test.QuickCheck, + module Test.Tasty.QuickCheck, module Data.List, module Data.Maybe ) where -import Test.QuickCheck hiding ((==>)) +import Test.Tasty.QuickCheck hiding ((==>)) import Data.ByteString.Short (ShortByteString) import Data.List import Data.Maybe @@ -25,11 +25,10 @@ import System.OsPath.Types #endif import System.OsString.Internal.Types -import System.OsPath.Encoding.Internal +import System.OsString.Encoding.Internal import GHC.IO.Encoding.UTF16 ( mkUTF16le ) import GHC.IO.Encoding.UTF8 ( mkUTF8 ) import GHC.IO.Encoding.Failure -import System.Environment infixr 0 ==> @@ -158,31 +157,3 @@ arbitrary = PW <$> arbitrary #endif -runTests :: [(String, Property)] -> IO () -runTests tests = do - args <- getArgs - let count = case args of i:_ -> read i; _ -> 10000 - let testNum = case args of - _:i:_ - | let num = read i - , num < 0 -> drop (negate num) tests - | let num = read i - , num > 0 -> take num tests - | otherwise -> [] - _ -> tests - putStrLn $ "Testing with " ++ show count ++ " repetitions" - let total' = length testNum - let showOutput x = show x{output=""} ++ "\n" ++ output x - bad <- fmap catMaybes $ forM (zip @Integer [1..] testNum) $ \(i,(msg,prop)) -> do - putStrLn $ "Test " ++ show i ++ " of " ++ show total' ++ ": " ++ msg - res <- quickCheckWithResult stdArgs{chatty=False, maxSuccess=count} prop - case res of - Success{} -> pure Nothing - bad -> do putStrLn $ showOutput bad; putStrLn "TEST FAILURE!"; pure $ Just (msg,bad) - if null bad then - putStrLn $ "Success, " ++ show total' ++ " tests passed" - else do - putStrLn $ show (length bad) ++ " FAILURES\n" - forM_ (zip @Integer [1..] bad) $ \(i,(a,b)) -> - putStrLn $ "FAILURE " ++ show i ++ ": " ++ a ++ "\n" ++ showOutput b ++ "\n" - fail $ "FAILURE, failed " ++ show (length bad) ++ " of " ++ show total' ++ " tests" diff --git a/tests/abstract-filepath/Arbitrary.hs b/tests/abstract-filepath/Arbitrary.hs --- a/tests/abstract-filepath/Arbitrary.hs +++ b/tests/abstract-filepath/Arbitrary.hs @@ -10,7 +10,7 @@ import qualified System.OsString.Windows as Windows import Data.ByteString ( ByteString ) import qualified Data.ByteString as ByteString -import Test.QuickCheck +import Test.Tasty.QuickCheck instance Arbitrary OsString where diff --git a/tests/abstract-filepath/EncodingSpec.hs b/tests/abstract-filepath/EncodingSpec.hs deleted file mode 100644 --- a/tests/abstract-filepath/EncodingSpec.hs +++ /dev/null @@ -1,174 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeApplications #-} - -module EncodingSpec where - -import Data.ByteString ( ByteString ) -import qualified Data.ByteString as BS - -import Arbitrary -import Test.QuickCheck - -import Data.Either ( isRight ) -import qualified System.OsPath.Data.ByteString.Short as BS8 -import qualified System.OsPath.Data.ByteString.Short.Word16 as BS16 -import System.OsPath.Encoding.Internal -import GHC.IO (unsafePerformIO) -import GHC.IO.Encoding ( setFileSystemEncoding ) -import System.IO - ( utf16le ) -import Control.Exception -import Control.DeepSeq -import Data.Bifunctor ( first ) -import GHC.IO.Encoding.Failure ( CodingFailureMode(..) ) -import GHC.IO.Encoding.UTF16 ( mkUTF16le ) -import GHC.IO.Encoding.UTF8 ( mkUTF8 ) - - -tests :: [(String, Property)] -tests = - [ ("ucs2le_decode . ucs2le_encode == id", - property $ \(padEven -> ba) -> - let decoded = decodeWithTE ucs2le (BS8.toShort ba) - encoded = encodeWithTE ucs2le =<< decoded - in (BS8.fromShort <$> encoded) === Right ba) - , ("utf16 doesn't handle invalid surrogate pairs", - property $ - let str = [toEnum 55296, toEnum 55297] - encoded = encodeWithTE utf16le str - decoded = decodeWithTE utf16le =<< encoded -#if __GLASGOW_HASKELL__ >= 910 - in decoded === Left (EncodingError ("recoverEncode: invalid argument (cannot encode character " <> show (head str) <> ")\n") Nothing)) -#elif __GLASGOW_HASKELL__ >= 904 - in decoded === Left (EncodingError ("recoverEncode: invalid argument (cannot encode character " <> show (head str) <> ")") Nothing)) -#else - in decoded === Left (EncodingError "recoverEncode: invalid argument (invalid character)" Nothing)) -#endif - , ("ucs2 handles invalid surrogate pairs", - property $ - let str = [toEnum 55296, toEnum 55297] - encoded = encodeWithTE ucs2le str - decoded = decodeWithTE ucs2le =<< encoded - in decoded === Right str) - , ("can roundtrip arbitrary bytes through utf-8 (with RoundtripFailure)", - property $ - \bs -> - let decoded = decodeWithTE (mkUTF8 RoundtripFailure) (BS8.toShort bs) - encoded = encodeWithTE (mkUTF8 RoundtripFailure) =<< decoded - in (either (const 0) BS8.length encoded, encoded) === (BS8.length (BS8.toShort bs), Right (BS8.toShort bs))) - - , ("can decode arbitrary strings through utf-8 (with RoundtripFailure)", - property $ - \(NonNullSurrogateString str) -> - let encoded = encodeWithTE (mkUTF8 RoundtripFailure) str - decoded = decodeWithTE (mkUTF8 RoundtripFailure) =<< encoded - in expectFailure $ (either (const 0) length decoded, decoded) === (length str, Right str)) - - , ("utf-8 roundtrip encode cannot deal with some surrogates", - property $ - let str = [toEnum 0xDFF0, toEnum 0xDFF2] - encoded = encodeWithTE (mkUTF8 RoundtripFailure) str - decoded = decodeWithTE (mkUTF8 RoundtripFailure) =<< encoded -#if __GLASGOW_HASKELL__ >= 910 - in decoded === Left (EncodingError ("recoverEncode: invalid argument (cannot encode character " <> show (head str) <> ")\n") Nothing)) -#elif __GLASGOW_HASKELL__ >= 904 - in decoded === Left (EncodingError ("recoverEncode: invalid argument (cannot encode character " <> show (head str) <> ")") Nothing)) -#else - in decoded === Left (EncodingError "recoverEncode: invalid argument (invalid character)" Nothing)) -#endif - - , ("cannot roundtrip arbitrary bytes through utf-16 (with RoundtripFailure)", - property $ - \(padEven -> bs) -> - let decoded = decodeWithTE (mkUTF16le RoundtripFailure) (BS8.toShort bs) - encoded = encodeWithTE (mkUTF16le RoundtripFailure) =<< decoded - in expectFailure $ (either (const 0) BS8.length encoded, encoded) === (BS8.length (BS8.toShort bs), Right (BS8.toShort bs))) - , ("encodeWithTE/decodeWithTE ErrorOnCodingFailure fails (utf16le)", - property $ - \(padEven -> bs) -> - let decoded = decodeWithTE (mkUTF16le ErrorOnCodingFailure) (BS8.toShort bs) - encoded = encodeWithTE (mkUTF16le ErrorOnCodingFailure) =<< decoded - in expectFailure $ (isRight encoded, isRight decoded) === (True, True)) - , ("encodeWithTE/decodeWithTE ErrorOnCodingFailure fails (utf8)", - property $ - \bs -> - let decoded = decodeWithTE (mkUTF8 ErrorOnCodingFailure) (BS8.toShort bs) - encoded = encodeWithTE (mkUTF8 ErrorOnCodingFailure) =<< decoded - in expectFailure $ (isRight encoded, isRight decoded) === (True, True)) - , ("encodeWithTE/decodeWithTE TransliterateCodingFailure never fails (utf16le)", - property $ - \(padEven -> bs) -> - let decoded = decodeWithTE (mkUTF16le TransliterateCodingFailure) (BS8.toShort bs) - encoded = encodeWithTE (mkUTF16le TransliterateCodingFailure) =<< decoded - in (isRight encoded, isRight decoded) === (True, True)) - , ("encodeWithTE/decodeWithTE TransliterateCodingFailure never fails (utf8)", - property $ - \bs -> - let decoded = decodeWithTE (mkUTF8 TransliterateCodingFailure) (BS8.toShort bs) - encoded = encodeWithTE (mkUTF8 TransliterateCodingFailure) =<< decoded - in (isRight encoded, isRight decoded) === (True, True)) - , ("encodeWithBaseWindows/decodeWithBaseWindows never fails (utf16le)", - property $ - \(padEven -> bs) -> - let decoded = decodeW' (BS8.toShort bs) - encoded = encodeW' =<< decoded - in (isRight encoded, isRight decoded) === (True, True)) - , ("encodeWithBasePosix/decodeWithBasePosix never fails (utf8b)", - property $ - \bs -> ioProperty $ do - setFileSystemEncoding (mkUTF8 TransliterateCodingFailure) - let decoded = decodeP' (BS8.toShort bs) - encoded = encodeP' =<< decoded - pure $ (isRight encoded, isRight decoded) === (True, True)) - - , ("decodeWithBaseWindows == utf16le_b", - property $ - \(BS8.toShort . padEven -> bs) -> - let decoded = decodeW' bs - decoded' = first displayException $ decodeWithTE (mkUTF16le_b ErrorOnCodingFailure) bs - in decoded === decoded') - - , ("encodeWithBaseWindows == utf16le_b", - property $ - \(NonNullSurrogateString str) -> - let decoded = encodeW' str - decoded' = first displayException $ encodeWithTE (mkUTF16le_b ErrorOnCodingFailure) str - in decoded === decoded') - - , ("encodeWithTE/decodeWithTE never fails (utf16le_b)", - property $ - \(padEven -> bs) -> - let decoded = decodeWithTE (mkUTF16le_b ErrorOnCodingFailure) (BS8.toShort bs) - encoded = encodeWithTE (mkUTF16le_b ErrorOnCodingFailure) =<< decoded - in (isRight encoded, isRight decoded) === (True, True)) - ] - - -padEven :: ByteString -> ByteString -padEven bs - | even (BS.length bs) = bs - | otherwise = bs `BS.append` BS.pack [70] - - -decodeP' :: BS8.ShortByteString -> Either String String -decodeP' ba = unsafePerformIO $ do - r <- try @SomeException $ decodeWithBasePosix ba - evaluate $ force $ first displayException r - -encodeP' :: String -> Either String BS8.ShortByteString -encodeP' str = unsafePerformIO $ do - r <- try @SomeException $ encodeWithBasePosix str - evaluate $ force $ first displayException r - -decodeW' :: BS16.ShortByteString -> Either String String -decodeW' ba = unsafePerformIO $ do - r <- try @SomeException $ decodeWithBaseWindows ba - evaluate $ force $ first displayException r - -encodeW' :: String -> Either String BS8.ShortByteString -encodeW' str = unsafePerformIO $ do - r <- try @SomeException $ encodeWithBaseWindows str - evaluate $ force $ first displayException r - diff --git a/tests/abstract-filepath/OsPathSpec.hs b/tests/abstract-filepath/OsPathSpec.hs --- a/tests/abstract-filepath/OsPathSpec.hs +++ b/tests/abstract-filepath/OsPathSpec.hs @@ -13,14 +13,13 @@ import System.OsPath.Windows as Windows import System.OsPath.Encoding import qualified System.OsString.Internal.Types as OS -import System.OsPath.Data.ByteString.Short ( toShort ) -import System.OsString.Posix as PosixS -import System.OsString.Windows as WindowsS +import System.OsString.Data.ByteString.Short ( toShort ) +import System.OsString.Posix as PosixS hiding (map) +import System.OsString.Windows as WindowsS hiding (map) import Control.Exception import Data.ByteString ( ByteString ) import qualified Data.ByteString as BS -import Test.QuickCheck import qualified Test.QuickCheck.Classes.Base as QC import GHC.IO.Encoding.UTF8 ( mkUTF8 ) import GHC.IO.Encoding.UTF16 ( mkUTF16le ) @@ -29,10 +28,12 @@ import Control.DeepSeq import Data.Bifunctor ( first ) import qualified Data.ByteString.Char8 as C -import qualified System.OsPath.Data.ByteString.Short.Word16 as BS16 -import qualified System.OsPath.Data.ByteString.Short as SBS +import qualified System.OsString.Data.ByteString.Short.Word16 as BS16 +import qualified System.OsString.Data.ByteString.Short as SBS import Data.Char ( ord ) import Data.Proxy ( Proxy(..) ) +import Test.Tasty +import Test.Tasty.QuickCheck import Arbitrary @@ -42,211 +43,216 @@ fromRight b _ = b -tests :: [(String, Property)] -tests = - [ ("OSP.encodeUtf . OSP.decodeUtf == id", - property $ \(NonNullString str) -> (OSP.decodeUtf . fromJust . OSP.encodeUtf) str == Just str) - - , ("decodeUtf . encodeUtf == id (Posix)", - property $ \(NonNullString str) -> (Posix.decodeUtf . fromJust . Posix.encodeUtf) str == Just str) - , ("decodeUtf . encodeUtf == id (Windows)", - property $ \(NonNullString str) -> (Windows.decodeUtf . fromJust . Windows.encodeUtf) str == Just str) - - , ("encodeWith ucs2le . decodeWith ucs2le == id (Posix)", - property $ \(padEven -> bs) -> (Posix.encodeWith ucs2le . (\(Right r) -> r) . Posix.decodeWith ucs2le . OS.PS . toShort) bs === Right (OS.PS . toShort $ bs)) - , ("encodeWith ucs2le . decodeWith ucs2le == id (Windows)", - property $ \(padEven -> bs) -> (Windows.encodeWith ucs2le . (\(Right r) -> r) . Windows.decodeWith ucs2le . OS.WS . toShort) bs - === Right (OS.WS . toShort $ bs)) - - , ("decodeFS . encodeFS == id (Posix)", - property $ \(NonNullString str) -> ioProperty $ do - setFileSystemEncoding (mkUTF8 TransliterateCodingFailure) - r1 <- Posix.encodeFS str - r2 <- try @SomeException $ Posix.decodeFS r1 - r3 <- evaluate $ force $ first displayException r2 - pure (r3 === Right str) - ) - , ("decodeFS . encodeFS == id (Windows)", - property $ \(NonNullString str) -> ioProperty $ do - r1 <- Windows.encodeFS str - r2 <- try @SomeException $ Windows.decodeFS r1 - r3 <- evaluate $ force $ first displayException r2 - pure (r3 === Right str) - ) - - , ("fromPlatformString* functions are equivalent under ASCII (Windows)", - property $ \(WindowsString . BS16.pack . map (fromIntegral . ord) . nonNullAsciiString -> str) -> ioProperty $ do - r1 <- Windows.decodeFS str - r2 <- Windows.decodeUtf str - (Right r3) <- pure $ Windows.decodeWith (mkUTF16le TransliterateCodingFailure) str - (Right r4) <- pure $ Windows.decodeWith (mkUTF16le RoundtripFailure) str - (Right r5) <- pure $ Windows.decodeWith (mkUTF16le ErrorOnCodingFailure) str - pure ( r1 === r2 - .&&. r1 === r3 - .&&. r1 === r4 - .&&. r1 === r5 - ) - ) - - , ("fromPlatformString* functions are equivalent under ASCII (Posix)", - property $ \(PosixString . SBS.toShort . C.pack . nonNullAsciiString -> str) -> ioProperty $ do - r1 <- Posix.decodeFS str - r2 <- Posix.decodeUtf str - (Right r3) <- pure $ Posix.decodeWith (mkUTF8 TransliterateCodingFailure) str - (Right r4) <- pure $ Posix.decodeWith (mkUTF8 RoundtripFailure) str - (Right r5) <- pure $ Posix.decodeWith (mkUTF8 ErrorOnCodingFailure) str - pure ( r1 === r2 - .&&. r1 === r3 - .&&. r1 === r4 - .&&. r1 === r5 - ) - ) - - , ("toPlatformString* functions are equivalent under ASCII (Windows)", - property $ \(NonNullAsciiString str) -> ioProperty $ do - r1 <- Windows.encodeFS str - r2 <- Windows.encodeUtf str - (Right r3) <- pure $ Windows.encodeWith (mkUTF16le TransliterateCodingFailure) str - (Right r4) <- pure $ Windows.encodeWith (mkUTF16le RoundtripFailure) str - (Right r5) <- pure $ Windows.encodeWith (mkUTF16le ErrorOnCodingFailure) str - pure ( r1 === r2 - .&&. r1 === r3 - .&&. r1 === r4 - .&&. r1 === r5 - ) - ) - - , ("toPlatformString* functions are equivalent under ASCII (Posix)", - property $ \(NonNullAsciiString str) -> ioProperty $ do - r1 <- Posix.encodeFS str - r2 <- Posix.encodeUtf str - (Right r3) <- pure $ Posix.encodeWith (mkUTF8 TransliterateCodingFailure) str - (Right r4) <- pure $ Posix.encodeWith (mkUTF8 RoundtripFailure) str - (Right r5) <- pure $ Posix.encodeWith (mkUTF8 ErrorOnCodingFailure) str - pure ( r1 === r2 - .&&. r1 === r3 - .&&. r1 === r4 - .&&. r1 === r5 - ) - ) - , ("Unit test toPlatformString* (Posix)", - property $ ioProperty $ do - let str = "ABcK_(ツ123_&**" - let expected = PosixString $ SBS.pack [0x41,0x42,0x63,0x4b,0x5f,0x28,0xe3,0x83,0x84,0x31,0x32,0x33,0x5f,0x26,0x2a,0x2a] - r1 <- Posix.encodeFS str - r2 <- Posix.encodeUtf str - (Right r3) <- pure $ Posix.encodeWith (mkUTF8 TransliterateCodingFailure) str - (Right r4) <- pure $ Posix.encodeWith (mkUTF8 RoundtripFailure) str - (Right r5) <- pure $ Posix.encodeWith (mkUTF8 ErrorOnCodingFailure) str - pure ( r1 === expected - .&&. r2 === expected - .&&. r3 === expected - .&&. r4 === expected - .&&. r5 === expected - ) - ) - , ("Unit test toPlatformString* (WindowsString)", - property $ ioProperty $ do - let str = "ABcK_(ツ123_&**" - let expected = WindowsString $ BS16.pack [0x0041,0x0042,0x0063,0x004b,0x005f,0x0028,0x30c4,0x0031,0x0032,0x0033,0x005f,0x0026,0x002a,0x002a] - r1 <- Windows.encodeFS str - r2 <- Windows.encodeUtf str - (Right r3) <- pure $ Windows.encodeWith (mkUTF16le TransliterateCodingFailure) str - (Right r4) <- pure $ Windows.encodeWith (mkUTF16le RoundtripFailure) str - (Right r5) <- pure $ Windows.encodeWith (mkUTF16le ErrorOnCodingFailure) str - pure ( r1 === expected - .&&. r2 === expected - .&&. r3 === expected - .&&. r4 === expected - .&&. r5 === expected - ) - ) - - , ("Unit test fromPlatformString* (Posix)", - property $ ioProperty $ do - let bs = PosixString $ SBS.pack [0x41,0x42,0x63,0x4b,0x5f,0x28,0xe3,0x83,0x84,0x31,0x32,0x33,0x5f,0x26,0x2a,0x2a] - let expected = "ABcK_(ツ123_&**" - r1 <- Posix.decodeFS bs - r2 <- Posix.decodeUtf bs - (Right r3) <- pure $ Posix.decodeWith (mkUTF8 TransliterateCodingFailure) bs - (Right r4) <- pure $ Posix.decodeWith (mkUTF8 RoundtripFailure) bs - (Right r5) <- pure $ Posix.decodeWith (mkUTF8 ErrorOnCodingFailure) bs - pure ( r1 === expected - .&&. r2 === expected - .&&. r3 === expected - .&&. r4 === expected - .&&. r5 === expected - ) - ) - , ("Unit test fromPlatformString* (WindowsString)", - property $ ioProperty $ do - let bs = WindowsString $ BS16.pack [0x0041,0x0042,0x0063,0x004b,0x005f,0x0028,0x30c4,0x0031,0x0032,0x0033,0x005f,0x0026,0x002a,0x002a] - let expected = "ABcK_(ツ123_&**" - r1 <- Windows.decodeFS bs - r2 <- Windows.decodeUtf bs - (Right r3) <- pure $ Windows.decodeWith (mkUTF16le TransliterateCodingFailure) bs - (Right r4) <- pure $ Windows.decodeWith (mkUTF16le RoundtripFailure) bs - (Right r5) <- pure $ Windows.decodeWith (mkUTF16le ErrorOnCodingFailure) bs - pure ( r1 === expected - .&&. r2 === expected - .&&. r3 === expected - .&&. r4 === expected - .&&. r5 === expected - ) - ) - , ("QuasiQuoter (WindowsString)", - property $ do - let bs = WindowsString $ BS16.pack [0x0041,0x0042,0x0063,0x004b,0x005f,0x0028,0x30c4,0x0031,0x0032,0x0033,0x005f,0x0026,0x002a,0x002a] - let expected = [WindowsS.pstr|ABcK_(ツ123_&**|] - bs === expected - ) - , ("QuasiQuoter (PosixString)", - property $ do - let bs = PosixString $ SBS.pack [0x41,0x42,0x63,0x4b,0x5f,0x28,0xe3,0x83,0x84,0x31,0x32,0x33,0x5f,0x26,0x2a,0x2a] - let expected = [PosixS.pstr|ABcK_(ツ123_&**|] - bs === expected - ) - , ("QuasiQuoter (WindowsPath)", - property $ do - let bs = WindowsString $ BS16.pack [0x0041,0x0042,0x0063,0x004b,0x005f] - let expected = [Windows.pstr|ABcK_|] - bs === expected - ) - , ("QuasiQuoter (PosixPath)", - property $ do - let bs = PosixString $ SBS.pack [0x41,0x42,0x63,0x4b,0x5f] - let expected = [Posix.pstr|ABcK_|] - bs === expected - ) - - , ("pack . unpack == id (Windows)", - property $ \ws@(WindowsString _) -> - Windows.pack (Windows.unpack ws) === ws - ) - , ("pack . unpack == id (Posix)", - property $ \ws@(PosixString _) -> - Posix.pack (Posix.unpack ws) === ws - ) - , ("pack . unpack == id (OsPath)", - property $ \ws@(OsString _) -> - OSP.pack (OSP.unpack ws) === ws - ) - - - ] ++ QC.lawsProperties (QC.ordLaws (Proxy @OsPath)) - ++ QC.lawsProperties (QC.monoidLaws (Proxy @OsPath)) +tests :: TestTree +tests = testGroup "Abstract filepath" [ + testGroup "filepaths" + [ testProperties "OSP" + [ ("pack . unpack == id", + property $ \ws@(OsString _) -> + OSP.pack (OSP.unpack ws) === ws + ), + ("encodeUtf . decodeUtf == id", + property $ \(NonNullString str) -> (OSP.decodeUtf . fromJust . OSP.encodeUtf) str == Just str) + ], + testProperties "Windows" + [ ("pack . unpack == id (Windows)", + property $ \ws@(WindowsString _) -> + Windows.pack (Windows.unpack ws) === ws + ) + , ("decodeUtf . encodeUtf == id", + property $ \(NonNullString str) -> (Windows.decodeUtf . fromJust . Windows.encodeUtf) str == Just str) + , ("encodeWith ucs2le . decodeWith ucs2le == id", + property $ \(padEven -> bs) -> (Windows.encodeWith ucs2le . (\(Right r) -> r) . Windows.decodeWith ucs2le . OS.WS . toShort) bs + === Right (OS.WS . toShort $ bs)) + , ("decodeFS . encodeFS == id (Windows)", + property $ \(NonNullString str) -> ioProperty $ do + r1 <- Windows.encodeFS str + r2 <- try @SomeException $ Windows.decodeFS r1 + r3 <- evaluate $ force $ first displayException r2 + pure (r3 === Right str) + ) + , ("fromPlatformString* functions are equivalent under ASCII", + property $ \(WindowsString . BS16.pack . map (fromIntegral . ord) . nonNullAsciiString -> str) -> ioProperty $ do + r1 <- Windows.decodeFS str + r2 <- Windows.decodeUtf str + (Right r3) <- pure $ Windows.decodeWith (mkUTF16le TransliterateCodingFailure) str + (Right r4) <- pure $ Windows.decodeWith (mkUTF16le RoundtripFailure) str + (Right r5) <- pure $ Windows.decodeWith (mkUTF16le ErrorOnCodingFailure) str + pure ( r1 === r2 + .&&. r1 === r3 + .&&. r1 === r4 + .&&. r1 === r5 + ) + ) + , ("toPlatformString* functions are equivalent under ASCII", + property $ \(NonNullAsciiString str) -> ioProperty $ do + r1 <- Windows.encodeFS str + r2 <- Windows.encodeUtf str + (Right r3) <- pure $ Windows.encodeWith (mkUTF16le TransliterateCodingFailure) str + (Right r4) <- pure $ Windows.encodeWith (mkUTF16le RoundtripFailure) str + (Right r5) <- pure $ Windows.encodeWith (mkUTF16le ErrorOnCodingFailure) str + pure ( r1 === r2 + .&&. r1 === r3 + .&&. r1 === r4 + .&&. r1 === r5 + ) + ) + , ("Unit test toPlatformString*", + property $ ioProperty $ do + let str = "ABcK_(ツ123_&**" + let expected = WindowsString $ BS16.pack [0x0041,0x0042,0x0063,0x004b,0x005f,0x0028,0x30c4,0x0031,0x0032,0x0033,0x005f,0x0026,0x002a,0x002a] + r1 <- Windows.encodeFS str + r2 <- Windows.encodeUtf str + (Right r3) <- pure $ Windows.encodeWith (mkUTF16le TransliterateCodingFailure) str + (Right r4) <- pure $ Windows.encodeWith (mkUTF16le RoundtripFailure) str + (Right r5) <- pure $ Windows.encodeWith (mkUTF16le ErrorOnCodingFailure) str + pure ( r1 === expected + .&&. r2 === expected + .&&. r3 === expected + .&&. r4 === expected + .&&. r5 === expected + ) + ) + , ("Unit test fromPlatformString*", + property $ ioProperty $ do + let bs = WindowsString $ BS16.pack [0x0041,0x0042,0x0063,0x004b,0x005f,0x0028,0x30c4,0x0031,0x0032,0x0033,0x005f,0x0026,0x002a,0x002a] + let expected = "ABcK_(ツ123_&**" + r1 <- Windows.decodeFS bs + r2 <- Windows.decodeUtf bs + (Right r3) <- pure $ Windows.decodeWith (mkUTF16le TransliterateCodingFailure) bs + (Right r4) <- pure $ Windows.decodeWith (mkUTF16le RoundtripFailure) bs + (Right r5) <- pure $ Windows.decodeWith (mkUTF16le ErrorOnCodingFailure) bs + pure ( r1 === expected + .&&. r2 === expected + .&&. r3 === expected + .&&. r4 === expected + .&&. r5 === expected + ) + ) + ] + , testProperties "Posix" + [ ("decodeUtf . encodeUtf == id", + property $ \(NonNullString str) -> (Posix.decodeUtf . fromJust . Posix.encodeUtf) str == Just str) + , ("encodeWith ucs2le . decodeWith ucs2le == id (Posix)", + property $ \(padEven -> bs) -> (Posix.encodeWith ucs2le . (\(Right r) -> r) . Posix.decodeWith ucs2le . OS.PS . toShort) bs === Right (OS.PS . toShort $ bs)) + , ("decodeFS . encodeFS == id", + property $ \(NonNullString str) -> ioProperty $ do + setFileSystemEncoding (mkUTF8 TransliterateCodingFailure) + r1 <- Posix.encodeFS str + r2 <- try @SomeException $ Posix.decodeFS r1 + r3 <- evaluate $ force $ first displayException r2 + pure (r3 === Right str) + ) + , ("fromPlatformString* functions are equivalent under ASCII", + property $ \(PosixString . SBS.toShort . C.pack . nonNullAsciiString -> str) -> ioProperty $ do + r1 <- Posix.decodeFS str + r2 <- Posix.decodeUtf str + (Right r3) <- pure $ Posix.decodeWith (mkUTF8 TransliterateCodingFailure) str + (Right r4) <- pure $ Posix.decodeWith (mkUTF8 RoundtripFailure) str + (Right r5) <- pure $ Posix.decodeWith (mkUTF8 ErrorOnCodingFailure) str + pure ( r1 === r2 + .&&. r1 === r3 + .&&. r1 === r4 + .&&. r1 === r5 + ) + ) + , ("toPlatformString* functions are equivalent under ASCII", + property $ \(NonNullAsciiString str) -> ioProperty $ do + r1 <- Posix.encodeFS str + r2 <- Posix.encodeUtf str + (Right r3) <- pure $ Posix.encodeWith (mkUTF8 TransliterateCodingFailure) str + (Right r4) <- pure $ Posix.encodeWith (mkUTF8 RoundtripFailure) str + (Right r5) <- pure $ Posix.encodeWith (mkUTF8 ErrorOnCodingFailure) str + pure ( r1 === r2 + .&&. r1 === r3 + .&&. r1 === r4 + .&&. r1 === r5 + ) + ) + , ("Unit test toPlatformString*", + property $ ioProperty $ do + let str = "ABcK_(ツ123_&**" + let expected = PosixString $ SBS.pack [0x41,0x42,0x63,0x4b,0x5f,0x28,0xe3,0x83,0x84,0x31,0x32,0x33,0x5f,0x26,0x2a,0x2a] + r1 <- Posix.encodeFS str + r2 <- Posix.encodeUtf str + (Right r3) <- pure $ Posix.encodeWith (mkUTF8 TransliterateCodingFailure) str + (Right r4) <- pure $ Posix.encodeWith (mkUTF8 RoundtripFailure) str + (Right r5) <- pure $ Posix.encodeWith (mkUTF8 ErrorOnCodingFailure) str + pure ( r1 === expected + .&&. r2 === expected + .&&. r3 === expected + .&&. r4 === expected + .&&. r5 === expected + ) + ) + , ("Unit test fromPlatformString*", + property $ ioProperty $ do + let bs = PosixString $ SBS.pack [0x41,0x42,0x63,0x4b,0x5f,0x28,0xe3,0x83,0x84,0x31,0x32,0x33,0x5f,0x26,0x2a,0x2a] + let expected = "ABcK_(ツ123_&**" + r1 <- Posix.decodeFS bs + r2 <- Posix.decodeUtf bs + (Right r3) <- pure $ Posix.decodeWith (mkUTF8 TransliterateCodingFailure) bs + (Right r4) <- pure $ Posix.decodeWith (mkUTF8 RoundtripFailure) bs + (Right r5) <- pure $ Posix.decodeWith (mkUTF8 ErrorOnCodingFailure) bs + pure ( r1 === expected + .&&. r2 === expected + .&&. r3 === expected + .&&. r4 === expected + .&&. r5 === expected + ) + ) + , ("pack . unpack == id (Posix)", + property $ \ws@(PosixString _) -> + Posix.pack (Posix.unpack ws) === ws + ) + ] + ], + testGroup "QuasiQuoter" + [ testProperties "windows" + [ ("QuasiQuoter (WindowsPath)", + property $ do + let bs = WindowsString $ BS16.pack [0x0041,0x0042,0x0063,0x004b,0x005f] + let expected = [Windows.pstr|ABcK_|] + bs === expected + ) + , ("QuasiQuoter (WindowsString)", + property $ do + let bs = WindowsString $ BS16.pack [0x0041,0x0042,0x0063,0x004b,0x005f,0x0028,0x30c4,0x0031,0x0032,0x0033,0x005f,0x0026,0x002a,0x002a] + let expected = [WindowsS.pstr|ABcK_(ツ123_&**|] + bs === expected + ) + ], + testProperties "posix" + [ ("QuasiQuoter (PosixPath)", + property $ do + let bs = PosixString $ SBS.pack [0x41,0x42,0x63,0x4b,0x5f] + let expected = [Posix.pstr|ABcK_|] + bs === expected + ) + , ("QuasiQuoter (PosixString)", + property $ do + let bs = PosixString $ SBS.pack [0x41,0x42,0x63,0x4b,0x5f,0x28,0xe3,0x83,0x84,0x31,0x32,0x33,0x5f,0x26,0x2a,0x2a] + let expected = [PosixS.pstr|ABcK_(ツ123_&**|] + bs === expected + ) + ] + ], + testProperties "Type laws" + (QC.lawsProperties (QC.ordLaws (Proxy @OsPath)) + ++ QC.lawsProperties (QC.monoidLaws (Proxy @OsPath)) - ++ QC.lawsProperties (QC.ordLaws (Proxy @OsString)) - ++ QC.lawsProperties (QC.monoidLaws (Proxy @OsString)) + ++ QC.lawsProperties (QC.ordLaws (Proxy @OsString)) + ++ QC.lawsProperties (QC.monoidLaws (Proxy @OsString)) - ++ QC.lawsProperties (QC.ordLaws (Proxy @WindowsString)) - ++ QC.lawsProperties (QC.monoidLaws (Proxy @WindowsString)) + ++ QC.lawsProperties (QC.ordLaws (Proxy @WindowsString)) + ++ QC.lawsProperties (QC.monoidLaws (Proxy @WindowsString)) - ++ QC.lawsProperties (QC.ordLaws (Proxy @PosixString)) - ++ QC.lawsProperties (QC.monoidLaws (Proxy @PosixString)) + ++ QC.lawsProperties (QC.ordLaws (Proxy @PosixString)) + ++ QC.lawsProperties (QC.monoidLaws (Proxy @PosixString)) - ++ QC.lawsProperties (QC.ordLaws (Proxy @PlatformString)) - ++ QC.lawsProperties (QC.monoidLaws (Proxy @PlatformString)) + ++ QC.lawsProperties (QC.ordLaws (Proxy @PlatformString)) + ++ QC.lawsProperties (QC.monoidLaws (Proxy @PlatformString))) + ] padEven :: ByteString -> ByteString diff --git a/tests/abstract-filepath/Test.hs b/tests/abstract-filepath/Test.hs --- a/tests/abstract-filepath/Test.hs +++ b/tests/abstract-filepath/Test.hs @@ -1,8 +1,7 @@ module Main (main) where import qualified OsPathSpec -import qualified EncodingSpec -import TestUtil +import Test.Tasty main :: IO () -main = runTests (EncodingSpec.tests ++ OsPathSpec.tests) +main = defaultMain OsPathSpec.tests diff --git a/tests/bytestring-tests/Main.hs b/tests/bytestring-tests/Main.hs deleted file mode 100644 --- a/tests/bytestring-tests/Main.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TypeApplications #-} - -module Main (main) where - -import qualified Properties.ShortByteString as PropSBS -import qualified Properties.ShortByteString.Word16 as PropSBSW16 -import TestUtil - -main :: IO () -main = runTests (PropSBS.tests ++ PropSBSW16.tests) diff --git a/tests/bytestring-tests/Properties/Common.hs b/tests/bytestring-tests/Properties/Common.hs deleted file mode 100644 --- a/tests/bytestring-tests/Properties/Common.hs +++ /dev/null @@ -1,441 +0,0 @@ --- | --- Module : Properties.ShortByteString --- Copyright : (c) Andrew Lelechenko 2021 --- License : BSD-style - -{-# LANGUAGE CPP #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wno-orphans #-} - --- We are happy to sacrifice optimizations in exchange for faster compilation, --- but need to test rewrite rules. As one can check using -ddump-rule-firings, --- rewrite rules do not fire in -O0 mode, so we use -O1, but disable almost all --- optimizations. It roughly halves compilation time. -{-# OPTIONS_GHC -O1 -fenable-rewrite-rules - -fmax-simplifier-iterations=1 -fsimplifier-phases=0 - -fno-call-arity -fno-case-merge -fno-cmm-elim-common-blocks -fno-cmm-sink - -fno-cpr-anal -fno-cse -fno-do-eta-reduction -fno-float-in -fno-full-laziness - -fno-loopification -fno-specialise -fno-strictness #-} - -#ifdef WORD16 -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 -import qualified Data.Char as C -#endif -import Data.ByteString.Short (ShortByteString) - -import Data.Word - -import Control.Arrow -import Data.Foldable -import Data.List as L hiding (unsnoc) -import Data.Semigroup -import Data.Tuple -import Test.QuickCheck -import Test.QuickCheck.Monadic ( monadicIO, run ) -import Text.Show.Functions () - -#ifdef WORD16 -numWord :: ShortByteString -> Int -numWord = B.numWord16 - -toElem :: Word16 -> Word16 -toElem = id - -swapW :: Word16 -> Word16 -swapW = byteSwap16 - -sizedByteString :: Int -> Gen ShortByteString -sizedByteString n = do m <- choose(0, n) - fmap B.pack $ vectorOf m arbitrary - -instance Arbitrary ShortByteString where - arbitrary = do - bs <- sized sizedByteString - n <- choose (0, 2) - return (B.drop n bs) -- to give us some with non-0 offset - -instance CoArbitrary ShortByteString where - coarbitrary s = coarbitrary (B.unpack s) - -#else -_nul :: Word8 -_nul = 0x00 - -isSpace :: Word8 -> Bool -isSpace = C.isSpace . word8ToChar - --- | Total conversion to char. -word8ToChar :: Word8 -> Char -word8ToChar = C.chr . fromIntegral - -numWord :: ShortByteString -> Int -numWord = B.length - -toElem :: Word8 -> Word8 -toElem = id - -swapW :: Word8 -> Word8 -swapW = id - - -sizedByteString :: Int -> Gen ShortByteString -sizedByteString n = do m <- choose(0, n) - fmap B.pack $ vectorOf m arbitrary - -instance Arbitrary ShortByteString where - arbitrary = do - bs <- sized sizedByteString - n <- choose (0, 2) - return (B.drop n bs) -- to give us some with non-0 offset - shrink = map B.pack . shrink . B.unpack - -instance CoArbitrary ShortByteString where - coarbitrary s = coarbitrary (B.unpack s) - -#endif - - -tests :: [(String, Property)] -tests = - [ ("pack . unpack", - property $ \x -> x === B.pack (B.unpack x)) - , ("unpack . pack" , - property $ \(map toElem -> xs) -> xs === B.unpack (B.pack xs)) - , ("read . show" , - property $ \x -> (x :: ShortByteString) === read (show x)) - - , ("==" , - property $ \x y -> (x == y) === (B.unpack x == B.unpack y)) - , ("== refl" , - property $ \x -> (x :: ShortByteString) == x) - , ("== symm", - property $ \x y -> ((x :: ShortByteString) == y) === (y == x)) - , ("== pack unpack", - property $ \x -> x == B.pack (B.unpack x)) - - , ("compare", - property $ \x y -> compare x y === compare (swapW <$> B.unpack x) (swapW <$> B.unpack y)) - , ("compare EQ", - property $ \x -> compare (x :: ShortByteString) x == EQ) - , ("compare GT", - property $ \x (toElem -> c) -> compare (B.snoc x c) x == GT) - , ("compare LT", - property $ \x (toElem -> c) -> compare x (B.snoc x c) == LT) - , ("compare GT empty", - property $ \x -> not (B.null x) ==> compare x B.empty == GT) - , ("compare LT empty", - property $ \x -> not (B.null x) ==> compare B.empty x == LT) - , ("compare GT concat", - property $ \x y -> not (B.null y) ==> compare (x <> y) x == GT) - , ("compare char" , - property $ \(toElem -> c) (toElem -> d) -> compare (swapW c) (swapW d) == compare (B.singleton c) (B.singleton d)) - , ("compare unsigned", - once $ compare (B.singleton 255) (B.singleton 127) == GT) - - , ("null" , - property $ \x -> B.null x === null (B.unpack x)) - , ("empty 0" , - once $ numWord B.empty === 0) - , ("empty []", - once $ B.unpack B.empty === []) - , ("mempty 0", - 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)) - , ("mconcat [x,x]" , - property $ \x -> B.unpack (mconcat [x, x]) === mconcat [B.unpack x, B.unpack x]) - , ("mconcat [x,[]]" , - property $ \x -> B.unpack (mconcat [x, B.empty]) === mconcat [B.unpack x, []]) - - , ("null" , - property $ \x -> B.null x === null (B.unpack x)) - , ("reverse" , - property $ \x -> B.unpack (B.reverse x) === reverse (B.unpack x)) - , ("all" , - property $ \f x -> B.all f x === all f (B.unpack x)) - , ("all ==" , - property $ \(toElem -> c) x -> B.all (== c) x === all (== c) (B.unpack x)) - , ("any" , - property $ \f x -> B.any f x === any f (B.unpack x)) - , ("any ==" , - property $ \(toElem -> c) x -> B.any (== c) x === any (== c) (B.unpack x)) - , ("mappend" , - property $ \x y -> B.unpack (mappend x y) === B.unpack x `mappend` B.unpack y) - , ("<>" , - property $ \x y -> B.unpack (x <> y) === B.unpack x <> B.unpack y) - , ("stimes" , - property $ \(Positive n) x -> stimes (n :: Int) (x :: ShortByteString) === mtimesDefault n x) - - , ("break" , - property $ \f x -> (B.unpack *** B.unpack) (B.break f x) === break f (B.unpack x)) - , ("break ==" , - property $ \(toElem -> c) x -> (B.unpack *** B.unpack) (B.break (== c) x) === break (== c) (B.unpack x)) - , ("break /=" , - property $ \(toElem -> c) x -> (B.unpack *** B.unpack) (B.break (/= c) x) === break (/= c) (B.unpack x)) - , ("break span" , - property $ \f x -> B.break f x === B.span (not . f) x) - , ("breakEnd" , - property $ \f x -> B.breakEnd f x === swap ((B.reverse *** B.reverse) (B.break f (B.reverse x)))) - , ("breakEnd" , - property $ \f x -> B.breakEnd f x === B.spanEnd (not . f) x) - , ("break isSpace" , - property $ \x -> (B.unpack *** B.unpack) (B.break isSpace x) === break isSpace (B.unpack x)) - - , ("singleton" , - property $ \(toElem -> c) -> B.unpack (B.singleton c) === [c]) - , ("cons" , - property $ \(toElem -> c) x -> B.unpack (B.cons c x) === c : B.unpack x) - , ("cons []" , - property $ \(toElem -> c) -> B.unpack (B.cons c B.empty) === [c]) - , ("uncons" , - property $ \x -> fmap (second B.unpack) (B.uncons x) === L.uncons (B.unpack x)) - , ("snoc" , - property $ \(toElem -> c) x -> B.unpack (B.snoc x c) === B.unpack x ++ [c]) - , ("snoc []" , - property $ \(toElem -> c) -> B.unpack (B.snoc B.empty c) === [c]) - , ("unsnoc" , - property $ \x -> fmap (first B.unpack) (B.unsnoc x) === unsnoc (B.unpack x)) - - , ("drop" , - property $ \n x -> B.unpack (B.drop n x) === drop (fromIntegral n) (B.unpack x)) - , ("drop 10" , - property $ \x -> B.unpack (B.drop 10 x) === drop 10 (B.unpack x)) - , ("dropWhile" , - property $ \f x -> B.unpack (B.dropWhile f x) === dropWhile f (B.unpack x)) - , ("dropWhile ==" , - property $ \(toElem -> c) x -> B.unpack (B.dropWhile (== c) x) === dropWhile (== c) (B.unpack x)) - , ("dropWhile /=" , - property $ \(toElem -> c) x -> B.unpack (B.dropWhile (/= c) x) === dropWhile (/= c) (B.unpack x)) - , ("dropWhile isSpace" , - property $ \x -> B.unpack (B.dropWhile isSpace x) === dropWhile isSpace (B.unpack x)) - - , ("take" , - property $ \n x -> B.unpack (B.take n x) === take (fromIntegral n) (B.unpack x)) - , ("take 10" , - property $ \x -> B.unpack (B.take 10 x) === take 10 (B.unpack x)) - , ("takeWhile" , - property $ \f x -> B.unpack (B.takeWhile f x) === takeWhile f (B.unpack x)) - , ("takeWhile ==" , - property $ \(toElem -> c) x -> B.unpack (B.takeWhile (== c) x) === takeWhile (== c) (B.unpack x)) - , ("takeWhile /=" , - property $ \(toElem -> c) x -> B.unpack (B.takeWhile (/= c) x) === takeWhile (/= c) (B.unpack x)) - - , ("takeWhile isSpace" , - property $ \x -> B.unpack (B.takeWhile isSpace x) === takeWhile isSpace (B.unpack x)) - - , ("dropEnd" , - property $ \n x -> B.dropEnd n x === B.take (numWord x - n) x) - , ("dropWhileEnd" , - property $ \f x -> B.dropWhileEnd f x === B.reverse (B.dropWhile f (B.reverse x))) - , ("takeEnd" , - property $ \n x -> B.takeEnd n x === B.drop (numWord x - n) x) - , ("takeWhileEnd" , - property $ \f x -> B.takeWhileEnd f x === B.reverse (B.takeWhile f (B.reverse x))) - - , ("length" , - property $ \x -> numWord x === fromIntegral (length (B.unpack x))) - , ("count" , - property $ \(toElem -> c) x -> B.count c x === fromIntegral (length (elemIndices c (B.unpack x)))) - , ("filter" , - property $ \f x -> B.unpack (B.filter f x) === filter f (B.unpack x)) - , ("filter compose" , - property $ \f g x -> B.filter f (B.filter g x) === B.filter (\c -> f c && g c) x) - , ("filter ==" , - property $ \(toElem -> c) x -> B.unpack (B.filter (== c) x) === filter (== c) (B.unpack x)) - , ("filter /=" , - property $ \(toElem -> c) x -> B.unpack (B.filter (/= c) x) === filter (/= c) (B.unpack x)) - , ("partition" , - property $ \f x -> (B.unpack *** B.unpack) (B.partition f x) === partition f (B.unpack x)) - - , ("find" , - property $ \f x -> B.find f x === find f (B.unpack x)) - , ("findIndex" , - property $ \f x -> B.findIndex f x === fmap fromIntegral (findIndex f (B.unpack x))) - , ("findIndices" , - property $ \f x -> B.findIndices f x === fmap fromIntegral (findIndices f (B.unpack x))) - , ("findIndices ==" , - property $ \(toElem -> c) x -> B.findIndices (== c) x === fmap fromIntegral (findIndices (== c) (B.unpack x))) - - , ("elem" , - property $ \(toElem -> c) x -> B.elem c x === elem c (B.unpack x)) - , ("not elem" , - property $ \(toElem -> c) x -> not (B.elem c x) === notElem c (B.unpack x)) - , ("elemIndex" , - property $ \(toElem -> c) x -> B.elemIndex c x === fmap fromIntegral (elemIndex c (B.unpack x))) - , ("elemIndices" , - property $ \(toElem -> c) x -> B.elemIndices c x === fmap fromIntegral (elemIndices c (B.unpack x))) - - - , ("map" , - property $ \f x -> B.unpack (B.map (toElem . f) x) === map (toElem . f) (B.unpack x)) - , ("map compose" , - property $ \f g x -> B.map (toElem . f) (B.map (toElem . g) x) === B.map (toElem . f . toElem . g) x) - , ("replicate" , - property $ \n (toElem -> c) -> B.unpack (B.replicate (fromIntegral n) c) === replicate n c) - , ("replicate 0" , - property $ \(toElem -> c) -> B.unpack (B.replicate 0 c) === replicate 0 c) - - , ("span" , - property $ \f x -> (B.unpack *** B.unpack) (B.span f x) === span f (B.unpack x)) - , ("span ==" , - property $ \(toElem -> c) x -> (B.unpack *** B.unpack) (B.span (== c) x) === span (== c) (B.unpack x)) - , ("span /=" , - property $ \(toElem -> c) x -> (B.unpack *** B.unpack) (B.span (/= c) x) === span (/= c) (B.unpack x)) - , ("spanEnd" , - property $ \f x -> B.spanEnd f x === swap ((B.reverse *** B.reverse) (B.span f (B.reverse x)))) - , ("split" , - property $ \(toElem -> c) x -> map B.unpack (B.split c x) === split c (B.unpack x)) - , ("split empty" , - property $ \(toElem -> c) -> B.split c B.empty === []) - , ("splitWith" , - property $ \f x -> map B.unpack (B.splitWith f x) === splitWith f (B.unpack x)) - , ("splitWith split" , - property $ \(toElem -> c) x -> B.splitWith (== c) x === B.split c x) - , ("splitWith empty" , - property $ \f -> B.splitWith f B.empty === []) - , ("splitWith length" , - property $ \f x -> let splits = B.splitWith f x; l1 = fromIntegral (length splits); l2 = numWord (B.filter f x) in - (l1 == l2 || l1 == l2 + 1) && sum (map numWord splits) + l2 == numWord x) - , ("splitAt" , - property $ \n x -> (B.unpack *** B.unpack) (B.splitAt n x) === splitAt (fromIntegral n) (B.unpack x)) - - , ("head" , - property $ \x -> not (B.null x) ==> B.head x == head (B.unpack x)) - , ("last" , - property $ \x -> not (B.null x) ==> B.last x == last (B.unpack x)) - , ("tail" , - property $ \x -> not (B.null x) ==> B.unpack (B.tail x) == tail (B.unpack x)) - , ("tail length" , - property $ \x -> not (B.null x) ==> numWord x == 1 + numWord (B.tail x)) - , ("init" , - property $ \x -> not (B.null x) ==> B.unpack (B.init x) == init (B.unpack x)) - , ("init length" , - property $ \x -> not (B.null x) ==> numWord x == 1 + numWord (B.init x)) - - , ("foldl" , - property $ \f (toElem -> c) x -> B.foldl ((toElem .) . f) c x === foldl ((toElem .) . f) c (B.unpack x)) - , ("foldl'" , - property $ \f (toElem -> c) x -> B.foldl' ((toElem .) . f) c x === foldl' ((toElem .) . f) c (B.unpack x)) - , ("foldr" , - property $ \f (toElem -> c) x -> B.foldr ((toElem .) . f) c x === foldr ((toElem .) . f) c (B.unpack x)) - , ("foldr'" , - property $ \f (toElem -> c) x -> B.foldr' ((toElem .) . f) c x === foldr' ((toElem .) . f) c (B.unpack x)) - - , ("foldl cons" , - property $ \x -> B.foldl (flip B.cons) B.empty x === B.reverse x) - , ("foldr cons" , - property $ \x -> B.foldr B.cons B.empty x === x) - , ("foldl special" , - property $ \x (toElem -> c) -> B.unpack (B.foldl (\acc t -> if t == c then acc else B.cons t acc) B.empty x) === - foldl (\acc t -> if t == c then acc else t : acc) [] (B.unpack x)) - , ("foldr special" , - property $ \x (toElem -> c) -> B.unpack (B.foldr (\t acc -> if t == c then acc else B.cons t acc) B.empty x) === - foldr (\t acc -> if t == c then acc else t : acc) [] (B.unpack x)) - - , ("foldl1" , - property $ \f x -> not (B.null x) ==> B.foldl1 ((toElem .) . f) x == foldl1 ((toElem .) . f) (B.unpack x)) - , ("foldl1'" , - property $ \f x -> not (B.null x) ==> B.foldl1' ((toElem .) . f) x == foldl1' ((toElem .) . f) (B.unpack x)) - , ("foldr1" , - property $ \f x -> not (B.null x) ==> B.foldr1 ((toElem .) . f) x == foldr1 ((toElem .) . f) (B.unpack x)) - , ("foldr1'", -- there is not Data.List.foldr1' - property $ \f x -> not (B.null x) ==> B.foldr1' ((toElem .) . f) x == foldr1 ((toElem .) . f) (B.unpack x)) - - , ("foldl1 const" , - property $ \x -> not (B.null x) ==> B.foldl1 const x == B.head x) - , ("foldl1 flip const" , - property $ \x -> not (B.null x) ==> B.foldl1 (flip const) x == B.last x) - , ("foldr1 const" , - property $ \x -> not (B.null x) ==> B.foldr1 const x == B.head x) - , ("foldr1 flip const" , - property $ \x -> not (B.null x) ==> B.foldr1 (flip const) x == B.last x) - , ("foldl1 max" , - property $ \x -> not (B.null x) ==> B.foldl1 max x == B.foldl max minBound x) - , ("foldr1 max" , - property $ \x -> not (B.null x) ==> B.foldr1 max x == B.foldr max minBound x) - - , ("index" , - property $ \(NonNegative n) x -> fromIntegral n < numWord x ==> B.index x (fromIntegral n) == B.unpack x !! n) - , ("indexMaybe" , - property $ \(NonNegative n) x -> fromIntegral n < numWord x ==> B.indexMaybe x (fromIntegral n) == Just (B.unpack x !! n)) - , ("indexMaybe Nothing" , - property $ \n x -> (n :: Int) < 0 || fromIntegral n >= numWord x ==> B.indexMaybe x (fromIntegral n) == Nothing) - , ("!?" , - property $ \n x -> B.indexMaybe x (fromIntegral (n :: Int)) === x B.!? (fromIntegral n)) - - , ("unfoldrN" , - property $ \n f (toElem -> c) -> B.unpack (fst (B.unfoldrN n (fmap (first toElem) . f) c)) === - take (fromIntegral n) (unfoldr (fmap (first toElem) . f) c)) - , ("unfoldrN replicate" , - property $ \n (toElem -> c) -> fst (B.unfoldrN n (\t -> Just (t, t)) c) === B.replicate n c) - , ("unfoldr" , - property $ \n a (toElem -> c) -> B.unpack (B.unfoldr (\x -> if x <= 100 * n then Just (c, x + 1 :: Int) else Nothing) a) === - unfoldr (\x -> if x <= 100 * n then Just (c, x + 1) else Nothing) a) - - --, ("unfoldr" , - -- property $ \n f (toElem -> a) -> B.unpack (B.take (fromIntegral n) (B.unfoldr (fmap (first toElem) . f) a)) === - -- take n (unfoldr (fmap (first toElem) . f) a)) - -- -#ifdef WORD16 - , ("useAsCWString str packCWString == str" , - property $ \x -> not (B.any (== _nul) x) - ==> monadicIO $ run (B.useAsCWString x B.packCWString >>= \x' -> pure (x == x'))) - , ("useAsCWStringLen str packCWStringLen == str" , - property $ \x -> not (B.any (== _nul) x) - ==> monadicIO $ run (B.useAsCWStringLen x B.packCWStringLen >>= \x' -> pure (x == x'))) -#else - , ("useAsCString str packCString == str" , - property $ \x -> not (B.any (== _nul) x) - ==> monadicIO $ run (B.useAsCString x B.packCString >>= \x' -> pure (x == x'))) - , ("useAsCStringLen str packCStringLen == str" , - property $ \x -> not (B.any (== _nul) x) - ==> monadicIO $ run (B.useAsCStringLen x B.packCStringLen >>= \x' -> pure (x == x'))) -#endif - ] - -split :: Eq a => a -> [a] -> [[a]] -split c = splitWith (== c) - -splitWith :: (a -> Bool) -> [a] -> [[a]] -splitWith _ [] = [] -splitWith f ys = go [] ys - where - go acc [] = [reverse acc] - go acc (x : xs) - | f x = reverse acc : go [] xs - | otherwise = go (x : acc) xs - -unsnoc :: [a] -> Maybe ([a], a) -unsnoc [] = Nothing -unsnoc xs = Just (init xs, last xs) diff --git a/tests/bytestring-tests/Properties/ShortByteString.hs b/tests/bytestring-tests/Properties/ShortByteString.hs deleted file mode 100644 --- a/tests/bytestring-tests/Properties/ShortByteString.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# LANGUAGE CPP #-} -#undef WORD16 -#include "Common.hs" diff --git a/tests/bytestring-tests/Properties/ShortByteString/Word16.hs b/tests/bytestring-tests/Properties/ShortByteString/Word16.hs deleted file mode 100644 --- a/tests/bytestring-tests/Properties/ShortByteString/Word16.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# LANGUAGE CPP #-} -#define WORD16 -#include "../Common.hs" diff --git a/tests/filepath-equivalent-tests/Gen.hs b/tests/filepath-equivalent-tests/Gen.hs new file mode 100644 --- /dev/null +++ b/tests/filepath-equivalent-tests/Gen.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia, TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DataKinds #-} + +module Gen where + +import System.FilePath +import Data.List.NonEmpty (NonEmpty(..)) +import GHC.Generics +import Generic.Random +import Generics.Deriving.Show +import Prelude as P +import Test.Tasty.QuickCheck hiding ((==>)) + +import qualified Data.List.NonEmpty as NE + + +class AltShow a where + altShow :: a -> String + +instance {-# OVERLAPPABLE #-} Show a => AltShow a where + altShow = show + +instance {-# OVERLAPS #-} AltShow String where + altShow = id + +instance {-# OVERLAPPABLE #-} AltShow a => AltShow (Maybe a) where + altShow Nothing = "" + altShow (Just a) = altShow a + + +newtype WindowsFilePaths = WindowsFilePaths { unWindowsFilePaths :: [WindowsFilePath] } + deriving (Show, Eq, Ord, Generic) + +-- filepath = namespace *"\" namespace-tail +-- / UNC +-- / [ disk ] *"\" relative-path +-- / disk *"\" +data WindowsFilePath = NS NameSpace [Separator] NSTail + | UNC UNCShare + | N (Maybe Char) [Separator] (Maybe RelFilePath) + -- ^ This differs from the grammar, because we allow + -- empty paths + | PotentiallyInvalid FilePath + -- ^ this branch is added purely for the tests + deriving (GShow, Eq, Ord, Generic) + deriving Arbitrary via (GenericArbitraryRec '[6, 2, 2, 1] `AndShrinking` WindowsFilePath) + +instance Show WindowsFilePath where + show wf = gshow wf ++ " (" ++ altShow wf ++ ")" + +instance AltShow WindowsFilePath where + altShow (NS ns seps nstail) = altShow ns ++ altShow seps ++ altShow nstail + altShow (UNC unc) = altShow unc + altShow (N mdisk seps mfrp) = maybe [] (:[]) mdisk ++ (altShow seps ++ altShow mfrp) + altShow (PotentiallyInvalid fp) = fp + + +-- namespace-tail = ( disk 1*"\" relative-path ; C:foo\bar is not valid +-- ; namespaced paths are all absolute +-- / disk *"\" +-- / relative-path +-- ) +data NSTail = NST1 Char (NonEmpty Separator) RelFilePath + | NST2 Char [Separator] + | NST3 RelFilePath + deriving (GShow, Show, Eq, Ord, Generic) + deriving Arbitrary via (GenericArbitraryRec '[1, 1, 1] `AndShrinking` NSTail) + +instance AltShow NSTail where + altShow (NST1 disk seps relfp) = disk:':':(altShow seps ++ altShow relfp) + altShow (NST2 disk seps) = disk:':':altShow seps + altShow (NST3 relfp) = altShow relfp + + +-- UNC = "\\" 1*pchar "\" 1*pchar [ 1*"\" [ relative-path ] ] +data UNCShare = UNCShare Separator Separator + NonEmptyString + (NonEmpty Separator) + NonEmptyString + (Maybe (NonEmpty Separator, Maybe RelFilePath)) + deriving (GShow, Show, Eq, Ord, Generic) + deriving Arbitrary via (GenericArbitraryRec '[1] `AndShrinking` UNCShare) + +instance AltShow UNCShare where + altShow (UNCShare sep1 sep2 fp1 seps fp2 mrfp) = altShow sep1 ++ altShow sep2 ++ altShow fp1 ++ altShow seps ++ altShow fp2 ++ maybe "" (\(a, b) -> altShow a ++ maybe "" altShow b) mrfp + +newtype NonEmptyString = NonEmptyString (NonEmpty Char) + deriving (GShow, Show, Eq, Ord, Generic) + deriving Arbitrary via (GenericArbitraryRec '[1] `AndShrinking` NonEmptyString) + +instance Semigroup NonEmptyString where + (<>) (NonEmptyString ne) (NonEmptyString ne') = NonEmptyString (ne <> ne') + +instance AltShow NonEmptyString where + altShow (NonEmptyString ns) = NE.toList ns + + +-- | Windows API Namespaces +-- +-- https://docs.microsoft.com/en-us/windows/win32/fileio/naming-a-file#namespaces +-- https://support.microsoft.com/en-us/topic/70b92942-a643-2f2d-2ac6-aad8acad49fb +-- https://superuser.com/a/1096784/854039 +-- https://reverseengineering.stackexchange.com/a/15178 +-- https://stackoverflow.com/a/25099634 +-- +-- namespace = file-namespace / device-namespace / nt-namespace +-- file-namespace = "\" "\" "?" "\" +-- device-namespace = "\" "\" "." "\" +-- nt-namespace = "\" "?" "?" "\" +data NameSpace = FileNameSpace + | DeviceNameSpace + | NTNameSpace + deriving (GShow, Show, Eq, Ord, Generic) + deriving Arbitrary via (GenericArbitraryRec '[3, 1, 1] `AndShrinking` NameSpace) + +instance AltShow NameSpace where + altShow FileNameSpace = "\\\\?\\" + altShow DeviceNameSpace = "\\\\.\\" + altShow NTNameSpace = "\\??\\" + + +data Separator = UnixSep + | WindowsSep + deriving (GShow, Show, Eq, Ord, Generic) + deriving Arbitrary via (GenericArbitraryRec '[1, 1] `AndShrinking` Separator) + +instance AltShow Separator where + altShow UnixSep = "/" + altShow WindowsSep = "\\" + +instance {-# OVERLAPS #-} AltShow (NonEmpty Separator) where + altShow ne = mconcat $ NE.toList (altShow <$> ne) + +instance {-# OVERLAPS #-} AltShow [Separator] where + altShow [] = "" + altShow ne = altShow (NE.fromList ne) + +-- relative-path = 1*(path-name 1*"\") [ file-name ] / file-name +data RelFilePath = Rel1 (NonEmpty (NonEmptyString, NonEmpty Separator)) (Maybe FileName) + | Rel2 FileName + deriving (GShow, Show, Eq, Ord, Generic) + deriving Arbitrary via (GenericArbitraryRec '[2, 1] `AndShrinking` RelFilePath) + +instance AltShow RelFilePath where + altShow (Rel1 ns mf) = mconcat (NE.toList $ fmap (\(a, b) -> altShow a ++ altShow b) ns) ++ altShow mf + altShow (Rel2 fn) = altShow fn + +-- file-name = 1*pchar [ stream ] +data FileName = FileName NonEmptyString (Maybe DataStream) + deriving (GShow, Show, Eq, Ord, Generic) + +instance Arbitrary FileName where + -- make sure that half of the filenames include a dot '.' + -- so that we can deal with extensions + arbitrary = do + ns <- arbitrary + ds <- arbitrary + i <- chooseInt (0, 100) + if i >= 50 + then do + ns' <- arbitrary + pure $ FileName (ns <> NonEmptyString ('.':|[]) <> ns') ds + else pure $ FileName ns ds + shrink = genericShrink + + +instance Arbitrary (Maybe DataStream) where + arbitrary = genericArbitraryRec (1 % 1 % ()) + shrink = genericShrink + +instance AltShow FileName where + altShow (FileName ns ds) = altShow ns ++ altShow ds + +-- stream = ":" 1*schar [ ":" 1*schar ] / ":" ":" 1*schar +data DataStream = DS1 NonEmptyString (Maybe NonEmptyString) + | DS2 NonEmptyString -- ::datatype + deriving (GShow, Show, Eq, Ord, Generic) + deriving Arbitrary via (GenericArbitraryRec '[1, 1] `AndShrinking` DataStream) + +instance AltShow DataStream where + altShow (DS1 ns Nothing) = ":" ++ altShow ns + altShow (DS1 ns (Just ns2)) = ":" ++ altShow ns ++ ":" ++ altShow ns2 + altShow (DS2 ns) = "::" ++ altShow ns + +instance Arbitrary WindowsFilePaths where + arbitrary = WindowsFilePaths <$> listOf' arbitrary + shrink = genericShrink + +instance Arbitrary [Separator] where + arbitrary = listOf' arbitrary + shrink = genericShrink + +#if !MIN_VERSION_QuickCheck(2,17,0) +instance Arbitrary a => Arbitrary (NonEmpty a) where + arbitrary = NE.fromList <$> listOf1' arbitrary + shrink = genericShrink +#endif diff --git a/tests/filepath-equivalent-tests/TestEquiv.hs b/tests/filepath-equivalent-tests/TestEquiv.hs --- a/tests/filepath-equivalent-tests/TestEquiv.hs +++ b/tests/filepath-equivalent-tests/TestEquiv.hs @@ -1,434 +1,433 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeApplications #-} module Main where -import Test.QuickCheck hiding ((==>)) +import Test.Tasty +import Test.Tasty.QuickCheck hiding ((==>)) import TestUtil import Prelude as P +import Data.Char (isAsciiLower, isAsciiUpper) +import Gen import qualified System.FilePath.Windows as W import qualified System.FilePath.Posix as P import qualified Legacy.System.FilePath.Windows as LW import qualified Legacy.System.FilePath.Posix as LP -import Data.Char (isAsciiLower, isAsciiUpper) main :: IO () -main = runTests equivalentTests +main = defaultMain equivalentTests -equivalentTests :: [(String, Property)] -equivalentTests = - [ - ( "pathSeparator (windows)" - , property $ W.pathSeparator == LW.pathSeparator - ) - , - ( "pathSeparators (windows)" - , property $ W.pathSeparators == LW.pathSeparators - ) - , - ( "isPathSeparator (windows)" - , property $ \p -> W.isPathSeparator p == LW.isPathSeparator p - ) - , - ( "searchPathSeparator (windows)" - , property $ W.searchPathSeparator == LW.searchPathSeparator - ) - , - ( "isSearchPathSeparator (windows)" - , property $ \p -> W.isSearchPathSeparator p == LW.isSearchPathSeparator p - ) - , - ( "extSeparator (windows)" - , property $ W.extSeparator == LW.extSeparator - ) - , - ( "isExtSeparator (windows)" - , property $ \p -> W.isExtSeparator p == LW.isExtSeparator p - ) - , - ( "splitSearchPath (windows)" - , property $ \p -> W.splitSearchPath p == LW.splitSearchPath p - ) - , - ( "splitExtension (windows)" - , property $ \p -> W.splitExtension p == LW.splitExtension p - ) - , - ( "takeExtension (windows)" - , property $ \p -> W.takeExtension p == LW.takeExtension p - ) - , - ( "replaceExtension (windows)" - , property $ \p s -> W.replaceExtension p s == LW.replaceExtension p s - ) - , - ( "dropExtension (windows)" - , property $ \p -> W.dropExtension p == LW.dropExtension p - ) - , - ( "addExtension (windows)" - , property $ \p s -> W.addExtension p s == LW.addExtension p s - ) - , - ( "hasExtension (windows)" - , property $ \p -> W.hasExtension p == LW.hasExtension p - ) - , - ( "splitExtensions (windows)" - , property $ \p -> W.splitExtensions p == LW.splitExtensions p - ) - , - ( "dropExtensions (windows)" - , property $ \p -> W.dropExtensions p == LW.dropExtensions p - ) - , - ( "takeExtensions (windows)" - , property $ \p -> W.takeExtensions p == LW.takeExtensions p - ) - , - ( "replaceExtensions (windows)" - , property $ \p s -> W.replaceExtensions p s == LW.replaceExtensions p s - ) - , - ( "isExtensionOf (windows)" - , property $ \p s -> W.isExtensionOf p s == LW.isExtensionOf p s - ) - , - ( "stripExtension (windows)" - , property $ \p s -> W.stripExtension p s == LW.stripExtension p s - ) - , - ( "splitFileName (windows)" - , property $ \p -> W.splitFileName p == LW.splitFileName p - ) - , - ( "takeFileName (windows)" - , property $ \p -> W.takeFileName p == LW.takeFileName p - ) - , - ( "replaceFileName (windows)" - , property $ \p s -> W.replaceFileName p s == LW.replaceFileName p s - ) - , - ( "dropFileName (windows)" - , property $ \p -> W.dropFileName p == LW.dropFileName p - ) - , - ( "takeBaseName (windows)" - , property $ \p -> W.takeBaseName p == LW.takeBaseName p - ) - , - ( "replaceBaseName (windows)" - , property $ \p s -> W.replaceBaseName p s == LW.replaceBaseName p s - ) - , - ( "takeDirectory (windows)" - , property $ \p -> W.takeDirectory p == LW.takeDirectory p - ) - , - ( "replaceDirectory (windows)" - , property $ \p s -> W.replaceDirectory p s == LW.replaceDirectory p s - ) - , - ( "combine (windows)" - , property $ \p s -> W.combine p s == LW.combine p s - ) - , - ( "splitPath (windows)" - , property $ \p -> W.splitPath p == LW.splitPath p - ) - , - ( "joinPath (windows)" - , property $ \p -> W.joinPath p == LW.joinPath p - ) - , - ( "splitDirectories (windows)" - , property $ \p -> W.splitDirectories p == LW.splitDirectories p - ) - , - ( "splitDirectories (windows)" - , property $ \p -> W.splitDirectories p == LW.splitDirectories p - ) - , - ( "splitDrive (windows)" - , property $ \p -> W.splitDrive p == LW.splitDrive p - ) - , - ( "joinDrive (windows)" - , property $ \p s -> W.joinDrive p s == LW.joinDrive p s - ) - , - ( "takeDrive (windows)" - , property $ \p -> W.takeDrive p == LW.takeDrive p - ) - , - ( "hasDrive (windows)" - , property $ \p -> W.hasDrive p == LW.hasDrive p - ) - , - ( "dropDrive (windows)" - , property $ \p -> W.dropDrive p == LW.dropDrive p - ) - , - ( "isDrive (windows)" - , property $ \p -> W.isDrive p == LW.isDrive p - ) - , - ( "hasTrailingPathSeparator (windows)" - , property $ \p -> W.hasTrailingPathSeparator p == LW.hasTrailingPathSeparator p - ) - , - ( "addTrailingPathSeparator (windows)" - , property $ \p -> W.addTrailingPathSeparator p == LW.addTrailingPathSeparator p - ) - , - ( "dropTrailingPathSeparator (windows)" - , property $ \p -> W.dropTrailingPathSeparator p == LW.dropTrailingPathSeparator p - ) - , - ( "normalise (windows)" - , property $ \p -> case p of - (l:':':rs) - -- new filepath normalises "a:////////" to "A:\\" - -- see https://github.com/haskell/filepath/commit/cb4890aa03a5ee61f16f7a08dd2d964fffffb385 - | isAsciiLower l || isAsciiUpper l - , let (seps, path) = span LW.isPathSeparator rs - , length seps > 1 -> let np = l : ':' : LW.pathSeparator : path in W.normalise np == LW.normalise np - _ -> W.normalise p == LW.normalise p - ) - , - ( "equalFilePath (windows)" - , property $ \p s -> W.equalFilePath p s == LW.equalFilePath p s - ) - , - ( "makeRelative (windows)" - , property $ \p s -> W.makeRelative p s == LW.makeRelative p s - ) - , - ( "isRelative (windows)" - , property $ \p -> W.isRelative p == LW.isRelative p - ) - , - ( "isAbsolute (windows)" - , property $ \p -> W.isAbsolute p == LW.isAbsolute p - ) - , - ( "isValid (windows)" - , property $ \p -> W.isValid p == LW.isValid p - ) - , - ( "makeValid (windows)" - , property $ \p -> W.makeValid p == LW.makeValid p - ) - , - ( "pathSeparator (posix)" - , property $ P.pathSeparator == LP.pathSeparator - ) - , - ( "pathSeparators (posix)" - , property $ P.pathSeparators == LP.pathSeparators - ) - , - ( "isPathSeparator (posix)" - , property $ \p -> P.isPathSeparator p == LP.isPathSeparator p - ) - , - ( "searchPathSeparator (posix)" - , property $ P.searchPathSeparator == LP.searchPathSeparator - ) - , - ( "isSearchPathSeparator (posix)" - , property $ \p -> P.isSearchPathSeparator p == LP.isSearchPathSeparator p - ) - , - ( "extSeparator (posix)" - , property $ P.extSeparator == LP.extSeparator - ) - , - ( "isExtSeparator (posix)" - , property $ \p -> P.isExtSeparator p == LP.isExtSeparator p - ) - , - ( "splitSearchPath (posix)" - , property $ \p -> P.splitSearchPath p == LP.splitSearchPath p - ) - , - ( "splitExtension (posix)" - , property $ \p -> P.splitExtension p == LP.splitExtension p - ) - , - ( "takeExtension (posix)" - , property $ \p -> P.takeExtension p == LP.takeExtension p - ) - , - ( "replaceExtension (posix)" - , property $ \p s -> P.replaceExtension p s == LP.replaceExtension p s - ) - , - ( "dropExtension (posix)" - , property $ \p -> P.dropExtension p == LP.dropExtension p - ) - , - ( "addExtension (posix)" - , property $ \p s -> P.addExtension p s == LP.addExtension p s - ) - , - ( "hasExtension (posix)" - , property $ \p -> P.hasExtension p == LP.hasExtension p - ) - , - ( "splitExtensions (posix)" - , property $ \p -> P.splitExtensions p == LP.splitExtensions p - ) - , - ( "dropExtensions (posix)" - , property $ \p -> P.dropExtensions p == LP.dropExtensions p - ) - , - ( "takeExtensions (posix)" - , property $ \p -> P.takeExtensions p == LP.takeExtensions p - ) - , - ( "replaceExtensions (posix)" - , property $ \p s -> P.replaceExtensions p s == LP.replaceExtensions p s - ) - , - ( "isExtensionOf (posix)" - , property $ \p s -> P.isExtensionOf p s == LP.isExtensionOf p s - ) - , - ( "stripExtension (posix)" - , property $ \p s -> P.stripExtension p s == LP.stripExtension p s - ) - , - ( "splitFileName (posix)" - , property $ \p -> P.splitFileName p == LP.splitFileName p - ) - , - ( "takeFileName (posix)" - , property $ \p -> P.takeFileName p == LP.takeFileName p - ) - , - ( "replaceFileName (posix)" - , property $ \p s -> P.replaceFileName p s == LP.replaceFileName p s - ) - , - ( "dropFileName (posix)" - , property $ \p -> P.dropFileName p == LP.dropFileName p - ) - , - ( "takeBaseName (posix)" - , property $ \p -> P.takeBaseName p == LP.takeBaseName p - ) - , - ( "replaceBaseName (posix)" - , property $ \p s -> P.replaceBaseName p s == LP.replaceBaseName p s - ) - , - ( "takeDirectory (posix)" - , property $ \p -> P.takeDirectory p == LP.takeDirectory p - ) - , - ( "replaceDirectory (posix)" - , property $ \p s -> P.replaceDirectory p s == LP.replaceDirectory p s - ) - , - ( "combine (posix)" - , property $ \p s -> P.combine p s == LP.combine p s - ) - , - ( "splitPath (posix)" - , property $ \p -> P.splitPath p == LP.splitPath p - ) - , - ( "joinPath (posix)" - , property $ \p -> P.joinPath p == LP.joinPath p - ) - , - ( "splitDirectories (posix)" - , property $ \p -> P.splitDirectories p == LP.splitDirectories p - ) - , - ( "splitDirectories (posix)" - , property $ \p -> P.splitDirectories p == LP.splitDirectories p - ) - , - ( "splitDrive (posix)" - , property $ \p -> P.splitDrive p == LP.splitDrive p - ) - , - ( "joinDrive (posix)" - , property $ \p s -> P.joinDrive p s == LP.joinDrive p s - ) - , - ( "takeDrive (posix)" - , property $ \p -> P.takeDrive p == LP.takeDrive p - ) - , - ( "hasDrive (posix)" - , property $ \p -> P.hasDrive p == LP.hasDrive p - ) - , - ( "dropDrive (posix)" - , property $ \p -> P.dropDrive p == LP.dropDrive p - ) - , - ( "isDrive (posix)" - , property $ \p -> P.isDrive p == LP.isDrive p - ) - , - ( "hasTrailingPathSeparator (posix)" - , property $ \p -> P.hasTrailingPathSeparator p == LP.hasTrailingPathSeparator p - ) - , - ( "addTrailingPathSeparator (posix)" - , property $ \p -> P.addTrailingPathSeparator p == LP.addTrailingPathSeparator p - ) - , - ( "dropTrailingPathSeparator (posix)" - , property $ \p -> P.dropTrailingPathSeparator p == LP.dropTrailingPathSeparator p - ) - , - ( "normalise (posix)" - , property $ \p -> P.normalise p == LP.normalise p - ) - , - ( "equalFilePath (posix)" - , property $ \p s -> P.equalFilePath p s == LP.equalFilePath p s - ) - , - ( "makeRelative (posix)" - , property $ \p s -> P.makeRelative p s == LP.makeRelative p s - ) - , - ( "isRelative (posix)" - , property $ \p -> P.isRelative p == LP.isRelative p - ) - , - ( "isAbsolute (posix)" - , property $ \p -> P.isAbsolute p == LP.isAbsolute p - ) - , - ( "isValid (posix)" - , property $ \p -> P.isValid p == LP.isValid p - ) - , - ( "makeValid (posix)" - , property $ \p -> P.makeValid p == LP.makeValid p - ) +equivalentTests :: TestTree +equivalentTests = testGroup "equivalence" + [ testProperties "windows" + [ + ( "pathSeparator" + , property $ W.pathSeparator == LW.pathSeparator + ) + , + ( "pathSeparators" + , property $ W.pathSeparators == LW.pathSeparators + ) + , + ( "isPathSeparator" + , property $ \p -> W.isPathSeparator p == LW.isPathSeparator p + ) + , + ( "searchPathSeparator" + , property $ W.searchPathSeparator == LW.searchPathSeparator + ) + , + ( "isSearchPathSeparator" + , property $ \p -> W.isSearchPathSeparator p == LW.isSearchPathSeparator p + ) + , + ( "extSeparator" + , property $ W.extSeparator == LW.extSeparator + ) + , + ( "isExtSeparator" + , property $ \p -> W.isExtSeparator p == LW.isExtSeparator p + ) + , + ( "splitSearchPath" + , property $ \(xs :: WindowsFilePaths) + -> let p = (intercalate ";" (altShow <$> unWindowsFilePaths xs)) + in W.splitSearchPath p == LW.splitSearchPath p + ) + , + ( "splitExtension" + , property $ \(altShow @WindowsFilePath -> p) -> W.splitExtension p == LW.splitExtension p + ) + , + ( "takeExtension" + , property $ \(altShow @WindowsFilePath -> p) -> W.takeExtension p == LW.takeExtension p + ) + , + ( "replaceExtension" + , property $ \(altShow @WindowsFilePath -> p) s -> W.replaceExtension p s == LW.replaceExtension p s + ) + , + ( "dropExtension" + , property $ \(altShow @WindowsFilePath -> p) -> W.dropExtension p == LW.dropExtension p + ) + , + ( "addExtension" + , property $ \(altShow @WindowsFilePath -> p) s -> W.addExtension p s == LW.addExtension p s + ) + , + ( "hasExtension" + , property $ \(altShow @WindowsFilePath -> p) -> W.hasExtension p == LW.hasExtension p + ) + , + ( "splitExtensions" + , property $ \(altShow @WindowsFilePath -> p) -> W.splitExtensions p == LW.splitExtensions p + ) + , + ( "dropExtensions" + , property $ \(altShow @WindowsFilePath -> p) -> W.dropExtensions p == LW.dropExtensions p + ) + , + ( "takeExtensions" + , property $ \p -> W.takeExtensions p == LW.takeExtensions p + ) + , + ( "replaceExtensions" + , property $ \(altShow @WindowsFilePath -> p) s -> W.replaceExtensions p s == LW.replaceExtensions p s + ) + , + ( "isExtensionOf" + , property $ \(altShow @WindowsFilePath -> p) s -> W.isExtensionOf p s == LW.isExtensionOf p s + ) + , + ( "stripExtension" + , property $ \(altShow @WindowsFilePath -> p) s -> W.stripExtension p s == LW.stripExtension p s + ) + , + ( "splitFileName" + , property $ \(altShow @WindowsFilePath -> p) -> W.splitFileName p == LW.splitFileName p + ) + , + ( "takeFileName" + , property $ \(altShow @WindowsFilePath -> p) -> W.takeFileName p == LW.takeFileName p + ) + , + ( "replaceFileName" + , property $ \(altShow @WindowsFilePath -> p) s -> W.replaceFileName p s == LW.replaceFileName p s + ) + , + ( "dropFileName" + , property $ \(altShow @WindowsFilePath -> p) -> W.dropFileName p == LW.dropFileName p + ) + , + ( "takeBaseName" + , property $ \(altShow @WindowsFilePath -> p) -> W.takeBaseName p == LW.takeBaseName p + ) + , + ( "replaceBaseName" + , property $ \(altShow @WindowsFilePath -> p) s -> W.replaceBaseName p s == LW.replaceBaseName p s + ) + , + ( "takeDirectory" + , property $ \(altShow @WindowsFilePath -> p) -> W.takeDirectory p == LW.takeDirectory p + ) + , + ( "replaceDirectory" + , property $ \(altShow @WindowsFilePath -> p) s -> W.replaceDirectory p s == LW.replaceDirectory p s + ) + , + ( "combine" + , property $ \(altShow @WindowsFilePath -> p) s -> W.combine p s == LW.combine p s + ) + , + ( "splitPath" + , property $ \(altShow @WindowsFilePath -> p) -> W.splitPath p == LW.splitPath p + ) + , + ( "joinPath" + , property $ \(xs :: WindowsFilePaths) -> + let p = altShow <$> unWindowsFilePaths xs + in W.joinPath p == LW.joinPath p + ) + , + ( "splitDirectories" + , property $ \(altShow @WindowsFilePath -> p) -> W.splitDirectories p == LW.splitDirectories p + ) + , + ( "splitDrive" + , property $ \(altShow @WindowsFilePath -> p) -> W.splitDrive p == LW.splitDrive p + ) + , + ( "joinDrive" + , property $ \(altShow @WindowsFilePath -> p) s -> W.joinDrive p s == LW.joinDrive p s + ) + , + ( "takeDrive" + , property $ \(altShow @WindowsFilePath -> p) -> W.takeDrive p == LW.takeDrive p + ) + , + ( "hasDrive" + , property $ \(altShow @WindowsFilePath -> p) -> W.hasDrive p == LW.hasDrive p + ) + , + ( "dropDrive" + , property $ \(altShow @WindowsFilePath -> p) -> W.dropDrive p == LW.dropDrive p + ) + , + ( "isDrive" + , property $ \(altShow @WindowsFilePath -> p) -> W.isDrive p == LW.isDrive p + ) + , + ( "hasTrailingPathSeparator" + , property $ \(altShow @WindowsFilePath -> p) -> W.hasTrailingPathSeparator p == LW.hasTrailingPathSeparator p + ) + , + ( "addTrailingPathSeparator" + , property $ \(altShow @WindowsFilePath -> p) -> W.addTrailingPathSeparator p == LW.addTrailingPathSeparator p + ) + , + ( "dropTrailingPathSeparator" + , property $ \(altShow @WindowsFilePath -> p) -> W.dropTrailingPathSeparator p == LW.dropTrailingPathSeparator p + ) + , + ( "normalise" + , property $ \(altShow @WindowsFilePath -> p) -> case p of + (l:':':rs) + -- new filepath normalises "a:////////" to "A:\\" + -- see https://github.com/haskell/filepath/commit/cb4890aa03a5ee61f16f7a08dd2d964fffffb385 + | isAsciiLower l || isAsciiUpper l + , let (seps, path) = span LW.isPathSeparator rs + , length seps > 1 -> let np = l : ':' : LW.pathSeparator : path in W.normalise np == LW.normalise np + _ -> W.normalise p == LW.normalise p + ) + , + ( "equalFilePath" + , property $ \p s -> W.equalFilePath p s == LW.equalFilePath p s + ) + , + ( "makeRelative" + , property $ \p s -> W.makeRelative p s == LW.makeRelative p s + ) + , + ( "isRelative" + , property $ \p -> W.isRelative p == LW.isRelative p + ) + , + ( "isAbsolute" + , property $ \p -> W.isAbsolute p == LW.isAbsolute p + ) + , + ( "isValid" + , property $ \p -> W.isValid p == LW.isValid p + ) + , + ( "makeValid" + , property $ \p -> W.makeValid p == LW.makeValid p + ) + ], + testProperties "posix" $ [ + ( "pathSeparator" + , property $ P.pathSeparator == LP.pathSeparator + ) + , + ( "pathSeparators" + , property $ P.pathSeparators == LP.pathSeparators + ) + , + ( "isPathSeparator" + , property $ \p -> P.isPathSeparator p == LP.isPathSeparator p + ) + , + ( "searchPathSeparator" + , property $ P.searchPathSeparator == LP.searchPathSeparator + ) + , + ( "isSearchPathSeparator" + , property $ \p -> P.isSearchPathSeparator p == LP.isSearchPathSeparator p + ) + , + ( "extSeparator" + , property $ P.extSeparator == LP.extSeparator + ) + , + ( "isExtSeparator" + , property $ \p -> P.isExtSeparator p == LP.isExtSeparator p + ) + , + ( "splitSearchPath" + , property $ \p -> P.splitSearchPath p == LP.splitSearchPath p + ) + , + ( "splitExtension" + , property $ \p -> P.splitExtension p == LP.splitExtension p + ) + , + ( "takeExtension" + , property $ \p -> P.takeExtension p == LP.takeExtension p + ) + , + ( "replaceExtension" + , property $ \p s -> P.replaceExtension p s == LP.replaceExtension p s + ) + , + ( "dropExtension" + , property $ \p -> P.dropExtension p == LP.dropExtension p + ) + , + ( "addExtension" + , property $ \p s -> P.addExtension p s == LP.addExtension p s + ) + , + ( "hasExtension" + , property $ \p -> P.hasExtension p == LP.hasExtension p + ) + , + ( "splitExtensions" + , property $ \p -> P.splitExtensions p == LP.splitExtensions p + ) + , + ( "dropExtensions" + , property $ \p -> P.dropExtensions p == LP.dropExtensions p + ) + , + ( "takeExtensions" + , property $ \p -> P.takeExtensions p == LP.takeExtensions p + ) + , + ( "replaceExtensions" + , property $ \p s -> P.replaceExtensions p s == LP.replaceExtensions p s + ) + , + ( "isExtensionOf" + , property $ \p s -> P.isExtensionOf p s == LP.isExtensionOf p s + ) + , + ( "stripExtension" + , property $ \p s -> P.stripExtension p s == LP.stripExtension p s + ) + , + ( "splitFileName" + , property $ \p -> P.splitFileName p == LP.splitFileName p + ) + , + ( "takeFileName" + , property $ \p -> P.takeFileName p == LP.takeFileName p + ) + , + ( "replaceFileName" + , property $ \p s -> P.replaceFileName p s == LP.replaceFileName p s + ) + , + ( "dropFileName" + , property $ \p -> P.dropFileName p == LP.dropFileName p + ) + , + ( "takeBaseName" + , property $ \p -> P.takeBaseName p == LP.takeBaseName p + ) + , + ( "replaceBaseName" + , property $ \p s -> P.replaceBaseName p s == LP.replaceBaseName p s + ) + , + ( "takeDirectory" + , property $ \p -> P.takeDirectory p == LP.takeDirectory p + ) + , + ( "replaceDirectory" + , property $ \p s -> P.replaceDirectory p s == LP.replaceDirectory p s + ) + , + ( "combine" + , property $ \p s -> P.combine p s == LP.combine p s + ) + , + ( "splitPath" + , property $ \p -> P.splitPath p == LP.splitPath p + ) + , + ( "joinPath" + , property $ \p -> P.joinPath p == LP.joinPath p + ) + , + ( "splitDirectories" + , property $ \p -> P.splitDirectories p == LP.splitDirectories p + ) + , + ( "splitDirectories" + , property $ \p -> P.splitDirectories p == LP.splitDirectories p + ) + , + ( "splitDrive" + , property $ \p -> P.splitDrive p == LP.splitDrive p + ) + , + ( "joinDrive" + , property $ \p s -> P.joinDrive p s == LP.joinDrive p s + ) + , + ( "takeDrive" + , property $ \p -> P.takeDrive p == LP.takeDrive p + ) + , + ( "hasDrive" + , property $ \p -> P.hasDrive p == LP.hasDrive p + ) + , + ( "dropDrive" + , property $ \p -> P.dropDrive p == LP.dropDrive p + ) + , + ( "isDrive" + , property $ \p -> P.isDrive p == LP.isDrive p + ) + , + ( "hasTrailingPathSeparator" + , property $ \p -> P.hasTrailingPathSeparator p == LP.hasTrailingPathSeparator p + ) + , + ( "addTrailingPathSeparator" + , property $ \p -> P.addTrailingPathSeparator p == LP.addTrailingPathSeparator p + ) + , + ( "dropTrailingPathSeparator" + , property $ \p -> P.dropTrailingPathSeparator p == LP.dropTrailingPathSeparator p + ) + , + ( "normalise" + , property $ \p -> P.normalise p == LP.normalise p + ) + , + ( "equalFilePath" + , property $ \p s -> P.equalFilePath p s == LP.equalFilePath p s + ) + , + ( "makeRelative" + , property $ \p s -> P.makeRelative p s == LP.makeRelative p s + ) + , + ( "isRelative" + , property $ \p -> P.isRelative p == LP.isRelative p + ) + , + ( "isAbsolute" + , property $ \p -> P.isAbsolute p == LP.isAbsolute p + ) + , + ( "isValid" + , property $ \p -> P.isValid p == LP.isValid p + ) + , + ( "makeValid" + , property $ \p -> P.makeValid p == LP.makeValid p + ) + ] ] - - - - - - - - - - - - diff --git a/tests/filepath-tests/Test.hs b/tests/filepath-tests/Test.hs --- a/tests/filepath-tests/Test.hs +++ b/tests/filepath-tests/Test.hs @@ -1,39 +1,9 @@ -{-# LANGUAGE TypeApplications #-} - module Main where -import System.Environment -import TestGen -import Control.Monad -import Data.Maybe -import Test.QuickCheck - +import TestGen (tests) +import Test.Tasty +import Test.Tasty.QuickCheck main :: IO () -main = do - args <- getArgs - let count = case args of i:_ -> read i; _ -> 10000 - let testNum = case args of - _:i:_ - | let num = read i - , num < 0 -> drop (negate num) tests - | let num = read i - , num > 0 -> take num tests - | otherwise -> [] - _ -> tests - putStrLn $ "Testing with " ++ show count ++ " repetitions" - let total' = length testNum - let showOutput x = show x{output=""} ++ "\n" ++ output x - bad <- fmap catMaybes $ forM (zip @Integer [1..] testNum) $ \(i,(msg,prop)) -> do - putStrLn $ "Test " ++ show i ++ " of " ++ show total' ++ ": " ++ msg - res <- quickCheckWithResult stdArgs{chatty=False, maxSuccess=count} prop - case res of - Success{} -> pure Nothing - bad -> do putStrLn $ showOutput bad; putStrLn "TEST FAILURE!"; pure $ Just (msg,bad) - if null bad then - putStrLn $ "Success, " ++ show total' ++ " tests passed" - else do - putStrLn $ show (length bad) ++ " FAILURES\n" - forM_ (zip @Integer [1..] bad) $ \(i,(a,b)) -> - putStrLn $ "FAILURE " ++ show i ++ ": " ++ a ++ "\n" ++ showOutput b ++ "\n" - fail $ "FAILURE, failed " ++ show (length bad) ++ " of " ++ show total' ++ " tests" +main = defaultMain $ testProperties "doctests" tests + diff --git a/tests/filepath-tests/TestGen.hs b/tests/filepath-tests/TestGen.hs --- a/tests/filepath-tests/TestGen.hs +++ b/tests/filepath-tests/TestGen.hs @@ -15,10 +15,10 @@ import GHC.IO.Encoding.UTF16 ( mkUTF16le ) import GHC.IO.Encoding.UTF8 ( mkUTF8 ) import System.OsString.Internal.Types -import System.OsPath.Encoding.Internal +import System.OsString.Encoding.Internal import qualified Data.Char as C -import qualified System.OsPath.Data.ByteString.Short as SBS -import qualified System.OsPath.Data.ByteString.Short.Word16 as SBS16 +import qualified System.OsString.Data.ByteString.Short as SBS +import qualified System.OsString.Data.ByteString.Short.Word16 as SBS16 import qualified System.FilePath.Windows as W import qualified System.FilePath.Posix as P import qualified System.OsPath.Windows as AFP_W @@ -312,10 +312,6 @@ ,("uncurry W.addExtension (W.splitExtensions x) == x", property $ \(QFilePathValidW x) -> uncurry W.addExtension (W.splitExtensions x) == x) ,("uncurry AFP_P.addExtension (AFP_P.splitExtensions x) == x", property $ \(QFilePathValidAFP_P x) -> uncurry AFP_P.addExtension (AFP_P.splitExtensions x) == x) ,("uncurry AFP_W.addExtension (AFP_W.splitExtensions x) == x", property $ \(QFilePathValidAFP_W x) -> uncurry AFP_W.addExtension (AFP_W.splitExtensions x) == x) - ,("P.splitExtensions \"file.tar.gz\" == (\"file\", \".tar.gz\")", property $ P.splitExtensions "file.tar.gz" == ("file", ".tar.gz")) - ,("W.splitExtensions \"file.tar.gz\" == (\"file\", \".tar.gz\")", property $ W.splitExtensions "file.tar.gz" == ("file", ".tar.gz")) - ,("AFP_P.splitExtensions (\"file.tar.gz\") == ((\"file\"), (\".tar.gz\"))", property $ AFP_P.splitExtensions ("file.tar.gz") == (("file"), (".tar.gz"))) - ,("AFP_W.splitExtensions (\"file.tar.gz\") == ((\"file\"), (\".tar.gz\"))", property $ AFP_W.splitExtensions ("file.tar.gz") == (("file"), (".tar.gz"))) ,("P.dropExtensions \"/directory/path.ext\" == \"/directory/path\"", property $ P.dropExtensions "/directory/path.ext" == "/directory/path") ,("W.dropExtensions \"/directory/path.ext\" == \"/directory/path\"", property $ W.dropExtensions "/directory/path.ext" == "/directory/path") ,("AFP_P.dropExtensions (\"/directory/path.ext\") == (\"/directory/path\")", property $ AFP_P.dropExtensions ("/directory/path.ext") == ("/directory/path")) @@ -476,6 +472,10 @@ ,("W.dropFileName x == fst (W.splitFileName x)", property $ \(QFilePath x) -> W.dropFileName x == fst (W.splitFileName x)) ,("AFP_P.dropFileName x == fst (AFP_P.splitFileName x)", property $ \(QFilePathAFP_P x) -> AFP_P.dropFileName x == fst (AFP_P.splitFileName x)) ,("AFP_W.dropFileName x == fst (AFP_W.splitFileName x)", property $ \(QFilePathAFP_W x) -> AFP_W.dropFileName x == fst (AFP_W.splitFileName x)) + ,("isPrefixOf (P.takeDrive x) (P.dropFileName x)", property $ \(QFilePath x) -> isPrefixOf (P.takeDrive x) (P.dropFileName x)) + ,("isPrefixOf (W.takeDrive x) (W.dropFileName x)", property $ \(QFilePath x) -> isPrefixOf (W.takeDrive x) (W.dropFileName x)) + ,("(\\(getPosixString -> x) (getPosixString -> y) -> SBS.isPrefixOf x y) (AFP_P.takeDrive x) (AFP_P.dropFileName x)", property $ \(QFilePathAFP_P x) -> (\(getPosixString -> x) (getPosixString -> y) -> SBS.isPrefixOf x y) (AFP_P.takeDrive x) (AFP_P.dropFileName x)) + ,("(\\(getWindowsString -> x) (getWindowsString -> y) -> SBS16.isPrefixOf x y) (AFP_W.takeDrive x) (AFP_W.dropFileName x)", property $ \(QFilePathAFP_W x) -> (\(getWindowsString -> x) (getWindowsString -> y) -> SBS16.isPrefixOf x y) (AFP_W.takeDrive x) (AFP_W.dropFileName x)) ,("P.takeFileName \"/directory/file.ext\" == \"file.ext\"", property $ P.takeFileName "/directory/file.ext" == "file.ext") ,("W.takeFileName \"/directory/file.ext\" == \"file.ext\"", property $ W.takeFileName "/directory/file.ext" == "file.ext") ,("AFP_P.takeFileName (\"/directory/file.ext\") == (\"file.ext\")", property $ AFP_P.takeFileName ("/directory/file.ext") == ("file.ext"))