packed (empty) → 0.1.0

raw patch · 13 files changed

+2006/−0 lines, 13 filesdep +basedep +containersdep +gaugesetup-changed

Dependencies added: base, containers, gauge, ghc-prim, hedgehog, packed, primitive, tasty, tasty-hedgehog, tasty-hunit

Files

ChangeLog.md +3/−0
LICENSE +30/−0
README.md +1/−0
Setup.hs +2/−0
bench/Main.hs +98/−0
packed.cabal +61/−0
src/Packed/Bytes.hs +101/−0
src/Packed/Bytes/Mutable.hs +1/−0
src/Packed/Bytes/Small.hs +184/−0
src/Packed/Bytes/Window.hs +517/−0
src/Packed/Text.hs +600/−0
src/Packed/Text/Small.hs +83/−0
test/Main.hs +325/−0

+ ChangeLog.md view

@@ -0,0 +1,3 @@+# Changelog for bytearray++## Unreleased changes

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Andrew Martin (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Andrew Martin nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,1 @@+# bytearray

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ bench/Main.hs view

@@ -0,0 +1,98 @@+{-# OPTIONS_GHC -O2 -Wall #-}++import Gauge (bgroup,bench,whnf)+import Gauge.Main (defaultMain)+import Packed.Bytes.Small (ByteArray)+import Packed.Text (Text)+import Packed.Bytes (Bytes)++import qualified Packed.Bytes.Small as BA+import qualified Packed.Text as T+import qualified GHC.OldList as L++main :: IO ()+main = do+  defaultMain+    [ bgroup "ByteArray"+      [ bench "findByte" $ whnf (BA.findByte 0x80) byteArrayA+      , bench "zipAnd" $ whnf (BA.zipAnd byteArrayA) byteArrayB+      ]+    , bgroup "Text"+      [ bgroup "toUpper"+        -- Not totally fair. The number 5000 refers to the character count,+        -- meaning that asian scripts end up with more bytes.+        [ bench "ascii" $ whnf T.toUpper textAscii5000+        , bench "latin" $ whnf T.toUpper textLatin5000+        , bench "asian" $ whnf T.toUpper textAsian5000+        ]+      , bgroup "decodeUtf8"+        [ bench "ascii" $ whnf T.decodeUtf8 encodedAscii5000+        , bench "latin" $ whnf T.decodeUtf8 encodedLatin5000+        , bench "asian" $ whnf T.decodeUtf8 encodedAsian5000+        ]+      ]+    ]++byteArrayA :: ByteArray+byteArrayA = BA.pack $ L.concat+  [ L.take 5000 (L.cycle (enumFromTo 0x00 0x7F))+  , [0x80]+  , L.take 2000 (L.cycle (enumFromTo 0xB0 0xFF))+  ]++byteArrayB :: ByteArray+byteArrayB = BA.pack $ L.concat+  [ L.take 2000 (L.cycle (enumFromTo 0x80 0xFF))+  , [0x70]+  , L.take 3000 (L.cycle (enumFromTo 0x20 0x60))+  ]++encodedAscii5000 :: Bytes+encodedAscii5000 = T.encodeUtf8 textAscii5000++encodedLatin5000 :: Bytes+encodedLatin5000 = T.encodeUtf8 textLatin5000++encodedAsian5000 :: Bytes+encodedAsian5000 = T.encodeUtf8 textAsian5000++textAscii5000 :: Text+textAscii5000 = T.pack $ L.concat+  [ L.take 2000 (L.cycle (enumFromTo 'a' 'm' ++ [','] ++ enumFromTo 'A' 'H' ++ ['.']))+  , L.take 3000 (L.cycle "The Old Tavern Across The Town")+  ]++textLatin5000 :: Text+textLatin5000 = T.pack $ L.take 5000 $ L.cycle $ L.concat+  [ "Suzanne et Joseph étaient nés dans les deux premières années de leur. "+  , "arrivée à la colonie. Après la naissance de Suzanne, la mère abandonna "+  , "l'enseignement d'état. "+  , "Mentiría si dijera que era del todo nuevo el sentimiento de que ya no "+  , "iba a poder ser más que lo que era, que era un hombre que había "+  , "envejecido más de lo que suponía, que había sospechado tener toda "+  , "la vida por delante y había ido dejando pasar los años a la espera "+  , "de que llegara su momento, y ahora la tenía a su espalda. "+  ]++textAsian5000 :: Text+textAsian5000 = T.pack $ L.take 5000 $ L.cycle $ L.concat+  [ "유구한 역사와 전통에 빛나는 우리 대한 국민은 3·1 운동으로 건립된 "+  , "대한민국 임시 정부의 법통과 불의에 항거한 4·19 민주 이념을 계승하고, "+  , "조국의 민주 개혁과 평화적 통일의 사명에 입각하여 정의·인도와 동포애로써 "+  , "민족의 단결을 공고히 하고, 모든 사회적 폐습과 불의를 타파하며, 자율과 "+  , "조화를 바탕으로 자유 민주적 기본 질서를 더욱 확고히 하여 정치·경제·사회·문화의 "+  , "모든 영역에 있어서 각인의 기회를 균등히 하고, 능력을 최고도로 발휘하게 하며, "+  , "자유와 권리에 따르는 책임과 의무를 완수하게 하여, 안으로는 국민 생활의 균등한 "+  , "향상을 기하고 밖으로는 항구적인 세계 평화와 인류 공영에 이바지함으로써 우리들과 "+  , "우리들의 자손의 안전과 자유와 행복을 영원히 확보할 것을 다짐하면서 1948년 7월 12일에 "+  , "제정되고 8차에 걸쳐 개정된 헌법을 이제 국회의 의결을 거쳐 국민 투표에 의하여 개정한다."+  ]++-- textFrench :: Text+-- textFrench = T.pack $ L.concat+--   [ "Suzanne et Joseph étaient nés dans les deux premières années de leur. "+--   , "arrivée à la colonie. Après la naissance de Suzanne, la mère abandonna "+--   , "l'enseignement d'état. "+--   ]+  +

+ packed.cabal view

@@ -0,0 +1,61 @@+name: packed+version: 0.1.0+description: Please see the README on Github at <https://github.com/andrewthad/bytearray#readme>+homepage: https://github.com/andrewthad/bytearray#readme+bug-reports: https://github.com/andrewthad/bytearray/issues+author: Andrew Martin+maintainer: andrew.thaddeus@gmail.com+copyright: 2017 Andrew Martin+license: BSD3+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10++extra-source-files:+  ChangeLog.md+  README.md++source-repository head+  type: git+  location: https://github.com/andrewthad/bytearray++library+  hs-source-dirs: src+  build-depends:+      base >=4.10 && <5+    , ghc-prim >= 0.5.1.1 && < 0.6+    , primitive >= 0.6 && < 0.7+  exposed-modules:+    Packed.Bytes+    Packed.Bytes.Window+    Packed.Bytes.Mutable+    Packed.Bytes.Small+    Packed.Text+    Packed.Text.Small+  default-language: Haskell2010++test-suite test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+      test+  build-depends:+      base >=4.7 && <5+    , packed+    , hedgehog >= 0.5+    , tasty-hedgehog >= 0.1.0.2+    , tasty-hunit >= 0.9+    , tasty >= 1.0+    , containers >= 0.5.10+    , ghc-prim+  default-language: Haskell2010++benchmark bench+  type: exitcode-stdio-1.0+  build-depends:+      base+    , packed+    , gauge+  default-language: Haskell2010+  hs-source-dirs: bench+  main-is: Main.hs

+ src/Packed/Bytes.hs view

@@ -0,0 +1,101 @@+{-# LANGUAGE BangPatterns #-}++{-# OPTIONS_GHC+ -Weverything+ -fno-warn-unsafe+ -fno-warn-implicit-prelude+ -fno-warn-missing-import-lists+ -O2+#-}++module Packed.Bytes+  ( Bytes(..)+  , pack+  , unpack+  , drop+  , dropEnd+  , replicate+  , length+  , foldl'+  , take+  , empty+  , findByte+    -- * Characters+  , isAscii+  ) where++import Prelude hiding (take,length,replicate,drop)++import Packed.Bytes.Small (ByteArray(..))+import Data.Word (Word8)+import qualified Packed.Bytes.Window as BAW+import qualified Packed.Bytes.Small as BA++data Bytes = Bytes+  {-# UNPACK #-} !ByteArray -- payload+  {-# UNPACK #-} !Int -- offset+  {-# UNPACK #-} !Int -- length++instance Eq Bytes where+  Bytes arrA offA lenA == Bytes arrB offB lenB =+    if lenA == lenB+      then BAW.equality offA offB lenA arrA arrB+      else False++pack :: [Word8] -> Bytes+pack bs = let arr = BA.pack bs in Bytes arr 0 (BA.length arr)++unpack :: Bytes -> [Word8]+unpack (Bytes arr off len) = go off+  where+  go :: Int -> [Word8]+  go !ix = if ix < len + off+    then BA.unsafeIndex arr ix : go (ix + 1)+    else []++drop :: Int -> Bytes -> Bytes+drop n (Bytes arr off len) = if len > n+  then Bytes arr (off + n) (len - n)+  else empty++dropEnd :: Int -> Bytes -> Bytes+dropEnd n (Bytes arr off len) = if len > n+  then Bytes arr off (len - n)+  else empty++replicate :: Int -> Word8 -> Bytes+replicate len w = fromByteArray (BA.replicate len w)++fromByteArray :: ByteArray -> Bytes+fromByteArray ba = Bytes ba 0 (BA.length ba)++length :: Bytes -> Int+length (Bytes _ _ len) = len++findByte :: Word8 -> Bytes -> Maybe Int+findByte !w (Bytes arr off len) = case BAW.findByte off len w arr of+  Just ix -> Just (ix - off)+  Nothing -> Nothing++foldl' :: (a -> Word8 -> a) -> a -> Bytes -> a+foldl' f !acc0 (Bytes arr off len) = BAW.foldl' off len f acc0 arr++take :: Int -> Bytes -> Bytes+take !n (Bytes arr off len) = if n < len+  then Bytes arr off (len - n)+  else empty++empty :: Bytes+empty = Bytes BA.empty 0 0++isAscii :: Bytes -> Bool+isAscii (Bytes arr off len) = BAW.isAscii off len arr++-- In this implementation, we overallocate on each side to+-- make things line up with machine word boundaries. This+-- make the reversal eight times faster.+-- reverse :: Bytes -> Bytes+-- reverse (Bytes arr off len) =+--   let !leftWordIx = quot off (PM.sizeOf (undefined :: Word))+--       !rightWordIx = quot (off + len) (PM.sizeOf (undefined :: Word))+

+ src/Packed/Bytes/Mutable.hs view

@@ -0,0 +1,1 @@+module Packed.Bytes.Mutable where

+ src/Packed/Bytes/Small.hs view

@@ -0,0 +1,184 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC+ -Weverything+ -fno-warn-unsafe+ -fno-warn-implicit-prelude+ -fno-warn-missing-import-lists+ -O2+#-}++module Packed.Bytes.Small+  ( ByteArray(..)+  , empty+  , pack+  , unpack+  , singleton+  , append+  , replicate+  , length+  , findByte+  , foldl'+  , take+  , cons+  , uncons+  , reverse+    -- * Zip+  , zipAnd+  , zipOr+  , zipXor+    -- * Characters+  , isAscii+    -- * Unsafe+  , unsafeIndex+  ) where++import Prelude hiding (replicate,length,take,reverse)++import Control.Monad.Primitive (primitive_)+import Control.Monad.ST (runST,ST)+import Data.Primitive.ByteArray (ByteArray(..),MutableByteArray(..))+import GHC.Exts (setByteArray#,word2Int#,byteSwap#)+import GHC.Int (Int(I#))+import GHC.Word (Word8(W8#),Word(W#))+import qualified GHC.OldList as L+import qualified Packed.Bytes.Window as BAW+import qualified Data.Primitive as PM++singleton :: Word8 -> ByteArray+singleton w = runST $ do+  marr <- PM.newByteArray 1+  PM.writeByteArray marr 0 w+  PM.unsafeFreezeByteArray marr++pack :: [Word8] -> ByteArray+pack ws0 = runST $ do+  marr <- PM.newByteArray (L.length ws0)+  let go [] !_ = return ()+      go (w : ws) !ix = writeByteArrayWord8 marr ix w >> go ws (ix + 1)+  go ws0 0+  PM.unsafeFreezeByteArray marr++unpack :: ByteArray -> [Word8]+unpack arr = go 0 where+  go :: Int -> [Word8]+  go !ix = if ix < length arr+    then unsafeIndex arr ix : go (ix + 1)+    else []++append :: ByteArray -> ByteArray -> ByteArray+append !a !b = do+  let !lenA = length a+      !lenB = length b+      !len = lenA + lenB+   in runST $ do+        !marr <- PM.newByteArray len+        PM.copyByteArray marr 0 a 0 lenA+        PM.copyByteArray marr lenA b 0 lenB+        PM.unsafeFreezeByteArray marr++cons :: Word8 -> ByteArray -> ByteArray+cons w arr = runST $ do+  let !lenArr = length arr+  marr <- PM.newByteArray (lenArr + 1)+  PM.writeByteArray marr 0 w+  PM.copyByteArray marr 1 arr 0 lenArr+  PM.unsafeFreezeByteArray marr++uncons :: ByteArray -> Maybe (Word8, ByteArray)+uncons arr0 = if lenArr > 0+  then+    let !arr1 = runST $ do+          marr <- PM.newByteArray (lenArr - 1)+          PM.copyByteArray marr 0 arr0 1 (lenArr - 1)+          PM.unsafeFreezeByteArray marr+        w :: Word8+        !w = PM.indexByteArray arr0 0+     in Just (w,arr1)+  else Nothing+  where+  !lenArr = length arr0++replicate :: Int -> Word8 -> ByteArray+replicate len@(I# len#) (W8# w#) = runST $ do+  marr@(MutableByteArray marr#) <- PM.newByteArray len+  primitive_ (setByteArray# marr# 0# len# (word2Int# w#))+  PM.unsafeFreezeByteArray marr++length :: ByteArray -> Int+length = PM.sizeofByteArray++findByte :: Word8 -> ByteArray -> Maybe Int+findByte !w !arr = BAW.findByte 0 (length arr) w arr++foldl' :: (a -> Word8 -> a) -> a -> ByteArray -> a+foldl' f !acc0 !arr = BAW.foldl' 0 (length arr) f acc0 arr++take :: Int -> ByteArray -> ByteArray+take !n !arr = if n < length arr+  then runST $ do+    marr <- PM.newByteArray n+    PM.copyByteArray marr 0 arr 0 n+    PM.unsafeFreezeByteArray marr+  else empty++empty :: ByteArray+empty = runST (PM.newByteArray 0 >>= PM.unsafeFreezeByteArray)++-- | Reverse the bytes in a byte array. This operation is eight+--   times faster if the length of the byte array divides eight+--   evenly.+reverse :: ByteArray -> ByteArray+reverse !arr = runST $ do+  marr <- PM.newByteArray (length arr)+  let !(!quotient,!remainder) = quotRem (length arr) (PM.sizeOf (undefined :: Word))+  if remainder == 0+    then goFast 0 quotient marr+    else goSlow 0 (length arr) marr+  PM.unsafeFreezeByteArray marr+  where+  goFast :: forall s. Int -> Int -> MutableByteArray s -> ST s ()+  goFast !ix !len !marr = if ix < len+    then do+      let !w = unsafeIndexWord arr ix+      writeByteArrayWord marr (len - ix) (byteSwap w)+      goFast (ix + 1) len marr+    else return ()+  goSlow :: forall s. Int -> Int -> MutableByteArray s -> ST s ()+  goSlow !ix !len !marr = if ix < len+    then do+      let !w = unsafeIndex arr ix+      writeByteArrayWord8 marr (len - ix) w+      goSlow (ix + 1) len marr+    else return ()++byteSwap :: Word -> Word+byteSwap (W# w) = W# (byteSwap# w)++writeByteArrayWord :: MutableByteArray s -> Int -> Word -> ST s ()+writeByteArrayWord = PM.writeByteArray++writeByteArrayWord8 :: MutableByteArray s -> Int -> Word8 -> ST s ()+writeByteArrayWord8 = PM.writeByteArray++-- this is only used internally+unsafeIndexWord :: ByteArray -> Int -> Word+unsafeIndexWord = PM.indexByteArray++-- | Does not check to see if the index is in bounds.+unsafeIndex :: ByteArray -> Int -> Word8+unsafeIndex = PM.indexByteArray++zipAnd :: ByteArray -> ByteArray -> ByteArray+zipAnd x y = BAW.zipAnd 0 (length x) 0 (length y) x y++zipOr :: ByteArray -> ByteArray -> ByteArray+zipOr x y = BAW.zipOr 0 (length x) 0 (length y) x y++zipXor :: ByteArray -> ByteArray -> ByteArray+zipXor x y = BAW.zipXor 0 (length x) 0 (length y) x y++isAscii :: ByteArray -> Bool+isAscii x = BAW.isAscii 0 (length x) x

+ src/Packed/Bytes/Window.hs view

@@ -0,0 +1,517 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE UnboxedSums #-}+{-# LANGUAGE UnboxedTuples #-}++{-# OPTIONS_GHC+ -Weverything+ -fno-warn-unsafe+ -fno-warn-implicit-prelude+ -O2+#-}++module Packed.Bytes.Window+  ( findByte+  , foldl'+  , reverse+  , zipAnd+  , zipOr+  , zipXor+  , equality+    -- * Characters+  , isAscii+  , isUtf8+  , findNonAscii'+  ) where++import Data.Primitive (ByteArray(ByteArray))+import Data.Word (Word8)+import GHC.Types (RuntimeRep,TYPE)+import GHC.Int (Int(I#))+import GHC.Word (Word8(W8#),Word(W#))+import GHC.Exts (Int#,Word#,ByteArray#)+import Data.Bits (xor,(.|.),(.&.),complement,unsafeShiftL)+import Control.Monad.ST (ST,runST)+import qualified Data.Primitive as PM++type Maybe# (a :: TYPE (r :: RuntimeRep)) = (# (# #) | a #)++boxMaybeInt :: Maybe# Int# -> Maybe Int+boxMaybeInt = \case+  (# | a #) -> Just (I# a)+  (# (# #) | #) -> Nothing++unboxInt :: Int -> Int#+unboxInt (I# i) = i++unboxWord :: Word -> Word#+unboxWord (W# i) = i++-- | Finds the first occurrence of the given byte.+{-# INLINE findByte #-}+findByte :: Int -> Int -> Word8 -> ByteArray -> Maybe Int+findByte (I# off) (I# len) (W8# w) (ByteArray arr) =+  boxMaybeInt (findByte' off len w arr)++{-# NOINLINE findByte' #-}+findByte' :: Int# -> Int# -> Word# -> ByteArray# -> Maybe# Int#+findByte' !off# !len0# !w0# !arr0# = +  let !off = I# off#+      !len0 = I# len0#+      !end0 = off + len0+      !beginMachWord = alignUp off+      !endMachWord = alignDown end0+   in if len0 < PM.sizeOf (undefined :: Word)+        then go off end0+        else case go off (beginMachWord * PM.sizeOf (undefined :: Word)) of+          (# | ix #) -> (# | ix #)+          (# (# #) | #) -> case goMachWord beginMachWord endMachWord (broadcastWord8 w) of+            (# | ix #) -> (# | ix #)+            (# (# #) | #) -> case go (endMachWord * PM.sizeOf (undefined :: Word)) end0 of+              (# | ix #) -> (# | ix #)+              (# (# #) | #) -> (# (# #) | #)+  where+  !w = W8# w0#+  !arr = ByteArray arr0#+  go :: Int -> Int -> Maybe# Int#+  go !ix !end = if ix < end+    then if PM.indexByteArray arr ix == w+      then (# | unboxInt ix #)+      else go (ix + 1) end+    else (# (# #) | #)+  -- The start and end index here are given in machine Word elements,+  -- not Word8 elements.+  goMachWord :: Int -> Int -> Word -> Maybe# Int#+  goMachWord !ix !end !artifact = if ix < end+    then case detectArtifact (unsafeIndexWord arr ix) artifact of+      0 -> goMachWord (ix + 1) end artifact+      _ -> go -- this call to go should always return Just+        (ix * PM.sizeOf (undefined :: Word)) +        ((ix + 1) * PM.sizeOf (undefined :: Word))+    else (# (# #) | #)++-- cast a Word8 index to a machine Word index, rounding up+alignUp :: Int -> Int+alignUp i =+  let !(!quotient,!remainder) = quotRem i (PM.sizeOf (undefined :: Word))+   in case remainder of+        0 -> quotient+        _ -> quotient + 1++-- cast a Word8 index to a machine Word index, rounding down+alignDown :: Int -> Int+alignDown i = quot i (PM.sizeOf (undefined :: Word))++broadcastWord8 :: Word8 -> Word+broadcastWord8 !w0 = go 8 (fromIntegral w0) where+  go :: Int -> Word -> Word+  go !n !w = if n < 8 * PM.sizeOf (undefined :: Word)+    then go (twice n) (unsafeShiftL w n .|. w)+    else w++twice :: Int -> Int+twice n = n * 2++-- returns non-zero if a null byte is present in the machine word+detectNull :: Word -> Word+detectNull x = (x - repeatHexZeroOne) .&. complement x .&. repeatHexEightZero++detectArtifact :: Word -> Word -> Word+detectArtifact x artifact = detectNull (applyArtifact x artifact)++applyArtifact :: Word -> Word -> Word+applyArtifact = xor++repeatHexZeroOne :: Word+repeatHexZeroOne = div maxBound 255++repeatHexEightZero :: Word+repeatHexEightZero = 128 * (div maxBound 255 :: Word)++foldl' :: forall a. Int -> Int -> (a -> Word8 -> a) -> a -> ByteArray -> a+foldl' !off !len f !acc0 !arr = go acc0 off where+  go :: a -> Int -> a+  go !acc !ix = if ix < off + len+    then go (f acc (PM.indexByteArray arr ix)) (ix + 1)+    else acc++-- this is only used internally+unsafeIndexWord :: ByteArray -> Int -> Word+unsafeIndexWord = PM.indexByteArray++safeIndexWord :: ByteArray -> Int -> Word+safeIndexWord arr ix = if ix < 0 || ix >= (div (PM.sizeofByteArray arr) (PM.sizeOf (undefined :: Word)))+  then error ("safeIndexWord: " ++ show ix ++ " is out of bounds")+  else PM.indexByteArray arr ix++-- this is only used internally+unsafeIndex :: ByteArray -> Int -> Word8+unsafeIndex = PM.indexByteArray++safeIndex :: ByteArray -> Int -> Word8+safeIndex arr ix = if ix < 0 || ix >= PM.sizeofByteArray arr+  then error ("safeIndex: " ++ show ix ++ " is out of bounds")+  else PM.indexByteArray arr ix++-- TODO: optimize this. We could do a whole Word64 at a+-- time if the bytearray is pinned. Maybe even if it+-- isn't pinned.+-- reverse :: Int -> Int -> ByteArray -> ByteArray+-- reverse off len arr = runST++-- | Check if the given slice of the two byte arrays+--   is equal.+equality :: +     Int -- ^ start x+  -> Int -- ^ start y+  -> Int -- ^ length+  -> ByteArray -- ^ array x+  -> ByteArray -- ^ array y+  -> Bool+equality !ixA !ixB !len !arrA !arrB = go 0+  -- TODO: Replace this with compareByteArrays# once GHC 8.4+  -- or GHC 8.6 is released. This will be simpler and much+  -- faster.+  where+  go :: Int -> Bool+  go !ix = if ix < len+    then if safeIndex arrA (ix + ixA) == safeIndex arrB (ix + ixB)+      then go (ix + 1)+      else False+    else True++{-# INLINE zipVectorizable #-}+zipVectorizable ::+     (Word8 -> Word8 -> Word8)+  -> (Word -> Word -> Word)+  -> Int -- start x+  -> Int -- len x+  -> Int -- start y+  -> Int -- len y+  -> ByteArray -- x+  -> ByteArray -- y+  -> ByteArray -- z+zipVectorizable !combine !combineMach !startX !lenX !startY !lenY !x !y = runST action+  where+  action :: forall s. ST s ByteArray+  action = do+    let !len = min lenX lenY+    marr <- PM.newByteArray len+    let !(!quotStartX,!remStartX) = quotRem startX (PM.sizeOf (undefined :: Word))+        !(!quotStartY,!remStartY) = quotRem startY (PM.sizeOf (undefined :: Word))+        go :: Int -> Int -> ST s ()+        go !ix !end = if ix < end+          then do+            PM.writeByteArray marr ix (combine (unsafeIndex x (startX + ix)) (unsafeIndex y (startY + ix)))+            go (ix + 1) end+          else return ()+        goMach :: Int -> Int -> ST s ()+        goMach !ix !end = if ix < end+          then do+            PM.writeByteArray marr ix (combineMach (unsafeIndexWord x (quotStartX + ix)) (unsafeIndexWord y (quotStartY + ix)))+            goMach (ix + 1) end+          else return ()+    if remStartX .|. remStartY == 0 -- if they are both zero+      then do+        let !lenQuotient = quot len (PM.sizeOf (undefined :: Word))+        goMach 0 lenQuotient+        go (lenQuotient * PM.sizeOf (undefined :: Word)) len+      else go 0 len+    PM.unsafeFreezeByteArray marr++zipAnd :: Int -> Int -> Int -> Int -> ByteArray -> ByteArray -> ByteArray+zipAnd x0 xlen y0 ylen x y = zipVectorizable (.&.) (.&.) x0 xlen y0 ylen x y++zipOr :: Int -> Int -> Int -> Int -> ByteArray -> ByteArray -> ByteArray+zipOr x0 xlen y0 ylen x y = zipVectorizable (.|.) (.|.) x0 xlen y0 ylen x y++zipXor :: Int -> Int -> Int -> Int -> ByteArray -> ByteArray -> ByteArray+zipXor x0 xlen y0 ylen x y = zipVectorizable (.|.) (.|.) x0 xlen y0 ylen x y++-- this can be used to implement all predicates or any predicates+{-# INLINE boolVectorizable #-}+boolVectorizable ::+     Bool+  -> (Bool -> Bool -> Bool)+  -> (Word8 -> Bool)+  -> (Word -> Bool)+  -> Int -- start+  -> Int -- len+  -> ByteArray+  -> Bool+boolVectorizable emptyBool together predicate predicateMach !start !len !arr =+  let !end0 = start + len+      !beginMachWord = alignUp start+      !endMachWord = alignDown end0+   in if len < PM.sizeOf (undefined :: Word)+        then go start end0+        else together+          (go start (beginMachWord * PM.sizeOf (undefined :: Word)))+          (together+            (goMachWord beginMachWord endMachWord)+            (go (endMachWord * PM.sizeOf (undefined :: Word)) end0)+          )+  where+  go :: Int -> Int -> Bool+  go !ix !end = if ix < end+    then together (predicate (PM.indexByteArray arr ix)) (go (ix + 1) end)+    else emptyBool+  -- The start and end index here are given in machine Word elements,+  -- not Word8 elements.+  goMachWord :: Int -> Int -> Bool+  goMachWord !ix !end = if ix < end+    then together (predicateMach (unsafeIndexWord arr ix)) (goMachWord (ix + 1) end)+    else emptyBool++{-# INLINE findVectorizable #-}+findVectorizable ::+     (Word8 -> Bool)+  -> (Word -> Bool)+  -> Int -- start+  -> Int -- len+  -> ByteArray+  -> Maybe# Int#+findVectorizable predicate predicateMach !start !len !arr =+  let !end0 = start + len+      !beginMachWord = alignUp start+      !endMachWord = alignDown end0+   in if len < PM.sizeOf (undefined :: Word)+        then go start end0+        else case go start (beginMachWord * PM.sizeOf (undefined :: Word)) of+          (# | ix #) -> (# | ix #)+          (# (# #) | #) -> case goMachWord beginMachWord endMachWord of+            (# | ix #) -> (# | ix #)+            (# (# #) | #) -> case go (endMachWord * PM.sizeOf (undefined :: Word)) end0 of+              (# | ix #) -> (# | ix #)+              (# (# #) | #) -> (# (# #) | #)+  where+  go :: Int -> Int -> Maybe# Int#+  go !ix !end = if ix < end+    then case predicate (safeIndex arr ix) of+      False -> go (ix + 1) end+      True -> (# | unboxInt ix #)+    else (# (# #) | #)+  -- The start and end index here are given in machine Word elements,+  -- not Word8 elements.+  goMachWord :: Int -> Int -> Maybe# Int#+  goMachWord !ix !end = if ix < end+    then case predicateMach (safeIndexWord arr ix) of+      False -> goMachWord (ix + 1) end+      True -> go+        (ix * PM.sizeOf (undefined :: Word)) +        ((ix + 1) * PM.sizeOf (undefined :: Word))+    else (# (# #) | #)++asciiMask :: Word8+asciiMask = 0x80++asciiMachMask :: Word+asciiMachMask = repeatHexEightZero++isAscii :: Int -> Int -> ByteArray -> Bool+isAscii start len arr = boolVectorizable True (&&)+  (\w -> w .&. asciiMask == 0)+  (\w -> w .&. asciiMachMask == 0)+  start len arr++-- This could be exported but it does not seem generally useful.+findNonAscii' :: Int -> Int -> ByteArray -> Maybe# Int#+findNonAscii' !start !len !arr = findVectorizable+  (\w -> w .&. asciiMask /= 0)+  (\w -> w .&. asciiMachMask /= 0)+  start len arr++-- | The meaning of the result sum elements in order:+--+--   1. An integer representing the first unparseable byte. This+--      may be up to three bytes before the actual byte where+--      the actual problem occurred. The leading byte is given+--      since that gives recovery mechanisms a reasonable place+--      to split the Bytes.+--   2. An empty nullary tuple indicating success with no leftovers+--   3. A triple of three words. The first word is the total number+--      of bytes in the multibyte word (only ever 2, 3, or 4). The+--      second is the number of additional bytes needed (only+--      ever 1, 2, or 3). The third is the fragment of the character built+--      so far. It will need to be bit shifted to the left by some+--      multiple of 6 to be completed.+--   +--   The first tuple element is 0 if everything successfully+--   parsed was acsii and a word with the high bit set to 1+--   if multi-byte characters were present.+--   It is 1 if there were surrogates, characters+--   in the range @U+D800@ to @U+DFFF@, present in the text. If+--   there are surrogates, it is implied that there are multi-byte+--   characters, since a surrogate is multi-byte by definition.+--   The value of this element is still meaningful even if the parse+--   ultimately fails.+isUtf8 :: +     Int -- start+  -> Int -- length+  -> ByteArray -- bytes+  -> (# Word#, (# Int# | (# #) | (# Word#, Word#, Word# #) #) #)+isUtf8 !start !len !arr = case findNonAscii' start len arr of+  (# (# #) | #) -> (# 0##, (# | (# #) | #) #)+  (# | ix# #) -> case postAsciiIsUtf8 (I# ix#) (len + start - (I# ix#)) arr of+    (# hasSurrogate, (# ixFailure# | | #) #) -> if I# ix# == I# ixFailure#+      then (# 0## , (# ixFailure# | | #) #)+      else (# hasSurrogate, (# ixFailure# | | #) #)+    (# hasSurrogate, (# | (# #) | #) #) -> (# hasSurrogate, (# | (# #) | #) #)+    (# hasSurrogate, (# | | (# w1, w2, w3 #) #) #) -> (# hasSurrogate, (# | | (# w1, w2, w3 #) #) #)+-- Notes on the implementation of isUtf8 There is some careful trickery to+-- ensure that we always correctly report whether or not we encountered any+-- multi-byte characters. We initially do a fast run to get as far as we can+-- on only ascii characters. In this stage, we are able to travel a full+-- machine word at a time. After this, we switch to a slower byte-by-byte+-- UTF-8 recognition function.  If this second stage fails on the very first+-- byte it sees, we report that everything successfully parsed was ascii.+-- If it fails at any point after this, we report that multibyte characters+-- were encounter. If it succeeds, we report that we encounter multi-byte+-- characters. This is accurate because, for it to start running at all,+-- findNonAscii' must have found something that was not ascii.++-- Note that postAsciiIsUtf8 does not return anything indicating whether or not there+-- were any multi-byte characters present. This is because, if this function+-- is called, it should be called with the start index on a non-ascii-encoded+-- character. This function is not expect to perform well. It shouldn't+-- allocate memory, but it has to go byte-by-byte through the ByteArray. The+-- author of this library does not know of a way to vectorize the check+-- for UTF-8 compliance.+--+-- The first element of the response tuple is either 1 or a machine word+-- with the high bit set to 1. If it is the high bit,+-- no surrogates were present. If it is 1, surrogates were present.+-- The second element is a nested unboxed sum with three cases. These+-- are described in the docs for isUtf8.+--+postAsciiIsUtf8 :: +     Int -- start+  -> Int -- length+  -> ByteArray -- bytes+  -> (# Word#, (# Int# | (# #) | (# Word#, Word#, Word# #) #) #)+postAsciiIsUtf8 !start !len !arr = go start binaryOneThenZeroes+  where+  !end = start + len+  go :: Int +     -> Word+     -> (# Word#, (# Int# | (# #) | (# Word#, Word#, Word# #) #) #)+  go !ix !hasSurrogate = if ix < end+    then+      let !firstByte = safeIndex arr ix in+       if | oneByteChar firstByte -> go (ix + 1) hasSurrogate+          | twoByteChar firstByte -> if ix + 1 < end+              then if followingByte (safeIndex arr (ix + 1))+                then go (ix + 2) hasSurrogate+                else (# unboxWord hasSurrogate, (# unboxInt ix | | #) #)+              else (# unboxWord hasSurrogate, (# | | (# 2##, 1##, unboxWord (byteTwoPartialOne firstByte) #) #) #)+          | threeByteChar firstByte ->+              if | ix + 2 < end -> +                     let !secondByte = safeIndex arr (ix + 1) in+                     if followingByte secondByte+                       then +                         let !thirdByte = safeIndex arr (ix + 2) in+                         if followingByte thirdByte+                           then if surrogate (codepointFromThreeBytes firstByte secondByte thirdByte)+                             then go (ix + 3) 1+                             else go (ix + 3) hasSurrogate+                           else (# unboxWord hasSurrogate, (# unboxInt ix | | #) #)+                       else (# unboxWord hasSurrogate, (# unboxInt ix | | #) #)+                 | ix + 1 < end -> +                     let !secondByte = safeIndex arr (ix + 1) in+                     if followingByte secondByte+                       then (# unboxWord hasSurrogate, (# | | (# 3##, 1##, unboxWord (byteThreePartialTwo firstByte secondByte) #) #) #)+                       else (# unboxWord hasSurrogate, (# unboxInt ix | | #) #)+                 | otherwise -> (# unboxWord hasSurrogate, (# | | (# 3##, 2##, unboxWord (byteThreePartialOne firstByte) #) #) #)+          | fourByteChar firstByte ->+              if | ix + 3 < end ->+                     let !secondByte = safeIndex arr (ix + 1) in+                     if followingByte secondByte+                       then +                         let !thirdByte = safeIndex arr (ix + 2) in+                         if followingByte thirdByte+                           then+                             let !fourthByte = safeIndex arr (ix + 3) in+                             if followingByte fourthByte+                               then go (ix + 4) hasSurrogate+                               else (# unboxWord hasSurrogate, (# unboxInt ix | | #) #)+                           else (# unboxWord hasSurrogate, (# unboxInt ix | | #) #)+                       else (# unboxWord hasSurrogate, (# unboxInt ix | | #) #)+                 | ix + 2 < end -> +                     let !secondByte = safeIndex arr (ix + 1) in+                     if followingByte secondByte+                       then +                         let !thirdByte = safeIndex arr (ix + 2) in+                         if followingByte thirdByte+                           then (# unboxWord hasSurrogate, (# | | (# 4##, 1##, unboxWord (byteFourPartialThree firstByte secondByte thirdByte) #) #) #)+                           else (# unboxWord hasSurrogate, (# unboxInt ix | | #) #)+                       else (# unboxWord hasSurrogate, (# unboxInt ix | | #) #)+                 | ix + 1 < end -> +                     let !secondByte = safeIndex arr (ix + 1) in+                     if followingByte secondByte+                       then (# unboxWord hasSurrogate, (# | | (# 4##, 2##, unboxWord (byteFourPartialTwo firstByte secondByte) #) #) #)+                       else (# unboxWord hasSurrogate, (# unboxInt ix | | #) #)+                 | otherwise -> (# unboxWord hasSurrogate, (# | | (# 4##, 3##, unboxWord (byteFourPartialOne firstByte) #) #) #)+          | otherwise -> (# unboxWord hasSurrogate, (# unboxInt ix | | #) #)+    else (# unboxWord hasSurrogate, (# | (# #) | #) #)++byteTwoPartialOne :: Word8 -> Word+byteTwoPartialOne w = word8ToWord w .&. 0b00011111++byteThreePartialTwo :: Word8 -> Word8 -> Word+byteThreePartialTwo a b =+  unsafeShiftL (word8ToWord a .&. 0b00001111) 6 .|.+  (word8ToWord b .&. 0b00111111)++byteThreePartialOne :: Word8 -> Word+byteThreePartialOne a = word8ToWord a .&. 0b00001111++byteFourPartialTwo :: Word8 -> Word8 -> Word+byteFourPartialTwo a b =+  unsafeShiftL (word8ToWord a .&. 0b00000111) 6 .|.+  (word8ToWord b .&. 0b00111111)++byteFourPartialThree :: Word8 -> Word8 -> Word8 -> Word+byteFourPartialThree a b c =+  unsafeShiftL (word8ToWord a .&. 0b00000111) 12 .|.+  unsafeShiftL (word8ToWord b .&. 0b00111111) 6 .|.+  (word8ToWord c .&. 0b00111111)++byteFourPartialOne :: Word8 -> Word+byteFourPartialOne a = word8ToWord a .&. 0b00000111++followingByte :: Word8 -> Bool+followingByte !w = xor w 0b01000000 .&. 0b11000000 == 0b11000000++oneByteChar :: Word8 -> Bool+oneByteChar !w = w .&. 0b10000000 == 0++twoByteChar :: Word8 -> Bool+twoByteChar !w = w .&. 0b11100000 == 0b11000000++threeByteChar :: Word8 -> Bool+threeByteChar !w = w .&. 0b11110000 == 0b11100000++fourByteChar :: Word8 -> Bool+fourByteChar !w = w .&. 0b11111000 == 0b11110000++codepointFromThreeBytes :: Word8 -> Word8 -> Word8 -> Word+codepointFromThreeBytes w1 w2 w3 = +  unsafeShiftL (word8ToWord w1 .&. 0b00001111) 12 .|. +  unsafeShiftL (word8ToWord w2 .&. 0b00111111) 6 .|. +  (word8ToWord w3 .&. 0b00111111)++word8ToWord :: Word8 -> Word+word8ToWord = fromIntegral++surrogate :: Word -> Bool+surrogate codepoint = codepoint >= 0xD800 && codepoint < 0xE000++binaryOneThenZeroes :: Word+binaryOneThenZeroes = maxBound - div (maxBound :: Word) 2+

+ src/Packed/Text.hs view

@@ -0,0 +1,600 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedSums #-}+{-# LANGUAGE UnboxedTuples #-}++{-# OPTIONS_GHC+ -Weverything+ -fno-warn-unsafe+ -fno-warn-implicit-prelude+ -fno-warn-missing-import-lists+ -O2+#-}++module Packed.Text+  ( Text(..)+  , empty+  , pack+  , unpack+  , breakChar+  , map+  , toUpper+  , take+  , drop+  , dropEnd+  , length+    -- * Encoding+  , decodeAscii+  , decodeResumeAscii+  , decodeUtf8+  , decodeResumeUtf8+  , encodeUtf8+  ) where++import Prelude hiding (map,take,drop,length)+import Data.Char (ord,chr)+import Data.Primitive (MutableByteArray)+import Packed.Bytes.Small (ByteArray)+import GHC.Exts (Word#)+import GHC.Int (Int(I#))+import GHC.Word (Word(W#),Word8(W8#))+import Data.Bits ((.&.),(.|.),unsafeShiftR,unsafeShiftL,complement)+import Control.Monad.ST (ST,runST)+import Packed.Bytes (Bytes(..))+import qualified Data.Char+import qualified Packed.Bytes.Small as BA+import qualified Packed.Bytes.Window as BAW+import qualified Packed.Bytes as B+import qualified Data.Primitive as PM++data Text = Text+  {-# UNPACK #-} !ByteArray -- payload, normal UTF8-encoded text, nothing special like the unsliced variant+  {-# UNPACK #-} !Word -- offset in bytes, not in characters, first bit reserved+  {-# UNPACK #-} !Int -- length in bytes, not in characters+-- The byte-multiplicity for text is always Multiple if+-- a multi-byte character is present. If no multi-byte+-- characters are present, it may be set to either single+-- or multiple. Functions should try to set it to single+-- when possible.++instance Eq Text where+  t1 == t2 = Bytes arr1 off1 len1 == Bytes arr2 off2 len2+    where+    !(!arr1,!off1,!len1,!_) = textMatch t1+    !(!arr2,!off2,!len2,!_) = textMatch t2++instance Show Text where+  show = show . unpack ++newtype Multiplicity = Multiplicity Word+  deriving Eq++appendMult :: Multiplicity -> Multiplicity -> Multiplicity+appendMult (Multiplicity a) (Multiplicity b) = Multiplicity (a .|. b)++single :: Multiplicity+single = Multiplicity 0++multiple :: Multiplicity+multiple = Multiplicity binaryOneThenZeroes++pack :: String -> Text+pack str = case metadata 0 single str of+  (!totalBytes,!totalMult) -> +    let !arr = runST $ do+          marr <- PM.newByteArray totalBytes+          let go [] !_ = return ()+              go (!c : cs) !ix0 = do+                ix1 <- writeChar c ix0 marr+                go cs ix1+          go str 0+          PM.unsafeFreezeByteArray marr+     in Text arr (buildZeroOffMult totalMult) totalBytes+  where+  metadata :: Int -> Multiplicity -> [Char] -> (Int,Multiplicity)+  metadata !totalBytes !totalMult [] = (totalBytes,totalMult)+  metadata !totalBytes !totalMult (!c : cs) =+    let !bytes = charBytes c+        !mult = if bytes < 2 then single else multiple+     in metadata (bytes + totalBytes) (appendMult mult totalMult) cs++-- Result is between 1 and 4. The guards used here do not have to treat+-- surrogates as a special case.+charBytes :: Char -> Int+charBytes !c+  | codepoint < 0x80 = 1+  | codepoint < 0x800 = 2+  | codepoint < 0x10000 = 3+  | otherwise = 4+  where+  !codepoint = intToWord (ord c)++-- returns the new index+writeChar :: Char -> Int -> PM.MutableByteArray s -> ST s Int+writeChar !c !ix !marr+  | codepoint < 0x80 = do+      PM.writeByteArray marr ix (unsafeWordToWord8 codepoint)+      return (ix + 1)+  | codepoint < 0x800 = do+      PM.writeByteArray marr ix (unsafeWordToWord8 (byteTwoOne codepoint))+      PM.writeByteArray marr (ix + 1) (unsafeWordToWord8 (byteTwoTwo codepoint))+      return (ix + 2)+  | surrogate codepoint = do+      -- Codepoint U+FFFD+      PM.writeByteArray marr ix (0xEF :: Word8)+      PM.writeByteArray marr (ix + 1) (0xBF :: Word8)+      PM.writeByteArray marr (ix + 2) (0xBD :: Word8)+      return (ix + 3)+  | codepoint < 0x10000 = do+      PM.writeByteArray marr ix (unsafeWordToWord8 (byteThreeOne codepoint))+      PM.writeByteArray marr (ix + 1) (unsafeWordToWord8 (byteThreeTwo codepoint))+      PM.writeByteArray marr (ix + 2) (unsafeWordToWord8 (byteThreeThree codepoint))+      return (ix + 3)+  | otherwise = do+      PM.writeByteArray marr ix (unsafeWordToWord8 (byteFourOne codepoint))+      PM.writeByteArray marr (ix + 1) (unsafeWordToWord8 (byteFourTwo codepoint))+      PM.writeByteArray marr (ix + 2) (unsafeWordToWord8 (byteFourThree codepoint))+      PM.writeByteArray marr (ix + 3) (unsafeWordToWord8 (byteFourFour codepoint))+      return (ix + 4)+  where+  !codepoint = intToWord (ord c)++unpack :: Text -> String+unpack !t = go off+  where+  go :: Int -> String+  go !ix0 = if ix0 < len + off+    then+      let !(!ix1,!c) = nextChar arr ix0+       in c : go ix1+    else []+  !(!arr,!off,!len,!_) = textMatch t++nextChar :: ByteArray -> Int -> (Int,Char)+nextChar !arr !ix+  | oneByteChar firstByte = (ix + 1, wordToChar (word8ToWord firstByte))+  | twoByteChar firstByte =+      let !secondByte = BA.unsafeIndex arr (ix + 1)+       in (ix + 2, charFromTwoBytes firstByte secondByte)+  | threeByteChar firstByte =+      let !secondByte = BA.unsafeIndex arr (ix + 1)+          !thirdByte = BA.unsafeIndex arr (ix + 2)+       in (ix + 3, charFromThreeBytes firstByte secondByte thirdByte)+  | otherwise =+      let !secondByte = BA.unsafeIndex arr (ix + 1)+          !thirdByte = BA.unsafeIndex arr (ix + 2)+          !fourthByte = BA.unsafeIndex arr (ix + 3)+       in (ix + 4, charFromFourBytes firstByte secondByte thirdByte fourthByte)+  where+  firstByte :: Word8+  !firstByte = BA.unsafeIndex arr ix++nextCharIx :: ByteArray -> Int -> Int+nextCharIx !arr !ix+  | oneByteChar firstByte = ix + 1+  | twoByteChar firstByte = ix + 2+  | threeByteChar firstByte = ix + 3+  | otherwise = ix + 4+  where+  firstByte :: Word8+  !firstByte = BA.unsafeIndex arr ix++moveChars ::+     ByteArray -- array+  -> Int -- start index+  -> Int -- maximal index+  -> Int -- number of characters to move through+  -> Int -- end index+moveChars !arr !start0 !maxIndex !n0 = go start0 n0+  where+  go :: Int -> Int -> Int+  go !ix !n = if n > 0 && ix < maxIndex+    then go (nextCharIx arr ix) (n - 1)+    else ix++countChars ::+     ByteArray -- array+  -> Int -- start index+  -> Int -- maximal index+  -> Int -- number of characters +countChars !arr !start0 !maxIndex = go start0 0+  where+  go :: Int -> Int -> Int+  go !ix !acc = if ix < maxIndex+    then go (nextCharIx arr ix) (acc + 1)+    else acc++oneByteChar :: Word8 -> Bool+oneByteChar w = w .&. 0b10000000 == 0++twoByteChar :: Word8 -> Bool+twoByteChar w = w .&. 0b11100000 == 0b11000000++threeByteChar :: Word8 -> Bool+threeByteChar w = w .&. 0b11110000 == 0b11100000++charFromTwoBytes :: Word8 -> Word8 -> Char+charFromTwoBytes w1 w2 = wordToChar $+  unsafeShiftL (word8ToWord w1 .&. 0b00011111) 6 .|. +  (word8ToWord w2 .&. 0b00111111)++charFromThreeBytes :: Word8 -> Word8 -> Word8 -> Char+charFromThreeBytes w1 w2 w3 = wordToChar $+  unsafeShiftL (word8ToWord w1 .&. 0b00001111) 12 .|. +  unsafeShiftL (word8ToWord w2 .&. 0b00111111) 6 .|. +  (word8ToWord w3 .&. 0b00111111)++charFromFourBytes :: Word8 -> Word8 -> Word8 -> Word8 -> Char+charFromFourBytes w1 w2 w3 w4 = wordToChar $+  unsafeShiftL (word8ToWord w1 .&. 0b00000111) 18 .|. +  unsafeShiftL (word8ToWord w2 .&. 0b00111111) 12 .|. +  unsafeShiftL (word8ToWord w3 .&. 0b00111111) 6 .|. +  (word8ToWord w4 .&. 0b00111111)++-- precondition: codepoint is less than 0x800+byteTwoOne :: Word -> Word+byteTwoOne w = unsafeShiftR w 6 .|. 0b11000000++byteTwoTwo :: Word -> Word+byteTwoTwo w = (w .&. 0b00111111) .|. 0b10000000++-- precondition: codepoint is less than 0x1000+byteThreeOne :: Word -> Word+byteThreeOne w = unsafeShiftR w 12 .|. 0b11100000++byteThreeTwo :: Word -> Word+byteThreeTwo w = (0b00111111 .&. unsafeShiftR w 6) .|. 0b10000000++byteThreeThree :: Word -> Word+byteThreeThree w = (w .&. 0b00111111) .|. 0b10000000++-- precondition: codepoint is less than 0x110000+byteFourOne :: Word -> Word+byteFourOne w = unsafeShiftR w 18 .|. 0b11110000++byteFourTwo :: Word -> Word+byteFourTwo w = (0b00111111 .&. unsafeShiftR w 12) .|. 0b10000000++byteFourThree :: Word -> Word+byteFourThree w = (0b00111111 .&. unsafeShiftR w 6) .|. 0b10000000++byteFourFour :: Word -> Word+byteFourFour w = (0b00111111 .&. w) .|. 0b10000000++++word8ToWord :: Word8 -> Word+word8ToWord = fromIntegral++intToWord :: Int -> Word+intToWord = fromIntegral++wordToInt :: Word -> Int+wordToInt = fromIntegral++unsafeWordToWord8 :: Word -> Word8+unsafeWordToWord8 (W# w) = W8# w++wordToChar :: Word -> Char+wordToChar w = chr (fromIntegral w)++empty :: Text+empty = Text BA.empty 0 0++breakChar :: Char -> Text -> (Text,Text)+breakChar !c !t+  | codepoint < 0x80 = breakOnByte1 (unsafeWordToWord8 codepoint) t+  | codepoint < 0x800 = case findBytePair off len (unsafeWordToWord8 (byteTwoOne codepoint)) (unsafeWordToWord8 (byteTwoTwo codepoint)) arr of+      Nothing -> (t,empty)+      Just ix -> (Text arr (buildOffMult off mult) (ix - off), Text arr (buildOffMult ix mult) (len + off - ix))+  | surrogate codepoint = case findByteTriple off len 0xEF 0xBF 0xBD arr of+      Nothing -> (t,empty)+      Just ix -> (Text arr (buildOffMult off mult) (ix - off), Text arr (buildOffMult ix mult) (len + off - ix))+  | codepoint < 0x10000 = case findByteTriple off len (unsafeWordToWord8 (byteThreeOne codepoint)) (unsafeWordToWord8 (byteThreeTwo codepoint)) (unsafeWordToWord8 (byteThreeThree codepoint)) arr of+      Nothing -> (t,empty)+      Just ix -> (Text arr (buildOffMult off mult) (ix - off), Text arr (buildOffMult ix mult) (len + off - ix))+  | otherwise = case findByteQuadruple off len (unsafeWordToWord8 (byteFourOne codepoint)) (unsafeWordToWord8 (byteFourTwo codepoint)) (unsafeWordToWord8 (byteFourThree codepoint)) (unsafeWordToWord8 (byteFourFour codepoint)) arr of+      Nothing -> (t,empty)+      Just ix -> (Text arr (buildOffMult off mult) (ix - off), Text arr (buildOffMult ix mult) (len + off - ix))+  where+  !codepoint = intToWord (ord c)+  !(!arr,!off,!len,!mult) = textMatch t++findBytePair :: Int -> Int -> Word8 -> Word8 -> ByteArray -> Maybe Int+findBytePair off0 len0 w1 w2 arr = go off0 (off0 + len0 - 1)+  where+  go :: Int -> Int -> Maybe Int+  go !ix !end = if ix < end+    then if PM.indexByteArray arr ix == w1 && PM.indexByteArray arr (ix + 1) == w2+      then Just ix+      else go (ix + 1) end+    else Nothing++findByteTriple :: Int -> Int -> Word8 -> Word8 -> Word8 -> ByteArray -> Maybe Int+findByteTriple off0 len0 w1 w2 w3 arr = go off0 (off0 + len0 - 2)+  where+  go :: Int -> Int -> Maybe Int+  go !ix !end = if ix < end+    then if PM.indexByteArray arr ix == w1 && PM.indexByteArray arr (ix + 1) == w2 && PM.indexByteArray arr (ix + 2) == w3+      then Just ix+      else go (ix + 1) end+    else Nothing++findByteQuadruple :: Int -> Int -> Word8 -> Word8 -> Word8 -> Word8 -> ByteArray -> Maybe Int+findByteQuadruple off0 len0 w1 w2 w3 w4 arr = go off0 (off0 + len0 - 3)+  where+  go :: Int -> Int -> Maybe Int+  go !ix !end = if ix < end+    then if PM.indexByteArray arr ix == w1 && PM.indexByteArray arr (ix + 1) == w2 && PM.indexByteArray arr (ix + 2) == w3 && PM.indexByteArray arr (ix + 3) == w4+      then Just ix+      else go (ix + 1) end+    else Nothing++-- precondition: the Word is less than 0x80+breakOnByte1 :: Word8 -> Text -> (Text,Text)+breakOnByte1 !w !t =+  let !(!arr,!off,!len,!mult) = textMatch t+   in case BAW.findByte off len w arr of+        Nothing -> (t,empty)+        Just !ix -> (dwindle (Text arr (buildOffMult off mult) (ix - off)), Text arr (buildOffMult ix mult) (len + off - ix))++dwindle :: Text -> Text+dwindle t@(Text _ _ !len) = if len > 0 then t else empty+  +buildOffMult :: Int -> Multiplicity -> Word+buildOffMult i (Multiplicity x) = intToWord i .|. x++buildZeroOffMult :: Multiplicity -> Word+buildZeroOffMult (Multiplicity w) = w++textMatch :: Text -> (ByteArray,Int,Int,Multiplicity)+textMatch (Text arr offMult len) =+  ( arr+  , wordToInt (binaryZeroThenOnes .&. offMult)+  , len+  , Multiplicity (offMult .&. binaryOneThenZeroes)+  )++binaryOneThenZeroes :: Word+binaryOneThenZeroes = maxBound - div (maxBound :: Word) 2++binaryZeroThenOnes :: Word+binaryZeroThenOnes = div (maxBound :: Word) 2++surrogate :: Word -> Bool+surrogate codepoint = codepoint >= 0xD800 && codepoint < 0xE000++-- Each byte in the word that is a lowercase ascii character is turned+-- into 0x80. All other bytes become 0x00.+hasAsciiLowerArtifact :: Word -> Word+hasAsciiLowerArtifact w = +  ((div maxBound 255 * (127 + hi)) - (w .&. (div maxBound 255 * 127))) .&. complement w .&.+  ((w .&. (div maxBound 255 * 127)) + (div maxBound 255 * (127 - lo))) .&. (div maxBound 255 * 128)+  where+  lo = intToWord (ord 'a' - 1)+  hi = intToWord (ord 'z' + 1)++-- TODO: improve this. Currently, we do not use a vectorized implementation if+-- the string doesn't start aligned on a machine word address. We can fix this+-- by padding the result to the left to line it up better. This would trade a+-- small amount of space for more speed.+{-# INLINE mapVectorizable #-}+mapVectorizable ::+     (Word8 -> Word8) -- function+  -> (Word -> Word) -- vectorized function variant+  -> Int -- start+  -> Int -- len+  -> ByteArray -- array+  -> ByteArray+mapVectorizable !func !funcMach !start !len !arr = runST action+  where+  action :: forall s. ST s ByteArray+  action = do+    marr <- PM.newByteArray len+    let !(!quotStart,!remStart) = quotRem start (PM.sizeOf (undefined :: Word))+        go :: Int -> Int -> ST s ()+        go !ix !end = if ix < end+          then do+            PM.writeByteArray marr ix (func (PM.indexByteArray arr (start + ix)))+            go (ix + 1) end+          else return ()+        goMach :: Int -> Int -> ST s ()+        goMach !ix !end = if ix < end+          then do+            PM.writeByteArray marr ix (funcMach (PM.indexByteArray arr (quotStart + ix)))+            goMach (ix + 1) end+          else return ()+    if remStart == 0+      then do+        let !lenQuotient = quot len (PM.sizeOf (undefined :: Word))+        goMach 0 lenQuotient+        go (lenQuotient * PM.sizeOf (undefined :: Word)) len+      else go 0 len+    PM.unsafeFreezeByteArray marr++toUpperAsciiWord8 :: Word8 -> Word8+toUpperAsciiWord8 w = if word8ToWord w - intToWord (ord 'a') < 26+  then w - 0x20+  else w++toUpperAsciiWord :: Word -> Word+toUpperAsciiWord w = w - unsafeShiftR (hasAsciiLowerArtifact w) 2++toUpperAscii :: Int -> Int -> ByteArray -> ByteArray+toUpperAscii !off !len !arr = mapVectorizable toUpperAsciiWord8 toUpperAsciiWord off len arr++toUpper :: Text -> Text+toUpper t = if mult == single+  then Text (toUpperAscii off len arr) (buildZeroOffMult single) len+  else map Data.Char.toUpper t+  where+  !(!arr,!off,!len,!mult) = textMatch t++map :: (Char -> Char) -> Text -> Text+map f !t = runST action+  where+  !(!arr,!off,!len,!_) = textMatch t+  action :: ST s Text+  action = do+    marr0 <- PM.newByteArray (len + 3)+    let go :: Int -> Int -> Int -> Multiplicity -> MutableByteArray s -> ST s (Int,MutableByteArray s,Multiplicity)+        go !ixSrc !ixDst !marrLen !mult !marr = if ixSrc < off + len+          then do+            let !(!ixSrcNext,!c) = nextChar arr ixSrc+                !c' = f c+                -- It is disappointing that this is handled this+                -- way. Reconsider this later.+                !newMult = appendMult mult (if ixSrcNext - ixSrc > 1 then multiple else single)+            if ixDst < marrLen - 3+              then do+                ixDstNext <- writeChar c' ixDst marr+                go ixSrcNext ixDstNext marrLen newMult marr+              else do+                let newMarrLen = marrLen * 2+                newMarr <- PM.newByteArray newMarrLen+                PM.copyMutableByteArray newMarr 0 marr 0 marrLen -- possible minus 3?+                ixDstNext <- writeChar c' ixDst newMarr+                go ixSrcNext ixDstNext newMarrLen newMult newMarr+          else return (ixDst,marr,mult)+    (finalLen,finalMarr,finalMult) <- go off 0 (len + 3) single marr0+    newArr <- PM.unsafeFreezeByteArray finalMarr+    return (Text newArr (buildZeroOffMult finalMult) finalLen)++-- | /O(n)/ 'take' @n xs@ returns the prefix of @xs@ of length @n@. It returns+--   @xs@ instead when @n > 'length' xs@. On text containing only ASCII characters,+--   the complexity of this function is reduced to /O(1)/.+take :: Int -> Text -> Text+take !n !t@(Text _ !offMult _) = if n < 1+  then empty+  else if mult == single+    then if n < len+      then Text arr offMult n+      else t+    else if n < len * 4+      then Text arr offMult (moveChars arr off (off + len) n - off)+      else t+  where+  !(!arr,!off,!len,!mult) = textMatch t++-- | /O(n)/ 'drop' @n xs@ returns the suffix of @xs@ after the first @n@ characters+--   have been removed. It returns @empty@ instead when @n > 'length' xs@. On text+--   containing only ASCII characters, the complexity of this function is reduced to /O(1)/.+drop :: Int -> Text -> Text+drop !n !t = if n < 1+  then t+  else if mult == single+    then if n < len+      then Text arr (buildOffMult (off + n) mult) (len - n)+      else empty+    else if n < len * 4+      then+        let !skipped = moveChars arr off (off + len) n - off+         in Text arr (buildOffMult (off + skipped) mult) (len - skipped)+      else empty+  where+  !(!arr,!off,!len,!mult) = textMatch t++length :: Text -> Int+length !t = if mult == single+  then len+  else countChars arr off (off + len)+  where+  !(!arr,!off,!len,!mult) = textMatch t++-- | /O(n)/ 'dropEnd' @n xs@ returns the prefix of @xs@ after the last @n@ characters+--   have been removed. It returns @empty@ instead when @n > 'length' xs@. On text+--   containing only ASCII characters, the complexity of this function is reduced to /O(1)/.+dropEnd :: Int -> Text -> Text+-- Note: There is a way to implement this that is more efficient. It would+-- required scanning UTF-8 encoded text backwards, which seems annoying+-- to do.+dropEnd !n !t = take (length t - n) t++decodeAscii :: Bytes -> Maybe Text+decodeAscii b = case decodeResumeAscii b of+  (# t, (# | (# #) #) #) -> Just t+  (# !_, (# !_ | #) #) -> Nothing+-- decodeAscii b@(Bytes arr off len) = if B.isAscii b+--   then Just (Text arr (buildOffMult off single) len)+--   else Nothing++decodeResumeAscii :: Bytes -> (# Text, (# Bytes | (# #) #) #)+decodeResumeAscii (Bytes arr off len) = case BAW.findNonAscii' off len arr of+  (# (# #) | #) -> (# Text arr (buildOffMult off single) len, (# | (# #) #) #)+  (# | ix# #) -> +    let ix = I# ix#+     in (# Text arr (buildOffMult off single) ix, (# (Bytes arr ix (len + off - ix)) | #) #)++decodeUtf8 :: Bytes -> Maybe Text+decodeUtf8 b = case decodeResumeUtf8 b of+  (# !_, (# !_ | | #) #) -> Nothing+  (# !t, (# | (# #) | #) #) -> Just t+  (# !_, (# | | !_ #) #) -> Nothing++-- decodeUtf8 :: Bytes -> Maybe Text+-- decodeUtf8 b = case decodeResumeUtf8 b of+--   (# !_, West !_ #) -> Nothing+--   (# !t, Center () #) -> Just t+--   (# !_, East !_ #) -> Nothing++data Choice a b c = West a | Center b | East c++decodeResumeUtf8 ::+     Bytes+  -> (# Text, (# Bytes | (# #) | (# Word#, Word#, Word# #) #) #)+decodeResumeUtf8 (Bytes arr off len) = +  let !(# !ascii, !r #) = BAW.isUtf8 off len arr+      !modifiedArr = case ascii of+        1## -> runST $ do+          marr <- PM.newByteArray len+          PM.copyByteArray marr 0 arr off len+          replaceSurrogates 0 len marr+          PM.unsafeFreezeByteArray marr+        _ -> arr+      !mult = case ascii of+        1## -> multiple+        _ -> Multiplicity (W# ascii)+   in case r of+        (# ixFailure# | | #) -> +          let !ixFailure = I# ixFailure#+           in (# Text modifiedArr (buildOffMult off mult) ixFailure, (# (Bytes arr ixFailure (len + off - ixFailure)) | | #) #)+        (# | (# #) | #) -> (# Text modifiedArr (buildOffMult off mult) len, (# | (# #) | #) #)+        (# | | (# w1, w2, w3 #) #) -> (# Text modifiedArr (buildOffMult off mult) len , (# | | (# w1, w2, w3 #) #) #)++replaceSurrogates :: forall s. Int -> Int -> MutableByteArray s -> ST s ()+replaceSurrogates start len marr = go start where+  go :: Int -> ST s ()+  go !ix = if ix < len - 2+    then do+      !w1 <- PM.readByteArray marr ix+      !w2 <- PM.readByteArray marr (ix + 1)+      !w3 <- PM.readByteArray marr (ix + 2)+      if threeByteChar w1 && surrogate (codepointFromThreeBytes w1 w2 w3)+        then do+          -- Codepoint U+FFFD+          PM.writeByteArray marr ix (0xEF :: Word8)+          PM.writeByteArray marr (ix + 1) (0xBF :: Word8)+          PM.writeByteArray marr (ix + 2) (0xBD :: Word8)+          go (ix + 3)+        else go (ix + 1)+    else return ()++codepointFromThreeBytes :: Word8 -> Word8 -> Word8 -> Word+codepointFromThreeBytes w1 w2 w3 = +  unsafeShiftL (word8ToWord w1 .&. 0b00001111) 12 .|. +  unsafeShiftL (word8ToWord w2 .&. 0b00111111) 6 .|. +  (word8ToWord w3 .&. 0b00111111)++convertTuple :: (# (# #) | (# Word#, Word#, Word# #) #) -> Either () (Word,Word,Word)+convertTuple (# (# #) | #) = Left ()+convertTuple (# | w #) = Right (convertWordTuple w)++convertWordTuple :: (# Word#, Word#, Word# #) -> (Word,Word,Word)+convertWordTuple (# a,b,c #) = ( W# a, W# b, W# c )++encodeUtf8 :: Text -> Bytes+encodeUtf8 t = Bytes arr off len where+  !(!arr,!off,!len,!_) = textMatch t+

+ src/Packed/Text/Small.hs view

@@ -0,0 +1,83 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC+ -Weverything+ -fno-warn-unsafe+ -fno-warn-implicit-prelude+ -fno-warn-missing-import-lists+ -O2+#-}+module Packed.Text.Small+  ( SmallText(..)+  , empty+  , reverse+  , decodeAscii+  ) where++import Prelude hiding (reverse)++import Packed.Bytes.Small (ByteArray)+import Data.Bits ((.&.))+import Data.Semigroup (Semigroup)+import qualified Packed.Bytes.Small as BA+import qualified Data.Semigroup as SG++newtype SmallText = SmallText ByteArray ++-- Text is UTF-8 encoded with one caveat. There are several operations+-- that can be faster if we know in advance that all the codepoints in+-- a piece of text are in the ascii range. So, we use the first+-- byte to encode the additional information. If the first byte has+-- zero as the MSB (representing a code point in the ascii range),+-- it is assumed that the entire piece of text only uses code points+-- in the ascii range. If however, the first byte is 0b11111111+-- (which is not valid a UTF-8 byte anywhere), then this first byte is discarded+-- and it is assumed that the text contains code points from any range.+-- The first byte is not allowed to be anything starting with 1.+-- This bloats all non-English text by one byte.++instance Eq SmallText where+  SmallText a == SmallText b = a == b++-- This is a boolean but with a more efficient way to+-- do conjunction+newtype UnicodeRange = UnicodeRange Word++ascii :: UnicodeRange+ascii = UnicodeRange 1++nonAscii :: UnicodeRange+nonAscii = UnicodeRange 0++instance Semigroup UnicodeRange where+  UnicodeRange a <> UnicodeRange b = UnicodeRange (a .&. b)++instance Monoid UnicodeRange where+  mempty = ascii+  mappend = (SG.<>)++unicodeRange :: ByteArray -> UnicodeRange+unicodeRange arr+  | BA.length arr > 0 =+      case BA.unsafeIndex arr 0 of+        0b11111111 -> nonAscii+        _ -> ascii+  | otherwise = ascii++empty :: SmallText+empty = SmallText BA.empty++reverse :: SmallText -> SmallText+reverse (SmallText arr) = case unicodeRange arr of+  UnicodeRange 1 -> SmallText (BA.reverse arr)+  _ -> error "Text.Array.reverse: write the non-ascii case"++decodeAscii :: ByteArray -> Maybe SmallText+decodeAscii arr = if BA.isAscii arr+  then Just (SmallText arr)+  else Nothing++

+ test/Main.hs view

@@ -0,0 +1,325 @@+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE UnboxedSums #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE MagicHash #-}++import Data.Set (Set)+import Data.Word (Word8)+import Hedgehog (Property,Gen,property,forAll,(===),failure)+import Hedgehog.Gen (list,enumBounded,int,frequency,choice,element,integral,word8)+import Hedgehog.Range (Range,linear)+import Test.Tasty (defaultMain,testGroup,TestTree)+import Data.Bits ((.&.))+import Data.Char (chr)+import Test.Tasty.HUnit (testCase)+import Test.Tasty.Hedgehog (testProperty)+import Data.Bifunctor (bimap)+import Data.Monoid+import GHC.Exts (Int#)+import GHC.Types+import Packed.Bytes (Bytes)+import Packed.Bytes.Small (ByteArray)+import GHC.Int (Int(I#))+import Data.Bits ((.&.),(.|.),unsafeShiftR)++import qualified Data.Char+import qualified Test.Tasty.Hedgehog as H+import qualified Packed.Text as T+import qualified Packed.Bytes.Small as BA+import qualified Packed.Bytes.Window as BAW+import qualified Packed.Bytes as B+import qualified Data.Set as S+import qualified GHC.OldList as L++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests"+  [ testGroup "ByteArray"+    [ testProperty "findByte" findByteProp+    , testProperty "zipAnd" zipAndProp+    ]+  , testGroup "Bytes"+    [ testProperty "findByte" sliceFindByteProp+    ]+  , testGroup "Text"+    [ testProperty "pack" textPackProp+    , testProperty "take" textTakeProp+    , testProperty "drop" textDropProp+    , testProperty "breakOnChar" textBreakCharProp+    , testProperty "toUpper" textToUpperProp+    , testProperty "decodeAscii" textDecodeAscii+    , testGroup "decodeUtf8"+      [ testProperty "isomorphism" textDecodeUtf8Iso+      , testProperty "surrogates" textDecodeUtf8Surrogates+        -- TODO: test against malformed inputs to decodeUtf8+      ]+    ]+  ]++isAscii :: Word8 -> Bool+isAscii w = w < 128++decodeAsciiList :: [Word8] -> Maybe String+decodeAsciiList = mapM+  (\w -> if isAscii w then Just (chr (fromIntegral w)) else Nothing)++textDecodeAscii :: Property+textDecodeAscii = property $ do+  bytes <- forAll genMostlyAsciiBytes+  front <- forAll (genOffset (L.length bytes))+  back <- forAll (genOffset (L.length bytes))+  let truncatedBytes = listDropEnd back (L.drop front bytes)+      expected = decodeAsciiList truncatedBytes+      actual = fmap T.unpack (T.decodeAscii (B.dropEnd back (B.drop front (B.pack bytes))))+  expected === actual++textDecodeUtf8Iso :: Property+textDecodeUtf8Iso = property $ do+  chars <- forAll genString+  front <- forAll (genOffset (L.length chars))+  back <- forAll (genOffset (L.length chars))+  let text = T.dropEnd back (T.drop front (T.pack chars))+      decoded = T.decodeUtf8 (T.encodeUtf8 text)+  Just (T.unpack text) === fmap T.unpack decoded++textDecodeUtf8Surrogates :: Property+textDecodeUtf8Surrogates = property $ do+  chars <- forAll genStringSurrogates+  front <- forAll (genOffset (L.length chars))+  back <- forAll (genOffset (L.length chars))+  let truncatedChars = listDropEnd back (L.drop front chars)+      cleanChars = map+        (\c -> if Data.Char.ord c >= 0xD800 && Data.Char.ord c < 0xE000 then chr 0xFFFD else c)+        truncatedChars+      bytes = B.pack (foldMap charToBytesWithSurrogates truncatedChars)+      text = T.dropEnd back (T.drop front (T.pack chars))+      decoded = T.decodeUtf8 (T.encodeUtf8 text)+  Just cleanChars === fmap T.unpack decoded+  Just (T.unpack text) === fmap T.unpack decoded+  Just cleanChars === fmap T.unpack (T.decodeUtf8 bytes)++textPackProp :: Property+textPackProp = property $ do+  chars <- forAll genString+  front <- forAll (genOffset (L.length chars))+  back <- forAll (genOffset (L.length chars))+  let expected = listDropEnd back (L.drop front chars)+      actual = T.unpack (T.dropEnd back (T.drop front (T.pack chars)))+  expected === actual++textTakeProp :: Property+textTakeProp = property $ do+  chars <- forAll genString+  n <- forAll (genChop (L.length chars))+  let expected = L.take n chars+      actual = T.unpack (T.take n (T.pack chars))+  expected === actual++textDropProp :: Property+textDropProp = property $ do+  chars <- forAll genString+  n <- forAll (genChop (L.length chars))+  let expected = L.drop n chars+      actual = T.unpack (T.drop n (T.pack chars))+  expected === actual+++textBreakCharProp :: Property+textBreakCharProp = property $ do+  chars <- forAll genString+  front <- forAll (genOffset (L.length chars))+  back <- forAll (genOffset (L.length chars))+  let truncatedChars = listDropEnd back (L.drop front chars)+  c <- forAll (pickChar truncatedChars)+  let expected = L.break (== c) truncatedChars+      actual = bimap T.unpack T.unpack (T.breakChar c (T.dropEnd back (T.drop front (T.pack chars))))+  expected === actual++textToUpperProp :: Property+textToUpperProp = property $ do+  chars <- forAll genString+  front <- forAll (genOffset (L.length chars))+  back <- forAll (genOffset (L.length chars))+  let expected = L.map Data.Char.toUpper (listDropEnd back (L.drop front chars))+      actual = T.unpack (T.toUpper (T.dropEnd back (T.drop front (T.pack chars))))+  expected === actual++listDropEnd :: Int -> [a] -> [a]+listDropEnd n xs = L.take (L.length xs - n) xs++pickChar :: String -> Gen Char+pickChar s = if L.null s+  then genCharUnicode+  else element s++pickByte :: [Word8] -> Gen Word8+pickByte s = if L.null s+  then genByte+  else element s++genChop :: Int -> Gen Int+genChop originalLen = integral (linear 0 maxDiscard)+  where+  maxDiscard = div (originalLen * 6) 5++genOffset :: Int -> Gen Int+genOffset originalLen = integral (linear 0 maxDiscard)+  where+  maxDiscard = min 19 (div originalLen 3)++-- Generates a string that is either entirely ascii+-- or that is a healthy mixture of characters with+-- variable UTF-8 byte lengths.+genString :: Gen String+genString = frequency [ (3, genStringAscii), (7, genStringUnicode) ]++genSurrogate :: Gen Char+genSurrogate = fmap chr (int (linear 0xD800 0xDFFF))++genSurrogates :: Gen String+genSurrogates = list (linear 0 3) genSurrogate++-- Generates a string that may contain unicode characters+-- in the range U+D800 to U+DFFF.+genStringSurrogates :: Gen String+genStringSurrogates = choice+  [ apcat [genSurrogates, genStringAscii, genSurrogates]+  , apcat [genSurrogates, genStringUnicode, genSurrogates]+  ]++-- Only uses ascii characters+genStringAscii :: Gen String+genStringAscii = list (linear 0 128) (fmap chr (int (linear 0x00 0x7F)))++-- Pulls from unicode characters that have all different+-- UTF-8 byte-lengths. +genStringUnicode :: Gen String+genStringUnicode = list (linear 0 128) genCharUnicode++genCharUnicode :: Gen Char+genCharUnicode = choice+  [ fmap chr (int (linear 0x00 0x7F))+  , fmap chr (int (linear 0x80 0x7FF))+  , fmap (chr . (\x -> if x >= 0xD800 && x <= 0xDFFF then 0xD799 else x)) (int (linear 0x800 0xFFFF))+  , fmap chr (int (linear 0x10000 0x10FFFF))+  ]++genByte :: Gen Word8+genByte = word8 (linear minBound maxBound)++genMostlyAsciiBytes :: Gen [Word8]+genMostlyAsciiBytes = choice+  [ apcat+    [ list (linear 0 20) (word8 (linear 0x00 0x7F))+    , fmap pure (word8 (linear 0xF0 0xFF))+    , list (linear 0 20) (word8 (linear 0x00 0x7F))+    ]+  , list (linear 0 45) (word8 (linear 0x00 0x7F))+  ]++++findByteProp :: Property+findByteProp = property $ do+  wordList :: [Word8] <- forAll (list (linear 0 128) enumBounded)+  let len = L.length wordList+  mindex <- forAll $ frequency+    [ (4, fmap Just (int (linear 0 (len - 1))))+    , (1, pure Nothing)+    ]+  w <- case mindex of+    Just ix -> case safeIndex ix wordList of+      Just b -> pure b+      Nothing -> if len == 0 && ix == 0 then pure 0 else failure+    Nothing -> case findUnusedByte (S.fromList wordList) of+      Just b -> pure b+      Nothing -> failure+  L.elemIndex w wordList === BA.findByte w (BA.pack wordList)++sliceFindByteProp :: Property+sliceFindByteProp = property $ do+  byteList <- forAll (list (linear 0 128) genByte)+  front <- forAll (genOffset (L.length byteList))+  back <- forAll (genOffset (L.length byteList))+  let truncatedByteList = listDropEnd back (L.drop front byteList)+  w <- forAll (pickByte truncatedByteList)+  let expected = L.elemIndex w truncatedByteList+      actual = B.findByte w (B.dropEnd back (B.drop front (B.pack byteList)))+  expected === actual+++zipAndProp :: Property+zipAndProp = property $ do+  xsList :: [Word8] <- forAll (list (linear 0 128) enumBounded)+  ysList :: [Word8] <- forAll (list (linear 0 128) enumBounded)+  let xs = BA.pack xsList+      ys = BA.pack ysList+  L.zipWith (.&.) xsList ysList === BA.unpack (BA.zipAnd xs ys)++safeIndex :: Int -> [a] -> Maybe a+safeIndex !_ [] = Nothing+safeIndex !ix (x : xs) = case compare ix 0 of+  EQ -> Just x+  LT -> Nothing+  GT -> safeIndex (ix - 1) xs++findUnusedByte :: Set Word8 -> Maybe Word8+findUnusedByte s = S.lookupMin (S.difference allBytes s)++allBytes :: Set Word8+allBytes = S.fromList (enumFromTo minBound maxBound)++apcat :: (Applicative f, Monoid a) => [f a] -> f a+apcat = fmap mconcat . sequenceA++-- This is nearly the same this as Packed.Text.pack. However, it does+-- not replace surrogates with U+FFFD. This is useful for testing+-- that we handle surrogates correctly when decoding UTF-8 text.+charToBytesWithSurrogates :: Char -> [Word8]+charToBytesWithSurrogates c+  | p < 0x80 = [wordToWord8 p]+  | p < 0x800 = [wordToWord8 (byteTwoOne p), wordToWord8 (byteTwoTwo p)]+  | p < 0x10000 = [wordToWord8 (byteThreeOne p), wordToWord8 (byteThreeTwo p), wordToWord8 (byteThreeThree p)]+  | otherwise = [wordToWord8 (byteFourOne p), wordToWord8 (byteFourTwo p), wordToWord8 (byteFourThree p), wordToWord8 (byteFourFour p)]+  where+  p :: Word+  p = fromIntegral (Data.Char.ord c)+  +wordToWord8 :: Word -> Word8+wordToWord8 = fromIntegral++-- precondition: codepoint is less than 0x800+byteTwoOne :: Word -> Word+byteTwoOne w = unsafeShiftR w 6 .|. 0b11000000++byteTwoTwo :: Word -> Word+byteTwoTwo w = (w .&. 0b00111111) .|. 0b10000000++-- precondition: codepoint is less than 0x1000+byteThreeOne :: Word -> Word+byteThreeOne w = unsafeShiftR w 12 .|. 0b11100000++byteThreeTwo :: Word -> Word+byteThreeTwo w = (0b00111111 .&. unsafeShiftR w 6) .|. 0b10000000++byteThreeThree :: Word -> Word+byteThreeThree w = (w .&. 0b00111111) .|. 0b10000000++-- precondition: codepoint is less than 0x110000+byteFourOne :: Word -> Word+byteFourOne w = unsafeShiftR w 18 .|. 0b11110000++byteFourTwo :: Word -> Word+byteFourTwo w = (0b00111111 .&. unsafeShiftR w 12) .|. 0b10000000++byteFourThree :: Word -> Word+byteFourThree w = (0b00111111 .&. unsafeShiftR w 6) .|. 0b10000000++byteFourFour :: Word -> Word+byteFourFour w = (0b00111111 .&. w) .|. 0b10000000+