diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Revision history for Z-Data +## 0.7.1.0 -- 2020-03-03 + +* Add `CPtr` type, a more lightweight foreign pointer. +* Add `toLower/toUpper/toLowerLatin/toUpperLatin` to `Z.Data.ASCII`. + ## 0.7.0.0 -- 2020-03-03 * Add more patterns to `Z.Data.ASCII`. diff --git a/Z-Data.cabal b/Z-Data.cabal --- a/Z-Data.cabal +++ b/Z-Data.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: Z-Data -version: 0.7.0.0 +version: 0.7.1.0 synopsis: Array, vector and text description: This package provides array, slice and text operations license: BSD-3-Clause @@ -164,6 +164,7 @@ Z.Data.Vector.Search Z.Data.Vector.Sort Z.Foreign + Z.Foreign.CPtr build-depends: , base >=4.12 && <5.0 diff --git a/Z/Data/ASCII.hs b/Z/Data/ASCII.hs --- a/Z/Data/ASCII.hs +++ b/Z/Data/ASCII.hs @@ -43,6 +43,38 @@ {-# INLINE isLower #-} isLower w = w - LETTER_a <= 25 +-- | @A ~ Z@ => @a ~ z@ +toLower :: Word8 -> Word8 +{-# INLINE toLower #-} +toLower w + | 65 <= w && w <= 90 = w + 32 + | otherwise = w + +-- | @a ~ z@ => @A ~ Z@ +toUpper :: Word8 -> Word8 +{-# INLINE toUpper #-} +toUpper w + | 97 <= w && w <= 122 = w - 32 + | otherwise = w + +-- | @A ~ Z@ => @a ~ z@, @À ~ Ö@ => @à ~ ö@, @Ø ~ Þ@ => @ø ~ þ@ +toLowerLatin :: Word8 -> Word8 +{-# INLINE toLowerLatin #-} +toLowerLatin w + | 65 <= w && w <= 90 || + 192 <= w && w <= 214 || + 216 <= w && w <= 222 = w + 32 + | otherwise = w + +-- | @a ~ z@ => @A ~ Z@, @à ~ ö@ => @À ~ Ö@, @ø ~ þ@ => @Ø ~ Þ@ +toUpperLatin :: Word8 -> Word8 +{-# INLINE toUpperLatin #-} +toUpperLatin w + | 97 <= w && w <= 122 || + 224 <= w && w <= 246 || + 248 <= w && w <= 254 = w - 32 + | otherwise = w + -- | @ISO-8859-1@ control letter. isControl :: Word8 -> Bool {-# INLINE isControl #-} diff --git a/Z/Data/Array.hs b/Z/Data/Array.hs --- a/Z/Data/Array.hs +++ b/Z/Data/Array.hs @@ -9,15 +9,17 @@ Unified unboxed and boxed array operations using type family. -All operations are NOT bound checked, if you need checked operations please use "Z.Data.Array.Checked". -It exports exactly same APIs so that you can switch between without pain. +NONE of the operations are bound checked, if you need checked operations please use "Z.Data.Array.Checked" instead. +It exports the exact same APIs ,so it requires no extra effort to switch between them. Some mnemonics: - * 'newArr', 'newArrWith' return mutable array, 'readArr', 'writeArr' works on them, 'setArr' fill elements - with offset and length. + * 'newArr' and 'newArrWith' return mutable array. + 'readArr' and 'writeArr' perform read and write actions on mutable arrays. + 'setArr' fills the elements with offset and length. - * 'indexArr' works on immutable one, use 'indexArr'' to avoid indexing thunk. + * 'indexArr' can only work on immutable Array. + Use 'indexArr'' to avoid thunks building up in the heap. * The order of arguements of 'copyArr', 'copyMutableArr' and 'moveArr' are always target and its offset come first, and source and source offset follow, copying length comes last. @@ -39,7 +41,7 @@ , PrimArray(..) , MutablePrimArray(..) , Prim(..) - -- * Primitive Array operations + -- * Primitive array operations , newPinnedPrimArray, newAlignedPinnedPrimArray , copyPrimArrayToPtr, copyMutablePrimArrayToPtr, copyPtrToMutablePrimArray , primArrayContents, mutablePrimArrayContents, withPrimArrayContents, withMutablePrimArrayContents @@ -58,14 +60,15 @@ , sizeOf ) where -import Control.Exception (ArrayException (..), throw) +import Control.Exception (ArrayException (..), throw) import Control.Monad import Control.Monad.Primitive import Control.Monad.ST +import Data.Kind (Type) import Data.Primitive.Array import Data.Primitive.ByteArray import Data.Primitive.PrimArray -import Data.Primitive.Ptr (copyPtrToMutablePrimArray) +import Data.Primitive.Ptr (copyPtrToMutablePrimArray) import Data.Primitive.SmallArray import Data.Primitive.Types import GHC.Exts @@ -74,35 +77,35 @@ -- | Bottom value (@throw ('UndefinedElement' 'Data.Array.uninitialized')@) --- for initialize new boxed array('Array', 'SmallArray'..). +-- for new boxed array('Array', 'SmallArray'..) initialization. -- uninitialized :: a uninitialized = throw (UndefinedElement "Data.Array.uninitialized") --- | A typeclass to unify box & unboxed, mutable & immutable array operations. +-- | The typeclass that unifies box & unboxed and mutable & immutable array operations. -- --- Most of these functions simply wrap their primitive counterpart, if there's no primitive ones, --- we polyfilled using other operations to get the same semantics. +-- Most of these functions simply wrap their primitive counterpart. +-- When there are no primitive ones, we fulfilled the semantic with other operations. -- --- One exception is that 'shrinkMutableArr' only perform closure resizing on 'PrimArray' because --- current RTS support only that, 'shrinkMutableArr' will do nothing on other array type. +-- One exception is 'shrinkMutableArr' which only performs closure resizing on 'PrimArray', because +-- currently, RTS only supports that. 'shrinkMutableArr' won't do anything on other array types. -- --- It's reasonable to trust GHC with specializing & inlining these polymorphric functions. --- They are used across this package and perform identical to their monomophric counterpart. +-- It's reasonable to trust GHC to specialize & inline these polymorphic functions. +-- They are used across this package and perform identically to their monomorphic counterpart. -- -class Arr (arr :: * -> * ) a where +class Arr (arr :: Type -> Type) a where - -- | Mutable version of this array type. + -- | The mutable version of this array type. -- - type MArr arr = (mar :: * -> * -> *) | mar -> arr + type MArr arr = (mar :: Type -> Type -> Type) | mar -> arr - -- | Make a new array with given size. + -- | Make a new array with a given size. -- - -- For boxed array, all elements are 'uninitialized' which shall not be accessed. - -- For primitive array, elements are just random garbage. + -- For boxed arrays, all elements are 'uninitialized' , which shall not be accessed. + -- For primitive arrays, elements are just random garbage. newArr :: (PrimMonad m, PrimState m ~ s) => Int -> m (MArr arr s a) @@ -110,97 +113,123 @@ newArrWith :: (PrimMonad m, PrimState m ~ s) => Int -> a -> m (MArr arr s a) - -- | Index mutable array in a primitive monad. + -- | Read from specified index of mutable array in a primitive monad. readArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> m a - -- | Write mutable array in a primitive monad. + -- | Write to specified index of mutable array in a primitive monad. writeArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> a -> m () - -- | Fill mutable array with a given value. + -- | Fill the mutable array with a given value. setArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> Int -> a -> m () - -- | Index immutable array, which is a pure operation. This operation often - -- result in an indexing thunk for lifted arrays, use 'indexArr\'' or 'indexArrM' - -- if that's not desired. + -- | Read from the specified index of an immutable array. It's pure and often + -- results in an indexing thunk for lifted arrays, use 'indexArr\'' or 'indexArrM' to avoid this. indexArr :: arr a -> Int -> a - -- | Index immutable array, pattern match on the unboxed unit tuple to force - -- indexing (without forcing the element). + -- | Read from the specified index of an immutable array. The result is packaged into an unboxed unary tuple; the result itself is not yet evaluated. + -- Pattern matching on the tuple forces the indexing of the array to happen but does not evaluate the element itself. + -- Evaluating the thunk prevents additional thunks from building up on the heap. + -- Avoiding these thunks, in turn, reduces references to the argument array, allowing it to be garbage collected more promptly. indexArr' :: arr a -> Int -> (# a #) - -- | Index immutable array in a primitive monad, this helps in situations that - -- you want your indexing result is not a thunk referencing whole array. + -- | Monadically read a value from the immutable array at the given index. + -- This allows us to be strict in the array while remaining lazy in the read + -- element which is very useful for collective operations. Suppose we want to + -- copy an array. We could do something like this: + -- + -- > copy marr arr ... = do ... + -- > writeArray marr i (indexArray arr i) ... + -- > ... + -- + -- But since primitive arrays are lazy, the calls to 'indexArray' will not be + -- evaluated. Rather, @marr@ will be filled with thunks each of which would + -- retain a reference to @arr@. This is definitely not what we want! + -- + -- With 'indexArrayM', we can instead write + -- + -- > copy marr arr ... = do ... + -- > x <- indexArrayM arr i + -- > writeArray marr i x + -- > ... + -- + -- Now, indexing is executed immediately although the returned element is + -- still not evaluated. + -- + -- /Note:/ this function does not do bounds checking. indexArrM :: (Monad m) => arr a -> Int -> m a - -- | Safely freeze mutable array by make a immutable copy of its slice. + -- | Create an immutable copy of a slice of an array. + -- This operation makes a copy of the specified section, so it is safe to continue using the mutable array afterward. freezeArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> Int -> m (arr a) - -- | Safely thaw immutable array by make a mutable copy of its slice. + -- | Create a mutable array from a slice of an immutable array. + -- This operation makes a copy of the specified slice, so it is safe to use the immutable array afterward. thawArr :: (PrimMonad m, PrimState m ~ s) => arr a -> Int -> Int -> m (MArr arr s a) - -- | In place freeze a mutable array, the original mutable array can not be used - -- anymore. + -- | Convert a mutable array to an immutable one without copying. + -- The array should not be modified after the conversion. unsafeFreezeArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> m (arr a) - -- | In place thaw a immutable array, the original immutable array can not be used - -- anymore. + + -- | Convert a mutable array to an immutable one without copying. The + -- array should not be modified after the conversion. unsafeThawArr :: (PrimMonad m, PrimState m ~ s) => arr a -> m (MArr arr s a) - -- | Copy a slice of immutable array to mutable array at given offset. + -- | Copy a slice of an immutable array to a mutable array at given offset. copyArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -- ^ target - -> Int -- ^ target offset + -> Int -- ^ offset into target array -> arr a -- ^ source - -> Int -- ^ source offset - -> Int -- ^ source length + -> Int -- ^ offset into source array + -> Int -- ^ number of elements to copy -> m () - -- | Copy a slice of mutable array to mutable array at given offset. - -- The two mutable arrays shall no be the same one. + -- | Copy a slice of a mutable array to another mutable array at given offset. + -- The two mutable arrays must not be the same. copyMutableArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -- ^ target - -> Int -- ^ target offset + -> Int -- ^ offset into target array -> MArr arr s a -- ^ source - -> Int -- ^ source offset - -> Int -- ^ source length + -> Int -- ^ offset into source array + -> Int -- ^ number of elements to copy -> m () - -- | Copy a slice of mutable array to mutable array at given offset. - -- The two mutable arrays may be the same one. + -- | Copy a slice of a mutable array to a mutable array at given offset. + -- The two mutable arrays can be the same. moveArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -- ^ target - -> Int -- ^ target offset + -> Int -- ^ offset into target array -> MArr arr s a -- ^ source - -> Int -- ^ source offset - -> Int -- ^ source length + -> Int -- ^ offset into source array + -> Int -- ^ number of elements to copy -> m () - -- | Create immutable copy. + -- | Create an immutable copy with the given subrange of the original array. cloneArr :: arr a -> Int -> Int -> arr a - -- | Create mutable copy. + -- | Create a mutable copy the given subrange of the original array. cloneMutableArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> Int -> m (MArr arr s a) - -- | Resize mutable array to given size. + -- | Resize a mutable array to the given size. resizeMutableArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> m (MArr arr s a) - -- | Shrink mutable array to given size. This operation only works on primitive arrays. + -- | Shrink a mutable array to the given size. This operation only works on primitive arrays. -- For some array types, this is a no-op, e.g. 'sizeOfMutableArr' will not change. shrinkMutableArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> m () @@ -209,21 +238,21 @@ sameMutableArr :: MArr arr s a -> MArr arr s a -> Bool - -- | Size of immutable array. + -- | Size of the immutable array. sizeofArr :: arr a -> Int - -- | Size of mutable array. + -- | Size of the mutable array. sizeofMutableArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> m Int - -- | Is two immutable array are referencing the same one. + -- | Check whether the two immutable arrays refer to the same memory block -- - -- Note that 'sameArr' 's result may change depending on compiler's optimizations, for example + -- Note that the result of 'sameArr' may change depending on compiler's optimizations, for example, -- @let arr = runST ... in arr `sameArr` arr@ may return false if compiler decides to -- inline it. -- - -- See https://ghc.haskell.org/trac/ghc/ticket/13908 for more background. + -- See https://ghc.haskell.org/trac/ghc/ticket/13908 for more context. -- sameArr :: arr a -> arr a -> Bool @@ -553,10 +582,10 @@ -------------------------------------------------------------------------------- --- | Yield a pointer to the array's data and do computation with it. +-- | Obtain the pointer to the content of an array, and the pointer should only be used during the IO action. -- --- This operation is only safe on /pinned/ primitive arrays allocated by 'newPinnedPrimArray' or --- 'newAlignedPinnedPrimArray'. +-- This operation is only safe on /pinned/ primitive arrays (Arrays allocated by 'newPinnedPrimArray' or +-- 'newAlignedPinnedPrimArray'). -- -- Don't pass a forever loop to this function, see . withPrimArrayContents :: PrimArray a -> (Ptr a -> IO b) -> IO b @@ -568,10 +597,10 @@ primitive_ (touch# ba#) return b --- | Yield a pointer to the array's data and do computation with it. +-- | Obtain the pointer to the content of an mutable array, and the pointer should only be used during the IO action. -- --- This operation is only safe on /pinned/ primitive arrays allocated by 'newPinnedPrimArray' or --- 'newAlignedPinnedPrimArray'. +-- This operation is only safe on /pinned/ primitive arrays (Arrays allocated by 'newPinnedPrimArray' or +-- 'newAlignedPinnedPrimArray'). -- -- Don't pass a forever loop to this function, see . withMutablePrimArrayContents :: MutablePrimArray RealWorld a -> (Ptr a -> IO b) -> IO b @@ -608,7 +637,8 @@ writeArr marr 1 y unsafeFreezeArr marr --- | Modify(strictly) an immutable array's element at given index to produce a new array. +-- | Modify(strictly) an immutable some elements of an array with specified subrange. +-- This function will produce a new array. modifyIndexArr :: Arr arr a => arr a -> Int -- ^ offset @@ -623,13 +653,13 @@ writeArr marr ix v unsafeFreezeArr marr --- | Insert an immutable array's element at given index to produce a new array. +-- | Insert a value to an immutable array at given index. This function will produce a new array. insertIndexArr :: Arr arr a => arr a -> Int -- ^ offset -> Int -- ^ length -> Int -- ^ insert index in new array - -> a -- ^ element to be inserted + -> a -- ^ value to be inserted -> arr a {-# INLINE insertIndexArr #-} insertIndexArr arr s l i x = runST $ do @@ -638,12 +668,12 @@ when (i arr a -> Int -- ^ offset -> Int -- ^ length - -> Int -- ^ drop index in new array + -> Int -- ^ the index of the element to delete -> arr a {-# INLINE deleteIndexArr #-} deleteIndexArr arr s l i = runST $ do diff --git a/Z/Data/Builder/Base.hs b/Z/Data/Builder/Base.hs --- a/Z/Data/Builder/Base.hs +++ b/Z/Data/Builder/Base.hs @@ -55,6 +55,7 @@ import Control.Monad import Control.Monad.Primitive import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.)) +import Data.Primitive.Ptr (copyPtrToMutablePrimArray) import Data.Word import Data.Int import GHC.CString (unpackCString#, unpackCStringUtf8#) @@ -67,7 +68,6 @@ import qualified Z.Data.Text.UTF8Codec as T import qualified Z.Data.Vector.Base as V import qualified Z.Data.Array as A -import Z.Foreign import System.IO.Unsafe import Test.QuickCheck.Arbitrary (Arbitrary(..), CoArbitrary(..)) diff --git a/Z/Data/Parser.hs b/Z/Data/Parser.hs --- a/Z/Data/Parser.hs +++ b/Z/Data/Parser.hs @@ -39,8 +39,9 @@ , decodePrimLE, decodePrimBE -- * More parsers , scan, scanChunks, peekMaybe, peek, satisfy, satisfyWith - , anyWord8, word8, anyChar8, char8, skipWord8, endOfLine, skip, skipWhile, skipSpaces - , take, takeTill, takeWhile, takeWhile1, takeRemaining, bytes, bytesCI + , anyWord8, word8, char8, anyChar8, anyCharUTF8, charUTF8, char7, anyChar7 + , skipWord8, endOfLine, skip, skipWhile, skipSpaces + , take, takeN, takeTill, takeWhile, takeWhile1, takeRemaining, bytes, bytesCI , text -- * Numeric parsers -- ** Decimal diff --git a/Z/Data/Parser/Base.hs b/Z/Data/Parser/Base.hs --- a/Z/Data/Parser/Base.hs +++ b/Z/Data/Parser/Base.hs @@ -28,7 +28,8 @@ , decodePrimLE, decodePrimBE -- * More parsers , scan, scanChunks, peekMaybe, peek, satisfy, satisfyWith - , anyWord8, word8, anyChar8, char8, skipWord8, endOfLine, skip, skipWhile, skipSpaces + , anyWord8, word8, char8, anyChar8, anyCharUTF8, charUTF8, char7, anyChar7 + , skipWord8, endOfLine, skip, skipWhile, skipSpaces , take, takeN, takeTill, takeWhile, takeWhile1, takeRemaining, bytes, bytesCI , text -- * Misc @@ -42,13 +43,16 @@ import qualified Data.Primitive.PrimArray as A import Data.Int import Data.Word +import Data.Bits ((.&.)) import GHC.Types import Prelude hiding (take, takeWhile) import Z.Data.Array.Unaligned import Z.Data.ASCII -import qualified Z.Data.Text.Base as T -import qualified Z.Data.Vector.Base as V -import qualified Z.Data.Vector.Extra as V +import qualified Z.Data.Text.Base as T +import qualified Z.Data.Text.Extra as T +import qualified Z.Data.Text.UTF8Codec as T +import qualified Z.Data.Vector.Base as V +import qualified Z.Data.Vector.Extra as V -- | Simple parsing result, that represent respectively: -- @@ -479,6 +483,18 @@ {-# INLINE char8 #-} char8 = word8 . c2w +-- | Match a specific 7bit char. +-- +char7 :: Char -> Parser () +{-# INLINE char7 #-} +char7 chr = word8 (c2w chr .&. 0x7F) + +-- | Match a specific UTF8 char. +-- +charUTF8 :: Char -> Parser () +{-# INLINE charUTF8 #-} +charUTF8 = text . T.singleton + -- | Take a byte and return as a 8bit char. -- anyChar8 :: Parser Char @@ -486,6 +502,40 @@ anyChar8 = do w <- anyWord8 return $! w2c w + +-- | Take a byte and return as a 7bit char, fail if exceeds @0x7F@. +-- +anyChar7 :: Parser Char +{-# INLINE anyChar7 #-} +anyChar7 = do + w <- anyWord8 + if w > 0x7f + then fail' "Z.Data.Parser.anyChar7: byte exceeds 0x7F" + else return $! w2c w + +-- | Decode next few bytes as an UTF8 char. +-- +-- Don't use this method as UTF8 decoder, it's slower than 'T.validate'. +anyCharUTF8 :: Parser Char +{-# INLINABLE anyCharUTF8 #-} +anyCharUTF8 = do + r <- Parser $ \ kf k inp -> do + let (V.PrimVector arr s l) = inp + if l > 0 + then + let l' = T.decodeCharLen arr s + in if l' > l + then k (Left l') inp + else do + case T.validateMaybe (V.unsafeTake l' inp) of + Just t -> k (Right $! T.head t) $! V.unsafeDrop l' inp + _ -> kf ["Z.Data.Parser.Base.anyCharUTF8: invalid UTF8 bytes"] inp + else k (Left 1) inp + case r of + Left d -> do + ensureN d ["Z.Data.Parser.Base.anyCharUTF8: not enough bytes"] + anyCharUTF8 + Right c -> return c -- | Match either a single newline byte @\'\\n\'@, or a carriage -- return followed by a newline byte @\"\\r\\n\"@. diff --git a/Z/Data/Text/Regex.hs b/Z/Data/Text/Regex.hs --- a/Z/Data/Text/Regex.hs +++ b/Z/Data/Text/Regex.hs @@ -28,25 +28,26 @@ , extract ) where -import Z.Foreign import Control.Exception +import Control.Monad import Data.Int import Data.Word import GHC.Stack import GHC.Generics -import Foreign.ForeignPtr import Foreign.Marshal.Utils (fromBool) import System.IO.Unsafe import qualified Z.Data.Text.Base as T import qualified Z.Data.Text.Print as T import qualified Z.Data.Vector.Base as V import qualified Z.Data.Array as A +import Z.Foreign.CPtr +import Z.Foreign -- | A compiled RE2 regex. data Regex = Regex - { regexPtr :: {-# UNPACK #-} !(ForeignPtr Regex) - , regexCaptureNum :: {-# UNPACK #-} !Int -- ^ capturing group number(including @\\0@) - , regexPattern :: T.Text -- ^ Get back regex's pattern. + { regexPtr :: {-# UNPACK #-} !(CPtr Regex) + , regexCaptureNum :: {-# UNPACK #-} !Int -- ^ capturing group number(including @\\0@) + , regexPattern :: T.Text -- ^ Get back regex's pattern. } deriving (Show, Generic) deriving anyclass T.Print @@ -113,44 +114,44 @@ regex :: HasCallStack => T.Text -> Regex {-# NOINLINE regex #-} regex t = unsafePerformIO $ do - r <- withPrimVectorUnsafe (T.getUTF8Bytes t) hs_re2_compile_pattern_default + (cp, r) <- newCPtrUnsafe (\ mba# -> + (withPrimVectorUnsafe (T.getUTF8Bytes t) (hs_re2_compile_pattern_default mba#))) + p_hs_re2_delete_pattern + + when (r == nullPtr) (throwIO (InvalidRegexPattern t callStack)) ok <- hs_re2_ok r - if ok /= 0 - then do - p <- newForeignPtr p_hs_re2_delete_pattern r - n <- hs_num_capture_groups r - return (Regex p n t) - else do - hs_re2_delete_pattern r - throwIO (InvalidRegexPattern t callStack) + when (ok == 0) (throwIO (InvalidRegexPattern t callStack)) + n <- withCPtr cp hs_num_capture_groups + return (Regex cp n t) + -- | Compile a regex pattern withOptions, throw 'InvalidRegexPattern' in case of illegal patterns. regexOpts :: HasCallStack => RegexOpts -> T.Text -> Regex {-# NOINLINE regexOpts #-} regexOpts RegexOpts{..} t = unsafePerformIO $ do - r <- withPrimVectorUnsafe (T.getUTF8Bytes t) $ \ p o l -> - hs_re2_compile_pattern p o l - (fromBool posix_syntax ) - (fromBool longest_match ) - max_mem - (fromBool literal ) - (fromBool never_nl ) - (fromBool dot_nl ) - (fromBool never_capture ) - (fromBool case_sensitive) - (fromBool perl_classes ) - (fromBool word_boundary ) - (fromBool one_line ) + (cp, r) <- newCPtrUnsafe ( \ mba# -> + (withPrimVectorUnsafe (T.getUTF8Bytes t) $ \ p o l -> + hs_re2_compile_pattern mba# p o l + (fromBool posix_syntax ) + (fromBool longest_match ) + max_mem + (fromBool literal ) + (fromBool never_nl ) + (fromBool dot_nl ) + (fromBool never_capture ) + (fromBool case_sensitive) + (fromBool perl_classes ) + (fromBool word_boundary ) + (fromBool one_line ))) + p_hs_re2_delete_pattern + + when (r == nullPtr) (throwIO (InvalidRegexPattern t callStack)) ok <- hs_re2_ok r - if ok /= 0 - then do - p <- newForeignPtr p_hs_re2_delete_pattern r - n <- hs_num_capture_groups r - return (Regex p n t) - else do - hs_re2_delete_pattern r - throwIO (InvalidRegexPattern t callStack) + when (ok == 0) (throwIO (InvalidRegexPattern t callStack)) + n <- withCPtr cp hs_num_capture_groups + return (Regex cp n t) + -- | Escape a piece of text literal so that it can be safely used in regex pattern. -- -- >>> escape "(\\d+)" @@ -165,7 +166,7 @@ test :: Regex -> T.Text -> Bool {-# INLINABLE test #-} test (Regex fp _ _) (T.Text bs) = unsafePerformIO $ do - withForeignPtr fp $ \ p -> + withCPtr fp $ \ p -> withPrimVectorUnsafe bs $ \ ba# s l -> do r <- hs_re2_test p ba# s l return $! r /= 0 @@ -181,7 +182,7 @@ match :: Regex -> T.Text -> (T.Text, [Maybe T.Text], T.Text) {-# INLINABLE match #-} match (Regex fp n _) t@(T.Text bs@(V.PrimVector ba _ _)) = unsafePerformIO $ do - withForeignPtr fp $ \ p -> + withCPtr fp $ \ p -> withPrimVectorUnsafe bs $ \ ba# s l -> do (starts, (lens, r)) <- allocPrimArrayUnsafe n $ \ p_starts -> allocPrimArrayUnsafe n $ \ p_ends -> @@ -216,7 +217,7 @@ -> T.Text {-# INLINABLE replace #-} replace (Regex fp _ _) g inp rew = T.Text . unsafePerformIO $ do - withForeignPtr fp $ \ p -> + withCPtr fp $ \ p -> withPrimVectorUnsafe (T.getUTF8Bytes inp) $ \ inpp inpoff inplen -> withPrimVectorUnsafe (T.getUTF8Bytes rew) $ \ rewp rewoff rewlen -> fromStdString ((if g then hs_re2_replace_g else hs_re2_replace) @@ -234,16 +235,20 @@ -> T.Text {-# INLINABLE extract #-} extract (Regex fp _ _) inp rew = T.Text . unsafePerformIO $ do - withForeignPtr fp $ \ p -> + withCPtr fp $ \ p -> withPrimVectorUnsafe (T.getUTF8Bytes inp) $ \ inpp inpoff inplen -> withPrimVectorUnsafe (T.getUTF8Bytes rew) $ \ rewp rewoff rewlen -> fromStdString (hs_re2_extract p inpp inpoff inplen rewp rewoff rewlen) -------------------------------------------------------------------------------- -foreign import ccall unsafe hs_re2_compile_pattern_default :: BA# Word8 -> Int -> Int -> IO (Ptr Regex) +foreign import ccall unsafe hs_re2_compile_pattern_default + :: MBA# (Ptr Regex) -> BA# Word8 -> Int -> Int + -> IO (Ptr Regex) + foreign import ccall unsafe hs_re2_compile_pattern - :: BA# Word8 -> Int -> Int + :: MBA# (Ptr Regex) + -> BA# Word8 -> Int -> Int -> CBool -- ^ posix_syntax -> CBool -- ^ longest_match -> Int64 -- ^ max_mem @@ -257,8 +262,7 @@ -> CBool -- ^ one_line -> IO (Ptr Regex) -foreign import ccall unsafe "&hs_re2_delete_pattern" p_hs_re2_delete_pattern :: FinalizerPtr Regex -foreign import ccall unsafe hs_re2_delete_pattern :: Ptr Regex -> IO () +foreign import ccall unsafe "&hs_re2_delete_pattern" p_hs_re2_delete_pattern :: FunPtr (Ptr Regex -> IO ()) foreign import ccall unsafe hs_re2_ok :: Ptr Regex -> IO CInt foreign import ccall unsafe hs_num_capture_groups :: Ptr Regex -> IO Int diff --git a/Z/Data/Vector/Base.hs b/Z/Data/Vector/Base.hs --- a/Z/Data/Vector/Base.hs +++ b/Z/Data/Vector/Base.hs @@ -88,6 +88,7 @@ import Data.Bits import Data.Char (ord) import qualified Data.Foldable as F +import Data.Kind (Type) import Data.Hashable (Hashable(..)) import Data.Hashable.Lifted (Hashable1(..), hashWithSalt1) import qualified Data.List as List @@ -114,6 +115,7 @@ import System.IO.Unsafe (unsafeDupablePerformIO) import Z.Data.Array +import Z.Data.ASCII (toLower) -- | Typeclass for box and unboxed vectors, which are created by slicing arrays. -- @@ -127,7 +129,7 @@ -- 'toArr' will always return offset 0 and whole array length, and 'fromArr' is O(n) 'copyArr'. class (Arr (IArray v) a) => Vec v a where -- | Vector's immutable array type - type IArray v :: * -> * + type IArray v :: Type -> Type -- | Get underline array and slice range(offset and length). toArr :: v a -> (IArray v a, Int, Int) -- | Create a vector by slicing an array(with offset and length). @@ -547,16 +549,10 @@ {-# INLINE fromListN #-} fromListN = packN +-- | This instance assume ASCII encoded bytes instance CI.FoldCase Bytes where {-# INLINE foldCase #-} - foldCase = map toLower8 - where - toLower8 :: Word8 -> Word8 - toLower8 w - | 65 <= w && w <= 90 || - 192 <= w && w <= 214 || - 216 <= w && w <= 222 = w + 32 - | otherwise = w + foldCase = map toLower -- | /O(n)/, pack an ASCII 'String', multi-bytes char WILL BE CHOPPED! packASCII :: String -> Bytes @@ -750,7 +746,7 @@ if i < n then do writeArr marr i x return (IPair (i+1) marr) - else do let !n' = n `shiftL` 1 + else do let !n' = n `unsafeShiftL` 1 !marr' <- resizeMutableArr marr n' writeArr marr' i x return (IPair (i+1) marr') @@ -804,7 +800,7 @@ if i >= 0 then do writeArr marr i x return (IPair (i-1) marr) - else do let !n' = n `shiftL` 1 -- double the buffer + else do let !n' = n `unsafeShiftL` 1 -- double the buffer !marr' <- newArr n' copyMutableArr marr' n marr 0 n writeArr marr' (n-1) x diff --git a/Z/Foreign/CPtr.hs b/Z/Foreign/CPtr.hs new file mode 100644 --- /dev/null +++ b/Z/Foreign/CPtr.hs @@ -0,0 +1,88 @@ +{-| +Module : Z.Foreign.CPtr +Description : Lightweight foreign pointer +Copyright : (c) Dong Han, 2020 +License : BSD +Maintainer : winterland1989@gmail.com +Stability : experimental +Portability : non-portable + +This module provide a lightweight foreign pointer, support c initializer and finalizer only. +-} + +module Z.Foreign.CPtr ( + -- * CPtr type + CPtr, newCPtrUnsafe, newCPtr, withCPtr + -- * Ptr type + , Ptr + , nullPtr + , FunPtr + ) where + +import Control.Monad.Primitive +import Control.Exception (mask_) +import Data.Primitive.PrimArray +import Z.Data.Text as T +import GHC.Ptr +import GHC.Exts + +-- | Lightweight foreign pointers. +newtype CPtr a = CPtr (PrimArray (Ptr a)) + +instance Eq (CPtr a) where + {-# INLINE (==) #-} + CPtr a == CPtr b = indexPrimArray a 0 == indexPrimArray b 0 + +instance Ord (CPtr a) where + {-# INLINE compare #-} + CPtr a `compare` CPtr b = indexPrimArray a 0 `compare` indexPrimArray b 0 + +instance Show (CPtr a) where + show = toString + +instance T.Print (CPtr a) where + {-# INLINE toUTF8BuilderP #-} + toUTF8BuilderP _ (CPtr mpa) = T.toUTF8BuilderP 0 (indexPrimArray mpa 0) + +-- | Initialize a 'CPtr' with initializer(must be unsafe FFI) and finalizer. +-- +-- The initializer will receive a pointer of pointer so that it can do allocation and +-- write pointer back. +newCPtrUnsafe :: (MutableByteArray# RealWorld -> IO r) -- ^ initializer + -> FunPtr (Ptr a -> IO b) -- ^ finalizer + -> IO (CPtr a, r) +newCPtrUnsafe ini (FunPtr fin#) = mask_ $ do + mpa@(MutablePrimArray mba#) <- newPrimArray 1 + r <- ini mba# + (Ptr addr#) <- readPrimArray mpa 0 + pa@(PrimArray ba#) <- unsafeFreezePrimArray mpa + primitive_ $ \ s0# -> + let !(# s1#, w# #) = mkWeakNoFinalizer# ba# () s0# + !(# s2#, _ #) = addCFinalizerToWeak# fin# addr# 0# addr# w# s1# + in s2# + return (CPtr pa, r) + +-- | Initialize a 'CPtr' with initializer and finalizer. +-- +-- The initializer will receive a pointer of pointer so that it can do allocation and +-- write pointer back. +newCPtr :: (Ptr (Ptr a) -> IO r) -- ^ initializer + -> FunPtr (Ptr a -> IO b) -- ^ finalizer + -> IO (CPtr a, r) +newCPtr ini (FunPtr fin#) = mask_ $ do + mpa <- newPinnedPrimArray 1 + r <- ini (mutablePrimArrayContents mpa) + (Ptr addr#) <- readPrimArray mpa 0 + pa@(PrimArray ba#) <- unsafeFreezePrimArray mpa + primitive_ $ \ s0# -> + let !(# s1#, w# #) = mkWeakNoFinalizer# ba# () s0# + !(# s2#, _ #) = addCFinalizerToWeak# fin# addr# 0# addr# w# s1# + in s2# + return (CPtr pa, r) + +-- | The only way to use 'CPtr' as a 'Ptr' in FFI is to use 'withCPtr'. +withCPtr :: CPtr a -> (Ptr a -> IO b) -> IO b +withCPtr (CPtr pa@(PrimArray ba#)) f = do + r <- f (indexPrimArray pa 0) + primitive_ (touch# ba#) + return r diff --git a/cbits/regex.cc b/cbits/regex.cc --- a/cbits/regex.cc +++ b/cbits/regex.cc @@ -28,6 +28,7 @@ #include #include #include +#include #include #include @@ -37,7 +38,7 @@ return re2::RE2::Options::kDefaultMaxMem; } -re2::RE2 *hs_re2_compile_pattern(const char *input, HsInt off, HsInt input_len +re2::RE2* hs_re2_compile_pattern(re2::RE2** re, const char *input, HsInt off, HsInt input_len , bool posix_syntax , bool longest_match , int64_t max_mem @@ -48,7 +49,7 @@ , bool case_sensitive , bool perl_classes , bool word_boundary - , bool one_line ){ + , bool one_line ){ re2::RE2::Options opts; opts.set_posix_syntax ( posix_syntax ); opts.set_longest_match ( longest_match ); @@ -61,11 +62,14 @@ opts.set_perl_classes ( perl_classes ); opts.set_word_boundary ( word_boundary ); opts.set_one_line ( one_line ); - return new re2::RE2(re2::StringPiece(input+off, input_len), opts); + + *re = new (std::nothrow) re2::RE2(re2::StringPiece(input+off, input_len), opts); + return *re; } -re2::RE2 *hs_re2_compile_pattern_default(const char *input, HsInt off, HsInt input_len) { - return new re2::RE2(re2::StringPiece(input+off, input_len)); +re2::RE2* hs_re2_compile_pattern_default(re2::RE2** re, const char *input, HsInt off, HsInt input_len) { + *re = new (std::nothrow) re2::RE2(re2::StringPiece(input+off, input_len)); + return *re; } void hs_re2_delete_pattern(re2::RE2 *regex) {