basement 0.0.6 → 0.0.7

raw patch · 29 files changed

+1465/−1130 lines, 29 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Basement/Alg/Foreign/Prim.hs +0/−35
• Basement/Alg/Foreign/String.hs +0/−128
• Basement/Alg/Foreign/UTF8.hs +0/−284
• Basement/Alg/Native/Prim.hs +0/−35
• Basement/Alg/Native/String.hs +0/−128
• Basement/Alg/Native/UTF8.hs +0/−284
• Basement/Alg/PrimArray.hs +19/−23
• Basement/Alg/String.hs +135/−0
• Basement/Alg/UTF8.hs +268/−0
• Basement/Bits.hs +557/−0
• Basement/Block.hs +8/−6
• Basement/Block/Base.hs +5/−7
• Basement/Block/Builder.hs +3/−3
• Basement/Compat/Base.hs +3/−0
• Basement/Compat/Primitive.hs +2/−2
• Basement/From.hs +5/−1
• Basement/Imports.hs +3/−0
• Basement/Sized/Block.hs +120/−3
• Basement/Sized/List.hs +164/−14
• Basement/String.hs +99/−104
• Basement/String/Builder.hs +7/−0
• Basement/Terminal/Size.hsc +3/−0
• Basement/Types/OffsetSize.hs +3/−0
• Basement/Types/Word128.hs +6/−0
• Basement/Types/Word256.hs +7/−1
• Basement/UArray.hs +16/−37
• Basement/UArray/Base.hs +11/−9
• Basement/UTF8/Base.hs +15/−16
• basement.cabal +6/−10

@@ -1,35 +0,0 @@-{-# LANGUAGE MagicHash #-}-module Basement.Alg.Foreign.Prim-    ( Immutable-    , Mutable-    , primIndex-    , primIndex64-    , primRead-    , primWrite-    ) where--import           GHC.Types-import           GHC.Prim-import           GHC.Word-import           Basement.Types.OffsetSize-import           Basement.PrimType-import           Basement.Monad--type Immutable = Addr#-type Mutable st = Addr#--primIndex :: PrimType ty => Immutable -> Offset ty -> ty-primIndex = primAddrIndex-{-# INLINE primIndex #-}--primIndex64 :: Immutable -> Offset Word64 -> Word64-primIndex64 = primIndex-{-# INLINE primIndex64 #-}--primRead :: (PrimMonad prim, PrimType ty) => Mutable (PrimState prim) -> Offset ty -> prim ty-primRead = primAddrRead-{-# INLINE primRead #-}--primWrite :: (PrimMonad prim, PrimType ty) => Mutable (PrimState prim) -> Offset ty -> ty -> prim ()-primWrite = primAddrWrite-{-# INLINE primWrite #-}

@@ -1,128 +0,0 @@-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE MagicHash                  #-}-{-# LANGUAGE NoImplicitPrelude          #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE CPP                        #-}-module Basement.Alg.Foreign.String-    ( copyFilter-    , validate-    , findIndexPredicate-    , revFindIndexPredicate-    ) where--import           GHC.Prim-import           GHC.ST-import           Basement.Compat.Base-import           Basement.Numerical.Additive-import           Basement.Types.OffsetSize--import qualified Basement.Alg.Native.Prim as PrimNative -- NO SUBST-import qualified Basement.Alg.Native.UTF8 as UTF8Native -- NO SUBST-import qualified Basement.Alg.Foreign.Prim as PrimBackend-import qualified Basement.Alg.Foreign.UTF8 as UTF8Backend-import           Basement.UTF8.Helper-import           Basement.UTF8.Table-import           Basement.UTF8.Types--copyFilter :: (Char -> Bool)-           -> CountOf Word8-           -> MutableByteArray# s-           -> PrimBackend.Immutable-           -> Offset Word8-           -> ST s (CountOf Word8)-copyFilter predicate !sz dst src start = loop (Offset 0) start-  where-    !end = start `offsetPlusE` sz-    loop !d !s-        | s == end  = pure (offsetAsSize d)-        | otherwise =-            let !h = PrimBackend.primIndex src s-             in case headerIsAscii h of-                    True | predicate (toChar1 h) -> PrimNative.primWrite dst d h >> loop (d + Offset 1) (s + Offset 1)-                         | otherwise             -> loop d (s + Offset 1)-                    False ->-                        case UTF8Backend.next src s of-                            Step c s' | predicate c -> UTF8Native.write dst d c >>= \d' -> loop d' s'-                                      | otherwise   -> loop d s'--validate :: Offset Word8-         -> PrimBackend.Immutable-         -> Offset Word8-         -> (Offset Word8, Maybe ValidationFailure)-validate end ba ofsStart = loop4 ofsStart-  where-    loop4 !ofs-        | ofs4 < end =-            let h1 = PrimBackend.primIndex ba ofs-                h2 = PrimBackend.primIndex ba (ofs+1)-                h3 = PrimBackend.primIndex ba (ofs+2)-                h4 = PrimBackend.primIndex ba (ofs+3)-             in if headerIsAscii h1 && headerIsAscii h2 && headerIsAscii h3 && headerIsAscii h4-                    then loop4 ofs4-                    else loop ofs-        | otherwise     = loop ofs-      where-        !ofs4 = ofs+4-    loop !ofs-        | ofs == end      = (end, Nothing)-        | headerIsAscii h = loop (ofs + Offset 1)-        | otherwise       = multi (CountOf $ getNbBytes h) ofs-      where-        h = PrimBackend.primIndex ba ofs--    multi (CountOf 0xff) pos = (pos, Just InvalidHeader)-    multi nbConts pos-        | (posNext `offsetPlusE` nbConts) > end = (pos, Just MissingByte)-        | otherwise =-            case nbConts of-                CountOf 1 ->-                    let c1 = PrimBackend.primIndex ba posNext-                    in if isContinuation c1-                        then loop (pos + Offset 2)-                        else (pos, Just InvalidContinuation)-                CountOf 2 ->-                    let c1 = PrimBackend.primIndex ba posNext-                        c2 = PrimBackend.primIndex ba (pos + Offset 2)-                     in if isContinuation2 c1 c2-                            then loop (pos + Offset 3)-                            else (pos, Just InvalidContinuation)-                CountOf _ ->-                    let c1 = PrimBackend.primIndex ba posNext-                        c2 = PrimBackend.primIndex ba (pos + Offset 2)-                        c3 = PrimBackend.primIndex ba (pos + Offset 3)-                     in if isContinuation3 c1 c2 c3-                            then loop (pos + Offset 4)-                            else (pos, Just InvalidContinuation)-      where posNext = pos + Offset 1--findIndexPredicate :: (Char -> Bool)-                   -> PrimBackend.Immutable-                   -> Offset Word8-                   -> Offset Word8-                   -> Offset Word8-findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex-  where-    loop !i-        | i < endIndex && not (predicate c) = loop (i')-        | otherwise                         = i-      where-        Step c i' = UTF8Backend.next ba i-{-# INLINE findIndexPredicate #-}--revFindIndexPredicate :: (Char -> Bool)-                      -> PrimBackend.Immutable-                      -> Offset Word8-                      -> Offset Word8-                      -> Offset Word8-revFindIndexPredicate predicate ba startIndex endIndex-    | endIndex > startIndex = loop endIndex-    | otherwise             = endIndex-  where-    loop !i-        | predicate c     = i'-        | i' > startIndex = loop i'-        | otherwise       = endIndex-      where -        StepBack c i' = UTF8Backend.prev ba i-{-# INLINE revFindIndexPredicate #-}

@@ -1,284 +0,0 @@-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE MagicHash                  #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE CPP                        #-}-module Basement.Alg.Foreign.UTF8-    ( Immutable-    , Mutable-    -- * functions-    , nextAscii-    , nextAsciiDigit-    , expectAscii-    , next-    , nextSkip-    , prev-    , prevSkip-    , write-    , toList-    , all-    , any-    , foldr-    , length-    , reverse-    -- temporary-    , primIndex64-    , primRead8-    , primWrite8-    ) where--import           GHC.Int-import           GHC.Types-import           GHC.Word-import           GHC.Prim-import           Data.Bits-import           Basement.Compat.Base hiding (toList)-import           Basement.Compat.Primitive-import           Basement.Alg.Foreign.Prim-import qualified Basement.Alg.Native.Prim as PrimNative -- NO SUBST-import           Data.Proxy-import           Basement.Numerical.Additive-import           Basement.Numerical.Subtractive-import           Basement.Types.OffsetSize-import           Basement.Monad-import           Basement.PrimType-import           Basement.UTF8.Helper-import           Basement.UTF8.Table-import           Basement.UTF8.Types--primWrite8 :: PrimMonad prim => Mutable (PrimState prim) -> Offset Word8 -> Word8 -> prim ()-primWrite8 = primWrite-{-# INLINE primWrite8 #-}--primRead8 :: PrimMonad prim => Mutable (PrimState prim) -> Offset Word8 -> prim Word8-primRead8 = primRead-{-# INLINE primRead8 #-}--primIndex8 :: Immutable -> Offset Word8 -> Word8-primIndex8 = primIndex-{-# INLINE primIndex8 #-}--nextAscii :: Immutable -> Offset Word8 -> StepASCII-nextAscii ba n = StepASCII w-  where-    !w = primIndex ba n-{-# INLINE nextAscii #-}---- | nextAsciiBa specialized to get a digit between 0 and 9 (included)-nextAsciiDigit :: Immutable -> Offset Word8 -> StepDigit-nextAsciiDigit ba n = StepDigit (primIndex8 ba n - 0x30)-{-# INLINE nextAsciiDigit #-}--expectAscii :: Immutable -> Offset Word8 -> Word8 -> Bool-expectAscii ba n v = primIndex8 ba n == v-{-# INLINE expectAscii #-}--next :: Immutable -> Offset8 -> Step-next ba n =-    case getNbBytes h of-        0 -> Step (toChar1 h) (n + Offset 1)-        1 -> Step (toChar2 h (primIndex8 ba (n + Offset 1))) (n + Offset 2)-        2 -> Step (toChar3 h (primIndex8 ba (n + Offset 1))-                             (primIndex8 ba (n + Offset 2))) (n + Offset 3)-        3 -> Step (toChar4 h (primIndex8 ba (n + Offset 1))-                             (primIndex8 ba (n + Offset 2))-                             (primIndex8 ba (n + Offset 3))) (n + Offset 4)-        r -> error ("next: internal error: invalid input: offset=" <> show n <> " table=" <> show r <> " h=" <> show h)-  where-    !h = primIndex8 ba n-{-# INLINE next #-}--nextSkip :: Immutable -> Offset Word8 -> Offset Word8-nextSkip ba n = n + 1 + Offset (getNbBytes (primIndex8 ba n))-{-# INLINE nextSkip #-}---- Given a non null offset, give the previous character and the offset of this character--- will fail bad if apply at the beginning of string or an empty string.-prev :: Immutable -> Offset Word8 -> StepBack-prev ba offset =-    case primIndex8 ba prevOfs1 of-        (W8# v1) | isContinuation# v1 -> atLeast2 (maskContinuation# v1)-                 | otherwise          -> StepBack (toChar# v1) prevOfs1-  where-    sz1 = CountOf 1-    !prevOfs1 = offset `offsetMinusE` sz1-    prevOfs2 = prevOfs1 `offsetMinusE` sz1-    prevOfs3 = prevOfs2 `offsetMinusE` sz1-    prevOfs4 = prevOfs3 `offsetMinusE` sz1-    atLeast2 !v  =-        case primIndex8 ba prevOfs2 of-            (W8# v2) | isContinuation# v2 -> atLeast3 (or# (uncheckedShiftL# (maskContinuation# v2) 6#) v)-                     | otherwise          -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader2# v2) 6#) v)) prevOfs2-    atLeast3 !v =-        case primIndex8 ba prevOfs3 of-            (W8# v3) | isContinuation# v3 -> atLeast4 (or# (uncheckedShiftL# (maskContinuation# v3) 12#) v)-                     | otherwise          -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader3# v3) 12#) v)) prevOfs3-    atLeast4 !v =-        case primIndex8 ba prevOfs4 of-            (W8# v4) -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader4# v4) 18#) v)) prevOfs4--prevSkip :: Immutable -> Offset Word8 -> Offset Word8-prevSkip ba offset = loop (offset `offsetMinusE` sz1)-  where-    sz1 = CountOf 1-    loop o-        | isContinuation (primIndex8 ba o) = loop (o `offsetMinusE` sz1)-        | otherwise                       = o--write :: PrimMonad prim => Mutable (PrimState prim) -> Offset8 -> Char -> prim Offset8-write mba !i !c-    | bool# (ltWord# x 0x80##   ) = encode1-    | bool# (ltWord# x 0x800##  ) = encode2-    | bool# (ltWord# x 0x10000##) = encode3-    | otherwise                   = encode4-  where-    !(I# xi) = fromEnum c-    !x       = int2Word# xi--    encode1 = primWrite8 mba i (W8# x) >> pure (i + Offset 1)-    encode2 = do-        let x1  = or# (uncheckedShiftRL# x 6#) 0xc0##-            x2  = toContinuation x-        primWrite8 mba i     (W8# x1)-        primWrite8 mba (i+1) (W8# x2)-        pure (i + Offset 2)--    encode3 = do-        let x1  = or# (uncheckedShiftRL# x 12#) 0xe0##-            x2  = toContinuation (uncheckedShiftRL# x 6#)-            x3  = toContinuation x-        primWrite8 mba i            (W8# x1)-        primWrite8 mba (i+Offset 1) (W8# x2)-        primWrite8 mba (i+Offset 2) (W8# x3)-        pure (i + Offset 3)--    encode4 = do-        let x1  = or# (uncheckedShiftRL# x 18#) 0xf0##-            x2  = toContinuation (uncheckedShiftRL# x 12#)-            x3  = toContinuation (uncheckedShiftRL# x 6#)-            x4  = toContinuation x-        primWrite8 mba i            (W8# x1)-        primWrite8 mba (i+Offset 1) (W8# x2)-        primWrite8 mba (i+Offset 2) (W8# x3)-        primWrite8 mba (i+Offset 3) (W8# x4)-        pure (i + Offset 4)--    toContinuation :: Word# -> Word#-    toContinuation w = or# (and# w 0x3f##) 0x80##-{-# INLINE write #-}--toList :: Immutable -> Offset Word8 -> Offset Word8 -> [Char]-toList ba !start !end = loop start-  where-    loop !idx-        | idx == end = []-        | otherwise  = c : loop idx'-      where (Step c idx') = next ba idx--all :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool-all predicate ba start end = loop start-  where-    loop !idx-        | idx == end  = True-        | predicate c = loop idx'-        | otherwise   = False-      where (Step c idx') = next ba idx-{-# INLINE all #-}--any :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool-any predicate ba start end = loop start-  where-    loop !idx-        | idx == end  = False-        | predicate c = True-        | otherwise   = loop idx'-      where (Step c idx') = next ba idx-{-# INLINE any #-}--foldr :: Immutable -> Offset Word8 -> Offset Word8 -> (Char -> a -> a) -> a -> a-foldr dat start end f acc = loop start-  where-    loop !i-        | i == end  = acc-        | otherwise =-            let (Step c i') = next dat i-             in c `f` loop i'-{-# INLINE foldr #-}--length :: Immutable -> Offset Word8 -> Offset Word8 -> CountOf Char-length dat start end-    | start == end = 0-    | otherwise    = processStart 0 start-  where-    end64 :: Offset Word64-    end64 = offsetInElements end--    prx64 :: Proxy Word64-    prx64 = Proxy--    mask64_80 :: Word64-    mask64_80 = 0x8080808080808080--    processStart :: CountOf Char -> Offset Word8 -> CountOf Char-    processStart !c !i-        | i == end                = c-        | offsetIsAligned prx64 i = processAligned c (offsetInElements i)-        | otherwise               =-            let h    = primIndex8 dat i-                cont = (h .&. 0xc0) == 0x80-                c'   = if cont then c else c+1-             in processStart c' (i+1)-    processAligned :: CountOf Char -> Offset Word64 -> CountOf Char-    processAligned !c !i-        | i >= end64 = processEnd c (offsetInBytes i)-        | otherwise  =-            let !h   = primIndex64 dat i-                !h80 = h .&. mask64_80-             in if h80 == 0-                 then processAligned (c+8) (i+1)-                 else let !nbAscii = if h80 == mask64_80 then 0 else CountOf (8 - popCount h80)-                          !nbHigh  = CountOf $ popCount (h .&. (h80 `unsafeShiftR` 1))-                       in processAligned (c + nbAscii + nbHigh) (i+1)-    processEnd !c !i-        | i == end  = c-        | otherwise =-            let h    = primIndex8 dat i-                cont = (h .&. 0xc0) == 0x80-                c'   = if cont then c else c+1-             in processStart c' (i+1)-{-# INLINE length #-}--reverse :: PrimMonad prim-        => MutableByteArray# (PrimState prim) -- ^ Destination buffer-        -> Offset Word8                       -- ^ Destination start-        -> Immutable                          -- ^ Source buffer-        -> Offset Word8                       -- ^ Source start-        -> Offset Word8                       -- ^ Source end-        -> prim ()-reverse dst dstOfs src start end-    | start == end = pure ()-    | otherwise    = loop (dstOfs `offsetPlusE` (offsetAsSize (end `offsetSub` start)) `offsetSub` 1) start-  where-    loop !d !s-        | s == end        = pure ()-        | headerIsAscii h = PrimNative.primWrite dst d h >> loop (d `offsetSub` 1) (s + 1)-        | otherwise       = do-            case getNbBytes h of-                1 -> do-                    PrimNative.primWrite dst (d `offsetSub` 1) h-                    PrimNative.primWrite dst d                 (primIndex8 src (s + 1))-                    loop (d `offsetSub` 2) (s + 2)-                2 -> do-                    PrimNative.primWrite dst (d `offsetSub` 2) h-                    PrimNative.primWrite dst (d `offsetSub` 1) (primIndex8 src (s + 1))-                    PrimNative.primWrite dst d                 (primIndex8 src (s + 2))-                    loop (d `offsetSub` 3) (s + 3)-                3 -> do-                    PrimNative.primWrite dst (d `offsetSub` 3) h-                    PrimNative.primWrite dst (d `offsetSub` 2) (primIndex8 src (s + 1))-                    PrimNative.primWrite dst (d `offsetSub` 1) (primIndex8 src (s + 2))-                    PrimNative.primWrite dst d                 (primIndex8 src (s + 3))-                    loop (d `offsetSub` 4) (s + 4)-                _ -> error "impossible"-      where h = primIndex8 src s-{-# INLINE reverse #-}

@@ -1,35 +0,0 @@-{-# LANGUAGE MagicHash #-}-module Basement.Alg.Native.Prim-    ( Immutable-    , Mutable-    , primIndex-    , primIndex64-    , primRead-    , primWrite-    ) where--import           GHC.Types-import           GHC.Prim-import           GHC.Word-import           Basement.Types.OffsetSize-import           Basement.PrimType-import           Basement.Monad--type Immutable = ByteArray#-type Mutable st = MutableByteArray# st--primIndex :: PrimType ty => Immutable -> Offset ty -> ty-primIndex = primBaIndex-{-# INLINE primIndex #-}--primIndex64 :: Immutable -> Offset Word64 -> Word64-primIndex64 = primIndex-{-# INLINE primIndex64 #-}--primRead :: (PrimMonad prim, PrimType ty) => Mutable (PrimState prim) -> Offset ty -> prim ty-primRead = primMbaRead-{-# INLINE primRead #-}--primWrite :: (PrimMonad prim, PrimType ty) => Mutable (PrimState prim) -> Offset ty -> ty -> prim ()-primWrite = primMbaWrite-{-# INLINE primWrite #-}

@@ -1,128 +0,0 @@-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE MagicHash                  #-}-{-# LANGUAGE NoImplicitPrelude          #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE CPP                        #-}-module Basement.Alg.Native.String-    ( copyFilter-    , validate-    , findIndexPredicate-    , revFindIndexPredicate-    ) where--import           GHC.Prim-import           GHC.ST-import           Basement.Compat.Base-import           Basement.Numerical.Additive-import           Basement.Types.OffsetSize--import qualified Basement.Alg.Native.Prim as PrimNative -- NO SUBST-import qualified Basement.Alg.Native.UTF8 as UTF8Native -- NO SUBST-import qualified Basement.Alg.Native.Prim as PrimBackend-import qualified Basement.Alg.Native.UTF8 as UTF8Backend-import           Basement.UTF8.Helper-import           Basement.UTF8.Table-import           Basement.UTF8.Types--copyFilter :: (Char -> Bool)-           -> CountOf Word8-           -> MutableByteArray# s-           -> PrimBackend.Immutable-           -> Offset Word8-           -> ST s (CountOf Word8)-copyFilter predicate !sz dst src start = loop (Offset 0) start-  where-    !end = start `offsetPlusE` sz-    loop !d !s-        | s == end  = pure (offsetAsSize d)-        | otherwise =-            let !h = PrimBackend.primIndex src s-             in case headerIsAscii h of-                    True | predicate (toChar1 h) -> PrimNative.primWrite dst d h >> loop (d + Offset 1) (s + Offset 1)-                         | otherwise             -> loop d (s + Offset 1)-                    False ->-                        case UTF8Backend.next src s of-                            Step c s' | predicate c -> UTF8Native.write dst d c >>= \d' -> loop d' s'-                                      | otherwise   -> loop d s'--validate :: Offset Word8-         -> PrimBackend.Immutable-         -> Offset Word8-         -> (Offset Word8, Maybe ValidationFailure)-validate end ba ofsStart = loop4 ofsStart-  where-    loop4 !ofs-        | ofs4 < end =-            let h1 = PrimBackend.primIndex ba ofs-                h2 = PrimBackend.primIndex ba (ofs+1)-                h3 = PrimBackend.primIndex ba (ofs+2)-                h4 = PrimBackend.primIndex ba (ofs+3)-             in if headerIsAscii h1 && headerIsAscii h2 && headerIsAscii h3 && headerIsAscii h4-                    then loop4 ofs4-                    else loop ofs-        | otherwise     = loop ofs-      where-        !ofs4 = ofs+4-    loop !ofs-        | ofs == end      = (end, Nothing)-        | headerIsAscii h = loop (ofs + Offset 1)-        | otherwise       = multi (CountOf $ getNbBytes h) ofs-      where-        h = PrimBackend.primIndex ba ofs--    multi (CountOf 0xff) pos = (pos, Just InvalidHeader)-    multi nbConts pos-        | (posNext `offsetPlusE` nbConts) > end = (pos, Just MissingByte)-        | otherwise =-            case nbConts of-                CountOf 1 ->-                    let c1 = PrimBackend.primIndex ba posNext-                    in if isContinuation c1-                        then loop (pos + Offset 2)-                        else (pos, Just InvalidContinuation)-                CountOf 2 ->-                    let c1 = PrimBackend.primIndex ba posNext-                        c2 = PrimBackend.primIndex ba (pos + Offset 2)-                     in if isContinuation2 c1 c2-                            then loop (pos + Offset 3)-                            else (pos, Just InvalidContinuation)-                CountOf _ ->-                    let c1 = PrimBackend.primIndex ba posNext-                        c2 = PrimBackend.primIndex ba (pos + Offset 2)-                        c3 = PrimBackend.primIndex ba (pos + Offset 3)-                     in if isContinuation3 c1 c2 c3-                            then loop (pos + Offset 4)-                            else (pos, Just InvalidContinuation)-      where posNext = pos + Offset 1--findIndexPredicate :: (Char -> Bool)-                   -> PrimBackend.Immutable-                   -> Offset Word8-                   -> Offset Word8-                   -> Offset Word8-findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex-  where-    loop !i-        | i < endIndex && not (predicate c) = loop (i')-        | otherwise                         = i-      where-        Step c i' = UTF8Backend.next ba i-{-# INLINE findIndexPredicate #-}--revFindIndexPredicate :: (Char -> Bool)-                      -> PrimBackend.Immutable-                      -> Offset Word8-                      -> Offset Word8-                      -> Offset Word8-revFindIndexPredicate predicate ba startIndex endIndex-    | endIndex > startIndex = loop endIndex-    | otherwise             = endIndex-  where-    loop !i-        | predicate c     = i'-        | i' > startIndex = loop i'-        | otherwise       = endIndex-      where -        StepBack c i' = UTF8Backend.prev ba i-{-# INLINE revFindIndexPredicate #-}

@@ -1,284 +0,0 @@-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE MagicHash                  #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE CPP                        #-}-module Basement.Alg.Native.UTF8-    ( Immutable-    , Mutable-    -- * functions-    , nextAscii-    , nextAsciiDigit-    , expectAscii-    , next-    , nextSkip-    , prev-    , prevSkip-    , write-    , toList-    , all-    , any-    , foldr-    , length-    , reverse-    -- temporary-    , primIndex64-    , primRead8-    , primWrite8-    ) where--import           GHC.Int-import           GHC.Types-import           GHC.Word-import           GHC.Prim-import           Data.Bits-import           Basement.Compat.Base hiding (toList)-import           Basement.Compat.Primitive-import           Basement.Alg.Native.Prim-import qualified Basement.Alg.Native.Prim as PrimNative -- NO SUBST-import           Data.Proxy-import           Basement.Numerical.Additive-import           Basement.Numerical.Subtractive-import           Basement.Types.OffsetSize-import           Basement.Monad-import           Basement.PrimType-import           Basement.UTF8.Helper-import           Basement.UTF8.Table-import           Basement.UTF8.Types--primWrite8 :: PrimMonad prim => Mutable (PrimState prim) -> Offset Word8 -> Word8 -> prim ()-primWrite8 = primWrite-{-# INLINE primWrite8 #-}--primRead8 :: PrimMonad prim => Mutable (PrimState prim) -> Offset Word8 -> prim Word8-primRead8 = primRead-{-# INLINE primRead8 #-}--primIndex8 :: Immutable -> Offset Word8 -> Word8-primIndex8 = primIndex-{-# INLINE primIndex8 #-}--nextAscii :: Immutable -> Offset Word8 -> StepASCII-nextAscii ba n = StepASCII w-  where-    !w = primIndex ba n-{-# INLINE nextAscii #-}---- | nextAsciiBa specialized to get a digit between 0 and 9 (included)-nextAsciiDigit :: Immutable -> Offset Word8 -> StepDigit-nextAsciiDigit ba n = StepDigit (primIndex8 ba n - 0x30)-{-# INLINE nextAsciiDigit #-}--expectAscii :: Immutable -> Offset Word8 -> Word8 -> Bool-expectAscii ba n v = primIndex8 ba n == v-{-# INLINE expectAscii #-}--next :: Immutable -> Offset8 -> Step-next ba n =-    case getNbBytes h of-        0 -> Step (toChar1 h) (n + Offset 1)-        1 -> Step (toChar2 h (primIndex8 ba (n + Offset 1))) (n + Offset 2)-        2 -> Step (toChar3 h (primIndex8 ba (n + Offset 1))-                             (primIndex8 ba (n + Offset 2))) (n + Offset 3)-        3 -> Step (toChar4 h (primIndex8 ba (n + Offset 1))-                             (primIndex8 ba (n + Offset 2))-                             (primIndex8 ba (n + Offset 3))) (n + Offset 4)-        r -> error ("next: internal error: invalid input: offset=" <> show n <> " table=" <> show r <> " h=" <> show h)-  where-    !h = primIndex8 ba n-{-# INLINE next #-}--nextSkip :: Immutable -> Offset Word8 -> Offset Word8-nextSkip ba n = n + 1 + Offset (getNbBytes (primIndex8 ba n))-{-# INLINE nextSkip #-}---- Given a non null offset, give the previous character and the offset of this character--- will fail bad if apply at the beginning of string or an empty string.-prev :: Immutable -> Offset Word8 -> StepBack-prev ba offset =-    case primIndex8 ba prevOfs1 of-        (W8# v1) | isContinuation# v1 -> atLeast2 (maskContinuation# v1)-                 | otherwise          -> StepBack (toChar# v1) prevOfs1-  where-    sz1 = CountOf 1-    !prevOfs1 = offset `offsetMinusE` sz1-    prevOfs2 = prevOfs1 `offsetMinusE` sz1-    prevOfs3 = prevOfs2 `offsetMinusE` sz1-    prevOfs4 = prevOfs3 `offsetMinusE` sz1-    atLeast2 !v  =-        case primIndex8 ba prevOfs2 of-            (W8# v2) | isContinuation# v2 -> atLeast3 (or# (uncheckedShiftL# (maskContinuation# v2) 6#) v)-                     | otherwise          -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader2# v2) 6#) v)) prevOfs2-    atLeast3 !v =-        case primIndex8 ba prevOfs3 of-            (W8# v3) | isContinuation# v3 -> atLeast4 (or# (uncheckedShiftL# (maskContinuation# v3) 12#) v)-                     | otherwise          -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader3# v3) 12#) v)) prevOfs3-    atLeast4 !v =-        case primIndex8 ba prevOfs4 of-            (W8# v4) -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader4# v4) 18#) v)) prevOfs4--prevSkip :: Immutable -> Offset Word8 -> Offset Word8-prevSkip ba offset = loop (offset `offsetMinusE` sz1)-  where-    sz1 = CountOf 1-    loop o-        | isContinuation (primIndex8 ba o) = loop (o `offsetMinusE` sz1)-        | otherwise                       = o--write :: PrimMonad prim => Mutable (PrimState prim) -> Offset8 -> Char -> prim Offset8-write mba !i !c-    | bool# (ltWord# x 0x80##   ) = encode1-    | bool# (ltWord# x 0x800##  ) = encode2-    | bool# (ltWord# x 0x10000##) = encode3-    | otherwise                   = encode4-  where-    !(I# xi) = fromEnum c-    !x       = int2Word# xi--    encode1 = primWrite8 mba i (W8# x) >> pure (i + Offset 1)-    encode2 = do-        let x1  = or# (uncheckedShiftRL# x 6#) 0xc0##-            x2  = toContinuation x-        primWrite8 mba i     (W8# x1)-        primWrite8 mba (i+1) (W8# x2)-        pure (i + Offset 2)--    encode3 = do-        let x1  = or# (uncheckedShiftRL# x 12#) 0xe0##-            x2  = toContinuation (uncheckedShiftRL# x 6#)-            x3  = toContinuation x-        primWrite8 mba i            (W8# x1)-        primWrite8 mba (i+Offset 1) (W8# x2)-        primWrite8 mba (i+Offset 2) (W8# x3)-        pure (i + Offset 3)--    encode4 = do-        let x1  = or# (uncheckedShiftRL# x 18#) 0xf0##-            x2  = toContinuation (uncheckedShiftRL# x 12#)-            x3  = toContinuation (uncheckedShiftRL# x 6#)-            x4  = toContinuation x-        primWrite8 mba i            (W8# x1)-        primWrite8 mba (i+Offset 1) (W8# x2)-        primWrite8 mba (i+Offset 2) (W8# x3)-        primWrite8 mba (i+Offset 3) (W8# x4)-        pure (i + Offset 4)--    toContinuation :: Word# -> Word#-    toContinuation w = or# (and# w 0x3f##) 0x80##-{-# INLINE write #-}--toList :: Immutable -> Offset Word8 -> Offset Word8 -> [Char]-toList ba !start !end = loop start-  where-    loop !idx-        | idx == end = []-        | otherwise  = c : loop idx'-      where (Step c idx') = next ba idx--all :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool-all predicate ba start end = loop start-  where-    loop !idx-        | idx == end  = True-        | predicate c = loop idx'-        | otherwise   = False-      where (Step c idx') = next ba idx-{-# INLINE all #-}--any :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool-any predicate ba start end = loop start-  where-    loop !idx-        | idx == end  = False-        | predicate c = True-        | otherwise   = loop idx'-      where (Step c idx') = next ba idx-{-# INLINE any #-}--foldr :: Immutable -> Offset Word8 -> Offset Word8 -> (Char -> a -> a) -> a -> a-foldr dat start end f acc = loop start-  where-    loop !i-        | i == end  = acc-        | otherwise =-            let (Step c i') = next dat i-             in c `f` loop i'-{-# INLINE foldr #-}--length :: Immutable -> Offset Word8 -> Offset Word8 -> CountOf Char-length dat start end-    | start == end = 0-    | otherwise    = processStart 0 start-  where-    end64 :: Offset Word64-    end64 = offsetInElements end--    prx64 :: Proxy Word64-    prx64 = Proxy--    mask64_80 :: Word64-    mask64_80 = 0x8080808080808080--    processStart :: CountOf Char -> Offset Word8 -> CountOf Char-    processStart !c !i-        | i == end                = c-        | offsetIsAligned prx64 i = processAligned c (offsetInElements i)-        | otherwise               =-            let h    = primIndex8 dat i-                cont = (h .&. 0xc0) == 0x80-                c'   = if cont then c else c+1-             in processStart c' (i+1)-    processAligned :: CountOf Char -> Offset Word64 -> CountOf Char-    processAligned !c !i-        | i >= end64 = processEnd c (offsetInBytes i)-        | otherwise  =-            let !h   = primIndex64 dat i-                !h80 = h .&. mask64_80-             in if h80 == 0-                 then processAligned (c+8) (i+1)-                 else let !nbAscii = if h80 == mask64_80 then 0 else CountOf (8 - popCount h80)-                          !nbHigh  = CountOf $ popCount (h .&. (h80 `unsafeShiftR` 1))-                       in processAligned (c + nbAscii + nbHigh) (i+1)-    processEnd !c !i-        | i == end  = c-        | otherwise =-            let h    = primIndex8 dat i-                cont = (h .&. 0xc0) == 0x80-                c'   = if cont then c else c+1-             in processStart c' (i+1)-{-# INLINE length #-}--reverse :: PrimMonad prim-        => MutableByteArray# (PrimState prim) -- ^ Destination buffer-        -> Offset Word8                       -- ^ Destination start-        -> Immutable                          -- ^ Source buffer-        -> Offset Word8                       -- ^ Source start-        -> Offset Word8                       -- ^ Source end-        -> prim ()-reverse dst dstOfs src start end-    | start == end = pure ()-    | otherwise    = loop (dstOfs `offsetPlusE` (offsetAsSize (end `offsetSub` start)) `offsetSub` 1) start-  where-    loop !d !s-        | s == end        = pure ()-        | headerIsAscii h = PrimNative.primWrite dst d h >> loop (d `offsetSub` 1) (s + 1)-        | otherwise       = do-            case getNbBytes h of-                1 -> do-                    PrimNative.primWrite dst (d `offsetSub` 1) h-                    PrimNative.primWrite dst d                 (primIndex8 src (s + 1))-                    loop (d `offsetSub` 2) (s + 2)-                2 -> do-                    PrimNative.primWrite dst (d `offsetSub` 2) h-                    PrimNative.primWrite dst (d `offsetSub` 1) (primIndex8 src (s + 1))-                    PrimNative.primWrite dst d                 (primIndex8 src (s + 2))-                    loop (d `offsetSub` 3) (s + 3)-                3 -> do-                    PrimNative.primWrite dst (d `offsetSub` 3) h-                    PrimNative.primWrite dst (d `offsetSub` 2) (primIndex8 src (s + 1))-                    PrimNative.primWrite dst (d `offsetSub` 1) (primIndex8 src (s + 2))-                    PrimNative.primWrite dst d                 (primIndex8 src (s + 3))-                    loop (d `offsetSub` 4) (s + 4)-                _ -> error "impossible"-      where h = primIndex8 src s-{-# INLINE reverse #-}

@@ -28,42 +28,38 @@ findIndexElem ty ba startIndex endIndex = loop startIndex   where     loop !i-        | i < endIndex && t /= ty = loop (i+1)-        | otherwise               = i-      where t = index ba i+        | i >= endIndex    = sentinel+        | index ba i == ty = i+        | otherwise        = loop (i+1) {-# INLINE findIndexElem #-}  revFindIndexElem :: (Indexable container ty, Eq ty) => ty -> container -> Offset ty -> Offset ty -> Offset ty-revFindIndexElem ty ba startIndex endIndex-    | endIndex > startIndex = loop (endIndex `offsetMinusE` 1)-    | otherwise             = endIndex+revFindIndexElem ty ba startIndex endIndex = loop endIndex   where-    loop !i-        | t == ty        = i-        | i > startIndex = loop (i `offsetMinusE` 1)-        | otherwise      = endIndex-      where t = index ba i+    loop !iplus1+        | iplus1 <= startIndex = sentinel+        | index ba i == ty     = i+        | otherwise            = loop i+      where !i = iplus1 `offsetMinusE` 1 {-# INLINE revFindIndexElem #-}  findIndexPredicate :: Indexable container ty => (ty -> Bool) -> container -> Offset ty -> Offset ty -> Offset ty-findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex+findIndexPredicate predicate ba startIndex endIndex = loop startIndex   where     loop !i-        | i < endIndex && not found = loop (i+1)-        | otherwise                 = i-      where found = predicate (index ba i)+        | i >= endIndex          = sentinel+        | predicate (index ba i) = i+        | otherwise              = loop (i+1) {-# INLINE findIndexPredicate #-}  revFindIndexPredicate :: Indexable container ty => (ty -> Bool) -> container -> Offset ty -> Offset ty -> Offset ty-revFindIndexPredicate predicate ba startIndex endIndex-    | endIndex > startIndex = loop (endIndex `offsetMinusE` 1)-    | otherwise             = endIndex+revFindIndexPredicate predicate ba startIndex endIndex = loop endIndex   where-    loop !i-        | found          = i-        | i > startIndex = loop (i `offsetMinusE` 1)-        | otherwise      = endIndex-      where found = predicate (index ba i)+    loop !iplus1+        | iplus1 <= startIndex   = sentinel+        | predicate (index ba i) = i+        | otherwise              = loop i+      where !i = iplus1 `offsetMinusE` 1 {-# INLINE revFindIndexPredicate #-}  foldl :: Indexable container ty => (a -> ty -> a) -> a -> container -> Offset ty -> Offset ty -> a

@@ -0,0 +1,135 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE NoImplicitPrelude          #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE CPP                        #-}+module Basement.Alg.String+    ( copyFilter+    , validate+    , findIndexPredicate+    , revFindIndexPredicate+    ) where++import           GHC.Prim+import           GHC.ST+import           Basement.Alg.Class+import           Basement.Alg.UTF8+import           Basement.Compat.Base+import           Basement.Numerical.Additive+import           Basement.Types.OffsetSize+import           Basement.PrimType+import           Basement.Block (MutableBlock(..))++import           Basement.UTF8.Helper+import           Basement.UTF8.Table+import           Basement.UTF8.Types++copyFilter :: forall s container . Indexable container Word8+           => (Char -> Bool)+           -> CountOf Word8+           -> MutableByteArray# s+           -> container+           -> Offset Word8+           -> ST s (CountOf Word8)+copyFilter predicate !sz dst src start = loop (Offset 0) start+  where+    !end = start `offsetPlusE` sz+    loop !d !s+        | s == end  = pure (offsetAsSize d)+        | otherwise =+            let !h = index src s+             in case headerIsAscii h of+                    True | predicate (toChar1 h) -> primMbaWrite dst d h >> loop (d + Offset 1) (s + Offset 1)+                         | otherwise             -> loop d (s + Offset 1)+                    False ->+                        case next src s of+                            Step c s' | predicate c -> writeUTF8 (MutableBlock dst :: MutableBlock Word8 s) d c >>= \d' -> loop d' s'+                                      | otherwise   -> loop d s'+{-# INLINE copyFilter #-}++validate :: Indexable container Word8+         => Offset Word8+         -> container+         -> Offset Word8+         -> (Offset Word8, Maybe ValidationFailure)+validate end ba ofsStart = loop4 ofsStart+  where+    loop4 !ofs+        | ofs4 < end =+            let h1 = index ba ofs+                h2 = index ba (ofs+1)+                h3 = index ba (ofs+2)+                h4 = index ba (ofs+3)+             in if headerIsAscii h1 && headerIsAscii h2 && headerIsAscii h3 && headerIsAscii h4+                    then loop4 ofs4+                    else loop ofs+        | otherwise     = loop ofs+      where+        !ofs4 = ofs+4+    loop !ofs+        | ofs == end      = (end, Nothing)+        | headerIsAscii h = loop (ofs + Offset 1)+        | otherwise       = multi (CountOf $ getNbBytes h) ofs+      where+        h = index ba ofs++    multi (CountOf 0xff) pos = (pos, Just InvalidHeader)+    multi nbConts pos+        | (posNext `offsetPlusE` nbConts) > end = (pos, Just MissingByte)+        | otherwise =+            case nbConts of+                CountOf 1 ->+                    let c1 = index ba posNext+                    in if isContinuation c1+                        then loop (pos + Offset 2)+                        else (pos, Just InvalidContinuation)+                CountOf 2 ->+                    let c1 = index ba posNext+                        c2 = index ba (pos + Offset 2)+                     in if isContinuation2 c1 c2+                            then loop (pos + Offset 3)+                            else (pos, Just InvalidContinuation)+                CountOf _ ->+                    let c1 = index ba posNext+                        c2 = index ba (pos + Offset 2)+                        c3 = index ba (pos + Offset 3)+                     in if isContinuation3 c1 c2 c3+                            then loop (pos + Offset 4)+                            else (pos, Just InvalidContinuation)+      where posNext = pos + Offset 1+{-# INLINE validate #-}++findIndexPredicate :: Indexable container Word8+                   => (Char -> Bool)+                   -> container+                   -> Offset Word8+                   -> Offset Word8+                   -> Offset Word8+findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex+  where+    loop !i+        | i < endIndex && not (predicate c) = loop (i')+        | otherwise                         = i+      where+        Step c i' = next ba i+{-# INLINE findIndexPredicate #-}++revFindIndexPredicate :: Indexable container Word8+                      => (Char -> Bool)+                      -> container+                      -> Offset Word8+                      -> Offset Word8+                      -> Offset Word8+revFindIndexPredicate predicate ba startIndex endIndex+    | endIndex > startIndex = loop endIndex+    | otherwise             = endIndex+  where+    loop !i+        | predicate c     = i'+        | i' > startIndex = loop i'+        | otherwise       = endIndex+      where +        StepBack c i' = prev ba i+{-# INLINE revFindIndexPredicate #-}

@@ -0,0 +1,268 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE CPP                        #-}+module Basement.Alg.UTF8+    ( nextAscii+    , nextAsciiDigit+    , expectAscii+    , next+    , nextSkip+    , prev+    , prevSkip+    , writeUTF8+    , toList+    , all+    , any+    , foldr+    , length+    , reverse+    ) where++import           GHC.Types+import           GHC.Word+import           GHC.Prim+import           Data.Bits+import           Data.Proxy+import           Basement.Alg.Class+import           Basement.Compat.Base hiding (toList)+import           Basement.Compat.Primitive+import           Basement.Monad+import           Basement.Numerical.Additive+import           Basement.Numerical.Subtractive+import           Basement.Types.OffsetSize+import           Basement.PrimType+import           Basement.UTF8.Helper+import           Basement.UTF8.Table+import           Basement.UTF8.Types++nextAscii :: Indexable container Word8 => container -> Offset Word8 -> StepASCII+nextAscii ba n = StepASCII w+  where+    !w = index ba n+{-# INLINE nextAscii #-}++-- | nextAsciiBa specialized to get a digit between 0 and 9 (included)+nextAsciiDigit :: Indexable container Word8 => container -> Offset Word8 -> StepDigit+nextAsciiDigit ba n = StepDigit (index ba n - 0x30)+{-# INLINE nextAsciiDigit #-}++expectAscii :: Indexable container Word8 => container -> Offset Word8 -> Word8 -> Bool+expectAscii ba n v = index ba n == v+{-# INLINE expectAscii #-}++next :: Indexable container Word8 => container -> Offset8 -> Step+next ba n =+    case getNbBytes h of+        0 -> Step (toChar1 h) (n + Offset 1)+        1 -> Step (toChar2 h (index ba (n + Offset 1))) (n + Offset 2)+        2 -> Step (toChar3 h (index ba (n + Offset 1))+                             (index ba (n + Offset 2))) (n + Offset 3)+        3 -> Step (toChar4 h (index ba (n + Offset 1))+                             (index ba (n + Offset 2))+                             (index ba (n + Offset 3))) (n + Offset 4)+        r -> error ("next: internal error: invalid input: offset=" <> show n <> " table=" <> show r <> " h=" <> show h)+  where+    !h = index ba n+{-# INLINE next #-}++nextSkip :: Indexable container Word8 => container -> Offset Word8 -> Offset Word8+nextSkip ba n = n + 1 + Offset (getNbBytes (index ba n))+{-# INLINE nextSkip #-}++-- Given a non null offset, give the previous character and the offset of this character+-- will fail bad if apply at the beginning of string or an empty string.+prev :: Indexable container Word8 => container -> Offset Word8 -> StepBack+prev ba offset =+    case index ba prevOfs1 of+        (W8# v1) | isContinuation# v1 -> atLeast2 (maskContinuation# v1)+                 | otherwise          -> StepBack (toChar# v1) prevOfs1+  where+    sz1 = CountOf 1+    !prevOfs1 = offset `offsetMinusE` sz1+    prevOfs2 = prevOfs1 `offsetMinusE` sz1+    prevOfs3 = prevOfs2 `offsetMinusE` sz1+    prevOfs4 = prevOfs3 `offsetMinusE` sz1+    atLeast2 !v  =+        case index ba prevOfs2 of+            (W8# v2) | isContinuation# v2 -> atLeast3 (or# (uncheckedShiftL# (maskContinuation# v2) 6#) v)+                     | otherwise          -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader2# v2) 6#) v)) prevOfs2+    atLeast3 !v =+        case index ba prevOfs3 of+            (W8# v3) | isContinuation# v3 -> atLeast4 (or# (uncheckedShiftL# (maskContinuation# v3) 12#) v)+                     | otherwise          -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader3# v3) 12#) v)) prevOfs3+    atLeast4 !v =+        case index ba prevOfs4 of+            (W8# v4) -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader4# v4) 18#) v)) prevOfs4++prevSkip :: Indexable container Word8 => container -> Offset Word8 -> Offset Word8+prevSkip ba offset = loop (offset `offsetMinusE` sz1)+  where+    sz1 = CountOf 1+    loop o+        | isContinuation (index ba o) = loop (o `offsetMinusE` sz1)+        | otherwise                       = o++writeUTF8 :: (PrimMonad prim, RandomAccess container prim Word8) +          => container -> Offset8 -> Char -> prim Offset8+writeUTF8 mba !i !c+    | bool# (ltWord# x 0x80##   ) = encode1+    | bool# (ltWord# x 0x800##  ) = encode2+    | bool# (ltWord# x 0x10000##) = encode3+    | otherwise                   = encode4+  where+    !(I# xi) = fromEnum c+    !x       = int2Word# xi++    encode1 = write mba i (W8# x) >> pure (i + Offset 1)+    encode2 = do+        let x1  = or# (uncheckedShiftRL# x 6#) 0xc0##+            x2  = toContinuation x+        write mba i     (W8# x1)+        write mba (i+1) (W8# x2)+        pure (i + Offset 2)++    encode3 = do+        let x1  = or# (uncheckedShiftRL# x 12#) 0xe0##+            x2  = toContinuation (uncheckedShiftRL# x 6#)+            x3  = toContinuation x+        write mba i            (W8# x1)+        write mba (i+Offset 1) (W8# x2)+        write mba (i+Offset 2) (W8# x3)+        pure (i + Offset 3)++    encode4 = do+        let x1  = or# (uncheckedShiftRL# x 18#) 0xf0##+            x2  = toContinuation (uncheckedShiftRL# x 12#)+            x3  = toContinuation (uncheckedShiftRL# x 6#)+            x4  = toContinuation x+        write mba i            (W8# x1)+        write mba (i+Offset 1) (W8# x2)+        write mba (i+Offset 2) (W8# x3)+        write mba (i+Offset 3) (W8# x4)+        pure (i + Offset 4)++    toContinuation :: Word# -> Word#+    toContinuation w = or# (and# w 0x3f##) 0x80##+{-# INLINE writeUTF8 #-}++toList :: Indexable container Word8 => container -> Offset Word8 -> Offset Word8 -> [Char]+toList ba !start !end = loop start+  where+    loop !idx+        | idx == end = []+        | otherwise  = c : loop idx'+      where (Step c idx') = next ba idx++all :: Indexable container Word8+    => (Char -> Bool) -> container -> Offset Word8 -> Offset Word8 -> Bool+all predicate ba start end = loop start+  where+    loop !idx+        | idx == end  = True+        | predicate c = loop idx'+        | otherwise   = False+      where (Step c idx') = next ba idx+{-# INLINE all #-}++any :: Indexable container Word8+    => (Char -> Bool) -> container -> Offset Word8 -> Offset Word8 -> Bool+any predicate ba start end = loop start+  where+    loop !idx+        | idx == end  = False+        | predicate c = True+        | otherwise   = loop idx'+      where (Step c idx') = next ba idx+{-# INLINE any #-}++foldr :: Indexable container Word8+      => container -> Offset Word8 -> Offset Word8 -> (Char -> a -> a) -> a -> a+foldr dat start end f acc = loop start+  where+    loop !i+        | i == end  = acc+        | otherwise =+            let (Step c i') = next dat i+             in c `f` loop i'+{-# INLINE foldr #-}++length :: (Indexable container Word8, Indexable container Word64)+       => container -> Offset Word8 -> Offset Word8 -> CountOf Char+length dat start end+    | start == end = 0+    | otherwise    = processStart 0 start+  where+    end64 :: Offset Word64+    end64 = offsetInElements end++    prx64 :: Proxy Word64+    prx64 = Proxy++    mask64_80 :: Word64+    mask64_80 = 0x8080808080808080++    processStart :: CountOf Char -> Offset Word8 -> CountOf Char+    processStart !c !i+        | i == end                = c+        | offsetIsAligned prx64 i = processAligned c (offsetInElements i)+        | otherwise               =+            let h    = index dat i+                cont = (h .&. 0xc0) == 0x80+                c'   = if cont then c else c+1+             in processStart c' (i+1)+    processAligned :: CountOf Char -> Offset Word64 -> CountOf Char+    processAligned !c !i+        | i >= end64 = processEnd c (offsetInBytes i)+        | otherwise  =+            let !h   = index dat i -- Word64+                !h80 = h .&. mask64_80+             in if h80 == 0+                 then processAligned (c+8) (i+1)+                 else let !nbAscii = if h80 == mask64_80 then 0 else CountOf (8 - popCount h80)+                          !nbHigh  = CountOf $ popCount (h .&. (h80 `unsafeShiftR` 1))+                       in processAligned (c + nbAscii + nbHigh) (i+1)+    processEnd !c !i+        | i == end  = c+        | otherwise =+            let h    = index dat i+                cont = (h .&. 0xc0) == 0x80+                c'   = if cont then c else c+1+             in processStart c' (i+1)+{-# INLINE length #-}++reverse :: (PrimMonad prim, Indexable container Word8)+        => MutableByteArray# (PrimState prim) -- ^ Destination buffer+        -> Offset Word8                       -- ^ Destination start+        -> container                          -- ^ Source buffer+        -> Offset Word8                       -- ^ Source start+        -> Offset Word8                       -- ^ Source end+        -> prim ()+reverse dst dstOfs src start end+    | start == end = pure ()+    | otherwise    = loop (dstOfs `offsetPlusE` (offsetAsSize (end `offsetSub` start)) `offsetSub` 1) start+  where+    loop !d !s+        | s == end        = pure ()+        | headerIsAscii h = primMbaWrite dst d h >> loop (d `offsetSub` 1) (s + 1)+        | otherwise       = do+            case getNbBytes h of+                1 -> do+                    primMbaWrite dst (d `offsetSub` 1) h+                    primMbaWrite dst d                 (index src (s + 1))+                    loop (d `offsetSub` 2) (s + 2)+                2 -> do+                    primMbaWrite dst (d `offsetSub` 2) h+                    primMbaWrite dst (d `offsetSub` 1) (index src (s + 1))+                    primMbaWrite dst d                 (index src (s + 2))+                    loop (d `offsetSub` 3) (s + 3)+                3 -> do+                    primMbaWrite dst (d `offsetSub` 3) h+                    primMbaWrite dst (d `offsetSub` 2) (index src (s + 1))+                    primMbaWrite dst (d `offsetSub` 1) (index src (s + 2))+                    primMbaWrite dst d                 (index src (s + 3))+                    loop (d `offsetSub` 4) (s + 4)+                _ -> error "impossible"+      where h = index src s+{-# INLINE reverse #-}

@@ -0,0 +1,557 @@+-- |+-- Module      : Basement.Bits+-- License     : BSD-style+-- Maintainer  : Haskell Foundation+-- Stability   : experimental+-- Portability : portable+--++{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NegativeLiterals #-}++#include "MachDeps.h"++module Basement.Bits+    ( BitOps(..)+    , FiniteBitsOps(..)++    , Bits+    , toBits+    , allOne+    ) where++import Basement.Compat.Base+import Basement.Compat.Natural+import Basement.Numerical.Additive+import Basement.Numerical.Subtractive+import Basement.Numerical.Multiplicative+import Basement.Types.OffsetSize+import Basement.Types.Word128 (Word128)+import qualified Basement.Types.Word128 as Word128+import Basement.Types.Word256 (Word256)+import qualified Basement.Types.Word256 as Word256+import Basement.IntegralConv (wordToInt)+import Basement.Nat++import qualified Prelude+import qualified Data.Bits as OldBits+import Data.Maybe (fromMaybe)+import Data.Proxy+import GHC.Base hiding ((.))+import GHC.Prim+import GHC.Types+import GHC.Word+import GHC.Int++#if WORD_SIZE_IN_BITS < 64+import GHC.IntWord64+#endif++-- | operation over finit bits+class FiniteBitsOps bits where+    -- | get the number of bits in the given object+    --+    numberOfBits :: bits -> CountOf Bool++    -- | rotate the given bit set.+    rotateL :: bits -> CountOf Bool -> bits+    -- | rotate the given bit set.+    rotateR :: bits -> CountOf Bool -> bits++    -- | count of number of bit set to 1 in the given bit set.+    popCount :: bits -> CountOf Bool++    -- | reverse all bits in the argument+    bitFlip   :: bits -> bits++    -- | count of the number of leading zeros+    countLeadingZeros :: bits -> CountOf Bool+    default countLeadingZeros :: BitOps bits => bits -> CountOf Bool+    countLeadingZeros n = loop stop azero+      where+        stop = numberOfBits n+        loop idx count+            | idx == azero = count+            | isBitSet n (sizeAsOffset idx) = count+            | otherwise = loop (fromMaybe azero (idx - 1)) (count + 1)++    -- | count of the number of trailing zeros+    countTrailingZeros :: bits -> CountOf Bool+    default countTrailingZeros :: BitOps bits => bits -> CountOf Bool+    countTrailingZeros n = loop azero+      where+        stop = numberOfBits n+        loop count+            | count == stop = count+            | isBitSet n (sizeAsOffset count) = count+            | otherwise = loop (count + 1)++-- | operation over bits+class BitOps bits where+    (.&.)     :: bits -> bits -> bits+    (.|.)     :: bits -> bits -> bits+    (.^.)     :: bits -> bits -> bits+    (.<<.)    :: bits -> CountOf Bool -> bits+    (.>>.)    :: bits -> CountOf Bool -> bits+    -- | construct a bit set with the bit at the given index set.+    bit       :: Offset Bool -> bits+    default bit :: Integral bits => Offset Bool -> bits+    bit n = 1 .<<. (offsetAsSize n)++    -- | test the bit at the given index is set+    isBitSet  :: bits -> Offset Bool -> Bool+    default isBitSet :: (Integral bits, Eq bits) => bits -> Offset Bool -> Bool+    isBitSet x n = x .&. (bit n) /= 0++    -- | set the bit at the given index+    setBit    :: bits -> Offset Bool -> bits+    default setBit :: Integral bits => bits -> Offset Bool -> bits+    setBit x n = x .|. (bit n)++    -- | clear the bit at the given index+    clearBit  :: bits -> Offset Bool -> bits+    default clearBit :: FiniteBitsOps bits => bits -> Offset Bool -> bits+    clearBit x n = x .&. (bitFlip (bit n))++-- | Bool set of 'n' bits.+--+newtype Bits (n :: Nat) = Bits { bitsToNatural :: Natural }+  deriving (Show, Eq, Ord, Typeable)++-- | convenient Type Constraint Alias fot 'Bits' functions+type SizeValid n = (KnownNat n, 1 <= n)++-- convert an 'Int' into a 'Natural'.+-- This functions is not meant to be exported+lift :: Int -> Natural+lift = Prelude.fromIntegral+{-# INLINABLE lift #-}++-- | convert the given 'Natural' into a 'Bits' of size 'n'+--+-- if bits that are not within the boundaries of the 'Bits n' will be truncated.+toBits :: SizeValid n => Natural -> Bits n+toBits nat = Bits nat .&. allOne++-- | construct a 'Bits' with all bits set.+--+-- this function is equivalet to 'maxBound'+allOne :: forall n . SizeValid n => Bits n+allOne = Bits (2 Prelude.^ n Prelude.- midentity)+  where+    n = natVal (Proxy @n)++instance SizeValid n => Enum (Bits n) where+    toEnum i | i < 0 && lift i > bitsToNatural maxi = error "Bits n not within bound"+             | otherwise                            = Bits (lift i)+      where maxi = allOne :: Bits n+    fromEnum (Bits n) = fromEnum n+instance SizeValid n => Bounded (Bits n) where+    minBound = azero+    maxBound = allOne+instance SizeValid n => Additive (Bits n) where+    azero = Bits 0+    (+) (Bits a) (Bits b) = toBits (a + b)+instance SizeValid n => Subtractive (Bits n) where+    type Difference (Bits n) = Bits n+    (-) (Bits a) (Bits b) = maybe azero toBits (a - b)+instance SizeValid n => Multiplicative (Bits n) where+    midentity = Bits 1+    (*) (Bits a) (Bits b) = Bits (a Prelude.* b)+instance SizeValid n => IDivisible (Bits n) where+    div (Bits a) (Bits b) = Bits (a `Prelude.div` b)+    mod (Bits a) (Bits b) = Bits (a `Prelude.mod` b)+    divMod (Bits a) (Bits b) = let (q, r) = Prelude.divMod a b in (Bits q, Bits r)++instance SizeValid n => BitOps (Bits n) where+    (.&.)    (Bits a) (Bits b)    = Bits (a OldBits..&. b)+    (.|.)    (Bits a) (Bits b)    = Bits (a OldBits..|. b)+    (.^.)    (Bits a) (Bits b)    = Bits (a `OldBits.xor` b)+    (.<<.)   (Bits a) (CountOf w) = Bits (a `OldBits.shiftL` w)+    (.>>.)   (Bits a) (CountOf w) = Bits (a `OldBits.shiftR` w)+    bit               (Offset w)  = Bits (OldBits.bit w)+    isBitSet (Bits a) (Offset w)  = OldBits.testBit a w+    setBit   (Bits a) (Offset w)  = Bits (OldBits.setBit a w)+    clearBit (Bits a) (Offset w)  = Bits (OldBits.clearBit a w)+instance (SizeValid n, NatWithinBound (CountOf Bool) n) => FiniteBitsOps (Bits n) where+    bitFlip (Bits a) = Bits (OldBits.complement a)+    numberOfBits _ = natValCountOf (Proxy @n)+    rotateL a i = (a .<<. i) .|. (a .>>. d)+      where+        n = natValCountOf (Proxy :: Proxy n)+        d = fromMaybe (fromMaybe (error "impossible") (i - n)) (n - i)+    rotateR a i = (a .>>. i) .|. (a .<<. d)+      where+        n = natValCountOf (Proxy :: Proxy n)+        d = fromMaybe (fromMaybe (error "impossible") (i - n)) (n - i)+    popCount (Bits n) = CountOf (OldBits.popCount n)++-- Bool ------------------------------------------------------------------------++instance FiniteBitsOps Bool where+    numberOfBits _ = 1+    rotateL x _ = x+    rotateR x _ = x+    popCount True = 1+    popCount False = 0+    bitFlip  = not+    countLeadingZeros True  = 0+    countLeadingZeros False = 1+    countTrailingZeros True  = 0+    countTrailingZeros False = 1+instance BitOps Bool where+    (.&.) = (&&)+    (.|.) = (||)+    (.^.) = (/=)+    x .<<. 0 = x+    _ .<<. _ = False+    x .>>. 0 = x+    _ .>>. _ = False+    bit 0 = True+    bit _ = False+    isBitSet x 0 = x+    isBitSet _ _ = False+    setBit _ 0 = True+    setBit _ _ = False+    clearBit _ 0 = False+    clearBit x _ = x++-- Word8 ----------------------------------------------------------------------++instance FiniteBitsOps Word8 where+    numberOfBits _ = 8+    rotateL (W8# x#) (CountOf (I# i#))+        | isTrue# (i'# ==# 0#) = W8# x#+        | otherwise  = W8# (narrow8Word# ((x# `uncheckedShiftL#` i'#) `or#`+                                          (x# `uncheckedShiftRL#` (8# -# i'#))))+      where+        !i'# = word2Int# (int2Word# i# `and#` 7##)+    rotateR (W8# x#) (CountOf (I# i#))+        | isTrue# (i'# ==# 0#) = W8# x#+        | otherwise  = W8# (narrow8Word# ((x# `uncheckedShiftRL#` i'#) `or#`+                                          (x# `uncheckedShiftL#` (8# -# i'#))))+      where+        !i'# = word2Int# (int2Word# i# `and#` 7##)+    bitFlip (W8# x#) = W8# (x# `xor#` mb#)+        where !(W8# mb#) = maxBound+    popCount (W8# x#) = CountOf $ wordToInt (W# (popCnt8# x#))+    countLeadingZeros (W8# w#) = CountOf $ wordToInt (W# (clz8# w#))+    countTrailingZeros (W8# w#) = CountOf $ wordToInt (W# (ctz8# w#))+instance BitOps Word8 where+    (W8# x#) .&. (W8# y#)   = W8# (x# `and#` y#)+    (W8# x#) .|. (W8# y#)   = W8# (x# `or#`  y#)+    (W8# x#) .^. (W8# y#)   = W8# (x# `xor#` y#)+    (W8# x#) .<<. (CountOf (I# i#)) = W8# (narrow8Word# (x# `shiftL#` i#))+    (W8# x#) .>>. (CountOf (I# i#)) = W8# (narrow8Word# (x# `shiftRL#` i#))++-- Word16 ---------------------------------------------------------------------++instance FiniteBitsOps Word16 where+    numberOfBits _ = 16+    rotateL (W16# x#) (CountOf (I# i#))+        | isTrue# (i'# ==# 0#) = W16# x#+        | otherwise  = W16# (narrow16Word# ((x# `uncheckedShiftL#` i'#) `or#`+                                            (x# `uncheckedShiftRL#` (16# -# i'#))))+      where+        !i'# = word2Int# (int2Word# i# `and#` 15##)+    rotateR (W16# x#) (CountOf (I# i#))+        | isTrue# (i'# ==# 0#) = W16# x#+        | otherwise  = W16# (narrow16Word# ((x# `uncheckedShiftRL#` i'#) `or#`+                                            (x# `uncheckedShiftL#` (16# -# i'#))))+      where+        !i'# = word2Int# (int2Word# i# `and#` 15##)+    bitFlip (W16# x#) = W16# (x# `xor#` mb#)+        where !(W16# mb#) = maxBound+    popCount (W16# x#) = CountOf $ wordToInt (W# (popCnt16# x#))+    countLeadingZeros (W16# w#) = CountOf $ wordToInt (W# (clz16# w#))+    countTrailingZeros (W16# w#) = CountOf $ wordToInt (W# (ctz16# w#))+instance BitOps Word16 where+    (W16# x#) .&. (W16# y#)   = W16# (x# `and#` y#)+    (W16# x#) .|. (W16# y#)   = W16# (x# `or#`  y#)+    (W16# x#) .^. (W16# y#)   = W16# (x# `xor#` y#)+    (W16# x#) .<<. (CountOf (I# i#)) = W16# (narrow16Word# (x# `shiftL#` i#))+    (W16# x#) .>>. (CountOf (I# i#)) = W16# (narrow16Word# (x# `shiftRL#` i#))++-- Word32 ---------------------------------------------------------------------++instance FiniteBitsOps Word32 where+    numberOfBits _ = 32+    rotateL (W32# x#) (CountOf (I# i#))+        | isTrue# (i'# ==# 0#) = W32# x#+        | otherwise  = W32# (narrow32Word# ((x# `uncheckedShiftL#` i'#) `or#`+                                            (x# `uncheckedShiftRL#` (32# -# i'#))))+      where+        !i'# = word2Int# (int2Word# i# `and#` 31##)+    rotateR (W32# x#) (CountOf (I# i#))+        | isTrue# (i'# ==# 0#) = W32# x#+        | otherwise  = W32# (narrow32Word# ((x# `uncheckedShiftRL#` i'#) `or#`+                                            (x# `uncheckedShiftL#` (32# -# i'#))))+      where+        !i'# = word2Int# (int2Word# i# `and#` 31##)+    bitFlip (W32# x#) = W32# (x# `xor#` mb#)+        where !(W32# mb#) = maxBound+    popCount (W32# x#) = CountOf $ wordToInt (W# (popCnt32# x#))+    countLeadingZeros (W32# w#) = CountOf $ wordToInt (W# (clz32# w#))+    countTrailingZeros (W32# w#) = CountOf $ wordToInt (W# (ctz32# w#))+instance BitOps Word32 where+    (W32# x#) .&. (W32# y#)   = W32# (x# `and#` y#)+    (W32# x#) .|. (W32# y#)   = W32# (x# `or#`  y#)+    (W32# x#) .^. (W32# y#)   = W32# (x# `xor#` y#)+    (W32# x#) .<<. (CountOf (I# i#)) = W32# (narrow32Word# (x# `shiftL#` i#))+    (W32# x#) .>>. (CountOf (I# i#)) = W32# (narrow32Word# (x# `shiftRL#` i#))++-- Word64 ---------------------------------------------------------------------++#if WORD_SIZE_IN_BITS == 64+instance FiniteBitsOps Word64 where+    numberOfBits _ = 64+    rotateL (W64# x#) (CountOf (I# i#))+        | isTrue# (i'# ==# 0#) = W64# x#+        | otherwise  = W64# ((x# `uncheckedShiftL#` i'#) `or#`+                             (x# `uncheckedShiftRL#` (64# -# i'#)))+      where+        !i'# = word2Int# (int2Word# i# `and#` 63##)+    rotateR (W64# x#) (CountOf (I# i#))+        | isTrue# (i'# ==# 0#) = W64# x#+        | otherwise  = W64# ((x# `uncheckedShiftRL#` i'#) `or#`+                             (x# `uncheckedShiftL#` (64# -# i'#)))+      where+        !i'# = word2Int# (int2Word# i# `and#` 63##)+    bitFlip (W64# x#) = W64# (x# `xor#` mb#)+        where !(W64# mb#) = maxBound+    popCount (W64# x#) = CountOf $ wordToInt (W# (popCnt64# x#))+    countLeadingZeros (W64# w#) = CountOf $ wordToInt (W# (clz64# w#))+    countTrailingZeros (W64# w#) = CountOf $ wordToInt (W# (ctz64# w#))+instance BitOps Word64 where+    (W64# x#) .&. (W64# y#)   = W64# (x# `and#` y#)+    (W64# x#) .|. (W64# y#)   = W64# (x# `or#`  y#)+    (W64# x#) .^. (W64# y#)   = W64# (x# `xor#` y#)+    (W64# x#) .<<. (CountOf (I# i#)) = W64# (x# `shiftL#` i#)+    (W64# x#) .>>. (CountOf (I# i#)) = W64# (x# `shiftRL#` i#)+#else+instance FiniteBitsOps Word64 where+    numberOfBits _ = 64+    rotateL (W64# x#) (CountOf (I# i#))+        | isTrue# (i'# ==# 0#) = W64# x#+        | otherwise  = W64# ((x# `uncheckedShiftL64#` i'#) `or64#`+                             (x# `uncheckedShiftRL64#` (64# -# i'#)))+      where+        !i'# = word2Int# (int2Word# i# `and#` 63##)+    rotateR (W64# x#) (CountOf (I# i#))+        | isTrue# (i'# ==# 0#) = W64# x#+        | otherwise  = W64# ((x# `uncheckedShiftRL64#` i'#) `or64#`+                             (x# `uncheckedShiftL64#` (64# -# i'#)))+      where+        !i'# = word2Int# (int2Word# i# `and#` 63##)+    bitFlip (W64# x#) = W64# (not64# x#)+    popCount (W64# x#) = CountOf $ wordToInt (W# (popCnt64# x#))+    countLeadingZeros (W64# w#) = CountOf $ wordToInt (W# (clz64# w#))+    countTrailingZeros (W64# w#) = CountOf $ wordToInt (W# (ctz64# w#))+instance BitOps Word64 where+    (W64# x#) .&. (W64# y#)   = W64# (x# `and64#` y#)+    (W64# x#) .|. (W64# y#)   = W64# (x# `or64#`  y#)+    (W64# x#) .^. (W64# y#)   = W64# (x# `xor64#` y#)+    (W64# x#) .<<. (CountOf (I# i#)) = W64# (x# `shiftL64#` i#)+    (W64# x#) .>>. (CountOf (I# i#)) = W64# (x# `shiftRL64#` i#)++shiftL64#, shiftRL64# :: Word64# -> Int# -> Word64#+a `shiftL64#` b  | isTrue# (b >=# 64#) = wordToWord64# 0##+                 | otherwise           = a `uncheckedShiftL64#` b+a `shiftRL64#` b | isTrue# (b >=# 64#) = wordToWord64# 0##+                 | otherwise           = a `uncheckedShiftRL64#` b+#endif++-- Word128 --------------------------------------------------------------------++instance FiniteBitsOps Word128 where+    numberOfBits _ = 128+    rotateL w (CountOf n) = Word128.rotateL w n+    rotateR w (CountOf n) = Word128.rotateR w n+    bitFlip = Word128.complement+    popCount = CountOf . Word128.popCount+instance BitOps Word128 where+    (.&.) = Word128.bitwiseAnd+    (.|.) = Word128.bitwiseOr+    (.^.) = Word128.bitwiseXor+    (.<<.) w (CountOf n) = Word128.shiftL w n+    (.>>.) w (CountOf n) = Word128.shiftR w n++-- Word256 --------------------------------------------------------------------++instance FiniteBitsOps Word256 where+    numberOfBits _ = 256+    rotateL w (CountOf n) = Word256.rotateL w n+    rotateR w (CountOf n) = Word256.rotateR w n+    bitFlip = Word256.complement+    popCount = CountOf . Word256.popCount+instance BitOps Word256 where+    (.&.) = Word256.bitwiseAnd+    (.|.) = Word256.bitwiseOr+    (.^.) = Word256.bitwiseXor+    (.<<.) w (CountOf n) = Word256.shiftL w n+    (.>>.) w (CountOf n) = Word256.shiftR w n++-- Int8 -----------------------------------------------------------------------++instance FiniteBitsOps Int8 where+    numberOfBits _ = 8+    rotateL (I8# x#) (CountOf (I# i#))+        | isTrue# (i'# ==# 0#) = I8# x#+        | otherwise  = I8# (narrow8Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`+                                                    (x'# `uncheckedShiftRL#` (8# -# i'#)))))+      where+        !x'# = narrow8Word# (int2Word# x#)+        !i'# = word2Int# (int2Word# i# `and#` 7##)+    rotateR (I8# x#) (CountOf (I# i#))+        | isTrue# (i'# ==# 0#) = I8# x#+        | otherwise  = I8# (narrow8Int# (word2Int# ((x'# `uncheckedShiftRL#` i'#) `or#`+                                                    (x'# `uncheckedShiftL#` (8# -# i'#)))))+      where+        !x'# = narrow8Word# (int2Word# x#)+        !i'# = word2Int# (int2Word# i# `and#` 7##)+    bitFlip (I8# x#) = I8# (word2Int# (not# (int2Word# x#)))+    popCount (I8# x#) = CountOf $ wordToInt (W# (popCnt8# (int2Word# x#)))+    countLeadingZeros (I8# w#) = CountOf $ wordToInt (W# (clz8# (int2Word# w#)))+    countTrailingZeros (I8# w#) = CountOf $ wordToInt (W# (ctz8# (int2Word# w#)))+instance BitOps Int8 where+    (I8# x#) .&. (I8# y#)   = I8# (x# `andI#` y#)+    (I8# x#) .|. (I8# y#)   = I8# (x# `orI#`  y#)+    (I8# x#) .^. (I8# y#)   = I8# (x# `xorI#` y#)+    (I8# x#) .<<. (CountOf (I# i#)) = I8# (narrow8Int# (x# `iShiftL#`  i#))+    (I8# x#) .>>. (CountOf (I# i#)) = I8# (narrow8Int# (x# `iShiftRL#` i#))++-- Int16 ----------------------------------------------------------------------++instance FiniteBitsOps Int16 where+    numberOfBits _ = 16+    rotateL (I16# x#) (CountOf (I# i#))+        | isTrue# (i'# ==# 0#) = I16# x#+        | otherwise  = I16# (narrow16Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`+                                                      (x'# `uncheckedShiftRL#` (16# -# i'#)))))+      where+        !x'# = narrow16Word# (int2Word# x#)+        !i'# = word2Int# (int2Word# i# `and#` 15##)+    rotateR (I16# x#) (CountOf (I# i#))+        | isTrue# (i'# ==# 0#) = I16# x#+        | otherwise  = I16# (narrow16Int# (word2Int# ((x'# `uncheckedShiftRL#` i'#) `or#`+                                                      (x'# `uncheckedShiftL#` (16# -# i'#)))))+      where+        !x'# = narrow16Word# (int2Word# x#)+        !i'# = word2Int# (int2Word# i# `and#` 15##)+    bitFlip (I16# x#) = I16# (word2Int# (not# (int2Word# x#)))+    popCount (I16# x#) = CountOf $ wordToInt (W# (popCnt16# (int2Word# x#)))+    countLeadingZeros (I16# w#) = CountOf $ wordToInt (W# (clz16# (int2Word# w#)))+    countTrailingZeros (I16# w#) = CountOf $ wordToInt (W# (ctz16# (int2Word# w#)))+instance BitOps Int16 where+    (I16# x#) .&. (I16# y#)   = I16# (x# `andI#` y#)+    (I16# x#) .|. (I16# y#)   = I16# (x# `orI#`  y#)+    (I16# x#) .^. (I16# y#)   = I16# (x# `xorI#` y#)+    (I16# x#) .<<. (CountOf (I# i#)) = I16# (narrow16Int# (x# `iShiftL#`  i#))+    (I16# x#) .>>. (CountOf (I# i#)) = I16# (narrow16Int# (x# `iShiftRL#` i#))++-- Int32 ----------------------------------------------------------------------++instance FiniteBitsOps Int32 where+    numberOfBits _ = 32+    rotateL (I32# x#) (CountOf (I# i#))+        | isTrue# (i'# ==# 0#) = I32# x#+        | otherwise  = I32# (narrow32Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`+                                                      (x'# `uncheckedShiftRL#` (32# -# i'#)))))+      where+        !x'# = narrow32Word# (int2Word# x#)+        !i'# = word2Int# (int2Word# i# `and#` 31##)+    rotateR (I32# x#) (CountOf (I# i#))+        | isTrue# (i'# ==# 0#) = I32# x#+        | otherwise  = I32# (narrow32Int# (word2Int# ((x'# `uncheckedShiftRL#` i'#) `or#`+                                                      (x'# `uncheckedShiftL#` (32# -# i'#)))))+      where+        !x'# = narrow32Word# (int2Word# x#)+        !i'# = word2Int# (int2Word# i# `and#` 31##)+    bitFlip (I32# x#) = I32# (word2Int# (not# (int2Word# x#)))+    popCount (I32# x#) = CountOf $ wordToInt (W# (popCnt32# (int2Word# x#)))+    countLeadingZeros (I32# w#) = CountOf $ wordToInt (W# (clz32# (int2Word# w#)))+    countTrailingZeros (I32# w#) = CountOf $ wordToInt (W# (ctz32# (int2Word# w#)))+instance BitOps Int32 where+    (I32# x#) .&. (I32# y#)   = I32# (x# `andI#` y#)+    (I32# x#) .|. (I32# y#)   = I32# (x# `orI#`  y#)+    (I32# x#) .^. (I32# y#)   = I32# (x# `xorI#` y#)+    (I32# x#) .<<. (CountOf (I# i#)) = I32# (narrow32Int# (x# `iShiftL#`  i#))+    (I32# x#) .>>. (CountOf (I# i#)) = I32# (narrow32Int# (x# `iShiftRL#` i#))++-- Int64 ----------------------------------------------------------------------++#if WORD_SIZE_IN_BITS == 64+instance FiniteBitsOps Int64 where+    numberOfBits _ = 64+    rotateL (I64# x#) (CountOf (I# i#))+        | isTrue# (i'# ==# 0#) = I64# x#+        | otherwise  = I64# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`+                                        (x'# `uncheckedShiftRL#` (64# -# i'#))))+      where+        !x'# = int2Word# x#+        !i'# = word2Int# (int2Word# i# `and#` 63##)+    rotateR (I64# x#) (CountOf (I# i#))+        | isTrue# (i'# ==# 0#) = I64# x#+        | otherwise  = I64# (word2Int# ((x'# `uncheckedShiftRL#` i'#) `or#`+                                        (x'# `uncheckedShiftL#` (64# -# i'#))))+      where+        !x'# = int2Word# x#+        !i'# = word2Int# (int2Word# i# `and#` 63##)+    bitFlip (I64# x#) = I64# (word2Int# (int2Word# x# `xor#` int2Word# (-1#)))+    popCount (I64# x#) = CountOf $ wordToInt (W# (popCnt64# (int2Word# x#)))+    countLeadingZeros (I64# w#) = CountOf $ wordToInt (W# (clz64# (int2Word# w#)))+    countTrailingZeros (I64# w#) = CountOf $ wordToInt (W# (ctz64# (int2Word# w#)))+instance BitOps Int64 where+    (I64# x#) .&. (I64# y#)   = I64# (x# `andI#` y#)+    (I64# x#) .|. (I64# y#)   = I64# (x# `orI#`  y#)+    (I64# x#) .^. (I64# y#)   = I64# (x# `xorI#` y#)+    (I64# x#) .<<. (CountOf (I# w#)) = I64# (x# `iShiftL#`  w#)+    (I64# x#) .>>. (CountOf (I# w#)) = I64# (x# `iShiftRL#` w#)+#else+instance FiniteBitsOps Int64 where+    numberOfBits _ = 64+    rotateL (I64# x#) (CountOf (I# i#))+        | isTrue# (i'# ==# 0#) = I64# x#+        | otherwise  = I64# (word64ToInt64# ((x'# `uncheckedShiftL64#` i'#) `or64#`+                                             (x'# `uncheckedShiftRL64#` (64# -# i'#))))+      where+        !x'# = int64ToWord64# x#+        !i'# = word2Int# (int2Word# i# `and#` 63##)+    rotateR (I64# x#) (CountOf (I# i#))+        | isTrue# (i'# ==# 0#) = I64# x#+        | otherwise  = I64# (word64ToInt64# ((x'# `uncheckedShiftRL64#` i'#) `or64#`+                                             (x'# `uncheckedShiftL64#` (64# -# i'#))))+      where+        !x'# = int64ToWord64# x#+        !i'# = word2Int# (int2Word# i# `and#` 63##)+    bitFlip (I64# x#) = I64# (word64ToInt64# (not64# (int64ToWord64# x#)))+    popCount (I64# x#) = CountOf $ wordToInt (W# (popCnt64# (int64ToWord64# x#)))+    countLeadingZeros (I64# w#) = CountOf $ wordToInt (W# (clz64# (int64ToWord64# w#)))+    countTrailingZeros (I64# w#) = CountOf $ wordToInt (W# (ctz64# (int64ToWord64# w#)))+instance BitOps Int64 where+    (I64# x#) .&. (I64# y#)  = I64# (word64ToInt64# (int64ToWord64# x# `and64#` int64ToWord64# y#))+    (I64# x#) .|. (I64# y#)  = I64# (word64ToInt64# (int64ToWord64# x# `or64#`  int64ToWord64# y#))+    (I64# x#) .^. (I64# y#)  = I64# (word64ToInt64# (int64ToWord64# x# `xor64#` int64ToWord64# y#))+    (I64# x#) .<<. (CountOf (I# w#)) = I64# (x# `iShiftL64#`  w#)+    (I64# x#) .>>. (CountOf (I# w#)) = I64# (x# `iShiftRA64#` w#)+++iShiftL64#, iShiftRA64# :: Int64# -> Int# -> Int64#+a `iShiftL64#` b  | isTrue# (b >=# 64#) = intToInt64# 0#+                  | otherwise           = a `uncheckedIShiftL64#` b+a `iShiftRA64#` b | isTrue# (b >=# 64#) && isTrue# (a `ltInt64#` (intToInt64# 0#))+                                        = intToInt64# (-1#)+                  | isTrue# (b >=# 64#) = intToInt64# 0#+                  | otherwise = a `uncheckedIShiftRA64#` b++#endif

@@ -84,7 +84,6 @@ import           Basement.Numerical.Additive import           Basement.Numerical.Subtractive import           Basement.Numerical.Multiplicative-import qualified Basement.Alg.Native.Prim as Prim import qualified Basement.Alg.Mutable as MutAlg import qualified Basement.Alg.Class as Alg import qualified Basement.Alg.PrimArray as Alg@@ -98,6 +97,10 @@     index (Block ba) = primBaIndex ba     {-# INLINE index #-} +instance Alg.Indexable (Block Word8) Word64 where+    index (Block ba) = primBaIndex ba+    {-# INLINE index #-}+ -- | Copy all the block content to the memory starting at the destination address unsafeCopyToPtr :: forall ty prim . PrimMonad prim                 => Block ty -- ^ the source block to copy@@ -278,12 +281,11 @@  breakEnd :: PrimType ty => (ty -> Bool) -> Block ty -> (Block ty, Block ty) breakEnd predicate blk-    | k == end  = (blk, mempty)-    | otherwise = splitAt (offsetAsSize (k+1)) blk+    | k == sentinel = (blk, mempty)+    | otherwise     = splitAt (offsetAsSize (k+1)) blk   where-    k = Alg.revFindIndexPredicate predicate blk 0 end-    end = 0 `offsetPlusE` len-    !len = length blk+    !k = Alg.revFindIndexPredicate predicate blk 0 end+    !end = sizeAsOffset $ length blk {-# SPECIALIZE [2] breakEnd :: (Word8 -> Bool) -> Block Word8 -> (Block Word8, Block Word8) #-}  span :: PrimType ty => (ty -> Bool) -> Block ty -> (Block ty, Block ty)

@@ -386,7 +386,7 @@ -- to use to modify the contents -- -- If the Block is pinned, then its address is returned as is,--- however if it's unpinned, a pinned copy of the UArray is made+-- however if it's unpinned, a pinned copy of the Block is made -- before getting the address. withPtr :: PrimMonad prim         => Block ty@@ -469,13 +469,11 @@     | isMutablePinned mb == Pinned = callWithPtr mb     | otherwise                    = do         trampoline <- unsafeNew Pinned vecSz-        if not skipCopy-            then unsafeCopyBytes trampoline 0 mb 0 vecSz-            else pure ()+        unless skipCopy $+            unsafeCopyBytes trampoline 0 mb 0 vecSz         r <- callWithPtr trampoline-        if not skipCopyBack-            then unsafeCopyBytes mb 0 trampoline 0 vecSz-            else pure ()+        unless skipCopyBack $+            unsafeCopyBytes mb 0 trampoline 0 vecSz         pure r   where     vecSz = mutableLengthBytes mb

@@ -21,7 +21,7 @@     , unsafeRunString     ) where -import qualified Basement.Alg.Native.UTF8      as PrimBA+import qualified Basement.Alg.UTF8 as UTF8 import           Basement.UTF8.Helper          (charToBytes) import           Basement.Numerical.Conversion (charToInt) import           Basement.Block.Base (Block(..), MutableBlock(..))@@ -147,5 +147,5 @@ -- -- this function may be replaced by `emit :: Encoding -> Char -> Builder` emitUTF8Char :: Char -> Builder-emitUTF8Char c = Builder (charToBytes $ charToInt c) $ Action $ \(MutableBlock arr) off ->-    PrimBA.write arr off c+emitUTF8Char c = Builder (charToBytes $ charToInt c) $ Action $ \block@(MutableBlock !_) off ->+    UTF8.writeUTF8 block off c

@@ -34,6 +34,8 @@     , Prelude.Functor (..)     , Control.Applicative.Applicative (..)     , Prelude.Monad (..)+    , Control.Monad.when+    , Control.Monad.unless     , Prelude.Maybe (..)     , Prelude.Ordering (..)     , Prelude.Bool (..)@@ -69,6 +71,7 @@ import qualified Control.Category import qualified Control.Applicative import qualified Control.Exception+import qualified Control.Monad import qualified Data.Monoid import qualified Data.Data import qualified Data.Word

@@ -140,7 +140,7 @@ compatShrinkMutableByteArray# src i s =     -- not check whether i is smaller than the size of the buffer     case newAlignedPinnedByteArray# i 8# s of { (# s2, dst #) ->-    case copyMutableByteArray# dst 0# src 0# i s2 of { s3 -> (# s3, dst #) }}+    case copyMutableByteArray# src 0# dst 0# i s2 of { s3 -> (# s3, dst #) }} #endif {-# INLINE compatShrinkMutableByteArray# #-} @@ -151,7 +151,7 @@ #else compatResizeMutableByteArray# src i s =     case newAlignedPinnedByteArray# i 8# s of { (# s2, dst #) ->-    case copyMutableByteArray# dst 0# src 0# nbBytes s2 of { s3 -> (# s3, dst #) }}+    case copyMutableByteArray# src 0# dst 0# nbBytes s2 of { s3 -> (# s3, dst #) }}   where     isGrow = bool# (i ># len)     nbBytes

@@ -5,6 +5,7 @@ {-# LANGUAGE CPP                   #-} {-# LANGUAGE MagicHash             #-} {-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE TypeOperators         #-} -- | -- Module      : Basement.From -- License     : BSD-style@@ -50,7 +51,7 @@ import qualified Basement.Types.Word128 as Word128 import qualified Basement.Types.Word256 as Word256 import           Basement.These-import           Basement.PrimType (PrimType)+import           Basement.PrimType (PrimType, PrimSize) import           Basement.Types.OffsetSize import           Basement.Compat.Natural import qualified Prelude (fromIntegral)@@ -247,6 +248,9 @@ #if __GLASGOW_HASKELL__ >= 800 instance From (BlockN.BlockN n ty) (Block.Block ty) where     from = BlockN.toBlock+instance (PrimType a, PrimType b, KnownNat n, KnownNat m, ((PrimSize b) Basement.Nat.* m) ~ ((PrimSize a) Basement.Nat.* n))+      => From (BlockN.BlockN n a) (BlockN.BlockN m b) where+    from = BlockN.cast instance (NatWithinBound Int n, PrimType ty) => From (BlockN.BlockN n ty) (UArray.UArray ty) where     from = UArray.fromBlock . BlockN.toBlock instance (NatWithinBound Int n, PrimType ty) => From (BlockN.BlockN n ty) (BoxArray.Array ty) where

@@ -36,6 +36,8 @@     , Prelude.Functor (..)     , Control.Applicative.Applicative (..)     , Prelude.Monad (..)+    , Control.Monad.when+    , Control.Monad.unless     , Prelude.Maybe (..)     , Prelude.Ordering (..)     , Prelude.Bool (..)@@ -87,6 +89,7 @@ import qualified Control.Category import qualified Control.Applicative import qualified Control.Exception+import qualified Control.Monad import qualified Data.Monoid import qualified Data.Data import qualified Data.Typeable

@@ -15,8 +15,12 @@ module Basement.Sized.Block     ( BlockN     , MutableBlockN+    , length+    , lengthBytes     , toBlockN     , toBlock+    , new+    , newPinned     , singleton     , replicate     , thaw@@ -39,20 +43,29 @@     , reverse     , sortBy     , intersperse+    , withPtr+    , withMutablePtr+    , withMutablePtrHint+    , cast+    , mutableCast     ) where  import           Data.Proxy (Proxy(..)) import           Basement.Compat.Base+import           Basement.Numerical.Additive (scale) import           Basement.Block (Block, MutableBlock(..), unsafeIndex) import qualified Basement.Block as B+import qualified Basement.Block.Base as B import           Basement.Monad (PrimMonad, PrimState) import           Basement.Nat import           Basement.Types.OffsetSize import           Basement.NormalForm-import           Basement.PrimType (PrimType)-import           Basement.Types.OffsetSize (CountOf(..), Offset(..), offsetSub)+import           Basement.PrimType (PrimType, PrimSize, primSizeInBytes) -newtype BlockN (n :: Nat) a = BlockN { unBlock :: Block a } deriving (NormalForm, Eq, Show)+-- | Sized version of 'Block'+--+newtype BlockN (n :: Nat) a = BlockN { unBlock :: Block a }+  deriving (NormalForm, Eq, Show, Data, Ord)  newtype MutableBlockN (n :: Nat) ty st = MutableBlockN { unMBlock :: MutableBlock ty st } @@ -63,9 +76,54 @@   where     expected = toCount @n +length :: forall n ty+        . (KnownNat n, Countable ty n)+       => BlockN n ty+       -> CountOf ty+length _ = toCount @n++lengthBytes :: forall n ty+             . PrimType ty+            => BlockN n ty+            -> CountOf Word8+lengthBytes = B.lengthBytes . unBlock+ toBlock :: BlockN n ty -> Block ty toBlock = unBlock +cast :: forall n m a b+      . ( PrimType a, PrimType b+        , KnownNat n, KnownNat m+        , ((PrimSize b) * m) ~ ((PrimSize a) * n)+        )+      => BlockN n a+      -> BlockN m b+cast (BlockN b) = BlockN (B.unsafeCast b)++mutableCast :: forall n m a b st+             . ( PrimType a, PrimType b+             , KnownNat n, KnownNat m+             , ((PrimSize b) * m) ~ ((PrimSize a) * n)+             )+            => MutableBlockN n a st+            -> MutableBlockN m b st+mutableCast (MutableBlockN b) = MutableBlockN (B.unsafeRecast b)++-- | Create a new unpinned mutable block of a specific N size of 'ty' elements+--+-- If the size exceeds a GHC-defined threshold, then the memory will be+-- pinned. To be certain about pinning status with small size, use 'newPinned'+new :: forall n ty prim+     . (PrimType ty, KnownNat n, Countable ty n, PrimMonad prim)+    => prim (MutableBlockN n ty (PrimState prim))+new = MutableBlockN <$> B.new (toCount @n)++-- | Create a new pinned mutable block of a specific N size of 'ty' elements+newPinned :: forall n ty prim+           . (PrimType ty, KnownNat n, Countable ty n, PrimMonad prim)+          => prim (MutableBlockN n ty (PrimState prim))+newPinned = MutableBlockN <$> B.newPinned (toCount @n)+ singleton :: PrimType ty => ty -> BlockN 1 ty singleton a = BlockN (B.singleton a) @@ -155,3 +213,62 @@  toOffset :: forall n ty . (KnownNat n, Offsetable ty n) => Offset ty toOffset = natValOffset (Proxy @n)++-- | Get a Ptr pointing to the data in the Block.+--+-- Since a Block is immutable, this Ptr shouldn't be+-- to use to modify the contents+--+-- If the Block is pinned, then its address is returned as is,+-- however if it's unpinned, a pinned copy of the Block is made+-- before getting the address.+withPtr :: (PrimMonad prim, KnownNat n)+        => BlockN n ty+        -> (Ptr ty -> prim a)+        -> prim a+withPtr b = B.withPtr (unBlock b)++-- | Create a pointer on the beginning of the MutableBlock+-- and call a function 'f'.+--+-- The mutable block can be mutated by the 'f' function+-- and the change will be reflected in the mutable block+--+-- If the mutable block is unpinned, a trampoline buffer+-- is created and the data is only copied when 'f' return.+--+-- it is all-in-all highly inefficient as this cause 2 copies+withMutablePtr :: (PrimMonad prim, KnownNat n)+               => MutableBlockN n ty (PrimState prim)+               -> (Ptr ty -> prim a)+               -> prim a+withMutablePtr mb = B.withMutablePtr (unMBlock mb)++-- | Same as 'withMutablePtr' but allow to specify 2 optimisations+-- which is only useful when the MutableBlock is unpinned and need+-- a pinned trampoline to be called safely.+--+-- If skipCopy is True, then the first copy which happen before+-- the call to 'f', is skipped. The Ptr is now effectively+-- pointing to uninitialized data in a new mutable Block.+--+-- If skipCopyBack is True, then the second copy which happen after+-- the call to 'f', is skipped. Then effectively in the case of a+-- trampoline being used the memory changed by 'f' will not+-- be reflected in the original Mutable Block.+--+-- If using the wrong parameters, it will lead to difficult to+-- debug issue of corrupted buffer which only present themselves+-- with certain Mutable Block that happened to have been allocated+-- unpinned.+--+-- If unsure use 'withMutablePtr', which default to *not* skip+-- any copy.+withMutablePtrHint :: forall n ty prim a . (PrimMonad prim, KnownNat n)+                   => Bool -- ^ hint that the buffer doesn't need to have the same value as the mutable block when calling f+                   -> Bool -- ^ hint that the buffer is not supposed to be modified by call of f+                   -> MutableBlockN n ty (PrimState prim)+                   -> (Ptr ty -> prim a)+                   -> prim a+withMutablePtrHint skipCopy skipCopyBack (MutableBlockN mb) f =+    B.withMutablePtrHint skipCopy skipCopyBack mb f

@@ -18,9 +18,13 @@ {-# LANGUAGE ScopedTypeVariables       #-} {-# LANGUAGE UndecidableInstances      #-} {-# LANGUAGE AllowAmbiguousTypes       #-}+{-# LANGUAGE DeriveDataTypeable        #-}+{-# LANGUAGE DeriveGeneric             #-}+{-# LANGUAGE FlexibleContexts          #-} module Basement.Sized.List     ( ListN     , toListN+    , toListN_     , unListN     , length     , create@@ -29,26 +33,39 @@     , singleton     , uncons     , cons+    , unsnoc+    , snoc     , index     , indexStatic+    , updateAt     , map+    , mapi     , elem     , foldl     , foldl'+    , foldl1'+    , scanl'+    , scanl1'     , foldr+    , foldr1+    , reverse     , append     , minimum     , maximum     , head     , tail+    , init     , take     , drop     , splitAt     , zip, zip3, zip4, zip5+    , unzip     , zipWith, zipWith3, zipWith4, zipWith5     , replicate     -- * Applicative And Monadic     , replicateM+    , sequence+    , sequence_     , mapM     , mapM_     ) where@@ -56,6 +73,8 @@ import           Data.Proxy import qualified Data.List import           Basement.Compat.Base+import           Basement.Compat.CallStack+import           Basement.Compat.Natural import           Basement.Nat import           Basement.NormalForm import           Basement.Numerical.Additive@@ -63,13 +82,14 @@ import           Basement.Types.OffsetSize import           Basement.Compat.ExtList ((!!)) import qualified Prelude-import qualified Control.Monad as M (replicateM, mapM, mapM_)+import qualified Control.Monad as M (replicateM, mapM, mapM_, sequence, sequence_) -impossible :: a+impossible :: HasCallStack => a impossible = error "ListN: internal error: the impossible happened" +-- | A Typed-level sized List equivalent to [a] newtype ListN (n :: Nat) a = ListN { unListN :: [a] }-    deriving (Eq,Ord)+    deriving (Eq,Ord,Typeable,Generic)  instance Show a => Show (ListN n a) where     show (ListN l) = show l@@ -77,6 +97,7 @@ instance NormalForm a => NormalForm (ListN n a) where     toNormalForm (ListN l) = toNormalForm l +-- | Try to create a ListN from a List, succeeding if the length is correct toListN :: forall (n :: Nat) a . (KnownNat n, NatWithinBound Int n) => [a] -> Maybe (ListN n a) toListN l     | expected == Prelude.fromIntegral (Prelude.length l) = Just (ListN l)@@ -84,122 +105,249 @@   where     expected = natValInt (Proxy :: Proxy n) +-- | Create a ListN from a List, expecting a given length+--+-- If this list contains more or less than the expected length of the resulting type,+-- then an asynchronous error is raised. use 'toListN' for a more friendly functions+toListN_ :: forall n a . (HasCallStack, NatWithinBound Int n, KnownNat n) => [a] -> ListN n a+toListN_ l+    | expected == got = ListN l+    | otherwise       = error ("toListN_: expecting list of " <> show expected <> " elements, got " <> show got <> " elements")+  where+    expected = natValInt (Proxy :: Proxy n)+    got      = Prelude.length l++-- | performs a monadic action n times, gathering the results in a List of size n. replicateM :: forall (n :: Nat) m a . (NatWithinBound Int n, Monad m, KnownNat n) => m a -> m (ListN n a) replicateM action = ListN <$> M.replicateM (Prelude.fromIntegral $ natVal (Proxy :: Proxy n)) action +-- | Evaluate each monadic action in the list sequentially, and collect the results.+sequence :: Monad m => ListN n (m a) -> m (ListN n a)+sequence (ListN l) = ListN <$> M.sequence l++-- | Evaluate each monadic action in the list sequentially, and ignore the results.+sequence_ :: Monad m => ListN n (m a) -> m ()+sequence_ (ListN l) = M.sequence_ l++-- | Map each element of a List to a monadic action, evaluate these+-- actions sequentially and collect the results mapM :: Monad m => (a -> m b) -> ListN n a -> m (ListN n b) mapM f (ListN l) = ListN <$> M.mapM f l +-- | Map each element of a List to a monadic action, evaluate these+-- actions sequentially and ignore the results mapM_ :: Monad m => (a -> m b) -> ListN n a -> m () mapM_ f (ListN l) = M.mapM_ f l +-- | Create a list of n elements where each element is the element in argument replicate :: forall (n :: Nat) a . (NatWithinBound Int n, KnownNat n) => a -> ListN n a replicate a = ListN $ Prelude.replicate (Prelude.fromIntegral $ natVal (Proxy :: Proxy n)) a -uncons :: CmpNat n 0 ~ 'GT => ListN n a -> (a, ListN (n-1) a)+-- | Decompose a list into its head and tail.+uncons :: (1 <= n) => ListN n a -> (a, ListN (n-1) a) uncons (ListN (x:xs)) = (x, ListN xs) uncons _ = impossible +-- | prepend an element to the list cons :: a -> ListN n a -> ListN (n+1) a cons a (ListN l) = ListN (a : l) +-- | Decompose a list into its first elements and the last.+unsnoc :: (1 <= n) => ListN n a -> (ListN (n-1) a, a)+unsnoc (ListN l) = (ListN $ Data.List.init l, Data.List.last l)++-- | append an element to the list+snoc :: ListN n a -> a -> ListN (n+1) a+snoc (ListN l) a = ListN (l Prelude.++ [a])++-- | Create an empty list of a empty :: ListN 0 a empty = ListN [] -length :: forall a (n :: Nat) . (KnownNat n, NatWithinBound Int n) => ListN n a -> Int-length _ = natValInt (Proxy :: Proxy n)+-- | Get the length of a list+length :: forall a (n :: Nat) . (KnownNat n, NatWithinBound Int n) => ListN n a -> CountOf a+length _ = CountOf $ natValInt (Proxy :: Proxy n) -create :: forall a (n :: Nat) . KnownNat n => (Integer -> a) -> ListN n a-create f = ListN $ Prelude.map f [0..(len-1)]+-- | Create a new list of size n, repeately calling f from 0 to n-1+create :: forall a (n :: Nat) . KnownNat n => (Natural -> a) -> ListN n a+create f = ListN $ Prelude.map (f . Prelude.fromIntegral) [0..(len-1)]   where     len = natVal (Proxy :: Proxy n) +-- | Same as create but apply an offset createFrom :: forall a (n :: Nat) (start :: Nat) . (KnownNat n, KnownNat start)-           => Proxy start -> (Integer -> a) -> ListN n a-createFrom p f = ListN $ Prelude.map f [idx..(idx+len-1)]+           => Proxy start -> (Natural -> a) -> ListN n a+createFrom p f = ListN $ Prelude.map (f . Prelude.fromIntegral) [idx..(idx+len-1)]   where     len = natVal (Proxy :: Proxy n)     idx = natVal p +-- | create a list of 1 element singleton :: a -> ListN 1 a singleton a = ListN [a] +-- | Check if a list contains the element a elem :: Eq a => a -> ListN n a -> Bool elem a (ListN l) = Prelude.elem a l +-- | Append 2 list together returning the new list append :: ListN n a -> ListN m a -> ListN (n+m) a append (ListN l1) (ListN l2) = ListN (l1 <> l2) -maximum :: (Ord a, CmpNat n 0 ~ 'GT) => ListN n a -> a+-- | Get the maximum element of a list+maximum :: (Ord a, 1 <= n) => ListN n a -> a maximum (ListN l) = Prelude.maximum l -minimum :: (Ord a, CmpNat n 0 ~ 'GT) => ListN n a -> a+-- | Get the minimum element of a list+minimum :: (Ord a, 1 <= n) => ListN n a -> a minimum (ListN l) = Prelude.minimum l -head :: CmpNat n 0 ~ 'GT => ListN n a -> a+-- | Get the head element of a list+head :: (1 <= n) => ListN n a -> a head (ListN (x:_)) = x head _ = impossible -tail :: CmpNat n 0 ~ 'GT => ListN n a -> ListN (n-1) a+-- | Get the tail of a list+tail :: (1 <= n) => ListN n a -> ListN (n-1) a tail (ListN (_:xs)) = ListN xs tail _ = impossible +-- | Get the list with the last element missing+init :: (1 <= n) => ListN n a -> ListN (n-1) a+init (ListN l) = ListN $ Data.List.init l++-- | Take m elements from the beggining of the list.+--+-- The number of elements need to be less or equal to the list in argument take :: forall a (m :: Nat) (n :: Nat) . (KnownNat m, NatWithinBound Int m, m <= n) => ListN n a -> ListN m a take (ListN l) = ListN (Prelude.take n l)   where n = natValInt (Proxy :: Proxy m) +-- | Drop elements from a list keeping the m remaining elements drop :: forall a d (m :: Nat) (n :: Nat) . (KnownNat d, NatWithinBound Int d, (n - m) ~ d, m <= n) => ListN n a -> ListN m a drop (ListN l) = ListN (Prelude.drop n l)   where n = natValInt (Proxy :: Proxy d) +-- | Split a list into two, returning 2 lists splitAt :: forall a d (m :: Nat) (n :: Nat) . (KnownNat d, NatWithinBound Int d, (n - m) ~ d, m <= n) => ListN n a -> (ListN m a, ListN (n-m) a) splitAt (ListN l) = let (l1, l2) = Prelude.splitAt n l in (ListN l1, ListN l2)   where n = natValInt (Proxy :: Proxy d) +-- | Get the i'th elements+--+-- This only works with TypeApplication:+--+-- > indexStatic @1 (toListN_ [1,2,3] :: ListN 3 Int) indexStatic :: forall i n a . (KnownNat i, CmpNat i n ~ 'LT, Offsetable a i) => ListN n a -> a indexStatic (ListN l) = l !! (natValOffset (Proxy :: Proxy i)) +-- | Get the i'the element index :: ListN n ty -> Offset ty -> ty index (ListN l) ofs = l !! ofs +-- | Update the value in a list at a specific location+updateAt :: forall n a+         .  Offset a+         -> (a -> a)+         -> ListN n a+         -> ListN n a+updateAt o f (ListN l) = ListN (doUpdate 0 l)+  where doUpdate _ []     = []+        doUpdate i (x:xs)+            | i == o      = f x : xs+            | otherwise   = x : doUpdate (i+1) xs++-- | Map all elements in a list map :: (a -> b) -> ListN n a -> ListN n b map f (ListN l) = ListN (Prelude.map f l) +-- | Map all elements in a list with an additional index+mapi :: (Natural -> a -> b) -> ListN n a -> ListN n b+mapi f (ListN l) = ListN . loop 0 $ l+  where loop _ []     = []+        loop i (x:xs) = f i x : loop (i+1) xs++-- | Fold all elements from left foldl :: (b -> a -> b) -> b -> ListN n a -> b foldl f acc (ListN l) = Prelude.foldl f acc l +-- | Fold all elements from left strictly foldl' :: (b -> a -> b) -> b -> ListN n a -> b foldl' f acc (ListN l) = Data.List.foldl' f acc l +-- | Fold all elements from left strictly with a first element+-- as the accumulator+foldl1' :: (1 <= n) => (a -> a -> a) -> ListN n a -> a+foldl1' f (ListN l) = Data.List.foldl1' f l++-- | Fold all elements from right foldr :: (a -> b -> b) -> b -> ListN n a -> b foldr f acc (ListN l) = Prelude.foldr f acc l +-- | Fold all elements from right assuming at least one element is in the list.+foldr1 :: (1 <= n) => (a -> a -> a) -> ListN n a -> a+foldr1 f (ListN l) = Prelude.foldr1 f l++-- | 'scanl' is similar to 'foldl', but returns a list of successive+-- reduced values from the left+--+-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]+scanl' :: (b -> a -> b) -> b -> ListN n a -> ListN (n+1) b+scanl' f initialAcc (ListN start) = ListN (go initialAcc start)+  where+    go !acc l = acc : case l of+                        []     -> []+                        (x:xs) -> go (f acc x) xs++-- | 'scanl1' is a variant of 'scanl' that has no starting value argument:+--+-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]+scanl1' :: (a -> a -> a) -> ListN n a -> ListN n a+scanl1' f (ListN l) = case l of+                        []     -> ListN []+                        (x:xs) -> ListN $ Data.List.scanl' f x xs++-- | Reverse a list+reverse :: ListN n a -> ListN n a+reverse (ListN l) = ListN (Prelude.reverse l)++-- | Zip 2 lists of the same size, returning a new list of+-- the tuple of each elements zip :: ListN n a -> ListN n b -> ListN n (a,b) zip (ListN l1) (ListN l2) = ListN (Prelude.zip l1 l2) +-- | Unzip a list of tuple, to 2 List of the deconstructed tuples+unzip :: ListN n (a,b) -> (ListN n a, ListN n b)+unzip l = (map fst l, map snd l)++-- | Zip 3 lists of the same size zip3 :: ListN n a -> ListN n b -> ListN n c -> ListN n (a,b,c) zip3 (ListN x1) (ListN x2) (ListN x3) = ListN (loop x1 x2 x3)   where loop (l1:l1s) (l2:l2s) (l3:l3s) = (l1,l2,l3) : loop l1s l2s l3s         loop []       _        _        = []         loop _        _        _        = impossible +-- | Zip 4 lists of the same size zip4 :: ListN n a -> ListN n b -> ListN n c -> ListN n d -> ListN n (a,b,c,d) zip4 (ListN x1) (ListN x2) (ListN x3) (ListN x4) = ListN (loop x1 x2 x3 x4)   where loop (l1:l1s) (l2:l2s) (l3:l3s) (l4:l4s) = (l1,l2,l3,l4) : loop l1s l2s l3s l4s         loop []       _        _        _        = []         loop _        _        _        _        = impossible +-- | Zip 5 lists of the same size zip5 :: ListN n a -> ListN n b -> ListN n c -> ListN n d -> ListN n e -> ListN n (a,b,c,d,e) zip5 (ListN x1) (ListN x2) (ListN x3) (ListN x4) (ListN x5) = ListN (loop x1 x2 x3 x4 x5)   where loop (l1:l1s) (l2:l2s) (l3:l3s) (l4:l4s) (l5:l5s) = (l1,l2,l3,l4,l5) : loop l1s l2s l3s l4s l5s         loop []       _        _        _        _        = []         loop _        _        _        _        _        = impossible +-- | Zip 2 lists using a function zipWith :: (a -> b -> x) -> ListN n a -> ListN n b -> ListN n x zipWith f (ListN (v1:vs)) (ListN (w1:ws)) = ListN (f v1 w1 : unListN (zipWith f (ListN vs) (ListN ws))) zipWith _ (ListN [])       _ = ListN [] zipWith _ _                _ = impossible +-- | Zip 3 lists using a function zipWith3 :: (a -> b -> c -> x)          -> ListN n a          -> ListN n b@@ -210,6 +358,7 @@ zipWith3 _ (ListN []) _       _ = ListN [] zipWith3 _ _          _       _ = impossible +-- | Zip 4 lists using a function zipWith4 :: (a -> b -> c -> d -> x)          -> ListN n a          -> ListN n b@@ -221,6 +370,7 @@ zipWith4 _ (ListN []) _       _       _ = ListN [] zipWith4 _ _          _       _       _ = impossible +-- | Zip 5 lists using a function zipWith5 :: (a -> b -> c -> d -> e -> x)          -> ListN n a          -> ListN n b

@@ -79,6 +79,7 @@     , readFloatingExact     , upper     , lower+    , caseFold     , isPrefixOf     , isSuffixOf     , isInfixOf@@ -99,6 +100,7 @@ import qualified Basement.UArray           as C import qualified Basement.UArray.Mutable   as MVec import           Basement.Block.Mutable (Block(..), MutableBlock(..))+import qualified Basement.Block.Mutable    as MBLK import           Basement.Compat.Bifunctor import           Basement.Compat.Base import           Basement.Compat.Natural@@ -116,16 +118,15 @@ import           Basement.IntegralConv import           Basement.Floating import           Basement.MutableBuilder-import           Basement.String.CaseMapping (upperMapping, lowerMapping)+import           Basement.String.CaseMapping (upperMapping, lowerMapping, foldMapping) import           Basement.UTF8.Table import           Basement.UTF8.Helper import           Basement.UTF8.Base import           Basement.UTF8.Types-import           Basement.UArray.Base as C (onBackendPrim, onBackend, offset, ValidRange(..), offsetsValidRange)-import qualified Basement.Alg.Native.UTF8 as PrimBA-import qualified Basement.Alg.Foreign.UTF8 as PrimAddr-import qualified Basement.Alg.Native.String as BackendBA-import qualified Basement.Alg.Foreign.String as BackendAddr+import           Basement.UArray.Base as C (onBackendPrim, onBackend, onBackendPure, offset, ValidRange(..), offsetsValidRange, MUArray(..), MUArrayBackend(..))+import           Basement.Alg.Class (Indexable)+import qualified Basement.Alg.UTF8 as UTF8+import qualified Basement.Alg.String as Alg import           GHC.Prim import           GHC.ST import           GHC.Types@@ -167,9 +168,9 @@   where     unTranslateOffset start = first (\e -> e `offsetSub` start)     goBa ba start =-        unTranslateOffset start $ BackendBA.validate (start+end) ba (start + ofsStart)-    goAddr (Ptr addr) start =-        pure $ unTranslateOffset start $ BackendAddr.validate (start+end) addr (ofsStart + start)+        unTranslateOffset start $ Alg.validate (start+end) ba (start + ofsStart)+    goAddr ptr@(Ptr !_) start =+        pure $ unTranslateOffset start $ Alg.validate (start+end) ptr (ofsStart + start)     end = ofsStart `offsetPlusE` sz  -- | Similar to 'validate' but works on a 'MutableByteArray'@@ -360,8 +361,8 @@ indexN :: CountOf Char -> String -> Offset Word8 indexN !n (String ba) = Vec.unsafeDewrap goVec goAddr ba   where-    goVec :: ByteArray# -> Offset Word8 -> Offset Word8-    goVec !ma !start = loop start 0+    goVec :: Block Word8 -> Offset Word8 -> Offset Word8+    goVec (Block !ma) !start = loop start 0       where         !len = start `offsetPlusE` Vec.length ba         loop :: Offset Word8 -> Offset Char -> Offset Word8@@ -469,15 +470,15 @@ breakEnd :: (Char -> Bool) -> String -> (String, String) breakEnd predicate s@(String arr)     | k == end  = (s, mempty)-    | otherwise = splitIndex k s+    | otherwise = splitIndex (k `offsetSub` start) s   where     k = C.onBackend goVec (\_ -> pure . goAddr) arr     (C.ValidRange !start !end) = offsetsValidRange arr-    goVec (Block ba) = let k = BackendBA.revFindIndexPredicate predicate ba start end-                        in if k == end then end else PrimBA.nextSkip ba k-    goAddr (Ptr addr) =-        let k = BackendAddr.revFindIndexPredicate predicate addr start end-         in if k == end then end else PrimAddr.nextSkip addr k+    goVec ba@(Block !_) = let k = Alg.revFindIndexPredicate predicate ba start end+                        in if k == end then end else UTF8.nextSkip ba k+    goAddr ptr@(Ptr !_) =+        let k = Alg.revFindIndexPredicate predicate ptr start end+         in if k == end then end else UTF8.nextSkip ptr k {-# INLINE [2] breakEnd #-}  #if MIN_VERSION_base(4,9,0)@@ -606,8 +607,8 @@     | otherwise    = C.onBackend goVec (\_ -> pure . goAddr) arr   where     (C.ValidRange !start !end) = offsetsValidRange arr-    goVec (Block ma) = PrimBA.length ma start end-    goAddr (Ptr ptr) = PrimAddr.length ptr start end+    goVec ma = UTF8.length ma start end+    goAddr ptr = UTF8.length ptr start end  -- | Replicate a character @c@ @n@ times to create a string of length @n@ replicate :: CountOf Char -> Char -> String@@ -787,8 +788,8 @@ filter :: (Char -> Bool) -> String -> String filter predicate (String arr) = runST $ do     (finalSize, dst) <- newNative sz $ \(MutableBlock mba) ->-        C.onBackendPrim (\(Block ba) -> BackendBA.copyFilter predicate sz mba ba start)-                        (\fptr -> withFinalPtr fptr $ \(Ptr addr) -> BackendAddr.copyFilter predicate sz mba addr start)+        C.onBackendPrim (\ba@(Block !_) -> Alg.copyFilter predicate sz mba ba start)+                        (\fptr -> withFinalPtr fptr $ \ptr@(Ptr !_) -> Alg.copyFilter predicate sz mba ptr start)                         arr     freezeShrink finalSize dst   where@@ -800,8 +801,8 @@ reverse (String arr) = runST $ do     ((), dst) <- newNative (C.length arr) $ \(MutableBlock mba) ->             C.onBackendPrim-                (\(Block ba) -> PrimBA.reverse mba 0 ba start end)-                (\fptr -> withFinalPtr fptr $ \(Ptr addr) -> PrimAddr.reverse mba 0 addr start end)+                (\ba@(Block !_) -> UTF8.reverse mba 0 ba start end)+                (\fptr -> withFinalPtr fptr $ \ptr@(Ptr !_) -> UTF8.reverse mba 0 ptr start end)                 arr     freeze dst   where@@ -1054,7 +1055,7 @@ builderBuild_ :: PrimMonad m => Int -> Builder String MutableString Word8 m () () -> m String builderBuild_ sizeChunksI sb = either (\() -> internalError "impossible output") id <$> builderBuild sizeChunksI sb -stringDewrap :: (ByteArray# -> Offset Word8 -> a)+stringDewrap :: (Block Word8 -> Offset Word8 -> a)              -> (Ptr Word8 -> Offset Word8 -> ST s a)              -> String              -> a@@ -1067,18 +1068,18 @@ readIntegral :: (HasNegation i, IntegralUpsize Word8 i, Additive i, Multiplicative i, IsIntegral i) => String -> Maybe i readIntegral str     | sz == 0   = Nothing-    | otherwise = stringDewrap withBa (\(Ptr ptr) -> pure . withPtr ptr) str+    | otherwise = stringDewrap withBa (\ptr@(Ptr !_) -> pure . withPtr ptr) str   where     !sz = size str     withBa ba ofs =-        let negativeSign = PrimBA.expectAscii ba ofs 0x2d+        let negativeSign = UTF8.expectAscii ba ofs 0x2d             startOfs     = if negativeSign then succ ofs else ofs          in case decimalDigitsBA 0 ba endOfs startOfs of                 (# acc, True, endOfs' #) | endOfs' > startOfs -> Just $! if negativeSign then negate acc else acc                 _                                             -> Nothing       where !endOfs = ofs `offsetPlusE` sz     withPtr addr ofs =-        let negativeSign = PrimAddr.expectAscii addr ofs 0x2d+        let negativeSign = UTF8.expectAscii addr ofs 0x2d             startOfs     = if negativeSign then succ ofs else ofs          in case decimalDigitsPtr 0 addr endOfs startOfs of                 (# acc, True, endOfs' #) | endOfs' > startOfs -> Just $! if negativeSign then negate acc else acc@@ -1096,7 +1097,7 @@ readNatural :: String -> Maybe Natural readNatural str     | sz == 0   = Nothing-    | otherwise = stringDewrap withBa (\(Ptr ptr) -> pure . withPtr ptr) str+    | otherwise = stringDewrap withBa (\ptr@(Ptr !_) -> pure . withPtr ptr) str   where     !sz = size str     withBa ba stringStart =@@ -1178,7 +1179,7 @@     !sz = size str      withBa ba stringStart =-        let !isNegative = PrimBA.expectAscii ba stringStart 0x2d+        let !isNegative = UTF8.expectAscii ba stringStart 0x2d          in consumeIntegral isNegative (if isNegative then stringStart+1 else stringStart)       where         eofs = stringStart `offsetPlusE` sz@@ -1186,7 +1187,7 @@             case decimalDigitsBA 0 ba eofs startOfs of                 (# acc, True , endOfs #) | endOfs > startOfs -> f isNegative acc 0 Nothing -- end of stream and no '.'                 (# acc, False, endOfs #) | endOfs > startOfs ->-                    if PrimBA.expectAscii ba endOfs 0x2e+                    if UTF8.expectAscii ba endOfs 0x2e                         then consumeFloat isNegative acc (endOfs + 1)                         else consumeExponant isNegative acc 0 endOfs                 _                                            -> Nothing@@ -1203,22 +1204,22 @@             | startOfs == eofs = f isNegative integral floatingDigits Nothing             | otherwise        =                 -- consume 'E' or 'e'-                case PrimBA.nextAscii ba startOfs of+                case UTF8.nextAscii ba startOfs of                     StepASCII 0x45 -> consumeExponantSign (startOfs+1)                     StepASCII 0x65 -> consumeExponantSign (startOfs+1)                     _              -> Nothing           where             consumeExponantSign ofs                 | ofs == eofs = Nothing-                | otherwise   = let exponentNegative = PrimBA.expectAscii ba ofs 0x2d+                | otherwise   = let exponentNegative = UTF8.expectAscii ba ofs 0x2d                                  in consumeExponantNumber exponentNegative (if exponentNegative then ofs + 1 else ofs)              consumeExponantNumber exponentNegative ofs =                 case decimalDigitsBA 0 ba eofs ofs of                     (# acc, True, endOfs #) | endOfs > ofs -> f isNegative integral floatingDigits (Just $! if exponentNegative then negate acc else acc)                     _                                      -> Nothing-    withPtr (Ptr ptr) stringStart = pure $-        let !isNegative = PrimAddr.expectAscii ptr stringStart 0x2d+    withPtr ptr@(Ptr !_) stringStart = pure $+        let !isNegative = UTF8.expectAscii ptr stringStart 0x2d          in consumeIntegral isNegative (if isNegative then stringStart+1 else stringStart)       where         eofs = stringStart `offsetPlusE` sz@@ -1226,7 +1227,7 @@             case decimalDigitsPtr 0 ptr eofs startOfs of                 (# acc, True , endOfs #) | endOfs > startOfs -> f isNegative acc 0 Nothing -- end of stream and no '.'                 (# acc, False, endOfs #) | endOfs > startOfs ->-                    if PrimAddr.expectAscii ptr endOfs 0x2e+                    if UTF8.expectAscii ptr endOfs 0x2e                         then consumeFloat isNegative acc (endOfs + 1)                         else consumeExponant isNegative acc 0 endOfs                 _                                            -> Nothing@@ -1243,14 +1244,14 @@             | startOfs == eofs = f isNegative integral floatingDigits Nothing             | otherwise        =                 -- consume 'E' or 'e'-                case PrimAddr.nextAscii ptr startOfs of+                case UTF8.nextAscii ptr startOfs of                     StepASCII 0x45 -> consumeExponantSign (startOfs+1)                     StepASCII 0x65 -> consumeExponantSign (startOfs+1)                     _              -> Nothing           where             consumeExponantSign ofs                 | ofs == eofs = Nothing-                | otherwise   = let exponentNegative = PrimAddr.expectAscii ptr ofs 0x2d+                | otherwise   = let exponentNegative = UTF8.expectAscii ptr ofs 0x2d                                  in consumeExponantNumber exponentNegative (if exponentNegative then ofs + 1 else ofs)              consumeExponantNumber exponentNegative ofs =@@ -1282,7 +1283,7 @@ -- this function decimalDigitsBA :: (IntegralUpsize Word8 acc, Additive acc, Multiplicative acc, Integral acc)                 => acc-                -> ByteArray#+                -> Block Word8                 -> Offset Word8 -- end offset                 -> Offset Word8 -- start offset                 -> (# acc, Bool, Offset Word8 #)@@ -1291,18 +1292,18 @@     loop !acc !ofs         | ofs == endOfs = (# acc, True, ofs #)         | otherwise     =-            case PrimBA.nextAsciiDigit ba ofs of+            case UTF8.nextAsciiDigit ba ofs of                 sg@(StepDigit d) | isValidStepDigit sg -> loop (10 * acc + integralUpsize d) (succ ofs)                                  | otherwise           -> (# acc, False, ofs #)-{-# SPECIALIZE decimalDigitsBA :: Integer -> ByteArray# -> Offset Word8 -> Offset Word8 -> (# Integer, Bool, Offset Word8 #) #-}-{-# SPECIALIZE decimalDigitsBA :: Natural -> ByteArray# -> Offset Word8 -> Offset Word8 -> (# Natural, Bool, Offset Word8 #) #-}-{-# SPECIALIZE decimalDigitsBA :: Int -> ByteArray# -> Offset Word8 -> Offset Word8 -> (# Int, Bool, Offset Word8 #) #-}-{-# SPECIALIZE decimalDigitsBA :: Word -> ByteArray# -> Offset Word8 -> Offset Word8 -> (# Word, Bool, Offset Word8 #) #-}+{-# SPECIALIZE decimalDigitsBA :: Integer -> Block Word8 -> Offset Word8 -> Offset Word8 -> (# Integer, Bool, Offset Word8 #) #-}+{-# SPECIALIZE decimalDigitsBA :: Natural -> Block Word8 -> Offset Word8 -> Offset Word8 -> (# Natural, Bool, Offset Word8 #) #-}+{-# SPECIALIZE decimalDigitsBA :: Int -> Block Word8 -> Offset Word8 -> Offset Word8 -> (# Int, Bool, Offset Word8 #) #-}+{-# SPECIALIZE decimalDigitsBA :: Word -> Block Word8 -> Offset Word8 -> Offset Word8 -> (# Word, Bool, Offset Word8 #) #-}  -- | same as decimalDigitsBA specialized for ptr # decimalDigitsPtr :: (IntegralUpsize Word8 acc, Additive acc, Multiplicative acc, Integral acc)                  => acc-                 -> Addr#+                 -> Ptr Word8                  -> Offset Word8 -- end offset                  -> Offset Word8 -- start offset                  -> (# acc, Bool, Offset Word8 #)@@ -1311,68 +1312,56 @@     loop !acc !ofs         | ofs == endOfs = (# acc, True, ofs #)         | otherwise     =-            case PrimAddr.nextAsciiDigit ptr ofs of+            case UTF8.nextAsciiDigit ptr ofs of                 sg@(StepDigit d) | isValidStepDigit sg -> loop (10 * acc + integralUpsize d) (succ ofs)                                  | otherwise           -> (# acc, False, ofs #)-{-# SPECIALIZE decimalDigitsPtr :: Integer -> Addr# -> Offset Word8 -> Offset Word8 -> (# Integer, Bool, Offset Word8 #) #-}-{-# SPECIALIZE decimalDigitsPtr :: Natural -> Addr# -> Offset Word8 -> Offset Word8 -> (# Natural, Bool, Offset Word8 #) #-}-{-# SPECIALIZE decimalDigitsPtr :: Int -> Addr# -> Offset Word8 -> Offset Word8 -> (# Int, Bool, Offset Word8 #) #-}-{-# SPECIALIZE decimalDigitsPtr :: Word -> Addr# -> Offset Word8 -> Offset Word8 -> (# Word, Bool, Offset Word8 #) #-}---- | A unicode string size may vary during a case conversion operation.---   This function calculates the new buffer size for a case conversion.---   Returns Nothing if no case conversion is needed.-caseConvertNBuff :: (Char -> CM) -> String -> Maybe (CountOf Word8)-caseConvertNBuff op s@(String ba) = runST $ Vec.unsafeIndexer ba go-  where-    !sz = size s-    !end = azero `offsetPlusE` sz-    go :: (Offset Word8 -> Word8) -> ST st (Maybe (CountOf Word8))-    go getIdx = loop (Offset 0) 0 False-      where-        !nextI = nextWithIndexer getIdx-        eSize !e = if e == '\0' -                      then 0-                      else charToBytes (fromEnum e)-        loop !idx ns changed -            | idx == end = if changed-                             then return $ Just ns-                             else return Nothing-            | otherwise = do-                let !(c, idx') = nextI idx-                    !cm@(CM c1 c2 c3) = op c -                    !cSize = if c2 == '\0' -- if c2 is empty, c3 will be empty as well.-                              then charToBytes (fromEnum c1) -                              else eSize c1 + eSize c2 + eSize c3-                    !nchanged = changed || c1 /= c || c2 /= '\0'-                loop idx' (ns + cSize) nchanged+{-# SPECIALIZE decimalDigitsPtr :: Integer -> Ptr Word8 -> Offset Word8 -> Offset Word8 -> (# Integer, Bool, Offset Word8 #) #-}+{-# SPECIALIZE decimalDigitsPtr :: Natural -> Ptr Word8 -> Offset Word8 -> Offset Word8 -> (# Natural, Bool, Offset Word8 #) #-}+{-# SPECIALIZE decimalDigitsPtr :: Int -> Ptr Word8 -> Offset Word8 -> Offset Word8 -> (# Int, Bool, Offset Word8 #) #-}+{-# SPECIALIZE decimalDigitsPtr :: Word -> Ptr Word8 -> Offset Word8 -> Offset Word8 -> (# Word, Bool, Offset Word8 #) #-} --- | Convert a 'String' 'Char' by 'Char' using a case mapping function. +-- | Convert a 'String' 'Char' by 'Char' using a case mapping function. caseConvert :: (Char -> CM) -> String -> String-caseConvert op s@(String ba) -  = case nBuff of-      Nothing -> s-      Just nLen -> runST $ unsafeCopyFrom s nLen go+caseConvert op s@(String arr) = runST $ do+  mba <- MBLK.new iLen+  nL <- C.onBackendPrim+        (\blk  -> go mba blk (Offset 0) start)+        (\fptr -> withFinalPtr fptr $ \ptr -> go mba ptr (Offset 0) start)+        arr+  freeze . MutableString $ MVec.MUArray 0 nL (C.MUArrayMBA mba)   where-    !nBuff = caseConvertNBuff op s-    go :: String -> Offset Char -> Offset8 -> MutableString s -> Offset8 -> ST s (Offset8, Offset8)-    go src' srcI srcIdx dst dstIdx = do-      let !(CM c1 c2 c3) = op c -      dstIdx <- write dst dstIdx c1-      nextDstIdx <- -        if c2 == '\0' -- We don't want to check C3 if C2 is empty.-          then return dstIdx-          else do-            dstIdx  <- writeValidChar c2 dstIdx-            writeValidChar c3 dstIdx-      return (nextSrcIdx, nextDstIdx)-          where-            !(Step c nextSrcIdx) = next src' srcIdx-            writeValidChar cc wIdx =-                if cc == '\0'-                    then return wIdx +    !(C.ValidRange start end) = C.offsetsValidRange arr+    !iLen = 1 + C.length arr+    go :: (Indexable container Word8, PrimMonad prim)+       => MutableBlock Word8 (PrimState prim)+       -> container+       -> Offset Word8+       -> Offset Word8+       -> prim (CountOf Word8)+    go !dst !src = loop dst iLen 0+      where+        eSize !e = if e == '\0' then 0 else charToBytes (fromEnum e)+        loop !dst !allocLen !nLen !dstIdx !srcIdx+          | srcIdx == end = return nLen+          | nLen == allocLen = realloc+          | otherwise = do+              let !(CM c1 c2 c3) = op c+                  !(Step c nextSrcIdx) = UTF8.next src srcIdx+              nextDstIdx <- UTF8.writeUTF8 dst dstIdx c1+              if c2 == '\0' -- We keep the most common case loop as short as possible.+                then loop dst allocLen (nLen + charToBytes (fromEnum c1)) nextDstIdx nextSrcIdx                 else do-                    write dst wIdx cc+                  let !cSize = eSize c1 + eSize c2 + eSize c3+                  nextDstIdx <- UTF8.writeUTF8 dst nextDstIdx c2+                  nextDstIdx <- if c3 == '\0' then return nextDstIdx else UTF8.writeUTF8 dst nextDstIdx c3+                  loop dst allocLen (nLen + cSize) nextDstIdx nextSrcIdx+          where+            {-# NOINLINE realloc #-}+            realloc = do+              let nAll = allocLen + allocLen + 1+              nDst <- MBLK.new nAll+              MBLK.unsafeCopyElements nDst 0 dst 0 nLen+              loop nDst nAll nLen dstIdx srcIdx  -- | Convert a 'String' to the upper-case equivalent. upper :: String -> String@@ -1382,6 +1371,12 @@ lower :: String -> String lower = caseConvert lowerMapping +-- | Convert a 'String' to the unicode case fold equivalent.+--+-- Case folding is mostly used for caseless comparison of strings.+caseFold :: String -> String+caseFold = caseConvert foldMapping+ -- | Check whether the first string is a prefix of the second string. isPrefixOf :: String -> String -> Bool isPrefixOf (String needle) (String haystack) = C.isPrefixOf needle haystack@@ -1429,15 +1424,15 @@ all predicate (String arr) = C.onBackend goBA (\_ -> pure . goAddr) arr   where     !(C.ValidRange start end) = C.offsetsValidRange arr-    goBA (Block ba)   = PrimBA.all predicate ba start end-    goAddr (Ptr addr) = PrimAddr.all predicate addr start end+    goBA ba   = UTF8.all predicate ba start end+    goAddr addr = UTF8.all predicate addr start end  any :: (Char -> Bool) -> String -> Bool any predicate (String arr) = C.onBackend goBA (\_ -> pure . goAddr) arr   where     !(C.ValidRange start end) = C.offsetsValidRange arr-    goBA (Block ba)   = PrimBA.any predicate ba start end-    goAddr (Ptr addr) = PrimAddr.any predicate addr start end+    goBA ba   = UTF8.any predicate ba start end+    goAddr addr = UTF8.any predicate addr start end  -- | Transform string @src@ to base64 binary representation. toBase64 :: String -> String

@@ -15,6 +15,9 @@     -- * Emit functions     , emit     , emitChar++    -- * unsafe+    , unsafeStringBuilder     ) where  @@ -29,6 +32,10 @@  newtype Builder = Builder Block.Builder   deriving (Semigroup, Monoid)++unsafeStringBuilder :: Block.Builder -> Builder+unsafeStringBuilder = Builder+{-# INLINE unsafeStringBuilder #-}  run :: PrimMonad prim => Builder -> prim (String, Maybe ValidationFailure, UArray Word8) run (Builder builder) = do

@@ -20,6 +20,9 @@ #include <windows.h> #elif defined FOUNDATION_SYSTEM_UNIX #include <sys/ioctl.h>+#ifdef __sun+#include <sys/termios.h>+#endif #endif   #include <stdio.h>

@@ -17,6 +17,7 @@     ( FileSize(..)     , Offset(..)     , Offset8+    , sentinel     , offsetOfE     , offsetPlusE     , offsetMinusE@@ -85,6 +86,8 @@ -- Trying to bring some sanity by a lightweight wrapping. newtype Offset ty = Offset Int     deriving (Show,Eq,Ord,Enum,Additive,Typeable,Integral,Prelude.Num)++sentinel = Offset (-1)  instance IsIntegral (Offset ty) where     toInteger (Offset i) = toInteger i

@@ -12,6 +12,12 @@     , bitwiseAnd     , bitwiseOr     , bitwiseXor+    , complement+    , shiftL+    , shiftR+    , rotateL+    , rotateR+    , popCount     , fromNatural     ) where 

@@ -12,6 +12,12 @@     , bitwiseAnd     , bitwiseOr     , bitwiseXor+    , complement+    , shiftL+    , shiftR+    , rotateL+    , rotateR+    , popCount     , fromNatural     ) where @@ -91,7 +97,7 @@         poke (castPtr p `plusPtr` 8 ) a2         poke (castPtr p `plusPtr` 16) a1         poke (castPtr p `plusPtr` 24) a0-                    + instance Integral Word256 where     fromInteger = literal instance HasNegation Word256 where

@@ -106,7 +106,6 @@     , toBase64Internal     ) where -import           Control.Monad (when) import           GHC.Prim import           GHC.Types import           GHC.Word@@ -136,8 +135,6 @@ import           Basement.Bindings.Memory (sysHsMemFindByteBa, sysHsMemFindByteAddr) import qualified Basement.Compat.ExtList as List import qualified Basement.Base16 as Base16-import qualified Basement.Alg.Native.Prim as PrimBA-import qualified Basement.Alg.Foreign.Prim as PrimAddr import qualified Basement.Alg.Mutable as Alg import qualified Basement.Alg.Class as Alg import qualified Basement.Alg.PrimArray as Alg@@ -394,14 +391,13 @@  breakElem :: PrimType ty => ty -> UArray ty -> (UArray ty, UArray ty) breakElem !ty arr@(UArray start len backend)--- TODO: return Maybe k-    | k == end   = (arr, empty)-    | k == start = (empty, arr)-    | otherwise  = ( UArray start (offsetAsSize k `sizeSub` offsetAsSize start) backend-                   , UArray k     (len `sizeSub` (offsetAsSize k `sizeSub` offsetAsSize start)) backend)+    | k == sentinel = (arr, empty)+    | k == start    = (empty, arr)+    | otherwise     = (UArray start (offsetAsSize l1)       backend+                     , UArray k     (sizeAsOffset len - l1) backend)   where-    !end = start `offsetPlusE` len     !k = onBackendPure' arr $ Alg.findIndexElem ty+    l1 = k `offsetSub` start {-# NOINLINE [3] breakElem #-} {-# RULES "breakElem Word8" [4] breakElem = breakElemByte #-} {-# SPECIALIZE [3] breakElem :: Word32 -> UArray Word32 -> (UArray Word32, UArray Word32) #-}@@ -440,11 +436,11 @@     carriageReturn = 0xd     goBa (Block ba) =         let k = sysHsMemFindByteBa ba start end lineFeed-            cr = k > start && PrimBA.primIndex ba (k `offsetSub` 1) == carriageReturn+            cr = k > start && primBaIndex ba (k `offsetSub` 1) == carriageReturn          in (if cr then k `offsetSub` 1 else k, k)     goAddr (Ptr addr) =         let k = sysHsMemFindByteAddr addr start end lineFeed-            cr = k > start && PrimAddr.primIndex addr (k `offsetSub` 1) == carriageReturn+            cr = k > start && primAddrIndex addr (k `offsetSub` 1) == carriageReturn          in (if cr then k `offsetSub` 1 else k, k)  -- inverse a CountOf that is specified from the end (e.g. take n elements from the end)@@ -496,35 +492,26 @@  findIndex :: PrimType ty => ty -> UArray ty -> Maybe (Offset ty) findIndex ty arr--- TODO: check for end could be done in algorithm-    | k == end  = Nothing-    | otherwise = Just (k `offsetSub` start)+    | k == sentinel  = Nothing+    | otherwise      = Just (k `offsetSub` offset arr)   where     !k = onBackendPure' arr $ Alg.findIndexElem ty-    !start = offset arr-    !end = start `offsetPlusE` length arr {-# SPECIALIZE [3] findIndex :: Word8 -> UArray Word8 -> Maybe (Offset Word8) #-}  revFindIndex :: PrimType ty => ty -> UArray ty -> Maybe (Offset ty) revFindIndex ty arr--- TODO: check for end could be done in algorithm-    | k == end  = Nothing-    | otherwise = Just (k `offsetSub` start)+    | k == sentinel = Nothing+    | otherwise     = Just (k `offsetSub` offset arr)   where     !k = onBackendPure' arr $ Alg.revFindIndexElem ty-    !start = offset arr-    !end = start `offsetPlusE` length arr {-# SPECIALIZE [3] revFindIndex :: Word8 -> UArray Word8 -> Maybe (Offset Word8) #-}  break :: forall ty . PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty) break predicate arr--- TODO2: check for end could be done in algorithm? but maybe more ops are involved-    | k == end  = (arr, mempty)-    | otherwise = splitAt (offsetAsSize (k `offsetSub` start)) arr+    | k == sentinel = (arr, mempty)+    | otherwise     = splitAt (k - offset arr) arr   where     !k = onBackendPure' arr $ Alg.findIndexPredicate predicate-    !start = offset arr-    !end = start `offsetPlusE` length arr  {- {-# SPECIALIZE [3] findIndex :: Word8 -> UArray Word8 -> Maybe (Offset Word8) #-}@@ -557,22 +544,14 @@ -- ([1,2,3], [0,0,0]) breakEnd :: forall ty . PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty) breakEnd predicate arr--- TODO2: check for end could be done in algorithm? but maybe more ops are involved-    | k == end  = (arr, mempty)-    | otherwise = splitAt (offsetAsSize (k+1) `sizeSub` offsetAsSize start) arr+    | k == sentinel = (arr, mempty)+    | otherwise     = splitAt ((k+1) - offset arr) arr   where     !k = onBackendPure' arr $ Alg.revFindIndexPredicate predicate-    !start = offset arr-    !end   = start `offsetPlusE` length arr {-# SPECIALIZE [3] breakEnd :: (Word8 -> Bool) -> UArray Word8 -> (UArray Word8, UArray Word8) #-}  elem :: PrimType ty => ty -> UArray ty -> Bool---elem !ty arr = onBackendPure goBa goAddr arr /= end--- check for end could be done in algorithm? isNothing?-elem !ty arr = onBackendPure' arr (Alg.findIndexElem ty) /= end-  where-    !start = offset arr-    !end = start `offsetPlusE` length arr+elem !ty arr = onBackendPure' arr (Alg.findIndexElem ty) /= sentinel {-# SPECIALIZE [2] elem :: Word8 -> UArray Word8 -> Bool #-}  intersperse :: forall ty . PrimType ty => ty -> UArray ty -> UArray ty

@@ -90,6 +90,9 @@ instance PrimType ty => Alg.Indexable (Ptr ty) ty where     index (Ptr addr) = primAddrIndex addr +instance Alg.Indexable (Ptr Word8) Word64 where+    index (Ptr addr) = primAddrIndex addr+ instance (PrimMonad prim, PrimType ty) => Alg.RandomAccess (Ptr ty) prim ty where     read (Ptr addr) = primAddrRead addr     write (Ptr addr) = primAddrWrite addr@@ -292,16 +295,15 @@ onBackendPure goBA goAddr arr = onBackend goBA (\_ -> pureST . goAddr) arr {-# INLINE onBackendPure #-} -onBackendPure' :: PrimType  ty+onBackendPure' :: forall ty a . PrimType  ty                => UArray ty                -> (forall container. Alg.Indexable container ty                     => container -> Offset ty -> Offset ty -> a)                -> a-onBackendPure' arr f = onBackendPure (\c -> f c start end) -                                     (\c -> f c start end) arr-  where !len = length arr-        !start = offset arr-        !end = start `offsetPlusE` len+onBackendPure' arr f = onBackendPure f' f' arr+  where f' :: Alg.Indexable container ty => container -> a+        f' c = f c start end+          where (ValidRange !start !end) = offsetsValidRange arr {-# INLINE onBackendPure' #-}  onBackendPrim :: PrimMonad prim@@ -323,12 +325,12 @@ {-# INLINE onMutableBackend #-}  -unsafeDewrap :: (ByteArray# -> Offset ty -> a)+unsafeDewrap :: (Block ty -> Offset ty -> a)              -> (Ptr ty -> Offset ty -> ST s a)              -> UArray ty              -> a unsafeDewrap _ g (UArray start _ (UArrayAddr fptr))     = withUnsafeFinalPtr fptr $ \ptr -> g ptr start-unsafeDewrap f _ (UArray start _ (UArrayBA (Block ba))) = f ba start+unsafeDewrap f _ (UArray start _ (UArrayBA ba)) = f ba start {-# INLINE unsafeDewrap #-}  unsafeDewrap2 :: (ByteArray# -> ByteArray# -> a)@@ -392,7 +394,7 @@     | otherwise = unsafeDewrap goBa goPtr a   where     !len = length a-    goBa ba start = loop start+    goBa (Block ba) start = loop start       where         !end = start `offsetPlusE` len         loop !i | i == end  = []

@@ -30,8 +30,7 @@ import           Basement.FinalPtr import           Basement.UTF8.Helper import           Basement.UTF8.Types-import qualified Basement.Alg.Native.UTF8      as PrimBA-import qualified Basement.Alg.Foreign.UTF8     as PrimAddr+import qualified Basement.Alg.UTF8         as UTF8 import           Basement.UArray           (UArray) import           Basement.Block            (MutableBlock) import qualified Basement.Block.Mutable    as BLK@@ -90,31 +89,31 @@ sToList (String arr) = Vec.onBackend onBA onAddr arr   where     (Vec.ValidRange !start !end) = Vec.offsetsValidRange arr-    onBA (BLK.Block ba) = loop start+    onBA ba@(BLK.Block _) = loop start       where         loop !idx             | idx == end = []-            | otherwise  = let !(Step c idx') = PrimBA.next ba idx in c : loop idx'-    onAddr fptr (Ptr ptr) = pureST (loop start)+            | otherwise  = let !(Step c idx') = UTF8.next ba idx in c : loop idx'+    onAddr fptr ptr@(Ptr _) = pureST (loop start)       where         loop !idx             | idx == end = []-            | otherwise  = let !(Step c idx') = PrimAddr.next ptr idx in c : loop idx'+            | otherwise  = let !(Step c idx') = UTF8.next ptr idx in c : loop idx' {-# NOINLINE sToList #-}  sToListStream (String arr) k z = Vec.onBackend onBA onAddr arr   where     (Vec.ValidRange !start !end) = Vec.offsetsValidRange arr-    onBA (BLK.Block ba) = loop start+    onBA ba@(BLK.Block _) = loop start       where         loop !idx             | idx == end = z-            | otherwise  = let !(Step c idx') = PrimBA.next ba idx in c `k` loop idx'-    onAddr fptr (Ptr ptr) = pureST (loop start)+            | otherwise  = let !(Step c idx') = UTF8.next ba idx in c `k` loop idx'+    onAddr fptr ptr@(Ptr _) = pureST (loop start)       where         loop !idx             | idx == end = z-            | otherwise  = let !(Step c idx') = PrimAddr.next ptr idx in c `k` loop idx'+            | otherwise  = let !(Step c idx') = UTF8.next ptr idx in c `k` loop idx'  {-# RULES "String sToList" [~1] forall s . sToList s = build (\ k z -> sToListStream s k z) #-} {-# RULES "String toList" [~1] forall s . toList s = build (\ k z -> sToListStream s k z) #-}@@ -178,16 +177,16 @@   where     !start = Vec.offset array     reoffset (Step a ofs) = Step a (ofs `offsetSub` start)-    nextBA (BLK.Block ba) = reoffset (PrimBA.next ba (start + n))-    nextAddr _ (Ptr ptr)  = pureST $ reoffset (PrimAddr.next ptr (start + n))+    nextBA ba@(BLK.Block _) = reoffset (UTF8.next ba (start + n))+    nextAddr _ ptr@(Ptr _)  = pureST $ reoffset (UTF8.next ptr (start + n))  prev :: String -> Offset8 -> StepBack prev (String array) !n = Vec.onBackend prevBA prevAddr array   where     !start = Vec.offset array     reoffset (StepBack a ofs) = StepBack a (ofs `offsetSub` start)-    prevBA (BLK.Block ba) = reoffset (PrimBA.prev ba (start + n))-    prevAddr _ (Ptr ptr)  = pureST $ reoffset (PrimAddr.prev ptr (start + n))+    prevBA ba@(BLK.Block _) = reoffset (UTF8.prev ba (start + n))+    prevAddr _ ptr@(Ptr _)  = pureST $ reoffset (UTF8.prev ptr (start + n))  -- A variant of 'next' when you want the next character -- to be ASCII only.@@ -202,8 +201,8 @@  write :: PrimMonad prim => MutableString (PrimState prim) -> Offset8 -> Char -> prim Offset8 write (MutableString marray) ofs c =-    MVec.onMutableBackend (\(BLK.MutableBlock mba) -> PrimBA.write mba (start + ofs) c)-                          (\fptr -> withFinalPtr fptr $ \(Ptr ptr) -> PrimAddr.write ptr (start + ofs) c)+    MVec.onMutableBackend (\mba@(BLK.MutableBlock _) -> UTF8.writeUTF8 mba (start + ofs) c)+                          (\fptr -> withFinalPtr fptr $ \ptr@(Ptr _) -> UTF8.writeUTF8 ptr (start + ofs) c)                           marray   where start = MVec.mutableOffset marray 

@@ -1,5 +1,5 @@ name:                basement-version:             0.0.6+version:             0.0.7 synopsis:            Foundation scrap box of array & string description:         Foundation most basic primitives without any dependencies homepage:            https://github.com/haskell-foundation/foundation#readme@@ -23,7 +23,7 @@  library   hs-source-dirs:    .-  exposed-modules:   +  exposed-modules:                      Basement.Imports                       Basement.Base16@@ -58,7 +58,7 @@                      Basement.String                      Basement.String.Builder                      Basement.NonEmpty-                     +                      -- Utils                      Basement.NormalForm                      Basement.These@@ -100,6 +100,7 @@                    , Basement.Sized.Block                    , Basement.Sized.UVect                    , Basement.Sized.Vect+                   , Basement.Bits   if impl(ghc >= 7.10)     exposed-modules:                      Basement.Sized.List@@ -113,13 +114,8 @@                      Basement.Alg.Mutable                      Basement.Alg.PrimArray -                     Basement.Alg.Native.Prim-                     Basement.Alg.Native.UTF8-                     Basement.Alg.Native.String--                     Basement.Alg.Foreign.Prim-                     Basement.Alg.Foreign.UTF8-                     Basement.Alg.Foreign.String+                     Basement.Alg.UTF8+                     Basement.Alg.String                       Basement.Numerical.Conversion