basement 0.0.0 → 0.0.1

raw patch · 41 files changed

+2544/−1244 lines, 41 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Basement/Alg/Foreign/Prim.hs +35/−0
• Basement/Alg/Foreign/PrimArray.hs +179/−0
• Basement/Alg/Foreign/String.hs +121/−0
• Basement/Alg/Foreign/UTF8.hs +247/−0
• Basement/Alg/Native/Prim.hs +35/−0
• Basement/Alg/Native/PrimArray.hs +179/−0
• Basement/Alg/Native/String.hs +121/−0
• Basement/Alg/Native/UTF8.hs +247/−0
• Basement/Block.hs +20/−35
• Basement/Block/Mutable.hs +19/−1
• Basement/BlockN.hs +39/−19
• Basement/Bounded.hs +3/−1
• Basement/BoxedArray.hs +50/−1
• Basement/Compat/Natural.hs +6/−2
• Basement/Error.hs +3/−0
• Basement/From.hs +234/−5
• Basement/IntegralConv.hs +11/−103
• Basement/Nat.hs +18/−0
• Basement/NormalForm.hs +6/−1
• Basement/Numerical/Additive.hs +12/−0
• Basement/Numerical/Conversion.hs +96/−0
• Basement/Numerical/Multiplicative.hs +16/−0
• Basement/Numerical/Number.hs +1/−0
• Basement/Numerical/Subtractive.hs +10/−0
• Basement/PrimType.hs +86/−0
• Basement/String.hs +27/−5
• Basement/String/Addr.hs +0/−86
• Basement/String/BA.hs +0/−86
• Basement/Types/OffsetSize.hs +0/−6
• Basement/Types/Word128.hs +242/−0
• Basement/Types/Word256.hs +317/−0
• Basement/UArray.hs +70/−72
• Basement/UArray/Addr.hs +0/−114
• Basement/UArray/BA.hs +0/−113
• Basement/UArray/Base.hs +67/−9
• Basement/UArray/Mutable.hs +4/−8
• Basement/UTF8/Addr.hs +0/−245
• Basement/UTF8/BA.hs +0/−245
• Basement/UTF8/Base.hs +9/−7
• Basement/Utils.hs +0/−72
• basement.cabal +14/−8

@@ -0,0 +1,35 @@+{-# 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 #-}

@@ -0,0 +1,179 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE CPP                        #-}+module Basement.Alg.Foreign.PrimArray+    ( findIndexElem+    , revFindIndexElem+    , findIndexPredicate+    , revFindIndexPredicate+    , foldl+    , foldr+    , foldl1+    , all+    , any+    , filter+    , primIndex+    , inplaceSortBy+    ) where++import           GHC.Types+import           GHC.Prim+import           Basement.Compat.Base+import           Basement.Numerical.Additive+import           Basement.Numerical.Multiplicative+import           Basement.Types.OffsetSize+import           Basement.PrimType+import           Basement.Monad++import           Basement.Alg.Foreign.Prim++findIndexElem :: PrimType ty => ty -> Immutable -> Offset ty -> Offset ty -> Offset ty+findIndexElem ty ba startIndex endIndex = loop startIndex+  where+    loop !i+        | i < endIndex && t /= ty = loop (i+1)+        | otherwise               = i+      where t = primIndex ba i+{-# INLINE findIndexElem #-}++revFindIndexElem :: PrimType ty => ty -> Immutable -> Offset ty -> Offset ty -> Offset ty+revFindIndexElem ty ba startIndex endIndex+    | endIndex > startIndex = loop (endIndex `offsetMinusE` 1)+    | otherwise             = endIndex+  where+    loop !i+        | t == ty        = i+        | i > startIndex = loop (i `offsetMinusE` 1)+        | otherwise      = endIndex+      where t = primIndex ba i+{-# INLINE revFindIndexElem #-}++findIndexPredicate :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Offset ty+findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex+  where+    loop !i+        | i < endIndex && not found = loop (i+1)+        | otherwise                 = i+      where found = predicate (primIndex ba i)+{-# INLINE findIndexPredicate #-}++revFindIndexPredicate :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Offset ty+revFindIndexPredicate predicate ba startIndex endIndex+    | endIndex > startIndex = loop (endIndex `offsetMinusE` 1)+    | otherwise             = endIndex+  where+    loop !i+        | found          = i+        | i > startIndex = loop (i `offsetMinusE` 1)+        | otherwise      = endIndex+      where found = predicate (primIndex ba i)+{-# INLINE revFindIndexPredicate #-}++foldl :: PrimType ty => (a -> ty -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a+foldl f !initialAcc ba !startIndex !endIndex = loop startIndex initialAcc+  where+    loop !i !acc+        | i == endIndex = acc+        | otherwise     = loop (i+1) (f acc (primIndex ba i))+{-# INLINE foldl #-}++foldr :: PrimType ty => (ty -> a -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a+foldr f !initialAcc ba startIndex endIndex = loop startIndex+  where+    loop !i+        | i == endIndex = initialAcc+        | otherwise     = primIndex ba i `f` loop (i+1)+{-# INLINE foldr #-}++foldl1 :: PrimType ty => (ty -> ty -> ty) -> Immutable -> Offset ty -> Offset ty -> ty+foldl1 f ba startIndex endIndex = loop (startIndex+1) (primIndex ba startIndex)+  where+    loop !i !acc+        | i == endIndex = acc+        | otherwise     = loop (i+1) (f acc (primIndex ba i))+{-# INLINE foldl1 #-}++filter :: (PrimMonad prim, PrimType ty)+       => (ty -> Bool) -> MutableByteArray# (PrimState prim) -> Immutable -> Offset ty -> Offset ty -> prim (CountOf ty)+filter predicate dst src start end = loop azero start+  where+    loop !d !s+        | s == end    = pure (offsetAsSize d)+        | predicate v = primMbaWrite dst d v >> loop (d+Offset 1) (s+Offset 1)+        | otherwise   = loop d (s+Offset 1)+      where+        v = primIndex src s++all :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool+all predicate ba start end = loop start+  where+    loop !i+        | i == end                   = True+        | predicate (primIndex ba i) = loop (i+1)+        | otherwise                  = False+{-# INLINE all #-}++any :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool+any predicate ba start end = loop start+  where+    loop !i+        | i == end                   = False+        | predicate (primIndex ba i) = True+        | otherwise                  = loop (i+1)+{-# INLINE any #-}++inplaceSortBy :: (PrimType ty, PrimMonad prim)+              => (ty -> ty -> Ordering)+              -> Mutable (PrimState prim)+              -> Offset ty+              -> Offset ty+              -> prim ()+inplaceSortBy ford ma start end = qsort start (end `offsetSub` 1)+  where+    qsort lo hi+        | lo >= hi  = pure ()+        | otherwise = do+            p <- partition lo hi+            qsort lo (pred p)+            qsort (p+1) hi+    pivotStrategy (Offset low) hi@(Offset high) = do+        let mid = Offset $ (low + high) `div` 2+        pivot <- primRead ma mid+        primRead ma hi >>= primWrite ma mid+        primWrite ma hi pivot -- move pivot @ pivotpos := hi+        pure pivot+    partition lo hi = do+        pivot <- pivotStrategy lo hi+        -- RETURN: index of pivot with [<pivot | pivot | >=pivot]+        -- INVARIANT: i & j are valid array indices; pivotpos==hi+        let go i j = do+                -- INVARIANT: k <= pivotpos+                let fw k = do ak <- primRead ma k+                              if ford ak pivot == LT+                                then fw (k+1)+                                else pure (k, ak)+                (i, ai) <- fw i -- POST: ai >= pivot+                -- INVARIANT: k >= i+                let bw k | k==i = pure (i, ai)+                         | otherwise = do ak <- primRead ma k+                                          if ford ak pivot /= LT+                                            then bw (pred k)+                                            else pure (k, ak)+                (j, aj) <- bw j -- POST: i==j OR (aj<pivot AND j<pivotpos)+                -- POST: ai>=pivot AND (i==j OR aj<pivot AND (j<pivotpos))+                if i < j+                    then do -- (ai>=p AND aj<p) AND (i<j<pivotpos)+                        -- swap two non-pivot elements and proceed+                        primWrite ma i aj+                        primWrite ma j ai+                        -- POST: (ai < pivot <= aj)+                        go (i+1) (pred j)+                    else do -- ai >= pivot+                        -- complete partitioning by swapping pivot to the center+                        primWrite ma hi ai+                        primWrite ma i pivot+                        pure i+        go lo hi+{-# INLINE inplaceSortBy #-}

@@ -0,0 +1,121 @@+{-# 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 = loop ofsStart+  where+    loop !ofs+        | ofs > end  = error ("validate: internal error: went pass offset : ofs=" <> show ofs <> " end=" <> show end)+        | ofs == end = (end, Nothing)+        | otherwise  =+            let !h = PrimBackend.primIndex ba ofs in+            case headerIsAscii h of+                True  -> loop (ofs + Offset 1)+                False ->+                    case one (CountOf $ getNbBytes h) ofs of+                        (nextOfs, Nothing)  -> loop nextOfs+                        (pos, Just failure) -> (pos, Just failure)++    one (CountOf 0xff) pos = (pos, Just InvalidHeader)+    one nbConts pos+        | ((pos+Offset 1) `offsetPlusE` nbConts) > end = (pos, Just MissingByte)+        | otherwise =+            case nbConts of+                CountOf 1 ->+                    let c1 = PrimBackend.primIndex ba (pos + Offset 1)+                    in if isContinuation c1+                        then (pos + Offset 2, Nothing)+                        else (pos, Just InvalidContinuation)+                CountOf 2 ->+                    let c1 = PrimBackend.primIndex ba (pos + Offset 1)+                        c2 = PrimBackend.primIndex ba (pos + Offset 2)+                     in if isContinuation c1 && isContinuation c2+                            then (pos + Offset 3, Nothing)+                            else (pos, Just InvalidContinuation)+                CountOf 3 ->+                    let c1 = PrimBackend.primIndex ba (pos + Offset 1)+                        c2 = PrimBackend.primIndex ba (pos + Offset 2)+                        c3 = PrimBackend.primIndex ba (pos + Offset 3)+                     in if isContinuation c1 && isContinuation c2 && isContinuation c3+                            then (pos + Offset 4, Nothing)+                            else (pos, Just InvalidContinuation)+                CountOf _ -> error "internal error"++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 #-}

@@ -0,0 +1,247 @@+{-# 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+    -- 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           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 #-}

@@ -0,0 +1,35 @@+{-# 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 #-}

@@ -0,0 +1,179 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE CPP                        #-}+module Basement.Alg.Native.PrimArray+    ( findIndexElem+    , revFindIndexElem+    , findIndexPredicate+    , revFindIndexPredicate+    , foldl+    , foldr+    , foldl1+    , all+    , any+    , filter+    , primIndex+    , inplaceSortBy+    ) where++import           GHC.Types+import           GHC.Prim+import           Basement.Compat.Base+import           Basement.Numerical.Additive+import           Basement.Numerical.Multiplicative+import           Basement.Types.OffsetSize+import           Basement.PrimType+import           Basement.Monad++import           Basement.Alg.Native.Prim++findIndexElem :: PrimType ty => ty -> Immutable -> Offset ty -> Offset ty -> Offset ty+findIndexElem ty ba startIndex endIndex = loop startIndex+  where+    loop !i+        | i < endIndex && t /= ty = loop (i+1)+        | otherwise               = i+      where t = primIndex ba i+{-# INLINE findIndexElem #-}++revFindIndexElem :: PrimType ty => ty -> Immutable -> Offset ty -> Offset ty -> Offset ty+revFindIndexElem ty ba startIndex endIndex+    | endIndex > startIndex = loop (endIndex `offsetMinusE` 1)+    | otherwise             = endIndex+  where+    loop !i+        | t == ty        = i+        | i > startIndex = loop (i `offsetMinusE` 1)+        | otherwise      = endIndex+      where t = primIndex ba i+{-# INLINE revFindIndexElem #-}++findIndexPredicate :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Offset ty+findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex+  where+    loop !i+        | i < endIndex && not found = loop (i+1)+        | otherwise                 = i+      where found = predicate (primIndex ba i)+{-# INLINE findIndexPredicate #-}++revFindIndexPredicate :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Offset ty+revFindIndexPredicate predicate ba startIndex endIndex+    | endIndex > startIndex = loop (endIndex `offsetMinusE` 1)+    | otherwise             = endIndex+  where+    loop !i+        | found          = i+        | i > startIndex = loop (i `offsetMinusE` 1)+        | otherwise      = endIndex+      where found = predicate (primIndex ba i)+{-# INLINE revFindIndexPredicate #-}++foldl :: PrimType ty => (a -> ty -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a+foldl f !initialAcc ba !startIndex !endIndex = loop startIndex initialAcc+  where+    loop !i !acc+        | i == endIndex = acc+        | otherwise     = loop (i+1) (f acc (primIndex ba i))+{-# INLINE foldl #-}++foldr :: PrimType ty => (ty -> a -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a+foldr f !initialAcc ba startIndex endIndex = loop startIndex+  where+    loop !i+        | i == endIndex = initialAcc+        | otherwise     = primIndex ba i `f` loop (i+1)+{-# INLINE foldr #-}++foldl1 :: PrimType ty => (ty -> ty -> ty) -> Immutable -> Offset ty -> Offset ty -> ty+foldl1 f ba startIndex endIndex = loop (startIndex+1) (primIndex ba startIndex)+  where+    loop !i !acc+        | i == endIndex = acc+        | otherwise     = loop (i+1) (f acc (primIndex ba i))+{-# INLINE foldl1 #-}++filter :: (PrimMonad prim, PrimType ty)+       => (ty -> Bool) -> MutableByteArray# (PrimState prim) -> Immutable -> Offset ty -> Offset ty -> prim (CountOf ty)+filter predicate dst src start end = loop azero start+  where+    loop !d !s+        | s == end    = pure (offsetAsSize d)+        | predicate v = primMbaWrite dst d v >> loop (d+Offset 1) (s+Offset 1)+        | otherwise   = loop d (s+Offset 1)+      where+        v = primIndex src s++all :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool+all predicate ba start end = loop start+  where+    loop !i+        | i == end                   = True+        | predicate (primIndex ba i) = loop (i+1)+        | otherwise                  = False+{-# INLINE all #-}++any :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool+any predicate ba start end = loop start+  where+    loop !i+        | i == end                   = False+        | predicate (primIndex ba i) = True+        | otherwise                  = loop (i+1)+{-# INLINE any #-}++inplaceSortBy :: (PrimType ty, PrimMonad prim)+              => (ty -> ty -> Ordering)+              -> Mutable (PrimState prim)+              -> Offset ty+              -> Offset ty+              -> prim ()+inplaceSortBy ford ma start end = qsort start (end `offsetSub` 1)+  where+    qsort lo hi+        | lo >= hi  = pure ()+        | otherwise = do+            p <- partition lo hi+            qsort lo (pred p)+            qsort (p+1) hi+    pivotStrategy (Offset low) hi@(Offset high) = do+        let mid = Offset $ (low + high) `div` 2+        pivot <- primRead ma mid+        primRead ma hi >>= primWrite ma mid+        primWrite ma hi pivot -- move pivot @ pivotpos := hi+        pure pivot+    partition lo hi = do+        pivot <- pivotStrategy lo hi+        -- RETURN: index of pivot with [<pivot | pivot | >=pivot]+        -- INVARIANT: i & j are valid array indices; pivotpos==hi+        let go i j = do+                -- INVARIANT: k <= pivotpos+                let fw k = do ak <- primRead ma k+                              if ford ak pivot == LT+                                then fw (k+1)+                                else pure (k, ak)+                (i, ai) <- fw i -- POST: ai >= pivot+                -- INVARIANT: k >= i+                let bw k | k==i = pure (i, ai)+                         | otherwise = do ak <- primRead ma k+                                          if ford ak pivot /= LT+                                            then bw (pred k)+                                            else pure (k, ak)+                (j, aj) <- bw j -- POST: i==j OR (aj<pivot AND j<pivotpos)+                -- POST: ai>=pivot AND (i==j OR aj<pivot AND (j<pivotpos))+                if i < j+                    then do -- (ai>=p AND aj<p) AND (i<j<pivotpos)+                        -- swap two non-pivot elements and proceed+                        primWrite ma i aj+                        primWrite ma j ai+                        -- POST: (ai < pivot <= aj)+                        go (i+1) (pred j)+                    else do -- ai >= pivot+                        -- complete partitioning by swapping pivot to the center+                        primWrite ma hi ai+                        primWrite ma i pivot+                        pure i+        go lo hi+{-# INLINE inplaceSortBy #-}

@@ -0,0 +1,121 @@+{-# 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 = loop ofsStart+  where+    loop !ofs+        | ofs > end  = error ("validate: internal error: went pass offset : ofs=" <> show ofs <> " end=" <> show end)+        | ofs == end = (end, Nothing)+        | otherwise  =+            let !h = PrimBackend.primIndex ba ofs in+            case headerIsAscii h of+                True  -> loop (ofs + Offset 1)+                False ->+                    case one (CountOf $ getNbBytes h) ofs of+                        (nextOfs, Nothing)  -> loop nextOfs+                        (pos, Just failure) -> (pos, Just failure)++    one (CountOf 0xff) pos = (pos, Just InvalidHeader)+    one nbConts pos+        | ((pos+Offset 1) `offsetPlusE` nbConts) > end = (pos, Just MissingByte)+        | otherwise =+            case nbConts of+                CountOf 1 ->+                    let c1 = PrimBackend.primIndex ba (pos + Offset 1)+                    in if isContinuation c1+                        then (pos + Offset 2, Nothing)+                        else (pos, Just InvalidContinuation)+                CountOf 2 ->+                    let c1 = PrimBackend.primIndex ba (pos + Offset 1)+                        c2 = PrimBackend.primIndex ba (pos + Offset 2)+                     in if isContinuation c1 && isContinuation c2+                            then (pos + Offset 3, Nothing)+                            else (pos, Just InvalidContinuation)+                CountOf 3 ->+                    let c1 = PrimBackend.primIndex ba (pos + Offset 1)+                        c2 = PrimBackend.primIndex ba (pos + Offset 2)+                        c3 = PrimBackend.primIndex ba (pos + Offset 3)+                     in if isContinuation c1 && isContinuation c2 && isContinuation c3+                            then (pos + Offset 4, Nothing)+                            else (pos, Just InvalidContinuation)+                CountOf _ -> error "internal error"++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 #-}

@@ -0,0 +1,247 @@+{-# 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+    -- 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           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 #-}

@@ -47,6 +47,7 @@     , revSplitAt     , splitOn     , break+    , breakEnd     , span     , elem     , all@@ -77,6 +78,7 @@ import           Basement.Block.Base import           Basement.Numerical.Additive import           Basement.Numerical.Subtractive+import qualified Basement.Alg.Native.PrimArray as Alg  -- | Copy all the block content to the memory starting at the destination address unsafeCopyToPtr :: forall ty prim . PrimMonad prim@@ -258,6 +260,16 @@     {-# INLINE findBreak #-} {-# SPECIALIZE [2] break :: (Word8 -> Bool) -> Block Word8 -> (Block Word8, Block Word8) #-} +breakEnd :: PrimType ty => (ty -> Bool) -> Block ty -> (Block ty, Block ty)+breakEnd predicate blk@(Block ba)+    | k == end  = (blk, mempty)+    | otherwise = splitAt (offsetAsSize (k+1)) blk+  where+    k = Alg.revFindIndexPredicate predicate ba 0 end+    end = 0 `offsetPlusE` len+    !len = length blk+{-# SPECIALIZE [2] breakEnd :: (Word8 -> Bool) -> Block Word8 -> (Block Word8, Block Word8) #-}+ span :: PrimType ty => (ty -> Bool) -> Block ty -> (Block ty, Block ty) span p = break (not . p) @@ -338,42 +350,15 @@             | otherwise  = unsafeWrite mb o' (unsafeIndex blk i) >> loop o' (i+1)           where o' = pred o -sortBy :: forall ty . PrimType ty => (ty -> ty -> Ordering) -> Block ty -> Block ty-sortBy xford vec+sortBy :: PrimType ty => (ty -> ty -> Ordering) -> Block ty -> Block ty+sortBy ford vec     | len == 0  = mempty-    | otherwise = runST (thaw vec >>= doSort xford)-  where-    len = length vec-    doSort :: (PrimType ty, PrimMonad prim) => (ty -> ty -> Ordering) -> MutableBlock ty (PrimState prim) -> prim (Block ty)-    doSort ford ma = qsort 0 (sizeLastOffset len) >> unsafeFreeze ma-      where-        qsort lo hi-            | lo >= hi  = pure ()-            | otherwise = do-                p <- partition lo hi-                qsort lo (pred p)-                qsort (p+1) hi-        partition lo hi = do-            pivot <- unsafeRead ma hi-            let loop i j-                    | j == hi   = pure i-                    | otherwise = do-                        aj <- unsafeRead ma j-                        i' <- if ford aj pivot == GT-                                then pure i-                                else do-                                    ai <- unsafeRead ma i-                                    unsafeWrite ma j ai-                                    unsafeWrite ma i aj-                                    pure $ i + 1-                        loop i' (j+1)--            i <- loop lo lo-            ai  <- unsafeRead ma i-            ahi <- unsafeRead ma hi-            unsafeWrite ma hi ai-            unsafeWrite ma i ahi-            pure i+    | otherwise = runST $ do+        mblock@(MutableBlock mba) <- thaw vec+        Alg.inplaceSortBy ford mba 0 (sizeAsOffset len)+        unsafeFreeze mblock+  where len = length vec+{-# SPECIALIZE [2] sortBy :: (Word8 -> Word8 -> Ordering) -> Block Word8 -> Block Word8 #-}  intersperse :: forall ty . PrimType ty => ty -> Block ty -> Block ty intersperse sep blk = case len - 1 of

@@ -16,7 +16,8 @@ -- of unboxed array that will benefit from optimisation. -- -- Because it's unpinned, the blocks are compactable / movable,--- at the expense of making them less friendly to C layer / address.+-- at the expense of making them less friendly to interop with the C layer+-- as address. -- -- Note that sadly the bytearray primitive type automatically create -- a pinned bytearray if the size is bigger than a certain threshold@@ -39,6 +40,8 @@     , mutableLengthSize     , mutableLengthBytes     , mutableGetAddr+    , mutableWithAddr+    , mutableTouch     , new     , newPinned     , mutableEmpty@@ -84,10 +87,25 @@ -- | Get the address of the context of the mutable block. -- -- if the block is not pinned, this is a _dangerous_ operation+--+-- Note that if nothing is holding the block, the GC can garbage collect the block+-- and thus the address is dangling on the memory. use 'mutableWithAddr' to prevent+-- this problem by construction mutableGetAddr :: PrimMonad prim => MutableBlock ty (PrimState prim) -> prim (Ptr ty) mutableGetAddr (MutableBlock mba) = primitive $ \s1 ->     case unsafeFreezeByteArray# mba s1 of         (# s2, ba #) -> (# s2, Ptr (byteArrayContents# ba) #)++-- | Get the address of the mutable block in a safer construct+--+-- if the block is not pinned, this is a _dangerous_ operation+mutableWithAddr :: PrimMonad prim+                => MutableBlock ty (PrimState prim)+                -> (Ptr ty -> prim a)+                -> prim a+mutableWithAddr mb f = do+    addr <- mutableGetAddr mb+    f addr <* mutableTouch mb  -- | Set all mutable block element to a value iterSet :: (PrimType ty, PrimMonad prim)

@@ -4,12 +4,13 @@ -- Maintainer  : Haskell Foundation -- -- A Nat-sized version of Block-{-# LANGUAGE AllowAmbiguousTypes       #-}-{-# LANGUAGE DataKinds                 #-}-{-# LANGUAGE TypeOperators             #-}-{-# LANGUAGE TypeApplications          #-}-{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE AllowAmbiguousTypes        #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE TypeApplications           #-}+{-# LANGUAGE ScopedTypeVariables        #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ConstraintKinds            #-}  module Basement.BlockN     ( BlockN@@ -48,13 +49,13 @@ import           Basement.Nat import           Basement.NormalForm import           Basement.PrimType (PrimType)-import           Basement.Types.OffsetSize (CountOf(..), Offset(..))+import           Basement.Types.OffsetSize (CountOf(..), Offset(..), offsetSub)  newtype BlockN (n :: Nat) a = BlockN { unBlock :: Block a } deriving (NormalForm, Eq, Show)  newtype MutableBlockN (n :: Nat) ty st = MutableBlockN { unMBlock :: MutableBlock ty st } -toBlockN :: forall n ty . (PrimType ty, KnownNat n, NatWithinBound Int n) => Block ty -> Maybe (BlockN n ty)+toBlockN :: forall n ty . (PrimType ty, KnownNat n, Countable ty n) => Block ty -> Maybe (BlockN n ty) toBlockN b     | expected == B.length b = Just (BlockN b)     | otherwise = Nothing@@ -67,16 +68,16 @@ singleton :: PrimType ty => ty -> BlockN 1 ty singleton a = BlockN (B.singleton a) -replicate :: forall n ty . (KnownNat n, NatWithinBound Int n, PrimType ty) => ty -> BlockN n ty+replicate :: forall n ty . (KnownNat n, Countable ty n, PrimType ty) => ty -> BlockN n ty replicate a = BlockN (B.replicate (toCount @n) a)  thaw :: (KnownNat n, PrimMonad prim, PrimType ty) => BlockN n ty -> prim (MutableBlockN n ty (PrimState prim)) thaw b = MutableBlockN <$> B.thaw (unBlock b) -freeze ::  (PrimMonad prim, PrimType ty, NatWithinBound Int n) => MutableBlockN n ty (PrimState prim) -> prim (BlockN n ty)+freeze ::  (PrimMonad prim, PrimType ty, Countable ty n) => MutableBlockN n ty (PrimState prim) -> prim (BlockN n ty) freeze b = BlockN <$> B.freeze (unMBlock b) -index :: forall i n ty . (KnownNat i, CmpNat i n ~ 'LT, PrimType ty,  NatWithinBound Int i) => BlockN n ty -> ty+index :: forall i n ty . (KnownNat i, CmpNat i n ~ 'LT, PrimType ty, Offsetable ty i) => BlockN n ty -> ty index b = unsafeIndex (unBlock b) (toOffset @i)  map :: (PrimType a, PrimType b) => (a -> b) -> BlockN n a -> BlockN n b@@ -94,16 +95,32 @@ snoc :: PrimType ty => BlockN n ty -> ty -> BlockN (n+1) ty snoc b = BlockN . B.snoc (unBlock b) -sub :: forall i j n ty . ((i <=? n) ~ 'True, (j <=? n) ~ 'True, (i <=? j) ~ 'True, PrimType ty, KnownNat i, NatWithinBound Int i, KnownNat j, NatWithinBound Int j) => BlockN n ty -> BlockN (j-i) ty+sub :: forall i j n ty+     . ( (i <=? n) ~ 'True+       , (j <=? n) ~ 'True+       , (i <=? j) ~ 'True+       , PrimType ty+       , KnownNat i+       , KnownNat j+       , Offsetable ty i+       , Offsetable ty j )+    => BlockN n ty+    -> BlockN (j-i) ty sub block = BlockN (B.sub (unBlock block) (toOffset @i) (toOffset @j)) -uncons :: forall n ty . (CmpNat 0 n ~ 'LT, PrimType ty, KnownNat n, NatWithinBound Int n) => BlockN n ty -> (ty, BlockN (n-1) ty)+uncons :: forall n ty . (CmpNat 0 n ~ 'LT, PrimType ty, KnownNat n, Offsetable ty n)+       => BlockN n ty+       -> (ty, BlockN (n-1) ty) uncons b = (index @0 b, BlockN (B.sub (unBlock b) 1 (toOffset @n))) -unsnoc :: forall n ty . (CmpNat 0 n ~ 'LT, KnownNat n, PrimType ty, NatWithinBound Int n) => BlockN n ty -> (BlockN (n-1) ty, ty)-unsnoc b = (BlockN (B.sub (unBlock b) 0 (toOffset @n)), undefined)+unsnoc :: forall n ty . (CmpNat 0 n ~ 'LT, KnownNat n, PrimType ty, Offsetable ty n)+       => BlockN n ty+       -> (BlockN (n-1) ty, ty)+unsnoc b =+    ( BlockN (B.sub (unBlock b) 0 (toOffset @n `offsetSub` 1))+    , unsafeIndex (unBlock b) (toOffset @n `offsetSub` 1)) -splitAt :: forall i n ty . (CmpNat i n ~ 'LT, PrimType ty, KnownNat i, NatWithinBound Int i) => BlockN n ty -> (BlockN i ty, BlockN (n-i) ty)+splitAt :: forall i n ty . (CmpNat i n ~ 'LT, PrimType ty, KnownNat i, Countable ty i) => BlockN n ty -> (BlockN i ty, BlockN (n-i) ty) splitAt b =     let (left, right) = B.splitAt (toCount @i) (unBlock b)      in (BlockN left, BlockN right)@@ -129,8 +146,11 @@ intersperse :: (CmpNat n 1 ~ 'GT, PrimType ty) => ty -> BlockN n ty -> BlockN (n+n-1) ty intersperse sep b = BlockN (B.intersperse sep (unBlock b)) -toCount :: forall n ty . (KnownNat n, NatWithinBound Int n) => CountOf ty-toCount = CountOf (natValInt (Proxy @n))+toCount :: forall n ty . (KnownNat n, Countable ty n) => CountOf ty+toCount = natValCountOf (Proxy @n) -toOffset :: forall n ty . (KnownNat n, NatWithinBound Int n) => Offset ty-toOffset = Offset (natValInt (Proxy @n))+toOffset :: forall n ty . (KnownNat n, Offsetable ty n) => Offset ty+toOffset = natValOffset (Proxy @n)++type Countable ty n = NatWithinBound (CountOf ty) n+type Offsetable ty n = NatWithinBound (Offset ty) n

@@ -41,7 +41,9 @@ zn64 v = Zn64 (v `Prelude.mod` natValWord64 (Proxy :: Proxy n))  -- | Create an element of ℤ/nℤ from a type level Nat-zn64Nat :: forall m n . (KnownNat m, KnownNat n, NatWithinBound Word64 m, NatWithinBound Word64 n, CmpNat m n ~ 'LT) => Proxy m -> Zn64 n+zn64Nat :: forall m n . (KnownNat m, KnownNat n, NatWithinBound Word64 m, NatWithinBound Word64 n, CmpNat m n ~ 'LT)+        => Proxy m+        -> Zn64 n zn64Nat p = Zn64 (natValWord64 p)  -- | A type level bounded natural

@@ -43,7 +43,11 @@     , sub     , intersperse     , span+    , spanEnd     , break+    , breakEnd+    , mapFromUnboxed+    , mapToUnboxed     , cons     , snoc     , uncons@@ -70,16 +74,18 @@ import           GHC.Prim import           GHC.Types import           GHC.ST+import           Data.Proxy import           Basement.Numerical.Additive import           Basement.Numerical.Subtractive import           Basement.NonEmpty import           Basement.Compat.Base-import           Data.Proxy import           Basement.Compat.MonadTrans import           Basement.Types.OffsetSize import           Basement.PrimType import           Basement.NormalForm import           Basement.Monad+import           Basement.UArray.Base (UArray)+import qualified Basement.UArray.Base as UArray import           Basement.Exception import           Basement.MutableBuilder import qualified Basement.Compat.ExtList as List@@ -131,6 +137,7 @@ instance IsList (Array ty) where     type Item (Array ty) = ty     fromList = vFromList+    fromListN len = vFromListN (CountOf len)     toList = vToList  -- | return the numbers of elements in a mutable array@@ -349,6 +356,27 @@     loop _ []     ma = unsafeFreeze ma     loop i (x:xs) ma = unsafeWrite ma i x >> loop (i+1) xs ma +-- | just like vFromList but with a length hint.+--+-- The resulting array is guarantee to have been allocated to the length+-- specified, but the slice might point to the initialized cells only in+-- case the length is bigger than the list.+--+-- If the length is too small, then the list is truncated.+--+vFromListN :: forall a . CountOf a -> [a] -> Array a+vFromListN len l = runST $ do+    ma <- new len+    sz <- loop 0 l ma+    unsafeFreezeShrink ma sz+  where+    -- TODO rewrite without ma as parameter+    loop :: Offset a -> [a] -> MArray a s -> ST s (CountOf a)+    loop i []     _  = return (offsetAsSize i)+    loop i (x:xs) ma+        | i .==# len = return (offsetAsSize i)+        | otherwise  = unsafeWrite ma i x >> loop (i+1) xs ma+ vToList :: Array a -> [a] vToList v     | len == 0  = []@@ -481,6 +509,18 @@                 then splitAt (offsetAsSize i) v                 else findBreak (i+1) +breakEnd ::  (ty -> Bool) -> Array ty -> (Array ty, Array ty)+breakEnd predicate v = findBreak (sizeAsOffset len)+  where+    !len = length v+    findBreak !i+        | i == 0      = (v, empty)+        | predicate e = splitAt (offsetAsSize i) v+        | otherwise   = findBreak i'+      where+        e = unsafeIndex v i'+        i' = i `offsetSub` 1+ intersperse :: ty -> Array ty -> Array ty intersperse sep v = case len - 1 of     Nothing -> v@@ -502,8 +542,17 @@ span ::  (ty -> Bool) -> Array ty -> (Array ty, Array ty) span p = break (not . p) +spanEnd ::  (ty -> Bool) -> Array ty -> (Array ty, Array ty)+spanEnd p = breakEnd (not . p)+ map :: (a -> b) -> Array a -> Array b map f a = create (sizeCast Proxy $ length a) (\i -> f $ unsafeIndex a (offsetCast Proxy i))++mapFromUnboxed :: PrimType a => (a -> b) -> UArray a -> Array b+mapFromUnboxed f arr = vFromListN (sizeCast Proxy $ UArray.length arr) . fmap f . toList $ arr++mapToUnboxed :: PrimType b => (a -> b) -> Array a -> UArray b+mapToUnboxed f arr = UArray.vFromListN (sizeCast Proxy $ length arr) . fmap f . toList $ arr  {- mapIndex :: (Int -> a -> b) -> Array a -> Array b

@@ -3,16 +3,17 @@ module Basement.Compat.Natural     ( Natural     , integerToNatural+    , naturalToInteger     ) where  #if MIN_VERSION_base(4,8,0)  import Numeric.Natural-import Prelude (Integer, abs, fromInteger)+import Prelude (Integer, abs, fromInteger, toInteger)  #else -import Prelude (Show(..),Eq,Ord,Enum,Num(..),Real(..),Integral(..),Integer,error,(<), (>), otherwise)+import Prelude (Show(..),Eq,Ord,Enum,Num(..),Real(..),Integral(..),Integer,error,(<), (>), otherwise, toInteger) import Data.Typeable  newtype Natural = Natural Integer@@ -54,3 +55,6 @@  integerToNatural :: Integer -> Natural integerToNatural i = fromInteger (abs i)++naturalToInteger :: Natural -> Integer+naturalToInteger n = toInteger n

@@ -3,6 +3,9 @@ {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE TypeInType #-}+#endif module Basement.Error     ( error     ) where

@@ -2,6 +2,25 @@ {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE MagicHash             #-}+{-# LANGUAGE UndecidableInstances  #-}+-- |+-- Module      : Basement.From+-- License     : BSD-style+-- Maintainer  : Haskell Foundation+--+-- Flexible Type convertion+--+-- From is multi parameter type class that allow converting+-- from a to b.+--+-- Only type that are valid to convert to another type+-- should be From instance; otherwise TryFrom should be used.+--+-- Into (resp TryInto) allows the contrary instances to be able+-- to specify the destination type before the source. This is+-- practical with TypeApplication module Basement.From     ( From(..)     , Into@@ -11,10 +30,41 @@     , tryInto     ) where -import Basement.Compat.Base-import Basement.IntegralConv+import           Basement.Compat.Base --- | Class of things that can be converted from a to b+-- basic instances+import           GHC.Types+import           GHC.Prim+import           GHC.Int+import           GHC.Word+import           Basement.Numerical.Number+import           Basement.Numerical.Conversion+import qualified Basement.Block as Block+import qualified Basement.BoxedArray as BoxArray+import qualified Basement.UArray as UArray+import qualified Basement.String as String+import qualified Basement.Types.AsciiString as AsciiString+import           Basement.Types.Word128 (Word128(..))+import           Basement.Types.Word256 (Word256(..))+import qualified Basement.Types.Word128 as Word128+import qualified Basement.Types.Word256 as Word256+import           Basement.These+import           Basement.PrimType (PrimType)+import           Basement.Types.OffsetSize+import           Basement.Compat.Natural+import qualified Prelude (fromIntegral)++-- nat instances+#if __GLASGOW_HASKELL__ >= 800+import           Basement.Nat+import qualified Basement.BlockN as BlockN+import           Basement.Bounded+#endif++-- | Class of things that can be converted from a to b.+--+-- In a valid instance, the source should be always representable by the destination,+-- otherwise the instance should be using 'TryFrom' class From a b where     from :: a -> b @@ -44,7 +94,186 @@ instance From a a where     from = id +-- Simple numerical instances instance From Int Word where-    from = integralCast+    from (I# i) = W# (int2Word# i) instance From Word Int where-    from = integralCast+    from (W# w) = I# (word2Int# w)++instance IsNatural n => From n Natural where+    from = toNatural+instance IsIntegral n => From n Integer where+    from = toInteger++instance From Int8 Int16 where+    from (I8# i) = I16# i+instance From Int8 Int32 where+    from (I8# i) = I32# i+instance From Int8 Int64 where+    from (I8# i) = intToInt64 (I# i)+instance From Int8 Int where+    from (I8# i) = I# i++instance From Int16 Int32 where+    from (I16# i) = I32# i+instance From Int16 Int64 where+    from (I16# i) = intToInt64 (I# i)+instance From Int16 Int where+    from (I16# i) = I# i++instance From Int32 Int64 where+    from (I32# i) = intToInt64 (I# i)+instance From Int32 Int where+    from (I32# i) = I# i++instance From Int Int64 where+    from = intToInt64++instance From Word8 Word16 where+    from (W8# i) = W16# i+instance From Word8 Word32 where+    from (W8# i) = W32# i+instance From Word8 Word64 where+    from (W8# i) = wordToWord64 (W# i)+instance From Word8 Word128 where+    from (W8# i) = Word128 0 (wordToWord64 $ W# i)+instance From Word8 Word256 where+    from (W8# i) = Word256 0 0 0 (wordToWord64 $ W# i)+instance From Word8 Word where+    from (W8# i) = W# i+instance From Word8 Int16 where+    from (W8# w) = I16# (word2Int# w)+instance From Word8 Int32 where+    from (W8# w) = I32# (word2Int# w)+instance From Word8 Int64 where+    from (W8# w) = intToInt64 (I# (word2Int# w))+instance From Word8 Int where+    from (W8# w) = I# (word2Int# w)++instance From Word16 Word32 where+    from (W16# i) = W32# i+instance From Word16 Word64 where+    from (W16# i) = wordToWord64 (W# i)+instance From Word16 Word128 where+    from (W16# i) = Word128 0 (wordToWord64 $ W# i)+instance From Word16 Word256 where+    from (W16# i) = Word256 0 0 0 (wordToWord64 $ W# i)+instance From Word16 Word where+    from (W16# i) = W# i++instance From Word32 Word64 where+    from (W32# i) = wordToWord64 (W# i)+instance From Word32 Word128 where+    from (W32# i) = Word128 0 (wordToWord64 $ W# i)+instance From Word32 Word256 where+    from (W32# i) = Word256 0 0 0 (wordToWord64 $ W# i)+instance From Word32 Word where+    from (W32# i) = W# i++instance From Word64 Word128 where+    from w = Word128 0 w+instance From Word64 Word256 where+    from w = Word256 0 0 0 w++instance From Word Word64 where+    from = wordToWord64++-- Simple prelude types+instance From (Maybe a) (Either () a) where+    from (Just x) = Right x+    from Nothing  = Left ()++-- basic basement types+instance From (CountOf ty) Int where+    from (CountOf n) = n+instance From (CountOf ty) Word where+    from (CountOf n) = from n++instance From (Either a b) (These a b) where+    from (Left a) = This a+    from (Right b) = That b++-- basement instances++-- uarrays+instance PrimType ty => From (Block.Block ty) (UArray.UArray ty) where+    from = UArray.fromBlock+instance PrimType ty => From (BoxArray.Array ty) (UArray.UArray ty) where+    from = BoxArray.mapToUnboxed id++-- blocks+instance PrimType ty => From (UArray.UArray ty) (Block.Block ty) where+    from = UArray.toBlock+instance PrimType ty => From (BoxArray.Array ty) (Block.Block ty) where+    from = UArray.toBlock . BoxArray.mapToUnboxed id++-- boxed array+instance PrimType ty => From (UArray.UArray ty) (BoxArray.Array ty) where+    from = BoxArray.mapFromUnboxed id+++instance From String.String (UArray.UArray Word8) where+    from = String.toBytes String.UTF8++instance From AsciiString.AsciiString String.String where+    from = String.fromBytesUnsafe . UArray.unsafeRecast . AsciiString.toBytes+instance From AsciiString.AsciiString (UArray.UArray Word8) where+    from = UArray.unsafeRecast . AsciiString.toBytes++instance TryFrom (UArray.UArray Word8) String.String where+    tryFrom arr = case String.fromBytes String.UTF8 arr of+                    (s, Nothing, _) -> Just s+                    (_, Just _, _)  -> Nothing++#if __GLASGOW_HASKELL__ >= 800+instance From (BlockN.BlockN n ty) (Block.Block ty) where+    from = BlockN.toBlock+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+    from = BoxArray.mapFromUnboxed id . UArray.fromBlock . BlockN.toBlock++instance (NatWithinBound (CountOf ty) n, KnownNat n, PrimType ty)+      => TryFrom (Block.Block ty) (BlockN.BlockN n ty) where+    tryFrom = BlockN.toBlockN+instance (NatWithinBound (CountOf ty) n, KnownNat n, PrimType ty)+      => TryFrom (UArray.UArray ty) (BlockN.BlockN n ty) where+    tryFrom = BlockN.toBlockN . UArray.toBlock+instance (NatWithinBound (CountOf ty) n, KnownNat n, PrimType ty)+      => TryFrom (BoxArray.Array ty) (BlockN.BlockN n ty) where+    tryFrom = BlockN.toBlockN . UArray.toBlock . BoxArray.mapToUnboxed id++instance (KnownNat n, NatWithinBound Word8 n) => From (Zn64 n) Word8 where+    from = narrow . unZn64 where narrow (W64# w) = W8# (narrow8Word# (word64ToWord# w))+instance (KnownNat n, NatWithinBound Word16 n) => From (Zn64 n) Word16 where+    from = narrow . unZn64 where narrow (W64# w) = W16# (narrow16Word# (word64ToWord# w))+instance (KnownNat n, NatWithinBound Word32 n) => From (Zn64 n) Word32 where+    from = narrow . unZn64 where narrow (W64# w) = W32# (narrow32Word# (word64ToWord# w))+instance From (Zn64 n) Word64 where+    from = unZn64+instance From (Zn64 n) Word128 where+    from = from . unZn64+instance From (Zn64 n) Word256 where+    from = from . unZn64++instance (KnownNat n, NatWithinBound Word8 n) => From (Zn n) Word8 where+    from = narrow . naturalToWord64 . unZn where narrow (W64# w) = W8# (narrow8Word# (word64ToWord# w))+instance (KnownNat n, NatWithinBound Word16 n) => From (Zn n) Word16 where+    from = narrow . naturalToWord64 . unZn where narrow (W64# w) = W16# (narrow16Word# (word64ToWord# w))+instance (KnownNat n, NatWithinBound Word32 n) => From (Zn n) Word32 where+    from = narrow . naturalToWord64 . unZn where narrow (W64# w) = W32# (narrow32Word# (word64ToWord# w))+instance (KnownNat n, NatWithinBound Word64 n) => From (Zn n) Word64 where+    from = naturalToWord64 . unZn+instance (KnownNat n, NatWithinBound Word128 n) => From (Zn n) Word128 where+    from = Word128.fromNatural . unZn+instance (KnownNat n, NatWithinBound Word256 n) => From (Zn n) Word256 where+    from = Word256.fromNatural . unZn++instance (KnownNat n, NatWithinBound Word64 n) => From (Zn n) (Zn64 n) where+    from = zn64 . naturalToWord64 . unZn+instance KnownNat n => From (Zn64 n) (Zn n) where+    from = zn . from . unZn64++naturalToWord64 :: Natural -> Word64+naturalToWord64 = Prelude.fromIntegral+#endif

@@ -1,9 +1,9 @@-{-# LANGUAGE CPP                   #-} {-# LANGUAGE MagicHash             #-} {-# LANGUAGE DefaultSignatures     #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE UnboxedTuples         #-}+{-# LANGUAGE FlexibleInstances     #-} module Basement.IntegralConv     ( IntegralDownsize(..)     , IntegralUpsize(..)@@ -12,14 +12,13 @@     , int64ToInt     , wordToWord64     , word64ToWord32s+    , Word32x2(..)     , word64ToWord     , wordToChar     , wordToInt     , charToInt     ) where -#include "MachDeps.h"- import GHC.Types import GHC.Prim import GHC.Int@@ -27,10 +26,8 @@ import Prelude (Integer, fromIntegral) import Basement.Compat.Base import Basement.Compat.Natural--#if WORD_SIZE_IN_BITS < 64-import GHC.IntWord64-#endif+import Basement.Numerical.Number+import Basement.Numerical.Conversion  -- | Downsize an integral value class IntegralDownsize a b where@@ -62,6 +59,11 @@     | x < integralUpsize (minBound :: b) && x > integralUpsize (maxBound :: b) = Nothing     | otherwise                                                                = Just (aToB x) +instance IsIntegral a => IntegralUpsize a Integer where+    integralUpsize = toInteger+instance IsNatural a => IntegralUpsize a Natural where+    integralUpsize = toNatural+ instance IntegralUpsize Int8 Int16 where     integralUpsize (I8# i) = I16# i instance IntegralUpsize Int8 Int32 where@@ -70,8 +72,6 @@     integralUpsize (I8# i) = intToInt64 (I# i) instance IntegralUpsize Int8 Int where     integralUpsize (I8# i) = I# i-instance IntegralUpsize Int8 Integer where-    integralUpsize = fromIntegral  instance IntegralUpsize Int16 Int32 where     integralUpsize (I16# i) = I32# i@@ -79,24 +79,15 @@     integralUpsize (I16# i) = intToInt64 (I# i) instance IntegralUpsize Int16 Int where     integralUpsize (I16# i) = I# i-instance IntegralUpsize Int16 Integer where-    integralUpsize = fromIntegral  instance IntegralUpsize Int32 Int64 where     integralUpsize (I32# i) = intToInt64 (I# i) instance IntegralUpsize Int32 Int where     integralUpsize (I32# i) = I# i-instance IntegralUpsize Int32 Integer where-    integralUpsize = fromIntegral -instance IntegralUpsize Int Integer where-    integralUpsize = fromIntegral instance IntegralUpsize Int Int64 where     integralUpsize = intToInt64 -instance IntegralUpsize Int64 Integer where-    integralUpsize = fromIntegral- instance IntegralUpsize Word8 Word16 where     integralUpsize (W8# i) = W16# i instance IntegralUpsize Word8 Word32 where@@ -113,10 +104,6 @@     integralUpsize (W8# w) = intToInt64 (I# (word2Int# w)) instance IntegralUpsize Word8 Int where     integralUpsize (W8# w) = I# (word2Int# w)-instance IntegralUpsize Word8 Integer where-    integralUpsize = fromIntegral-instance IntegralUpsize Word8 Natural where-    integralUpsize = fromIntegral  instance IntegralUpsize Word16 Word32 where     integralUpsize (W16# i) = W32# i@@ -124,35 +111,15 @@     integralUpsize (W16# i) = wordToWord64 (W# i) instance IntegralUpsize Word16 Word where     integralUpsize (W16# i) = W# i-instance IntegralUpsize Word16 Integer where-    integralUpsize = fromIntegral-instance IntegralUpsize Word16 Natural where-    integralUpsize = fromIntegral  instance IntegralUpsize Word32 Word64 where     integralUpsize (W32# i) = wordToWord64 (W# i) instance IntegralUpsize Word32 Word where     integralUpsize (W32# i) = W# i-instance IntegralUpsize Word32 Integer where-    integralUpsize = fromIntegral-instance IntegralUpsize Word32 Natural where-    integralUpsize = fromIntegral -instance IntegralUpsize Word Integer where-    integralUpsize = fromIntegral-instance IntegralUpsize Word Natural where-    integralUpsize = fromIntegral instance IntegralUpsize Word Word64 where     integralUpsize = wordToWord64 -instance IntegralUpsize Word64 Integer where-    integralUpsize = fromIntegral-instance IntegralUpsize Word64 Natural where-    integralUpsize = fromIntegral--instance IntegralUpsize Natural Integer where-    integralUpsize = fromIntegral- instance IntegralDownsize Int Int8 where     integralDownsize      (I# i) = I8# (narrow8Int# i)     integralDownsizeCheck = integralDownsizeBounded integralDownsize@@ -258,17 +225,9 @@ instance IntegralCast Int Word where     integralCast (I# i) = W# (int2Word# i) instance IntegralCast Word64 Int64 where-#if WORD_SIZE_IN_BITS == 64-    integralCast (W64# i) = I64# (word2Int# i)-#else-    integralCast (W64# i) = I64# (word64ToInt64# i)-#endif+    integralCast = word64ToInt64 instance IntegralCast Int64 Word64 where-#if WORD_SIZE_IN_BITS == 64-    integralCast (I64# i) = W64# (int2Word# i)-#else-    integralCast (I64# i) = W64# (int64ToWord64# i)-#endif+    integralCast = int64ToWord64  instance IntegralCast Int8 Word8 where     integralCast (I8# i) = W8# (narrow8Word# (int2Word# i))@@ -287,54 +246,3 @@  instance IntegralCast Word32 Int32 where     integralCast (W32# i) = I32# (narrow32Int# (word2Int# i))--intToInt64 :: Int -> Int64-#if WORD_SIZE_IN_BITS == 64-intToInt64 (I# i) = I64# i-#else-intToInt64 (I# i) = I64# (intToInt64# i)-#endif--int64ToInt :: Int64 -> Int-#if WORD_SIZE_IN_BITS == 64-int64ToInt (I64# i) = I# i-#else-int64ToInt (I64# i) = I# (int64ToInt# i)-#endif--wordToWord64 :: Word -> Word64-#if WORD_SIZE_IN_BITS == 64-wordToWord64 (W# i) = W64# i-#else-wordToWord64 (W# i) = W64# (wordToWord64# i)-#endif--word64ToWord :: Word64 -> Word-#if WORD_SIZE_IN_BITS == 64-word64ToWord (W64# i) = W# i-#else-word64ToWord (W64# i) = W# (word64ToWord# i)-#endif--#if WORD_SIZE_IN_BITS == 64-word64ToWord# :: Word# -> Word#-word64ToWord# i = i-{-# INLINE word64ToWord# #-}-#endif--#if WORD_SIZE_IN_BITS == 64-word64ToWord32s :: Word64 -> (# Word32, Word32 #)-word64ToWord32s (W64# w64) = (# W32# (uncheckedShiftRL# w64 32#), W32# (narrow32Word# w64) #)-#else-word64ToWord32s :: Word64 -> (# Word32, Word32 #)-word64ToWord32s (W64# w64) = (# W32# (word64ToWord# (uncheckedShiftRL64# w64 32#)), W32# (word64ToWord# w64) #)-#endif--wordToChar :: Word -> Char-wordToChar (W# word) = C# (chr# (word2Int# word))--wordToInt :: Word -> Int-wordToInt (W# word) = I# (word2Int# word)--charToInt :: Char -> Int-charToInt (C# x) = I# (ord# x)

@@ -18,6 +18,8 @@     , CmpNat     -- * Nat convertion     , natValNatural+    , natValCountOf+    , natValOffset     , natValInt     , natValInt8     , natValInt16@@ -40,6 +42,10 @@ import           GHC.TypeLits import           Basement.Compat.Base import           Basement.Compat.Natural+import           Basement.Types.OffsetSize+import           Basement.Types.Char7 (Char7)+import           Basement.Types.Word128 (Word128)+import           Basement.Types.Word256 (Word256) import           Data.Int (Int8, Int16, Int32, Int64) import           Data.Word (Word8, Word16, Word32, Word64) import qualified Prelude (fromIntegral)@@ -51,6 +57,12 @@ natValNatural :: forall n proxy . KnownNat n => proxy n -> Natural natValNatural n = Prelude.fromIntegral (natVal n) +natValCountOf :: forall n ty proxy . (KnownNat n, NatWithinBound (CountOf ty) n) => proxy n -> CountOf ty+natValCountOf n = CountOf $ Prelude.fromIntegral (natVal n)++natValOffset :: forall n ty proxy . (KnownNat n, NatWithinBound (Offset ty) n) => proxy n -> Offset ty+natValOffset n = Offset $ Prelude.fromIntegral (natVal n)+ natValInt :: forall n proxy . (KnownNat n, NatWithinBound Int n) => proxy n -> Int natValInt n = Prelude.fromIntegral (natVal n) @@ -83,10 +95,14 @@  -- | Get Maximum bounds of different Integral / Natural types related to Nat type family NatNumMaxBound ty where+    NatNumMaxBound Char   = 0x10ffff+    NatNumMaxBound Char7  = 0x7f     NatNumMaxBound Int64  = 0x7fffffffffffffff     NatNumMaxBound Int32  = 0x7fffffff     NatNumMaxBound Int16  = 0x7fff     NatNumMaxBound Int8   = 0x7f+    NatNumMaxBound Word256 = 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff+    NatNumMaxBound Word128 = 0xffffffffffffffffffffffffffffffff     NatNumMaxBound Word64 = 0xffffffffffffffff     NatNumMaxBound Word32 = 0xffffffff     NatNumMaxBound Word16 = 0xffff@@ -98,6 +114,8 @@     NatNumMaxBound Int    = NatNumMaxBound Int32     NatNumMaxBound Word   = NatNumMaxBound Word32 #endif+    NatNumMaxBound (CountOf x) = NatNumMaxBound Int+    NatNumMaxBound (Offset x) = NatNumMaxBound Int  -- | Check if a Nat is in bounds of another integral / natural types type family NatInBoundOf ty n where

@@ -8,6 +8,8 @@ import Basement.Compat.Natural import Basement.Types.OffsetSize import Basement.Types.Char7+import Basement.Types.Word128 (Word128)+import Basement.Types.Word256 (Word256) import Basement.Endianness import Foreign.C.Types @@ -42,7 +44,6 @@ instance NormalForm Float  where toNormalForm !_ = () instance NormalForm Double where toNormalForm !_ = () -instance NormalForm Char7 where toNormalForm !_ = () instance NormalForm Char where toNormalForm !_ = () instance NormalForm Bool where toNormalForm !_ = () instance NormalForm ()   where toNormalForm !_ = ()@@ -71,6 +72,10 @@ -- Basic Foundation primitive types instance NormalForm (Offset a) where toNormalForm !_ = () instance NormalForm (CountOf a) where toNormalForm !_ = ()++instance NormalForm Char7 where toNormalForm !_ = ()+instance NormalForm Word128 where toNormalForm !_ = ()+instance NormalForm Word256 where toNormalForm !_ = ()  ----- -- composed type

@@ -15,6 +15,10 @@ import           GHC.Int import           GHC.Word import           Foreign.C.Types+import           Basement.Types.Word128 (Word128)+import           Basement.Types.Word256 (Word256)+import qualified Basement.Types.Word128 as Word128+import qualified Basement.Types.Word256 as Word256  #if WORD_SIZE_IN_BITS < 64 import           GHC.IntWord64@@ -95,6 +99,14 @@ #else     (W64# a) + (W64# b) = W64# (int64ToWord64# (word64ToInt64# a `plusInt64#` word64ToInt64# b)) #endif+    scale = scaleNum+instance Additive Word128 where+    azero = 0+    (+) = (Word128.+)+    scale = scaleNum+instance Additive Word256 where+    azero = 0+    (+) = (Word256.+)     scale = scaleNum instance Additive Prelude.Float where     azero = 0.0

@@ -0,0 +1,96 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE MagicHash             #-}+module Basement.Numerical.Conversion+    ( intToInt64+    , int64ToInt+    , wordToWord64+    , word64ToWord+    , Word32x2(..)+    , word64ToWord32s+    , wordToChar+    , wordToInt+    , word64ToWord#+    , charToInt+    , int64ToWord64+    , word64ToInt64+    ) where++#include "MachDeps.h"++import GHC.Types+import GHC.Prim+import GHC.Int+import GHC.Word++#if WORD_SIZE_IN_BITS < 64+import GHC.IntWord64+#endif++intToInt64 :: Int -> Int64+#if WORD_SIZE_IN_BITS == 64+intToInt64 (I# i) = I64# i+#else+intToInt64 (I# i) = I64# (intToInt64# i)+#endif++int64ToInt :: Int64 -> Int+#if WORD_SIZE_IN_BITS == 64+int64ToInt (I64# i) = I# i+#else+int64ToInt (I64# i) = I# (int64ToInt# i)+#endif++wordToWord64 :: Word -> Word64+#if WORD_SIZE_IN_BITS == 64+wordToWord64 (W# i) = W64# i+#else+wordToWord64 (W# i) = W64# (wordToWord64# i)+#endif++word64ToWord :: Word64 -> Word+#if WORD_SIZE_IN_BITS == 64+word64ToWord (W64# i) = W# i+#else+word64ToWord (W64# i) = W# (word64ToWord# i)+#endif++word64ToInt64 :: Word64 -> Int64+#if WORD_SIZE_IN_BITS == 64+word64ToInt64 (W64# i) = I64# (word2Int# i)+#else+word64ToInt64 (W64# i) = I64# (word64ToInt64# i)+#endif++int64ToWord64 :: Int64 -> Word64+#if WORD_SIZE_IN_BITS == 64+int64ToWord64 (I64# i) = W64# (int2Word# i)+#else+int64ToWord64 (I64# i) = W64# (int64ToWord64# i)+#endif++#if WORD_SIZE_IN_BITS == 64+word64ToWord# :: Word# -> Word#+word64ToWord# i = i+{-# INLINE word64ToWord# #-}+#endif++-- | 2 Word32s+data Word32x2 = Word32x2 {-# UNPACK #-} !Word32+                         {-# UNPACK #-} !Word32++#if WORD_SIZE_IN_BITS == 64+word64ToWord32s :: Word64 -> Word32x2+word64ToWord32s (W64# w64) = Word32x2 (W32# (uncheckedShiftRL# w64 32#)) (W32# (narrow32Word# w64))+#else+word64ToWord32s :: Word64 -> Word32x2+word64ToWord32s (W64# w64) = Word32x2 (W32# (word64ToWord# (uncheckedShiftRL64# w64 32#))) (W32# (word64ToWord# w64))+#endif++wordToChar :: Word -> Char+wordToChar (W# word) = C# (chr# (word2Int# word))++wordToInt :: Word -> Int+wordToInt (W# word) = I# (word2Int# word)++charToInt :: Char -> Int+charToInt (C# x) = I# (ord# x)

@@ -11,6 +11,10 @@ import           Basement.Compat.Natural import           Basement.Numerical.Number import           Basement.Numerical.Additive+import           Basement.Types.Word128 (Word128)+import           Basement.Types.Word256 (Word256)+import qualified Basement.Types.Word128 as Word128+import qualified Basement.Types.Word256 as Word256 import qualified Prelude  -- | Represent class of things that can be multiplied together@@ -92,6 +96,12 @@ instance Multiplicative Word64 where     midentity = 1     (*) = (Prelude.*)+instance Multiplicative Word128 where+    midentity = 1+    (*) = (Word128.*)+instance Multiplicative Word256 where+    midentity = 1+    (*) = (Word256.*) instance Multiplicative Prelude.Float where     midentity = 1.0     (*) = (Prelude.*)@@ -138,6 +148,12 @@ instance IDivisible Word64 where     div = Prelude.quot     mod = Prelude.rem+instance IDivisible Word128 where+    div = Word128.quot+    mod = Word128.rem+instance IDivisible Word256 where+    div = Word256.quot+    mod = Word256.rem  instance Divisible Prelude.Rational where     (/) = (Prelude./)

@@ -5,6 +5,7 @@  import           Basement.Compat.Base import           Basement.Compat.Natural+import           Data.Bits import qualified Prelude import           Foreign.C.Types 

@@ -5,6 +5,10 @@ import           Basement.Compat.Base import           Basement.Compat.Natural import           Basement.IntegralConv+import           Basement.Types.Word128 (Word128)+import           Basement.Types.Word256 (Word256)+import qualified Basement.Types.Word128 as Word128+import qualified Basement.Types.Word256 as Word256 import qualified Prelude  -- | Represent class of things that can be subtracted.@@ -63,6 +67,12 @@ instance Subtractive Word64 where     type Difference Word64 = Word64     (-) = (Prelude.-)+instance Subtractive Word128 where+    type Difference Word128 = Word128+    (-) = (Word128.-)+instance Subtractive Word256 where+    type Difference Word256 = Word256+    (-) = (Word256.-) instance Subtractive Prelude.Float where     type Difference Prelude.Float = Prelude.Float     (-) = (Prelude.-)

@@ -46,6 +46,8 @@ import           Basement.Types.OffsetSize import           Basement.Types.Char7 (Char7(..)) import           Basement.Endianness+import           Basement.Types.Word128 (Word128(..))+import           Basement.Types.Word256 (Word256(..)) import           Basement.Monad import qualified Prelude (quot) @@ -329,6 +331,80 @@     {-# INLINE primAddrRead #-}     primAddrWrite addr (Offset (I# n)) (W64# w) = primitive $ \s1 -> (# writeWord64OffAddr# addr n w s1, () #)     {-# INLINE primAddrWrite #-}+instance PrimType Word128 where+    primSizeInBytes _ = CountOf 16+    {-# INLINE primSizeInBytes #-}+    primShiftToBytes _ = 4+    {-# INLINE primShiftToBytes #-}+    primBaUIndex ba n =+        Word128 (W64# (indexWord64Array# ba n1)) (W64# (indexWord64Array# ba n2))+      where (# n1, n2 #) = offset128_64 n+    {-# INLINE primBaUIndex #-}+    primMbaURead mba n = primitive $ \s1 -> let !(# s2, r1 #) = readWord64Array# mba n1 s1+                                                !(# s3, r2 #) = readWord64Array# mba n2 s2+                                             in (# s3, Word128 (W64# r1) (W64# r2) #)+      where (# n1, n2 #) = offset128_64 n+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba n (Word128 (W64# w1) (W64# w2)) = primitive $ \s1 ->+        let !s2 = writeWord64Array# mba n1 w1 s1+         in (# writeWord64Array# mba n2 w2 s2, () #)+      where (# n1, n2 #) = offset128_64 n+    {-# INLINE primMbaUWrite #-}+    primAddrIndex addr n = Word128 (W64# (indexWord64OffAddr# addr n1)) (W64# (indexWord64OffAddr# addr n2))+      where (# n1, n2 #) = offset128_64 n+    {-# INLINE primAddrIndex #-}+    primAddrRead addr n = primitive $ \s1 -> let !(# s2, r1 #) = readWord64OffAddr# addr n1 s1+                                                 !(# s3, r2 #) = readWord64OffAddr# addr n2 s2+                                              in (# s3, Word128 (W64# r1) (W64# r2) #)+      where (# n1, n2 #) = offset128_64 n+    {-# INLINE primAddrRead #-}+    primAddrWrite addr n (Word128 (W64# w1) (W64# w2)) = primitive $ \s1 ->+        let !s2 = writeWord64OffAddr# addr n1 w1 s1+         in (# writeWord64OffAddr# addr n2 w2 s2, () #)+      where (# n1, n2 #) = offset128_64 n+    {-# INLINE primAddrWrite #-}+instance PrimType Word256 where+    primSizeInBytes _ = CountOf 32+    {-# INLINE primSizeInBytes #-}+    primShiftToBytes _ = 5+    {-# INLINE primShiftToBytes #-}+    primBaUIndex ba n =+        Word256 (W64# (indexWord64Array# ba n1)) (W64# (indexWord64Array# ba n2))+                (W64# (indexWord64Array# ba n3)) (W64# (indexWord64Array# ba n4))+      where (# n1, n2, n3, n4 #) = offset256_64 n+    {-# INLINE primBaUIndex #-}+    primMbaURead mba n = primitive $ \s1 -> let !(# s2, r1 #) = readWord64Array# mba n1 s1+                                                !(# s3, r2 #) = readWord64Array# mba n2 s2+                                                !(# s4, r3 #) = readWord64Array# mba n3 s3+                                                !(# s5, r4 #) = readWord64Array# mba n4 s4+                                             in (# s5, Word256 (W64# r1) (W64# r2) (W64# r3) (W64# r4) #)+      where (# n1, n2, n3, n4 #) = offset256_64 n+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba n (Word256 (W64# w1) (W64# w2) (W64# w3) (W64# w4)) = primitive $ \s1 ->+        let !s2 = writeWord64Array# mba n1 w1 s1+            !s3 = writeWord64Array# mba n2 w2 s2+            !s4 = writeWord64Array# mba n3 w3 s3+         in (# writeWord64Array# mba n4 w4 s4, () #)+      where (# n1, n2, n3, n4 #) = offset256_64 n+    {-# INLINE primMbaUWrite #-}+    primAddrIndex addr n = Word256 (W64# (indexWord64OffAddr# addr n1)) (W64# (indexWord64OffAddr# addr n2))+                                   (W64# (indexWord64OffAddr# addr n3)) (W64# (indexWord64OffAddr# addr n4))+      where (# n1, n2, n3, n4 #) = offset256_64 n+    {-# INLINE primAddrIndex #-}+    primAddrRead addr n = primitive $ \s1 -> let !(# s2, r1 #) = readWord64OffAddr# addr n1 s1+                                                 !(# s3, r2 #) = readWord64OffAddr# addr n2 s2+                                                 !(# s4, r3 #) = readWord64OffAddr# addr n3 s3+                                                 !(# s5, r4 #) = readWord64OffAddr# addr n4 s4+                                              in (# s5, Word256 (W64# r1) (W64# r2) (W64# r3) (W64# r4) #)+      where (# n1, n2, n3, n4 #) = offset256_64 n+    {-# INLINE primAddrRead #-}+    primAddrWrite addr n (Word256 (W64# w1) (W64# w2) (W64# w3) (W64# w4)) = primitive $ \s1 ->+        let !s2 = writeWord64OffAddr# addr n1 w1 s1+            !s3 = writeWord64OffAddr# addr n2 w2 s2+            !s4 = writeWord64OffAddr# addr n3 w3 s3+         in (# writeWord64OffAddr# addr n4 w4 s4, () #)+      where (# n1, n2, n3, n4 #) = offset256_64 n+    {-# INLINE primAddrWrite #-} instance PrimType Int8 where     primSizeInBytes _ = CountOf 1     {-# INLINE primSizeInBytes #-}@@ -553,6 +629,8 @@ instance PrimMemoryComparable Word16 where instance PrimMemoryComparable Word32 where instance PrimMemoryComparable Word64 where+instance PrimMemoryComparable Word128 where+instance PrimMemoryComparable Word256 where instance PrimMemoryComparable Int8 where instance PrimMemoryComparable Int16 where instance PrimMemoryComparable Int32 where@@ -562,6 +640,14 @@ instance PrimMemoryComparable CUChar where instance PrimMemoryComparable a => PrimMemoryComparable (LE a) where instance PrimMemoryComparable a => PrimMemoryComparable (BE a) where++offset128_64 :: Offset Word128 -> (# Int#, Int# #)+offset128_64 (Offset (I# i)) = (# n , n +# 1# #)+  where !n = uncheckedIShiftL# i 1#++offset256_64 :: Offset Word256 -> (# Int#, Int#, Int#, Int# #)+offset256_64 (Offset (I# i)) = (# n , n +# 1#, n +# 2#, n +# 3# #)+  where !n = uncheckedIShiftL# i 2#  -- | Cast a CountOf linked to type A (CountOf A) to a CountOf linked to type B (CountOf B) sizeRecast :: forall a b . (PrimType a, PrimType b) => CountOf a -> CountOf b

@@ -50,7 +50,9 @@     , indices     , intersperse     , span+    , spanEnd     , break+    , breakEnd     , breakElem     , breakLine     , dropWhile@@ -96,6 +98,7 @@ import qualified Basement.UArray           as Vec import qualified Basement.UArray           as C import qualified Basement.UArray.Mutable   as MVec+import           Basement.Block.Mutable (MutableBlock(..)) import           Basement.Compat.Bifunctor import           Basement.Compat.Base import           Basement.Compat.Natural@@ -117,10 +120,10 @@ import           Basement.UTF8.Base import           Basement.UTF8.Types import           Basement.UArray.Base as C (onBackendPrim, onBackend, offset, ValidRange(..), offsetsValidRange)-import qualified Basement.UTF8.BA as PrimBA-import qualified Basement.UTF8.Addr as PrimAddr-import qualified Basement.String.BA as BackendBA-import qualified Basement.String.Addr as BackendAddr+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           GHC.Prim import           GHC.ST import           GHC.Types@@ -461,6 +464,20 @@         {-# INLINE loop #-} {-# INLINE [2] break #-} +breakEnd :: (Char -> Bool) -> String -> (String, String)+breakEnd predicate s@(String arr)+    | k == end  = (s, mempty)+    | otherwise = splitIndex k s+  where+    k = C.onBackend goVec (\_ -> pure . goAddr) arr+    (C.ValidRange !start !end) = offsetsValidRange arr+    goVec 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+{-# INLINE [2] breakEnd #-}+ #if MIN_VERSION_base(4,9,0) {-# RULES "break (== 'c')" [3] forall c . break (eqChar c) = breakElem c #-} #else@@ -505,6 +522,11 @@ span :: (Char -> Bool) -> String -> (String, String) span predicate s = break (not . predicate) s +-- | Apply a @predicate@ to the string to return the longest suffix that satisfy the predicate and+-- the remaining+spanEnd :: (Char -> Bool) -> String -> (String, String)+spanEnd predicate s = breakEnd (not . predicate) s+ -- | Drop character from the beginning while the predicate is true dropWhile :: (Char -> Bool) -> String -> String dropWhile predicate = snd . break (not . predicate)@@ -762,7 +784,7 @@ -- | Filter characters of a string using the predicate filter :: (Char -> Bool) -> String -> String filter predicate (String arr) = runST $ do-    (finalSize, dst) <- newNative sz $ \mba ->+    (finalSize, dst) <- newNative sz $ \(MutableBlock mba) ->         C.onBackendPrim (\ba -> BackendBA.copyFilter predicate sz mba ba start)                         (\fptr -> withFinalPtr fptr $ \(Ptr addr) -> BackendAddr.copyFilter predicate sz mba addr start)                         arr

@@ -1,86 +0,0 @@-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE MagicHash                  #-}-{-# LANGUAGE NoImplicitPrelude          #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE CPP                        #-}-module Basement.String.Addr-    ( copyFilter-    , validate-    ) where--import           GHC.Prim-import           GHC.ST-import           Basement.Compat.Base-import           Basement.Numerical.Additive-import           Basement.Types.OffsetSize--import qualified Basement.UTF8.BA   as PrimBA-import qualified Basement.UTF8.Addr as PrimBackend-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) -> PrimBA.primWrite dst d h >> loop (d + Offset 1) (s + Offset 1)-                         | otherwise             -> loop d (s + Offset 1)-                    False ->-                        case PrimBackend.next src s of-                            Step c s' | predicate c -> PrimBA.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 = loop ofsStart-  where-    loop !ofs-        | ofs > end  = error ("validate: internal error: went pass offset : ofs=" <> show ofs <> " end=" <> show end)-        | ofs == end = (end, Nothing)-        | otherwise  =-            let !h = PrimBackend.primIndex ba ofs in-            case headerIsAscii h of-                True  -> loop (ofs + Offset 1)-                False ->-                    case one (CountOf $ getNbBytes h) ofs of-                        (nextOfs, Nothing)  -> loop nextOfs-                        (pos, Just failure) -> (pos, Just failure)--    one (CountOf 0xff) pos = (pos, Just InvalidHeader)-    one nbConts pos-        | ((pos+Offset 1) `offsetPlusE` nbConts) > end = (pos, Just MissingByte)-        | otherwise =-            case nbConts of-                CountOf 1 ->-                    let c1 = PrimBackend.primIndex ba (pos + Offset 1)-                    in if isContinuation c1-                        then (pos + Offset 2, Nothing)-                        else (pos, Just InvalidContinuation)-                CountOf 2 ->-                    let c1 = PrimBackend.primIndex ba (pos + Offset 1)-                        c2 = PrimBackend.primIndex ba (pos + Offset 2)-                     in if isContinuation c1 && isContinuation c2-                            then (pos + Offset 3, Nothing)-                            else (pos, Just InvalidContinuation)-                CountOf 3 ->-                    let c1 = PrimBackend.primIndex ba (pos + Offset 1)-                        c2 = PrimBackend.primIndex ba (pos + Offset 2)-                        c3 = PrimBackend.primIndex ba (pos + Offset 3)-                     in if isContinuation c1 && isContinuation c2 && isContinuation c3-                            then (pos + Offset 4, Nothing)-                            else (pos, Just InvalidContinuation)-                CountOf _ -> error "internal error"

@@ -1,86 +0,0 @@-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE MagicHash                  #-}-{-# LANGUAGE NoImplicitPrelude          #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE CPP                        #-}-module Basement.String.BA-    ( copyFilter-    , validate-    ) where--import           GHC.Prim-import           GHC.ST-import           Basement.Compat.Base-import           Basement.Numerical.Additive-import           Basement.Types.OffsetSize--import qualified Basement.UTF8.BA as PrimBA-import qualified Basement.UTF8.BA as PrimBackend-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) -> PrimBA.primWrite dst d h >> loop (d + Offset 1) (s + Offset 1)-                         | otherwise             -> loop d (s + Offset 1)-                    False ->-                        case PrimBackend.next src s of-                            Step c s' | predicate c -> PrimBA.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 = loop ofsStart-  where-    loop !ofs-        | ofs > end  = error ("validate: internal error: went pass offset : ofs=" <> show ofs <> " end=" <> show end)-        | ofs == end = (end, Nothing)-        | otherwise  =-            let !h = PrimBackend.primIndex ba ofs in-            case headerIsAscii h of-                True  -> loop (ofs + Offset 1)-                False ->-                    case one (CountOf $ getNbBytes h) ofs of-                        (nextOfs, Nothing)  -> loop nextOfs-                        (pos, Just failure) -> (pos, Just failure)--    one (CountOf 0xff) pos = (pos, Just InvalidHeader)-    one nbConts pos-        | ((pos+Offset 1) `offsetPlusE` nbConts) > end = (pos, Just MissingByte)-        | otherwise =-            case nbConts of-                CountOf 1 ->-                    let c1 = PrimBackend.primIndex ba (pos + Offset 1)-                    in if isContinuation c1-                        then (pos + Offset 2, Nothing)-                        else (pos, Just InvalidContinuation)-                CountOf 2 ->-                    let c1 = PrimBackend.primIndex ba (pos + Offset 1)-                        c2 = PrimBackend.primIndex ba (pos + Offset 2)-                     in if isContinuation c1 && isContinuation c2-                            then (pos + Offset 3, Nothing)-                            else (pos, Just InvalidContinuation)-                CountOf 3 ->-                    let c1 = PrimBackend.primIndex ba (pos + Offset 1)-                        c2 = PrimBackend.primIndex ba (pos + Offset 2)-                        c3 = PrimBackend.primIndex ba (pos + Offset 3)-                     in if isContinuation c1 && isContinuation c2 && isContinuation c3-                            then (pos + Offset 4, Nothing)-                            else (pos, Just InvalidContinuation)-                CountOf _ -> error "internal error"

@@ -48,7 +48,6 @@ import Data.Bits import Basement.Compat.Base import Data.Proxy-import Basement.From import Basement.Numerical.Number import Basement.Numerical.Additive import Basement.Numerical.Subtractive@@ -179,11 +178,6 @@     abs a = a     negate _ = error "cannot negate CountOf: use Foundation Numerical hierarchy for this function to not be exposed to CountOf"     signum (CountOf a) = CountOf (Prelude.signum a)--instance From (CountOf ty) Int where-    from (CountOf n) = n-instance From (CountOf ty) Word where-    from (CountOf n) = from n  instance IsIntegral (CountOf ty) where     toInteger (CountOf i) = toInteger i

@@ -0,0 +1,242 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+module Basement.Types.Word128+    ( Word128(..)+    , (+)+    , (-)+    , (*)+    , quot+    , rem+    , bitwiseAnd+    , bitwiseOr+    , bitwiseXor+    , fromNatural+    ) where++import           GHC.Prim+import           GHC.Word+import           GHC.Types+import qualified Prelude (fromInteger, show, Num(..), quot, rem, mod)+import           Data.Bits hiding (complement, popCount, bit, testBit+                                  , rotateL, rotateR, shiftL, shiftR)+import qualified Data.Bits as Bits+import           Data.Function (on)+import           Foreign.C+import           Foreign.Ptr+import           Foreign.Storable++import           Basement.Compat.Base+import           Basement.Compat.Natural+import           Basement.Compat.Primitive (bool#)+import           Basement.Numerical.Conversion+import           Basement.Numerical.Number++#include "MachDeps.h"++-- | 128 bits Word+data Word128 = Word128 {-# UNPACK #-} !Word64+                       {-# UNPACK #-} !Word64+    deriving (Eq)++instance Show Word128 where+    show w = Prelude.show (toNatural w)+instance Enum Word128 where+    toEnum i = Word128 0 $ int64ToWord64 (intToInt64 i)+    fromEnum (Word128 _ a0) = wordToInt (word64ToWord a0)+    succ (Word128 a1 a0)+        | a0 == maxBound = Word128 (succ a1) 0+        | otherwise      = Word128 a1        (succ a0)+    pred (Word128 a1 a0)+        | a0 == minBound = Word128 (pred a1) maxBound+        | otherwise      = Word128 a1        (pred a0)+instance Bounded Word128 where+    minBound = Word128 minBound minBound+    maxBound = Word128 maxBound maxBound+instance Ord Word128 where+    compare (Word128 a1 a0) (Word128 b1 b0) =+        case compare a1 b1 of+            EQ -> compare a0 b0+            r  -> r+    (<) (Word128 a1 a0) (Word128 b1 b0) =+        case compare a1 b1 of+            EQ -> a0 < b0+            r  -> r == LT+    (<=) (Word128 a1 a0) (Word128 b1 b0) =+        case compare a1 b1 of+            EQ -> a0 <= b0+            r  -> r == LT+instance Storable Word128 where+    sizeOf _ = 16+    alignment _ = 16+    peek p = Word128 <$> peek (castPtr p            )+                     <*> peek (castPtr p `plusPtr` 8)+    poke p (Word128 a1 a0) = do+        poke (castPtr p            ) a1+        poke (castPtr p `plusPtr` 8) a0++instance Integral Word128 where+    fromInteger = literal+instance HasNegation Word128 where+    negate = complement++instance IsIntegral Word128 where+    toInteger (Word128 a1 a0) =+        (toInteger a1 `unsafeShiftL` 64) .|.+        toInteger a0+instance IsNatural Word128 where+    toNatural (Word128 a1 a0) =+        (toNatural a1 `unsafeShiftL` 64) .|.+        toNatural a0++instance Prelude.Num Word128 where+    abs w = w+    signum w@(Word128 a1 a0)+        | a1 == 0 && a0 == 0 = w+        | otherwise          = Word128 0 1+    fromInteger = literal+    (+) = (+)+    (-) = (-)+    (*) = (*)++instance Bits.Bits Word128 where+    (.&.) = bitwiseAnd+    (.|.) = bitwiseOr+    xor   = bitwiseXor+    complement = complement+    shiftL = shiftL+    shiftR = shiftR+    rotateL = rotateL+    rotateR = rotateR+    bitSize _ = 128+    bitSizeMaybe _ = Just 128+    isSigned _ = False+    testBit = testBit+    bit = bit+    popCount = popCount++-- | Add 2 Word128+(+) :: Word128 -> Word128 -> Word128+#if WORD_SIZE_IN_BITS < 64+(+) = applyBiWordOnNatural (Prelude.+)+#else+(+) (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) = Word128 (W64# s1) (W64# s0)+  where+    !(# carry, s0 #) = plusWord2# a0 b0+    s1               = plusWord# (plusWord# a1 b1) carry+#endif++-- temporary available until native operation available+applyBiWordOnNatural :: (Natural -> Natural -> Natural)+                     -> Word128+                     -> Word128+                     -> Word128+applyBiWordOnNatural f = (fromNatural .) . (f `on` toNatural)++-- | Subtract 2 Word128+(-) :: Word128 -> Word128 -> Word128+(-) a b+    | a >= b    = applyBiWordOnNatural (Prelude.-) a b+    | otherwise = complement $ applyBiWordOnNatural (Prelude.-) b a++-- | Multiplication+(*) :: Word128 -> Word128 -> Word128+(*) = applyBiWordOnNatural (Prelude.*)++-- | Division+quot :: Word128 -> Word128 -> Word128+quot = applyBiWordOnNatural Prelude.quot++-- | Modulo+rem :: Word128 -> Word128 -> Word128+rem = applyBiWordOnNatural Prelude.rem++-- | Bitwise and+bitwiseAnd :: Word128 -> Word128 -> Word128+bitwiseAnd (Word128 a1 a0) (Word128 b1 b0) =+    Word128 (a1 .&. b1) (a0 .&. b0)++-- | Bitwise or+bitwiseOr :: Word128 -> Word128 -> Word128+bitwiseOr (Word128 a1 a0) (Word128 b1 b0) =+    Word128 (a1 .|. b1) (a0 .|. b0)++-- | Bitwise xor+bitwiseXor :: Word128 -> Word128 -> Word128+bitwiseXor (Word128 a1 a0) (Word128 b1 b0) =+    Word128 (a1 `Bits.xor` b1) (a0 `Bits.xor` b0)++-- | Bitwise complement+complement :: Word128 -> Word128+complement (Word128 a1 a0) = Word128 (Bits.complement a1) (Bits.complement a0)++-- | Population count+popCount :: Word128 -> Int+popCount (Word128 a1 a0) = Bits.popCount a1 Prelude.+ Bits.popCount a0++-- | Bitwise Shift Left+shiftL :: Word128 -> Int -> Word128+shiftL w@(Word128 a1 a0) n+    | n < 0 || n > 127 = Word128 0 0+    | n == 64          = Word128 a0 0+    | n == 0           = w+    | n >  64          = Word128 (a0 `Bits.unsafeShiftL` (n Prelude.- 64)) 0+    | otherwise        = Word128 ((a1 `Bits.unsafeShiftL` n) .|. (a0 `Bits.unsafeShiftR` (64 Prelude.- n)))+                                 (a0 `Bits.unsafeShiftL` n)++-- | Bitwise Shift Right+shiftR :: Word128 -> Int -> Word128+shiftR w@(Word128 a1 a0) n+    | n < 0 || n > 127 = Word128 0 0+    | n == 64          = Word128 0 a1+    | n == 0           = w+    | n >  64          = Word128 0 (a1 `Bits.unsafeShiftR` (n Prelude.- 64))+    | otherwise        = Word128 (a1 `Bits.unsafeShiftR` n)+                                 ((a1 `Bits.unsafeShiftL` (inv64 n)) .|. (a0 `Bits.unsafeShiftR` n))++-- | Bitwise rotate Left+rotateL :: Word128 -> Int -> Word128+rotateL (Word128 a1 a0) n'+    | n == 0    = Word128 a1 a0+    | n == 64   = Word128 a0 a1+    | n < 64    = Word128 (comb64 a1 n a0 (inv64 n)) (comb64 a0 n a1 (inv64 n))+    | otherwise = let n = n Prelude.- 64 in Word128 (comb64 a0 n a1 (inv64 n)) (comb64 a1 n a0 (inv64 n))+  where+    n :: Int+    n | n' >= 0   = n' `Prelude.mod` 128+      | otherwise = 128 Prelude.- (n' `Prelude.mod` 128)++-- | Bitwise rotate Left+rotateR :: Word128 -> Int -> Word128+rotateR w n = rotateL w (128 Prelude.- n)++inv64 :: Int -> Int+inv64 i = 64 Prelude.- i++comb64 :: Word64 -> Int -> Word64 -> Int -> Word64+comb64 x i y j =+    (x `Bits.unsafeShiftL` i) .|. (y `Bits.unsafeShiftR` j)++-- | Test bit+testBit :: Word128 -> Int -> Bool+testBit (Word128 a1 a0) n+    | n < 0 || n > 127 = False+    | n > 63           = Bits.testBit a1 (n Prelude.- 64)+    | otherwise        = Bits.testBit a0 n++-- | bit+bit :: Int -> Word128+bit n+    | n < 0 || n > 127 = Word128 0 0+    | n > 63           = Word128 (Bits.bit (n Prelude.- 64)) 0+    | otherwise        = Word128 0 (Bits.bit n)++literal :: Integer -> Word128+literal i = Word128+    (Prelude.fromInteger (i `Bits.unsafeShiftR` 64))+    (Prelude.fromInteger i)++fromNatural :: Natural -> Word128+fromNatural n = Word128+    (Prelude.fromInteger (naturalToInteger n `Bits.unsafeShiftR` 64))+    (Prelude.fromInteger $ naturalToInteger n)

@@ -0,0 +1,317 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+module Basement.Types.Word256+    ( Word256(..)+    , (+)+    , (-)+    , (*)+    , quot+    , rem+    , bitwiseAnd+    , bitwiseOr+    , bitwiseXor+    , fromNatural+    ) where++import           GHC.Prim+import           GHC.Word+import           GHC.Types+import qualified Prelude (fromInteger, show, Num(..), quot, rem, mod)+import           Data.Bits hiding (complement, popCount, bit, testBit+                                  , rotateL, rotateR, shiftL, shiftR)+import qualified Data.Bits as Bits+import           Data.Function (on)+import           Foreign.C+import           Foreign.Ptr+import           Foreign.Storable++import           Basement.Compat.Base+import           Basement.Compat.Natural+import           Basement.Compat.Primitive (bool#)+import           Basement.Numerical.Conversion+import           Basement.Numerical.Number++#include "MachDeps.h"++-- | 256 bits Word+data Word256 = Word256 {-# UNPACK #-} !Word64+                       {-# UNPACK #-} !Word64+                       {-# UNPACK #-} !Word64+                       {-# UNPACK #-} !Word64+    deriving (Eq)++instance Show Word256 where+    show w = Prelude.show (toNatural w)+instance Enum Word256 where+    toEnum i = Word256 0 0 0 $ int64ToWord64 (intToInt64 i)+    fromEnum (Word256 _ _ _ a0) = wordToInt (word64ToWord a0)+    succ (Word256 a3 a2 a1 a0)+        | a0 == maxBound =+            if a1 == maxBound+                then if a2 == maxBound+                        then Word256 (succ a3) 0 0 0+                        else Word256 a3 (succ a2) 0 0+                else Word256 a3 a2 (succ a1) 0+        | otherwise      = Word256 a3 a2 a1        (succ a0)+    pred (Word256 a3 a2 a1 a0)+        | a0 == minBound =+            if a1 == minBound+                then if a2 == minBound+                        then Word256 (pred a3) maxBound maxBound maxBound+                        else Word256 a3 (pred a2) maxBound maxBound+                else Word256 a3 a2 (pred a1) maxBound+        | otherwise      = Word256 a3 a2 a1        (pred a0)+instance Bounded Word256 where+    minBound = Word256 minBound minBound minBound minBound+    maxBound = Word256 maxBound maxBound maxBound maxBound+instance Ord Word256 where+    compare (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) =+        compareEq a3 b3 $ compareEq a2 b2 $ compareEq a1 b1 $ compare a0 b0+      where compareEq x y next =+                case compare x y of+                    EQ -> next+                    r  -> r+    (<) (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) =+        compareLt a3 b3 $ compareLt a2 b2 $ compareLt a1 b1 (a0 < b0)+      where compareLt x y next =+                case compare x y of+                    EQ -> next+                    r  -> r == LT+instance Storable Word256 where+    sizeOf _ = 32+    alignment _ = 32+    peek p = Word256 <$> peek (castPtr p            )+                     <*> peek (castPtr p `plusPtr` 8)+                     <*> peek (castPtr p `plusPtr` 16)+                     <*> peek (castPtr p `plusPtr` 24)+    poke p (Word256 a3 a2 a1 a0) = do+        poke (castPtr p             ) a3+        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+    negate = complement++instance IsIntegral Word256 where+    toInteger (Word256 a3 a2 a1 a0) =+        (toInteger a3 `Bits.unsafeShiftL` 192) Bits..|.+        (toInteger a2 `Bits.unsafeShiftL` 128) Bits..|.+        (toInteger a1 `Bits.unsafeShiftL` 64) Bits..|.+        toInteger a0+instance IsNatural Word256 where+    toNatural (Word256 a3 a2 a1 a0) =+        (toNatural a3 `Bits.unsafeShiftL` 192) Bits..|.+        (toNatural a2 `Bits.unsafeShiftL` 128) Bits..|.+        (toNatural a1 `Bits.unsafeShiftL` 64) Bits..|.+        toNatural a0++instance Prelude.Num Word256 where+    abs w = w+    signum w@(Word256 a3 a2 a1 a0)+        | a3 == 0 && a2 == 0 && a1 == 0 && a0 == 0 = w+        | otherwise                                = Word256 0 0 0 1+    fromInteger = literal+    (+) = (+)+    (-) = (-)+    (*) = (*)++instance Bits.Bits Word256 where+    (.&.) = bitwiseAnd+    (.|.) = bitwiseOr+    xor   = bitwiseXor+    complement = complement+    shiftL = shiftL+    shiftR = shiftR+    rotateL = rotateL+    rotateR = rotateR+    bitSize _ = 256+    bitSizeMaybe _ = Just 256+    isSigned _ = False+    testBit = testBit+    bit = bit+    popCount = popCount++-- | Add 2 Word256+(+) :: Word256 -> Word256 -> Word256+#if WORD_SIZE_IN_BITS < 64+(+) = applyBiWordOnNatural (Prelude.+)+#else+(+) (Word256 (W64# a3) (W64# a2) (W64# a1) (W64# a0))+    (Word256 (W64# b3) (W64# b2) (W64# b1) (W64# b0)) =+    Word256 (W64# s3) (W64# s2) (W64# s1) (W64# s0)+  where+    !(# c0, s0 #) = plusWord2# a0 b0+    !(# c1, s1 #) = plusWord3# a1 b1 c0+    !(# c2, s2 #) = plusWord3# a2 b2 c1+    !s3           = plusWord3NoCarry# a3 b3 c2++    plusWord3NoCarry# a b c = plusWord# (plusWord# a b) c+    plusWord3# a b c+        | bool# (eqWord# carry 0##) = plusWord2# x c+        | otherwise                 =+            case plusWord2# x c of+                (# carry2, x' #)+                    | bool# (eqWord# carry2 0##) -> (# carry, x' #)+                    | otherwise                  -> (# plusWord# carry carry2, x' #)+      where+        (# carry, x #) = plusWord2# a b+#endif++-- temporary available until native operation available+applyBiWordOnNatural :: (Natural -> Natural -> Natural)+                     -> Word256+                     -> Word256+                     -> Word256+applyBiWordOnNatural f = (fromNatural .) . (f `on` toNatural)++-- | Subtract 2 Word256+(-) :: Word256 -> Word256 -> Word256+(-) a b+    | a >= b    = applyBiWordOnNatural (Prelude.-) a b+    | otherwise = complement $ applyBiWordOnNatural (Prelude.-) b a++-- | Multiplication+(*) :: Word256 -> Word256 -> Word256+(*) = applyBiWordOnNatural (Prelude.*)++-- | Division+quot :: Word256 -> Word256 -> Word256+quot = applyBiWordOnNatural Prelude.quot++-- | Modulo+rem :: Word256 -> Word256 -> Word256+rem = applyBiWordOnNatural Prelude.rem++-- | Bitwise and+bitwiseAnd :: Word256 -> Word256 -> Word256+bitwiseAnd (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) =+    Word256 (a3 Bits..&. b3) (a2 Bits..&. b2)  (a1 Bits..&. b1) (a0 Bits..&. b0)++-- | Bitwise or+bitwiseOr :: Word256 -> Word256 -> Word256+bitwiseOr (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) =+    Word256 (a3 Bits..|. b3) (a2 Bits..|. b2)  (a1 Bits..|. b1) (a0 Bits..|. b0)++-- | Bitwise xor+bitwiseXor :: Word256 -> Word256 -> Word256+bitwiseXor (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) =+    Word256 (a3 `Bits.xor` b3) (a2 `Bits.xor` b2)  (a1 `Bits.xor` b1) (a0 `Bits.xor` b0)++-- | Bitwise complement+complement :: Word256 -> Word256+complement (Word256 a3 a2 a1 a0) =+    Word256 (Bits.complement a3) (Bits.complement a2) (Bits.complement a1) (Bits.complement a0)++-- | Population count+popCount :: Word256 -> Int+popCount (Word256 a3 a2 a1 a0) =+    Bits.popCount a3 Prelude.++    Bits.popCount a2 Prelude.++    Bits.popCount a1 Prelude.++    Bits.popCount a0++-- | Bitwise Shift Left+shiftL :: Word256 -> Int -> Word256+shiftL w@(Word256 a3 a2 a1 a0) n+    | n < 0 || n > 255 = Word256 0 0 0 0+    | n == 0           = w+    | n == 64          = Word256 a2 a1 a0 0+    | n == 128         = Word256 a1 a0 0 0+    | n == 192         = Word256 a0 0 0 0+    | n < 64           = mkWordShift a3 a2 a1 a0 n+    | n < 128          = mkWordShift a2 a1 a0 0  (n Prelude.- 64)+    | n < 192          = mkWordShift a1 a0 0  0  (n Prelude.- 128)+    | otherwise        = mkWordShift a0 0  0  0  (n Prelude.- 192)+  where+    mkWordShift :: Word64 -> Word64 -> Word64 -> Word64 -> Int -> Word256+    mkWordShift w x y z s =+        Word256 (comb64 w s x s') (comb64 x s y s') (comb64 y s z s') (z `Bits.unsafeShiftL` s)+      where s' = inv64 s++-- | Bitwise Shift Right+shiftR :: Word256 -> Int -> Word256+shiftR w@(Word256 a3 a2 a1 a0) n+    | n < 0 || n > 255 = Word256 0 0 0 0+    | n == 0           = w+    | n == 64          = Word256 0 a3 a2 a1+    | n == 128         = Word256 0 0 a3 a2+    | n == 192         = Word256 0 0 0 a3+    | n <  64          = mkWordShift a3 a2 a1 a0 n+    | n < 128          = mkWordShift  0 a3 a2 a1 (n Prelude.- 64)+    | n < 192          = mkWordShift  0  0 a3 a2 (n Prelude.- 128)+    | otherwise        = Word256 0 0 0 (a3 `Bits.unsafeShiftR` (n Prelude.- 192))+  where+    mkWordShift :: Word64 -> Word64 -> Word64 -> Word64 -> Int -> Word256+    mkWordShift w x y z s =+        Word256 (w `Bits.unsafeShiftR` s) (comb64 w s' x s) (comb64 x s' y s) (comb64 y s' z s)+      where s' = inv64 s++-- | Bitwise rotate Left+rotateL :: Word256 -> Int -> Word256+rotateL (Word256 a3 a2 a1 a0) n'+    | n == 0    = Word256 a3 a2 a1 a0+    | n == 192  = Word256 a0 a3 a2 a1+    | n == 128  = Word256 a1 a0 a3 a2+    | n == 64   = Word256 a2 a1 a0 a3+    | n < 64    = Word256 (comb64 a3 n a2 (inv64 n)) (comb64 a2 n a1 (inv64 n))+                          (comb64 a1 n a0 (inv64 n)) (comb64 a0 n a3 (inv64 n))+    | n < 128   = let n = n Prelude.- 64 in Word256+                          (comb64 a2 n a1 (inv64 n)) (comb64 a1 n a0 (inv64 n))+                          (comb64 a0 n a3 (inv64 n)) (comb64 a3 n a2 (inv64 n))+    | n < 192   = let n = n Prelude.- 128 in Word256+                          (comb64 a1 n a0 (inv64 n)) (comb64 a0 n a3 (inv64 n))+                          (comb64 a3 n a2 (inv64 n)) (comb64 a2 n a1 (inv64 n))+    | otherwise = let n = n Prelude.- 192 in Word256+                          (comb64 a0 n a3 (inv64 n)) (comb64 a3 n a2 (inv64 n))+                          (comb64 a2 n a1 (inv64 n)) (comb64 a1 n a0 (inv64 n))+  where+    n :: Int+    n | n' >= 0   = n' `Prelude.mod` 256+      | otherwise = 256 Prelude.- (n' `Prelude.mod` 256)++-- | Bitwise rotate Left+rotateR :: Word256 -> Int -> Word256+rotateR w n = rotateL w (256 Prelude.- n)++inv64 :: Int -> Int+inv64 i = 64 Prelude.- i++comb64 :: Word64 -> Int -> Word64 -> Int -> Word64+comb64 x i y j =+    (x `Bits.unsafeShiftL` i) .|. (y `Bits.unsafeShiftR` j)++-- | Test bit+testBit :: Word256 -> Int -> Bool+testBit (Word256 a3 a2 a1 a0) n+    | n < 0 || n > 255 = False+    | n > 191          = Bits.testBit a3 (n Prelude.- 192)+    | n > 127          = Bits.testBit a2 (n Prelude.- 128)+    | n > 63           = Bits.testBit a1 (n Prelude.- 64)+    | otherwise        = Bits.testBit a0 n++-- | bit+bit :: Int -> Word256+bit n+    | n < 0 || n > 255 = Word256 0 0 0 0+    | n > 191          = Word256 (Bits.bit (n Prelude.- 192)) 0 0 0+    | n > 127          = Word256 0 (Bits.bit (n Prelude.- 128)) 0 0+    | n > 63           = Word256 0 0 (Bits.bit (n Prelude.- 64)) 0+    | otherwise        = Word256 0 0 0 (Bits.bit n)++literal :: Integer -> Word256+literal i = Word256+    (Prelude.fromInteger (i `Bits.unsafeShiftR` 192))+    (Prelude.fromInteger (i `Bits.unsafeShiftR` 128))+    (Prelude.fromInteger (i `Bits.unsafeShiftR` 64))+    (Prelude.fromInteger i)++fromNatural :: Natural -> Word256+fromNatural n = Word256+    (Prelude.fromInteger (naturalToInteger n `Bits.unsafeShiftR` 192))+    (Prelude.fromInteger (naturalToInteger n `Bits.unsafeShiftR` 128))+    (Prelude.fromInteger (naturalToInteger n `Bits.unsafeShiftR` 64))+    (Prelude.fromInteger $ naturalToInteger n)

@@ -29,6 +29,7 @@     , thaw     , unsafeThaw     -- * Creation+    , vFromListN     , new     , create     , createFromIO@@ -39,7 +40,8 @@     , withMutablePtr     , unsafeFreezeShrink     , freezeShrink-    , unsafeSlide+    , fromBlock+    , toBlock     -- * accessors     , update     , unsafeUpdate@@ -68,12 +70,14 @@     , revSplitAt     , splitOn     , break+    , breakEnd     , breakElem     , breakLine     , elem     , indices     , intersperse     , span+    , spanEnd     , cons     , snoc     , uncons@@ -118,9 +122,10 @@ import           Basement.PrimType import           Basement.FinalPtr import           Basement.Exception-import           Basement.Utils import           Basement.UArray.Base import           Basement.Block (Block(..), MutableBlock(..))+import qualified Basement.Block as BLK+import qualified Basement.Block.Base as BLK (touch, unsafeWrite) import           Basement.UArray.Mutable hiding (sub, copyToPtr) import           Basement.Numerical.Additive import           Basement.Numerical.Subtractive@@ -129,23 +134,8 @@ import           Basement.Bindings.Memory (sysHsMemFindByteBa, sysHsMemFindByteAddr) import qualified Basement.Compat.ExtList as List import qualified Basement.Base16 as Base16-import qualified Basement.UArray.BA as PrimBA-import qualified Basement.UArray.Addr as PrimAddr---- | Copy every cells of an existing array to a new array-copy :: PrimType ty => UArray ty -> UArray ty-copy array = runST (thaw array >>= unsafeFreeze)---- | Thaw an array to a mutable array.------ the array is not modified, instead a new mutable array is created--- and every values is copied, before returning the mutable array.-thaw :: (PrimMonad prim, PrimType ty) => UArray ty -> prim (MUArray ty (PrimState prim))-thaw array = do-    ma <- new (length array)-    unsafeCopyAtRO ma azero array (Offset 0) (length array)-    pure ma-{-# INLINE thaw #-}+import qualified Basement.Alg.Native.PrimArray as PrimBA+import qualified Basement.Alg.Foreign.PrimArray as PrimAddr  -- | Return the element at a specific index from an array. --@@ -170,6 +160,14 @@ fromForeignPtr (fptr, ofs, len) = UArray (Offset ofs) (CountOf len) (UArrayAddr $ toFinalPtrForeign fptr)  +-- | Create a UArray from a Block+--+-- The block is still used by the uarray+fromBlock :: PrimType ty+          => Block ty+          -> UArray ty+fromBlock blk = UArray 0 (BLK.length blk) (UArrayBA blk)+ -- | Allocate a new array with a fill function that has access to the elements of --   the source array. unsafeCopyFrom :: (PrimType a, PrimType b)@@ -198,15 +196,6 @@     copyAt ma' (Offset 0) ma (Offset 0) n     unsafeFreeze ma' -unsafeSlide :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> Offset ty -> Offset ty -> prim ()-unsafeSlide mua s e = doSlide mua s e-  where-    doSlide :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> Offset ty -> Offset ty -> prim ()-    doSlide (MUArray mbStart _ (MUArrayMBA (MutableBlock mba))) start end  =-        primMutableByteArraySlideToStart mba (offsetInBytes $ mbStart+start) (offsetInBytes end)-    doSlide (MUArray mbStart _ (MUArrayAddr fptr)) start end = withFinalPtr fptr $ \(Ptr addr) ->-        primMutableAddrSlideToStart addr (offsetInBytes $ mbStart+start) (offsetInBytes end)- -- | Create a new array of size @n by settings each cells through the -- function @f. create :: forall ty . PrimType ty@@ -304,7 +293,7 @@         -> prim a withPtr a f     | isPinned a == Pinned =-        onBackendPrim (\ba -> f (Ptr (byteArrayContents# ba) `plusPtr` os))+        onBackendPrim (\ba -> f (Ptr (byteArrayContents# ba) `plusPtr` os) <* BLK.touch (Block ba))                       (\fptr -> withFinalPtr fptr $ \ptr -> f (ptr `plusPtr` os))                       a     | otherwise = do@@ -312,9 +301,7 @@             trampoline <- newPinned (length a)             unsafeCopyAtRO trampoline 0 a 0 (length a)             unsafeFreeze trampoline-        r <- withPtr arr f-        touch arr-        pure r+        withPtr arr f   where     !sz          = primSizeInBytes (Proxy :: Proxy ty)     !(Offset os) = offsetOfE sz $ offset a@@ -377,6 +364,7 @@                                                    ,UArray (start `offsetPlusE` nbElems) nbTails backend)     | otherwise                                  = (arr, empty) + breakElem :: PrimType ty => ty -> UArray ty -> (UArray ty, UArray ty) breakElem !ty arr@(UArray start len backend)     | k == end   = (arr, empty)@@ -505,7 +493,18 @@ {-# SPECIALIZE [3] revFindIndex :: Word8 -> UArray Word8 -> Maybe (Offset Word8) #-}  break :: forall ty . PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty)-break xpredicate xv+break predicate arr+    | k == end  = (arr, mempty)+    | otherwise = splitAt (offsetAsSize (k `offsetSub` start)) arr+  where+    !k = onBackend goBa (\_ -> pure . goAddr) arr+    !start = offset arr+    !end = start `offsetPlusE` length arr+    goBa ba = PrimBA.findIndexPredicate predicate ba start end+    goAddr (Ptr addr) = PrimAddr.findIndexPredicate predicate addr start end++{-+{-# SPECIALIZE [3] findIndex :: Word8 -> UArray Word8 -> Maybe (Offset Word8) #-}     | len == 0  = (mempty, mempty)     | otherwise = runST $ unsafeIndexer xv (go xv xpredicate)   where@@ -519,6 +518,7 @@             | otherwise            = findBreak (i + Offset 1)         {-# INLINE findBreak #-}     {-# INLINE go #-}+    -} {-# NOINLINE [2] break #-} {-# SPECIALIZE [2] break :: (Word8 -> Bool) -> UArray Word8 -> (UArray Word8, UArray Word8) #-} @@ -528,6 +528,22 @@ {-# RULES "break (== ty)" [3] forall (x :: Word8) . break (== x) = breakElem x #-} -} +-- | Similar to break but start the search of the breakpoint from the end+--+-- > breakEnd (> 0) [1,2,3,0,0,0]+-- ([1,2,3], [0,0,0])+breakEnd :: forall ty . PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty)+breakEnd predicate arr+    | k == end  = (arr, mempty)+    | otherwise = splitAt (offsetAsSize (k+1) `sizeSub` offsetAsSize start) arr+  where+    !k = onBackend goBa (\_ -> pure . goAddr) arr+    !start = offset arr+    !end   = start `offsetPlusE` length arr+    goBa ba = PrimBA.revFindIndexPredicate predicate ba start end+    goAddr (Ptr addr) = PrimAddr.revFindIndexPredicate predicate addr start end+{-# SPECIALIZE [3] breakEnd :: (Word8 -> Bool) -> UArray Word8 -> (UArray Word8, UArray Word8) #-}+ elem :: PrimType ty => ty -> UArray ty -> Bool elem !ty arr = onBackend goBa (\_ -> pure . goAddr) arr /= end   where@@ -558,6 +574,9 @@ span :: PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty) span p = break (not . p) +spanEnd :: PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty)+spanEnd p = breakEnd (not . p)+ map :: (PrimType a, PrimType b) => (a -> b) -> UArray a -> UArray b map f a = create lenB (\i -> f $ unsafeIndex a (offsetCast Proxy i))   where !lenB = sizeCast (Proxy :: Proxy (a -> b)) (length a)@@ -611,45 +630,24 @@              in if predicate e then Just e else loop (i+1)  sortBy :: forall ty . PrimType ty => (ty -> ty -> Ordering) -> UArray ty -> UArray ty-sortBy xford vec-    | len == 0  = mempty-    | otherwise = runST (thaw vec >>= doSort xford)+sortBy ford vec = runST $ do+    mvec <- thaw vec+    onMutableBackend goNative (\fptr -> withFinalPtr fptr goAddr) mvec+    unsafeFreeze mvec   where-    len = length vec-    doSort :: (PrimType ty, PrimMonad prim) => (ty -> ty -> Ordering) -> MUArray ty (PrimState prim) -> prim (UArray ty)-    doSort ford ma = qsort 0 (sizeLastOffset len) >> unsafeFreeze ma-      where-        qsort lo hi-            | lo >= hi  = pure ()-            | otherwise = do-                p <- partition lo hi-                qsort lo (pred p)-                qsort (p+1) hi-        partition lo hi = do-            pivot <- unsafeRead ma hi-            let loop i j-                    | j == hi   = pure i-                    | otherwise = do-                        aj <- unsafeRead ma j-                        i' <- if ford aj pivot == GT-                                then pure i-                                else do-                                    ai <- unsafeRead ma i-                                    unsafeWrite ma j ai-                                    unsafeWrite ma i aj-                                    pure $ i + 1-                        loop i' (j+1)+    !len = length vec+    !end = 0 `offsetPlusE` len+    !start = offset vec -            i <- loop lo lo-            ai  <- unsafeRead ma i-            ahi <- unsafeRead ma hi-            unsafeWrite ma hi ai-            unsafeWrite ma i ahi-            pure i+    goNative :: MutableByteArray# (PrimState (ST s)) -> ST s ()+    goNative mba = PrimBA.inplaceSortBy ford mba start end+    goAddr :: Ptr ty -> ST s ()+    goAddr (Ptr addr) = PrimAddr.inplaceSortBy ford addr start end+{-# SPECIALIZE [3] sortBy :: (Word8 -> Word8 -> Ordering) -> UArray Word8 -> UArray Word8 #-}  filter :: forall ty . PrimType ty => (ty -> Bool) -> UArray ty -> UArray ty filter predicate arr = runST $ do-    (newLen, ma) <- newNative (length arr) $ \mba ->+    (newLen, ma) <- newNative (length arr) $ \(MutableBlock mba) ->             onBackendPrim (\ba -> PrimBA.filter predicate mba ba start end)                           (\fptr -> withFinalPtr fptr $ \(Ptr addr) ->                                         PrimAddr.filter predicate mba addr start end)@@ -660,7 +658,7 @@     !start = offset arr     !end   = start `offsetPlusE` len -reverse :: PrimType ty => UArray ty -> UArray ty+reverse :: forall ty . PrimType ty => UArray ty -> UArray ty reverse a     | len == 0  = mempty     | otherwise = runST $ do@@ -674,18 +672,18 @@     !start = offset a     !endI = sizeAsOffset ((start + end) - Offset 1) -    goNative :: MutableByteArray# s -> ByteArray# -> ST s ()+    goNative :: MutableBlock ty s -> ByteArray# -> ST s ()     goNative !ma !ba = loop 0       where         loop !i             | i == end  = pure ()-            | otherwise = primMbaWrite ma i (primBaIndex ba (sizeAsOffset (endI - i))) >> loop (i+1)-    goAddr :: MutableByteArray# s -> Ptr ty -> ST s ()+            | otherwise = BLK.unsafeWrite ma i (primBaIndex ba (sizeAsOffset (endI - i))) >> loop (i+1)+    goAddr :: MutableBlock ty s -> Ptr ty -> ST s ()     goAddr !ma (Ptr addr) = loop 0       where         loop !i             | i == end  = pure ()-            | otherwise = primMbaWrite ma i (primAddrIndex addr (sizeAsOffset (endI - i))) >> loop (i+1)+            | otherwise = BLK.unsafeWrite ma i (primAddrIndex addr (sizeAsOffset (endI - i))) >> loop (i+1) {-# SPECIALIZE [3] reverse :: UArray Word8 -> UArray Word8 #-}  -- Finds where are the insertion points when we search for a `needle`

@@ -1,114 +0,0 @@-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE MagicHash                  #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE ExistentialQuantification  #-}-{-# LANGUAGE CPP                        #-}-module Basement.UArray.Addr-    ( findIndexElem-    , revFindIndexElem-    , findIndexPredicate-    , foldl-    , foldr-    , foldl1-    , all-    , any-    , filter-    , primIndex-    ) where--import           GHC.Types-import           GHC.Prim-import           Basement.Compat.Base-import           Basement.Numerical.Additive-import           Basement.Types.OffsetSize-import           Basement.PrimType-import           Basement.Monad--type Immutable = Addr#--primIndex :: PrimType ty => Immutable -> Offset ty -> ty-primIndex = primAddrIndex--findIndexElem :: PrimType ty => ty -> Immutable -> Offset ty -> Offset ty -> Offset ty-findIndexElem ty ba startIndex endIndex = loop startIndex-  where-    loop !i-        | i < endIndex && t /= ty = loop (i+1)-        | otherwise               = i-      where t = primIndex ba i-{-# INLINE findIndexElem #-}--revFindIndexElem :: PrimType ty => ty -> Immutable -> Offset ty -> Offset ty -> Offset ty-revFindIndexElem ty ba startIndex endIndex-    | endIndex > startIndex = loop (endIndex `offsetMinusE` 1)-    | otherwise             = endIndex-  where-    loop !i-        | t == ty        = i-        | i > startIndex = loop (i `offsetMinusE` 1)-        | otherwise      = endIndex-      where t = primIndex ba i-{-# INLINE revFindIndexElem #-}--findIndexPredicate :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Offset ty-findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex-  where-    loop !i-        | i < endIndex && not found = loop (i+1)-        | otherwise                 = i-      where found = predicate (primIndex ba i)-{-# INLINE findIndexPredicate #-}--foldl :: PrimType ty => (a -> ty -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a-foldl f !initialAcc ba !startIndex !endIndex = loop startIndex initialAcc-  where-    loop !i !acc-        | i == endIndex = acc-        | otherwise     = loop (i+1) (f acc (primIndex ba i))-{-# INLINE foldl #-}--foldr :: PrimType ty => (ty -> a -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a-foldr f !initialAcc ba startIndex endIndex = loop startIndex-  where-    loop !i-        | i == endIndex = initialAcc-        | otherwise     = primIndex ba i `f` loop (i+1)-{-# INLINE foldr #-}--foldl1 :: PrimType ty => (ty -> ty -> ty) -> Immutable -> Offset ty -> Offset ty -> ty-foldl1 f ba startIndex endIndex = loop (startIndex+1) (primIndex ba startIndex)-  where-    loop !i !acc-        | i == endIndex = acc-        | otherwise     = loop (i+1) (f acc (primIndex ba i))-{-# INLINE foldl1 #-}--filter :: (PrimMonad prim, PrimType ty)-       => (ty -> Bool) -> MutableByteArray# (PrimState prim) -> Immutable -> Offset ty -> Offset ty -> prim (CountOf ty)-filter predicate dst src start end = loop azero start-  where-    loop !d !s-        | s == end    = pure (offsetAsSize d)-        | predicate v = primMbaWrite dst d v >> loop (d+Offset 1) (s+Offset 1)-        | otherwise   = loop d (s+Offset 1)-      where-        v = primIndex src s--all :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool-all predicate ba start end = loop start-  where-    loop !i-        | i == end                   = True-        | predicate (primIndex ba i) = loop (i+1)-        | otherwise                  = False-{-# INLINE all #-}--any :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool-any predicate ba start end = loop start-  where-    loop !i-        | i == end                   = False-        | predicate (primIndex ba i) = True-        | otherwise                  = loop (i+1)-{-# INLINE any #-}

@@ -1,113 +0,0 @@-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE MagicHash                  #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE CPP                        #-}-module Basement.UArray.BA-    ( findIndexElem-    , revFindIndexElem-    , findIndexPredicate-    , foldl-    , foldr-    , foldl1-    , all-    , any-    , filter-    , primIndex-    ) where--import           GHC.Types-import           GHC.Prim-import           Basement.Compat.Base-import           Basement.Numerical.Additive-import           Basement.Types.OffsetSize-import           Basement.PrimType-import           Basement.Monad--type Immutable = ByteArray#--primIndex :: PrimType ty => Immutable -> Offset ty -> ty-primIndex = primBaIndex--findIndexElem :: PrimType ty => ty -> Immutable -> Offset ty -> Offset ty -> Offset ty-findIndexElem ty ba startIndex endIndex = loop startIndex-  where-    loop !i-        | i < endIndex && t /= ty = loop (i+1)-        | otherwise               = i-      where t = primIndex ba i-{-# INLINE findIndexElem #-}--revFindIndexElem :: PrimType ty => ty -> Immutable -> Offset ty -> Offset ty -> Offset ty-revFindIndexElem ty ba startIndex endIndex-    | endIndex > startIndex = loop (endIndex `offsetMinusE` 1)-    | otherwise             = endIndex-  where-    loop !i-        | t == ty        = i-        | i > startIndex = loop (i `offsetMinusE` 1)-        | otherwise      = endIndex-      where t = primIndex ba i-{-# INLINE revFindIndexElem #-}--findIndexPredicate :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Offset ty-findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex-  where-    loop !i-        | i < endIndex && not found = loop (i+1)-        | otherwise                 = i-      where found = predicate (primIndex ba i)-{-# INLINE findIndexPredicate #-}--foldl :: PrimType ty => (a -> ty -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a-foldl f !initialAcc ba !startIndex !endIndex = loop startIndex initialAcc-  where-    loop !i !acc-        | i == endIndex = acc-        | otherwise     = loop (i+1) (f acc (primIndex ba i))-{-# INLINE foldl #-}--foldr :: PrimType ty => (ty -> a -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a-foldr f !initialAcc ba startIndex endIndex = loop startIndex-  where-    loop !i-        | i == endIndex = initialAcc-        | otherwise     = primIndex ba i `f` loop (i+1)-{-# INLINE foldr #-}--foldl1 :: PrimType ty => (ty -> ty -> ty) -> Immutable -> Offset ty -> Offset ty -> ty-foldl1 f ba startIndex endIndex = loop (startIndex+1) (primIndex ba startIndex)-  where-    loop !i !acc-        | i == endIndex = acc-        | otherwise     = loop (i+1) (f acc (primIndex ba i))-{-# INLINE foldl1 #-}--filter :: (PrimMonad prim, PrimType ty)-       => (ty -> Bool) -> MutableByteArray# (PrimState prim) -> Immutable -> Offset ty -> Offset ty -> prim (CountOf ty)-filter predicate dst src start end = loop azero start-  where-    loop !d !s-        | s == end    = pure (offsetAsSize d)-        | predicate v = primMbaWrite dst d v >> loop (d+Offset 1) (s+Offset 1)-        | otherwise   = loop d (s+Offset 1)-      where-        v = primIndex src s--all :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool-all predicate ba start end = loop start-  where-    loop !i-        | i == end                   = True-        | predicate (primIndex ba i) = loop (i+1)-        | otherwise                  = False-{-# INLINE all #-}--any :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool-any predicate ba start end = loop start-  where-    loop !i-        | i == end                   = False-        | predicate (primIndex ba i) = True-        | otherwise                  = loop (i+1)-{-# INLINE any #-}

@@ -22,6 +22,8 @@     , unsafeFreezeShrink     , unsafeFreeze     , unsafeThaw+    , thaw+    , copy     -- * Array accessor     , unsafeIndex     , unsafeIndexer@@ -31,6 +33,7 @@     , unsafeDewrap     , unsafeDewrap2     -- * Basic lowlevel functions+    , vFromListN     , empty     , length     , offset@@ -42,6 +45,7 @@     , copyAt     , unsafeCopyAtRO     , touch+    , toBlock     -- * temporary     , pureST     ) where@@ -118,6 +122,7 @@ instance PrimType ty => IsList (UArray ty) where     type Item (UArray ty) = ty     fromList = vFromList+    fromListN len = vFromListN (CountOf len)     toList = vToList  length :: UArray ty -> CountOf ty@@ -158,11 +163,11 @@  newNative :: (PrimMonad prim, PrimType ty)           => CountOf ty-          -> (MutableByteArray# (PrimState prim) -> prim a) -- ^ move to a MutableBlock+          -> (MutableBlock ty (PrimState prim) -> prim a)           -> prim (a, MUArray ty (PrimState prim)) newNative n f = do-    mb@(MutableBlock mba) <- MBLK.new n-    a <- f mba+    mb <- MBLK.new n+    a  <- f mb     pure (a, MUArray 0 n (MUArrayMBA mb))  -- | Create a new mutable array of size @n.@@ -238,6 +243,22 @@ unsafeThaw (UArray start len (UArrayAddr fptr)) = pure $ MUArray start len (MUArrayAddr fptr) {-# INLINE unsafeThaw #-} +-- | Thaw an array to a mutable array.+--+-- the array is not modified, instead a new mutable array is created+-- and every values is copied, before returning the mutable array.+thaw :: (PrimMonad prim, PrimType ty) => UArray ty -> prim (MUArray ty (PrimState prim))+thaw array = do+    ma <- new (length array)+    unsafeCopyAtRO ma azero array (Offset 0) (length array)+    pure ma+{-# INLINE thaw #-}++-- | Copy every cells of an existing array to a new array+copy :: PrimType ty => UArray ty -> UArray ty+copy array = runST (thaw array >>= unsafeFreeze)++ onBackend :: (ByteArray# -> a)           -> (FinalPtr ty -> Ptr ty -> ST s a)           -> UArray ty@@ -292,15 +313,41 @@ pureST = pure  -- | make an array from a list of elements.-vFromList :: PrimType ty => [ty] -> UArray ty+vFromList :: forall ty . PrimType ty => [ty] -> UArray ty vFromList l = runST $ do-    ma <- new (CountOf len)-    iter azero l $ \i x -> unsafeWrite ma i x+    ((), ma) <- newNative (CountOf len) copyList     unsafeFreeze ma-  where len = List.length l-        iter _  []     _ = return ()-        iter !i (x:xs) z = z i x >> iter (i+1) xs z+  where+    len = List.length l+    copyList :: MutableBlock ty s -> ST s ()+    copyList mb = loop 0 l+      where+        loop _  []     = pure ()+        loop !i (x:xs) = MBLK.unsafeWrite mb i x >> loop (i+1) xs +-- | Make an array from a list of elements with a size hint.+--+-- The list should be of the same size as the hint, as otherwise:+--+-- * The length of the list is smaller than the hint:+--    the array allocated is of the size of the hint, but is sliced+--    to only represent the valid bits+-- * The length of the list is bigger than the hint:+--    The allocated array is the size of the hint, and the list is truncated to+--    fit.+vFromListN :: forall ty . PrimType ty => CountOf ty -> [ty] -> UArray ty+vFromListN len l = runST $ do+    (sz, ma) <- newNative len copyList+    unsafeFreezeShrink ma sz+  where+    copyList :: MutableBlock ty s -> ST s (CountOf ty)+    copyList mb = loop 0 l+      where+        loop !i  []     = pure (offsetAsSize i)+        loop !i (x:xs)+            | i .==# len = pure (offsetAsSize i)+            | otherwise  = MBLK.unsafeWrite mb i x >> loop (i+1) xs+ -- | transform an array to a list. vToList :: forall ty . PrimType ty => UArray ty -> [ty] vToList a@@ -548,3 +595,14 @@ touch :: PrimMonad prim => UArray ty -> prim () touch (UArray _ _ (UArrayBA blk))    = BLK.touch blk touch (UArray _ _ (UArrayAddr fptr)) = touchFinalPtr fptr++-- | Create a Block from a UArray.+--+-- Note that because of the slice, the destination block+-- is re-allocated and copied, unless the slice point+-- at the whole array+toBlock :: PrimType ty => UArray ty -> Block ty+toBlock arr@(UArray start len (UArrayBA blk))+    | start == 0 && BLK.length blk == len = blk+    | otherwise                           = toBlock $ copy arr+toBlock arr = toBlock $ copy arr

@@ -49,6 +49,7 @@ import           Basement.PrimType import           Basement.FinalPtr import           Basement.Exception+import qualified Basement.Block         as BLK import qualified Basement.Block.Mutable as MBLK import           Basement.Block         (MutableBlock(..)) import           Basement.UArray.Base hiding (empty)@@ -123,9 +124,9 @@   where     sz           = primSizeInBytes (Proxy :: Proxy ty)     !(Offset os) = offsetOfE sz start-withMutablePtrHint skipCopy skipCopyBack vec@(MUArray start vecSz (MUArrayMBA (MutableBlock a))) f-    | isMutablePinned vec == Pinned = mutableByteArrayContent a >>= \ptr -> f (ptr `plusPtr` os)-    | otherwise                     = do+withMutablePtrHint skipCopy skipCopyBack vec@(MUArray start vecSz (MUArrayMBA mb)) f+    | BLK.isMutablePinned mb == Pinned = MBLK.mutableWithAddr mb (\ptr -> f (ptr `plusPtr` os))+    | otherwise                        = do         trampoline <- newPinned vecSz         if not skipCopy             then copyAt trampoline 0 vec 0 vecSz@@ -138,11 +139,6 @@   where     !(Offset os) = offsetOfE sz start     sz           = primSizeInBytes (Proxy :: Proxy ty)--    mutableByteArrayContent :: PrimMonad prim => MutableByteArray# (PrimState prim) -> prim (Ptr ty)-    mutableByteArrayContent mba = primitive $ \s1 ->-        case unsafeFreezeByteArray# mba s1 of-            (# s2, ba #) -> (# s2, Ptr (byteArrayContents# ba) #)  -- | Create a pointer on the beginning of the mutable array -- and call a function 'f'.

@@ -1,245 +0,0 @@-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE MagicHash                  #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE CPP                        #-}-module Basement.UTF8.Addr-    ( Immutable-    , Mutable-    -- * functions-    , nextAscii-    , nextAsciiDigit-    , expectAscii-    , next-    , prev-    , prevSkip-    , write-    , toList-    , all-    , any-    , foldr-    , length-    -- temporary-    , primIndex-    , primIndex64-    , primRead-    , primWrite-    ) 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           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--type Immutable = Addr#-type Mutable (prim :: * -> *) = Addr#--primWrite :: PrimMonad prim => Mutable prim -> Offset Word8 -> Word8 -> prim ()-primWrite = primAddrWrite--primRead :: PrimMonad prim => Mutable prim -> Offset Word8 -> prim Word8-primRead = primAddrRead--primIndex :: Immutable -> Offset Word8 -> Word8-primIndex = primAddrIndex--primIndex64 :: Immutable -> Offset Word64 -> Word64-primIndex64 = primAddrIndex--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 (primIndex ba n - 0x30)-{-# INLINE nextAsciiDigit #-}--expectAscii :: Immutable -> Offset Word8 -> Word8 -> Bool-expectAscii ba n v = primIndex 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 (primIndex ba (n + Offset 1))) (n + Offset 2)-        2 -> Step (toChar3 h (primIndex ba (n + Offset 1))-                             (primIndex ba (n + Offset 2))) (n + Offset 3)-        3 -> Step (toChar4 h (primIndex ba (n + Offset 1))-                             (primIndex ba (n + Offset 2))-                             (primIndex 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 = primIndex ba n-{-# INLINE next #-}---- 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 primIndex 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 primIndex 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 primIndex 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 primIndex 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 (primIndex ba o) = loop (o `offsetMinusE` sz1)-        | otherwise                       = o--write :: PrimMonad prim => Mutable 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 = primWrite mba i (W8# x) >> pure (i + Offset 1)-    encode2 = do-        let x1  = or# (uncheckedShiftRL# x 6#) 0xc0##-            x2  = toContinuation x-        primWrite mba i     (W8# x1)-        primWrite 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-        primWrite mba i            (W8# x1)-        primWrite mba (i+Offset 1) (W8# x2)-        primWrite 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-        primWrite mba i            (W8# x1)-        primWrite mba (i+Offset 1) (W8# x2)-        primWrite mba (i+Offset 2) (W8# x3)-        primWrite 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    = primIndex 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    = primIndex dat i-                cont = (h .&. 0xc0) == 0x80-                c'   = if cont then c else c+1-             in processStart c' (i+1)-{-# INLINE length #-}

@@ -1,245 +0,0 @@-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE MagicHash                  #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE CPP                        #-}-module Basement.UTF8.BA-    ( Immutable-    , Mutable-    -- * functions-    , nextAscii-    , nextAsciiDigit-    , expectAscii-    , next-    , prev-    , prevSkip-    , write-    , toList-    , all-    , any-    , foldr-    , length-    -- temporary-    , primIndex-    , primIndex64-    , primRead-    , primWrite-    ) 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           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--type Immutable = ByteArray#-type Mutable prim = MutableByteArray# (PrimState prim)--primWrite :: PrimMonad prim => Mutable prim -> Offset Word8 -> Word8 -> prim ()-primWrite = primMbaWrite--primRead :: PrimMonad prim => Mutable prim -> Offset Word8 -> prim Word8-primRead = primMbaRead--primIndex :: Immutable -> Offset Word8 -> Word8-primIndex = primBaIndex--primIndex64 :: Immutable -> Offset Word64 -> Word64-primIndex64 = primBaIndex--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 (primIndex ba n - 0x30)-{-# INLINE nextAsciiDigit #-}--expectAscii :: Immutable -> Offset Word8 -> Word8 -> Bool-expectAscii ba n v = primIndex 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 (primIndex ba (n + Offset 1))) (n + Offset 2)-        2 -> Step (toChar3 h (primIndex ba (n + Offset 1))-                             (primIndex ba (n + Offset 2))) (n + Offset 3)-        3 -> Step (toChar4 h (primIndex ba (n + Offset 1))-                             (primIndex ba (n + Offset 2))-                             (primIndex 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 = primIndex ba n-{-# INLINE next #-}---- 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 primIndex 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 primIndex 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 primIndex 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 primIndex 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 (primIndex ba o) = loop (o `offsetMinusE` sz1)-        | otherwise                       = o--write :: PrimMonad prim => Mutable 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 = primWrite mba i (W8# x) >> pure (i + Offset 1)-    encode2 = do-        let x1  = or# (uncheckedShiftRL# x 6#) 0xc0##-            x2  = toContinuation x-        primWrite mba i     (W8# x1)-        primWrite 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-        primWrite mba i            (W8# x1)-        primWrite mba (i+Offset 1) (W8# x2)-        primWrite 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-        primWrite mba i            (W8# x1)-        primWrite mba (i+Offset 1) (W8# x2)-        primWrite mba (i+Offset 2) (W8# x3)-        primWrite 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    = primIndex 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    = primIndex dat i-                cont = (h .&. 0xc0) == 0x80-                c'   = if cont then c else c+1-             in processStart c' (i+1)-{-# INLINE length #-}

@@ -29,9 +29,11 @@ import           Basement.FinalPtr import           Basement.UTF8.Helper import           Basement.UTF8.Types-import qualified Basement.UTF8.BA       as PrimBA-import qualified Basement.UTF8.Addr     as PrimAddr+import qualified Basement.Alg.Native.UTF8      as PrimBA+import qualified Basement.Alg.Foreign.UTF8     as PrimAddr import           Basement.UArray           (UArray)+import           Basement.Block            (MutableBlock)+import qualified Basement.Block.Mutable    as BLK import qualified Basement.UArray           as Vec import qualified Basement.UArray           as C import qualified Basement.UArray.Mutable   as MVec@@ -115,16 +117,16 @@                         _    -> countAndCopy (count+2) (ofs+2)             _    -> countAndCopy (count+1) (ofs+1) -    copy :: CountOf Word8 -> MutableByteArray# st -> ST st ()+    copy :: CountOf Word8 -> MutableBlock Word8 st -> ST st ()     copy count mba = loop 0 0       where loop o i                 | o .==# count = pure ()                 | otherwise    =                     case primAddrIndex addr i of                         0xC0 -> case primAddrIndex addr (i+1) of-                                    0x80 -> primMbaUWrite mba o 0x00 >> loop (o+1) (i+2)-                                    b2   -> primMbaUWrite mba o 0xC0 >> primMbaUWrite mba (o+1) b2 >> loop (o+2) (i+2)-                        b1   -> primMbaUWrite mba o b1 >> loop (o+1) (i+1)+                                    0x80 -> BLK.unsafeWrite mba o 0x00 >> loop (o+1) (i+2)+                                    b2   -> BLK.unsafeWrite mba o 0xC0 >> BLK.unsafeWrite mba (o+1) b2 >> loop (o+2) (i+2)+                        b1   -> BLK.unsafeWrite mba o b1 >> loop (o+1) (i+1)   -- | Create a new String from a list of characters@@ -187,7 +189,7 @@  newNative :: PrimMonad prim           => CountOf Word8 -- ^ in number of bytes, not of elements.-          -> (MutableByteArray# (PrimState prim) -> prim a)+          -> (MutableBlock Word8 (PrimState prim) -> prim a)           -> prim (a, MutableString (PrimState prim)) newNative n f = second MutableString `fmap` MVec.newNative n f 

@@ -1,72 +0,0 @@--- |--- Module      : Basement.Utils--- License     : BSD-style--- Maintainer  : Vincent Hanquez <vincent@snarc.org>--- Stability   : experimental--- Portability : portable----{-# LANGUAGE MagicHash #-}-{-# LANGUAGE UnboxedTuples #-}-module Basement.Utils-    ( primCopyFreezedBytes-    , primCopyFreezedBytesOffset-    , primCopyFreezedW32-    , primCopyFreezedW64-    , primMutableAddrSlideToStart-    , primMutableByteArraySlideToStart-    ) where--import           Basement.Compat.Base-import           Basement.Types.OffsetSize-import           Basement.Compat.Primitive-import           Basement.Monad-import           GHC.Prim-import           GHC.Types---- | Copy all bytes from a byteArray# to a mutableByteArray#-primCopyFreezedBytes :: PrimMonad m => MutableByteArray# (PrimState m) -> ByteArray# -> m ()-primCopyFreezedBytes mba ba = primitive $ \st ->-    (# copyByteArray# ba 0# mba 0# (sizeofByteArray# ba) st , () #)-{-# INLINE primCopyFreezedBytes #-}---- | Copy @nbBytes bytes from a byteArray# to a mutableByteArray# starting at an offset-primCopyFreezedBytesOffset :: PrimMonad m => MutableByteArray# (PrimState m) -> Int# -> ByteArray# -> Int# -> m ()-primCopyFreezedBytesOffset mba ofs ba nbBytes = primitive $ \st ->-    (# copyByteArray# ba 0# mba ofs nbBytes st , () #)-{-# INLINE primCopyFreezedBytesOffset #-}---- | same as 'primCopyFreezedBytes' except copy using 32 bits word-primCopyFreezedW32 :: PrimMonad m => MutableByteArray# (PrimState m) -> ByteArray# -> m ()-primCopyFreezedW32 mba ba = primitive $ \st -> (# loop st 0#, () #)-  where-    !len = quotInt# (sizeofByteArray# ba) 8#-    loop !st !n-        | bool# (n ==# len) = st-        | otherwise         = loop (writeWord32Array# mba n (indexWord32Array# ba n) st) (n +# 1#)-    {-# INLINE loop #-}-{-# INLINE primCopyFreezedW32 #-}---- | same as 'primCopyFreezedBytes' except copy using 64 bits word-primCopyFreezedW64 :: PrimMonad m => MutableByteArray# (PrimState m) -> ByteArray# -> m ()-primCopyFreezedW64 mba ba = primitive $ \st -> (# loop st 0#, () #)-  where-    !len = quotInt# (sizeofByteArray# ba) 8#-    loop !st !n-        | bool# (n ==# len) = st-        | otherwise         = loop (writeWord64Array# mba n (indexWord64Array# ba n) st) (n +# 1#)-    {-# INLINE loop #-}-{-# INLINE primCopyFreezedW64 #-}--primMutableByteArraySlideToStart :: PrimMonad m => MutableByteArray# (PrimState m) -> Offset8 -> Offset8 -> m ()-primMutableByteArraySlideToStart mba (Offset (I# ofs)) (Offset (I# end)) = primitive $ \st ->-    (# copyMutableByteArray# mba 0# mba ofs (end -# ofs) st, () #)--primMutableAddrSlideToStart :: PrimMonad m => Addr# -> Offset8 -> Offset8 -> m ()-primMutableAddrSlideToStart addr (Offset (I# ofsIni)) (Offset (I# end)) = primitive $ \st -> (# loop st 0# ofsIni, () #)-  where-    loop !st !dst !ofs-        | bool# (ofs ==# end) = st-        | otherwise           =-            case readWord8OffAddr# addr ofs st of { (# st', v #) ->-            case writeWord8OffAddr# addr dst v st' of { st'' ->-                loop st'' (dst +# 1#) (ofs +# 1#) }}

@@ -1,5 +1,5 @@ name:                basement-version:             0.0.0+version:             0.0.1 synopsis:            Foundation scrap box of array & string description:         Foundation most basic primitives without any dependencies homepage:            https://github.com/haskell-foundation/foundation#readme@@ -39,6 +39,8 @@                      Basement.Types.OffsetSize                      Basement.Types.Ptr                      Basement.Types.AsciiString+                     Basement.Types.Word128+                     Basement.Types.Word256                      Basement.Monad                      Basement.MutableBuilder                      Basement.FinalPtr@@ -88,23 +90,27 @@                      Basement.Show                      Basement.Runtime -                     Basement.Utils+                     Basement.Alg.Native.Prim+                     Basement.Alg.Native.UTF8+                     Basement.Alg.Native.String+                     Basement.Alg.Native.PrimArray +                     Basement.Alg.Foreign.Prim+                     Basement.Alg.Foreign.UTF8+                     Basement.Alg.Foreign.String+                     Basement.Alg.Foreign.PrimArray++                     Basement.Numerical.Conversion+                      Basement.Block.Base -                     Basement.UTF8.Addr-                     Basement.UTF8.BA                      Basement.UTF8.Base                      Basement.UTF8.Helper                      Basement.UTF8.Table                      Basement.UTF8.Types -                     Basement.UArray.Addr-                     Basement.UArray.BA                      Basement.UArray.Base -                     Basement.String.BA-                     Basement.String.Addr                      Basement.String.Encoding.Encoding                      Basement.String.Encoding.UTF16                      Basement.String.Encoding.UTF32