diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/System/OsString.hs b/System/OsString.hs new file mode 100644 --- /dev/null +++ b/System/OsString.hs @@ -0,0 +1,206 @@ +-- | +-- 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 + ( + -- * String types + OsString + + -- * OsString construction + , encodeUtf + , encodeWith + , encodeFS + , osstr + , empty + , singleton + , pack + + -- * OsString deconstruction + , decodeUtf + , decodeWith + , decodeFS + , unpack + + -- * Word types + , OsChar + + -- * Word construction + , unsafeFromChar + + -- * Word deconstruction + , toChar + + -- * Basic interface + , snoc + , cons + , last + , tail + , uncons + , head + , init + , unsnoc + , null + , length + + -- * Transforming OsString + , map + , reverse + , intercalate + + -- * Reducing OsStrings (folds) + , foldl + , foldl' + , foldl1 + , foldl1' + , foldr + , foldr' + , foldr1 + , foldr1' + + -- * Special folds + , all + , any + , concat + + -- * Generating and unfolding OsStrings + , replicate + , unfoldr + , unfoldrN + + -- * Substrings + -- ** Breaking strings + , take + , takeEnd + , takeWhileEnd + , takeWhile + , drop + , dropEnd + , dropWhileEnd + , dropWhile + , break + , breakEnd + , span + , spanEnd + , splitAt + , split + , splitWith + , stripSuffix + , stripPrefix + + -- * Predicates + , isInfixOf + , isPrefixOf + , isSuffixOf + -- ** Search for arbitrary susbstrings + , breakSubstring + + -- * Searching OsStrings + -- ** Searching by equality + , elem + , find + , filter + , partition + + -- * Indexing OsStrings + , index + , indexMaybe + , (!?) + , elemIndex + , elemIndices + , count + , findIndex + , findIndices + ) +where + +import System.OsString.Internal + ( unsafeFromChar + , toChar + , encodeUtf + , encodeWith + , encodeFS + , osstr + , pack + , empty + , singleton + , decodeUtf + , decodeWith + , decodeFS + , unpack + , snoc + , cons + , last + , tail + , uncons + , head + , init + , unsnoc + , null + , length + , map + , reverse + , intercalate + , foldl + , foldl' + , foldl1 + , foldl1' + , foldr + , foldr' + , foldr1 + , foldr1' + , all + , any + , concat + , replicate + , unfoldr + , unfoldrN + , take + , takeEnd + , takeWhileEnd + , takeWhile + , drop + , dropEnd + , dropWhileEnd + , dropWhile + , break + , breakEnd + , span + , spanEnd + , splitAt + , split + , splitWith + , stripSuffix + , stripPrefix + , isInfixOf + , isPrefixOf + , isSuffixOf + , breakSubstring + , elem + , find + , filter + , partition + , index + , indexMaybe + , (!?) + , elemIndex + , elemIndices + , count + , findIndex + , findIndices + ) +import System.OsString.Internal.Types + ( OsString, OsChar ) +import Prelude () diff --git a/System/OsString/Common.hs b/System/OsString/Common.hs new file mode 100644 --- /dev/null +++ b/System/OsString/Common.hs @@ -0,0 +1,947 @@ +{- HLINT ignore "Unused LANGUAGE pragma" -} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} + +-- 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 + ( + -- * Types +#ifdef WINDOWS + WindowsString + , WindowsChar +#else + PosixString + , PosixChar +#endif + + -- * String construction + , encodeUtf + , encodeWith + , encodeFS + , fromBytes + , pstr + , singleton + , empty + , pack + + -- * String deconstruction + , decodeUtf + , decodeWith + , decodeFS + , unpack + + -- * Word construction + , unsafeFromChar + + -- * Word deconstruction + , toChar + + -- * Basic interface + , snoc + , cons + , last + , tail + , uncons + , head + , init + , unsnoc + , null + , length + + -- * Transforming OsString + , map + , reverse + , intercalate + + -- * Reducing OsStrings (folds) + , foldl + , foldl' + , foldl1 + , foldl1' + , foldr + , foldr' + , foldr1 + , foldr1' + + -- ** Special folds + , all + , any + , concat + + -- ** Generating and unfolding OsStrings + , replicate + , unfoldr + , unfoldrN + + -- * Substrings + -- ** Breaking strings + , take + , takeEnd + , takeWhileEnd + , takeWhile + , drop + , dropEnd + , dropWhileEnd + , dropWhile + , break + , breakEnd + , span + , spanEnd + , splitAt + , split + , splitWith + , stripSuffix + , stripPrefix + + -- * Predicates + , isInfixOf + , isPrefixOf + , isSuffixOf + -- ** Search for arbitrary susbstrings + , breakSubstring + + -- * Searching OsStrings + -- ** Searching by equality + , elem + , find + , filter + , partition + + -- * Indexing OsStrings + , index + , indexMaybe + , (!?) + , elemIndex + , elemIndices + , count + , findIndex + , findIndices + ) +where + + + +import System.OsString.Internal.Types ( +#ifdef WINDOWS + WindowsString(..), WindowsChar(..) +#else + PosixString(..), PosixChar(..) +#endif + ) + +import Data.Coerce +import Data.Char +import Control.Monad.Catch + ( MonadThrow, throwM ) +import Data.ByteString.Internal + ( ByteString ) +import Control.Exception + ( SomeException, try, 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 GHC.IO.Encoding.Failure ( CodingFailureMode(..) ) +#ifdef WINDOWS +import System.OsString.Encoding +import System.IO + ( TextEncoding, utf16le ) +import GHC.IO.Encoding.UTF16 ( mkUTF16le ) +import qualified System.OsString.Data.ByteString.Short.Word16 as BSP +#else +import System.OsString.Encoding +import System.IO + ( TextEncoding, utf8 ) +import GHC.IO.Encoding.UTF8 ( mkUTF8 ) +import qualified System.OsString.Data.ByteString.Short as BSP +#endif +import GHC.Stack (HasCallStack) +import Prelude (Bool, Int, Maybe(..), IO, String, Either(..), fmap, ($), (.), mconcat, fromEnum, fromInteger, mempty, fromIntegral, fail, (<$>), show, either, pure, const, flip) +import Data.Bifunctor ( bimap ) +import qualified System.OsString.Data.ByteString.Short.Word16 as BS16 +import qualified System.OsString.Data.ByteString.Short as BS8 + + + +#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 <- try @SomeException $ GHC.withCStringLen enc str $ \cstr -> WindowsString <$> BS8.packCStringLen cstr + evaluate $ force $ first (flip EncodingError Nothing . displayException) r +#else + r <- try @SomeException $ GHC.withCStringLen enc str $ \cstr -> PosixString <$> BSP.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 <- try @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 <- try @SomeException $ BSP.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 . BSP.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] +unpack = coerce BSP.unpack + + +-- | 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 +pack = coerce BSP.pack + +singleton :: PLATFORM_WORD -> PLATFORM_STRING +singleton = coerce BSP.singleton + +empty :: PLATFORM_STRING +empty = mempty + + +#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 + +-- | /O(n)/ Append a byte to the end of a 'OsString' +-- +-- @since 1.4.200.0 +snoc :: PLATFORM_STRING -> PLATFORM_WORD -> PLATFORM_STRING +snoc = coerce BSP.snoc + +-- | /O(n)/ 'cons' is analogous to (:) for lists. +-- +-- @since 1.4.200.0 +cons :: PLATFORM_WORD -> PLATFORM_STRING -> PLATFORM_STRING +cons = coerce BSP.cons + + +-- | /O(1)/ Extract the last element of a OsString, which must be finite and non-empty. +-- An exception will be thrown in the case of an empty OsString. +-- +-- This is a partial function, consider using 'unsnoc' instead. +-- +-- @since 1.4.200.0 +last :: HasCallStack => PLATFORM_STRING -> PLATFORM_WORD +last = coerce BSP.last + +-- | /O(n)/ Extract the elements after the head of a OsString, which must be non-empty. +-- An exception will be thrown in the case of an empty OsString. +-- +-- This is a partial function, consider using 'uncons' instead. +-- +-- @since 1.4.200.0 +tail :: HasCallStack => PLATFORM_STRING -> PLATFORM_STRING +tail = coerce BSP.tail + +-- | /O(n)/ Extract the 'head' and 'tail' of a OsString, returning 'Nothing' +-- if it is empty. +-- +-- @since 1.4.200.0 +uncons :: PLATFORM_STRING -> Maybe (PLATFORM_WORD, PLATFORM_STRING) +uncons = coerce BSP.uncons + +-- | /O(1)/ Extract the first element of a OsString, which must be non-empty. +-- An exception will be thrown in the case of an empty OsString. +-- +-- This is a partial function, consider using 'uncons' instead. +-- +-- @since 1.4.200.0 +head :: HasCallStack => PLATFORM_STRING -> PLATFORM_WORD +head = coerce BSP.head + +-- | /O(n)/ Return all the elements of a 'OsString' except the last one. +-- An exception will be thrown in the case of an empty OsString. +-- +-- This is a partial function, consider using 'unsnoc' instead. +-- +-- @since 1.4.200.0 +init :: HasCallStack => PLATFORM_STRING -> PLATFORM_STRING +init = coerce BSP.init + +-- | /O(n)/ Extract the 'init' and 'last' of a OsString, returning 'Nothing' +-- if it is empty. +-- +-- @since 1.4.200.0 +unsnoc :: PLATFORM_STRING -> Maybe (PLATFORM_STRING, PLATFORM_WORD) +unsnoc = coerce BSP.unsnoc + +-- | /O(1)/. The empty 'OsString'. +-- +-- @since 1.4.200.0 +null :: PLATFORM_STRING -> Bool +null = coerce BSP.null + +-- | /O(1)/ The length of a 'OsString'. +-- +-- @since 1.4.200.0 +length :: PLATFORM_STRING -> Int +length = coerce BSP.length + +-- | /O(n)/ 'map' @f xs@ is the OsString obtained by applying @f@ to each +-- element of @xs@. +-- +-- @since 1.4.200.0 +map :: (PLATFORM_WORD -> PLATFORM_WORD) -> PLATFORM_STRING -> PLATFORM_STRING +map = coerce BSP.map + +-- | /O(n)/ 'reverse' @xs@ efficiently returns the elements of @xs@ in reverse order. +-- +-- @since 1.4.200.0 +reverse :: PLATFORM_STRING -> PLATFORM_STRING +reverse = coerce BSP.reverse + +-- | /O(n)/ The 'intercalate' function takes a 'OsString' and a list of +-- 'OsString's and concatenates the list after interspersing the first +-- argument between each element of the list. +-- +-- @since 1.4.200.0 +intercalate :: PLATFORM_STRING -> [PLATFORM_STRING] -> PLATFORM_STRING +intercalate = coerce BSP.intercalate + +-- | 'foldl', applied to a binary operator, a starting value (typically +-- the left-identity of the operator), and a OsString, reduces the +-- OsString using the binary operator, from left to right. +-- +-- @since 1.4.200.0 +foldl :: forall a. (a -> PLATFORM_WORD -> a) -> a -> PLATFORM_STRING -> a +foldl = coerce (BSP.foldl @a) + +-- | 'foldl'' is like 'foldl', but strict in the accumulator. +-- +-- @since 1.4.200.0 +foldl' + :: forall a. (a -> PLATFORM_WORD -> a) -> a -> PLATFORM_STRING -> a +foldl' = coerce (BSP.foldl' @a) + +-- | 'foldl1' is a variant of 'foldl' that has no starting value +-- argument, and thus must be applied to non-empty 'OsString's. +-- An exception will be thrown in the case of an empty OsString. +-- +-- @since 1.4.200.0 +foldl1 :: (PLATFORM_WORD -> PLATFORM_WORD -> PLATFORM_WORD) -> PLATFORM_STRING -> PLATFORM_WORD +foldl1 = coerce BSP.foldl1 + +-- | 'foldl1'' is like 'foldl1', but strict in the accumulator. +-- An exception will be thrown in the case of an empty OsString. +-- +-- @since 1.4.200.0 +foldl1' + :: (PLATFORM_WORD -> PLATFORM_WORD -> PLATFORM_WORD) -> PLATFORM_STRING -> PLATFORM_WORD +foldl1' = coerce BSP.foldl1' + +-- | 'foldr', applied to a binary operator, a starting value +-- (typically the right-identity of the operator), and a OsString, +-- reduces the OsString using the binary operator, from right to left. +-- +-- @since 1.4.200.0 +foldr :: forall a. (PLATFORM_WORD -> a -> a) -> a -> PLATFORM_STRING -> a +foldr = coerce (BSP.foldr @a) + +-- | 'foldr'' is like 'foldr', but strict in the accumulator. +-- +-- @since 1.4.200.0 +foldr' + :: forall a. (PLATFORM_WORD -> a -> a) -> a -> PLATFORM_STRING -> a +foldr' = coerce (BSP.foldr' @a) + +-- | 'foldr1' is a variant of 'foldr' that has no starting value argument, +-- and thus must be applied to non-empty 'OsString's +-- An exception will be thrown in the case of an empty OsString. +-- +-- @since 1.4.200.0 +foldr1 :: (PLATFORM_WORD -> PLATFORM_WORD -> PLATFORM_WORD) -> PLATFORM_STRING -> PLATFORM_WORD +foldr1 = coerce BSP.foldr1 + +-- | 'foldr1'' is a variant of 'foldr1', but is strict in the +-- accumulator. +-- +-- @since 1.4.200.0 +foldr1' + :: (PLATFORM_WORD -> PLATFORM_WORD -> PLATFORM_WORD) -> PLATFORM_STRING -> PLATFORM_WORD +foldr1' = coerce BSP.foldr1' + +-- | /O(n)/ Applied to a predicate and a 'OsString', 'all' determines +-- if all elements of the 'OsString' satisfy the predicate. +-- +-- @since 1.4.200.0 +all :: (PLATFORM_WORD -> Bool) -> PLATFORM_STRING -> Bool +all = coerce BSP.all + +-- | /O(n)/ Applied to a predicate and a 'OsString', 'any' determines if +-- any element of the 'OsString' satisfies the predicate. +-- +-- @since 1.4.200.0 +any :: (PLATFORM_WORD -> Bool) -> PLATFORM_STRING -> Bool +any = coerce BSP.any + +-- /O(n)/ Concatenate a list of OsStrings. +-- +-- @since 1.4.200.0 +concat :: [PLATFORM_STRING] -> PLATFORM_STRING +concat = mconcat + +-- | /O(n)/ 'replicate' @n x@ is a OsString of length @n@ with @x@ +-- the value of every element. The following holds: +-- +-- > replicate w c = unfoldr w (\u -> Just (u,u)) c +-- +-- @since 1.4.200.0 +replicate :: Int -> PLATFORM_WORD -> PLATFORM_STRING +replicate = coerce BSP.replicate + +-- | /O(n)/, where /n/ is the length of the result. The 'unfoldr' +-- function is analogous to the List \'unfoldr\'. 'unfoldr' builds a +-- OsString from a seed value. The function takes the element and +-- returns 'Nothing' if it is done producing the OsString 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 @[Word8]@ +-- and run the generator until it returns `Nothing`, otherwise recurse infinitely, +-- then finally create a 'OsString'. +-- +-- If you know the maximum length, consider using 'unfoldrN'. +-- +-- Examples: +-- +-- > unfoldr (\x -> if x <= 5 then Just (x, x + 1) else Nothing) 0 +-- > == pack [0, 1, 2, 3, 4, 5] +-- +-- @since 1.4.200.0 +unfoldr :: forall a. (a -> Maybe (PLATFORM_WORD, a)) -> a -> PLATFORM_STRING +unfoldr = coerce (BSP.unfoldr @a) + +-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a OsString 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) +-- +-- @since 1.4.200.0 +unfoldrN :: forall a. Int -> (a -> Maybe (PLATFORM_WORD, a)) -> a -> (PLATFORM_STRING, Maybe a) +unfoldrN = coerce (BSP.unfoldrN @a) + +-- | /O(n)/ 'take' @n@, applied to a OsString @xs@, returns the prefix +-- of @xs@ of length @n@, or @xs@ itself if @n > 'length' xs@. +-- +-- @since 1.4.200.0 +take :: Int -> PLATFORM_STRING -> PLATFORM_STRING +take = coerce BSP.take + +-- | /O(n)/ @'takeEnd' n xs@ is equivalent to @'drop' ('length' xs - n) xs@. +-- Takes @n@ elements from end of bytestring. +-- +-- >>> takeEnd 3 "abcdefg" +-- "efg" +-- >>> takeEnd 0 "abcdefg" +-- "" +-- >>> takeEnd 4 "abc" +-- "abc" +-- +-- @since 1.4.200.0 +takeEnd :: Int -> PLATFORM_STRING -> PLATFORM_STRING +takeEnd = coerce BSP.takeEnd + +-- | Returns the longest (possibly empty) suffix of elements +-- satisfying the predicate. +-- +-- @'takeWhileEnd' p@ is equivalent to @'reverse' . 'takeWhile' p . 'reverse'@. +-- +-- @since 1.4.200.0 +takeWhileEnd :: (PLATFORM_WORD -> Bool) -> PLATFORM_STRING -> PLATFORM_STRING +takeWhileEnd = coerce BSP.takeWhileEnd + +-- | Similar to 'Prelude.takeWhile', +-- returns the longest (possibly empty) prefix of elements +-- satisfying the predicate. +-- +-- @since 1.4.200.0 +takeWhile :: (PLATFORM_WORD -> Bool) -> PLATFORM_STRING -> PLATFORM_STRING +takeWhile = coerce BSP.takeWhile + +-- | /O(n)/ 'drop' @n@ @xs@ returns the suffix of @xs@ after the first n elements, or 'empty' if @n > 'length' xs@. +-- +-- @since 1.4.200.0 +drop :: Int -> PLATFORM_STRING -> PLATFORM_STRING +drop = coerce BSP.drop + +-- | /O(n)/ @'dropEnd' n xs@ is equivalent to @'take' ('length' xs - n) xs@. +-- Drops @n@ elements from end of bytestring. +-- +-- >>> dropEnd 3 "abcdefg" +-- "abcd" +-- >>> dropEnd 0 "abcdefg" +-- "abcdefg" +-- >>> dropEnd 4 "abc" +-- "" +-- +-- @since 1.4.200.0 +dropEnd :: Int -> PLATFORM_STRING -> PLATFORM_STRING +dropEnd = coerce BSP.dropEnd + +-- | Similar to 'Prelude.dropWhile', +-- drops the longest (possibly empty) prefix of elements +-- satisfying the predicate and returns the remainder. +-- +-- @since 1.4.200.0 +dropWhile :: (PLATFORM_WORD -> Bool) -> PLATFORM_STRING -> PLATFORM_STRING +dropWhile = coerce BSP.dropWhile + +-- | Similar to 'Prelude.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 1.4.200.0 +dropWhileEnd :: (PLATFORM_WORD -> Bool) -> PLATFORM_STRING -> PLATFORM_STRING +dropWhileEnd = coerce BSP.dropWhileEnd + +-- | 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))@. +-- +-- @since 1.4.200.0 +breakEnd :: (PLATFORM_WORD -> Bool) -> PLATFORM_STRING -> (PLATFORM_STRING, PLATFORM_STRING) +breakEnd = coerce BSP.breakEnd + +-- | Similar to 'Prelude.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))@. +-- +-- @since 1.4.200.0 +break :: (PLATFORM_WORD -> Bool) -> PLATFORM_STRING -> (PLATFORM_STRING, PLATFORM_STRING) +break = coerce BSP.break + +-- | Similar to 'Prelude.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)@. +-- +-- @since 1.4.200.0 +span :: (PLATFORM_WORD -> Bool) -> PLATFORM_STRING -> (PLATFORM_STRING, PLATFORM_STRING) +span = coerce BSP.span + +-- | 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) sbs +-- > == +-- > let (x, y) = span (not . isSpace) (reverse sbs) in (reverse y, reverse x) +-- +-- @since 1.4.200.0 +spanEnd :: (PLATFORM_WORD -> Bool) -> PLATFORM_STRING -> (PLATFORM_STRING, PLATFORM_STRING) +spanEnd = coerce BSP.spanEnd + +-- | /O(n)/ 'splitAt' @n sbs@ is equivalent to @('take' n sbs, 'drop' n sbs)@. +-- +-- @since 1.4.200.0 +splitAt :: Int -> PLATFORM_STRING -> (PLATFORM_STRING, PLATFORM_STRING) +splitAt = coerce BSP.splitAt + +-- | /O(n)/ Break a 'OsString' 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 . (==) +-- +-- @since 1.4.200.0 +split :: PLATFORM_WORD -> PLATFORM_STRING -> [PLATFORM_STRING] +split = coerce BSP.split + +-- | /O(n)/ Splits a 'OsString' 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 [""] +-- +-- @since 1.4.200.0 +splitWith :: (PLATFORM_WORD -> Bool) -> PLATFORM_STRING -> [PLATFORM_STRING] +splitWith = coerce BSP.splitWith + +-- | /O(n)/ The 'stripSuffix' function takes two OsStrings and returns 'Just' +-- the remainder of the second iff the first is its suffix, and otherwise +-- 'Nothing'. +-- +-- @since 1.4.200.0 +stripSuffix :: PLATFORM_STRING -> PLATFORM_STRING -> Maybe PLATFORM_STRING +stripSuffix = coerce BSP.stripSuffix + +-- | /O(n)/ The 'stripPrefix' function takes two OsStrings and returns 'Just' +-- the remainder of the second iff the first is its prefix, and otherwise +-- 'Nothing'. +-- +-- @since 1.4.200.0 +stripPrefix :: PLATFORM_STRING -> PLATFORM_STRING -> Maybe PLATFORM_STRING +stripPrefix = coerce BSP.stripPrefix + + +-- | Check whether one string is a substring of another. +-- +-- @since 1.4.200.0 +isInfixOf :: PLATFORM_STRING -> PLATFORM_STRING -> Bool +isInfixOf = coerce BSP.isInfixOf + +-- |/O(n)/ The 'isPrefixOf' function takes two OsStrings and returns 'True' +-- +-- @since 1.4.200.0 +isPrefixOf :: PLATFORM_STRING -> PLATFORM_STRING -> Bool +isPrefixOf = coerce BSP.isPrefixOf + +-- | /O(n)/ The 'isSuffixOf' function takes two OsStrings and returns 'True' +-- iff the first is a suffix of the second. +-- +-- The following holds: +-- +-- > isSuffixOf x y == reverse x `isPrefixOf` reverse y +-- +-- @since 1.4.200.0 +isSuffixOf :: PLATFORM_STRING -> PLATFORM_STRING -> Bool +isSuffixOf = coerce BSP.isSuffixOf + + +-- | Break a string on a substring, returning a pair of the part of the +-- string prior to the match, and the rest of the string. +-- +-- The following relationships hold: +-- +-- > break (== c) l == breakSubstring (singleton c) l +-- +-- For example, to tokenise a string, dropping delimiters: +-- +-- > tokenise x y = h : if null t then [] else tokenise x (drop (length x) t) +-- > where (h,t) = breakSubstring x y +-- +-- To skip to the first occurrence of a string: +-- +-- > snd (breakSubstring x y) +-- +-- To take the parts of a string before a delimiter: +-- +-- > fst (breakSubstring x y) +-- +-- Note that calling `breakSubstring x` does some preprocessing work, so +-- you should avoid unnecessarily duplicating breakSubstring calls with the same +-- pattern. +-- +-- @since 1.4.200.0 +breakSubstring :: PLATFORM_STRING -> PLATFORM_STRING -> (PLATFORM_STRING, PLATFORM_STRING) +breakSubstring = coerce BSP.breakSubstring + +-- | /O(n)/ 'elem' is the 'OsString' membership predicate. +-- +-- @since 1.4.200.0 +elem :: PLATFORM_WORD -> PLATFORM_STRING -> Bool +elem = coerce BSP.elem + +-- | /O(n)/ The 'find' function takes a predicate and a OsString, +-- 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 +-- +-- @since 1.4.200.0 +find :: (PLATFORM_WORD -> Bool) -> PLATFORM_STRING -> Maybe PLATFORM_WORD +find = coerce BSP.find + +-- | /O(n)/ 'filter', applied to a predicate and a OsString, +-- returns a OsString containing those characters that satisfy the +-- predicate. +-- +-- @since 1.4.200.0 +filter :: (PLATFORM_WORD -> Bool) -> PLATFORM_STRING -> PLATFORM_STRING +filter = coerce BSP.filter + +-- | /O(n)/ The 'partition' function takes a predicate a OsString and returns +-- the pair of OsStrings with elements which do and do not satisfy the +-- predicate, respectively; i.e., +-- +-- > partition p bs == (filter p sbs, filter (not . p) sbs) +-- +-- @since 1.4.200.0 +partition :: (PLATFORM_WORD -> Bool) -> PLATFORM_STRING -> (PLATFORM_STRING, PLATFORM_STRING) +partition = coerce BSP.partition + +-- | /O(1)/ 'OsString' index (subscript) operator, starting from 0. +-- +-- @since 1.4.200.0 +index :: HasCallStack => PLATFORM_STRING -> Int -> PLATFORM_WORD +index = coerce BSP.index + +-- | /O(1)/ 'OsString' index, starting from 0, that returns 'Just' if: +-- +-- > 0 <= n < length bs +-- +-- @since 1.4.200.0 +indexMaybe :: PLATFORM_STRING -> Int -> Maybe PLATFORM_WORD +indexMaybe = coerce BSP.indexMaybe + +-- | /O(1)/ 'OsString' index, starting from 0, that returns 'Just' if: +-- +-- > 0 <= n < length bs +-- +-- @since 1.4.200.0 +(!?) :: PLATFORM_STRING -> Int -> Maybe PLATFORM_WORD +(!?) = indexMaybe + +-- | /O(n)/ The 'elemIndex' function returns the index of the first +-- element in the given 'OsString' which is equal to the query +-- element, or 'Nothing' if there is no such element. +-- +-- @since 1.4.200.0 +elemIndex :: PLATFORM_WORD -> PLATFORM_STRING -> Maybe Int +elemIndex = coerce BSP.elemIndex + +-- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by returning +-- the indices of all elements equal to the query element, in ascending order. +-- +-- @since 1.4.200.0 +elemIndices :: PLATFORM_WORD -> PLATFORM_STRING -> [Int] +elemIndices = coerce BSP.elemIndices + +-- | count returns the number of times its argument appears in the OsString +-- +-- @since 1.4.200.0 +count :: PLATFORM_WORD -> PLATFORM_STRING -> Int +count = coerce BSP.count + +-- | /O(n)/ The 'findIndex' function takes a predicate and a 'OsString' and +-- returns the index of the first element in the OsString +-- satisfying the predicate. +-- +-- @since 1.4.200.0 +findIndex :: (PLATFORM_WORD -> Bool) -> PLATFORM_STRING -> Maybe Int +findIndex = coerce BSP.findIndex + +-- | /O(n)/ The 'findIndices' function extends 'findIndex', by returning the +-- indices of all elements satisfying the predicate, in ascending order. +-- +-- @since 1.4.200.0 +findIndices :: (PLATFORM_WORD -> Bool) -> PLATFORM_STRING -> [Int] +findIndices = coerce BSP.findIndices diff --git a/System/OsString/Data/ByteString/Short.hs b/System/OsString/Data/ByteString/Short.hs new file mode 100644 --- /dev/null +++ b/System/OsString/Data/ByteString/Short.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : System.OsString.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.OsString.Data.ByteString.Short ( + + -- * 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.OsString.Data.ByteString.Short.Internal + +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/OsString/Data/ByteString/Short/Internal.hs b/System/OsString/Data/ByteString/Short/Internal.hs new file mode 100644 --- /dev/null +++ b/System/OsString/Data/ByteString/Short/Internal.hs @@ -0,0 +1,481 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE UnliftedFFITypes #-} + +-- | +-- Module : System.OsString.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.OsString.Data.ByteString.Short.Internal 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/OsString/Data/ByteString/Short/Word16.hs b/System/OsString/Data/ByteString/Short/Word16.hs new file mode 100644 --- /dev/null +++ b/System/OsString/Data/ByteString/Short/Word16.hs @@ -0,0 +1,895 @@ +{-# 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.OsString.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.OsString.Data.ByteString.Short.Word16 ( + -- * 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.OsString.Data.ByteString.Short ( append, intercalate, concat, stripSuffix, stripPrefix, isPrefixOf, isSuffixOf, length, empty, null, ShortByteString(..), fromShort, toShort ) +import System.OsString.Data.ByteString.Short.Internal +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/OsString/Encoding.hs b/System/OsString/Encoding.hs new file mode 100644 --- /dev/null +++ b/System/OsString/Encoding.hs @@ -0,0 +1,31 @@ +module System.OsString.Encoding + ( + -- * Types + EncodingException(..) + , showEncodingException + + -- * UCS-2 + , ucs2le + , mkUcs2le + , ucs2le_DF + , ucs2le_EF + , ucs2le_decode + , ucs2le_encode + + -- * UTF-16LE_b + , utf16le_b + , mkUTF16le_b + , utf16le_b_DF + , utf16le_b_EF + , utf16le_b_decode + , utf16le_b_encode + + -- * base encoding + , encodeWithBasePosix + , decodeWithBasePosix + , encodeWithBaseWindows + , decodeWithBaseWindows + ) + where + +import System.OsString.Encoding.Internal diff --git a/System/OsString/Encoding/Internal.hs b/System/OsString/Encoding/Internal.hs new file mode 100644 --- /dev/null +++ b/System/OsString/Encoding/Internal.hs @@ -0,0 +1,348 @@ +{-# LANGUAGE NoImplicitPrelude + , BangPatterns + , TypeApplications + , MultiWayIf + #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} + + +module System.OsString.Encoding.Internal where + +import qualified System.OsString.Data.ByteString.Short as BS8 +import qualified System.OsString.Data.ByteString.Short.Word16 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) +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 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 +-- + +withWindowsString :: String -> (Int -> Ptr Word16 -> IO a) -> IO a +withWindowsString = withArrayLen . charsToCWchars + +peekWindowsString :: (Ptr Word16, Int) -> IO String +peekWindowsString (cp, l) = do + cs <- peekArray l cp + return (cWcharsToChars cs) + +withPosixString :: String -> (CStringLen -> IO a) -> IO a +withPosixString fp f = getFileSystemEncoding >>= \enc -> GHC.withCStringLen enc fp f + +peekPosixString :: CStringLen -> IO String +peekPosixString 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 <- try @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 <- try @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 -> peekPosixString 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 = withPosixString 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 -> peekWindowsString 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 = withWindowsString 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 diff --git a/System/OsString/Internal.hs b/System/OsString/Internal.hs new file mode 100644 --- /dev/null +++ b/System/OsString/Internal.hs @@ -0,0 +1,721 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module System.OsString.Internal where + +import System.OsString.Internal.Types + +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.OsString.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 as PF +#else +import GHC.IO.Encoding.UTF8 ( mkUTF8 ) +import qualified System.OsString.Posix as PF +#endif +import GHC.Stack (HasCallStack) +import Data.Coerce (coerce) + + + + +-- | 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 = coerce PF.unpack + + +-- | 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 = coerce PF.pack + +empty :: OsString +empty = mempty + +singleton :: OsChar -> OsString +singleton = coerce PF.singleton + + +-- | Truncates on unix to 1 and on Windows to 2 octets. +unsafeFromChar :: Char -> OsChar +unsafeFromChar = coerce 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 + +-- | /O(n)/ Append a byte to the end of a 'OsString' +-- +-- @since 1.4.200.0 +snoc :: OsString -> OsChar -> OsString +snoc = coerce PF.snoc + +-- | /O(n)/ 'cons' is analogous to (:) for lists. +-- +-- @since 1.4.200.0 +cons :: OsChar -> OsString -> OsString +cons = coerce PF.cons + +-- | /O(1)/ Extract the last element of a OsString, which must be finite and non-empty. +-- An exception will be thrown in the case of an empty OsString. +-- +-- This is a partial function, consider using 'unsnoc' instead. +-- +-- @since 1.4.200.0 +last :: HasCallStack => OsString -> OsChar +last = coerce PF.last + +-- | /O(n)/ Extract the elements after the head of a OsString, which must be non-empty. +-- An exception will be thrown in the case of an empty OsString. +-- +-- This is a partial function, consider using 'uncons' instead. +-- +-- @since 1.4.200.0 +tail :: HasCallStack => OsString -> OsString +tail = coerce PF.tail + +-- | /O(n)/ Extract the 'head' and 'tail' of a OsString, returning 'Nothing' +-- if it is empty. +-- +-- @since 1.4.200.0 +uncons :: OsString -> Maybe (OsChar, OsString) +uncons = coerce PF.uncons + +-- | /O(1)/ Extract the first element of a OsString, which must be non-empty. +-- An exception will be thrown in the case of an empty OsString. +-- +-- This is a partial function, consider using 'uncons' instead. +-- +-- @since 1.4.200.0 +head :: HasCallStack => OsString -> OsChar +head = coerce PF.head + +-- | /O(n)/ Return all the elements of a 'OsString' except the last one. +-- An exception will be thrown in the case of an empty OsString. +-- +-- This is a partial function, consider using 'unsnoc' instead. +-- +-- @since 1.4.200.0 +init :: HasCallStack => OsString -> OsString +init = coerce PF.init + +-- | /O(n)/ Extract the 'init' and 'last' of a OsString, returning 'Nothing' +-- if it is empty. +-- +-- @since 1.4.200.0 +unsnoc :: OsString -> Maybe (OsString, OsChar) +unsnoc = coerce PF.unsnoc + +-- | /O(1)/ Test whether a 'OsString' is empty. +-- +-- @since 1.4.200.0 +null :: OsString -> Bool +null = coerce PF.null + +-- | /O(1)/ The length of a 'OsString'. +-- +-- @since 1.4.200.0 +length :: OsString -> Int +length = coerce PF.length + +-- | /O(n)/ 'map' @f xs@ is the OsString obtained by applying @f@ to each +-- element of @xs@. +-- +-- @since 1.4.200.0 +map :: (OsChar -> OsChar) -> OsString -> OsString +map = coerce PF.map + +-- | /O(n)/ 'reverse' @xs@ efficiently returns the elements of @xs@ in reverse order. +-- +-- @since 1.4.200.0 +reverse :: OsString -> OsString +reverse = coerce PF.reverse + +-- | /O(n)/ The 'intercalate' function takes a 'OsString' and a list of +-- 'OsString's and concatenates the list after interspersing the first +-- argument between each element of the list. +-- +-- @since 1.4.200.0 +intercalate :: OsString -> [OsString] -> OsString +intercalate = coerce PF.intercalate + +-- | 'foldl', applied to a binary operator, a starting value (typically +-- the left-identity of the operator), and a OsString, reduces the +-- OsString using the binary operator, from left to right. +-- +-- @since 1.4.200.0 +foldl :: forall a. (a -> OsChar -> a) -> a -> OsString -> a +foldl = coerce (PF.foldl @a) + +-- | 'foldl'' is like 'foldl', but strict in the accumulator. +-- +-- @since 1.4.200.0 +foldl' :: forall a. (a -> OsChar -> a) -> a -> OsString -> a +foldl' = coerce (PF.foldl' @a) + +-- | 'foldl1' is a variant of 'foldl' that has no starting value +-- argument, and thus must be applied to non-empty 'OsString's. +-- An exception will be thrown in the case of an empty OsString. +-- +-- @since 1.4.200.0 +foldl1 :: (OsChar -> OsChar -> OsChar) -> OsString -> OsChar +foldl1 = coerce PF.foldl1 + +-- | 'foldl1'' is like 'foldl1', but strict in the accumulator. +-- An exception will be thrown in the case of an empty OsString. +-- +-- @since 1.4.200.0 +foldl1' :: (OsChar -> OsChar -> OsChar) -> OsString -> OsChar +foldl1' = coerce PF.foldl1' + + +-- | 'foldr', applied to a binary operator, a starting value +-- (typically the right-identity of the operator), and a OsString, +-- reduces the OsString using the binary operator, from right to left. +-- +-- @since 1.4.200.0 +foldr :: forall a. (OsChar -> a -> a) -> a -> OsString -> a +foldr = coerce (PF.foldr @a) + +-- | 'foldr'' is like 'foldr', but strict in the accumulator. +-- +-- @since 1.4.200.0 +foldr' :: forall a. (OsChar -> a -> a) -> a -> OsString -> a +foldr' = coerce (PF.foldr' @a) + +-- | 'foldr1' is a variant of 'foldr' that has no starting value argument, +-- and thus must be applied to non-empty 'OsString's +-- An exception will be thrown in the case of an empty OsString. +-- +-- @since 1.4.200.0 +foldr1 :: (OsChar -> OsChar -> OsChar) -> OsString -> OsChar +foldr1 = coerce PF.foldr1 + +-- | 'foldr1'' is a variant of 'foldr1', but is strict in the +-- accumulator. +-- +-- @since 1.4.200.0 +foldr1' :: (OsChar -> OsChar -> OsChar) -> OsString -> OsChar +foldr1' = coerce PF.foldr1' + +-- | /O(n)/ Applied to a predicate and a 'OsString', 'all' determines +-- if all elements of the 'OsString' satisfy the predicate. +-- +-- @since 1.4.200.0 +all :: (OsChar -> Bool) -> OsString -> Bool +all = coerce PF.all + +-- | /O(n)/ Applied to a predicate and a 'OsString', 'any' determines if +-- any element of the 'OsString' satisfies the predicate. +-- +-- @since 1.4.200.0 +any :: (OsChar -> Bool) -> OsString -> Bool +any = coerce PF.any + +-- /O(n)/ Concatenate a list of OsStrings. +-- +-- @since 1.4.200.0 +concat :: [OsString] -> OsString +concat = mconcat + +-- | /O(n)/ 'replicate' @n x@ is a OsString of length @n@ with @x@ +-- the value of every element. The following holds: +-- +-- > replicate w c = unfoldr w (\u -> Just (u,u)) c +-- +-- @since 1.4.200.0 +replicate :: Int -> OsChar -> OsString +replicate = coerce PF.replicate + +-- | /O(n)/, where /n/ is the length of the result. The 'unfoldr' +-- function is analogous to the List \'unfoldr\'. 'unfoldr' builds a +-- OsString from a seed value. The function takes the element and +-- returns 'Nothing' if it is done producing the OsString 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 @[Word8]@ +-- and run the generator until it returns `Nothing`, otherwise recurse infinitely, +-- then finally create a 'OsString'. +-- +-- If you know the maximum length, consider using 'unfoldrN'. +-- +-- Examples: +-- +-- > unfoldr (\x -> if x <= 5 then Just (x, x + 1) else Nothing) 0 +-- > == pack [0, 1, 2, 3, 4, 5] +-- +-- @since 1.4.200.0 +unfoldr :: forall a. (a -> Maybe (OsChar, a)) -> a -> OsString +unfoldr = coerce (PF.unfoldr @a) + +-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a OsString 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) +-- +-- @since 1.4.200.0 +unfoldrN :: forall a. Int -> (a -> Maybe (OsChar, a)) -> a -> (OsString, Maybe a) +unfoldrN = coerce (PF.unfoldrN @a) + +-- | /O(n)/ 'take' @n@, applied to a OsString @xs@, returns the prefix +-- of @xs@ of length @n@, or @xs@ itself if @n > 'length' xs@. +-- +-- @since 1.4.200.0 +take :: Int -> OsString -> OsString +take = coerce PF.take + +-- | /O(n)/ @'takeEnd' n xs@ is equivalent to @'drop' ('length' xs - n) xs@. +-- Takes @n@ elements from end of bytestring. +-- +-- >>> takeEnd 3 "abcdefg" +-- "efg" +-- >>> takeEnd 0 "abcdefg" +-- "" +-- >>> takeEnd 4 "abc" +-- "abc" +-- +-- @since 1.4.200.0 +takeEnd :: Int -> OsString -> OsString +takeEnd = coerce PF.takeEnd + +-- | Returns the longest (possibly empty) suffix of elements +-- satisfying the predicate. +-- +-- @'takeWhileEnd' p@ is equivalent to @'reverse' . 'takeWhile' p . 'reverse'@. +-- +-- @since 1.4.200.0 +takeWhileEnd :: (OsChar -> Bool) -> OsString -> OsString +takeWhileEnd = coerce PF.takeWhileEnd + +-- | Similar to 'Prelude.takeWhile', +-- returns the longest (possibly empty) prefix of elements +-- satisfying the predicate. +-- +-- @since 1.4.200.0 +takeWhile :: (OsChar -> Bool) -> OsString -> OsString +takeWhile = coerce PF.takeWhile + +-- | /O(n)/ 'drop' @n@ @xs@ returns the suffix of @xs@ after the first n elements, or 'empty' if @n > 'length' xs@. +-- +-- @since 1.4.200.0 +drop :: Int -> OsString -> OsString +drop = coerce PF.drop + +-- | /O(n)/ @'dropEnd' n xs@ is equivalent to @'take' ('length' xs - n) xs@. +-- Drops @n@ elements from end of bytestring. +-- +-- >>> dropEnd 3 "abcdefg" +-- "abcd" +-- >>> dropEnd 0 "abcdefg" +-- "abcdefg" +-- >>> dropEnd 4 "abc" +-- "" +-- +-- @since 1.4.200.0 +dropEnd :: Int -> OsString -> OsString +dropEnd = coerce PF.dropEnd + +-- | Similar to 'Prelude.dropWhile', +-- drops the longest (possibly empty) prefix of elements +-- satisfying the predicate and returns the remainder. +-- +-- @since 1.4.200.0 +dropWhile :: (OsChar -> Bool) -> OsString -> OsString +dropWhile = coerce PF.dropWhile + +-- | Similar to 'Prelude.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 1.4.200.0 +dropWhileEnd :: (OsChar -> Bool) -> OsString -> OsString +dropWhileEnd = coerce PF.dropWhileEnd + +-- | 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))@. +-- +-- @since 1.4.200.0 +breakEnd :: (OsChar -> Bool) -> OsString -> (OsString, OsString) +breakEnd = coerce PF.breakEnd + +-- | Similar to 'Prelude.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))@. +-- +-- @since 1.4.200.0 +break :: (OsChar -> Bool) -> OsString -> (OsString, OsString) +break = coerce PF.break + +-- | Similar to 'Prelude.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)@. +-- +-- @since 1.4.200.0 +span :: (OsChar -> Bool) -> OsString -> (OsString, OsString) +span = coerce PF.span + +-- | 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) sbs +-- > == +-- > let (x, y) = span (not . isSpace) (reverse sbs) in (reverse y, reverse x) +-- +-- @since 1.4.200.0 +spanEnd :: (OsChar -> Bool) -> OsString -> (OsString, OsString) +spanEnd = coerce PF.spanEnd + +-- | /O(n)/ 'splitAt' @n sbs@ is equivalent to @('take' n sbs, 'drop' n sbs)@. +-- +-- @since 1.4.200.0 +splitAt :: Int -> OsString -> (OsString, OsString) +splitAt = coerce PF.splitAt + +-- | /O(n)/ Break a 'OsString' 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 . (==) +-- +-- @since 1.4.200.0 +split :: OsChar -> OsString -> [OsString] +split = coerce PF.split + +-- | /O(n)/ Splits a 'OsString' 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 [""] +-- +-- @since 1.4.200.0 +splitWith :: (OsChar -> Bool) -> OsString -> [OsString] +splitWith = coerce PF.splitWith + +-- | /O(n)/ The 'stripSuffix' function takes two OsStrings and returns 'Just' +-- the remainder of the second iff the first is its suffix, and otherwise +-- 'Nothing'. +-- +-- @since 1.4.200.0 +stripSuffix :: OsString -> OsString -> Maybe OsString +stripSuffix = coerce PF.stripSuffix + +-- | /O(n)/ The 'stripPrefix' function takes two OsStrings and returns 'Just' +-- the remainder of the second iff the first is its prefix, and otherwise +-- 'Nothing'. +-- +-- @since 1.4.200.0 +stripPrefix :: OsString -> OsString -> Maybe OsString +stripPrefix = coerce PF.stripPrefix + + +-- | Check whether one string is a substring of another. +-- +-- @since 1.4.200.0 +isInfixOf :: OsString -> OsString -> Bool +isInfixOf = coerce PF.isInfixOf + +-- |/O(n)/ The 'isPrefixOf' function takes two OsStrings and returns 'True' +-- +-- @since 1.4.200.0 +isPrefixOf :: OsString -> OsString -> Bool +isPrefixOf = coerce PF.isPrefixOf + +-- | /O(n)/ The 'isSuffixOf' function takes two OsStrings and returns 'True' +-- iff the first is a suffix of the second. +-- +-- The following holds: +-- +-- > isSuffixOf x y == reverse x `isPrefixOf` reverse y +-- +-- @since 1.4.200.0 +isSuffixOf :: OsString -> OsString -> Bool +isSuffixOf = coerce PF.isSuffixOf + +-- | Break a string on a substring, returning a pair of the part of the +-- string prior to the match, and the rest of the string. +-- +-- The following relationships hold: +-- +-- > break (== c) l == breakSubstring (singleton c) l +-- +-- For example, to tokenise a string, dropping delimiters: +-- +-- > tokenise x y = h : if null t then [] else tokenise x (drop (length x) t) +-- > where (h,t) = breakSubstring x y +-- +-- To skip to the first occurrence of a string: +-- +-- > snd (breakSubstring x y) +-- +-- To take the parts of a string before a delimiter: +-- +-- > fst (breakSubstring x y) +-- +-- Note that calling `breakSubstring x` does some preprocessing work, so +-- you should avoid unnecessarily duplicating breakSubstring calls with the same +-- pattern. +-- +-- @since 1.4.200.0 +breakSubstring :: OsString -> OsString -> (OsString, OsString) +breakSubstring = coerce PF.breakSubstring + +-- | /O(n)/ 'elem' is the 'OsString' membership predicate. +-- +-- @since 1.4.200.0 +elem :: OsChar -> OsString -> Bool +elem = coerce PF.elem + +-- | /O(n)/ The 'find' function takes a predicate and a OsString, +-- 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 +-- +-- @since 1.4.200.0 +find :: (OsChar -> Bool) -> OsString -> Maybe OsChar +find = coerce PF.find + +-- | /O(n)/ 'filter', applied to a predicate and a OsString, +-- returns a OsString containing those characters that satisfy the +-- predicate. +-- +-- @since 1.4.200.0 +filter :: (OsChar -> Bool) -> OsString -> OsString +filter = coerce PF.filter + +-- | /O(n)/ The 'partition' function takes a predicate a OsString and returns +-- the pair of OsStrings with elements which do and do not satisfy the +-- predicate, respectively; i.e., +-- +-- > partition p bs == (filter p sbs, filter (not . p) sbs) +-- +-- @since 1.4.200.0 +partition :: (OsChar -> Bool) -> OsString -> (OsString, OsString) +partition = coerce PF.partition + +-- | /O(1)/ 'OsString' index (subscript) operator, starting from 0. +-- +-- @since 1.4.200.0 +index :: HasCallStack => OsString -> Int -> OsChar +index = coerce PF.index + +-- | /O(1)/ 'OsString' index, starting from 0, that returns 'Just' if: +-- +-- > 0 <= n < length bs +-- +-- @since 1.4.200.0 +indexMaybe :: OsString -> Int -> Maybe OsChar +indexMaybe = coerce PF.indexMaybe + +-- | /O(1)/ 'OsString' index, starting from 0, that returns 'Just' if: +-- +-- > 0 <= n < length bs +-- +-- @since 1.4.200.0 +(!?) :: OsString -> Int -> Maybe OsChar +(!?) = indexMaybe + +-- | /O(n)/ The 'elemIndex' function returns the index of the first +-- element in the given 'OsString' which is equal to the query +-- element, or 'Nothing' if there is no such element. +-- +-- @since 1.4.200.0 +elemIndex :: OsChar -> OsString -> Maybe Int +elemIndex = coerce PF.elemIndex + +-- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by returning +-- the indices of all elements equal to the query element, in ascending order. +-- +-- @since 1.4.200.0 +elemIndices :: OsChar -> OsString -> [Int] +elemIndices = coerce PF.elemIndices + +-- | count returns the number of times its argument appears in the OsString +-- +-- @since 1.4.200.0 +count :: OsChar -> OsString -> Int +count = coerce PF.count + +-- | /O(n)/ The 'findIndex' function takes a predicate and a 'OsString' and +-- returns the index of the first element in the OsString +-- satisfying the predicate. +-- +-- @since 1.4.200.0 +findIndex :: (OsChar -> Bool) -> OsString -> Maybe Int +findIndex = coerce PF.findIndex + +-- | /O(n)/ The 'findIndices' function extends 'findIndex', by returning the +-- indices of all elements satisfying the predicate, in ascending order. +-- +-- @since 1.4.200.0 +findIndices :: (OsChar -> Bool) -> OsString -> [Int] +findIndices = coerce PF.findIndices + diff --git a/System/OsString/Internal/Types.hs b/System/OsString/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/System/OsString/Internal/Types.hs @@ -0,0 +1,246 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE PatternSynonyms #-} + +module System.OsString.Internal.Types + ( + 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.OsString.Encoding.Internal +import qualified System.OsString.Data.ByteString.Short as BS +import qualified System.OsString.Data.ByteString.Short.Word16 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 new file mode 100644 --- /dev/null +++ b/System/OsString/Posix.hs @@ -0,0 +1,7 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/System/OsString/Windows.hs @@ -0,0 +1,13 @@ +{-# 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/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,15 @@ +module Main (main) where + +import Test.Tasty.Bench +import qualified BenchOsString +import qualified BenchPosixString +import qualified BenchWindowsString + + +main :: IO () +main = do + defaultMain [ BenchOsString.benchMark + , BenchPosixString.benchMark + , BenchWindowsString.benchMark + ] + diff --git a/bench/BenchOsString.hs b/bench/BenchOsString.hs new file mode 100644 --- /dev/null +++ b/bench/BenchOsString.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} + +#define OSSTR osstr +#define OS_STRING OsString +#define OS_CHAR OsChar + + +module BenchOsString (benchMark) where + +import System.OsString (osstr) +import qualified System.OsString as S +import System.OsString.Internal.Types (OsString(..), OsChar(..), PosixChar(..), WindowsChar(..)) + +#include "Common.hs" + +benchStr :: String +benchStr = "OsString" + +w :: Int -> OsChar +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +w i = OsChar (WindowsChar (fromIntegral i)) +#else +w i = OsChar (PosixChar (fromIntegral i)) +#endif + +hashWord8 :: OsChar -> OsChar +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +hashWord8 (OsChar (WindowsChar w)) = OsChar . WindowsChar . fromIntegral . hashInt . fromIntegral $ w +#else +hashWord8 (OsChar (PosixChar w)) = OsChar . PosixChar . fromIntegral . hashInt . fromIntegral $ w +#endif + +iw :: OsChar -> Int +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +iw (OsChar (WindowsChar w)) = fromIntegral w +#else +iw (OsChar (PosixChar w)) = fromIntegral w +#endif + diff --git a/bench/BenchPosixString.hs b/bench/BenchPosixString.hs new file mode 100644 --- /dev/null +++ b/bench/BenchPosixString.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} + +#define OSSTR pstr +#define OS_STRING PosixString +#define OS_CHAR PosixChar + + +module BenchPosixString (benchMark) where + +import System.OsString.Posix (PosixString, pstr) +import qualified System.OsString.Posix as S +import System.OsString.Internal.Types (PosixChar(..)) + +#include "Common.hs" + +benchStr :: String +benchStr = "PosixString" + +w :: Int -> PosixChar +w i = PosixChar (fromIntegral i) + +hashWord8 :: PosixChar -> PosixChar +hashWord8 (PosixChar w) = PosixChar . fromIntegral . hashInt . fromIntegral $ w + +iw :: PosixChar -> Int +iw (PosixChar w) = fromIntegral w + diff --git a/bench/BenchWindowsString.hs b/bench/BenchWindowsString.hs new file mode 100644 --- /dev/null +++ b/bench/BenchWindowsString.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} + +#define OSSTR pstr +#define OS_STRING WindowsString +#define OS_CHAR WindowsChar + + +module BenchWindowsString (benchMark) where + +import System.OsString.Windows (WindowsString, WindowsChar, pstr) +import qualified System.OsString.Windows as S +import System.OsString.Internal.Types (WindowsChar(..)) + +#include "Common.hs" + +benchStr :: String +benchStr = "WindowsString" + +w :: Int -> WindowsChar +w i = WindowsChar (fromIntegral i) + +hashWord8 :: WindowsChar -> WindowsChar +hashWord8 (WindowsChar w) = WindowsChar . fromIntegral . hashInt . fromIntegral $ w + +iw :: WindowsChar -> Int +iw (WindowsChar w) = fromIntegral w + diff --git a/bench/Common.hs b/bench/Common.hs new file mode 100644 --- /dev/null +++ b/bench/Common.hs @@ -0,0 +1,230 @@ +import Control.DeepSeq (force) +import Data.Foldable (foldMap) +import Data.Maybe (listToMaybe, fromJust) +import Data.Monoid +import Data.String +import Prelude hiding (words, head, tail) + +import Test.Tasty.Bench +import Data.ByteString.Builder +import Data.ByteString.Builder.Extra (byteStringCopy, byteStringInsert, intHost) +import Data.ByteString.Builder.Internal (ensureFree) +import Data.ByteString.Builder.Prim (BoundedPrim, FixedPrim, (>$<)) +import qualified Data.ByteString.Builder.Prim as P +import qualified Data.ByteString.Builder.Prim.Internal as PI + +import Foreign + +import System.Random +import Data.Bifunctor (first) + +------------------------------------------------------------------------------ +-- Benchmark +------------------------------------------------------------------------------ + +-- input data (NOINLINE to ensure memoization) +---------------------------------------------- + +-- | Few-enough repetitions to avoid making GC too expensive. +nRepl :: Int +nRepl = 10000 + +{-# NOINLINE intData #-} +intData :: [Int] +intData = [1..nRepl] + +{-# NOINLINE byteStringData #-} +byteStringData :: S.OS_STRING +byteStringData = S.pack $ map w intData + +{-# NOINLINE loremIpsum #-} +loremIpsum :: S.OS_STRING +loremIpsum = [OSSTR|incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis +nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. +Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu +fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in +culpa qui officia deserunt mollit anim id est laborum.|] + +-- benchmark wrappers +--------------------- + +{-# INLINE benchB' #-} +benchB' + :: String -> a -> (a -> OS_STRING) -> Benchmark +benchB' name x b = bench name $ whnf (S.length . b) x + + +-- We use this construction of just looping through @n,n-1,..,1@ to ensure that +-- we measure the speed of the encoding and not the speed of generating the +-- values to be encoded. +{-# INLINE benchIntEncodingB #-} +benchIntEncodingB :: Int -- ^ Maximal 'Int' to write + -> BoundedPrim Int -- ^ 'BoundedPrim' to execute + -> IO () -- ^ 'IO' action to benchmark +benchIntEncodingB n0 w + | n0 <= 0 = return () + | otherwise = do + fpbuf <- mallocForeignPtrBytes (n0 * PI.sizeBound w) + withForeignPtr fpbuf (loop n0) >> return () + where + loop !n !op + | n <= 0 = return op + | otherwise = PI.runB w n op >>= loop (n - 1) + + +-- Helpers +------------- + +hashInt :: Int -> Int +hashInt x = iterate step x !! 10 + where + step a = e + where b = (a `xor` 61) `xor` (a `shiftR` 16) + c = b + (b `shiftL` 3) + d = c `xor` (c `shiftR` 4) + e = d * 0x27d4eb2d + f = e `xor` (e `shiftR` 15) + + +foldInputs' + :: [[ OS_CHAR ]] +foldInputs' = force (S.unpack <$> foldInputs) + +foldInputs :: [S.OS_STRING] +foldInputs = map (\k -> S.pack . map w $ if k <= 6 then take (2 ^ k) [32..95] else concat (replicate (2 ^ (k - 6)) [32..95])) [0..16] + +largeTraversalInput :: S.OS_STRING +largeTraversalInput = S.concat (replicate 10 byteStringData) + +smallTraversalInput :: S.OS_STRING +smallTraversalInput = [OSSTR|The quick brown fox|] + +zeroes :: S.OS_STRING +zeroes = S.replicate 10000 (w 0) + +partitionStrict p = nf (S.partition p) . randomStrict $ mkStdGen 98423098 + where randomStrict = fst . S.unfoldrN 10000 (Just . first S.unsafeFromChar . random) + +-- ASCII \n to ensure no typos +nl :: OS_CHAR +nl = w 0xa +{-# INLINE nl #-} + +-- non-inlined equality test +nilEq :: OS_CHAR -> OS_CHAR -> Bool +{-# NOINLINE nilEq #-} +nilEq = (==) + +-- lines of 200 letters from a to e, followed by repeated letter f +absurdlong :: S.OS_STRING +absurdlong = (S.replicate 200 (w 0x61) <> S.singleton nl + <> S.replicate 200 (w 0x62) <> S.singleton nl + <> S.replicate 200 (w 0x63) <> S.singleton nl + <> S.replicate 200 (w 0x64) <> S.singleton nl + <> S.replicate 200 (w 0x65) <> S.singleton nl) + <> S.replicate 999999 (w 0x66) + +bench_find_index_second :: OS_STRING -> Maybe Int +bench_find_index_second bs = + let isNl = (== nl) + in case S.findIndex isNl bs of + Just !i -> S.findIndex isNl (S.drop (i+1) bs) + Nothing -> Nothing +{-# INLINE bench_find_index_second #-} + +bench_elem_index_second :: OS_STRING -> Maybe Int +bench_elem_index_second bs = + case S.elemIndex nl bs of + Just !i -> S.elemIndex nl (S.drop (i+1) bs) + Nothing -> Nothing +{-# INLINE bench_elem_index_second #-} + + + +-- benchmarks +------------- + +benchMark :: Benchmark +benchMark = absurdlong `seq` bgroup benchStr + [ bgroup "Small payload" + [ benchB' "mempty" () (const mempty) + , benchB' "UTF-8 String (naive)" "hello world\0" (fromJust . S.encodeUtf) + , benchB' "String (naive)" "hello world!" (fromJust . S.encodeUtf) + ] + , bgroup "intercalate" + [ bench "intercalate (large)" $ whnf (S.intercalate $ [OSSTR| and also |]) (replicate 300 [OSSTR|expression|]) + , bench "intercalate (small)" $ whnf (S.intercalate [OSSTR|&|]) (replicate 30 [OSSTR|foo|]) + , bench "intercalate (tiny)" $ whnf (S.intercalate [OSSTR|&|]) [[OSSTR|foo|], [OSSTR|bar|], [OSSTR|baz|]] + ] + , bgroup "partition" + [ + bgroup "strict" + [ + bench "mostlyTrueFast" $ partitionStrict (< (w 225)) + , bench "mostlyFalseFast" $ partitionStrict (< (w 10)) + , bench "balancedFast" $ partitionStrict (< (w 128)) + + , bench "mostlyTrueSlow" $ partitionStrict (\x -> hashWord8 x < w 225) + , bench "mostlyFalseSlow" $ partitionStrict (\x -> hashWord8 x < w 10) + , bench "balancedSlow" $ partitionStrict (\x -> hashWord8 x < w 128) + ] + ] + , bgroup "folds" + [ bgroup "strict" + [ bgroup "foldl" $ map (\s -> bench (show $ S.length s) $ + nf (S.foldl (\acc x -> acc + iw x) (0 :: Int)) s) foldInputs + , bgroup "foldl'" $ map (\s -> bench (show $ S.length s) $ + nf (S.foldl' (\acc x -> acc + iw x) (0 :: Int)) s) foldInputs + , bgroup "foldr" $ map (\s -> bench (show $ S.length s) $ + nf (S.foldr (\x acc -> iw x + acc) (0 :: Int)) s) foldInputs + , bgroup "foldr'" $ map (\s -> bench (show $ S.length s) $ + nf (S.foldr' (\x acc -> iw x + acc) (0 :: Int)) s) foldInputs + , bgroup "foldr1'" $ map (\s -> bench (show $ S.length s) $ + nf (S.foldr1' (\x acc -> w $ iw x + iw acc)) s) foldInputs + , bgroup "unfoldrN" $ map (\s -> bench (show $ S.length s) $ + nf (S.unfoldrN (S.length s) (\a -> Just (w a, a + 1))) 0) foldInputs + , bgroup "filter" $ map (\s -> bench (show $ S.length s) $ + nf (S.filter (odd . iw)) s) foldInputs + ] + ] + , bgroup "findIndexOrLength" + [ bench "takeWhile" $ nf (S.takeWhile (even . iw)) zeroes + , bench "dropWhile" $ nf (S.dropWhile (even . iw)) zeroes + , bench "break" $ nf (S.break (odd . iw)) zeroes + ] + , bgroup "findIndex_" + [ bench "findIndices" $ nf (sum . S.findIndices (\x -> x == w 129 || x == w 72)) byteStringData + , bench "find" $ nf (S.find (>= w 198)) byteStringData + ] + , bgroup "traversals" + [ bench "map (+1) large" $ nf (S.map (w . (+ 1) . iw)) largeTraversalInput + , bench "map (+1) small" $ nf (S.map (w . (+ 1) . iw)) smallTraversalInput + ] + , bgroup (benchStr <> " strict first index") $ + [ bench "FindIndices" $ nf (listToMaybe . S.findIndices (== nl)) absurdlong + , bench "ElemIndices" $ nf (listToMaybe . S.elemIndices nl) absurdlong + , bench "FindIndex" $ nf (S.findIndex (== nl)) absurdlong + , bench "ElemIndex" $ nf (S.elemIndex nl) absurdlong + ] + , bgroup (benchStr <> " strict second index") $ + [ bench "FindIndices" $ nf (listToMaybe . drop 1 . S.findIndices (== nl)) absurdlong + , bench "ElemIndices" $ nf (listToMaybe . drop 1 . S.elemIndices nl) absurdlong + , bench "FindIndex" $ nf bench_find_index_second absurdlong + , bench "ElemIndex" $ nf bench_elem_index_second absurdlong + ] + , bgroup (benchStr <> " index equality inlining") $ + [ bench "FindIndices/inlined" $ nf (S.findIndices (== nl)) absurdlong + , bench "FindIndices/non-inlined" $ nf (S.findIndices (nilEq nl)) absurdlong + , bench "FindIndex/inlined" $ nf (S.findIndex (== nl)) absurdlong + , bench "FindIndex/non-inlined" $ nf (S.findIndex (nilEq nl)) absurdlong + ] + , bgroup (benchStr <> " conversions") $ + [ bgroup "unpack" $ map (\s -> bench (show $ S.length s) $ + nf (\x -> S.unpack x) s) foldInputs + , bgroup "pack" $ map (\s -> bench (show $ length s) $ + nf S.pack s) foldInputs' + , bench "unpack and get last element" $ nf (\x -> last . S.unpack $ x) absurdlong + , bench "unpack and get first 120 elements" $ nf (\x -> take 120 . S.unpack $ x) absurdlong + ] + ] + diff --git a/os-string.cabal b/os-string.cabal --- a/os-string.cabal +++ b/os-string.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: os-string -version: 1.0.0 +version: 2.0.0 -- NOTE: Don't forget to update ./changelog.md license: BSD-3-Clause @@ -27,31 +27,12 @@ description: This package provides functionality for manipulating @OsString@ values, and is shipped with . - . - Version 1.0.0 (unlike the following versions) is a dummy package that prevents module name clashes - between os-string and filepath if used together. - . - If you simply want the newer os-string package, make sure to depend on the newer versions: - . - > library - > build-depends: - > os-string >= 2.0.0 - . - If you want to default to the older filepath provided OsString modules, but allow users to switch to the newer os-string, - you can provide a flag like so: - . - > flag os-string - > description: Use the new os-string package - > default: False - > manual: False - > - > library - > -- ... - > if flag(os-string) - > build-depends: os-string >= 2.0.0 - > else - > build-depends: filepath < 1.5, os-string < 2.0.0 +extra-source-files: + System/OsString/Common.hs + tests/bytestring-tests/Properties/Common.hs + bench/Common.hs + extra-doc-files: changelog.md README.md @@ -61,7 +42,69 @@ location: https://github.com/haskell/os-string library + exposed-modules: + System.OsString.Data.ByteString.Short + System.OsString.Data.ByteString.Short.Internal + System.OsString.Data.ByteString.Short.Word16 + System.OsString.Encoding + System.OsString.Encoding.Internal + System.OsString + System.OsString.Internal + System.OsString.Internal.Types + System.OsString.Posix + System.OsString.Windows + + other-extensions: + CPP + PatternGuards + + if impl(ghc >=7.2) + other-extensions: Safe + default-language: Haskell2010 build-depends: - filepath <1.5 + , base >=4.9 && <4.20 + , bytestring >=0.11.3.0 + , deepseq + , exceptions + , template-haskell + ghc-options: -Wall + +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.WindowsString + Properties.PosixString + Properties.OsString + Properties.ShortByteString.Word16 + TestUtil + + build-depends: + , base + , bytestring >=0.11.3.0 + , os-string + , QuickCheck >=2.7 && <2.15 + +benchmark bench + main-is: Bench.hs + other-modules: BenchOsString + BenchPosixString + BenchWindowsString + type: exitcode-stdio-1.0 + hs-source-dirs: bench + default-language: Haskell2010 + ghc-options: -O2 "-with-rtsopts=-A32m" + if impl(ghc >= 8.6) + ghc-options: -fproc-alignment=64 + build-depends: base, + bytestring, + os-string, + deepseq, + tasty-bench, + random diff --git a/tests/TestUtil.hs b/tests/TestUtil.hs new file mode 100644 --- /dev/null +++ b/tests/TestUtil.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module TestUtil( + module TestUtil, + module Test.QuickCheck, + module Data.List, + module Data.Maybe + ) where + +import Test.QuickCheck hiding ((==>)) +import Data.List +import Data.Maybe +import Control.Monad +import System.Environment + + +infixr 0 ==> +(==>) :: Bool -> Bool -> Bool +a ==> b = not a || b + +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/bytestring-tests/Main.hs b/tests/bytestring-tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/bytestring-tests/Main.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeApplications #-} + +module Main (main) where + +import qualified Properties.OsString as PropOs +import qualified Properties.PosixString as PropPos +import qualified Properties.WindowsString as PropWin +import qualified Properties.ShortByteString as PropSBS +import qualified Properties.ShortByteString.Word16 as PropSBSW16 +import TestUtil + +main :: IO () +main = runTests (PropSBS.tests ++ PropSBSW16.tests ++ PropWin.tests ++ PropPos.tests ++ PropOs.tests) diff --git a/tests/bytestring-tests/Properties/Common.hs b/tests/bytestring-tests/Properties/Common.hs new file mode 100644 --- /dev/null +++ b/tests/bytestring-tests/Properties/Common.hs @@ -0,0 +1,643 @@ +-- | +-- Module : Properties.ShortByteString +-- Copyright : (c) Andrew Lelechenko 2021 +-- License : BSD-style + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# 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 -Wno-unused-imports -Wno-unused-top-binds #-} + +#ifdef OSWORD +module Properties.OsString (tests) where +import System.OsString.Internal.Types (OsString(..), OsChar(..), getOsChar) +import qualified System.OsString as B +import qualified System.OsString as BS +import qualified System.OsString.Data.ByteString.Short.Internal as BSI (_nul, isSpace) + +#else + +#ifdef WORD16 +#ifdef WIN +module Properties.WindowsString (tests) where +import qualified System.OsString.Windows as B +import qualified System.OsString.Windows as BS +#else +module Properties.ShortByteString.Word16 (tests) where +import System.OsString.Data.ByteString.Short.Internal (_nul, isSpace) +import qualified System.OsString.Data.ByteString.Short.Word16 as B +import qualified System.OsString.Data.ByteString.Short as BS +#endif +#else +#ifdef POSIX +module Properties.PosixString (tests) where +import qualified System.OsString.Posix as B +import qualified System.OsString.Posix as BS +#else +module Properties.ShortByteString (tests) where +import qualified System.OsString.Data.ByteString.Short as B +#endif +#endif +#endif + +import Data.ByteString.Short (ShortByteString) + +import qualified Data.Char as C +import qualified System.OsString.Data.ByteString.Short.Word16 as B16 +import qualified System.OsString.Data.ByteString.Short as B8 + +import Data.Word + +import Control.Arrow +import Data.Foldable +import Data.List as L +import Data.Semigroup +import Data.Tuple +import Test.QuickCheck +import Test.QuickCheck.Monadic ( monadicIO, run ) +import Text.Show.Functions () + +import System.OsString.Internal.Types (WindowsString(..), WindowsChar(..), getWindowsChar, PosixChar(..), PosixString(..), getPosixChar, OsString(..), OsChar(..), getOsChar) +import qualified System.OsString.Posix as PBS +import qualified System.OsString.Windows as WBS +import qualified System.OsString as OBS +import qualified System.OsString.Data.ByteString.Short.Internal as BSI (_nul, isSpace) + + +instance Arbitrary PosixString where + arbitrary = do + bs <- sized sizedByteString' + n <- choose (0, 2) + return (PBS.drop n bs) -- to give us some with non-0 offset + where + sizedByteString' :: Int -> Gen PosixString + sizedByteString' n = do m <- choose(0, n) + fmap (PosixString . B8.pack) $ vectorOf m arbitrary + +instance Arbitrary PosixChar where + arbitrary = fmap PosixChar (arbitrary @Word8) + +instance CoArbitrary PosixChar where + coarbitrary s = coarbitrary (PBS.toChar s) + +instance CoArbitrary PosixString where + coarbitrary s = coarbitrary (PBS.unpack s) + +deriving instance Num PosixChar + +deriving instance Bounded PosixChar + +instance Arbitrary WindowsString where + arbitrary = do + bs <- sized sizedByteString' + n <- choose (0, 2) + return (WBS.drop n bs) -- to give us some with non-0 offset + where + sizedByteString' :: Int -> Gen WindowsString + sizedByteString' n = do m <- choose(0, n) + fmap (WindowsString . B16.pack) $ vectorOf m arbitrary + +instance Arbitrary WindowsChar where + arbitrary = fmap WindowsChar (arbitrary @Word16) + +instance CoArbitrary WindowsChar where + coarbitrary s = coarbitrary (WBS.toChar s) + +instance CoArbitrary WindowsString where + coarbitrary s = coarbitrary (WBS.unpack s) + +deriving instance Num WindowsChar + +deriving instance Bounded WindowsChar + +isSpaceWin :: WindowsChar -> Bool +isSpaceWin = BSI.isSpace . getWindowsChar + +numWordWin :: WindowsString -> Int +numWordWin = B16.numWord16 . getWindowsString + + +swapWWin :: WindowsChar -> WindowsChar +swapWWin = WindowsChar . byteSwap16 . getWindowsChar + +isSpacePosix :: PosixChar -> Bool +isSpacePosix = C.isSpace . word8ToChar . getPosixChar + +numWordPosix :: PosixString -> Int +numWordPosix = B8.length . getPosixString + + +swapWPosix :: PosixChar -> PosixChar +swapWPosix = id + +#ifdef OSWORD +isSpace :: OsChar -> Bool +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +isSpace = isSpaceWin . getOsChar +#else +isSpace = isSpacePosix . getOsChar +#endif + +numWord :: OsString -> Int +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +numWord = numWordWin . getOsString +#else +numWord = numWordPosix . getOsString +#endif + +toElem :: OsChar -> OsChar +toElem = id + +swapW :: OsChar -> OsChar +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +swapW = OsChar . swapWWin . getOsChar +#else +swapW = OsChar . swapWPosix . getOsChar +#endif + +instance Arbitrary OsString where + arbitrary = OsString <$> arbitrary + +instance Arbitrary OsChar where + arbitrary = OsChar <$> arbitrary + +instance CoArbitrary OsChar where + coarbitrary s = coarbitrary (OBS.toChar s) + +instance CoArbitrary OsString where + coarbitrary s = coarbitrary (OBS.unpack s) + +deriving instance Num OsChar +deriving instance Bounded OsChar + +instance Arbitrary ShortByteString where +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) + arbitrary = getWindowsString <$> arbitrary +#else + arbitrary = getPosixString <$> arbitrary +#endif + +#else + +#ifdef WORD16 + +instance Arbitrary ShortByteString where + arbitrary = do + bs <- sized sizedByteString + n <- choose (0, 2) + return (B16.drop n bs) -- to give us some with non-0 offset + where + sizedByteString :: Int -> Gen ShortByteString + sizedByteString n = do m <- choose(0, n) + fmap B16.pack $ vectorOf m arbitrary + +instance CoArbitrary ShortByteString where + coarbitrary s = coarbitrary (B16.unpack s) +#ifdef WIN + +isSpace :: WindowsChar -> Bool +isSpace = isSpaceWin + +numWord :: WindowsString -> Int +numWord = numWordWin + +toElem :: WindowsChar -> WindowsChar +toElem = id + +swapW :: WindowsChar -> WindowsChar +swapW = swapWWin + +#else +numWord :: ShortByteString -> Int +numWord = B.numWord16 + +toElem :: Word16 -> Word16 +toElem = id + +swapW :: Word16 -> Word16 +swapW = byteSwap16 + + +#endif +#else +#ifdef POSIX + +isSpace :: PosixChar -> Bool +isSpace = isSpacePosix + +numWord :: PosixString -> Int +numWord = numWordPosix + +toElem :: PosixChar -> PosixChar +toElem = id + +swapW :: PosixChar -> PosixChar +swapW = swapWPosix + +#else +_nul :: Word8 +_nul = 0x00 + +isSpace :: Word8 -> Bool +isSpace = C.isSpace . word8ToChar + + +numWord :: ShortByteString -> Int +numWord = B8.length + +toElem :: Word8 -> Word8 +toElem = id + +swapW :: Word8 -> Word8 +swapW = id + + + +#endif + +instance Arbitrary ShortByteString where + arbitrary = do + bs <- sized sizedByteString' + n <- choose (0, 2) + return (B8.drop n bs) -- to give us some with non-0 offset + where + sizedByteString' :: Int -> Gen ShortByteString + sizedByteString' n = do m <- choose(0, n) + fmap B8.pack $ vectorOf m arbitrary + shrink = map B8.pack . shrink . B8.unpack + +instance CoArbitrary ShortByteString where + coarbitrary s = coarbitrary (B8.unpack s) +#endif +#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 `mappend` 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 +#ifdef WIN + , ("isInfixOf works correctly under UTF16", + once $ + let foo = WindowsString $ B8.pack [0xbb, 0x03] + foo' = WindowsString $ B8.pack [0xd2, 0xbb] + bar = WindowsString $ B8.pack [0xd2, 0xbb, 0x03, 0xad] + bar' = WindowsString $ B8.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] + ) +#else + , ("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 +#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 `mappend` y) === B.unpack x `mappend` 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)) + -- +#if defined(WORD16) && !defined(WIN) && !defined(OSWORD) && !defined(POSIX) + , ("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'))) +#endif +#if !defined(WORD16) && !defined(WIN) && !defined(OSWORD) && !defined(POSIX) + , ("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 + +#if !MIN_VERSION_base(4, 19, 0) +unsnoc :: [a] -> Maybe ([a], a) +unsnoc [] = Nothing +unsnoc xs = Just (init xs, last xs) +#endif + +-- | Total conversion to char. +word8ToChar :: Word8 -> Char +word8ToChar = C.chr . fromIntegral diff --git a/tests/bytestring-tests/Properties/OsString.hs b/tests/bytestring-tests/Properties/OsString.hs new file mode 100644 --- /dev/null +++ b/tests/bytestring-tests/Properties/OsString.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE CPP #-} +#undef WORD16 +#undef POSIX +#undef WIN +#define OSWORD +#include "Common.hs" + diff --git a/tests/bytestring-tests/Properties/PosixString.hs b/tests/bytestring-tests/Properties/PosixString.hs new file mode 100644 --- /dev/null +++ b/tests/bytestring-tests/Properties/PosixString.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE CPP #-} +#undef WORD16 +#define POSIX +#undef WIN +#undef OSWORD +#include "Common.hs" + diff --git a/tests/bytestring-tests/Properties/ShortByteString.hs b/tests/bytestring-tests/Properties/ShortByteString.hs new file mode 100644 --- /dev/null +++ b/tests/bytestring-tests/Properties/ShortByteString.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE CPP #-} +#undef WORD16 +#undef WIN +#undef POSIX +#undef OSWORD +#include "Common.hs" + diff --git a/tests/bytestring-tests/Properties/ShortByteString/Word16.hs b/tests/bytestring-tests/Properties/ShortByteString/Word16.hs new file mode 100644 --- /dev/null +++ b/tests/bytestring-tests/Properties/ShortByteString/Word16.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE CPP #-} +#define WORD16 +#undef WIN +#undef POSIX +#undef OSWORD +#include "../Common.hs" diff --git a/tests/bytestring-tests/Properties/WindowsString.hs b/tests/bytestring-tests/Properties/WindowsString.hs new file mode 100644 --- /dev/null +++ b/tests/bytestring-tests/Properties/WindowsString.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE CPP #-} +#define WORD16 +#define WIN +#undef POSIX +#undef OSWORD +#include "Common.hs" +