diff --git a/Basement/Alg/Foreign/Prim.hs b/Basement/Alg/Foreign/Prim.hs deleted file mode 100644 --- a/Basement/Alg/Foreign/Prim.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE MagicHash #-} -module Basement.Alg.Foreign.Prim - ( Immutable - , Mutable - , primIndex - , primIndex64 - , primRead - , primWrite - ) where - -import GHC.Types -import GHC.Prim -import GHC.Word -import Basement.Types.OffsetSize -import Basement.PrimType -import Basement.Monad - -type Immutable = Addr# -type Mutable st = Addr# - -primIndex :: PrimType ty => Immutable -> Offset ty -> ty -primIndex = primAddrIndex -{-# INLINE primIndex #-} - -primIndex64 :: Immutable -> Offset Word64 -> Word64 -primIndex64 = primIndex -{-# INLINE primIndex64 #-} - -primRead :: (PrimMonad prim, PrimType ty) => Mutable (PrimState prim) -> Offset ty -> prim ty -primRead = primAddrRead -{-# INLINE primRead #-} - -primWrite :: (PrimMonad prim, PrimType ty) => Mutable (PrimState prim) -> Offset ty -> ty -> prim () -primWrite = primAddrWrite -{-# INLINE primWrite #-} diff --git a/Basement/Alg/Foreign/String.hs b/Basement/Alg/Foreign/String.hs deleted file mode 100644 --- a/Basement/Alg/Foreign/String.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -module Basement.Alg.Foreign.String - ( copyFilter - , validate - , findIndexPredicate - , revFindIndexPredicate - ) where - -import GHC.Prim -import GHC.ST -import Basement.Compat.Base -import Basement.Numerical.Additive -import Basement.Types.OffsetSize - -import qualified Basement.Alg.Native.Prim as PrimNative -- NO SUBST -import qualified Basement.Alg.Native.UTF8 as UTF8Native -- NO SUBST -import qualified Basement.Alg.Foreign.Prim as PrimBackend -import qualified Basement.Alg.Foreign.UTF8 as UTF8Backend -import Basement.UTF8.Helper -import Basement.UTF8.Table -import Basement.UTF8.Types - -copyFilter :: (Char -> Bool) - -> CountOf Word8 - -> MutableByteArray# s - -> PrimBackend.Immutable - -> Offset Word8 - -> ST s (CountOf Word8) -copyFilter predicate !sz dst src start = loop (Offset 0) start - where - !end = start `offsetPlusE` sz - loop !d !s - | s == end = pure (offsetAsSize d) - | otherwise = - let !h = PrimBackend.primIndex src s - in case headerIsAscii h of - True | predicate (toChar1 h) -> PrimNative.primWrite dst d h >> loop (d + Offset 1) (s + Offset 1) - | otherwise -> loop d (s + Offset 1) - False -> - case UTF8Backend.next src s of - Step c s' | predicate c -> UTF8Native.write dst d c >>= \d' -> loop d' s' - | otherwise -> loop d s' - -validate :: Offset Word8 - -> PrimBackend.Immutable - -> Offset Word8 - -> (Offset Word8, Maybe ValidationFailure) -validate end ba ofsStart = loop4 ofsStart - where - loop4 !ofs - | ofs4 < end = - let h1 = PrimBackend.primIndex ba ofs - h2 = PrimBackend.primIndex ba (ofs+1) - h3 = PrimBackend.primIndex ba (ofs+2) - h4 = PrimBackend.primIndex ba (ofs+3) - in if headerIsAscii h1 && headerIsAscii h2 && headerIsAscii h3 && headerIsAscii h4 - then loop4 ofs4 - else loop ofs - | otherwise = loop ofs - where - !ofs4 = ofs+4 - loop !ofs - | ofs == end = (end, Nothing) - | headerIsAscii h = loop (ofs + Offset 1) - | otherwise = multi (CountOf $ getNbBytes h) ofs - where - h = PrimBackend.primIndex ba ofs - - multi (CountOf 0xff) pos = (pos, Just InvalidHeader) - multi nbConts pos - | (posNext `offsetPlusE` nbConts) > end = (pos, Just MissingByte) - | otherwise = - case nbConts of - CountOf 1 -> - let c1 = PrimBackend.primIndex ba posNext - in if isContinuation c1 - then loop (pos + Offset 2) - else (pos, Just InvalidContinuation) - CountOf 2 -> - let c1 = PrimBackend.primIndex ba posNext - c2 = PrimBackend.primIndex ba (pos + Offset 2) - in if isContinuation2 c1 c2 - then loop (pos + Offset 3) - else (pos, Just InvalidContinuation) - CountOf _ -> - let c1 = PrimBackend.primIndex ba posNext - c2 = PrimBackend.primIndex ba (pos + Offset 2) - c3 = PrimBackend.primIndex ba (pos + Offset 3) - in if isContinuation3 c1 c2 c3 - then loop (pos + Offset 4) - else (pos, Just InvalidContinuation) - where posNext = pos + Offset 1 - -findIndexPredicate :: (Char -> Bool) - -> PrimBackend.Immutable - -> Offset Word8 - -> Offset Word8 - -> Offset Word8 -findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex - where - loop !i - | i < endIndex && not (predicate c) = loop (i') - | otherwise = i - where - Step c i' = UTF8Backend.next ba i -{-# INLINE findIndexPredicate #-} - -revFindIndexPredicate :: (Char -> Bool) - -> PrimBackend.Immutable - -> Offset Word8 - -> Offset Word8 - -> Offset Word8 -revFindIndexPredicate predicate ba startIndex endIndex - | endIndex > startIndex = loop endIndex - | otherwise = endIndex - where - loop !i - | predicate c = i' - | i' > startIndex = loop i' - | otherwise = endIndex - where - StepBack c i' = UTF8Backend.prev ba i -{-# INLINE revFindIndexPredicate #-} diff --git a/Basement/Alg/Foreign/UTF8.hs b/Basement/Alg/Foreign/UTF8.hs deleted file mode 100644 --- a/Basement/Alg/Foreign/UTF8.hs +++ /dev/null @@ -1,284 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -module Basement.Alg.Foreign.UTF8 - ( Immutable - , Mutable - -- * functions - , nextAscii - , nextAsciiDigit - , expectAscii - , next - , nextSkip - , prev - , prevSkip - , write - , toList - , all - , any - , foldr - , length - , reverse - -- temporary - , primIndex64 - , primRead8 - , primWrite8 - ) where - -import GHC.Int -import GHC.Types -import GHC.Word -import GHC.Prim -import Data.Bits -import Basement.Compat.Base hiding (toList) -import Basement.Compat.Primitive -import Basement.Alg.Foreign.Prim -import qualified Basement.Alg.Native.Prim as PrimNative -- NO SUBST -import Data.Proxy -import Basement.Numerical.Additive -import Basement.Numerical.Subtractive -import Basement.Types.OffsetSize -import Basement.Monad -import Basement.PrimType -import Basement.UTF8.Helper -import Basement.UTF8.Table -import Basement.UTF8.Types - -primWrite8 :: PrimMonad prim => Mutable (PrimState prim) -> Offset Word8 -> Word8 -> prim () -primWrite8 = primWrite -{-# INLINE primWrite8 #-} - -primRead8 :: PrimMonad prim => Mutable (PrimState prim) -> Offset Word8 -> prim Word8 -primRead8 = primRead -{-# INLINE primRead8 #-} - -primIndex8 :: Immutable -> Offset Word8 -> Word8 -primIndex8 = primIndex -{-# INLINE primIndex8 #-} - -nextAscii :: Immutable -> Offset Word8 -> StepASCII -nextAscii ba n = StepASCII w - where - !w = primIndex ba n -{-# INLINE nextAscii #-} - --- | nextAsciiBa specialized to get a digit between 0 and 9 (included) -nextAsciiDigit :: Immutable -> Offset Word8 -> StepDigit -nextAsciiDigit ba n = StepDigit (primIndex8 ba n - 0x30) -{-# INLINE nextAsciiDigit #-} - -expectAscii :: Immutable -> Offset Word8 -> Word8 -> Bool -expectAscii ba n v = primIndex8 ba n == v -{-# INLINE expectAscii #-} - -next :: Immutable -> Offset8 -> Step -next ba n = - case getNbBytes h of - 0 -> Step (toChar1 h) (n + Offset 1) - 1 -> Step (toChar2 h (primIndex8 ba (n + Offset 1))) (n + Offset 2) - 2 -> Step (toChar3 h (primIndex8 ba (n + Offset 1)) - (primIndex8 ba (n + Offset 2))) (n + Offset 3) - 3 -> Step (toChar4 h (primIndex8 ba (n + Offset 1)) - (primIndex8 ba (n + Offset 2)) - (primIndex8 ba (n + Offset 3))) (n + Offset 4) - r -> error ("next: internal error: invalid input: offset=" <> show n <> " table=" <> show r <> " h=" <> show h) - where - !h = primIndex8 ba n -{-# INLINE next #-} - -nextSkip :: Immutable -> Offset Word8 -> Offset Word8 -nextSkip ba n = n + 1 + Offset (getNbBytes (primIndex8 ba n)) -{-# INLINE nextSkip #-} - --- Given a non null offset, give the previous character and the offset of this character --- will fail bad if apply at the beginning of string or an empty string. -prev :: Immutable -> Offset Word8 -> StepBack -prev ba offset = - case primIndex8 ba prevOfs1 of - (W8# v1) | isContinuation# v1 -> atLeast2 (maskContinuation# v1) - | otherwise -> StepBack (toChar# v1) prevOfs1 - where - sz1 = CountOf 1 - !prevOfs1 = offset `offsetMinusE` sz1 - prevOfs2 = prevOfs1 `offsetMinusE` sz1 - prevOfs3 = prevOfs2 `offsetMinusE` sz1 - prevOfs4 = prevOfs3 `offsetMinusE` sz1 - atLeast2 !v = - case primIndex8 ba prevOfs2 of - (W8# v2) | isContinuation# v2 -> atLeast3 (or# (uncheckedShiftL# (maskContinuation# v2) 6#) v) - | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader2# v2) 6#) v)) prevOfs2 - atLeast3 !v = - case primIndex8 ba prevOfs3 of - (W8# v3) | isContinuation# v3 -> atLeast4 (or# (uncheckedShiftL# (maskContinuation# v3) 12#) v) - | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader3# v3) 12#) v)) prevOfs3 - atLeast4 !v = - case primIndex8 ba prevOfs4 of - (W8# v4) -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader4# v4) 18#) v)) prevOfs4 - -prevSkip :: Immutable -> Offset Word8 -> Offset Word8 -prevSkip ba offset = loop (offset `offsetMinusE` sz1) - where - sz1 = CountOf 1 - loop o - | isContinuation (primIndex8 ba o) = loop (o `offsetMinusE` sz1) - | otherwise = o - -write :: PrimMonad prim => Mutable (PrimState prim) -> Offset8 -> Char -> prim Offset8 -write mba !i !c - | bool# (ltWord# x 0x80## ) = encode1 - | bool# (ltWord# x 0x800## ) = encode2 - | bool# (ltWord# x 0x10000##) = encode3 - | otherwise = encode4 - where - !(I# xi) = fromEnum c - !x = int2Word# xi - - encode1 = primWrite8 mba i (W8# x) >> pure (i + Offset 1) - encode2 = do - let x1 = or# (uncheckedShiftRL# x 6#) 0xc0## - x2 = toContinuation x - primWrite8 mba i (W8# x1) - primWrite8 mba (i+1) (W8# x2) - pure (i + Offset 2) - - encode3 = do - let x1 = or# (uncheckedShiftRL# x 12#) 0xe0## - x2 = toContinuation (uncheckedShiftRL# x 6#) - x3 = toContinuation x - primWrite8 mba i (W8# x1) - primWrite8 mba (i+Offset 1) (W8# x2) - primWrite8 mba (i+Offset 2) (W8# x3) - pure (i + Offset 3) - - encode4 = do - let x1 = or# (uncheckedShiftRL# x 18#) 0xf0## - x2 = toContinuation (uncheckedShiftRL# x 12#) - x3 = toContinuation (uncheckedShiftRL# x 6#) - x4 = toContinuation x - primWrite8 mba i (W8# x1) - primWrite8 mba (i+Offset 1) (W8# x2) - primWrite8 mba (i+Offset 2) (W8# x3) - primWrite8 mba (i+Offset 3) (W8# x4) - pure (i + Offset 4) - - toContinuation :: Word# -> Word# - toContinuation w = or# (and# w 0x3f##) 0x80## -{-# INLINE write #-} - -toList :: Immutable -> Offset Word8 -> Offset Word8 -> [Char] -toList ba !start !end = loop start - where - loop !idx - | idx == end = [] - | otherwise = c : loop idx' - where (Step c idx') = next ba idx - -all :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool -all predicate ba start end = loop start - where - loop !idx - | idx == end = True - | predicate c = loop idx' - | otherwise = False - where (Step c idx') = next ba idx -{-# INLINE all #-} - -any :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool -any predicate ba start end = loop start - where - loop !idx - | idx == end = False - | predicate c = True - | otherwise = loop idx' - where (Step c idx') = next ba idx -{-# INLINE any #-} - -foldr :: Immutable -> Offset Word8 -> Offset Word8 -> (Char -> a -> a) -> a -> a -foldr dat start end f acc = loop start - where - loop !i - | i == end = acc - | otherwise = - let (Step c i') = next dat i - in c `f` loop i' -{-# INLINE foldr #-} - -length :: Immutable -> Offset Word8 -> Offset Word8 -> CountOf Char -length dat start end - | start == end = 0 - | otherwise = processStart 0 start - where - end64 :: Offset Word64 - end64 = offsetInElements end - - prx64 :: Proxy Word64 - prx64 = Proxy - - mask64_80 :: Word64 - mask64_80 = 0x8080808080808080 - - processStart :: CountOf Char -> Offset Word8 -> CountOf Char - processStart !c !i - | i == end = c - | offsetIsAligned prx64 i = processAligned c (offsetInElements i) - | otherwise = - let h = primIndex8 dat i - cont = (h .&. 0xc0) == 0x80 - c' = if cont then c else c+1 - in processStart c' (i+1) - processAligned :: CountOf Char -> Offset Word64 -> CountOf Char - processAligned !c !i - | i >= end64 = processEnd c (offsetInBytes i) - | otherwise = - let !h = primIndex64 dat i - !h80 = h .&. mask64_80 - in if h80 == 0 - then processAligned (c+8) (i+1) - else let !nbAscii = if h80 == mask64_80 then 0 else CountOf (8 - popCount h80) - !nbHigh = CountOf $ popCount (h .&. (h80 `unsafeShiftR` 1)) - in processAligned (c + nbAscii + nbHigh) (i+1) - processEnd !c !i - | i == end = c - | otherwise = - let h = primIndex8 dat i - cont = (h .&. 0xc0) == 0x80 - c' = if cont then c else c+1 - in processStart c' (i+1) -{-# INLINE length #-} - -reverse :: PrimMonad prim - => MutableByteArray# (PrimState prim) -- ^ Destination buffer - -> Offset Word8 -- ^ Destination start - -> Immutable -- ^ Source buffer - -> Offset Word8 -- ^ Source start - -> Offset Word8 -- ^ Source end - -> prim () -reverse dst dstOfs src start end - | start == end = pure () - | otherwise = loop (dstOfs `offsetPlusE` (offsetAsSize (end `offsetSub` start)) `offsetSub` 1) start - where - loop !d !s - | s == end = pure () - | headerIsAscii h = PrimNative.primWrite dst d h >> loop (d `offsetSub` 1) (s + 1) - | otherwise = do - case getNbBytes h of - 1 -> do - PrimNative.primWrite dst (d `offsetSub` 1) h - PrimNative.primWrite dst d (primIndex8 src (s + 1)) - loop (d `offsetSub` 2) (s + 2) - 2 -> do - PrimNative.primWrite dst (d `offsetSub` 2) h - PrimNative.primWrite dst (d `offsetSub` 1) (primIndex8 src (s + 1)) - PrimNative.primWrite dst d (primIndex8 src (s + 2)) - loop (d `offsetSub` 3) (s + 3) - 3 -> do - PrimNative.primWrite dst (d `offsetSub` 3) h - PrimNative.primWrite dst (d `offsetSub` 2) (primIndex8 src (s + 1)) - PrimNative.primWrite dst (d `offsetSub` 1) (primIndex8 src (s + 2)) - PrimNative.primWrite dst d (primIndex8 src (s + 3)) - loop (d `offsetSub` 4) (s + 4) - _ -> error "impossible" - where h = primIndex8 src s -{-# INLINE reverse #-} diff --git a/Basement/Alg/Native/Prim.hs b/Basement/Alg/Native/Prim.hs deleted file mode 100644 --- a/Basement/Alg/Native/Prim.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE MagicHash #-} -module Basement.Alg.Native.Prim - ( Immutable - , Mutable - , primIndex - , primIndex64 - , primRead - , primWrite - ) where - -import GHC.Types -import GHC.Prim -import GHC.Word -import Basement.Types.OffsetSize -import Basement.PrimType -import Basement.Monad - -type Immutable = ByteArray# -type Mutable st = MutableByteArray# st - -primIndex :: PrimType ty => Immutable -> Offset ty -> ty -primIndex = primBaIndex -{-# INLINE primIndex #-} - -primIndex64 :: Immutable -> Offset Word64 -> Word64 -primIndex64 = primIndex -{-# INLINE primIndex64 #-} - -primRead :: (PrimMonad prim, PrimType ty) => Mutable (PrimState prim) -> Offset ty -> prim ty -primRead = primMbaRead -{-# INLINE primRead #-} - -primWrite :: (PrimMonad prim, PrimType ty) => Mutable (PrimState prim) -> Offset ty -> ty -> prim () -primWrite = primMbaWrite -{-# INLINE primWrite #-} diff --git a/Basement/Alg/Native/String.hs b/Basement/Alg/Native/String.hs deleted file mode 100644 --- a/Basement/Alg/Native/String.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -module Basement.Alg.Native.String - ( copyFilter - , validate - , findIndexPredicate - , revFindIndexPredicate - ) where - -import GHC.Prim -import GHC.ST -import Basement.Compat.Base -import Basement.Numerical.Additive -import Basement.Types.OffsetSize - -import qualified Basement.Alg.Native.Prim as PrimNative -- NO SUBST -import qualified Basement.Alg.Native.UTF8 as UTF8Native -- NO SUBST -import qualified Basement.Alg.Native.Prim as PrimBackend -import qualified Basement.Alg.Native.UTF8 as UTF8Backend -import Basement.UTF8.Helper -import Basement.UTF8.Table -import Basement.UTF8.Types - -copyFilter :: (Char -> Bool) - -> CountOf Word8 - -> MutableByteArray# s - -> PrimBackend.Immutable - -> Offset Word8 - -> ST s (CountOf Word8) -copyFilter predicate !sz dst src start = loop (Offset 0) start - where - !end = start `offsetPlusE` sz - loop !d !s - | s == end = pure (offsetAsSize d) - | otherwise = - let !h = PrimBackend.primIndex src s - in case headerIsAscii h of - True | predicate (toChar1 h) -> PrimNative.primWrite dst d h >> loop (d + Offset 1) (s + Offset 1) - | otherwise -> loop d (s + Offset 1) - False -> - case UTF8Backend.next src s of - Step c s' | predicate c -> UTF8Native.write dst d c >>= \d' -> loop d' s' - | otherwise -> loop d s' - -validate :: Offset Word8 - -> PrimBackend.Immutable - -> Offset Word8 - -> (Offset Word8, Maybe ValidationFailure) -validate end ba ofsStart = loop4 ofsStart - where - loop4 !ofs - | ofs4 < end = - let h1 = PrimBackend.primIndex ba ofs - h2 = PrimBackend.primIndex ba (ofs+1) - h3 = PrimBackend.primIndex ba (ofs+2) - h4 = PrimBackend.primIndex ba (ofs+3) - in if headerIsAscii h1 && headerIsAscii h2 && headerIsAscii h3 && headerIsAscii h4 - then loop4 ofs4 - else loop ofs - | otherwise = loop ofs - where - !ofs4 = ofs+4 - loop !ofs - | ofs == end = (end, Nothing) - | headerIsAscii h = loop (ofs + Offset 1) - | otherwise = multi (CountOf $ getNbBytes h) ofs - where - h = PrimBackend.primIndex ba ofs - - multi (CountOf 0xff) pos = (pos, Just InvalidHeader) - multi nbConts pos - | (posNext `offsetPlusE` nbConts) > end = (pos, Just MissingByte) - | otherwise = - case nbConts of - CountOf 1 -> - let c1 = PrimBackend.primIndex ba posNext - in if isContinuation c1 - then loop (pos + Offset 2) - else (pos, Just InvalidContinuation) - CountOf 2 -> - let c1 = PrimBackend.primIndex ba posNext - c2 = PrimBackend.primIndex ba (pos + Offset 2) - in if isContinuation2 c1 c2 - then loop (pos + Offset 3) - else (pos, Just InvalidContinuation) - CountOf _ -> - let c1 = PrimBackend.primIndex ba posNext - c2 = PrimBackend.primIndex ba (pos + Offset 2) - c3 = PrimBackend.primIndex ba (pos + Offset 3) - in if isContinuation3 c1 c2 c3 - then loop (pos + Offset 4) - else (pos, Just InvalidContinuation) - where posNext = pos + Offset 1 - -findIndexPredicate :: (Char -> Bool) - -> PrimBackend.Immutable - -> Offset Word8 - -> Offset Word8 - -> Offset Word8 -findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex - where - loop !i - | i < endIndex && not (predicate c) = loop (i') - | otherwise = i - where - Step c i' = UTF8Backend.next ba i -{-# INLINE findIndexPredicate #-} - -revFindIndexPredicate :: (Char -> Bool) - -> PrimBackend.Immutable - -> Offset Word8 - -> Offset Word8 - -> Offset Word8 -revFindIndexPredicate predicate ba startIndex endIndex - | endIndex > startIndex = loop endIndex - | otherwise = endIndex - where - loop !i - | predicate c = i' - | i' > startIndex = loop i' - | otherwise = endIndex - where - StepBack c i' = UTF8Backend.prev ba i -{-# INLINE revFindIndexPredicate #-} diff --git a/Basement/Alg/Native/UTF8.hs b/Basement/Alg/Native/UTF8.hs deleted file mode 100644 --- a/Basement/Alg/Native/UTF8.hs +++ /dev/null @@ -1,284 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -module Basement.Alg.Native.UTF8 - ( Immutable - , Mutable - -- * functions - , nextAscii - , nextAsciiDigit - , expectAscii - , next - , nextSkip - , prev - , prevSkip - , write - , toList - , all - , any - , foldr - , length - , reverse - -- temporary - , primIndex64 - , primRead8 - , primWrite8 - ) where - -import GHC.Int -import GHC.Types -import GHC.Word -import GHC.Prim -import Data.Bits -import Basement.Compat.Base hiding (toList) -import Basement.Compat.Primitive -import Basement.Alg.Native.Prim -import qualified Basement.Alg.Native.Prim as PrimNative -- NO SUBST -import Data.Proxy -import Basement.Numerical.Additive -import Basement.Numerical.Subtractive -import Basement.Types.OffsetSize -import Basement.Monad -import Basement.PrimType -import Basement.UTF8.Helper -import Basement.UTF8.Table -import Basement.UTF8.Types - -primWrite8 :: PrimMonad prim => Mutable (PrimState prim) -> Offset Word8 -> Word8 -> prim () -primWrite8 = primWrite -{-# INLINE primWrite8 #-} - -primRead8 :: PrimMonad prim => Mutable (PrimState prim) -> Offset Word8 -> prim Word8 -primRead8 = primRead -{-# INLINE primRead8 #-} - -primIndex8 :: Immutable -> Offset Word8 -> Word8 -primIndex8 = primIndex -{-# INLINE primIndex8 #-} - -nextAscii :: Immutable -> Offset Word8 -> StepASCII -nextAscii ba n = StepASCII w - where - !w = primIndex ba n -{-# INLINE nextAscii #-} - --- | nextAsciiBa specialized to get a digit between 0 and 9 (included) -nextAsciiDigit :: Immutable -> Offset Word8 -> StepDigit -nextAsciiDigit ba n = StepDigit (primIndex8 ba n - 0x30) -{-# INLINE nextAsciiDigit #-} - -expectAscii :: Immutable -> Offset Word8 -> Word8 -> Bool -expectAscii ba n v = primIndex8 ba n == v -{-# INLINE expectAscii #-} - -next :: Immutable -> Offset8 -> Step -next ba n = - case getNbBytes h of - 0 -> Step (toChar1 h) (n + Offset 1) - 1 -> Step (toChar2 h (primIndex8 ba (n + Offset 1))) (n + Offset 2) - 2 -> Step (toChar3 h (primIndex8 ba (n + Offset 1)) - (primIndex8 ba (n + Offset 2))) (n + Offset 3) - 3 -> Step (toChar4 h (primIndex8 ba (n + Offset 1)) - (primIndex8 ba (n + Offset 2)) - (primIndex8 ba (n + Offset 3))) (n + Offset 4) - r -> error ("next: internal error: invalid input: offset=" <> show n <> " table=" <> show r <> " h=" <> show h) - where - !h = primIndex8 ba n -{-# INLINE next #-} - -nextSkip :: Immutable -> Offset Word8 -> Offset Word8 -nextSkip ba n = n + 1 + Offset (getNbBytes (primIndex8 ba n)) -{-# INLINE nextSkip #-} - --- Given a non null offset, give the previous character and the offset of this character --- will fail bad if apply at the beginning of string or an empty string. -prev :: Immutable -> Offset Word8 -> StepBack -prev ba offset = - case primIndex8 ba prevOfs1 of - (W8# v1) | isContinuation# v1 -> atLeast2 (maskContinuation# v1) - | otherwise -> StepBack (toChar# v1) prevOfs1 - where - sz1 = CountOf 1 - !prevOfs1 = offset `offsetMinusE` sz1 - prevOfs2 = prevOfs1 `offsetMinusE` sz1 - prevOfs3 = prevOfs2 `offsetMinusE` sz1 - prevOfs4 = prevOfs3 `offsetMinusE` sz1 - atLeast2 !v = - case primIndex8 ba prevOfs2 of - (W8# v2) | isContinuation# v2 -> atLeast3 (or# (uncheckedShiftL# (maskContinuation# v2) 6#) v) - | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader2# v2) 6#) v)) prevOfs2 - atLeast3 !v = - case primIndex8 ba prevOfs3 of - (W8# v3) | isContinuation# v3 -> atLeast4 (or# (uncheckedShiftL# (maskContinuation# v3) 12#) v) - | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader3# v3) 12#) v)) prevOfs3 - atLeast4 !v = - case primIndex8 ba prevOfs4 of - (W8# v4) -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader4# v4) 18#) v)) prevOfs4 - -prevSkip :: Immutable -> Offset Word8 -> Offset Word8 -prevSkip ba offset = loop (offset `offsetMinusE` sz1) - where - sz1 = CountOf 1 - loop o - | isContinuation (primIndex8 ba o) = loop (o `offsetMinusE` sz1) - | otherwise = o - -write :: PrimMonad prim => Mutable (PrimState prim) -> Offset8 -> Char -> prim Offset8 -write mba !i !c - | bool# (ltWord# x 0x80## ) = encode1 - | bool# (ltWord# x 0x800## ) = encode2 - | bool# (ltWord# x 0x10000##) = encode3 - | otherwise = encode4 - where - !(I# xi) = fromEnum c - !x = int2Word# xi - - encode1 = primWrite8 mba i (W8# x) >> pure (i + Offset 1) - encode2 = do - let x1 = or# (uncheckedShiftRL# x 6#) 0xc0## - x2 = toContinuation x - primWrite8 mba i (W8# x1) - primWrite8 mba (i+1) (W8# x2) - pure (i + Offset 2) - - encode3 = do - let x1 = or# (uncheckedShiftRL# x 12#) 0xe0## - x2 = toContinuation (uncheckedShiftRL# x 6#) - x3 = toContinuation x - primWrite8 mba i (W8# x1) - primWrite8 mba (i+Offset 1) (W8# x2) - primWrite8 mba (i+Offset 2) (W8# x3) - pure (i + Offset 3) - - encode4 = do - let x1 = or# (uncheckedShiftRL# x 18#) 0xf0## - x2 = toContinuation (uncheckedShiftRL# x 12#) - x3 = toContinuation (uncheckedShiftRL# x 6#) - x4 = toContinuation x - primWrite8 mba i (W8# x1) - primWrite8 mba (i+Offset 1) (W8# x2) - primWrite8 mba (i+Offset 2) (W8# x3) - primWrite8 mba (i+Offset 3) (W8# x4) - pure (i + Offset 4) - - toContinuation :: Word# -> Word# - toContinuation w = or# (and# w 0x3f##) 0x80## -{-# INLINE write #-} - -toList :: Immutable -> Offset Word8 -> Offset Word8 -> [Char] -toList ba !start !end = loop start - where - loop !idx - | idx == end = [] - | otherwise = c : loop idx' - where (Step c idx') = next ba idx - -all :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool -all predicate ba start end = loop start - where - loop !idx - | idx == end = True - | predicate c = loop idx' - | otherwise = False - where (Step c idx') = next ba idx -{-# INLINE all #-} - -any :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool -any predicate ba start end = loop start - where - loop !idx - | idx == end = False - | predicate c = True - | otherwise = loop idx' - where (Step c idx') = next ba idx -{-# INLINE any #-} - -foldr :: Immutable -> Offset Word8 -> Offset Word8 -> (Char -> a -> a) -> a -> a -foldr dat start end f acc = loop start - where - loop !i - | i == end = acc - | otherwise = - let (Step c i') = next dat i - in c `f` loop i' -{-# INLINE foldr #-} - -length :: Immutable -> Offset Word8 -> Offset Word8 -> CountOf Char -length dat start end - | start == end = 0 - | otherwise = processStart 0 start - where - end64 :: Offset Word64 - end64 = offsetInElements end - - prx64 :: Proxy Word64 - prx64 = Proxy - - mask64_80 :: Word64 - mask64_80 = 0x8080808080808080 - - processStart :: CountOf Char -> Offset Word8 -> CountOf Char - processStart !c !i - | i == end = c - | offsetIsAligned prx64 i = processAligned c (offsetInElements i) - | otherwise = - let h = primIndex8 dat i - cont = (h .&. 0xc0) == 0x80 - c' = if cont then c else c+1 - in processStart c' (i+1) - processAligned :: CountOf Char -> Offset Word64 -> CountOf Char - processAligned !c !i - | i >= end64 = processEnd c (offsetInBytes i) - | otherwise = - let !h = primIndex64 dat i - !h80 = h .&. mask64_80 - in if h80 == 0 - then processAligned (c+8) (i+1) - else let !nbAscii = if h80 == mask64_80 then 0 else CountOf (8 - popCount h80) - !nbHigh = CountOf $ popCount (h .&. (h80 `unsafeShiftR` 1)) - in processAligned (c + nbAscii + nbHigh) (i+1) - processEnd !c !i - | i == end = c - | otherwise = - let h = primIndex8 dat i - cont = (h .&. 0xc0) == 0x80 - c' = if cont then c else c+1 - in processStart c' (i+1) -{-# INLINE length #-} - -reverse :: PrimMonad prim - => MutableByteArray# (PrimState prim) -- ^ Destination buffer - -> Offset Word8 -- ^ Destination start - -> Immutable -- ^ Source buffer - -> Offset Word8 -- ^ Source start - -> Offset Word8 -- ^ Source end - -> prim () -reverse dst dstOfs src start end - | start == end = pure () - | otherwise = loop (dstOfs `offsetPlusE` (offsetAsSize (end `offsetSub` start)) `offsetSub` 1) start - where - loop !d !s - | s == end = pure () - | headerIsAscii h = PrimNative.primWrite dst d h >> loop (d `offsetSub` 1) (s + 1) - | otherwise = do - case getNbBytes h of - 1 -> do - PrimNative.primWrite dst (d `offsetSub` 1) h - PrimNative.primWrite dst d (primIndex8 src (s + 1)) - loop (d `offsetSub` 2) (s + 2) - 2 -> do - PrimNative.primWrite dst (d `offsetSub` 2) h - PrimNative.primWrite dst (d `offsetSub` 1) (primIndex8 src (s + 1)) - PrimNative.primWrite dst d (primIndex8 src (s + 2)) - loop (d `offsetSub` 3) (s + 3) - 3 -> do - PrimNative.primWrite dst (d `offsetSub` 3) h - PrimNative.primWrite dst (d `offsetSub` 2) (primIndex8 src (s + 1)) - PrimNative.primWrite dst (d `offsetSub` 1) (primIndex8 src (s + 2)) - PrimNative.primWrite dst d (primIndex8 src (s + 3)) - loop (d `offsetSub` 4) (s + 4) - _ -> error "impossible" - where h = primIndex8 src s -{-# INLINE reverse #-} diff --git a/Basement/Alg/PrimArray.hs b/Basement/Alg/PrimArray.hs --- a/Basement/Alg/PrimArray.hs +++ b/Basement/Alg/PrimArray.hs @@ -28,42 +28,38 @@ findIndexElem ty ba startIndex endIndex = loop startIndex where loop !i - | i < endIndex && t /= ty = loop (i+1) - | otherwise = i - where t = index ba i + | i >= endIndex = sentinel + | index ba i == ty = i + | otherwise = loop (i+1) {-# INLINE findIndexElem #-} revFindIndexElem :: (Indexable container ty, Eq ty) => ty -> container -> Offset ty -> Offset ty -> Offset ty -revFindIndexElem ty ba startIndex endIndex - | endIndex > startIndex = loop (endIndex `offsetMinusE` 1) - | otherwise = endIndex +revFindIndexElem ty ba startIndex endIndex = loop endIndex where - loop !i - | t == ty = i - | i > startIndex = loop (i `offsetMinusE` 1) - | otherwise = endIndex - where t = index ba i + loop !iplus1 + | iplus1 <= startIndex = sentinel + | index ba i == ty = i + | otherwise = loop i + where !i = iplus1 `offsetMinusE` 1 {-# INLINE revFindIndexElem #-} findIndexPredicate :: Indexable container ty => (ty -> Bool) -> container -> Offset ty -> Offset ty -> Offset ty -findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex +findIndexPredicate predicate ba startIndex endIndex = loop startIndex where loop !i - | i < endIndex && not found = loop (i+1) - | otherwise = i - where found = predicate (index ba i) + | i >= endIndex = sentinel + | predicate (index ba i) = i + | otherwise = loop (i+1) {-# INLINE findIndexPredicate #-} revFindIndexPredicate :: Indexable container ty => (ty -> Bool) -> container -> Offset ty -> Offset ty -> Offset ty -revFindIndexPredicate predicate ba startIndex endIndex - | endIndex > startIndex = loop (endIndex `offsetMinusE` 1) - | otherwise = endIndex +revFindIndexPredicate predicate ba startIndex endIndex = loop endIndex where - loop !i - | found = i - | i > startIndex = loop (i `offsetMinusE` 1) - | otherwise = endIndex - where found = predicate (index ba i) + loop !iplus1 + | iplus1 <= startIndex = sentinel + | predicate (index ba i) = i + | otherwise = loop i + where !i = iplus1 `offsetMinusE` 1 {-# INLINE revFindIndexPredicate #-} foldl :: Indexable container ty => (a -> ty -> a) -> a -> container -> Offset ty -> Offset ty -> a diff --git a/Basement/Alg/String.hs b/Basement/Alg/String.hs new file mode 100644 --- /dev/null +++ b/Basement/Alg/String.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +module Basement.Alg.String + ( copyFilter + , validate + , findIndexPredicate + , revFindIndexPredicate + ) where + +import GHC.Prim +import GHC.ST +import Basement.Alg.Class +import Basement.Alg.UTF8 +import Basement.Compat.Base +import Basement.Numerical.Additive +import Basement.Types.OffsetSize +import Basement.PrimType +import Basement.Block (MutableBlock(..)) + +import Basement.UTF8.Helper +import Basement.UTF8.Table +import Basement.UTF8.Types + +copyFilter :: forall s container . Indexable container Word8 + => (Char -> Bool) + -> CountOf Word8 + -> MutableByteArray# s + -> container + -> Offset Word8 + -> ST s (CountOf Word8) +copyFilter predicate !sz dst src start = loop (Offset 0) start + where + !end = start `offsetPlusE` sz + loop !d !s + | s == end = pure (offsetAsSize d) + | otherwise = + let !h = index src s + in case headerIsAscii h of + True | predicate (toChar1 h) -> primMbaWrite dst d h >> loop (d + Offset 1) (s + Offset 1) + | otherwise -> loop d (s + Offset 1) + False -> + case next src s of + Step c s' | predicate c -> writeUTF8 (MutableBlock dst :: MutableBlock Word8 s) d c >>= \d' -> loop d' s' + | otherwise -> loop d s' +{-# INLINE copyFilter #-} + +validate :: Indexable container Word8 + => Offset Word8 + -> container + -> Offset Word8 + -> (Offset Word8, Maybe ValidationFailure) +validate end ba ofsStart = loop4 ofsStart + where + loop4 !ofs + | ofs4 < end = + let h1 = index ba ofs + h2 = index ba (ofs+1) + h3 = index ba (ofs+2) + h4 = index ba (ofs+3) + in if headerIsAscii h1 && headerIsAscii h2 && headerIsAscii h3 && headerIsAscii h4 + then loop4 ofs4 + else loop ofs + | otherwise = loop ofs + where + !ofs4 = ofs+4 + loop !ofs + | ofs == end = (end, Nothing) + | headerIsAscii h = loop (ofs + Offset 1) + | otherwise = multi (CountOf $ getNbBytes h) ofs + where + h = index ba ofs + + multi (CountOf 0xff) pos = (pos, Just InvalidHeader) + multi nbConts pos + | (posNext `offsetPlusE` nbConts) > end = (pos, Just MissingByte) + | otherwise = + case nbConts of + CountOf 1 -> + let c1 = index ba posNext + in if isContinuation c1 + then loop (pos + Offset 2) + else (pos, Just InvalidContinuation) + CountOf 2 -> + let c1 = index ba posNext + c2 = index ba (pos + Offset 2) + in if isContinuation2 c1 c2 + then loop (pos + Offset 3) + else (pos, Just InvalidContinuation) + CountOf _ -> + let c1 = index ba posNext + c2 = index ba (pos + Offset 2) + c3 = index ba (pos + Offset 3) + in if isContinuation3 c1 c2 c3 + then loop (pos + Offset 4) + else (pos, Just InvalidContinuation) + where posNext = pos + Offset 1 +{-# INLINE validate #-} + +findIndexPredicate :: Indexable container Word8 + => (Char -> Bool) + -> container + -> Offset Word8 + -> Offset Word8 + -> Offset Word8 +findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex + where + loop !i + | i < endIndex && not (predicate c) = loop (i') + | otherwise = i + where + Step c i' = next ba i +{-# INLINE findIndexPredicate #-} + +revFindIndexPredicate :: Indexable container Word8 + => (Char -> Bool) + -> container + -> Offset Word8 + -> Offset Word8 + -> Offset Word8 +revFindIndexPredicate predicate ba startIndex endIndex + | endIndex > startIndex = loop endIndex + | otherwise = endIndex + where + loop !i + | predicate c = i' + | i' > startIndex = loop i' + | otherwise = endIndex + where + StepBack c i' = prev ba i +{-# INLINE revFindIndexPredicate #-} diff --git a/Basement/Alg/UTF8.hs b/Basement/Alg/UTF8.hs new file mode 100644 --- /dev/null +++ b/Basement/Alg/UTF8.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +module Basement.Alg.UTF8 + ( nextAscii + , nextAsciiDigit + , expectAscii + , next + , nextSkip + , prev + , prevSkip + , writeUTF8 + , toList + , all + , any + , foldr + , length + , reverse + ) where + +import GHC.Types +import GHC.Word +import GHC.Prim +import Data.Bits +import Data.Proxy +import Basement.Alg.Class +import Basement.Compat.Base hiding (toList) +import Basement.Compat.Primitive +import Basement.Monad +import Basement.Numerical.Additive +import Basement.Numerical.Subtractive +import Basement.Types.OffsetSize +import Basement.PrimType +import Basement.UTF8.Helper +import Basement.UTF8.Table +import Basement.UTF8.Types + +nextAscii :: Indexable container Word8 => container -> Offset Word8 -> StepASCII +nextAscii ba n = StepASCII w + where + !w = index ba n +{-# INLINE nextAscii #-} + +-- | nextAsciiBa specialized to get a digit between 0 and 9 (included) +nextAsciiDigit :: Indexable container Word8 => container -> Offset Word8 -> StepDigit +nextAsciiDigit ba n = StepDigit (index ba n - 0x30) +{-# INLINE nextAsciiDigit #-} + +expectAscii :: Indexable container Word8 => container -> Offset Word8 -> Word8 -> Bool +expectAscii ba n v = index ba n == v +{-# INLINE expectAscii #-} + +next :: Indexable container Word8 => container -> Offset8 -> Step +next ba n = + case getNbBytes h of + 0 -> Step (toChar1 h) (n + Offset 1) + 1 -> Step (toChar2 h (index ba (n + Offset 1))) (n + Offset 2) + 2 -> Step (toChar3 h (index ba (n + Offset 1)) + (index ba (n + Offset 2))) (n + Offset 3) + 3 -> Step (toChar4 h (index ba (n + Offset 1)) + (index ba (n + Offset 2)) + (index ba (n + Offset 3))) (n + Offset 4) + r -> error ("next: internal error: invalid input: offset=" <> show n <> " table=" <> show r <> " h=" <> show h) + where + !h = index ba n +{-# INLINE next #-} + +nextSkip :: Indexable container Word8 => container -> Offset Word8 -> Offset Word8 +nextSkip ba n = n + 1 + Offset (getNbBytes (index ba n)) +{-# INLINE nextSkip #-} + +-- Given a non null offset, give the previous character and the offset of this character +-- will fail bad if apply at the beginning of string or an empty string. +prev :: Indexable container Word8 => container -> Offset Word8 -> StepBack +prev ba offset = + case index ba prevOfs1 of + (W8# v1) | isContinuation# v1 -> atLeast2 (maskContinuation# v1) + | otherwise -> StepBack (toChar# v1) prevOfs1 + where + sz1 = CountOf 1 + !prevOfs1 = offset `offsetMinusE` sz1 + prevOfs2 = prevOfs1 `offsetMinusE` sz1 + prevOfs3 = prevOfs2 `offsetMinusE` sz1 + prevOfs4 = prevOfs3 `offsetMinusE` sz1 + atLeast2 !v = + case index ba prevOfs2 of + (W8# v2) | isContinuation# v2 -> atLeast3 (or# (uncheckedShiftL# (maskContinuation# v2) 6#) v) + | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader2# v2) 6#) v)) prevOfs2 + atLeast3 !v = + case index ba prevOfs3 of + (W8# v3) | isContinuation# v3 -> atLeast4 (or# (uncheckedShiftL# (maskContinuation# v3) 12#) v) + | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader3# v3) 12#) v)) prevOfs3 + atLeast4 !v = + case index ba prevOfs4 of + (W8# v4) -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader4# v4) 18#) v)) prevOfs4 + +prevSkip :: Indexable container Word8 => container -> Offset Word8 -> Offset Word8 +prevSkip ba offset = loop (offset `offsetMinusE` sz1) + where + sz1 = CountOf 1 + loop o + | isContinuation (index ba o) = loop (o `offsetMinusE` sz1) + | otherwise = o + +writeUTF8 :: (PrimMonad prim, RandomAccess container prim Word8) + => container -> Offset8 -> Char -> prim Offset8 +writeUTF8 mba !i !c + | bool# (ltWord# x 0x80## ) = encode1 + | bool# (ltWord# x 0x800## ) = encode2 + | bool# (ltWord# x 0x10000##) = encode3 + | otherwise = encode4 + where + !(I# xi) = fromEnum c + !x = int2Word# xi + + encode1 = write mba i (W8# x) >> pure (i + Offset 1) + encode2 = do + let x1 = or# (uncheckedShiftRL# x 6#) 0xc0## + x2 = toContinuation x + write mba i (W8# x1) + write mba (i+1) (W8# x2) + pure (i + Offset 2) + + encode3 = do + let x1 = or# (uncheckedShiftRL# x 12#) 0xe0## + x2 = toContinuation (uncheckedShiftRL# x 6#) + x3 = toContinuation x + write mba i (W8# x1) + write mba (i+Offset 1) (W8# x2) + write mba (i+Offset 2) (W8# x3) + pure (i + Offset 3) + + encode4 = do + let x1 = or# (uncheckedShiftRL# x 18#) 0xf0## + x2 = toContinuation (uncheckedShiftRL# x 12#) + x3 = toContinuation (uncheckedShiftRL# x 6#) + x4 = toContinuation x + write mba i (W8# x1) + write mba (i+Offset 1) (W8# x2) + write mba (i+Offset 2) (W8# x3) + write mba (i+Offset 3) (W8# x4) + pure (i + Offset 4) + + toContinuation :: Word# -> Word# + toContinuation w = or# (and# w 0x3f##) 0x80## +{-# INLINE writeUTF8 #-} + +toList :: Indexable container Word8 => container -> Offset Word8 -> Offset Word8 -> [Char] +toList ba !start !end = loop start + where + loop !idx + | idx == end = [] + | otherwise = c : loop idx' + where (Step c idx') = next ba idx + +all :: Indexable container Word8 + => (Char -> Bool) -> container -> Offset Word8 -> Offset Word8 -> Bool +all predicate ba start end = loop start + where + loop !idx + | idx == end = True + | predicate c = loop idx' + | otherwise = False + where (Step c idx') = next ba idx +{-# INLINE all #-} + +any :: Indexable container Word8 + => (Char -> Bool) -> container -> Offset Word8 -> Offset Word8 -> Bool +any predicate ba start end = loop start + where + loop !idx + | idx == end = False + | predicate c = True + | otherwise = loop idx' + where (Step c idx') = next ba idx +{-# INLINE any #-} + +foldr :: Indexable container Word8 + => container -> Offset Word8 -> Offset Word8 -> (Char -> a -> a) -> a -> a +foldr dat start end f acc = loop start + where + loop !i + | i == end = acc + | otherwise = + let (Step c i') = next dat i + in c `f` loop i' +{-# INLINE foldr #-} + +length :: (Indexable container Word8, Indexable container Word64) + => container -> Offset Word8 -> Offset Word8 -> CountOf Char +length dat start end + | start == end = 0 + | otherwise = processStart 0 start + where + end64 :: Offset Word64 + end64 = offsetInElements end + + prx64 :: Proxy Word64 + prx64 = Proxy + + mask64_80 :: Word64 + mask64_80 = 0x8080808080808080 + + processStart :: CountOf Char -> Offset Word8 -> CountOf Char + processStart !c !i + | i == end = c + | offsetIsAligned prx64 i = processAligned c (offsetInElements i) + | otherwise = + let h = index dat i + cont = (h .&. 0xc0) == 0x80 + c' = if cont then c else c+1 + in processStart c' (i+1) + processAligned :: CountOf Char -> Offset Word64 -> CountOf Char + processAligned !c !i + | i >= end64 = processEnd c (offsetInBytes i) + | otherwise = + let !h = index dat i -- Word64 + !h80 = h .&. mask64_80 + in if h80 == 0 + then processAligned (c+8) (i+1) + else let !nbAscii = if h80 == mask64_80 then 0 else CountOf (8 - popCount h80) + !nbHigh = CountOf $ popCount (h .&. (h80 `unsafeShiftR` 1)) + in processAligned (c + nbAscii + nbHigh) (i+1) + processEnd !c !i + | i == end = c + | otherwise = + let h = index dat i + cont = (h .&. 0xc0) == 0x80 + c' = if cont then c else c+1 + in processStart c' (i+1) +{-# INLINE length #-} + +reverse :: (PrimMonad prim, Indexable container Word8) + => MutableByteArray# (PrimState prim) -- ^ Destination buffer + -> Offset Word8 -- ^ Destination start + -> container -- ^ Source buffer + -> Offset Word8 -- ^ Source start + -> Offset Word8 -- ^ Source end + -> prim () +reverse dst dstOfs src start end + | start == end = pure () + | otherwise = loop (dstOfs `offsetPlusE` (offsetAsSize (end `offsetSub` start)) `offsetSub` 1) start + where + loop !d !s + | s == end = pure () + | headerIsAscii h = primMbaWrite dst d h >> loop (d `offsetSub` 1) (s + 1) + | otherwise = do + case getNbBytes h of + 1 -> do + primMbaWrite dst (d `offsetSub` 1) h + primMbaWrite dst d (index src (s + 1)) + loop (d `offsetSub` 2) (s + 2) + 2 -> do + primMbaWrite dst (d `offsetSub` 2) h + primMbaWrite dst (d `offsetSub` 1) (index src (s + 1)) + primMbaWrite dst d (index src (s + 2)) + loop (d `offsetSub` 3) (s + 3) + 3 -> do + primMbaWrite dst (d `offsetSub` 3) h + primMbaWrite dst (d `offsetSub` 2) (index src (s + 1)) + primMbaWrite dst (d `offsetSub` 1) (index src (s + 2)) + primMbaWrite dst d (index src (s + 3)) + loop (d `offsetSub` 4) (s + 4) + _ -> error "impossible" + where h = index src s +{-# INLINE reverse #-} diff --git a/Basement/Bits.hs b/Basement/Bits.hs new file mode 100644 --- /dev/null +++ b/Basement/Bits.hs @@ -0,0 +1,557 @@ +-- | +-- Module : Basement.Bits +-- License : BSD-style +-- Maintainer : Haskell Foundation +-- Stability : experimental +-- Portability : portable +-- + +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NegativeLiterals #-} + +#include "MachDeps.h" + +module Basement.Bits + ( BitOps(..) + , FiniteBitsOps(..) + + , Bits + , toBits + , allOne + ) where + +import Basement.Compat.Base +import Basement.Compat.Natural +import Basement.Numerical.Additive +import Basement.Numerical.Subtractive +import Basement.Numerical.Multiplicative +import Basement.Types.OffsetSize +import Basement.Types.Word128 (Word128) +import qualified Basement.Types.Word128 as Word128 +import Basement.Types.Word256 (Word256) +import qualified Basement.Types.Word256 as Word256 +import Basement.IntegralConv (wordToInt) +import Basement.Nat + +import qualified Prelude +import qualified Data.Bits as OldBits +import Data.Maybe (fromMaybe) +import Data.Proxy +import GHC.Base hiding ((.)) +import GHC.Prim +import GHC.Types +import GHC.Word +import GHC.Int + +#if WORD_SIZE_IN_BITS < 64 +import GHC.IntWord64 +#endif + +-- | operation over finit bits +class FiniteBitsOps bits where + -- | get the number of bits in the given object + -- + numberOfBits :: bits -> CountOf Bool + + -- | rotate the given bit set. + rotateL :: bits -> CountOf Bool -> bits + -- | rotate the given bit set. + rotateR :: bits -> CountOf Bool -> bits + + -- | count of number of bit set to 1 in the given bit set. + popCount :: bits -> CountOf Bool + + -- | reverse all bits in the argument + bitFlip :: bits -> bits + + -- | count of the number of leading zeros + countLeadingZeros :: bits -> CountOf Bool + default countLeadingZeros :: BitOps bits => bits -> CountOf Bool + countLeadingZeros n = loop stop azero + where + stop = numberOfBits n + loop idx count + | idx == azero = count + | isBitSet n (sizeAsOffset idx) = count + | otherwise = loop (fromMaybe azero (idx - 1)) (count + 1) + + -- | count of the number of trailing zeros + countTrailingZeros :: bits -> CountOf Bool + default countTrailingZeros :: BitOps bits => bits -> CountOf Bool + countTrailingZeros n = loop azero + where + stop = numberOfBits n + loop count + | count == stop = count + | isBitSet n (sizeAsOffset count) = count + | otherwise = loop (count + 1) + +-- | operation over bits +class BitOps bits where + (.&.) :: bits -> bits -> bits + (.|.) :: bits -> bits -> bits + (.^.) :: bits -> bits -> bits + (.<<.) :: bits -> CountOf Bool -> bits + (.>>.) :: bits -> CountOf Bool -> bits + -- | construct a bit set with the bit at the given index set. + bit :: Offset Bool -> bits + default bit :: Integral bits => Offset Bool -> bits + bit n = 1 .<<. (offsetAsSize n) + + -- | test the bit at the given index is set + isBitSet :: bits -> Offset Bool -> Bool + default isBitSet :: (Integral bits, Eq bits) => bits -> Offset Bool -> Bool + isBitSet x n = x .&. (bit n) /= 0 + + -- | set the bit at the given index + setBit :: bits -> Offset Bool -> bits + default setBit :: Integral bits => bits -> Offset Bool -> bits + setBit x n = x .|. (bit n) + + -- | clear the bit at the given index + clearBit :: bits -> Offset Bool -> bits + default clearBit :: FiniteBitsOps bits => bits -> Offset Bool -> bits + clearBit x n = x .&. (bitFlip (bit n)) + +-- | Bool set of 'n' bits. +-- +newtype Bits (n :: Nat) = Bits { bitsToNatural :: Natural } + deriving (Show, Eq, Ord, Typeable) + +-- | convenient Type Constraint Alias fot 'Bits' functions +type SizeValid n = (KnownNat n, 1 <= n) + +-- convert an 'Int' into a 'Natural'. +-- This functions is not meant to be exported +lift :: Int -> Natural +lift = Prelude.fromIntegral +{-# INLINABLE lift #-} + +-- | convert the given 'Natural' into a 'Bits' of size 'n' +-- +-- if bits that are not within the boundaries of the 'Bits n' will be truncated. +toBits :: SizeValid n => Natural -> Bits n +toBits nat = Bits nat .&. allOne + +-- | construct a 'Bits' with all bits set. +-- +-- this function is equivalet to 'maxBound' +allOne :: forall n . SizeValid n => Bits n +allOne = Bits (2 Prelude.^ n Prelude.- midentity) + where + n = natVal (Proxy @n) + +instance SizeValid n => Enum (Bits n) where + toEnum i | i < 0 && lift i > bitsToNatural maxi = error "Bits n not within bound" + | otherwise = Bits (lift i) + where maxi = allOne :: Bits n + fromEnum (Bits n) = fromEnum n +instance SizeValid n => Bounded (Bits n) where + minBound = azero + maxBound = allOne +instance SizeValid n => Additive (Bits n) where + azero = Bits 0 + (+) (Bits a) (Bits b) = toBits (a + b) +instance SizeValid n => Subtractive (Bits n) where + type Difference (Bits n) = Bits n + (-) (Bits a) (Bits b) = maybe azero toBits (a - b) +instance SizeValid n => Multiplicative (Bits n) where + midentity = Bits 1 + (*) (Bits a) (Bits b) = Bits (a Prelude.* b) +instance SizeValid n => IDivisible (Bits n) where + div (Bits a) (Bits b) = Bits (a `Prelude.div` b) + mod (Bits a) (Bits b) = Bits (a `Prelude.mod` b) + divMod (Bits a) (Bits b) = let (q, r) = Prelude.divMod a b in (Bits q, Bits r) + +instance SizeValid n => BitOps (Bits n) where + (.&.) (Bits a) (Bits b) = Bits (a OldBits..&. b) + (.|.) (Bits a) (Bits b) = Bits (a OldBits..|. b) + (.^.) (Bits a) (Bits b) = Bits (a `OldBits.xor` b) + (.<<.) (Bits a) (CountOf w) = Bits (a `OldBits.shiftL` w) + (.>>.) (Bits a) (CountOf w) = Bits (a `OldBits.shiftR` w) + bit (Offset w) = Bits (OldBits.bit w) + isBitSet (Bits a) (Offset w) = OldBits.testBit a w + setBit (Bits a) (Offset w) = Bits (OldBits.setBit a w) + clearBit (Bits a) (Offset w) = Bits (OldBits.clearBit a w) +instance (SizeValid n, NatWithinBound (CountOf Bool) n) => FiniteBitsOps (Bits n) where + bitFlip (Bits a) = Bits (OldBits.complement a) + numberOfBits _ = natValCountOf (Proxy @n) + rotateL a i = (a .<<. i) .|. (a .>>. d) + where + n = natValCountOf (Proxy :: Proxy n) + d = fromMaybe (fromMaybe (error "impossible") (i - n)) (n - i) + rotateR a i = (a .>>. i) .|. (a .<<. d) + where + n = natValCountOf (Proxy :: Proxy n) + d = fromMaybe (fromMaybe (error "impossible") (i - n)) (n - i) + popCount (Bits n) = CountOf (OldBits.popCount n) + +-- Bool ------------------------------------------------------------------------ + +instance FiniteBitsOps Bool where + numberOfBits _ = 1 + rotateL x _ = x + rotateR x _ = x + popCount True = 1 + popCount False = 0 + bitFlip = not + countLeadingZeros True = 0 + countLeadingZeros False = 1 + countTrailingZeros True = 0 + countTrailingZeros False = 1 +instance BitOps Bool where + (.&.) = (&&) + (.|.) = (||) + (.^.) = (/=) + x .<<. 0 = x + _ .<<. _ = False + x .>>. 0 = x + _ .>>. _ = False + bit 0 = True + bit _ = False + isBitSet x 0 = x + isBitSet _ _ = False + setBit _ 0 = True + setBit _ _ = False + clearBit _ 0 = False + clearBit x _ = x + +-- Word8 ---------------------------------------------------------------------- + +instance FiniteBitsOps Word8 where + numberOfBits _ = 8 + rotateL (W8# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = W8# x# + | otherwise = W8# (narrow8Word# ((x# `uncheckedShiftL#` i'#) `or#` + (x# `uncheckedShiftRL#` (8# -# i'#)))) + where + !i'# = word2Int# (int2Word# i# `and#` 7##) + rotateR (W8# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = W8# x# + | otherwise = W8# (narrow8Word# ((x# `uncheckedShiftRL#` i'#) `or#` + (x# `uncheckedShiftL#` (8# -# i'#)))) + where + !i'# = word2Int# (int2Word# i# `and#` 7##) + bitFlip (W8# x#) = W8# (x# `xor#` mb#) + where !(W8# mb#) = maxBound + popCount (W8# x#) = CountOf $ wordToInt (W# (popCnt8# x#)) + countLeadingZeros (W8# w#) = CountOf $ wordToInt (W# (clz8# w#)) + countTrailingZeros (W8# w#) = CountOf $ wordToInt (W# (ctz8# w#)) +instance BitOps Word8 where + (W8# x#) .&. (W8# y#) = W8# (x# `and#` y#) + (W8# x#) .|. (W8# y#) = W8# (x# `or#` y#) + (W8# x#) .^. (W8# y#) = W8# (x# `xor#` y#) + (W8# x#) .<<. (CountOf (I# i#)) = W8# (narrow8Word# (x# `shiftL#` i#)) + (W8# x#) .>>. (CountOf (I# i#)) = W8# (narrow8Word# (x# `shiftRL#` i#)) + +-- Word16 --------------------------------------------------------------------- + +instance FiniteBitsOps Word16 where + numberOfBits _ = 16 + rotateL (W16# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = W16# x# + | otherwise = W16# (narrow16Word# ((x# `uncheckedShiftL#` i'#) `or#` + (x# `uncheckedShiftRL#` (16# -# i'#)))) + where + !i'# = word2Int# (int2Word# i# `and#` 15##) + rotateR (W16# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = W16# x# + | otherwise = W16# (narrow16Word# ((x# `uncheckedShiftRL#` i'#) `or#` + (x# `uncheckedShiftL#` (16# -# i'#)))) + where + !i'# = word2Int# (int2Word# i# `and#` 15##) + bitFlip (W16# x#) = W16# (x# `xor#` mb#) + where !(W16# mb#) = maxBound + popCount (W16# x#) = CountOf $ wordToInt (W# (popCnt16# x#)) + countLeadingZeros (W16# w#) = CountOf $ wordToInt (W# (clz16# w#)) + countTrailingZeros (W16# w#) = CountOf $ wordToInt (W# (ctz16# w#)) +instance BitOps Word16 where + (W16# x#) .&. (W16# y#) = W16# (x# `and#` y#) + (W16# x#) .|. (W16# y#) = W16# (x# `or#` y#) + (W16# x#) .^. (W16# y#) = W16# (x# `xor#` y#) + (W16# x#) .<<. (CountOf (I# i#)) = W16# (narrow16Word# (x# `shiftL#` i#)) + (W16# x#) .>>. (CountOf (I# i#)) = W16# (narrow16Word# (x# `shiftRL#` i#)) + +-- Word32 --------------------------------------------------------------------- + +instance FiniteBitsOps Word32 where + numberOfBits _ = 32 + rotateL (W32# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = W32# x# + | otherwise = W32# (narrow32Word# ((x# `uncheckedShiftL#` i'#) `or#` + (x# `uncheckedShiftRL#` (32# -# i'#)))) + where + !i'# = word2Int# (int2Word# i# `and#` 31##) + rotateR (W32# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = W32# x# + | otherwise = W32# (narrow32Word# ((x# `uncheckedShiftRL#` i'#) `or#` + (x# `uncheckedShiftL#` (32# -# i'#)))) + where + !i'# = word2Int# (int2Word# i# `and#` 31##) + bitFlip (W32# x#) = W32# (x# `xor#` mb#) + where !(W32# mb#) = maxBound + popCount (W32# x#) = CountOf $ wordToInt (W# (popCnt32# x#)) + countLeadingZeros (W32# w#) = CountOf $ wordToInt (W# (clz32# w#)) + countTrailingZeros (W32# w#) = CountOf $ wordToInt (W# (ctz32# w#)) +instance BitOps Word32 where + (W32# x#) .&. (W32# y#) = W32# (x# `and#` y#) + (W32# x#) .|. (W32# y#) = W32# (x# `or#` y#) + (W32# x#) .^. (W32# y#) = W32# (x# `xor#` y#) + (W32# x#) .<<. (CountOf (I# i#)) = W32# (narrow32Word# (x# `shiftL#` i#)) + (W32# x#) .>>. (CountOf (I# i#)) = W32# (narrow32Word# (x# `shiftRL#` i#)) + +-- Word64 --------------------------------------------------------------------- + +#if WORD_SIZE_IN_BITS == 64 +instance FiniteBitsOps Word64 where + numberOfBits _ = 64 + rotateL (W64# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = W64# x# + | otherwise = W64# ((x# `uncheckedShiftL#` i'#) `or#` + (x# `uncheckedShiftRL#` (64# -# i'#))) + where + !i'# = word2Int# (int2Word# i# `and#` 63##) + rotateR (W64# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = W64# x# + | otherwise = W64# ((x# `uncheckedShiftRL#` i'#) `or#` + (x# `uncheckedShiftL#` (64# -# i'#))) + where + !i'# = word2Int# (int2Word# i# `and#` 63##) + bitFlip (W64# x#) = W64# (x# `xor#` mb#) + where !(W64# mb#) = maxBound + popCount (W64# x#) = CountOf $ wordToInt (W# (popCnt64# x#)) + countLeadingZeros (W64# w#) = CountOf $ wordToInt (W# (clz64# w#)) + countTrailingZeros (W64# w#) = CountOf $ wordToInt (W# (ctz64# w#)) +instance BitOps Word64 where + (W64# x#) .&. (W64# y#) = W64# (x# `and#` y#) + (W64# x#) .|. (W64# y#) = W64# (x# `or#` y#) + (W64# x#) .^. (W64# y#) = W64# (x# `xor#` y#) + (W64# x#) .<<. (CountOf (I# i#)) = W64# (x# `shiftL#` i#) + (W64# x#) .>>. (CountOf (I# i#)) = W64# (x# `shiftRL#` i#) +#else +instance FiniteBitsOps Word64 where + numberOfBits _ = 64 + rotateL (W64# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = W64# x# + | otherwise = W64# ((x# `uncheckedShiftL64#` i'#) `or64#` + (x# `uncheckedShiftRL64#` (64# -# i'#))) + where + !i'# = word2Int# (int2Word# i# `and#` 63##) + rotateR (W64# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = W64# x# + | otherwise = W64# ((x# `uncheckedShiftRL64#` i'#) `or64#` + (x# `uncheckedShiftL64#` (64# -# i'#))) + where + !i'# = word2Int# (int2Word# i# `and#` 63##) + bitFlip (W64# x#) = W64# (not64# x#) + popCount (W64# x#) = CountOf $ wordToInt (W# (popCnt64# x#)) + countLeadingZeros (W64# w#) = CountOf $ wordToInt (W# (clz64# w#)) + countTrailingZeros (W64# w#) = CountOf $ wordToInt (W# (ctz64# w#)) +instance BitOps Word64 where + (W64# x#) .&. (W64# y#) = W64# (x# `and64#` y#) + (W64# x#) .|. (W64# y#) = W64# (x# `or64#` y#) + (W64# x#) .^. (W64# y#) = W64# (x# `xor64#` y#) + (W64# x#) .<<. (CountOf (I# i#)) = W64# (x# `shiftL64#` i#) + (W64# x#) .>>. (CountOf (I# i#)) = W64# (x# `shiftRL64#` i#) + +shiftL64#, shiftRL64# :: Word64# -> Int# -> Word64# +a `shiftL64#` b | isTrue# (b >=# 64#) = wordToWord64# 0## + | otherwise = a `uncheckedShiftL64#` b +a `shiftRL64#` b | isTrue# (b >=# 64#) = wordToWord64# 0## + | otherwise = a `uncheckedShiftRL64#` b +#endif + +-- Word128 -------------------------------------------------------------------- + +instance FiniteBitsOps Word128 where + numberOfBits _ = 128 + rotateL w (CountOf n) = Word128.rotateL w n + rotateR w (CountOf n) = Word128.rotateR w n + bitFlip = Word128.complement + popCount = CountOf . Word128.popCount +instance BitOps Word128 where + (.&.) = Word128.bitwiseAnd + (.|.) = Word128.bitwiseOr + (.^.) = Word128.bitwiseXor + (.<<.) w (CountOf n) = Word128.shiftL w n + (.>>.) w (CountOf n) = Word128.shiftR w n + +-- Word256 -------------------------------------------------------------------- + +instance FiniteBitsOps Word256 where + numberOfBits _ = 256 + rotateL w (CountOf n) = Word256.rotateL w n + rotateR w (CountOf n) = Word256.rotateR w n + bitFlip = Word256.complement + popCount = CountOf . Word256.popCount +instance BitOps Word256 where + (.&.) = Word256.bitwiseAnd + (.|.) = Word256.bitwiseOr + (.^.) = Word256.bitwiseXor + (.<<.) w (CountOf n) = Word256.shiftL w n + (.>>.) w (CountOf n) = Word256.shiftR w n + +-- Int8 ----------------------------------------------------------------------- + +instance FiniteBitsOps Int8 where + numberOfBits _ = 8 + rotateL (I8# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = I8# x# + | otherwise = I8# (narrow8Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#` + (x'# `uncheckedShiftRL#` (8# -# i'#))))) + where + !x'# = narrow8Word# (int2Word# x#) + !i'# = word2Int# (int2Word# i# `and#` 7##) + rotateR (I8# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = I8# x# + | otherwise = I8# (narrow8Int# (word2Int# ((x'# `uncheckedShiftRL#` i'#) `or#` + (x'# `uncheckedShiftL#` (8# -# i'#))))) + where + !x'# = narrow8Word# (int2Word# x#) + !i'# = word2Int# (int2Word# i# `and#` 7##) + bitFlip (I8# x#) = I8# (word2Int# (not# (int2Word# x#))) + popCount (I8# x#) = CountOf $ wordToInt (W# (popCnt8# (int2Word# x#))) + countLeadingZeros (I8# w#) = CountOf $ wordToInt (W# (clz8# (int2Word# w#))) + countTrailingZeros (I8# w#) = CountOf $ wordToInt (W# (ctz8# (int2Word# w#))) +instance BitOps Int8 where + (I8# x#) .&. (I8# y#) = I8# (x# `andI#` y#) + (I8# x#) .|. (I8# y#) = I8# (x# `orI#` y#) + (I8# x#) .^. (I8# y#) = I8# (x# `xorI#` y#) + (I8# x#) .<<. (CountOf (I# i#)) = I8# (narrow8Int# (x# `iShiftL#` i#)) + (I8# x#) .>>. (CountOf (I# i#)) = I8# (narrow8Int# (x# `iShiftRL#` i#)) + +-- Int16 ---------------------------------------------------------------------- + +instance FiniteBitsOps Int16 where + numberOfBits _ = 16 + rotateL (I16# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = I16# x# + | otherwise = I16# (narrow16Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#` + (x'# `uncheckedShiftRL#` (16# -# i'#))))) + where + !x'# = narrow16Word# (int2Word# x#) + !i'# = word2Int# (int2Word# i# `and#` 15##) + rotateR (I16# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = I16# x# + | otherwise = I16# (narrow16Int# (word2Int# ((x'# `uncheckedShiftRL#` i'#) `or#` + (x'# `uncheckedShiftL#` (16# -# i'#))))) + where + !x'# = narrow16Word# (int2Word# x#) + !i'# = word2Int# (int2Word# i# `and#` 15##) + bitFlip (I16# x#) = I16# (word2Int# (not# (int2Word# x#))) + popCount (I16# x#) = CountOf $ wordToInt (W# (popCnt16# (int2Word# x#))) + countLeadingZeros (I16# w#) = CountOf $ wordToInt (W# (clz16# (int2Word# w#))) + countTrailingZeros (I16# w#) = CountOf $ wordToInt (W# (ctz16# (int2Word# w#))) +instance BitOps Int16 where + (I16# x#) .&. (I16# y#) = I16# (x# `andI#` y#) + (I16# x#) .|. (I16# y#) = I16# (x# `orI#` y#) + (I16# x#) .^. (I16# y#) = I16# (x# `xorI#` y#) + (I16# x#) .<<. (CountOf (I# i#)) = I16# (narrow16Int# (x# `iShiftL#` i#)) + (I16# x#) .>>. (CountOf (I# i#)) = I16# (narrow16Int# (x# `iShiftRL#` i#)) + +-- Int32 ---------------------------------------------------------------------- + +instance FiniteBitsOps Int32 where + numberOfBits _ = 32 + rotateL (I32# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = I32# x# + | otherwise = I32# (narrow32Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#` + (x'# `uncheckedShiftRL#` (32# -# i'#))))) + where + !x'# = narrow32Word# (int2Word# x#) + !i'# = word2Int# (int2Word# i# `and#` 31##) + rotateR (I32# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = I32# x# + | otherwise = I32# (narrow32Int# (word2Int# ((x'# `uncheckedShiftRL#` i'#) `or#` + (x'# `uncheckedShiftL#` (32# -# i'#))))) + where + !x'# = narrow32Word# (int2Word# x#) + !i'# = word2Int# (int2Word# i# `and#` 31##) + bitFlip (I32# x#) = I32# (word2Int# (not# (int2Word# x#))) + popCount (I32# x#) = CountOf $ wordToInt (W# (popCnt32# (int2Word# x#))) + countLeadingZeros (I32# w#) = CountOf $ wordToInt (W# (clz32# (int2Word# w#))) + countTrailingZeros (I32# w#) = CountOf $ wordToInt (W# (ctz32# (int2Word# w#))) +instance BitOps Int32 where + (I32# x#) .&. (I32# y#) = I32# (x# `andI#` y#) + (I32# x#) .|. (I32# y#) = I32# (x# `orI#` y#) + (I32# x#) .^. (I32# y#) = I32# (x# `xorI#` y#) + (I32# x#) .<<. (CountOf (I# i#)) = I32# (narrow32Int# (x# `iShiftL#` i#)) + (I32# x#) .>>. (CountOf (I# i#)) = I32# (narrow32Int# (x# `iShiftRL#` i#)) + +-- Int64 ---------------------------------------------------------------------- + +#if WORD_SIZE_IN_BITS == 64 +instance FiniteBitsOps Int64 where + numberOfBits _ = 64 + rotateL (I64# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = I64# x# + | otherwise = I64# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#` + (x'# `uncheckedShiftRL#` (64# -# i'#)))) + where + !x'# = int2Word# x# + !i'# = word2Int# (int2Word# i# `and#` 63##) + rotateR (I64# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = I64# x# + | otherwise = I64# (word2Int# ((x'# `uncheckedShiftRL#` i'#) `or#` + (x'# `uncheckedShiftL#` (64# -# i'#)))) + where + !x'# = int2Word# x# + !i'# = word2Int# (int2Word# i# `and#` 63##) + bitFlip (I64# x#) = I64# (word2Int# (int2Word# x# `xor#` int2Word# (-1#))) + popCount (I64# x#) = CountOf $ wordToInt (W# (popCnt64# (int2Word# x#))) + countLeadingZeros (I64# w#) = CountOf $ wordToInt (W# (clz64# (int2Word# w#))) + countTrailingZeros (I64# w#) = CountOf $ wordToInt (W# (ctz64# (int2Word# w#))) +instance BitOps Int64 where + (I64# x#) .&. (I64# y#) = I64# (x# `andI#` y#) + (I64# x#) .|. (I64# y#) = I64# (x# `orI#` y#) + (I64# x#) .^. (I64# y#) = I64# (x# `xorI#` y#) + (I64# x#) .<<. (CountOf (I# w#)) = I64# (x# `iShiftL#` w#) + (I64# x#) .>>. (CountOf (I# w#)) = I64# (x# `iShiftRL#` w#) +#else +instance FiniteBitsOps Int64 where + numberOfBits _ = 64 + rotateL (I64# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = I64# x# + | otherwise = I64# (word64ToInt64# ((x'# `uncheckedShiftL64#` i'#) `or64#` + (x'# `uncheckedShiftRL64#` (64# -# i'#)))) + where + !x'# = int64ToWord64# x# + !i'# = word2Int# (int2Word# i# `and#` 63##) + rotateR (I64# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = I64# x# + | otherwise = I64# (word64ToInt64# ((x'# `uncheckedShiftRL64#` i'#) `or64#` + (x'# `uncheckedShiftL64#` (64# -# i'#)))) + where + !x'# = int64ToWord64# x# + !i'# = word2Int# (int2Word# i# `and#` 63##) + bitFlip (I64# x#) = I64# (word64ToInt64# (not64# (int64ToWord64# x#))) + popCount (I64# x#) = CountOf $ wordToInt (W# (popCnt64# (int64ToWord64# x#))) + countLeadingZeros (I64# w#) = CountOf $ wordToInt (W# (clz64# (int64ToWord64# w#))) + countTrailingZeros (I64# w#) = CountOf $ wordToInt (W# (ctz64# (int64ToWord64# w#))) +instance BitOps Int64 where + (I64# x#) .&. (I64# y#) = I64# (word64ToInt64# (int64ToWord64# x# `and64#` int64ToWord64# y#)) + (I64# x#) .|. (I64# y#) = I64# (word64ToInt64# (int64ToWord64# x# `or64#` int64ToWord64# y#)) + (I64# x#) .^. (I64# y#) = I64# (word64ToInt64# (int64ToWord64# x# `xor64#` int64ToWord64# y#)) + (I64# x#) .<<. (CountOf (I# w#)) = I64# (x# `iShiftL64#` w#) + (I64# x#) .>>. (CountOf (I# w#)) = I64# (x# `iShiftRA64#` w#) + + +iShiftL64#, iShiftRA64# :: Int64# -> Int# -> Int64# +a `iShiftL64#` b | isTrue# (b >=# 64#) = intToInt64# 0# + | otherwise = a `uncheckedIShiftL64#` b +a `iShiftRA64#` b | isTrue# (b >=# 64#) && isTrue# (a `ltInt64#` (intToInt64# 0#)) + = intToInt64# (-1#) + | isTrue# (b >=# 64#) = intToInt64# 0# + | otherwise = a `uncheckedIShiftRA64#` b + +#endif diff --git a/Basement/Block.hs b/Basement/Block.hs --- a/Basement/Block.hs +++ b/Basement/Block.hs @@ -84,7 +84,6 @@ import Basement.Numerical.Additive import Basement.Numerical.Subtractive import Basement.Numerical.Multiplicative -import qualified Basement.Alg.Native.Prim as Prim import qualified Basement.Alg.Mutable as MutAlg import qualified Basement.Alg.Class as Alg import qualified Basement.Alg.PrimArray as Alg @@ -98,6 +97,10 @@ index (Block ba) = primBaIndex ba {-# INLINE index #-} +instance Alg.Indexable (Block Word8) Word64 where + index (Block ba) = primBaIndex ba + {-# INLINE index #-} + -- | Copy all the block content to the memory starting at the destination address unsafeCopyToPtr :: forall ty prim . PrimMonad prim => Block ty -- ^ the source block to copy @@ -278,12 +281,11 @@ breakEnd :: PrimType ty => (ty -> Bool) -> Block ty -> (Block ty, Block ty) breakEnd predicate blk - | k == end = (blk, mempty) - | otherwise = splitAt (offsetAsSize (k+1)) blk + | k == sentinel = (blk, mempty) + | otherwise = splitAt (offsetAsSize (k+1)) blk where - k = Alg.revFindIndexPredicate predicate blk 0 end - end = 0 `offsetPlusE` len - !len = length blk + !k = Alg.revFindIndexPredicate predicate blk 0 end + !end = sizeAsOffset $ length blk {-# SPECIALIZE [2] breakEnd :: (Word8 -> Bool) -> Block Word8 -> (Block Word8, Block Word8) #-} span :: PrimType ty => (ty -> Bool) -> Block ty -> (Block ty, Block ty) diff --git a/Basement/Block/Base.hs b/Basement/Block/Base.hs --- a/Basement/Block/Base.hs +++ b/Basement/Block/Base.hs @@ -386,7 +386,7 @@ -- to use to modify the contents -- -- If the Block is pinned, then its address is returned as is, --- however if it's unpinned, a pinned copy of the UArray is made +-- however if it's unpinned, a pinned copy of the Block is made -- before getting the address. withPtr :: PrimMonad prim => Block ty @@ -469,13 +469,11 @@ | isMutablePinned mb == Pinned = callWithPtr mb | otherwise = do trampoline <- unsafeNew Pinned vecSz - if not skipCopy - then unsafeCopyBytes trampoline 0 mb 0 vecSz - else pure () + unless skipCopy $ + unsafeCopyBytes trampoline 0 mb 0 vecSz r <- callWithPtr trampoline - if not skipCopyBack - then unsafeCopyBytes mb 0 trampoline 0 vecSz - else pure () + unless skipCopyBack $ + unsafeCopyBytes mb 0 trampoline 0 vecSz pure r where vecSz = mutableLengthBytes mb diff --git a/Basement/Block/Builder.hs b/Basement/Block/Builder.hs --- a/Basement/Block/Builder.hs +++ b/Basement/Block/Builder.hs @@ -21,7 +21,7 @@ , unsafeRunString ) where -import qualified Basement.Alg.Native.UTF8 as PrimBA +import qualified Basement.Alg.UTF8 as UTF8 import Basement.UTF8.Helper (charToBytes) import Basement.Numerical.Conversion (charToInt) import Basement.Block.Base (Block(..), MutableBlock(..)) @@ -147,5 +147,5 @@ -- -- this function may be replaced by `emit :: Encoding -> Char -> Builder` emitUTF8Char :: Char -> Builder -emitUTF8Char c = Builder (charToBytes $ charToInt c) $ Action $ \(MutableBlock arr) off -> - PrimBA.write arr off c +emitUTF8Char c = Builder (charToBytes $ charToInt c) $ Action $ \block@(MutableBlock !_) off -> + UTF8.writeUTF8 block off c diff --git a/Basement/Compat/Base.hs b/Basement/Compat/Base.hs --- a/Basement/Compat/Base.hs +++ b/Basement/Compat/Base.hs @@ -34,6 +34,8 @@ , Prelude.Functor (..) , Control.Applicative.Applicative (..) , Prelude.Monad (..) + , Control.Monad.when + , Control.Monad.unless , Prelude.Maybe (..) , Prelude.Ordering (..) , Prelude.Bool (..) @@ -69,6 +71,7 @@ import qualified Control.Category import qualified Control.Applicative import qualified Control.Exception +import qualified Control.Monad import qualified Data.Monoid import qualified Data.Data import qualified Data.Word diff --git a/Basement/Compat/Primitive.hs b/Basement/Compat/Primitive.hs --- a/Basement/Compat/Primitive.hs +++ b/Basement/Compat/Primitive.hs @@ -140,7 +140,7 @@ compatShrinkMutableByteArray# src i s = -- not check whether i is smaller than the size of the buffer case newAlignedPinnedByteArray# i 8# s of { (# s2, dst #) -> - case copyMutableByteArray# dst 0# src 0# i s2 of { s3 -> (# s3, dst #) }} + case copyMutableByteArray# src 0# dst 0# i s2 of { s3 -> (# s3, dst #) }} #endif {-# INLINE compatShrinkMutableByteArray# #-} @@ -151,7 +151,7 @@ #else compatResizeMutableByteArray# src i s = case newAlignedPinnedByteArray# i 8# s of { (# s2, dst #) -> - case copyMutableByteArray# dst 0# src 0# nbBytes s2 of { s3 -> (# s3, dst #) }} + case copyMutableByteArray# src 0# dst 0# nbBytes s2 of { s3 -> (# s3, dst #) }} where isGrow = bool# (i ># len) nbBytes diff --git a/Basement/From.hs b/Basement/From.hs --- a/Basement/From.hs +++ b/Basement/From.hs @@ -5,6 +5,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeOperators #-} -- | -- Module : Basement.From -- License : BSD-style @@ -50,7 +51,7 @@ import qualified Basement.Types.Word128 as Word128 import qualified Basement.Types.Word256 as Word256 import Basement.These -import Basement.PrimType (PrimType) +import Basement.PrimType (PrimType, PrimSize) import Basement.Types.OffsetSize import Basement.Compat.Natural import qualified Prelude (fromIntegral) @@ -247,6 +248,9 @@ #if __GLASGOW_HASKELL__ >= 800 instance From (BlockN.BlockN n ty) (Block.Block ty) where from = BlockN.toBlock +instance (PrimType a, PrimType b, KnownNat n, KnownNat m, ((PrimSize b) Basement.Nat.* m) ~ ((PrimSize a) Basement.Nat.* n)) + => From (BlockN.BlockN n a) (BlockN.BlockN m b) where + from = BlockN.cast instance (NatWithinBound Int n, PrimType ty) => From (BlockN.BlockN n ty) (UArray.UArray ty) where from = UArray.fromBlock . BlockN.toBlock instance (NatWithinBound Int n, PrimType ty) => From (BlockN.BlockN n ty) (BoxArray.Array ty) where diff --git a/Basement/Imports.hs b/Basement/Imports.hs --- a/Basement/Imports.hs +++ b/Basement/Imports.hs @@ -36,6 +36,8 @@ , Prelude.Functor (..) , Control.Applicative.Applicative (..) , Prelude.Monad (..) + , Control.Monad.when + , Control.Monad.unless , Prelude.Maybe (..) , Prelude.Ordering (..) , Prelude.Bool (..) @@ -87,6 +89,7 @@ import qualified Control.Category import qualified Control.Applicative import qualified Control.Exception +import qualified Control.Monad import qualified Data.Monoid import qualified Data.Data import qualified Data.Typeable diff --git a/Basement/Sized/Block.hs b/Basement/Sized/Block.hs --- a/Basement/Sized/Block.hs +++ b/Basement/Sized/Block.hs @@ -15,8 +15,12 @@ module Basement.Sized.Block ( BlockN , MutableBlockN + , length + , lengthBytes , toBlockN , toBlock + , new + , newPinned , singleton , replicate , thaw @@ -39,20 +43,29 @@ , reverse , sortBy , intersperse + , withPtr + , withMutablePtr + , withMutablePtrHint + , cast + , mutableCast ) where import Data.Proxy (Proxy(..)) import Basement.Compat.Base +import Basement.Numerical.Additive (scale) import Basement.Block (Block, MutableBlock(..), unsafeIndex) import qualified Basement.Block as B +import qualified Basement.Block.Base as B import Basement.Monad (PrimMonad, PrimState) import Basement.Nat import Basement.Types.OffsetSize import Basement.NormalForm -import Basement.PrimType (PrimType) -import Basement.Types.OffsetSize (CountOf(..), Offset(..), offsetSub) +import Basement.PrimType (PrimType, PrimSize, primSizeInBytes) -newtype BlockN (n :: Nat) a = BlockN { unBlock :: Block a } deriving (NormalForm, Eq, Show) +-- | Sized version of 'Block' +-- +newtype BlockN (n :: Nat) a = BlockN { unBlock :: Block a } + deriving (NormalForm, Eq, Show, Data, Ord) newtype MutableBlockN (n :: Nat) ty st = MutableBlockN { unMBlock :: MutableBlock ty st } @@ -63,9 +76,54 @@ where expected = toCount @n +length :: forall n ty + . (KnownNat n, Countable ty n) + => BlockN n ty + -> CountOf ty +length _ = toCount @n + +lengthBytes :: forall n ty + . PrimType ty + => BlockN n ty + -> CountOf Word8 +lengthBytes = B.lengthBytes . unBlock + toBlock :: BlockN n ty -> Block ty toBlock = unBlock +cast :: forall n m a b + . ( PrimType a, PrimType b + , KnownNat n, KnownNat m + , ((PrimSize b) * m) ~ ((PrimSize a) * n) + ) + => BlockN n a + -> BlockN m b +cast (BlockN b) = BlockN (B.unsafeCast b) + +mutableCast :: forall n m a b st + . ( PrimType a, PrimType b + , KnownNat n, KnownNat m + , ((PrimSize b) * m) ~ ((PrimSize a) * n) + ) + => MutableBlockN n a st + -> MutableBlockN m b st +mutableCast (MutableBlockN b) = MutableBlockN (B.unsafeRecast b) + +-- | Create a new unpinned mutable block of a specific N size of 'ty' elements +-- +-- If the size exceeds a GHC-defined threshold, then the memory will be +-- pinned. To be certain about pinning status with small size, use 'newPinned' +new :: forall n ty prim + . (PrimType ty, KnownNat n, Countable ty n, PrimMonad prim) + => prim (MutableBlockN n ty (PrimState prim)) +new = MutableBlockN <$> B.new (toCount @n) + +-- | Create a new pinned mutable block of a specific N size of 'ty' elements +newPinned :: forall n ty prim + . (PrimType ty, KnownNat n, Countable ty n, PrimMonad prim) + => prim (MutableBlockN n ty (PrimState prim)) +newPinned = MutableBlockN <$> B.newPinned (toCount @n) + singleton :: PrimType ty => ty -> BlockN 1 ty singleton a = BlockN (B.singleton a) @@ -155,3 +213,62 @@ toOffset :: forall n ty . (KnownNat n, Offsetable ty n) => Offset ty toOffset = natValOffset (Proxy @n) + +-- | Get a Ptr pointing to the data in the Block. +-- +-- Since a Block is immutable, this Ptr shouldn't be +-- to use to modify the contents +-- +-- If the Block is pinned, then its address is returned as is, +-- however if it's unpinned, a pinned copy of the Block is made +-- before getting the address. +withPtr :: (PrimMonad prim, KnownNat n) + => BlockN n ty + -> (Ptr ty -> prim a) + -> prim a +withPtr b = B.withPtr (unBlock b) + +-- | Create a pointer on the beginning of the MutableBlock +-- and call a function 'f'. +-- +-- The mutable block can be mutated by the 'f' function +-- and the change will be reflected in the mutable block +-- +-- If the mutable block is unpinned, a trampoline buffer +-- is created and the data is only copied when 'f' return. +-- +-- it is all-in-all highly inefficient as this cause 2 copies +withMutablePtr :: (PrimMonad prim, KnownNat n) + => MutableBlockN n ty (PrimState prim) + -> (Ptr ty -> prim a) + -> prim a +withMutablePtr mb = B.withMutablePtr (unMBlock mb) + +-- | Same as 'withMutablePtr' but allow to specify 2 optimisations +-- which is only useful when the MutableBlock is unpinned and need +-- a pinned trampoline to be called safely. +-- +-- If skipCopy is True, then the first copy which happen before +-- the call to 'f', is skipped. The Ptr is now effectively +-- pointing to uninitialized data in a new mutable Block. +-- +-- If skipCopyBack is True, then the second copy which happen after +-- the call to 'f', is skipped. Then effectively in the case of a +-- trampoline being used the memory changed by 'f' will not +-- be reflected in the original Mutable Block. +-- +-- If using the wrong parameters, it will lead to difficult to +-- debug issue of corrupted buffer which only present themselves +-- with certain Mutable Block that happened to have been allocated +-- unpinned. +-- +-- If unsure use 'withMutablePtr', which default to *not* skip +-- any copy. +withMutablePtrHint :: forall n ty prim a . (PrimMonad prim, KnownNat n) + => Bool -- ^ hint that the buffer doesn't need to have the same value as the mutable block when calling f + -> Bool -- ^ hint that the buffer is not supposed to be modified by call of f + -> MutableBlockN n ty (PrimState prim) + -> (Ptr ty -> prim a) + -> prim a +withMutablePtrHint skipCopy skipCopyBack (MutableBlockN mb) f = + B.withMutablePtrHint skipCopy skipCopyBack mb f diff --git a/Basement/Sized/List.hs b/Basement/Sized/List.hs --- a/Basement/Sized/List.hs +++ b/Basement/Sized/List.hs @@ -18,9 +18,13 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} module Basement.Sized.List ( ListN , toListN + , toListN_ , unListN , length , create @@ -29,26 +33,39 @@ , singleton , uncons , cons + , unsnoc + , snoc , index , indexStatic + , updateAt , map + , mapi , elem , foldl , foldl' + , foldl1' + , scanl' + , scanl1' , foldr + , foldr1 + , reverse , append , minimum , maximum , head , tail + , init , take , drop , splitAt , zip, zip3, zip4, zip5 + , unzip , zipWith, zipWith3, zipWith4, zipWith5 , replicate -- * Applicative And Monadic , replicateM + , sequence + , sequence_ , mapM , mapM_ ) where @@ -56,6 +73,8 @@ import Data.Proxy import qualified Data.List import Basement.Compat.Base +import Basement.Compat.CallStack +import Basement.Compat.Natural import Basement.Nat import Basement.NormalForm import Basement.Numerical.Additive @@ -63,13 +82,14 @@ import Basement.Types.OffsetSize import Basement.Compat.ExtList ((!!)) import qualified Prelude -import qualified Control.Monad as M (replicateM, mapM, mapM_) +import qualified Control.Monad as M (replicateM, mapM, mapM_, sequence, sequence_) -impossible :: a +impossible :: HasCallStack => a impossible = error "ListN: internal error: the impossible happened" +-- | A Typed-level sized List equivalent to [a] newtype ListN (n :: Nat) a = ListN { unListN :: [a] } - deriving (Eq,Ord) + deriving (Eq,Ord,Typeable,Generic) instance Show a => Show (ListN n a) where show (ListN l) = show l @@ -77,6 +97,7 @@ instance NormalForm a => NormalForm (ListN n a) where toNormalForm (ListN l) = toNormalForm l +-- | Try to create a ListN from a List, succeeding if the length is correct toListN :: forall (n :: Nat) a . (KnownNat n, NatWithinBound Int n) => [a] -> Maybe (ListN n a) toListN l | expected == Prelude.fromIntegral (Prelude.length l) = Just (ListN l) @@ -84,122 +105,249 @@ where expected = natValInt (Proxy :: Proxy n) +-- | Create a ListN from a List, expecting a given length +-- +-- If this list contains more or less than the expected length of the resulting type, +-- then an asynchronous error is raised. use 'toListN' for a more friendly functions +toListN_ :: forall n a . (HasCallStack, NatWithinBound Int n, KnownNat n) => [a] -> ListN n a +toListN_ l + | expected == got = ListN l + | otherwise = error ("toListN_: expecting list of " <> show expected <> " elements, got " <> show got <> " elements") + where + expected = natValInt (Proxy :: Proxy n) + got = Prelude.length l + +-- | performs a monadic action n times, gathering the results in a List of size n. replicateM :: forall (n :: Nat) m a . (NatWithinBound Int n, Monad m, KnownNat n) => m a -> m (ListN n a) replicateM action = ListN <$> M.replicateM (Prelude.fromIntegral $ natVal (Proxy :: Proxy n)) action +-- | Evaluate each monadic action in the list sequentially, and collect the results. +sequence :: Monad m => ListN n (m a) -> m (ListN n a) +sequence (ListN l) = ListN <$> M.sequence l + +-- | Evaluate each monadic action in the list sequentially, and ignore the results. +sequence_ :: Monad m => ListN n (m a) -> m () +sequence_ (ListN l) = M.sequence_ l + +-- | Map each element of a List to a monadic action, evaluate these +-- actions sequentially and collect the results mapM :: Monad m => (a -> m b) -> ListN n a -> m (ListN n b) mapM f (ListN l) = ListN <$> M.mapM f l +-- | Map each element of a List to a monadic action, evaluate these +-- actions sequentially and ignore the results mapM_ :: Monad m => (a -> m b) -> ListN n a -> m () mapM_ f (ListN l) = M.mapM_ f l +-- | Create a list of n elements where each element is the element in argument replicate :: forall (n :: Nat) a . (NatWithinBound Int n, KnownNat n) => a -> ListN n a replicate a = ListN $ Prelude.replicate (Prelude.fromIntegral $ natVal (Proxy :: Proxy n)) a -uncons :: CmpNat n 0 ~ 'GT => ListN n a -> (a, ListN (n-1) a) +-- | Decompose a list into its head and tail. +uncons :: (1 <= n) => ListN n a -> (a, ListN (n-1) a) uncons (ListN (x:xs)) = (x, ListN xs) uncons _ = impossible +-- | prepend an element to the list cons :: a -> ListN n a -> ListN (n+1) a cons a (ListN l) = ListN (a : l) +-- | Decompose a list into its first elements and the last. +unsnoc :: (1 <= n) => ListN n a -> (ListN (n-1) a, a) +unsnoc (ListN l) = (ListN $ Data.List.init l, Data.List.last l) + +-- | append an element to the list +snoc :: ListN n a -> a -> ListN (n+1) a +snoc (ListN l) a = ListN (l Prelude.++ [a]) + +-- | Create an empty list of a empty :: ListN 0 a empty = ListN [] -length :: forall a (n :: Nat) . (KnownNat n, NatWithinBound Int n) => ListN n a -> Int -length _ = natValInt (Proxy :: Proxy n) +-- | Get the length of a list +length :: forall a (n :: Nat) . (KnownNat n, NatWithinBound Int n) => ListN n a -> CountOf a +length _ = CountOf $ natValInt (Proxy :: Proxy n) -create :: forall a (n :: Nat) . KnownNat n => (Integer -> a) -> ListN n a -create f = ListN $ Prelude.map f [0..(len-1)] +-- | Create a new list of size n, repeately calling f from 0 to n-1 +create :: forall a (n :: Nat) . KnownNat n => (Natural -> a) -> ListN n a +create f = ListN $ Prelude.map (f . Prelude.fromIntegral) [0..(len-1)] where len = natVal (Proxy :: Proxy n) +-- | Same as create but apply an offset createFrom :: forall a (n :: Nat) (start :: Nat) . (KnownNat n, KnownNat start) - => Proxy start -> (Integer -> a) -> ListN n a -createFrom p f = ListN $ Prelude.map f [idx..(idx+len-1)] + => Proxy start -> (Natural -> a) -> ListN n a +createFrom p f = ListN $ Prelude.map (f . Prelude.fromIntegral) [idx..(idx+len-1)] where len = natVal (Proxy :: Proxy n) idx = natVal p +-- | create a list of 1 element singleton :: a -> ListN 1 a singleton a = ListN [a] +-- | Check if a list contains the element a elem :: Eq a => a -> ListN n a -> Bool elem a (ListN l) = Prelude.elem a l +-- | Append 2 list together returning the new list append :: ListN n a -> ListN m a -> ListN (n+m) a append (ListN l1) (ListN l2) = ListN (l1 <> l2) -maximum :: (Ord a, CmpNat n 0 ~ 'GT) => ListN n a -> a +-- | Get the maximum element of a list +maximum :: (Ord a, 1 <= n) => ListN n a -> a maximum (ListN l) = Prelude.maximum l -minimum :: (Ord a, CmpNat n 0 ~ 'GT) => ListN n a -> a +-- | Get the minimum element of a list +minimum :: (Ord a, 1 <= n) => ListN n a -> a minimum (ListN l) = Prelude.minimum l -head :: CmpNat n 0 ~ 'GT => ListN n a -> a +-- | Get the head element of a list +head :: (1 <= n) => ListN n a -> a head (ListN (x:_)) = x head _ = impossible -tail :: CmpNat n 0 ~ 'GT => ListN n a -> ListN (n-1) a +-- | Get the tail of a list +tail :: (1 <= n) => ListN n a -> ListN (n-1) a tail (ListN (_:xs)) = ListN xs tail _ = impossible +-- | Get the list with the last element missing +init :: (1 <= n) => ListN n a -> ListN (n-1) a +init (ListN l) = ListN $ Data.List.init l + +-- | Take m elements from the beggining of the list. +-- +-- The number of elements need to be less or equal to the list in argument take :: forall a (m :: Nat) (n :: Nat) . (KnownNat m, NatWithinBound Int m, m <= n) => ListN n a -> ListN m a take (ListN l) = ListN (Prelude.take n l) where n = natValInt (Proxy :: Proxy m) +-- | Drop elements from a list keeping the m remaining elements drop :: forall a d (m :: Nat) (n :: Nat) . (KnownNat d, NatWithinBound Int d, (n - m) ~ d, m <= n) => ListN n a -> ListN m a drop (ListN l) = ListN (Prelude.drop n l) where n = natValInt (Proxy :: Proxy d) +-- | Split a list into two, returning 2 lists splitAt :: forall a d (m :: Nat) (n :: Nat) . (KnownNat d, NatWithinBound Int d, (n - m) ~ d, m <= n) => ListN n a -> (ListN m a, ListN (n-m) a) splitAt (ListN l) = let (l1, l2) = Prelude.splitAt n l in (ListN l1, ListN l2) where n = natValInt (Proxy :: Proxy d) +-- | Get the i'th elements +-- +-- This only works with TypeApplication: +-- +-- > indexStatic @1 (toListN_ [1,2,3] :: ListN 3 Int) indexStatic :: forall i n a . (KnownNat i, CmpNat i n ~ 'LT, Offsetable a i) => ListN n a -> a indexStatic (ListN l) = l !! (natValOffset (Proxy :: Proxy i)) +-- | Get the i'the element index :: ListN n ty -> Offset ty -> ty index (ListN l) ofs = l !! ofs +-- | Update the value in a list at a specific location +updateAt :: forall n a + . Offset a + -> (a -> a) + -> ListN n a + -> ListN n a +updateAt o f (ListN l) = ListN (doUpdate 0 l) + where doUpdate _ [] = [] + doUpdate i (x:xs) + | i == o = f x : xs + | otherwise = x : doUpdate (i+1) xs + +-- | Map all elements in a list map :: (a -> b) -> ListN n a -> ListN n b map f (ListN l) = ListN (Prelude.map f l) +-- | Map all elements in a list with an additional index +mapi :: (Natural -> a -> b) -> ListN n a -> ListN n b +mapi f (ListN l) = ListN . loop 0 $ l + where loop _ [] = [] + loop i (x:xs) = f i x : loop (i+1) xs + +-- | Fold all elements from left foldl :: (b -> a -> b) -> b -> ListN n a -> b foldl f acc (ListN l) = Prelude.foldl f acc l +-- | Fold all elements from left strictly foldl' :: (b -> a -> b) -> b -> ListN n a -> b foldl' f acc (ListN l) = Data.List.foldl' f acc l +-- | Fold all elements from left strictly with a first element +-- as the accumulator +foldl1' :: (1 <= n) => (a -> a -> a) -> ListN n a -> a +foldl1' f (ListN l) = Data.List.foldl1' f l + +-- | Fold all elements from right foldr :: (a -> b -> b) -> b -> ListN n a -> b foldr f acc (ListN l) = Prelude.foldr f acc l +-- | Fold all elements from right assuming at least one element is in the list. +foldr1 :: (1 <= n) => (a -> a -> a) -> ListN n a -> a +foldr1 f (ListN l) = Prelude.foldr1 f l + +-- | 'scanl' is similar to 'foldl', but returns a list of successive +-- reduced values from the left +-- +-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] +scanl' :: (b -> a -> b) -> b -> ListN n a -> ListN (n+1) b +scanl' f initialAcc (ListN start) = ListN (go initialAcc start) + where + go !acc l = acc : case l of + [] -> [] + (x:xs) -> go (f acc x) xs + +-- | 'scanl1' is a variant of 'scanl' that has no starting value argument: +-- +-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...] +scanl1' :: (a -> a -> a) -> ListN n a -> ListN n a +scanl1' f (ListN l) = case l of + [] -> ListN [] + (x:xs) -> ListN $ Data.List.scanl' f x xs + +-- | Reverse a list +reverse :: ListN n a -> ListN n a +reverse (ListN l) = ListN (Prelude.reverse l) + +-- | Zip 2 lists of the same size, returning a new list of +-- the tuple of each elements zip :: ListN n a -> ListN n b -> ListN n (a,b) zip (ListN l1) (ListN l2) = ListN (Prelude.zip l1 l2) +-- | Unzip a list of tuple, to 2 List of the deconstructed tuples +unzip :: ListN n (a,b) -> (ListN n a, ListN n b) +unzip l = (map fst l, map snd l) + +-- | Zip 3 lists of the same size zip3 :: ListN n a -> ListN n b -> ListN n c -> ListN n (a,b,c) zip3 (ListN x1) (ListN x2) (ListN x3) = ListN (loop x1 x2 x3) where loop (l1:l1s) (l2:l2s) (l3:l3s) = (l1,l2,l3) : loop l1s l2s l3s loop [] _ _ = [] loop _ _ _ = impossible +-- | Zip 4 lists of the same size zip4 :: ListN n a -> ListN n b -> ListN n c -> ListN n d -> ListN n (a,b,c,d) zip4 (ListN x1) (ListN x2) (ListN x3) (ListN x4) = ListN (loop x1 x2 x3 x4) where loop (l1:l1s) (l2:l2s) (l3:l3s) (l4:l4s) = (l1,l2,l3,l4) : loop l1s l2s l3s l4s loop [] _ _ _ = [] loop _ _ _ _ = impossible +-- | Zip 5 lists of the same size zip5 :: ListN n a -> ListN n b -> ListN n c -> ListN n d -> ListN n e -> ListN n (a,b,c,d,e) zip5 (ListN x1) (ListN x2) (ListN x3) (ListN x4) (ListN x5) = ListN (loop x1 x2 x3 x4 x5) where loop (l1:l1s) (l2:l2s) (l3:l3s) (l4:l4s) (l5:l5s) = (l1,l2,l3,l4,l5) : loop l1s l2s l3s l4s l5s loop [] _ _ _ _ = [] loop _ _ _ _ _ = impossible +-- | Zip 2 lists using a function zipWith :: (a -> b -> x) -> ListN n a -> ListN n b -> ListN n x zipWith f (ListN (v1:vs)) (ListN (w1:ws)) = ListN (f v1 w1 : unListN (zipWith f (ListN vs) (ListN ws))) zipWith _ (ListN []) _ = ListN [] zipWith _ _ _ = impossible +-- | Zip 3 lists using a function zipWith3 :: (a -> b -> c -> x) -> ListN n a -> ListN n b @@ -210,6 +358,7 @@ zipWith3 _ (ListN []) _ _ = ListN [] zipWith3 _ _ _ _ = impossible +-- | Zip 4 lists using a function zipWith4 :: (a -> b -> c -> d -> x) -> ListN n a -> ListN n b @@ -221,6 +370,7 @@ zipWith4 _ (ListN []) _ _ _ = ListN [] zipWith4 _ _ _ _ _ = impossible +-- | Zip 5 lists using a function zipWith5 :: (a -> b -> c -> d -> e -> x) -> ListN n a -> ListN n b diff --git a/Basement/String.hs b/Basement/String.hs --- a/Basement/String.hs +++ b/Basement/String.hs @@ -79,6 +79,7 @@ , readFloatingExact , upper , lower + , caseFold , isPrefixOf , isSuffixOf , isInfixOf @@ -99,6 +100,7 @@ import qualified Basement.UArray as C import qualified Basement.UArray.Mutable as MVec import Basement.Block.Mutable (Block(..), MutableBlock(..)) +import qualified Basement.Block.Mutable as MBLK import Basement.Compat.Bifunctor import Basement.Compat.Base import Basement.Compat.Natural @@ -116,16 +118,15 @@ import Basement.IntegralConv import Basement.Floating import Basement.MutableBuilder -import Basement.String.CaseMapping (upperMapping, lowerMapping) +import Basement.String.CaseMapping (upperMapping, lowerMapping, foldMapping) import Basement.UTF8.Table import Basement.UTF8.Helper import Basement.UTF8.Base import Basement.UTF8.Types -import Basement.UArray.Base as C (onBackendPrim, onBackend, offset, ValidRange(..), offsetsValidRange) -import qualified Basement.Alg.Native.UTF8 as PrimBA -import qualified Basement.Alg.Foreign.UTF8 as PrimAddr -import qualified Basement.Alg.Native.String as BackendBA -import qualified Basement.Alg.Foreign.String as BackendAddr +import Basement.UArray.Base as C (onBackendPrim, onBackend, onBackendPure, offset, ValidRange(..), offsetsValidRange, MUArray(..), MUArrayBackend(..)) +import Basement.Alg.Class (Indexable) +import qualified Basement.Alg.UTF8 as UTF8 +import qualified Basement.Alg.String as Alg import GHC.Prim import GHC.ST import GHC.Types @@ -167,9 +168,9 @@ where unTranslateOffset start = first (\e -> e `offsetSub` start) goBa ba start = - unTranslateOffset start $ BackendBA.validate (start+end) ba (start + ofsStart) - goAddr (Ptr addr) start = - pure $ unTranslateOffset start $ BackendAddr.validate (start+end) addr (ofsStart + start) + unTranslateOffset start $ Alg.validate (start+end) ba (start + ofsStart) + goAddr ptr@(Ptr !_) start = + pure $ unTranslateOffset start $ Alg.validate (start+end) ptr (ofsStart + start) end = ofsStart `offsetPlusE` sz -- | Similar to 'validate' but works on a 'MutableByteArray' @@ -360,8 +361,8 @@ indexN :: CountOf Char -> String -> Offset Word8 indexN !n (String ba) = Vec.unsafeDewrap goVec goAddr ba where - goVec :: ByteArray# -> Offset Word8 -> Offset Word8 - goVec !ma !start = loop start 0 + goVec :: Block Word8 -> Offset Word8 -> Offset Word8 + goVec (Block !ma) !start = loop start 0 where !len = start `offsetPlusE` Vec.length ba loop :: Offset Word8 -> Offset Char -> Offset Word8 @@ -469,15 +470,15 @@ breakEnd :: (Char -> Bool) -> String -> (String, String) breakEnd predicate s@(String arr) | k == end = (s, mempty) - | otherwise = splitIndex k s + | otherwise = splitIndex (k `offsetSub` start) s where k = C.onBackend goVec (\_ -> pure . goAddr) arr (C.ValidRange !start !end) = offsetsValidRange arr - goVec (Block ba) = let k = BackendBA.revFindIndexPredicate predicate ba start end - in if k == end then end else PrimBA.nextSkip ba k - goAddr (Ptr addr) = - let k = BackendAddr.revFindIndexPredicate predicate addr start end - in if k == end then end else PrimAddr.nextSkip addr k + goVec ba@(Block !_) = let k = Alg.revFindIndexPredicate predicate ba start end + in if k == end then end else UTF8.nextSkip ba k + goAddr ptr@(Ptr !_) = + let k = Alg.revFindIndexPredicate predicate ptr start end + in if k == end then end else UTF8.nextSkip ptr k {-# INLINE [2] breakEnd #-} #if MIN_VERSION_base(4,9,0) @@ -606,8 +607,8 @@ | otherwise = C.onBackend goVec (\_ -> pure . goAddr) arr where (C.ValidRange !start !end) = offsetsValidRange arr - goVec (Block ma) = PrimBA.length ma start end - goAddr (Ptr ptr) = PrimAddr.length ptr start end + goVec ma = UTF8.length ma start end + goAddr ptr = UTF8.length ptr start end -- | Replicate a character @c@ @n@ times to create a string of length @n@ replicate :: CountOf Char -> Char -> String @@ -787,8 +788,8 @@ filter :: (Char -> Bool) -> String -> String filter predicate (String arr) = runST $ do (finalSize, dst) <- newNative sz $ \(MutableBlock mba) -> - C.onBackendPrim (\(Block ba) -> BackendBA.copyFilter predicate sz mba ba start) - (\fptr -> withFinalPtr fptr $ \(Ptr addr) -> BackendAddr.copyFilter predicate sz mba addr start) + C.onBackendPrim (\ba@(Block !_) -> Alg.copyFilter predicate sz mba ba start) + (\fptr -> withFinalPtr fptr $ \ptr@(Ptr !_) -> Alg.copyFilter predicate sz mba ptr start) arr freezeShrink finalSize dst where @@ -800,8 +801,8 @@ reverse (String arr) = runST $ do ((), dst) <- newNative (C.length arr) $ \(MutableBlock mba) -> C.onBackendPrim - (\(Block ba) -> PrimBA.reverse mba 0 ba start end) - (\fptr -> withFinalPtr fptr $ \(Ptr addr) -> PrimAddr.reverse mba 0 addr start end) + (\ba@(Block !_) -> UTF8.reverse mba 0 ba start end) + (\fptr -> withFinalPtr fptr $ \ptr@(Ptr !_) -> UTF8.reverse mba 0 ptr start end) arr freeze dst where @@ -1054,7 +1055,7 @@ builderBuild_ :: PrimMonad m => Int -> Builder String MutableString Word8 m () () -> m String builderBuild_ sizeChunksI sb = either (\() -> internalError "impossible output") id <$> builderBuild sizeChunksI sb -stringDewrap :: (ByteArray# -> Offset Word8 -> a) +stringDewrap :: (Block Word8 -> Offset Word8 -> a) -> (Ptr Word8 -> Offset Word8 -> ST s a) -> String -> a @@ -1067,18 +1068,18 @@ readIntegral :: (HasNegation i, IntegralUpsize Word8 i, Additive i, Multiplicative i, IsIntegral i) => String -> Maybe i readIntegral str | sz == 0 = Nothing - | otherwise = stringDewrap withBa (\(Ptr ptr) -> pure . withPtr ptr) str + | otherwise = stringDewrap withBa (\ptr@(Ptr !_) -> pure . withPtr ptr) str where !sz = size str withBa ba ofs = - let negativeSign = PrimBA.expectAscii ba ofs 0x2d + let negativeSign = UTF8.expectAscii ba ofs 0x2d startOfs = if negativeSign then succ ofs else ofs in case decimalDigitsBA 0 ba endOfs startOfs of (# acc, True, endOfs' #) | endOfs' > startOfs -> Just $! if negativeSign then negate acc else acc _ -> Nothing where !endOfs = ofs `offsetPlusE` sz withPtr addr ofs = - let negativeSign = PrimAddr.expectAscii addr ofs 0x2d + let negativeSign = UTF8.expectAscii addr ofs 0x2d startOfs = if negativeSign then succ ofs else ofs in case decimalDigitsPtr 0 addr endOfs startOfs of (# acc, True, endOfs' #) | endOfs' > startOfs -> Just $! if negativeSign then negate acc else acc @@ -1096,7 +1097,7 @@ readNatural :: String -> Maybe Natural readNatural str | sz == 0 = Nothing - | otherwise = stringDewrap withBa (\(Ptr ptr) -> pure . withPtr ptr) str + | otherwise = stringDewrap withBa (\ptr@(Ptr !_) -> pure . withPtr ptr) str where !sz = size str withBa ba stringStart = @@ -1178,7 +1179,7 @@ !sz = size str withBa ba stringStart = - let !isNegative = PrimBA.expectAscii ba stringStart 0x2d + let !isNegative = UTF8.expectAscii ba stringStart 0x2d in consumeIntegral isNegative (if isNegative then stringStart+1 else stringStart) where eofs = stringStart `offsetPlusE` sz @@ -1186,7 +1187,7 @@ case decimalDigitsBA 0 ba eofs startOfs of (# acc, True , endOfs #) | endOfs > startOfs -> f isNegative acc 0 Nothing -- end of stream and no '.' (# acc, False, endOfs #) | endOfs > startOfs -> - if PrimBA.expectAscii ba endOfs 0x2e + if UTF8.expectAscii ba endOfs 0x2e then consumeFloat isNegative acc (endOfs + 1) else consumeExponant isNegative acc 0 endOfs _ -> Nothing @@ -1203,22 +1204,22 @@ | startOfs == eofs = f isNegative integral floatingDigits Nothing | otherwise = -- consume 'E' or 'e' - case PrimBA.nextAscii ba startOfs of + case UTF8.nextAscii ba startOfs of StepASCII 0x45 -> consumeExponantSign (startOfs+1) StepASCII 0x65 -> consumeExponantSign (startOfs+1) _ -> Nothing where consumeExponantSign ofs | ofs == eofs = Nothing - | otherwise = let exponentNegative = PrimBA.expectAscii ba ofs 0x2d + | otherwise = let exponentNegative = UTF8.expectAscii ba ofs 0x2d in consumeExponantNumber exponentNegative (if exponentNegative then ofs + 1 else ofs) consumeExponantNumber exponentNegative ofs = case decimalDigitsBA 0 ba eofs ofs of (# acc, True, endOfs #) | endOfs > ofs -> f isNegative integral floatingDigits (Just $! if exponentNegative then negate acc else acc) _ -> Nothing - withPtr (Ptr ptr) stringStart = pure $ - let !isNegative = PrimAddr.expectAscii ptr stringStart 0x2d + withPtr ptr@(Ptr !_) stringStart = pure $ + let !isNegative = UTF8.expectAscii ptr stringStart 0x2d in consumeIntegral isNegative (if isNegative then stringStart+1 else stringStart) where eofs = stringStart `offsetPlusE` sz @@ -1226,7 +1227,7 @@ case decimalDigitsPtr 0 ptr eofs startOfs of (# acc, True , endOfs #) | endOfs > startOfs -> f isNegative acc 0 Nothing -- end of stream and no '.' (# acc, False, endOfs #) | endOfs > startOfs -> - if PrimAddr.expectAscii ptr endOfs 0x2e + if UTF8.expectAscii ptr endOfs 0x2e then consumeFloat isNegative acc (endOfs + 1) else consumeExponant isNegative acc 0 endOfs _ -> Nothing @@ -1243,14 +1244,14 @@ | startOfs == eofs = f isNegative integral floatingDigits Nothing | otherwise = -- consume 'E' or 'e' - case PrimAddr.nextAscii ptr startOfs of + case UTF8.nextAscii ptr startOfs of StepASCII 0x45 -> consumeExponantSign (startOfs+1) StepASCII 0x65 -> consumeExponantSign (startOfs+1) _ -> Nothing where consumeExponantSign ofs | ofs == eofs = Nothing - | otherwise = let exponentNegative = PrimAddr.expectAscii ptr ofs 0x2d + | otherwise = let exponentNegative = UTF8.expectAscii ptr ofs 0x2d in consumeExponantNumber exponentNegative (if exponentNegative then ofs + 1 else ofs) consumeExponantNumber exponentNegative ofs = @@ -1282,7 +1283,7 @@ -- this function decimalDigitsBA :: (IntegralUpsize Word8 acc, Additive acc, Multiplicative acc, Integral acc) => acc - -> ByteArray# + -> Block Word8 -> Offset Word8 -- end offset -> Offset Word8 -- start offset -> (# acc, Bool, Offset Word8 #) @@ -1291,18 +1292,18 @@ loop !acc !ofs | ofs == endOfs = (# acc, True, ofs #) | otherwise = - case PrimBA.nextAsciiDigit ba ofs of + case UTF8.nextAsciiDigit ba ofs of sg@(StepDigit d) | isValidStepDigit sg -> loop (10 * acc + integralUpsize d) (succ ofs) | otherwise -> (# acc, False, ofs #) -{-# SPECIALIZE decimalDigitsBA :: Integer -> ByteArray# -> Offset Word8 -> Offset Word8 -> (# Integer, Bool, Offset Word8 #) #-} -{-# SPECIALIZE decimalDigitsBA :: Natural -> ByteArray# -> Offset Word8 -> Offset Word8 -> (# Natural, Bool, Offset Word8 #) #-} -{-# SPECIALIZE decimalDigitsBA :: Int -> ByteArray# -> Offset Word8 -> Offset Word8 -> (# Int, Bool, Offset Word8 #) #-} -{-# SPECIALIZE decimalDigitsBA :: Word -> ByteArray# -> Offset Word8 -> Offset Word8 -> (# Word, Bool, Offset Word8 #) #-} +{-# SPECIALIZE decimalDigitsBA :: Integer -> Block Word8 -> Offset Word8 -> Offset Word8 -> (# Integer, Bool, Offset Word8 #) #-} +{-# SPECIALIZE decimalDigitsBA :: Natural -> Block Word8 -> Offset Word8 -> Offset Word8 -> (# Natural, Bool, Offset Word8 #) #-} +{-# SPECIALIZE decimalDigitsBA :: Int -> Block Word8 -> Offset Word8 -> Offset Word8 -> (# Int, Bool, Offset Word8 #) #-} +{-# SPECIALIZE decimalDigitsBA :: Word -> Block Word8 -> Offset Word8 -> Offset Word8 -> (# Word, Bool, Offset Word8 #) #-} -- | same as decimalDigitsBA specialized for ptr # decimalDigitsPtr :: (IntegralUpsize Word8 acc, Additive acc, Multiplicative acc, Integral acc) => acc - -> Addr# + -> Ptr Word8 -> Offset Word8 -- end offset -> Offset Word8 -- start offset -> (# acc, Bool, Offset Word8 #) @@ -1311,68 +1312,56 @@ loop !acc !ofs | ofs == endOfs = (# acc, True, ofs #) | otherwise = - case PrimAddr.nextAsciiDigit ptr ofs of + case UTF8.nextAsciiDigit ptr ofs of sg@(StepDigit d) | isValidStepDigit sg -> loop (10 * acc + integralUpsize d) (succ ofs) | otherwise -> (# acc, False, ofs #) -{-# SPECIALIZE decimalDigitsPtr :: Integer -> Addr# -> Offset Word8 -> Offset Word8 -> (# Integer, Bool, Offset Word8 #) #-} -{-# SPECIALIZE decimalDigitsPtr :: Natural -> Addr# -> Offset Word8 -> Offset Word8 -> (# Natural, Bool, Offset Word8 #) #-} -{-# SPECIALIZE decimalDigitsPtr :: Int -> Addr# -> Offset Word8 -> Offset Word8 -> (# Int, Bool, Offset Word8 #) #-} -{-# SPECIALIZE decimalDigitsPtr :: Word -> Addr# -> Offset Word8 -> Offset Word8 -> (# Word, Bool, Offset Word8 #) #-} - --- | A unicode string size may vary during a case conversion operation. --- This function calculates the new buffer size for a case conversion. --- Returns Nothing if no case conversion is needed. -caseConvertNBuff :: (Char -> CM) -> String -> Maybe (CountOf Word8) -caseConvertNBuff op s@(String ba) = runST $ Vec.unsafeIndexer ba go - where - !sz = size s - !end = azero `offsetPlusE` sz - go :: (Offset Word8 -> Word8) -> ST st (Maybe (CountOf Word8)) - go getIdx = loop (Offset 0) 0 False - where - !nextI = nextWithIndexer getIdx - eSize !e = if e == '\0' - then 0 - else charToBytes (fromEnum e) - loop !idx ns changed - | idx == end = if changed - then return $ Just ns - else return Nothing - | otherwise = do - let !(c, idx') = nextI idx - !cm@(CM c1 c2 c3) = op c - !cSize = if c2 == '\0' -- if c2 is empty, c3 will be empty as well. - then charToBytes (fromEnum c1) - else eSize c1 + eSize c2 + eSize c3 - !nchanged = changed || c1 /= c || c2 /= '\0' - loop idx' (ns + cSize) nchanged +{-# SPECIALIZE decimalDigitsPtr :: Integer -> Ptr Word8 -> Offset Word8 -> Offset Word8 -> (# Integer, Bool, Offset Word8 #) #-} +{-# SPECIALIZE decimalDigitsPtr :: Natural -> Ptr Word8 -> Offset Word8 -> Offset Word8 -> (# Natural, Bool, Offset Word8 #) #-} +{-# SPECIALIZE decimalDigitsPtr :: Int -> Ptr Word8 -> Offset Word8 -> Offset Word8 -> (# Int, Bool, Offset Word8 #) #-} +{-# SPECIALIZE decimalDigitsPtr :: Word -> Ptr Word8 -> Offset Word8 -> Offset Word8 -> (# Word, Bool, Offset Word8 #) #-} --- | Convert a 'String' 'Char' by 'Char' using a case mapping function. +-- | Convert a 'String' 'Char' by 'Char' using a case mapping function. caseConvert :: (Char -> CM) -> String -> String -caseConvert op s@(String ba) - = case nBuff of - Nothing -> s - Just nLen -> runST $ unsafeCopyFrom s nLen go +caseConvert op s@(String arr) = runST $ do + mba <- MBLK.new iLen + nL <- C.onBackendPrim + (\blk -> go mba blk (Offset 0) start) + (\fptr -> withFinalPtr fptr $ \ptr -> go mba ptr (Offset 0) start) + arr + freeze . MutableString $ MVec.MUArray 0 nL (C.MUArrayMBA mba) where - !nBuff = caseConvertNBuff op s - go :: String -> Offset Char -> Offset8 -> MutableString s -> Offset8 -> ST s (Offset8, Offset8) - go src' srcI srcIdx dst dstIdx = do - let !(CM c1 c2 c3) = op c - dstIdx <- write dst dstIdx c1 - nextDstIdx <- - if c2 == '\0' -- We don't want to check C3 if C2 is empty. - then return dstIdx - else do - dstIdx <- writeValidChar c2 dstIdx - writeValidChar c3 dstIdx - return (nextSrcIdx, nextDstIdx) - where - !(Step c nextSrcIdx) = next src' srcIdx - writeValidChar cc wIdx = - if cc == '\0' - then return wIdx + !(C.ValidRange start end) = C.offsetsValidRange arr + !iLen = 1 + C.length arr + go :: (Indexable container Word8, PrimMonad prim) + => MutableBlock Word8 (PrimState prim) + -> container + -> Offset Word8 + -> Offset Word8 + -> prim (CountOf Word8) + go !dst !src = loop dst iLen 0 + where + eSize !e = if e == '\0' then 0 else charToBytes (fromEnum e) + loop !dst !allocLen !nLen !dstIdx !srcIdx + | srcIdx == end = return nLen + | nLen == allocLen = realloc + | otherwise = do + let !(CM c1 c2 c3) = op c + !(Step c nextSrcIdx) = UTF8.next src srcIdx + nextDstIdx <- UTF8.writeUTF8 dst dstIdx c1 + if c2 == '\0' -- We keep the most common case loop as short as possible. + then loop dst allocLen (nLen + charToBytes (fromEnum c1)) nextDstIdx nextSrcIdx else do - write dst wIdx cc + let !cSize = eSize c1 + eSize c2 + eSize c3 + nextDstIdx <- UTF8.writeUTF8 dst nextDstIdx c2 + nextDstIdx <- if c3 == '\0' then return nextDstIdx else UTF8.writeUTF8 dst nextDstIdx c3 + loop dst allocLen (nLen + cSize) nextDstIdx nextSrcIdx + where + {-# NOINLINE realloc #-} + realloc = do + let nAll = allocLen + allocLen + 1 + nDst <- MBLK.new nAll + MBLK.unsafeCopyElements nDst 0 dst 0 nLen + loop nDst nAll nLen dstIdx srcIdx -- | Convert a 'String' to the upper-case equivalent. upper :: String -> String @@ -1382,6 +1371,12 @@ lower :: String -> String lower = caseConvert lowerMapping +-- | Convert a 'String' to the unicode case fold equivalent. +-- +-- Case folding is mostly used for caseless comparison of strings. +caseFold :: String -> String +caseFold = caseConvert foldMapping + -- | Check whether the first string is a prefix of the second string. isPrefixOf :: String -> String -> Bool isPrefixOf (String needle) (String haystack) = C.isPrefixOf needle haystack @@ -1429,15 +1424,15 @@ all predicate (String arr) = C.onBackend goBA (\_ -> pure . goAddr) arr where !(C.ValidRange start end) = C.offsetsValidRange arr - goBA (Block ba) = PrimBA.all predicate ba start end - goAddr (Ptr addr) = PrimAddr.all predicate addr start end + goBA ba = UTF8.all predicate ba start end + goAddr addr = UTF8.all predicate addr start end any :: (Char -> Bool) -> String -> Bool any predicate (String arr) = C.onBackend goBA (\_ -> pure . goAddr) arr where !(C.ValidRange start end) = C.offsetsValidRange arr - goBA (Block ba) = PrimBA.any predicate ba start end - goAddr (Ptr addr) = PrimAddr.any predicate addr start end + goBA ba = UTF8.any predicate ba start end + goAddr addr = UTF8.any predicate addr start end -- | Transform string @src@ to base64 binary representation. toBase64 :: String -> String diff --git a/Basement/String/Builder.hs b/Basement/String/Builder.hs --- a/Basement/String/Builder.hs +++ b/Basement/String/Builder.hs @@ -15,6 +15,9 @@ -- * Emit functions , emit , emitChar + + -- * unsafe + , unsafeStringBuilder ) where @@ -29,6 +32,10 @@ newtype Builder = Builder Block.Builder deriving (Semigroup, Monoid) + +unsafeStringBuilder :: Block.Builder -> Builder +unsafeStringBuilder = Builder +{-# INLINE unsafeStringBuilder #-} run :: PrimMonad prim => Builder -> prim (String, Maybe ValidationFailure, UArray Word8) run (Builder builder) = do diff --git a/Basement/Terminal/Size.hsc b/Basement/Terminal/Size.hsc --- a/Basement/Terminal/Size.hsc +++ b/Basement/Terminal/Size.hsc @@ -20,6 +20,9 @@ #include #elif defined FOUNDATION_SYSTEM_UNIX #include +#ifdef __sun +#include +#endif #endif #include diff --git a/Basement/Types/OffsetSize.hs b/Basement/Types/OffsetSize.hs --- a/Basement/Types/OffsetSize.hs +++ b/Basement/Types/OffsetSize.hs @@ -17,6 +17,7 @@ ( FileSize(..) , Offset(..) , Offset8 + , sentinel , offsetOfE , offsetPlusE , offsetMinusE @@ -85,6 +86,8 @@ -- Trying to bring some sanity by a lightweight wrapping. newtype Offset ty = Offset Int deriving (Show,Eq,Ord,Enum,Additive,Typeable,Integral,Prelude.Num) + +sentinel = Offset (-1) instance IsIntegral (Offset ty) where toInteger (Offset i) = toInteger i diff --git a/Basement/Types/Word128.hs b/Basement/Types/Word128.hs --- a/Basement/Types/Word128.hs +++ b/Basement/Types/Word128.hs @@ -12,6 +12,12 @@ , bitwiseAnd , bitwiseOr , bitwiseXor + , complement + , shiftL + , shiftR + , rotateL + , rotateR + , popCount , fromNatural ) where diff --git a/Basement/Types/Word256.hs b/Basement/Types/Word256.hs --- a/Basement/Types/Word256.hs +++ b/Basement/Types/Word256.hs @@ -12,6 +12,12 @@ , bitwiseAnd , bitwiseOr , bitwiseXor + , complement + , shiftL + , shiftR + , rotateL + , rotateR + , popCount , fromNatural ) where @@ -91,7 +97,7 @@ poke (castPtr p `plusPtr` 8 ) a2 poke (castPtr p `plusPtr` 16) a1 poke (castPtr p `plusPtr` 24) a0 - + instance Integral Word256 where fromInteger = literal instance HasNegation Word256 where diff --git a/Basement/UArray.hs b/Basement/UArray.hs --- a/Basement/UArray.hs +++ b/Basement/UArray.hs @@ -106,7 +106,6 @@ , toBase64Internal ) where -import Control.Monad (when) import GHC.Prim import GHC.Types import GHC.Word @@ -136,8 +135,6 @@ import Basement.Bindings.Memory (sysHsMemFindByteBa, sysHsMemFindByteAddr) import qualified Basement.Compat.ExtList as List import qualified Basement.Base16 as Base16 -import qualified Basement.Alg.Native.Prim as PrimBA -import qualified Basement.Alg.Foreign.Prim as PrimAddr import qualified Basement.Alg.Mutable as Alg import qualified Basement.Alg.Class as Alg import qualified Basement.Alg.PrimArray as Alg @@ -394,14 +391,13 @@ breakElem :: PrimType ty => ty -> UArray ty -> (UArray ty, UArray ty) breakElem !ty arr@(UArray start len backend) --- TODO: return Maybe k - | k == end = (arr, empty) - | k == start = (empty, arr) - | otherwise = ( UArray start (offsetAsSize k `sizeSub` offsetAsSize start) backend - , UArray k (len `sizeSub` (offsetAsSize k `sizeSub` offsetAsSize start)) backend) + | k == sentinel = (arr, empty) + | k == start = (empty, arr) + | otherwise = (UArray start (offsetAsSize l1) backend + , UArray k (sizeAsOffset len - l1) backend) where - !end = start `offsetPlusE` len !k = onBackendPure' arr $ Alg.findIndexElem ty + l1 = k `offsetSub` start {-# NOINLINE [3] breakElem #-} {-# RULES "breakElem Word8" [4] breakElem = breakElemByte #-} {-# SPECIALIZE [3] breakElem :: Word32 -> UArray Word32 -> (UArray Word32, UArray Word32) #-} @@ -440,11 +436,11 @@ carriageReturn = 0xd goBa (Block ba) = let k = sysHsMemFindByteBa ba start end lineFeed - cr = k > start && PrimBA.primIndex ba (k `offsetSub` 1) == carriageReturn + cr = k > start && primBaIndex ba (k `offsetSub` 1) == carriageReturn in (if cr then k `offsetSub` 1 else k, k) goAddr (Ptr addr) = let k = sysHsMemFindByteAddr addr start end lineFeed - cr = k > start && PrimAddr.primIndex addr (k `offsetSub` 1) == carriageReturn + cr = k > start && primAddrIndex addr (k `offsetSub` 1) == carriageReturn in (if cr then k `offsetSub` 1 else k, k) -- inverse a CountOf that is specified from the end (e.g. take n elements from the end) @@ -496,35 +492,26 @@ findIndex :: PrimType ty => ty -> UArray ty -> Maybe (Offset ty) findIndex ty arr --- TODO: check for end could be done in algorithm - | k == end = Nothing - | otherwise = Just (k `offsetSub` start) + | k == sentinel = Nothing + | otherwise = Just (k `offsetSub` offset arr) where !k = onBackendPure' arr $ Alg.findIndexElem ty - !start = offset arr - !end = start `offsetPlusE` length arr {-# SPECIALIZE [3] findIndex :: Word8 -> UArray Word8 -> Maybe (Offset Word8) #-} revFindIndex :: PrimType ty => ty -> UArray ty -> Maybe (Offset ty) revFindIndex ty arr --- TODO: check for end could be done in algorithm - | k == end = Nothing - | otherwise = Just (k `offsetSub` start) + | k == sentinel = Nothing + | otherwise = Just (k `offsetSub` offset arr) where !k = onBackendPure' arr $ Alg.revFindIndexElem ty - !start = offset arr - !end = start `offsetPlusE` length arr {-# SPECIALIZE [3] revFindIndex :: Word8 -> UArray Word8 -> Maybe (Offset Word8) #-} break :: forall ty . PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty) break predicate arr --- TODO2: check for end could be done in algorithm? but maybe more ops are involved - | k == end = (arr, mempty) - | otherwise = splitAt (offsetAsSize (k `offsetSub` start)) arr + | k == sentinel = (arr, mempty) + | otherwise = splitAt (k - offset arr) arr where !k = onBackendPure' arr $ Alg.findIndexPredicate predicate - !start = offset arr - !end = start `offsetPlusE` length arr {- {-# SPECIALIZE [3] findIndex :: Word8 -> UArray Word8 -> Maybe (Offset Word8) #-} @@ -557,22 +544,14 @@ -- ([1,2,3], [0,0,0]) breakEnd :: forall ty . PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty) breakEnd predicate arr --- TODO2: check for end could be done in algorithm? but maybe more ops are involved - | k == end = (arr, mempty) - | otherwise = splitAt (offsetAsSize (k+1) `sizeSub` offsetAsSize start) arr + | k == sentinel = (arr, mempty) + | otherwise = splitAt ((k+1) - offset arr) arr where !k = onBackendPure' arr $ Alg.revFindIndexPredicate predicate - !start = offset arr - !end = start `offsetPlusE` length arr {-# SPECIALIZE [3] breakEnd :: (Word8 -> Bool) -> UArray Word8 -> (UArray Word8, UArray Word8) #-} elem :: PrimType ty => ty -> UArray ty -> Bool ---elem !ty arr = onBackendPure goBa goAddr arr /= end --- check for end could be done in algorithm? isNothing? -elem !ty arr = onBackendPure' arr (Alg.findIndexElem ty) /= end - where - !start = offset arr - !end = start `offsetPlusE` length arr +elem !ty arr = onBackendPure' arr (Alg.findIndexElem ty) /= sentinel {-# SPECIALIZE [2] elem :: Word8 -> UArray Word8 -> Bool #-} intersperse :: forall ty . PrimType ty => ty -> UArray ty -> UArray ty diff --git a/Basement/UArray/Base.hs b/Basement/UArray/Base.hs --- a/Basement/UArray/Base.hs +++ b/Basement/UArray/Base.hs @@ -90,6 +90,9 @@ instance PrimType ty => Alg.Indexable (Ptr ty) ty where index (Ptr addr) = primAddrIndex addr +instance Alg.Indexable (Ptr Word8) Word64 where + index (Ptr addr) = primAddrIndex addr + instance (PrimMonad prim, PrimType ty) => Alg.RandomAccess (Ptr ty) prim ty where read (Ptr addr) = primAddrRead addr write (Ptr addr) = primAddrWrite addr @@ -292,16 +295,15 @@ onBackendPure goBA goAddr arr = onBackend goBA (\_ -> pureST . goAddr) arr {-# INLINE onBackendPure #-} -onBackendPure' :: PrimType ty +onBackendPure' :: forall ty a . PrimType ty => UArray ty -> (forall container. Alg.Indexable container ty => container -> Offset ty -> Offset ty -> a) -> a -onBackendPure' arr f = onBackendPure (\c -> f c start end) - (\c -> f c start end) arr - where !len = length arr - !start = offset arr - !end = start `offsetPlusE` len +onBackendPure' arr f = onBackendPure f' f' arr + where f' :: Alg.Indexable container ty => container -> a + f' c = f c start end + where (ValidRange !start !end) = offsetsValidRange arr {-# INLINE onBackendPure' #-} onBackendPrim :: PrimMonad prim @@ -323,12 +325,12 @@ {-# INLINE onMutableBackend #-} -unsafeDewrap :: (ByteArray# -> Offset ty -> a) +unsafeDewrap :: (Block ty -> Offset ty -> a) -> (Ptr ty -> Offset ty -> ST s a) -> UArray ty -> a unsafeDewrap _ g (UArray start _ (UArrayAddr fptr)) = withUnsafeFinalPtr fptr $ \ptr -> g ptr start -unsafeDewrap f _ (UArray start _ (UArrayBA (Block ba))) = f ba start +unsafeDewrap f _ (UArray start _ (UArrayBA ba)) = f ba start {-# INLINE unsafeDewrap #-} unsafeDewrap2 :: (ByteArray# -> ByteArray# -> a) @@ -392,7 +394,7 @@ | otherwise = unsafeDewrap goBa goPtr a where !len = length a - goBa ba start = loop start + goBa (Block ba) start = loop start where !end = start `offsetPlusE` len loop !i | i == end = [] diff --git a/Basement/UTF8/Base.hs b/Basement/UTF8/Base.hs --- a/Basement/UTF8/Base.hs +++ b/Basement/UTF8/Base.hs @@ -30,8 +30,7 @@ import Basement.FinalPtr import Basement.UTF8.Helper import Basement.UTF8.Types -import qualified Basement.Alg.Native.UTF8 as PrimBA -import qualified Basement.Alg.Foreign.UTF8 as PrimAddr +import qualified Basement.Alg.UTF8 as UTF8 import Basement.UArray (UArray) import Basement.Block (MutableBlock) import qualified Basement.Block.Mutable as BLK @@ -90,31 +89,31 @@ sToList (String arr) = Vec.onBackend onBA onAddr arr where (Vec.ValidRange !start !end) = Vec.offsetsValidRange arr - onBA (BLK.Block ba) = loop start + onBA ba@(BLK.Block _) = loop start where loop !idx | idx == end = [] - | otherwise = let !(Step c idx') = PrimBA.next ba idx in c : loop idx' - onAddr fptr (Ptr ptr) = pureST (loop start) + | otherwise = let !(Step c idx') = UTF8.next ba idx in c : loop idx' + onAddr fptr ptr@(Ptr _) = pureST (loop start) where loop !idx | idx == end = [] - | otherwise = let !(Step c idx') = PrimAddr.next ptr idx in c : loop idx' + | otherwise = let !(Step c idx') = UTF8.next ptr idx in c : loop idx' {-# NOINLINE sToList #-} sToListStream (String arr) k z = Vec.onBackend onBA onAddr arr where (Vec.ValidRange !start !end) = Vec.offsetsValidRange arr - onBA (BLK.Block ba) = loop start + onBA ba@(BLK.Block _) = loop start where loop !idx | idx == end = z - | otherwise = let !(Step c idx') = PrimBA.next ba idx in c `k` loop idx' - onAddr fptr (Ptr ptr) = pureST (loop start) + | otherwise = let !(Step c idx') = UTF8.next ba idx in c `k` loop idx' + onAddr fptr ptr@(Ptr _) = pureST (loop start) where loop !idx | idx == end = z - | otherwise = let !(Step c idx') = PrimAddr.next ptr idx in c `k` loop idx' + | otherwise = let !(Step c idx') = UTF8.next ptr idx in c `k` loop idx' {-# RULES "String sToList" [~1] forall s . sToList s = build (\ k z -> sToListStream s k z) #-} {-# RULES "String toList" [~1] forall s . toList s = build (\ k z -> sToListStream s k z) #-} @@ -178,16 +177,16 @@ where !start = Vec.offset array reoffset (Step a ofs) = Step a (ofs `offsetSub` start) - nextBA (BLK.Block ba) = reoffset (PrimBA.next ba (start + n)) - nextAddr _ (Ptr ptr) = pureST $ reoffset (PrimAddr.next ptr (start + n)) + nextBA ba@(BLK.Block _) = reoffset (UTF8.next ba (start + n)) + nextAddr _ ptr@(Ptr _) = pureST $ reoffset (UTF8.next ptr (start + n)) prev :: String -> Offset8 -> StepBack prev (String array) !n = Vec.onBackend prevBA prevAddr array where !start = Vec.offset array reoffset (StepBack a ofs) = StepBack a (ofs `offsetSub` start) - prevBA (BLK.Block ba) = reoffset (PrimBA.prev ba (start + n)) - prevAddr _ (Ptr ptr) = pureST $ reoffset (PrimAddr.prev ptr (start + n)) + prevBA ba@(BLK.Block _) = reoffset (UTF8.prev ba (start + n)) + prevAddr _ ptr@(Ptr _) = pureST $ reoffset (UTF8.prev ptr (start + n)) -- A variant of 'next' when you want the next character -- to be ASCII only. @@ -202,8 +201,8 @@ write :: PrimMonad prim => MutableString (PrimState prim) -> Offset8 -> Char -> prim Offset8 write (MutableString marray) ofs c = - MVec.onMutableBackend (\(BLK.MutableBlock mba) -> PrimBA.write mba (start + ofs) c) - (\fptr -> withFinalPtr fptr $ \(Ptr ptr) -> PrimAddr.write ptr (start + ofs) c) + MVec.onMutableBackend (\mba@(BLK.MutableBlock _) -> UTF8.writeUTF8 mba (start + ofs) c) + (\fptr -> withFinalPtr fptr $ \ptr@(Ptr _) -> UTF8.writeUTF8 ptr (start + ofs) c) marray where start = MVec.mutableOffset marray diff --git a/basement.cabal b/basement.cabal --- a/basement.cabal +++ b/basement.cabal @@ -1,5 +1,5 @@ name: basement -version: 0.0.6 +version: 0.0.7 synopsis: Foundation scrap box of array & string description: Foundation most basic primitives without any dependencies homepage: https://github.com/haskell-foundation/foundation#readme @@ -23,7 +23,7 @@ library hs-source-dirs: . - exposed-modules: + exposed-modules: Basement.Imports Basement.Base16 @@ -58,7 +58,7 @@ Basement.String Basement.String.Builder Basement.NonEmpty - + -- Utils Basement.NormalForm Basement.These @@ -100,6 +100,7 @@ , Basement.Sized.Block , Basement.Sized.UVect , Basement.Sized.Vect + , Basement.Bits if impl(ghc >= 7.10) exposed-modules: Basement.Sized.List @@ -113,13 +114,8 @@ Basement.Alg.Mutable Basement.Alg.PrimArray - Basement.Alg.Native.Prim - Basement.Alg.Native.UTF8 - Basement.Alg.Native.String - - Basement.Alg.Foreign.Prim - Basement.Alg.Foreign.UTF8 - Basement.Alg.Foreign.String + Basement.Alg.UTF8 + Basement.Alg.String Basement.Numerical.Conversion