packages feed

basement (empty) → 0.0.0

raw patch · 72 files changed

+10772/−0 lines, 72 filesdep +basedep +ghc-primsetup-changed

Dependencies added: base, ghc-prim

Files

+ Basement/Base16.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE MagicHash     #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE BangPatterns  #-}+module Basement.Base16+    ( unsafeConvertByte+    , hexWord16+    , hexWord32+    ) where++import GHC.Prim+import GHC.Types+import GHC.Word++-- | Convert a byte value in Word# to two Word#s containing+-- the hexadecimal representation of the Word#+--+-- The output words# are guaranteed to be included in the 0 to 2^7-1 range+--+-- Note that calling convertByte with a value greater than 256+-- will cause segfault or other horrible effect.+unsafeConvertByte :: Word# -> (# Word#, Word# #)+unsafeConvertByte b = (# r tableHi b, r tableLo b #)+  where+    r :: Table -> Word# -> Word#+    r (Table !table) index = indexWord8OffAddr# table (word2Int# index)+{-# INLINE unsafeConvertByte #-}++-- | hex word16+hexWord16 :: Word16 -> (Char, Char, Char, Char)+hexWord16 (W16# w) = (toChar w1,toChar w2,toChar w3,toChar w4)+  where+    toChar :: Word# -> Char+    toChar c = C# (chr# (word2Int# c))+    !(# w1, w2 #) = unsafeConvertByte (uncheckedShiftRL# w 8#)+    !(# w3, w4 #) = unsafeConvertByte (and# w 0xff##)++-- | hex word32+hexWord32 :: Word32 -> (Char, Char, Char, Char, Char, Char, Char, Char)+hexWord32 (W32# w) = (toChar w1,toChar w2,toChar w3,toChar w4+                     ,toChar w5,toChar w6,toChar w7,toChar w8)+  where+    toChar :: Word# -> Char+    toChar c = C# (chr# (word2Int# c))+    !(# w1, w2 #) = unsafeConvertByte (uncheckedShiftRL# w 24#)+    !(# w3, w4 #) = unsafeConvertByte (and# (uncheckedShiftRL# w 16#) 0xff##)+    !(# w5, w6 #) = unsafeConvertByte (and# (uncheckedShiftRL# w 8#) 0xff##)+    !(# w7, w8 #) = unsafeConvertByte (and# w 0xff##)++data Table = Table Addr#++tableLo:: Table+tableLo = Table+    "0123456789abcdef0123456789abcdef\+    \0123456789abcdef0123456789abcdef\+    \0123456789abcdef0123456789abcdef\+    \0123456789abcdef0123456789abcdef\+    \0123456789abcdef0123456789abcdef\+    \0123456789abcdef0123456789abcdef\+    \0123456789abcdef0123456789abcdef\+    \0123456789abcdef0123456789abcdef"#++tableHi :: Table+tableHi = Table+    "00000000000000001111111111111111\+    \22222222222222223333333333333333\+    \44444444444444445555555555555555\+    \66666666666666667777777777777777\+    \88888888888888889999999999999999\+    \aaaaaaaaaaaaaaaabbbbbbbbbbbbbbbb\+    \ccccccccccccccccdddddddddddddddd\+    \eeeeeeeeeeeeeeeeffffffffffffffff"#+
+ Basement/Bindings/Memory.hs view
@@ -0,0 +1,30 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnliftedFFITypes #-}+module Basement.Bindings.Memory+    where++import GHC.IO+import GHC.Prim+import GHC.Word+import Foreign.C.Types+import Foreign.Ptr+import Basement.Types.OffsetSize++foreign import ccall unsafe "_foundation_memcmp" sysHsMemcmpBaBa ::+    ByteArray# -> Offset Word8 -> ByteArray# -> Offset Word8 -> CountOf Word8 -> IO CInt++foreign import ccall unsafe "_foundation_memcmp" sysHsMemcmpBaPtr ::+    ByteArray# -> Offset Word8 -> Ptr a -> Offset Word8 -> CountOf Word8 -> IO CInt++foreign import ccall unsafe "_foundation_memcmp" sysHsMemcmpPtrBa ::+    Ptr a -> Offset Word8 -> ByteArray# -> Offset Word8 -> CountOf Word8 -> IO CInt++foreign import ccall unsafe "_foundation_memcmp" sysHsMemcmpPtrPtr ::+    Ptr a -> Offset Word8 -> Ptr b -> Offset Word8 -> CountOf Word8 -> IO CInt++foreign import ccall unsafe "_foundation_mem_findbyte" sysHsMemFindByteBa ::+    ByteArray# -> Offset Word8 -> Offset Word8 -> Word8 -> Offset Word8++foreign import ccall unsafe "_foundation_mem_findbyte" sysHsMemFindByteAddr ::+    Addr# -> Offset Word8 -> Offset Word8 -> Word8 -> Offset Word8
+ Basement/Block.hs view
@@ -0,0 +1,397 @@+-- |+-- Module      : Basement.Block+-- License     : BSD-style+-- Maintainer  : Haskell Foundation+--+-- A block of memory that contains elements of a type,+-- very similar to an unboxed array but with the key difference:+--+-- * It doesn't have slicing capability (no cheap take or drop)+-- * It consume less memory: 1 Offset, 1 CountOf+-- * It's unpackable in any constructor+-- * It uses unpinned memory by default+--+{-# LANGUAGE MagicHash           #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedTuples       #-}+module Basement.Block+    ( Block(..)+    , MutableBlock(..)+    -- * Properties+    , length+    -- * Lowlevel functions+    , unsafeThaw+    , unsafeFreeze+    , unsafeIndex+    , thaw+    , freeze+    , copy+    -- * safer api+    , create+    , isPinned+    , isMutablePinned+    , singleton+    , replicate+    , index+    , map+    , foldl'+    , foldr+    , foldl1'+    , foldr1+    , cons+    , snoc+    , uncons+    , unsnoc+    , sub+    , splitAt+    , revSplitAt+    , splitOn+    , break+    , span+    , elem+    , all+    , any+    , find+    , filter+    , reverse+    , sortBy+    , intersperse+    -- * Foreign interfaces+    , unsafeCopyToPtr+    ) where++import           GHC.Prim+import           GHC.Types+import           GHC.ST+import qualified Data.List+import           Basement.Compat.Base+import           Data.Proxy+import           Basement.Compat.Primitive+import           Basement.NonEmpty+import           Basement.Types.OffsetSize+import           Basement.Monad+import           Basement.Exception+import           Basement.PrimType+import qualified Basement.Block.Mutable as M+import           Basement.Block.Mutable (Block(..), MutableBlock(..), new, unsafeThaw, unsafeFreeze)+import           Basement.Block.Base+import           Basement.Numerical.Additive+import           Basement.Numerical.Subtractive++-- | 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+                -> Ptr ty   -- ^ The destination address where the copy is going to start+                -> prim ()+unsafeCopyToPtr (Block blk) (Ptr p) = primitive $ \s1 ->+    (# compatCopyByteArrayToAddr# blk 0# p (sizeofByteArray# blk) s1, () #)++-- | Create a new array of size @n by settings each cells through the+-- function @f.+create :: forall ty . PrimType ty+       => CountOf ty           -- ^ the size of the block (in element of ty)+       -> (Offset ty -> ty) -- ^ the function that set the value at the index+       -> Block ty          -- ^ the array created+create n initializer+    | n == 0    = mempty+    | otherwise = runST $ do+        mb <- new n+        M.iterSet initializer mb+        unsafeFreeze mb++isPinned :: Block ty -> PinnedStatus+isPinned (Block ba) = toPinnedStatus# (compatIsByteArrayPinned# ba)++isMutablePinned :: MutableBlock s ty -> PinnedStatus+isMutablePinned (MutableBlock mba) = toPinnedStatus# (compatIsMutableByteArrayPinned# mba)++singleton :: PrimType ty => ty -> Block ty+singleton ty = create 1 (const ty)++replicate :: PrimType ty => CountOf ty -> ty -> Block ty+replicate sz ty = create sz (const ty)++-- | Thaw a Block into a MutableBlock+--+-- the Block is not modified, instead a new Mutable Block is created+-- and its content is copied to the mutable block+thaw :: (PrimMonad prim, PrimType ty) => Block ty -> prim (MutableBlock ty (PrimState prim))+thaw array = do+    ma <- M.unsafeNew Unpinned (lengthBytes array)+    M.unsafeCopyBytesRO ma 0 array 0 (lengthBytes array)+    pure ma+{-# INLINE thaw #-}++freeze :: (PrimType ty, PrimMonad prim) => MutableBlock ty (PrimState prim) -> prim (Block ty)+freeze ma = do+    ma' <- unsafeNew Unpinned len+    M.unsafeCopyBytes ma' 0 ma 0 len+    --M.copyAt ma' (Offset 0) ma (Offset 0) len+    unsafeFreeze ma'+  where+    len = M.mutableLengthBytes ma++-- | Copy every cells of an existing Block to a new Block+copy :: PrimType ty => Block ty -> Block ty+copy array = runST (thaw array >>= unsafeFreeze)++-- | Return the element at a specific index from an array.+--+-- If the index @n is out of bounds, an error is raised.+index :: PrimType ty => Block ty -> Offset ty -> ty+index array n+    | isOutOfBound n len = outOfBound OOB_Index n len+    | otherwise          = unsafeIndex array n+  where+    !len = length array+{-# INLINE index #-}++-- | Map all element 'a' from a block to a new block of 'b'+map :: (PrimType a, PrimType b) => (a -> b) -> Block a -> Block b+map f a = create lenB (\i -> f $ unsafeIndex a (offsetCast Proxy i))+  where !lenB = sizeCast (Proxy :: Proxy (a -> b)) (length a)++foldr :: PrimType ty => (ty -> a -> a) -> a -> Block ty -> a+foldr f initialAcc vec = loop 0+  where+    !len = length vec+    loop !i+        | i .==# len = initialAcc+        | otherwise  = unsafeIndex vec i `f` loop (i+1)+{-# SPECIALIZE [2] foldr :: (Word8 -> a -> a) -> a -> Block Word8 -> a #-}++foldl' :: PrimType ty => (a -> ty -> a) -> a -> Block ty -> a+foldl' f initialAcc vec = loop 0 initialAcc+  where+    !len = length vec+    loop !i !acc+        | i .==# len = acc+        | otherwise  = loop (i+1) (f acc (unsafeIndex vec i))+{-# SPECIALIZE [2] foldl' :: (a -> Word8 -> a) -> a -> Block Word8 -> a #-}++foldl1' :: PrimType ty => (ty -> ty -> ty) -> NonEmpty (Block ty) -> ty+foldl1' f (NonEmpty arr) = loop 1 (unsafeIndex arr 0)+  where+    !len = length arr+    loop !i !acc+        | i .==# len = acc+        | otherwise  = loop (i+1) (f acc (unsafeIndex arr i))+{-# SPECIALIZE [3] foldl1' :: (Word8 -> Word8 -> Word8) -> NonEmpty (Block Word8) -> Word8 #-}++foldr1 :: PrimType ty => (ty -> ty -> ty) -> NonEmpty (Block ty) -> ty+foldr1 f arr = let (initialAcc, rest) = revSplitAt 1 $ getNonEmpty arr+               in foldr f (unsafeIndex initialAcc 0) rest++cons :: PrimType ty => ty -> Block ty -> Block ty+cons e vec+    | len == 0  = singleton e+    | otherwise = runST $ do+        muv <- new (len + 1)+        M.unsafeCopyElementsRO muv 1 vec 0 len+        M.unsafeWrite muv 0 e+        unsafeFreeze muv+  where+    !len = length vec++snoc :: PrimType ty => Block ty -> ty -> Block ty+snoc vec e+    | len == 0  = singleton e+    | otherwise = runST $ do+        muv <- new (len + 1)+        M.unsafeCopyElementsRO muv 0 vec 0 len+        M.unsafeWrite muv (0 `offsetPlusE` len) e+        unsafeFreeze muv+  where+     !len = length vec++sub :: PrimType ty => Block ty -> Offset ty -> Offset ty -> Block ty+sub blk start end+    | start >= end' = mempty+    | otherwise     = runST $ do+        dst <- new newLen+        M.unsafeCopyElementsRO dst 0 blk start newLen+        unsafeFreeze dst+  where+    newLen = end' - start+    end' = min (sizeAsOffset len) end+    !len = length blk++uncons :: PrimType ty => Block ty -> Maybe (ty, Block ty)+uncons vec+    | nbElems == 0 = Nothing+    | otherwise    = Just (unsafeIndex vec 0, sub vec 1 (0 `offsetPlusE` nbElems))+  where+    !nbElems = length vec++unsnoc :: PrimType ty => Block ty -> Maybe (Block ty, ty)+unsnoc vec = case length vec - 1 of+    Nothing -> Nothing+    Just offset -> Just (sub vec 0 lastElem, unsafeIndex vec lastElem)+                     where !lastElem = 0 `offsetPlusE` offset++splitAt :: PrimType ty => CountOf ty -> Block ty -> (Block ty, Block ty)+splitAt nbElems blk+    | nbElems <= 0 = (mempty, blk)+    | Just nbTails <- length blk - nbElems, nbTails > 0 = runST $ do+        left  <- new nbElems+        right <- new nbTails+        M.unsafeCopyElementsRO left  0 blk 0                      nbElems+        M.unsafeCopyElementsRO right 0 blk (sizeAsOffset nbElems) nbTails+        (,) <$> unsafeFreeze left <*> unsafeFreeze right+    | otherwise    = (blk, mempty)+{-# SPECIALIZE [2] splitAt :: CountOf Word8 -> Block Word8 -> (Block Word8, Block Word8) #-}++revSplitAt :: PrimType ty => CountOf ty -> Block ty -> (Block ty, Block ty)+revSplitAt n blk +    | n <= 0                         = (mempty, blk)+    | Just nbElems <- length blk - n = let (x, y) = splitAt nbElems blk in (y, x)+    | otherwise                      = (blk, mempty)++break :: PrimType ty => (ty -> Bool) -> Block ty -> (Block ty, Block ty)+break predicate blk = findBreak 0+  where+    !len = length blk+    findBreak !i+        | i .==# len                    = (blk, mempty)+        | predicate (unsafeIndex blk i) = splitAt (offsetAsSize i) blk+        | otherwise                     = findBreak (i + 1)+    {-# INLINE findBreak #-}+{-# SPECIALIZE [2] break :: (Word8 -> Bool) -> Block Word8 -> (Block Word8, Block Word8) #-}++span :: PrimType ty => (ty -> Bool) -> Block ty -> (Block ty, Block ty)+span p = break (not . p)++elem :: PrimType ty => ty -> Block ty -> Bool+elem v blk = loop 0+  where+    !len = length blk+    loop !i+        | i .==# len             = False+        | unsafeIndex blk i == v = True+        | otherwise              = loop (i+1)+{-# SPECIALIZE [2] elem :: Word8 -> Block Word8 -> Bool #-}++all :: PrimType ty => (ty -> Bool) -> Block ty -> Bool+all p blk = loop 0+  where+    !len = length blk+    loop !i+        | i .==# len            = True+        | p (unsafeIndex blk i) = loop (i+1)+        | otherwise             = False+{-# SPECIALIZE [2] all :: (Word8 -> Bool) -> Block Word8 -> Bool #-}++any :: PrimType ty => (ty -> Bool) -> Block ty -> Bool+any p blk = loop 0+  where+    !len = length blk+    loop !i+        | i .==# len            = False+        | p (unsafeIndex blk i) = True+        | otherwise             = loop (i+1)+{-# SPECIALIZE [2] any :: (Word8 -> Bool) -> Block Word8 -> Bool #-}++splitOn :: PrimType ty => (ty -> Bool) -> Block ty -> [Block ty]+splitOn predicate blk+    | len == 0  = [mempty]+    | otherwise = go 0 0+  where+    !len = length blk+    go !prevIdx !idx+        | idx .==# len = [sub blk prevIdx idx]+        | otherwise    =+            let e = unsafeIndex blk idx+                idx' = idx + 1+             in if predicate e+                    then sub blk prevIdx idx : go idx' idx'+                    else go prevIdx idx'++find :: PrimType ty => (ty -> Bool) -> Block ty -> Maybe ty+find predicate vec = loop 0+  where+    !len = length vec+    loop i+        | i .==# len = Nothing+        | otherwise  =+            let e = unsafeIndex vec i+             in if predicate e then Just e else loop (i+1)++filter :: PrimType ty => (ty -> Bool) -> Block ty -> Block ty+filter predicate vec = fromList $ Data.List.filter predicate $ toList vec++reverse :: forall ty . PrimType ty => Block ty -> Block ty+reverse blk+    | len == 0  = mempty+    | otherwise = runST $ do+        mb <- new len+        go mb+        unsafeFreeze mb+  where+    !len = length blk+    !endOfs = 0 `offsetPlusE` len++    go :: MutableBlock ty s -> ST s ()+    go mb = loop endOfs 0+      where+        loop o i+            | i .==# len = pure ()+            | otherwise  = unsafeWrite mb o' (unsafeIndex blk i) >> loop o' (i+1)+          where o' = pred o++sortBy :: forall ty . PrimType ty => (ty -> ty -> Ordering) -> Block ty -> Block ty+sortBy xford vec+    | len == 0  = mempty+    | otherwise = runST (thaw vec >>= doSort xford)+  where+    len = length vec+    doSort :: (PrimType ty, PrimMonad prim) => (ty -> ty -> Ordering) -> MutableBlock ty (PrimState prim) -> prim (Block ty)+    doSort ford ma = qsort 0 (sizeLastOffset len) >> unsafeFreeze ma+      where+        qsort lo hi+            | lo >= hi  = pure ()+            | otherwise = do+                p <- partition lo hi+                qsort lo (pred p)+                qsort (p+1) hi+        partition lo hi = do+            pivot <- unsafeRead ma hi+            let loop i j+                    | j == hi   = pure i+                    | otherwise = do+                        aj <- unsafeRead ma j+                        i' <- if ford aj pivot == GT+                                then pure i+                                else do+                                    ai <- unsafeRead ma i+                                    unsafeWrite ma j ai+                                    unsafeWrite ma i aj+                                    pure $ i + 1+                        loop i' (j+1)++            i <- loop lo lo+            ai  <- unsafeRead ma i+            ahi <- unsafeRead ma hi+            unsafeWrite ma hi ai+            unsafeWrite ma i ahi+            pure i++intersperse :: forall ty . PrimType ty => ty -> Block ty -> Block ty+intersperse sep blk = case len - 1 of+    Nothing -> blk+    Just 0 -> blk+    Just size -> runST $ do+        mb <- new (len+size)+        go mb+        unsafeFreeze mb+  where+    !len = length blk++    go :: MutableBlock ty s -> ST s ()+    go mb = loop 0 0+      where+        loop !o !i+            | (i + 1) .==# len = unsafeWrite mb o (unsafeIndex blk i)+            | otherwise        = do+                unsafeWrite mb o     (unsafeIndex blk i)+                unsafeWrite mb (o+1) sep+                loop (o+2) (i+1)
+ Basement/Block/Base.hs view
@@ -0,0 +1,342 @@+{-# LANGUAGE MagicHash           #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedTuples       #-}+module Basement.Block.Base+    ( Block(..)+    , MutableBlock(..)+    -- * Basic accessor+    , unsafeNew+    , unsafeThaw+    , unsafeFreeze+    , unsafeCopyElements+    , unsafeCopyElementsRO+    , unsafeCopyBytes+    , unsafeCopyBytesRO+    , unsafeRead+    , unsafeWrite+    , unsafeIndex+    -- * Properties+    , length+    , lengthBytes+    -- * Other methods+    , mutableEmpty+    , new+    , newPinned+    , touch+    , mutableTouch+    ) where++import           GHC.Prim+import           GHC.Types+import           GHC.ST+import           GHC.IO+import qualified Data.List+import           Basement.Compat.Base+import           Data.Proxy+import           Basement.Compat.Primitive+import           Basement.Bindings.Memory (sysHsMemcmpBaBa)+import           Basement.Types.OffsetSize+import           Basement.Monad+import           Basement.NormalForm+import           Basement.Numerical.Additive+import           Basement.PrimType++-- | A block of memory containing unpacked bytes representing values of type 'ty'+data Block ty = Block ByteArray#+    deriving (Typeable)++instance Data ty => Data (Block ty) where+    dataTypeOf _ = blockType+    toConstr _   = error "toConstr"+    gunfold _ _  = error "gunfold"++blockType :: DataType+blockType = mkNoRepType "Foundation.Block"++instance NormalForm (Block ty) where+    toNormalForm (Block !_) = ()+instance (PrimType ty, Show ty) => Show (Block ty) where+    show v = show (toList v)+instance (PrimType ty, Eq ty) => Eq (Block ty) where+    {-# SPECIALIZE instance Eq (Block Word8) #-}+    (==) = equal+instance (PrimType ty, Ord ty) => Ord (Block ty) where+    compare = internalCompare++instance PrimType ty => Monoid (Block ty) where+    mempty  = empty+    mappend = append+    mconcat = concat++instance PrimType ty => IsList (Block ty) where+    type Item (Block ty) = ty+    fromList = internalFromList+    toList = internalToList++length :: forall ty . PrimType ty => Block ty -> CountOf ty+length (Block ba) =+    case primShiftToBytes (Proxy :: Proxy ty) of+        0           -> CountOf (I# (sizeofByteArray# ba))+        (I# szBits) -> CountOf (I# (uncheckedIShiftRL# (sizeofByteArray# ba) szBits))+{-# INLINE[1] length #-}+{-# SPECIALIZE [2] length :: Block Word8 -> CountOf Word8 #-}++lengthBytes :: Block ty -> CountOf Word8+lengthBytes (Block ba) = CountOf (I# (sizeofByteArray# ba))+{-# INLINE[1] lengthBytes #-}++-- | Create an empty block of memory+empty :: Block ty+empty = Block ba where !(Block ba) = empty_++empty_ :: Block ()+empty_ = runST $ primitive $ \s1 ->+    case newByteArray# 0# s1           of { (# s2, mba #) ->+    case unsafeFreezeByteArray# mba s2 of { (# s3, ba  #) ->+        (# s3, Block ba #) }}++mutableEmpty :: PrimMonad prim => prim (MutableBlock ty (PrimState prim))+mutableEmpty = primitive $ \s1 ->+    case newByteArray# 0# s1 of { (# s2, mba #) ->+        (# s2, MutableBlock mba #) }++-- | Return the element at a specific index from an array without bounds checking.+--+-- Reading from invalid memory can return unpredictable and invalid values.+-- use 'index' if unsure.+unsafeIndex :: forall ty . PrimType ty => Block ty -> Offset ty -> ty+unsafeIndex (Block ba) n = primBaIndex ba n+{-# SPECIALIZE unsafeIndex :: Block Word8 -> Offset Word8 -> Word8 #-}+{-# INLINE unsafeIndex #-}++-- | make a block from a list of elements.+internalFromList :: PrimType ty => [ty] -> Block ty+internalFromList l = runST $ do+    ma <- new (CountOf len)+    iter azero l $ \i x -> unsafeWrite ma i x+    unsafeFreeze ma+  where len = Data.List.length l+        iter _  []     _ = return ()+        iter !i (x:xs) z = z i x >> iter (i+1) xs z++-- | transform a block to a list.+internalToList :: forall ty . PrimType ty => Block ty -> [ty]+internalToList blk@(Block ba)+    | len == azero = []+    | otherwise    = loop azero+  where+    !len = length blk+    loop !i | i .==# len = []+            | otherwise  = primBaIndex ba i : loop (i+1)++-- | Check if two blocks are identical+equal :: (PrimType ty, Eq ty) => Block ty -> Block ty -> Bool+equal a b+    | la /= lb  = False+    | otherwise = loop azero+  where+    !la = lengthBytes a+    !lb = lengthBytes b+    lat = length a++    loop !n | n .==# lat = True+            | otherwise  = (unsafeIndex a n == unsafeIndex b n) && loop (n+o1)+    o1 = Offset (I# 1#)+{-# RULES "Block/Eq/Word8" [3]+   forall (a :: Block Word8) b . equal a b = equalMemcmp a b #-}+{-# INLINEABLE [2] equal #-}+-- {-# SPECIALIZE equal :: Block Word8 -> Block Word8 -> Bool #-}++equalMemcmp :: PrimMemoryComparable ty => Block ty -> Block ty -> Bool+equalMemcmp b1@(Block a) b2@(Block b)+    | la /= lb  = False+    | otherwise = unsafeDupablePerformIO (sysHsMemcmpBaBa a 0 b 0 la) == 0+  where+    la = lengthBytes b1+    lb = lengthBytes b2+{-# SPECIALIZE equalMemcmp :: Block Word8 -> Block Word8 -> Bool #-}++-- | Compare 2 blocks+internalCompare :: (Ord ty, PrimType ty) => Block ty -> Block ty -> Ordering+internalCompare a b = loop azero+  where+    !la = length a+    !lb = length b+    !end = sizeAsOffset (min la lb)+    loop !n+        | n == end  = la `compare` lb+        | v1 == v2  = loop (n + Offset (I# 1#))+        | otherwise = v1 `compare` v2+      where+        v1 = unsafeIndex a n+        v2 = unsafeIndex b n+{-# RULES "Block/Ord/Word8" [3] forall (a :: Block Word8) b . internalCompare a b = compareMemcmp a b #-}+{-# NOINLINE internalCompare #-}++compareMemcmp :: PrimMemoryComparable ty => Block ty -> Block ty -> Ordering+compareMemcmp b1@(Block a) b2@(Block b) =+    case unsafeDupablePerformIO (sysHsMemcmpBaBa a 0 b 0 sz) of+        0             -> la `compare` lb+        n | n > 0     -> GT+          | otherwise -> LT+  where+    la = lengthBytes b1+    lb = lengthBytes b2+    sz = min la lb+{-# SPECIALIZE [3] compareMemcmp :: Block Word8 -> Block Word8 -> Ordering #-}++-- | Append 2 blocks together by creating a new bigger block+append :: Block ty -> Block ty -> Block ty+append a b+    | la == azero = b+    | lb == azero = a+    | otherwise = runST $ do+        r  <- unsafeNew Unpinned (la+lb)+        unsafeCopyBytesRO r 0                 a 0 la+        unsafeCopyBytesRO r (sizeAsOffset la) b 0 lb+        unsafeFreeze r+  where+    !la = lengthBytes a+    !lb = lengthBytes b++concat :: [Block ty] -> Block ty+concat [] = empty+concat l  =+    case filterAndSum 0 [] l of+        (_,[])            -> empty+        (_,[x])           -> x+        (totalLen,chunks) -> runST $ do+            r <- unsafeNew Unpinned totalLen+            doCopy r 0 chunks+            unsafeFreeze r+  where+    -- TODO would go faster not to reverse but pack from the end instead+    filterAndSum !totalLen acc []     = (totalLen, Data.List.reverse acc)+    filterAndSum !totalLen acc (x:xs)+        | len == 0  = filterAndSum totalLen acc xs+        | otherwise = filterAndSum (len+totalLen) (x:acc) xs+      where len = lengthBytes x++    doCopy _ _ []     = return ()+    doCopy r i (x:xs) = do+        unsafeCopyBytesRO r i x 0 lx+        doCopy r (i `offsetPlusE` lx) xs+      where !lx = lengthBytes x++-- | A Mutable block of memory containing unpacked bytes representing values of type 'ty'+data MutableBlock ty st = MutableBlock (MutableByteArray# st)++-- | Freeze a mutable block into a block.+--+-- If the mutable block is still use after freeze,+-- then the modification will be reflected in an unexpected+-- way in the Block.+unsafeFreeze :: PrimMonad prim => MutableBlock ty (PrimState prim) -> prim (Block ty)+unsafeFreeze (MutableBlock mba) = primitive $ \s1 ->+    case unsafeFreezeByteArray# mba s1 of+        (# s2, ba #) -> (# s2, Block ba #)+{-# INLINE unsafeFreeze #-}++-- | Thaw an immutable block.+--+-- If the immutable block is modified, then the original immutable block will+-- be modified too, but lead to unexpected results when querying+unsafeThaw :: (PrimType ty, PrimMonad prim) => Block ty -> prim (MutableBlock ty (PrimState prim))+unsafeThaw (Block ba) = primitive $ \st -> (# st, MutableBlock (unsafeCoerce# ba) #)++-- | Create a new mutable block of a specific size in bytes.+--+-- Note that no checks are made to see if the size in bytes is compatible with the size+-- of the underlaying element 'ty' in the block.+--+-- use 'new' if unsure+unsafeNew :: PrimMonad prim+          => PinnedStatus+          -> CountOf Word8+          -> prim (MutableBlock ty (PrimState prim))+unsafeNew pinSt (CountOf (I# bytes)) = case pinSt of+    Unpinned -> primitive $ \s1 -> case newByteArray# bytes s1 of { (# s2, mba #) -> (# s2, MutableBlock mba #) }+    _        -> primitive $ \s1 -> case newAlignedPinnedByteArray# bytes 8# s1 of { (# s2, mba #) -> (# s2, MutableBlock mba #) }++-- | Create a new mutable block of a specific N size of 'ty' elements+new :: forall prim ty . (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MutableBlock ty (PrimState prim))+new n = unsafeNew Unpinned (sizeOfE (primSizeInBytes (Proxy :: Proxy ty)) n)++newPinned :: forall prim ty . (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MutableBlock ty (PrimState prim))+newPinned n = unsafeNew Pinned (sizeOfE (primSizeInBytes (Proxy :: Proxy ty)) n)++-- | Copy a number of elements from an array to another array with offsets+unsafeCopyElements :: forall prim ty . (PrimMonad prim, PrimType ty)+                   => MutableBlock ty (PrimState prim) -- ^ destination mutable block+                   -> Offset ty                        -- ^ offset at destination+                   -> MutableBlock ty (PrimState prim) -- ^ source mutable block+                   -> Offset ty                        -- ^ offset at source+                   -> CountOf ty                          -- ^ number of elements to copy+                   -> prim ()+unsafeCopyElements dstMb destOffset srcMb srcOffset n = -- (MutableBlock dstMba) ed (MutableBlock srcBa) es n =+    unsafeCopyBytes dstMb (offsetOfE sz destOffset)+                    srcMb (offsetOfE sz srcOffset)+                    (sizeOfE sz n)+  where+    !sz = primSizeInBytes (Proxy :: Proxy ty)++unsafeCopyElementsRO :: forall prim ty . (PrimMonad prim, PrimType ty)+                     => MutableBlock ty (PrimState prim) -- ^ destination mutable block+                     -> Offset ty                        -- ^ offset at destination+                     -> Block ty                         -- ^ source block+                     -> Offset ty                        -- ^ offset at source+                     -> CountOf ty                          -- ^ number of elements to copy+                     -> prim ()+unsafeCopyElementsRO dstMb destOffset srcMb srcOffset n =+    unsafeCopyBytesRO dstMb (offsetOfE sz destOffset)+                      srcMb (offsetOfE sz srcOffset)+                      (sizeOfE sz n)+  where+    !sz = primSizeInBytes (Proxy :: Proxy ty)++-- | Copy a number of bytes from a MutableBlock to another MutableBlock with specific byte offsets+unsafeCopyBytes :: forall prim ty . PrimMonad prim+                => MutableBlock ty (PrimState prim) -- ^ destination mutable block+                -> Offset Word8                     -- ^ offset at destination+                -> MutableBlock ty (PrimState prim) -- ^ source mutable block+                -> Offset Word8                     -- ^ offset at source+                -> CountOf Word8                       -- ^ number of elements to copy+                -> prim ()+unsafeCopyBytes (MutableBlock dstMba) (Offset (I# d)) (MutableBlock srcBa) (Offset (I# s)) (CountOf (I# n)) =+    primitive $ \st -> (# copyMutableByteArray# srcBa s dstMba d n st, () #)+{-# INLINE unsafeCopyBytes #-}++-- | Copy a number of bytes from a Block to a MutableBlock with specific byte offsets+unsafeCopyBytesRO :: forall prim ty . PrimMonad prim+                  => MutableBlock ty (PrimState prim) -- ^ destination mutable block+                  -> Offset Word8                     -- ^ offset at destination+                  -> Block ty                         -- ^ source block+                  -> Offset Word8                     -- ^ offset at source+                  -> CountOf Word8                       -- ^ number of elements to copy+                  -> prim ()+unsafeCopyBytesRO (MutableBlock dstMba) (Offset (I# d)) (Block srcBa) (Offset (I# s)) (CountOf (I# n)) =+    primitive $ \st -> (# copyByteArray# srcBa s dstMba d n st, () #)+{-# INLINE unsafeCopyBytesRO #-}++-- | read from a cell in a mutable block without bounds checking.+--+-- Reading from invalid memory can return unpredictable and invalid values.+-- use 'read' if unsure.+unsafeRead :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> Offset ty -> prim ty+unsafeRead (MutableBlock mba) i = primMbaRead mba i+{-# INLINE unsafeRead #-}++-- | write to a cell in a mutable block without bounds checking.+--+-- Writing with invalid bounds will corrupt memory and your program will+-- become unreliable. use 'write' if unsure.+unsafeWrite :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> Offset ty -> ty -> prim ()+unsafeWrite (MutableBlock mba) i v = primMbaWrite mba i v+{-# INLINE unsafeWrite #-}++touch :: PrimMonad prim => Block ty -> prim ()+touch (Block ba) = unsafePrimFromIO $ primitive $ \s -> case touch# ba s of { s2 -> (# s2, () #) }++mutableTouch :: PrimMonad prim => MutableBlock ty (PrimState prim) -> prim ()+mutableTouch (MutableBlock mba) = unsafePrimFromIO $ primitive $ \s -> case touch# mba s of { s2 -> (# s2, () #) }+
+ Basement/Block/Mutable.hs view
@@ -0,0 +1,124 @@+-- |+-- Module      : Basement.Block.Mutable+-- License     : BSD-style+-- Maintainer  : Haskell Foundation+--+-- A block of memory that contains elements of a type,+-- very similar to an unboxed array but with the key difference:+--+-- * It doesn't have slicing capability (no cheap take or drop)+-- * It consume less memory: 1 Offset, 1 CountOf, 1 Pinning status trimmed+-- * It's unpackable in any constructor+-- * It uses unpinned memory by default+--+-- It should be rarely needed in high level API, but+-- in lowlevel API or some data structure containing lots+-- of unboxed array that will benefit from optimisation.+--+-- Because it's unpinned, the blocks are compactable / movable,+-- at the expense of making them less friendly to C layer / address.+--+-- Note that sadly the bytearray primitive type automatically create+-- a pinned bytearray if the size is bigger than a certain threshold+--+-- GHC Documentation associated:+--+-- includes/rts/storage/Block.h+--   * LARGE_OBJECT_THRESHOLD ((uint32_t)(BLOCK_SIZE * 8 / 10))+--   * BLOCK_SIZE   (1<<BLOCK_SHIFT)+--+-- includes/rts/Constant.h+--   * BLOCK_SHIFT  12+--+{-# LANGUAGE MagicHash           #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedTuples       #-}+module Basement.Block.Mutable+    ( Block(..)+    , MutableBlock(..)+    , mutableLengthSize+    , mutableLengthBytes+    , mutableGetAddr+    , new+    , newPinned+    , mutableEmpty+    , iterSet+    , read+    , write+    , unsafeNew+    , unsafeWrite+    , unsafeRead+    , unsafeFreeze+    , unsafeThaw+    , unsafeCopyElements+    , unsafeCopyElementsRO+    , unsafeCopyBytes+    , unsafeCopyBytesRO+    ) where++import           GHC.Prim+import           GHC.Types+import           Basement.Compat.Base+import           Data.Proxy+import           Basement.Exception+import           Basement.Types.OffsetSize+import           Basement.Monad+import           Basement.Numerical.Additive+import           Basement.PrimType+import           Basement.Block.Base++-- | Return the length of a Mutable Block+--+-- note: we don't allow resizing yet, so this can remain a pure function+mutableLengthSize :: forall ty st . PrimType ty => MutableBlock ty st -> CountOf ty+mutableLengthSize (MutableBlock mba) =+    let !(CountOf (I# szBits)) = primSizeInBytes (Proxy :: Proxy ty)+        !elems              = quotInt# (sizeofMutableByteArray# mba) szBits+     in CountOf (I# elems)+{-# INLINE[1] mutableLengthSize #-}++mutableLengthBytes :: MutableBlock ty st -> CountOf Word8+mutableLengthBytes (MutableBlock mba) = CountOf (I# (sizeofMutableByteArray# mba))+{-# INLINE[1] mutableLengthBytes #-}++-- | Get the address of the context of the mutable block.+--+-- if the block is not pinned, this is a _dangerous_ operation+mutableGetAddr :: PrimMonad prim => MutableBlock ty (PrimState prim) -> prim (Ptr ty)+mutableGetAddr (MutableBlock mba) = primitive $ \s1 ->+    case unsafeFreezeByteArray# mba s1 of+        (# s2, ba #) -> (# s2, Ptr (byteArrayContents# ba) #)++-- | Set all mutable block element to a value+iterSet :: (PrimType ty, PrimMonad prim)+        => (Offset ty -> ty)+        -> MutableBlock ty (PrimState prim)+        -> prim ()+iterSet f ma = loop 0+  where+    !sz = mutableLengthSize ma+    loop i+        | i .==# sz = pure ()+        | otherwise = unsafeWrite ma i (f i) >> loop (i+1)+    {-# INLINE loop #-}++-- | read a cell in a mutable array.+--+-- If the index is out of bounds, an error is raised.+read :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> Offset ty -> prim ty+read array n+    | isOutOfBound n len = primOutOfBound OOB_Read n len+    | otherwise          = unsafeRead array n+  where len = mutableLengthSize array+{-# INLINE read #-}++-- | Write to a cell in a mutable array.+--+-- If the index is out of bounds, an error is raised.+write :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> Offset ty -> ty -> prim ()+write array n val+    | isOutOfBound n len = primOutOfBound OOB_Write n len+    | otherwise          = unsafeWrite array n val+  where+    len = mutableLengthSize array+{-# INLINE write #-}
+ Basement/BlockN.hs view
@@ -0,0 +1,136 @@+-- |+-- Module      : Basement.Block+-- License     : BSD-style+-- Maintainer  : Haskell Foundation+--+-- A Nat-sized version of Block+{-# LANGUAGE AllowAmbiguousTypes       #-}+{-# LANGUAGE DataKinds                 #-}+{-# LANGUAGE TypeOperators             #-}+{-# LANGUAGE TypeApplications          #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Basement.BlockN+    ( BlockN+    , MutableBlockN+    , toBlockN+    , toBlock+    , singleton+    , replicate+    , thaw+    , freeze+    , index+    , map+    , foldl'+    , foldr+    , cons+    , snoc+    , elem+    , sub+    , uncons+    , unsnoc+    , splitAt+    , all+    , any+    , find+    , reverse+    , sortBy+    , intersperse+    )+where++import           Data.Proxy (Proxy(..))+import           Basement.Compat.Base+import           Basement.Block (Block, MutableBlock(..), unsafeIndex)+import qualified Basement.Block as B+import           Basement.Monad (PrimMonad, PrimState)+import           Basement.Nat+import           Basement.NormalForm+import           Basement.PrimType (PrimType)+import           Basement.Types.OffsetSize (CountOf(..), Offset(..))++newtype BlockN (n :: Nat) a = BlockN { unBlock :: Block a } deriving (NormalForm, Eq, Show)++newtype MutableBlockN (n :: Nat) ty st = MutableBlockN { unMBlock :: MutableBlock ty st }++toBlockN :: forall n ty . (PrimType ty, KnownNat n, NatWithinBound Int n) => Block ty -> Maybe (BlockN n ty)+toBlockN b+    | expected == B.length b = Just (BlockN b)+    | otherwise = Nothing+  where+    expected = toCount @n++toBlock :: BlockN n ty -> Block ty+toBlock = unBlock++singleton :: PrimType ty => ty -> BlockN 1 ty+singleton a = BlockN (B.singleton a)++replicate :: forall n ty . (KnownNat n, NatWithinBound Int n, PrimType ty) => ty -> BlockN n ty+replicate a = BlockN (B.replicate (toCount @n) a)++thaw :: (KnownNat n, PrimMonad prim, PrimType ty) => BlockN n ty -> prim (MutableBlockN n ty (PrimState prim))+thaw b = MutableBlockN <$> B.thaw (unBlock b)++freeze ::  (PrimMonad prim, PrimType ty, NatWithinBound Int n) => MutableBlockN n ty (PrimState prim) -> prim (BlockN n ty)+freeze b = BlockN <$> B.freeze (unMBlock b)++index :: forall i n ty . (KnownNat i, CmpNat i n ~ 'LT, PrimType ty,  NatWithinBound Int i) => BlockN n ty -> ty+index b = unsafeIndex (unBlock b) (toOffset @i)++map :: (PrimType a, PrimType b) => (a -> b) -> BlockN n a -> BlockN n b+map f b = BlockN (B.map f (unBlock b))++foldl' :: PrimType ty => (a -> ty -> a) -> a -> BlockN n ty -> a+foldl' f acc b = B.foldl' f acc (unBlock b)++foldr :: PrimType ty => (ty -> a -> a) -> a -> BlockN n ty -> a+foldr f acc b = B.foldr f acc (unBlock b)++cons :: PrimType ty => ty -> BlockN n ty -> BlockN (n+1) ty+cons e = BlockN . B.cons e . unBlock++snoc :: PrimType ty => BlockN n ty -> ty -> BlockN (n+1) ty+snoc b = BlockN . B.snoc (unBlock b)++sub :: forall i j n ty . ((i <=? n) ~ 'True, (j <=? n) ~ 'True, (i <=? j) ~ 'True, PrimType ty, KnownNat i, NatWithinBound Int i, KnownNat j, NatWithinBound Int j) => BlockN n ty -> BlockN (j-i) ty+sub block = BlockN (B.sub (unBlock block) (toOffset @i) (toOffset @j))++uncons :: forall n ty . (CmpNat 0 n ~ 'LT, PrimType ty, KnownNat n, NatWithinBound Int n) => BlockN n ty -> (ty, BlockN (n-1) ty)+uncons b = (index @0 b, BlockN (B.sub (unBlock b) 1 (toOffset @n)))++unsnoc :: forall n ty . (CmpNat 0 n ~ 'LT, KnownNat n, PrimType ty, NatWithinBound Int n) => BlockN n ty -> (BlockN (n-1) ty, ty)+unsnoc b = (BlockN (B.sub (unBlock b) 0 (toOffset @n)), undefined)++splitAt :: forall i n ty . (CmpNat i n ~ 'LT, PrimType ty, KnownNat i, NatWithinBound Int i) => BlockN n ty -> (BlockN i ty, BlockN (n-i) ty)+splitAt b =+    let (left, right) = B.splitAt (toCount @i) (unBlock b)+     in (BlockN left, BlockN right)++elem :: PrimType ty => ty -> BlockN n ty -> Bool+elem e b = B.elem e (unBlock b)++all :: PrimType ty => (ty -> Bool) -> BlockN n ty -> Bool+all p b = B.all p (unBlock b)++any :: PrimType ty => (ty -> Bool) -> BlockN n ty -> Bool+any p b = B.any p (unBlock b)++find :: PrimType ty => (ty -> Bool) -> BlockN n ty -> Maybe ty+find p b = B.find p (unBlock b)++reverse :: PrimType ty => BlockN n ty -> BlockN n ty+reverse = BlockN . B.reverse . unBlock++sortBy :: PrimType ty => (ty -> ty -> Ordering) -> BlockN n ty -> BlockN n ty+sortBy f b = BlockN (B.sortBy f (unBlock b))++intersperse :: (CmpNat n 1 ~ 'GT, PrimType ty) => ty -> BlockN n ty -> BlockN (n+n-1) ty+intersperse sep b = BlockN (B.intersperse sep (unBlock b))++toCount :: forall n ty . (KnownNat n, NatWithinBound Int n) => CountOf ty+toCount = CountOf (natValInt (Proxy @n))++toOffset :: forall n ty . (KnownNat n, NatWithinBound Int n) => Offset ty+toOffset = Offset (natValInt (Proxy @n))
+ Basement/Bounded.hs view
@@ -0,0 +1,60 @@+-- |+-- Module      : Basement.Block+-- License     : BSD-style+-- Maintainer  : Haskell Foundation+--+-- Types to represent ℤ/nℤ.+--+-- ℤ/nℤ is a finite field and is defined as the set of natural number:+-- {0, 1, ..., n − 1}.+--+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Basement.Bounded+    ( Zn64+    , unZn64+    , Zn+    , unZn+    , zn64+    , zn+    , zn64Nat+    , znNat+    ) where++import           GHC.TypeLits+import           Data.Word+import           Basement.Compat.Base+import           Basement.Compat.Natural+import           Data.Proxy+import           Basement.Nat+import qualified Prelude++-- | A type level bounded natural backed by a Word64+newtype Zn64 (n :: Nat) = Zn64 { unZn64 :: Word64 }+    deriving (Show,Eq,Ord)++-- | Create an element of ℤ/nℤ from a Word64+--+-- If the value is greater than n, then the value is normalized by using the+-- integer modulus n+zn64 :: forall n . (KnownNat n, NatWithinBound Word64 n) => Word64 -> Zn64 n+zn64 v = Zn64 (v `Prelude.mod` natValWord64 (Proxy :: Proxy n))++-- | Create an element of ℤ/nℤ from a type level Nat+zn64Nat :: forall m n . (KnownNat m, KnownNat n, NatWithinBound Word64 m, NatWithinBound Word64 n, CmpNat m n ~ 'LT) => Proxy m -> Zn64 n+zn64Nat p = Zn64 (natValWord64 p)++-- | A type level bounded natural+newtype Zn (n :: Nat) = Zn { unZn :: Natural }+    deriving (Show,Eq,Ord)++-- | Create an element of ℤ/nℤ from a Natural.+--+-- If the value is greater than n, then the value is normalized by using the+-- integer modulus n+zn :: forall n . KnownNat n => Natural -> Zn n+zn v = Zn (v `Prelude.mod` natValNatural (Proxy :: Proxy n))++-- | Create an element of ℤ/nℤ from a type level Nat+znNat :: forall m n . (KnownNat m, KnownNat n, CmpNat m n ~ 'LT) => Proxy m -> Zn n+znNat m = Zn (natValNatural m)
+ Basement/BoxedArray.hs view
@@ -0,0 +1,741 @@+-- |+-- Module      : Basement.BoxedArray+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : portable+--+-- Simple boxed array abstraction+--+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Basement.BoxedArray+    ( Array+    , MArray+    , empty+    , length+    , mutableLength+    , copy+    , unsafeCopyAtRO+    , thaw+    , new+    , unsafeFreeze+    , unsafeThaw+    , freeze+    , unsafeWrite+    , unsafeRead+    , unsafeIndex+    , write+    , read+    , index+    , singleton+    , replicate+    , null+    , take+    , drop+    , splitAt+    , revTake+    , revDrop+    , revSplitAt+    , splitOn+    , sub+    , intersperse+    , span+    , break+    , cons+    , snoc+    , uncons+    , unsnoc+    -- , findIndex+    , sortBy+    , filter+    , reverse+    , elem+    , find+    , foldl'+    , foldr+    , foldl1'+    , foldr1+    , all+    , any+    , isPrefixOf+    , isSuffixOf+    , builderAppend+    , builderBuild+    , builderBuild_+    ) where++import           GHC.Prim+import           GHC.Types+import           GHC.ST+import           Basement.Numerical.Additive+import           Basement.Numerical.Subtractive+import           Basement.NonEmpty+import           Basement.Compat.Base+import           Data.Proxy+import           Basement.Compat.MonadTrans+import           Basement.Types.OffsetSize+import           Basement.PrimType+import           Basement.NormalForm+import           Basement.Monad+import           Basement.Exception+import           Basement.MutableBuilder+import qualified Basement.Compat.ExtList as List++-- | Array of a+data Array a = Array {-# UNPACK #-} !(Offset a)+                     {-# UNPACK #-} !(CountOf a)+                                    (Array# a)+    deriving (Typeable)++instance Data ty => Data (Array ty) where+    dataTypeOf _ = arrayType+    toConstr _   = error "toConstr"+    gunfold _ _  = error "gunfold"++arrayType :: DataType+arrayType = mkNoRepType "Foundation.Array"++instance NormalForm a => NormalForm (Array a) where+    toNormalForm arr = loop 0+      where+        !sz = length arr+        loop !i+            | i .==# sz = ()+            | otherwise = unsafeIndex arr i `seq` loop (i+1)++-- | Mutable Array of a+data MArray a st = MArray {-# UNPACK #-} !(Offset a)+                          {-# UNPACK #-} !(CountOf a)+                                         (MutableArray# st a)+    deriving (Typeable)++instance Functor Array where+    fmap = map++instance Monoid (Array a) where+    mempty  = empty+    mappend = append+    mconcat = concat++instance Show a => Show (Array a) where+    show v = show (toList v)++instance Eq a => Eq (Array a) where+    (==) = equal+instance Ord a => Ord (Array a) where+    compare = vCompare++instance IsList (Array ty) where+    type Item (Array ty) = ty+    fromList = vFromList+    toList = vToList++-- | return the numbers of elements in a mutable array+mutableLength :: MArray ty st -> Int+mutableLength (MArray _ (CountOf len) _) = len+{-# INLINE mutableLength #-}++-- | return the numbers of elements in a mutable array+mutableLengthSize :: MArray ty st -> CountOf ty+mutableLengthSize (MArray _ size _) = size+{-# INLINE mutableLengthSize #-}++-- | Return the element at a specific index from an array.+--+-- If the index @n is out of bounds, an error is raised.+index :: Array ty -> Offset ty -> ty+index array n+    | isOutOfBound n len = outOfBound OOB_Index n len+    | otherwise          = unsafeIndex array n+  where len = length array+{-# INLINE index #-}++-- | Return the element at a specific index from an array without bounds checking.+--+-- Reading from invalid memory can return unpredictable and invalid values.+-- use 'index' if unsure.+unsafeIndex :: Array ty -> Offset ty -> ty+unsafeIndex (Array start _ a) ofs = primArrayIndex a (start+ofs)+{-# INLINE unsafeIndex #-}++-- | read a cell in a mutable array.+--+-- If the index is out of bounds, an error is raised.+read :: PrimMonad prim => MArray ty (PrimState prim) -> Offset ty -> prim ty+read array n+    | isOutOfBound n len = primOutOfBound OOB_Read n len+    | otherwise          = unsafeRead array n+  where len = mutableLengthSize array+{-# INLINE read #-}++-- | read from a cell in a mutable array without bounds checking.+--+-- Reading from invalid memory can return unpredictable and invalid values.+-- use 'read' if unsure.+unsafeRead :: PrimMonad prim => MArray ty (PrimState prim) -> Offset ty -> prim ty+unsafeRead (MArray start _ ma) i = primMutableArrayRead ma (start + i)+{-# INLINE unsafeRead #-}++-- | Write to a cell in a mutable array.+--+-- If the index is out of bounds, an error is raised.+write :: PrimMonad prim => MArray ty (PrimState prim) -> Offset ty -> ty -> prim ()+write array n val+    | isOutOfBound n len = primOutOfBound OOB_Write n len+    | otherwise          = unsafeWrite array n val+  where len = mutableLengthSize array+{-# INLINE write #-}++-- | write to a cell in a mutable array without bounds checking.+--+-- Writing with invalid bounds will corrupt memory and your program will+-- become unreliable. use 'write' if unsure.+unsafeWrite :: PrimMonad prim => MArray ty (PrimState prim) -> Offset ty -> ty -> prim ()+unsafeWrite (MArray start _ ma) ofs v =+    primMutableArrayWrite ma (start + ofs) v+{-# INLINE unsafeWrite #-}++-- | Freeze a mutable array into an array.+--+-- the MArray must not be changed after freezing.+unsafeFreeze :: PrimMonad prim => MArray ty (PrimState prim) -> prim (Array ty)+unsafeFreeze (MArray ofs sz ma) = primitive $ \s1 ->+    case unsafeFreezeArray# ma s1 of+        (# s2, a #) -> (# s2, Array ofs sz a #)+{-# INLINE unsafeFreeze #-}++-- | Thaw an immutable array.+--+-- The Array must not be used after thawing.+unsafeThaw :: PrimMonad prim => Array ty -> prim (MArray ty (PrimState prim))+unsafeThaw (Array ofs sz a) = primitive $ \st -> (# st, MArray ofs sz (unsafeCoerce# a) #)+{-# INLINE unsafeThaw #-}++-- | Thaw an array to a mutable array.+--+-- the array is not modified, instead a new mutable array is created+-- and every values is copied, before returning the mutable array.+thaw :: PrimMonad prim => Array ty -> prim (MArray ty (PrimState prim))+thaw array = do+    m <- new (length array)+    unsafeCopyAtRO m (Offset 0) array (Offset 0) (length array)+    pure m+{-# INLINE thaw #-}++freeze :: PrimMonad prim => MArray ty (PrimState prim) -> prim (Array ty)+freeze marray = do+    m <- new sz+    copyAt m (Offset 0) marray (Offset 0) sz+    unsafeFreeze m+  where+    sz = mutableLengthSize marray++-- | Copy the element to a new element array+copy :: Array ty -> Array ty+copy a = runST (unsafeThaw a >>= freeze)++-- | Copy a number of elements from an array to another array with offsets+copyAt :: PrimMonad prim+       => MArray ty (PrimState prim) -- ^ destination array+       -> Offset ty                  -- ^ offset at destination+       -> MArray ty (PrimState prim) -- ^ source array+       -> Offset ty                  -- ^ offset at source+       -> CountOf ty                    -- ^ number of elements to copy+       -> prim ()+copyAt dst od src os n = loop od os+  where -- !endIndex = os `offsetPlusE` n+        loop d s+            | s .==# n  = pure ()+            | otherwise = unsafeRead src s >>= unsafeWrite dst d >> loop (d+1) (s+1)++-- | Copy @n@ sequential elements from the specified offset in a source array+--   to the specified position in a destination array.+--+--   This function does not check bounds. Accessing invalid memory can return+--   unpredictable and invalid values.+unsafeCopyAtRO :: PrimMonad prim+               => MArray ty (PrimState prim) -- ^ destination array+               -> Offset ty                  -- ^ offset at destination+               -> Array ty                   -- ^ source array+               -> Offset ty                  -- ^ offset at source+               -> CountOf ty                    -- ^ number of elements to copy+               -> prim ()+unsafeCopyAtRO (MArray (Offset (I# dstart)) _ da) (Offset (I# dofs))+               (Array  (Offset (I# sstart)) _ sa) (Offset (I# sofs))+               (CountOf (I# n)) =+    primitive $ \st ->+        (# copyArray# sa (sstart +# sofs) da (dstart +# dofs) n st, () #)++-- | Allocate a new array with a fill function that has access to the elements of+--   the source array.+unsafeCopyFrom :: Array ty -- ^ Source array+               -> CountOf ty  -- ^ Length of the destination array+               -> (Array ty -> Offset ty -> MArray ty s -> ST s ())+               -- ^ Function called for each element in the source array+               -> ST s (Array ty) -- ^ Returns the filled new array+unsafeCopyFrom v' newLen f = new newLen >>= fill (Offset 0) f >>= unsafeFreeze+  where len = length v'+        endIdx = Offset 0 `offsetPlusE` len+        fill i f' r'+            | i == endIdx = pure r'+            | otherwise   = do f' v' i r'+                               fill (i + Offset 1) f' r'++-- | Create a new mutable array of size @n.+--+-- all the cells are uninitialized and could contains invalid values.+--+-- All mutable arrays are allocated on a 64 bits aligned addresses+-- and always contains a number of bytes multiples of 64 bits.+new :: PrimMonad prim => CountOf ty -> prim (MArray ty (PrimState prim))+new sz@(CountOf (I# n)) = primitive $ \s1 ->+    case newArray# n (error "vector: internal error uninitialized vector") s1 of+        (# s2, ma #) -> (# s2, MArray (Offset 0) sz ma #)++-- | Create a new array of size @n by settings each cells through the+-- function @f.+create :: forall ty . CountOf ty -- ^ the size of the array+       -> (Offset ty -> ty)   -- ^ the function that set the value at the index+       -> Array ty            -- ^ the array created+create n initializer = runST (new n >>= iter initializer)+  where+    iter :: PrimMonad prim => (Offset ty -> ty) -> MArray ty (PrimState prim) -> prim (Array ty)+    iter f ma = loop 0+      where+        loop s+            | s .==# n  = unsafeFreeze ma+            | otherwise = unsafeWrite ma s (f s) >> loop (s+1)+        {-# INLINE loop #-}+    {-# INLINE iter #-}++-----------------------------------------------------------------------+-- higher level collection implementation+-----------------------------------------------------------------------+equal :: Eq a => Array a -> Array a -> Bool+equal a b = (len == length b) && eachEqual 0+  where+    len = length a+    eachEqual !i+        | i .==# len                         = True+        | unsafeIndex a i /= unsafeIndex b i = False+        | otherwise                          = eachEqual (i+1)++vCompare :: Ord a => Array a -> Array a -> Ordering+vCompare a b = loop 0+  where+    !la = length a+    !lb = length b+    loop n+        | n .==# la = if la == lb then EQ else LT+        | n .==# lb = GT+        | otherwise =+            case unsafeIndex a n `compare` unsafeIndex b n of+                EQ -> loop (n+1)+                r  -> r++empty :: Array a+empty = runST $ onNewArray 0 (\_ s -> s)++length :: Array a -> CountOf a+length (Array _ sz _) = sz++vFromList :: [a] -> Array a+vFromList l = runST (new len >>= loop 0 l)+  where+    len = CountOf $ List.length l+    loop _ []     ma = unsafeFreeze ma+    loop i (x:xs) ma = unsafeWrite ma i x >> loop (i+1) xs ma++vToList :: Array a -> [a]+vToList v+    | len == 0  = []+    | otherwise = fmap (unsafeIndex v) [0..sizeLastOffset len]+  where !len = length v++-- | Append 2 arrays together by creating a new bigger array+append :: Array ty -> Array ty -> Array ty+append a b = runST $ do+    r  <- new (la+lb)+    unsafeCopyAtRO r (Offset 0) a (Offset 0) la+    unsafeCopyAtRO r (sizeAsOffset la) b (Offset 0) lb+    unsafeFreeze r+  where la = length a+        lb = length b++concat :: [Array ty] -> Array ty+concat l = runST $ do+    r <- new (mconcat $ fmap length l)+    loop r (Offset 0) l+    unsafeFreeze r+  where loop _ _ []     = pure ()+        loop r i (x:xs) = do+            unsafeCopyAtRO r i x (Offset 0) lx+            loop r (i `offsetPlusE` lx) xs+          where lx = length x++{-+modify :: PrimMonad m+       => Array a+       -> (MArray (PrimState m) a -> m ())+       -> m (Array a)+modify (Array a) f = primitive $ \st -> do+    case thawArray# a 0# (sizeofArray# a) st of+        (# st2, mv #) ->+            case internal_ (f $ MArray mv) st2 of+                st3 ->+                    case unsafeFreezeArray# mv st3 of+                        (# st4, a' #) -> (# st4, Array a' #)+-}++-----------------------------------------------------------------------+-- helpers++onNewArray :: PrimMonad m+           => Int+           -> (MutableArray# (PrimState m) a -> State# (PrimState m) -> State# (PrimState m))+           -> m (Array a)+onNewArray len@(I# len#) f = primitive $ \st -> do+    case newArray# len# (error "onArray") st of { (# st2, mv #) ->+    case f mv st2                            of { st3           ->+    case unsafeFreezeArray# mv st3           of { (# st4, a #)  ->+        (# st4, Array (Offset 0) (CountOf len) a #) }}}++-----------------------------------------------------------------------+++null :: Array ty -> Bool+null = (==) 0 . length++take :: CountOf ty -> Array ty -> Array ty+take nbElems a@(Array start len arr)+    | nbElems <= 0 = empty+    | n == len     = a+    | otherwise    = Array start n arr+  where+    n = min nbElems len++drop :: CountOf ty -> Array ty -> Array ty+drop nbElems a@(Array start len arr)+    | nbElems <= 0                               = a+    | Just nbTails <- len - nbElems, nbTails > 0 = Array (start `offsetPlusE` nbElems) nbTails arr+    | otherwise                                  = empty++splitAt :: CountOf ty -> Array ty -> (Array ty, Array ty)+splitAt nbElems a@(Array start len arr)+    | nbElems <= 0 = (empty, a)+    | Just nbTails <- len - nbElems, nbTails > 0 = ( Array start                         nbElems arr+                                                   , Array (start `offsetPlusE` nbElems) nbTails arr)+    | otherwise = (a, empty)++-- inverse a CountOf that is specified from the end (e.g. take n elements from the end)+countFromStart :: Array ty -> CountOf ty -> CountOf ty+countFromStart v sz@(CountOf sz')+    | sz >= len = CountOf 0+    | otherwise = CountOf (len' - sz')+  where len@(CountOf len') = length v++revTake :: CountOf ty -> Array ty -> Array ty+revTake n v = drop (countFromStart v n) v++revDrop :: CountOf ty -> Array ty -> Array ty+revDrop n v = take (countFromStart v n) v++revSplitAt :: CountOf ty -> Array ty -> (Array ty, Array ty)+revSplitAt n v = (drop idx v, take idx v) where idx = countFromStart v n++splitOn ::  (ty -> Bool) -> Array ty -> [Array ty]+splitOn predicate vec+    | len == CountOf 0 = [mempty]+    | otherwise     = loop (Offset 0) (Offset 0)+  where+    !len = length vec+    !endIdx = Offset 0 `offsetPlusE` len+    loop prevIdx idx+        | idx == endIdx = [sub vec prevIdx idx]+        | otherwise     =+            let e = unsafeIndex vec idx+                idx' = idx + 1+             in if predicate e+                    then sub vec prevIdx idx : loop idx' idx'+                    else loop prevIdx idx'++sub :: Array ty -> Offset ty -> Offset ty -> Array ty+sub (Array start len a) startIdx expectedEndIdx+    | startIdx == endIdx           = empty+    | otherwise                    = Array (start + startIdx) newLen a+  where+    newLen = endIdx - startIdx+    endIdx = min expectedEndIdx (sizeAsOffset len)++break ::  (ty -> Bool) -> Array ty -> (Array ty, Array ty)+break predicate v = findBreak 0+  where+    !len = length v+    findBreak i+        | i .==# len  = (v, empty)+        | otherwise   =+            if predicate (unsafeIndex v i)+                then splitAt (offsetAsSize i) v+                else findBreak (i+1)++intersperse :: ty -> Array ty -> Array ty+intersperse sep v = case len - 1 of+    Nothing -> v+    Just 0 -> v+    Just more -> runST $ unsafeCopyFrom v (len + more) (go (Offset 0 `offsetPlusE` more) sep)+  where len = length v+        -- terminate 1 before the end++        go :: Offset ty -> ty -> Array ty -> Offset ty -> MArray ty s -> ST s ()+        go endI sep' oldV oldI newV+            | oldI == endI = unsafeWrite newV dst e+            | otherwise    = do+                unsafeWrite newV dst e+                unsafeWrite newV (dst + 1) sep'+          where+            e = unsafeIndex oldV oldI+            dst = oldI + oldI++span ::  (ty -> Bool) -> Array ty -> (Array ty, Array ty)+span p = break (not . p)++map :: (a -> b) -> Array a -> Array b+map f a = create (sizeCast Proxy $ length a) (\i -> f $ unsafeIndex a (offsetCast Proxy i))++{-+mapIndex :: (Int -> a -> b) -> Array a -> Array b+mapIndex f a = create (length a) (\i -> f i $ unsafeIndex a i)+-}++singleton :: ty -> Array ty+singleton e = runST $ do+    a <- new 1+    unsafeWrite a 0 e+    unsafeFreeze a++replicate :: CountOf ty -> ty -> Array ty+replicate sz ty = create sz (const ty)++cons :: ty -> Array ty -> Array ty+cons e vec+    | len == CountOf 0 = singleton e+    | otherwise     = runST $ do+        mv <- new (len + CountOf 1)+        unsafeWrite mv 0 e+        unsafeCopyAtRO mv (Offset 1) vec (Offset 0) len+        unsafeFreeze mv+  where+    !len = length vec++snoc ::  Array ty -> ty -> Array ty+snoc vec e+    | len == 0  = singleton e+    | otherwise = runST $ do+        mv <- new (len + 1)+        unsafeCopyAtRO mv 0 vec 0 len+        unsafeWrite mv (sizeAsOffset len) e+        unsafeFreeze mv+  where+    !len = length vec++uncons :: Array ty -> Maybe (ty, Array ty)+uncons vec+    | len == 0  = Nothing+    | otherwise = Just (unsafeIndex vec 0, drop 1 vec)+  where+    !len = length vec++unsnoc :: Array ty -> Maybe (Array ty, ty)+unsnoc vec = case len - 1 of+    Nothing -> Nothing+    Just newLen -> Just (take newLen vec, unsafeIndex vec (sizeLastOffset len))+  where+    !len = length vec++elem :: Eq ty => ty -> Array ty -> Bool+elem !ty arr = loop 0+  where+    !sz = length arr+    loop !i | i .==# sz = False+            | t == ty   = True+            | otherwise = loop (i+1)+      where t = unsafeIndex arr i++find :: (ty -> Bool) -> Array ty -> Maybe ty+find predicate vec = loop 0+  where+    !len = length vec+    loop i+        | i .==# len = Nothing+        | otherwise  =+            let e = unsafeIndex vec i+             in if predicate e then Just e else loop (i+1)++sortBy :: forall ty . (ty -> ty -> Ordering) -> Array ty -> Array ty+sortBy xford vec+    | len == 0  = empty+    | otherwise = runST (thaw vec >>= doSort xford)+  where+    len = length vec+    doSort :: PrimMonad prim => (ty -> ty -> Ordering) -> MArray ty (PrimState prim) -> prim (Array ty)+    doSort ford ma = qsort 0 (sizeLastOffset len) >> unsafeFreeze ma+      where+        qsort lo hi+            | lo >= hi  = pure ()+            | otherwise = do+                p <- partition lo hi+                qsort lo (pred p)+                qsort (p+1) hi+        partition lo hi = do+            pivot <- unsafeRead ma hi+            let loop i j+                    | j == hi   = pure i+                    | otherwise = do+                        aj <- unsafeRead ma j+                        i' <- if ford aj pivot == GT+                                then pure i+                                else do+                                    ai <- unsafeRead ma i+                                    unsafeWrite ma j ai+                                    unsafeWrite ma i aj+                                    pure $ i + 1+                        loop i' (j+1)++            i <- loop lo lo+            ai  <- unsafeRead ma i+            ahi <- unsafeRead ma hi+            unsafeWrite ma hi ai+            unsafeWrite ma i ahi+            pure i++filter :: forall ty . (ty -> Bool) -> Array ty -> Array ty+filter predicate vec = runST (new len >>= copyFilterFreeze predicate (unsafeIndex vec))+  where+    !len = length vec+    copyFilterFreeze :: PrimMonad prim => (ty -> Bool) -> (Offset ty -> ty) -> MArray ty (PrimState prim) -> prim (Array ty)+    copyFilterFreeze predi getVec mvec = loop (Offset 0) (Offset 0) >>= freezeUntilIndex mvec+      where+        loop d s+            | s .==# len  = pure d+            | predi v     = unsafeWrite mvec d v >> loop (d+1) (s+1)+            | otherwise   = loop d (s+1)+          where+            v = getVec s++freezeUntilIndex :: PrimMonad prim => MArray ty (PrimState prim) -> Offset ty -> prim (Array ty)+freezeUntilIndex mvec d = do+    m <- new (offsetAsSize d)+    copyAt m (Offset 0) mvec (Offset 0) (offsetAsSize d)+    unsafeFreeze m++unsafeFreezeShrink :: PrimMonad prim => MArray ty (PrimState prim) -> CountOf ty -> prim (Array ty)+unsafeFreezeShrink (MArray start _ ma) n = unsafeFreeze (MArray start n ma)++reverse :: Array ty -> Array ty+reverse a = create len toEnd+  where+    len@(CountOf s) = length a+    toEnd (Offset i) = unsafeIndex a (Offset (s - 1 - i))++foldr :: (ty -> a -> a) -> a -> Array ty -> a+foldr f initialAcc vec = loop 0+  where+    len = length vec+    loop !i+        | i .==# len = initialAcc+        | otherwise  = unsafeIndex vec i `f` loop (i+1)++foldl' :: (a -> ty -> a) -> a -> Array ty -> a+foldl' f initialAcc vec = loop 0 initialAcc+  where+    len = length vec+    loop !i !acc+        | i .==# len = acc+        | otherwise  = loop (i+1) (f acc (unsafeIndex vec i))++foldl1' :: (ty -> ty -> ty) -> NonEmpty (Array ty) -> ty+foldl1' f arr = let (initialAcc, rest) = splitAt 1 $ getNonEmpty arr+               in foldl' f (unsafeIndex initialAcc 0) rest++foldr1 :: (ty -> ty -> ty) -> NonEmpty (Array ty) -> ty+foldr1 f arr = let (initialAcc, rest) = revSplitAt 1 $ getNonEmpty arr+               in foldr f (unsafeIndex initialAcc 0) rest++all :: (ty -> Bool) -> Array ty -> Bool+all p ba = loop 0+  where+    len = length ba+    loop !i+      | i .==# len = True+      | not $ p (unsafeIndex ba i) = False+      | otherwise = loop (i + 1)++any :: (ty -> Bool) -> Array ty -> Bool+any p ba = loop 0+  where+    len = length ba+    loop !i+      | i .==# len = False+      | p (unsafeIndex ba i) = True+      | otherwise = loop (i + 1)++isPrefixOf :: Eq ty => Array ty -> Array ty -> Bool+isPrefixOf pre arr+    | pLen > pArr = False+    | otherwise   = pre == take pLen arr+  where+    !pLen = length pre+    !pArr = length arr++isSuffixOf :: Eq ty => Array ty -> Array ty -> Bool+isSuffixOf suffix arr+    | pLen > pArr = False+    | otherwise   = suffix == revTake pLen arr+  where+    !pLen = length suffix+    !pArr = length arr++builderAppend :: PrimMonad state => ty -> Builder (Array ty) (MArray ty) ty state err ()+builderAppend v = Builder $ State $ \(i, st, e) ->+    if i .==# chunkSize st+        then do+            cur      <- unsafeFreeze (curChunk st)+            newChunk <- new (chunkSize st)+            unsafeWrite newChunk 0 v+            pure ((), (Offset 1, st { prevChunks     = cur : prevChunks st+                                      , prevChunksSize = chunkSize st + prevChunksSize st+                                      , curChunk       = newChunk+                                      }, e))+        else do+            unsafeWrite (curChunk st) i v+            pure ((), (i+1, st, e))++builderBuild :: PrimMonad m => Int -> Builder (Array ty) (MArray ty) ty m err () -> m (Either err (Array ty))+builderBuild sizeChunksI ab+    | sizeChunksI <= 0 = builderBuild 64 ab+    | otherwise        = do+        first         <- new sizeChunks+        ((), (i, st, e)) <- runState (runBuilder ab) (Offset 0, BuildingState [] (CountOf 0) first sizeChunks, Nothing)+        case e of+          Just err -> pure (Left err)+          Nothing -> do+            cur <- unsafeFreezeShrink (curChunk st) (offsetAsSize i)+            -- Build final array+            let totalSize = prevChunksSize st + offsetAsSize i+            bytes <- new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= unsafeFreeze+            pure (Right bytes)+  where+    sizeChunks = CountOf sizeChunksI++    fillFromEnd _    []     mua = pure mua+    fillFromEnd !end (x:xs) mua = do+        let sz = length x+        let start = end `sizeSub` sz+        unsafeCopyAtRO mua (sizeAsOffset start) x (Offset 0) sz+        fillFromEnd start xs mua++builderBuild_ :: PrimMonad m => Int -> Builder (Array ty) (MArray ty) ty m () () -> m (Array ty)+builderBuild_ sizeChunksI ab = either (\() -> internalError "impossible output") id <$> builderBuild sizeChunksI ab
+ Basement/Compat/Base.hs view
@@ -0,0 +1,91 @@+-- |+-- Module      : Basement.Compat.Base+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : portable+--+-- internal re-export of all the good base bits+module Basement.Compat.Base+    ( (Prelude.$)+    , (Prelude.$!)+    , (Prelude.&&)+    , (Prelude.||)+    , (Control.Category..)+    , (Control.Applicative.<$>)+    , Prelude.not+    , Prelude.otherwise+    , Prelude.fst+    , Prelude.snd+    , Control.Category.id+    , Prelude.maybe+    , Prelude.either+    , Prelude.flip+    , Prelude.const+    , Prelude.error+    , Prelude.and+    , Prelude.undefined+    , Prelude.seq+    , Prelude.Show (..)+    , Prelude.Ord (..)+    , Prelude.Eq (..)+    , Prelude.Bounded (..)+    , Prelude.Enum (..)+    , Prelude.Functor (..)+    , Control.Applicative.Applicative (..)+    , Prelude.Monad (..)+    , Prelude.Maybe (..)+    , Prelude.Ordering (..)+    , Prelude.Bool (..)+    , Prelude.Int+    , Prelude.Integer+    , Prelude.Char+    , Basement.Compat.NumLiteral.Integral (..)+    , Basement.Compat.NumLiteral.Fractional (..)+    , Basement.Compat.NumLiteral.HasNegation (..)+    , Data.Int.Int8, Data.Int.Int16, Data.Int.Int32, Data.Int.Int64+    , Data.Word.Word8, Data.Word.Word16, Data.Word.Word32, Data.Word.Word64, Data.Word.Word+    , Prelude.Double, Prelude.Float+    , Prelude.IO+    , Basement.Compat.IsList.IsList (..)+    , GHC.Exts.IsString (..)+    , GHC.Generics.Generic+    , Prelude.Either (..)+    , Data.Data.Data (..)+    , Data.Data.mkNoRepType+    , Data.Data.DataType+    , Basement.Compat.Typeable.Typeable+    , Data.Monoid.Monoid (..)+    , (Data.Monoid.<>)+    , Control.Exception.Exception+    , Control.Exception.throw+    , Control.Exception.throwIO+    , GHC.Ptr.Ptr(..)+    , ifThenElse+    , internalError+    ) where++import qualified Prelude+import qualified Control.Category+import qualified Control.Applicative+import qualified Control.Exception+import qualified Data.Monoid+import qualified Data.Data+import qualified Data.Word+import qualified Data.Int+import qualified Basement.Compat.IsList+import qualified Basement.Compat.NumLiteral+import qualified Basement.Compat.Typeable+import qualified GHC.Exts+import qualified GHC.Generics+import qualified GHC.Ptr+import           GHC.Exts (fromString)++-- | Only to use internally for internal error cases+internalError :: [Prelude.Char] -> a+internalError s = Prelude.error ("Internal Error: the impossible happened: " Prelude.++ s)++-- | for support of if .. then .. else+ifThenElse :: Prelude.Bool -> a -> a -> a+ifThenElse Prelude.True  e1 _  = e1+ifThenElse Prelude.False _  e2 = e2
+ Basement/Compat/Bifunctor.hs view
@@ -0,0 +1,83 @@+-- |+-- Module      : Basement.Compat.Bifunctor+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : portable+--+-- Formally, the class 'Bifunctor' represents a bifunctor+-- from @Hask@ -> @Hask@.+--+-- Intuitively it is a bifunctor where both the first and second+-- arguments are covariant.+--+-- You can define a 'Bifunctor' by either defining 'bimap' or by+-- defining both 'first' and 'second'.+--+{-# LANGUAGE CPP #-}+module Basement.Compat.Bifunctor+  ( Bifunctor(..)+  ) where++#if MIN_VERSION_base(4,8,0)++import Data.Bifunctor (Bifunctor(..))++#else++import           Control.Applicative ( Const(..) )+import           GHC.Generics ( K1(..) )+import qualified Prelude as P++class Bifunctor p where+    {-# MINIMAL bimap | first, second #-}++    -- | Map over both arguments at the same time.+    --+    -- @'bimap' f g ≡ 'first' f '.' 'second' g@+    bimap :: (a -> b) -> (c -> d) -> p a c -> p b d+    bimap f g = first f P.. second g++    -- | Map covariantly over the first argument.+    --+    -- @'first' f ≡ 'bimap' f 'id'@+    first :: (a -> b) -> p a c -> p b c+    first f = bimap f P.id++    -- | Map covariantly over the second argument.+    --+    -- @'second' ≡ 'bimap' 'id'@+    second :: (b -> c) -> p a b -> p a c+    second = bimap P.id+++instance Bifunctor (,) where+    bimap f g ~(a, b) = (f a, g b)++instance Bifunctor ((,,) x1) where+    bimap f g ~(x1, a, b) = (x1, f a, g b)++instance Bifunctor ((,,,) x1 x2) where+    bimap f g ~(x1, x2, a, b) = (x1, x2, f a, g b)++instance Bifunctor ((,,,,) x1 x2 x3) where+    bimap f g ~(x1, x2, x3, a, b) = (x1, x2, x3, f a, g b)++instance Bifunctor ((,,,,,) x1 x2 x3 x4) where+    bimap f g ~(x1, x2, x3, x4, a, b) = (x1, x2, x3, x4, f a, g b)++instance Bifunctor ((,,,,,,) x1 x2 x3 x4 x5) where+    bimap f g ~(x1, x2, x3, x4, x5, a, b) = (x1, x2, x3, x4, x5, f a, g b)+++instance Bifunctor P.Either where+    bimap f _ (P.Left a) = P.Left (f a)+    bimap _ g (P.Right b) = P.Right (g b)++instance Bifunctor Const where+    bimap f _ (Const a) = Const (f a)++instance Bifunctor (K1 i) where+    bimap f _ (K1 c) = K1 (f c)++#endif
+ Basement/Compat/CallStack.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE ConstraintKinds #-}+module Basement.Compat.CallStack+    ( HasCallStack+    ) where++#if MIN_VERSION_base(4,9,0)++import GHC.Stack (HasCallStack)++#elif MIN_VERSION_base(4,8,1)++import qualified GHC.Stack++type HasCallStack = (?callStack :: GHC.Stack.CallStack)++#else++import GHC.Exts (Constraint)++type HasCallStack = (() :: Constraint)++#endif
+ Basement/Compat/ExtList.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE CPP #-}+module Basement.Compat.ExtList+    ( length+    , null+    , sum+    , reverse+    ) where++import Basement.Compat.Base+import Basement.Numerical.Additive+import qualified GHC.List as List++-- | Compute the size of the list+length :: [a] -> Int+#if MIN_VERSION_base(4,8,0)+length = List.foldl' (\c _ -> c+1) 0+#else+length = loop 0+  where loop !acc []     = acc+        loop !acc (_:xs) = loop (1+acc) xs+#endif++null :: [a] -> Bool+null []    = True+null (_:_) = False++-- | Sum the element in a list+sum :: Additive n => [n] -> n+sum []     = azero+sum (i:is) = loop i is+  where+    loop !acc [] = acc+    loop !acc (x:xs) = loop (acc+x) xs+    {-# INLINE loop #-}++reverse :: [a] -> [a]+reverse l =  go l []+  where+    go []     acc = acc+    go (x:xs) acc = go xs (x:acc)
+ Basement/Compat/Identity.hs view
@@ -0,0 +1,37 @@+-- |+-- Module      : Basement.Compat.Identity+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : portable+--+-- Identity re-export, with a compat wrapper for older version of base that+-- do not have Data.Functor.Identity+{-# LANGUAGE CPP #-}+module Basement.Compat.Identity+    ( Identity(..)+    ) where++#if MIN_VERSION_base(4,8,0)++import Data.Functor.Identity++#else++import Basement.Compat.Base++newtype Identity a = Identity { runIdentity :: a }+    deriving (Eq, Ord)++instance Functor Identity where+    fmap f (Identity a) = Identity (f a)++instance Applicative Identity where+    pure a = Identity a+    (<*>) fab fa = Identity $ runIdentity fab (runIdentity fa)++instance Monad Identity where+    return    = pure+    ma >>= mb = mb (runIdentity ma)++#endif
+ Basement/Compat/IsList.hs view
@@ -0,0 +1,36 @@+-- |+-- Module      : Basement.Compat.IsList+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : portable+--+-- compat friendly version of IsList+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE CPP #-}+module Basement.Compat.IsList+    ( IsList(..)+    ) where++#if MIN_VERSION_base(4,7,0)++import           GHC.Exts++#else++import qualified Prelude++class IsList l where+  type Item l+  fromList  :: [Item l] -> l+  toList    :: l -> [Item l]++  fromListN :: Prelude.Int -> [Item l] -> l+  fromListN _ = fromList++instance IsList [a] where+    type Item [a] = a+    fromList = Prelude.id+    toList   = Prelude.id++#endif
+ Basement/Compat/MonadTrans.hs view
@@ -0,0 +1,50 @@+-- |+-- Module      : Basement.Compat.MonadTrans+-- License     : BSD-style+-- Maintainer  : Psychohistorians+-- Stability   : experimental+-- Portability : portable+--+-- An internal and really simple monad transformers,+-- without any bells and whistse.+module Basement.Compat.MonadTrans+    ( State(..)+    , Reader(..)+    ) where++import Basement.Compat.Base+import Control.Monad ((>=>))++-- | Simple State monad+newtype State s m a = State { runState :: s -> m (a, s) }++instance Monad m => Functor (State s m) where+    fmap f fa = State $ runState fa >=> (\(a, s2) -> return (f a, s2))+instance Monad m => Applicative (State s m) where+    pure a = State $ \st -> return (a,st)+    fab <*> fa = State $ \s1 -> do+        (ab,s2) <- runState fab s1+        (a,s3)  <- runState fa s2+        return (ab a, s3)+instance Monad m => Monad (State r m) where+    return a = State $ \st -> return (a,st)+    ma >>= mb = State $ \s1 -> do+        (a,s2) <- runState ma s1+        runState (mb a) s2++-- | Simple Reader monad+newtype Reader r m a = Reader { runReader :: r -> m a }++instance Monad m => Functor (Reader r m) where+    fmap f fa = Reader $ runReader fa >=> (\a -> return (f a))+instance Monad m => Applicative (Reader r m) where+    pure a = Reader $ \_ -> return a+    fab <*> fa = Reader $ \r -> do+        a  <- runReader fa r+        ab <- runReader fab r+        return $ ab a+instance Monad m => Monad (Reader r m) where+    return a = Reader $ \_ -> return a+    ma >>= mb = Reader $ \r -> do+        a <- runReader ma r+        runReader (mb a) r
+ Basement/Compat/Natural.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Basement.Compat.Natural+    ( Natural+    , integerToNatural+    ) where++#if MIN_VERSION_base(4,8,0)++import Numeric.Natural+import Prelude (Integer, abs, fromInteger)++#else++import Prelude (Show(..),Eq,Ord,Enum,Num(..),Real(..),Integral(..),Integer,error,(<), (>), otherwise)+import Data.Typeable++newtype Natural = Natural Integer+    deriving (Eq,Ord,Enum,Typeable)++instance Show Natural where+    show (Natural i) = show i++-- re-create the buggy Num instance for Natural+instance Num Natural where+    fromInteger n+        | n < 0     = error "natural should be positive: "+        | otherwise = Natural n+    (+) (Natural a) (Natural b) = Natural (a + b)+    (-) (Natural a) (Natural b)+        | r < 0     = error "natural should be positve"+        | otherwise = Natural (a - b)+      where r = (a - b)+    (*) (Natural a) (Natural b) = Natural (a * b)+    abs n = n+    negate n = n+    signum (Natural n)+        | n > 0     = 1+        | otherwise = 0++instance Real Natural where+    toRational (Natural n) = toRational n++instance Integral Natural where+    toInteger (Natural n) = n+    divMod (Natural n) (Natural e) = let (a,b) = n `quotRem` e in (Natural a, Natural b)+    quotRem (Natural n) (Natural e) = let (a,b) = n `quotRem` e in (Natural a, Natural b)+    quot (Natural n) (Natural e) = Natural (n `quot` e)+    rem (Natural n) (Natural e) = Natural (n `rem` e)+    div = quot+    mod = rem++#endif++integerToNatural :: Integer -> Natural+integerToNatural i = fromInteger (abs i)
+ Basement/Compat/NumLiteral.hs view
@@ -0,0 +1,127 @@+-- |+-- Module      : Basement.Compat.NumLiteral+-- License     : BSD-style+-- Maintainer  : Foundation+--+-- Literal support for Integral and Fractional+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+module Basement.Compat.NumLiteral+    ( Integral(..)+    , Fractional(..)+    , HasNegation(..)+    ) where++import           Prelude (Int, Integer, Rational, Float, Double)+import           Data.Word (Word8, Word16, Word32, Word64, Word)+import           Data.Int (Int8, Int16, Int32, Int64)+import qualified Prelude+import           Basement.Compat.Natural+import           Foreign.C.Types+import           System.Posix.Types++-- | Integral Literal support+--+-- e.g. 123 :: Integer+--      123 :: Word8+class Integral a where+    fromInteger :: Integer -> a++-- | Fractional Literal support+--+-- e.g. 1.2  :: Double+--      0.03 :: Float+class Fractional a where+    fromRational :: Rational -> a++-- | Negation support+--+-- e.g. -(f x)+class HasNegation a where+    negate :: a -> a++instance Integral Integer where+    fromInteger a = a+instance Integral Natural where+    fromInteger a = Prelude.fromInteger a+instance Integral Int where+    fromInteger a = Prelude.fromInteger a+instance Integral Word where+    fromInteger a = Prelude.fromInteger a+instance Integral Word8 where+    fromInteger a = Prelude.fromInteger a+instance Integral Word16 where+    fromInteger a = Prelude.fromInteger a+instance Integral Word32 where+    fromInteger a = Prelude.fromInteger a+instance Integral Word64 where+    fromInteger a = Prelude.fromInteger a+instance Integral Int8 where+    fromInteger a = Prelude.fromInteger a+instance Integral Int16 where+    fromInteger a = Prelude.fromInteger a+instance Integral Int32 where+    fromInteger a = Prelude.fromInteger a+instance Integral Int64 where+    fromInteger a = Prelude.fromInteger a+instance Integral CSize where+    fromInteger a = Prelude.fromInteger a+instance Integral CInt where+    fromInteger a = Prelude.fromInteger a+instance Integral COff where+    fromInteger a = Prelude.fromInteger a+instance Integral CUIntPtr where+    fromInteger a = Prelude.fromInteger a++instance Integral Float where+    fromInteger a = Prelude.fromInteger a+instance Integral Double where+    fromInteger a = Prelude.fromInteger a+instance Integral CFloat where+    fromInteger a = Prelude.fromInteger a+instance Integral CDouble where+    fromInteger a = Prelude.fromInteger a++instance HasNegation Integer where+    negate = Prelude.negate+instance HasNegation Int where+    negate = Prelude.negate+instance HasNegation Int8 where+    negate = Prelude.negate+instance HasNegation Int16 where+    negate = Prelude.negate+instance HasNegation Int32 where+    negate = Prelude.negate+instance HasNegation Int64 where+    negate = Prelude.negate+instance HasNegation Word where+    negate = Prelude.negate+instance HasNegation Word8 where+    negate = Prelude.negate+instance HasNegation Word16 where+    negate = Prelude.negate+instance HasNegation Word32 where+    negate = Prelude.negate+instance HasNegation Word64 where+    negate = Prelude.negate+instance HasNegation CInt where+    negate = Prelude.negate+instance HasNegation Float where+    negate = Prelude.negate+instance HasNegation Double where+    negate = Prelude.negate+instance HasNegation CFloat where+    negate = Prelude.negate+instance HasNegation CDouble where+    negate = Prelude.negate++instance Fractional Rational where+    fromRational a = Prelude.fromRational a+instance Fractional Float where+    fromRational a = Prelude.fromRational a+instance Fractional Double where+    fromRational a = Prelude.fromRational a+instance Fractional CFloat where+    fromRational a = Prelude.fromRational a+instance Fractional CDouble where+    fromRational a = Prelude.fromRational a
+ Basement/Compat/PrimTypes.hs view
@@ -0,0 +1,36 @@+-- |+-- Module      : Basement.Compat.PrimTypes+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : portable+--+{-# LANGUAGE MagicHash #-}+module Basement.Compat.PrimTypes+    ( FileSize#+    , Offset#+    , CountOf#+    , Bool#+    , Pinned#+    ) where++import GHC.Prim++-- | File size in bytes+type FileSize# = Word64#++-- | Offset in a bytearray, string, type alias+--+-- for code documentation purpose only, just a simple type alias on Int#+type Offset# = Int#++-- | CountOf in bytes type alias+--+-- for code documentation purpose only, just a simple type alias on Int#+type CountOf# = Int#++-- | Lowlevel Boolean+type Bool# = Int#++-- | Pinning status+type Pinned# = Bool#
+ Basement/Compat/Primitive.hs view
@@ -0,0 +1,175 @@+-- |+-- Module      : Basement.Compat.Primitive+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : portable+--+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE UnliftedFFITypes #-}+module Basement.Compat.Primitive+    ( bool#+    , PinnedStatus(..), toPinnedStatus#+    , compatAndI#+    , compatQuotRemInt#+    , compatCopyAddrToByteArray#+    , compatCopyByteArrayToAddr#+    , compatMkWeak#+    , compatGetSizeofMutableByteArray#+    , compatShrinkMutableByteArray#+    , compatResizeMutableByteArray#+    , compatIsByteArrayPinned#+    , compatIsMutableByteArrayPinned#+    , Word(..)+    ) where++import qualified Prelude+import           GHC.Prim+import           GHC.Word+#if __GLASGOW_HASKELL__ >= 800+import           GHC.IO+#endif++import           Basement.Compat.PrimTypes++--  GHC 8.0  | Base 4.9+--  GHC 7.10 | Base 4.8+--  GHC 7.8  | Base 4.7+--  GHC 7.6  | Base 4.6+--  GHC 7.4  | Base 4.5++-- | Flag record whether a specific byte array is pinned or not+data PinnedStatus = Pinned | Unpinned+    deriving (Prelude.Eq)++toPinnedStatus# :: Pinned# -> PinnedStatus+toPinnedStatus# 0# = Unpinned+toPinnedStatus# _  = Pinned++-- | turn an Int# into a Bool+--+-- Since GHC 7.8, boolean primitive don't return Bool but Int#.+#if MIN_VERSION_base(4,7,0)+bool# :: Int# -> Prelude.Bool+bool# v = tagToEnum# v+#else+bool# :: Prelude.Bool -> Prelude.Bool+bool# v = v+#endif+{-# INLINE bool# #-}++-- | A version friendly of andI#+compatAndI# :: Int# -> Int# -> Int#+#if !MIN_VERSION_base(4,7,0)+compatAndI# a b = word2Int# (and# (int2Word# a) (int2Word# b))+#else+compatAndI# = andI#+#endif+{-# INLINE compatAndI# #-}++-- | A version friendly of quotRemInt#+compatQuotRemInt# :: Int# -> Int# -> (# Int#, Int# #)+compatQuotRemInt# = quotRemInt#+{-# INLINE compatQuotRemInt# #-}++-- | A version friendly fo copyAddrToByteArray#+--+-- only available from GHC 7.8+compatCopyAddrToByteArray# :: Addr# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+#if MIN_VERSION_base(4,7,0)+compatCopyAddrToByteArray# = copyAddrToByteArray#+#else+compatCopyAddrToByteArray# addr ba ofs sz stini =+    loop ofs 0# stini+  where+    loop o i st+        | bool# (i ==# sz)  = st+        | Prelude.otherwise =+            case readWord8OffAddr# addr i st of+                (# st2, w #) -> loop (o +# 1#) (i +# 1#) (writeWord8Array# ba o w st2)+#endif+{-# INLINE compatCopyAddrToByteArray# #-}++-- | A version friendly fo copyByteArrayToAddr#+--+-- only available from GHC 7.8+compatCopyByteArrayToAddr# :: ByteArray# -> Int# -> Addr# -> Int# -> State# s -> State# s+#if MIN_VERSION_base(4,7,0)+compatCopyByteArrayToAddr# = copyByteArrayToAddr#+#else+compatCopyByteArrayToAddr# ba ofs addr sz stini =+    loop ofs 0# stini+  where+    loop o i st+        | bool# (i ==# sz)  = st+        | Prelude.otherwise =+            loop (o +# 1#) (i +# 1#) (writeWord8OffAddr# addr i (indexWord8Array# ba o) st)+#endif+{-# INLINE compatCopyByteArrayToAddr# #-}++-- | A mkWeak# version that keep working on 8.0+--+-- signature change in ghc-prim:+-- * 0.4: mkWeak# :: o -> b -> c                                             -> State# RealWorld -> (#State# RealWorld, Weak# b#)+-- * 0.5 :mkWeak# :: o -> b -> (State# RealWorld -> (#State# RealWorld, c#)) -> State# RealWorld -> (#State# RealWorld, Weak# b#)+--+compatMkWeak# :: o -> b -> Prelude.IO () -> State# RealWorld -> (#State# RealWorld, Weak# b #)+#if __GLASGOW_HASKELL__ >= 800+compatMkWeak# o b c s = mkWeak# o b (case c of { IO f -> f }) s+#else+compatMkWeak# o b c s = mkWeak# o b c s+#endif+{-# INLINE compatMkWeak# #-}++compatGetSizeofMutableByteArray# :: MutableByteArray# s -> State# s -> (#State# s, Int# #)+#if __GLASGOW_HASKELL__ >= 800+compatGetSizeofMutableByteArray# mba s = getSizeofMutableByteArray# mba s+#else+compatGetSizeofMutableByteArray# mba s = (# s, sizeofMutableByteArray# mba #)+#endif+{-# INLINE compatGetSizeofMutableByteArray# #-}++compatShrinkMutableByteArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, MutableByteArray# s #)+#if __GLASGOW_HASKELL__ >= 800+compatShrinkMutableByteArray# mba i s =+    case shrinkMutableByteArray# mba i s of { s2 -> (# s2, mba #) }+#else+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 #) }}+#endif+{-# INLINE compatShrinkMutableByteArray# #-}++--shrinkMutableByteArray# :: MutableByteArray# s -> Int# -> State# s -> State# s+compatResizeMutableByteArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, MutableByteArray# s #)+#if __GLASGOW_HASKELL__ >= 800+compatResizeMutableByteArray# mba i s = resizeMutableByteArray# mba i s+#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 #) }}+  where+    isGrow = bool# (i ># len)+    nbBytes+        | isGrow            = len+        | Prelude.otherwise = i+    !len = sizeofMutableByteArray# src+#endif+{-# INLINE compatResizeMutableByteArray# #-}++#if __GLASGOW_HASKELL__ >= 802+compatIsByteArrayPinned# :: ByteArray# -> Pinned#+compatIsByteArrayPinned# ba = isByteArrayPinned# ba++compatIsMutableByteArrayPinned# :: MutableByteArray# s -> Pinned#+compatIsMutableByteArrayPinned# ba = isMutableByteArrayPinned# ba+#else+foreign import ccall unsafe "foundation_is_bytearray_pinned"+    compatIsByteArrayPinned# :: ByteArray# -> Pinned#++foreign import ccall unsafe "foundation_is_bytearray_pinned"+    compatIsMutableByteArrayPinned# :: MutableByteArray# s -> Pinned#+#endif
+ Basement/Compat/Typeable.hs view
@@ -0,0 +1,37 @@+-- |+-- Module      : Basement.Compat.Typeable+-- License     : BSD-style+-- Maintainer  : Nicolas Di Prima <nicolas@primetype.co.uk>+-- Stability   : statble+-- Portability : portable+--+-- conveniently provide support for legacy and modern base+--++{-# LANGUAGE CPP #-}++module Basement.Compat.Typeable+    (+#if MIN_VERSION_base(4,7,0)+      Typeable+#else+      Typeable(..)+    , typeRep+#endif+    ) where++#if !MIN_VERSION_base(4,7,0)+import Data.Proxy (Proxy(..))+import qualified Prelude (undefined)+#endif+import Data.Typeable++#if !MIN_VERSION_base(4,7,0)+-- this function does not exist prior base 4.7+typeRep :: Typeable a => Proxy a -> TypeRep+typeRep = typeRep' Prelude.undefined+  where+    typeRep' :: Typeable a => a -> Proxy a -> TypeRep+    typeRep' a _ = typeOf a+    {-# INLINE typeRep' #-}+#endif
+ Basement/Endianness.hs view
@@ -0,0 +1,141 @@+-- |+-- Module      : Basement.Endianness+-- License     : BSD-style+-- Maintainer  : Haskell Foundation+-- Stability   : experimental+-- Portability : portable+--+-- Set endianness tag to a given primitive. This will help for serialising+-- data for protocols (such as the network protocols).+--++{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Basement.Endianness+    (+      ByteSwap+      -- * Big Endian+    , BE(..), toBE, fromBE+      -- * Little Endian+    , LE(..), toLE, fromLE+      -- * System Endianness+    , Endianness(..)+    , endianness+    ) where++import Basement.Compat.Base+import Data.Word (byteSwap16, byteSwap32, byteSwap64)++#if defined(ARCH_IS_LITTLE_ENDIAN) || defined(ARCH_IS_BIG_ENDIAN)+#else+import Foreign.Marshal.Alloc (alloca)+import Foreign.Ptr (castPtr)+import Foreign.Storable (poke, peek)+import Data.Word (Word8, Word32)+import System.IO.Unsafe (unsafePerformIO)+#endif++import Data.Bits+++-- #if !defined(ARCH_IS_LITTLE_ENDIAN) && !defined(ARCH_IS_BIG_ENDIAN)+-- import Foundation.System.Info (endianness, Endianness(..))+-- #endif++data Endianness =+      LittleEndian+    | BigEndian+    deriving (Eq, Show)++-- | Little Endian value+newtype LE a = LE { unLE :: a }+  deriving (Show, Eq, Typeable, Bits)+instance (ByteSwap a, Ord a) => Ord (LE a) where+    compare e1 e2 = compare (fromLE e1) (fromLE e2)++-- | Big Endian value+newtype BE a = BE { unBE :: a }+  deriving (Show, Eq, Typeable, Bits)+instance (ByteSwap a, Ord a) => Ord (BE a) where+    compare e1 e2 = compare (fromBE e1) (fromBE e2)++-- | Convert a value in cpu endianess to big endian+toBE :: ByteSwap a => a -> BE a+#ifdef ARCH_IS_LITTLE_ENDIAN+toBE = BE . byteSwap+#elif ARCH_IS_BIG_ENDIAN+toBE = BE+#else+toBE = BE . (if endianness == LittleEndian then byteSwap else id)+#endif+{-# INLINE toBE #-}++-- | Convert from a big endian value to the cpu endianness+fromBE :: ByteSwap a => BE a -> a+#ifdef ARCH_IS_LITTLE_ENDIAN+fromBE (BE a) = byteSwap a+#elif ARCH_IS_BIG_ENDIAN+fromBE (BE a) = a+#else+fromBE (BE a) = if endianness == LittleEndian then byteSwap a else a+#endif+{-# INLINE fromBE #-}++-- | Convert a value in cpu endianess to little endian+toLE :: ByteSwap a => a -> LE a+#ifdef ARCH_IS_LITTLE_ENDIAN+toLE = LE+#elif ARCH_IS_BIG_ENDIAN+toLE = LE . byteSwap+#else+toLE = LE . (if endianness == LittleEndian then id else byteSwap)+#endif+{-# INLINE toLE #-}++-- | Convert from a little endian value to the cpu endianness+fromLE :: ByteSwap a => LE a -> a+#ifdef ARCH_IS_LITTLE_ENDIAN+fromLE (LE a) = a+#elif ARCH_IS_BIG_ENDIAN+fromLE (LE a) = byteSwap a+#else+fromLE (LE a) = if endianness == LittleEndian then a else byteSwap a+#endif+{-# INLINE fromLE #-}++-- | endianness of the current architecture+endianness :: Endianness+#ifdef ARCH_IS_LITTLE_ENDIAN+endianness = LittleEndian+#elif ARCH_IS_BIG_ENDIAN+endianness = BigEndian+#else+-- ! ARCH_IS_UNKNOWN_ENDIAN+endianness = unsafePerformIO $ bytesToEndianness <$> word32ToByte input+  where+    input :: Word32+    input = 0x01020304+{-# NOINLINE endianness #-}++word32ToByte :: Word32 -> IO Word8+word32ToByte word = alloca $ \wordPtr -> do+         poke wordPtr word+         peek (castPtr wordPtr)++bytesToEndianness :: Word8 -> Endianness+bytesToEndianness 1 = BigEndian+bytesToEndianness _ = LittleEndian+#endif++-- | Class of types that can be byte-swapped.+--+-- e.g. Word16, Word32, Word64+class ByteSwap a where+    byteSwap :: a -> a+instance ByteSwap Word16 where+    byteSwap = byteSwap16+instance ByteSwap Word32 where+    byteSwap = byteSwap32+instance ByteSwap Word64 where+    byteSwap = byteSwap64
+ Basement/Environment.hs view
@@ -0,0 +1,16 @@+module Basement.Environment+    ( getArgs+    , lookupEnv+    ) where++import           Basement.Compat.Base+import           Basement.UTF8.Base (String)+import qualified System.Environment as Sys (getArgs, lookupEnv)++-- | Returns a list of the program's command line arguments (not including the program name).+getArgs :: IO [String]+getArgs = fmap fromList <$> Sys.getArgs++-- | Lookup variable in the environment+lookupEnv :: String -> IO (Maybe String)+lookupEnv s = fmap fromList <$> Sys.lookupEnv (toList s)
+ Basement/Error.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE CPP #-}+module Basement.Error+    ( error+    ) where++import           GHC.Prim+import           Basement.UTF8.Base+import           Basement.Compat.CallStack++#if MIN_VERSION_base(4,9,0)++import           GHC.Types (RuntimeRep)+import           GHC.Exception (errorCallWithCallStackException)++-- | stop execution and displays an error message+error :: forall (r :: RuntimeRep) . forall (a :: TYPE r) . HasCallStack => String -> a+error s = raise# (errorCallWithCallStackException (sToList s) ?callstack)++#elif MIN_VERSION_base(4,7,0)++import           GHC.Exception (errorCallException)++error :: String -> a+error s = raise# (errorCallException (sToList s))++#else++import           GHC.Types+import           GHC.Exception++error :: String -> a+error s = throw (ErrorCall (sToList s))++#endif
+ Basement/Exception.hs view
@@ -0,0 +1,69 @@+-- |+-- Module      : Basement.Exception+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : portable+--+-- Common part for vectors+--+{-# LANGUAGE DeriveDataTypeable #-}+module Basement.Exception+    ( OutOfBound(..)+    , OutOfBoundOperation(..)+    , isOutOfBound+    , outOfBound+    , primOutOfBound+    , InvalidRecast(..)+    , RecastSourceSize(..)+    , RecastDestinationSize(..)+    , NonEmptyCollectionIsEmpty(..)+    ) where++import           Basement.Compat.Base+import           Basement.Types.OffsetSize+import           Basement.Monad++-- | The type of operation that triggers an OutOfBound exception.+--+-- * OOB_Index: reading an immutable vector+-- * OOB_Read: reading a mutable vector+-- * OOB_Write: write a mutable vector+data OutOfBoundOperation = OOB_Read | OOB_Write | OOB_MemSet | OOB_MemCopy | OOB_Index+    deriving (Show,Eq,Typeable)++-- | Exception during an operation accessing the vector out of bound+--+-- Represent the type of operation, the index accessed, and the total length of the vector.+data OutOfBound = OutOfBound OutOfBoundOperation Int Int+    deriving (Show,Typeable)++instance Exception OutOfBound++outOfBound :: OutOfBoundOperation -> Offset ty -> CountOf ty -> a+outOfBound oobop (Offset ofs) (CountOf sz) = throw (OutOfBound oobop ofs sz)+{-# INLINE outOfBound #-}++primOutOfBound :: PrimMonad prim => OutOfBoundOperation -> Offset ty -> CountOf ty -> prim a+primOutOfBound oobop (Offset ofs) (CountOf sz) = primThrow (OutOfBound oobop ofs sz)+{-# INLINE primOutOfBound #-}++isOutOfBound :: Offset ty -> CountOf ty -> Bool+isOutOfBound (Offset ty) (CountOf sz) = ty < 0 || ty >= sz+{-# INLINE isOutOfBound #-}++newtype RecastSourceSize      = RecastSourceSize Int+    deriving (Show,Eq,Typeable)+newtype RecastDestinationSize = RecastDestinationSize Int+    deriving (Show,Eq,Typeable)++data InvalidRecast = InvalidRecast RecastSourceSize RecastDestinationSize+    deriving (Show,Typeable)++instance Exception InvalidRecast++-- | Exception for using NonEmpty assertion with an empty collection+data NonEmptyCollectionIsEmpty = NonEmptyCollectionIsEmpty+    deriving (Show,Typeable)++instance Exception NonEmptyCollectionIsEmpty
+ Basement/FinalPtr.hs view
@@ -0,0 +1,112 @@+-- |+-- Module      : Basement.FinalPtr+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : portable+--+-- A smaller ForeignPtr reimplementation that work in any prim monad.+--+-- Here be dragon.+--+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE CPP #-}+module Basement.FinalPtr+    ( FinalPtr(..)+    , finalPtrSameMemory+    , castFinalPtr+    , toFinalPtr+    , toFinalPtrForeign+    , touchFinalPtr+    , withFinalPtr+    , withUnsafeFinalPtr+    , withFinalPtrNoTouch+    ) where++import GHC.Ptr+import GHC.ForeignPtr+import GHC.IO+import Basement.Monad+import Basement.Compat.Primitive+import Basement.Compat.Base++import Control.Monad.ST (runST)++-- | Create a pointer with an associated finalizer+data FinalPtr a = FinalPtr (Ptr a)+                | FinalForeign (ForeignPtr a)+instance Show (FinalPtr a) where+    show f = runST $ withFinalPtr f (pure . show)+instance Eq (FinalPtr a) where+    (==) f1 f2 = runST (equal f1 f2)+instance Ord (FinalPtr a) where+    compare f1 f2 = runST (compare_ f1 f2)++-- | Check if 2 final ptr points on the same memory bits+--+-- it stand to reason that provided a final ptr that is still being referenced+-- and thus have the memory still valid, if 2 final ptrs have the+-- same address, they should be the same final ptr+finalPtrSameMemory :: FinalPtr a -> FinalPtr b -> Bool+finalPtrSameMemory (FinalPtr p1)     (FinalPtr p2)     = p1 == castPtr p2+finalPtrSameMemory (FinalForeign p1) (FinalForeign p2) = p1 == castForeignPtr p2+finalPtrSameMemory (FinalForeign _)  (FinalPtr _)      = False+finalPtrSameMemory (FinalPtr _)      (FinalForeign _)  = False++-- | create a new FinalPtr from a Pointer+toFinalPtr :: PrimMonad prim => Ptr a -> (Ptr a -> IO ()) -> prim (FinalPtr a)+toFinalPtr ptr finalizer = unsafePrimFromIO (primitive makeWithFinalizer)+  where+    makeWithFinalizer s =+        case compatMkWeak# ptr () (finalizer ptr) s of { (# s2, _ #) -> (# s2, FinalPtr ptr #) }++-- | Create a new FinalPtr from a ForeignPtr+toFinalPtrForeign :: ForeignPtr a -> FinalPtr a+toFinalPtrForeign fptr = FinalForeign fptr++-- | Cast a finalized pointer from type a to type b+castFinalPtr :: FinalPtr a -> FinalPtr b+castFinalPtr (FinalPtr a)     = FinalPtr (castPtr a)+castFinalPtr (FinalForeign a) = FinalForeign (castForeignPtr a)++withFinalPtrNoTouch :: FinalPtr p -> (Ptr p -> a) -> a+withFinalPtrNoTouch (FinalPtr ptr) f = f ptr+withFinalPtrNoTouch (FinalForeign fptr) f = f (unsafeForeignPtrToPtr fptr)+{-# INLINE withFinalPtrNoTouch #-}++-- | Looks at the raw pointer inside a FinalPtr, making sure the+-- data pointed by the pointer is not finalized during the call to 'f'+withFinalPtr :: PrimMonad prim => FinalPtr p -> (Ptr p -> prim a) -> prim a+withFinalPtr (FinalPtr ptr) f = do+    r <- f ptr+    primTouch ptr+    pure r+withFinalPtr (FinalForeign fptr) f = do+    r <- f (unsafeForeignPtrToPtr fptr)+    unsafePrimFromIO (touchForeignPtr fptr)+    pure r+{-# INLINE withFinalPtr #-}++touchFinalPtr :: PrimMonad prim => FinalPtr p -> prim ()+touchFinalPtr (FinalPtr ptr) = primTouch ptr+touchFinalPtr (FinalForeign fptr) = unsafePrimFromIO (touchForeignPtr fptr)++-- | Unsafe version of 'withFinalPtr'+withUnsafeFinalPtr :: PrimMonad prim => FinalPtr p -> (Ptr p -> prim a) -> a+withUnsafeFinalPtr fptr f = unsafePerformIO (unsafePrimToIO (withFinalPtr fptr f))+{-# NOINLINE withUnsafeFinalPtr #-}++equal :: PrimMonad prim => FinalPtr a -> FinalPtr a -> prim Bool+equal f1 f2 =+    withFinalPtr f1 $ \ptr1 ->+    withFinalPtr f2 $ \ptr2 ->+        pure $ ptr1 == ptr2+{-# INLINE equal #-}++compare_ :: PrimMonad prim => FinalPtr a -> FinalPtr a -> prim Ordering+compare_ f1 f2 =+    withFinalPtr f1 $ \ptr1 ->+    withFinalPtr f2 $ \ptr2 ->+        pure $ ptr1 `compare` ptr2+{-# INLINE compare_ #-}
+ Basement/Floating.hs view
@@ -0,0 +1,29 @@+module Basement.Floating+    ( integerToDouble+    , naturalToDouble+    , doubleExponant+    , integerToFloat+    , naturalToFloat+    ) where++import           GHC.Types+import           Basement.Compat.Base+import           Basement.Compat.Natural+import qualified Prelude (fromInteger, toInteger, (^^))++integerToDouble :: Integer -> Double+integerToDouble = Prelude.fromInteger+-- this depends on integer-gmp+--integerToDouble i = D# (doubleFromInteger i)++naturalToDouble :: Natural -> Double+naturalToDouble = integerToDouble . Prelude.toInteger++doubleExponant :: Double -> Int -> Double+doubleExponant = (Prelude.^^)++integerToFloat :: Integer -> Float+integerToFloat = Prelude.fromInteger++naturalToFloat :: Natural -> Float+naturalToFloat = integerToFloat . Prelude.toInteger
+ Basement/From.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE ConstraintKinds       #-}+module Basement.From+    ( From(..)+    , Into+    , TryFrom(..)+    , TryInto+    , into+    , tryInto+    ) where++import Basement.Compat.Base+import Basement.IntegralConv++-- | Class of things that can be converted from a to b+class From a b where+    from :: a -> b++type Into b a = From a b++-- | Same as from but reverse the type variable so that the destination type can be specified first+--+-- e.g. converting:+--+-- from @_ @Word (10 :: Int)+--+-- into @Word (10 :: Int)+--+into :: Into b a => a -> b+into = from++-- | Class of things that can mostly be converted from a to b, but with possible error cases.+class TryFrom a b where+    tryFrom :: a -> Maybe b++type TryInto b a = TryFrom a b++-- | same as tryFrom but reversed+tryInto :: TryInto b a => a -> Maybe b+tryInto = tryFrom++instance From a a where+    from = id++instance From Int Word where+    from = integralCast+instance From Word Int where+    from = integralCast
+ Basement/Imports.hs view
@@ -0,0 +1,114 @@+-- |+-- Module      : Basement.Imports+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : portable+--+-- re-export of all the base prelude and basic primitive stuffs+module Basement.Imports+    ( (Prelude.$)+    , (Prelude.$!)+    , (Prelude.&&)+    , (Prelude.||)+    , (Control.Category..)+    , (Control.Applicative.<$>)+    , Prelude.not+    , Prelude.otherwise+    , Prelude.fst+    , Prelude.snd+    , Control.Category.id+    , Prelude.maybe+    , Prelude.either+    , Prelude.flip+    , Prelude.const+    , Basement.Error.error+    , Prelude.and+    , Prelude.undefined+    , Prelude.seq+    , Prelude.Show+    , Basement.Show.show+    , Prelude.Ord (..)+    , Prelude.Eq (..)+    , Prelude.Bounded (..)+    , Prelude.Enum (..)+    , Prelude.Functor (..)+    , Control.Applicative.Applicative (..)+    , Prelude.Monad (..)+    , Prelude.Maybe (..)+    , Prelude.Ordering (..)+    , Prelude.Bool (..)+    , Prelude.Int+    , Prelude.Integer+    , Basement.Compat.Natural.Natural+    , Basement.Types.OffsetSize.Offset+    , Basement.Types.OffsetSize.CountOf+    , Prelude.Char+    , Basement.PrimType.PrimType+    , Basement.Types.Char7.Char7+    , Basement.Types.AsciiString.AsciiString+    , Basement.UTF8.Base.String+    , Basement.UArray.UArray+    , Basement.BoxedArray.Array+    , Basement.Compat.NumLiteral.Integral (..)+    , Basement.Compat.NumLiteral.Fractional (..)+    , Basement.Compat.NumLiteral.HasNegation (..)+    , Data.Int.Int8, Data.Int.Int16, Data.Int.Int32, Data.Int.Int64+    , Data.Word.Word8, Data.Word.Word16, Data.Word.Word32, Data.Word.Word64, Data.Word.Word+    , Prelude.Double, Prelude.Float+    , Prelude.IO+    , FP32+    , FP64+    , Basement.Compat.IsList.IsList (..)+    , GHC.Exts.IsString (..)+    , GHC.Generics.Generic (..)+    , Prelude.Either (..)+    , Data.Data.Data (..)+    , Data.Data.mkNoRepType+    , Data.Data.DataType+    , Data.Typeable.Typeable+    , Data.Monoid.Monoid (..)+    , (Data.Monoid.<>)+    , Control.Exception.Exception+    , Control.Exception.throw+    , Control.Exception.throwIO+    , GHC.Ptr.Ptr(..)+    , ifThenElse+    ) where++import qualified Prelude+import qualified Control.Category+import qualified Control.Applicative+import qualified Control.Exception+import qualified Data.Monoid+import qualified Data.Data+import qualified Data.Typeable+import qualified Data.Word+import qualified Data.Int+import qualified Basement.Compat.IsList+import qualified Basement.Compat.Natural+import qualified Basement.Compat.NumLiteral+import qualified Basement.UArray+import qualified Basement.BoxedArray+import qualified Basement.UTF8.Base+import qualified Basement.Error+import qualified Basement.Show+import qualified Basement.PrimType+import qualified Basement.Types.OffsetSize+import qualified Basement.Types.AsciiString+import qualified Basement.Types.Char7+import qualified GHC.Exts+import qualified GHC.Generics+import qualified GHC.Ptr+import           GHC.Exts (fromString)++-- | for support of if .. then .. else+ifThenElse :: Prelude.Bool -> a -> a -> a+ifThenElse Prelude.True  e1 _  = e1+ifThenElse Prelude.False _  e2 = e2++-- | IEEE754 Floating point Binary32, simple precision (Also known as Float)+type FP32 = Prelude.Float++-- | IEEE754 Floating point Binary64, double precision (Also known as Double)+type FP64 = Prelude.Double
+ Basement/IntegralConv.hs view
@@ -0,0 +1,340 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE MagicHash             #-}+{-# LANGUAGE DefaultSignatures     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE UnboxedTuples         #-}+module Basement.IntegralConv+    ( IntegralDownsize(..)+    , IntegralUpsize(..)+    , IntegralCast(..)+    , intToInt64+    , int64ToInt+    , wordToWord64+    , word64ToWord32s+    , word64ToWord+    , wordToChar+    , wordToInt+    , charToInt+    ) where++#include "MachDeps.h"++import GHC.Types+import GHC.Prim+import GHC.Int+import GHC.Word+import Prelude (Integer, fromIntegral)+import Basement.Compat.Base+import Basement.Compat.Natural++#if WORD_SIZE_IN_BITS < 64+import GHC.IntWord64+#endif++-- | Downsize an integral value+class IntegralDownsize a b where+    integralDownsize :: a -> b+    default integralDownsize :: a ~ b => a -> b+    integralDownsize = id++    integralDownsizeCheck :: a -> Maybe b++-- | Upsize an integral value+--+-- The destination type 'b' size need to be greater or equal+-- than the size type of 'a'+class IntegralUpsize a b where+    integralUpsize      :: a -> b++-- | Cast an integral value to another value+-- that have the same representional size+class IntegralCast a b where+    integralCast :: a -> b+    default integralCast :: a ~ b => a -> b+    integralCast = id++integralDownsizeBounded :: forall a b . (Ord a, Bounded b, IntegralDownsize a b, IntegralUpsize b a)+                        => (a -> b)+                        -> a+                        -> Maybe b+integralDownsizeBounded aToB x+    | x < integralUpsize (minBound :: b) && x > integralUpsize (maxBound :: b) = Nothing+    | otherwise                                                                = Just (aToB x)++instance IntegralUpsize Int8 Int16 where+    integralUpsize (I8# i) = I16# i+instance IntegralUpsize Int8 Int32 where+    integralUpsize (I8# i) = I32# i+instance IntegralUpsize Int8 Int64 where+    integralUpsize (I8# i) = intToInt64 (I# i)+instance IntegralUpsize Int8 Int where+    integralUpsize (I8# i) = I# i+instance IntegralUpsize Int8 Integer where+    integralUpsize = fromIntegral++instance IntegralUpsize Int16 Int32 where+    integralUpsize (I16# i) = I32# i+instance IntegralUpsize Int16 Int64 where+    integralUpsize (I16# i) = intToInt64 (I# i)+instance IntegralUpsize Int16 Int where+    integralUpsize (I16# i) = I# i+instance IntegralUpsize Int16 Integer where+    integralUpsize = fromIntegral++instance IntegralUpsize Int32 Int64 where+    integralUpsize (I32# i) = intToInt64 (I# i)+instance IntegralUpsize Int32 Int where+    integralUpsize (I32# i) = I# i+instance IntegralUpsize Int32 Integer where+    integralUpsize = fromIntegral++instance IntegralUpsize Int Integer where+    integralUpsize = fromIntegral+instance IntegralUpsize Int Int64 where+    integralUpsize = intToInt64++instance IntegralUpsize Int64 Integer where+    integralUpsize = fromIntegral++instance IntegralUpsize Word8 Word16 where+    integralUpsize (W8# i) = W16# i+instance IntegralUpsize Word8 Word32 where+    integralUpsize (W8# i) = W32# i+instance IntegralUpsize Word8 Word64 where+    integralUpsize (W8# i) = wordToWord64 (W# i)+instance IntegralUpsize Word8 Word where+    integralUpsize (W8# i) = W# i+instance IntegralUpsize Word8 Int16 where+    integralUpsize (W8# w) = I16# (word2Int# w)+instance IntegralUpsize Word8 Int32 where+    integralUpsize (W8# w) = I32# (word2Int# w)+instance IntegralUpsize Word8 Int64 where+    integralUpsize (W8# w) = intToInt64 (I# (word2Int# w))+instance IntegralUpsize Word8 Int where+    integralUpsize (W8# w) = I# (word2Int# w)+instance IntegralUpsize Word8 Integer where+    integralUpsize = fromIntegral+instance IntegralUpsize Word8 Natural where+    integralUpsize = fromIntegral++instance IntegralUpsize Word16 Word32 where+    integralUpsize (W16# i) = W32# i+instance IntegralUpsize Word16 Word64 where+    integralUpsize (W16# i) = wordToWord64 (W# i)+instance IntegralUpsize Word16 Word where+    integralUpsize (W16# i) = W# i+instance IntegralUpsize Word16 Integer where+    integralUpsize = fromIntegral+instance IntegralUpsize Word16 Natural where+    integralUpsize = fromIntegral++instance IntegralUpsize Word32 Word64 where+    integralUpsize (W32# i) = wordToWord64 (W# i)+instance IntegralUpsize Word32 Word where+    integralUpsize (W32# i) = W# i+instance IntegralUpsize Word32 Integer where+    integralUpsize = fromIntegral+instance IntegralUpsize Word32 Natural where+    integralUpsize = fromIntegral++instance IntegralUpsize Word Integer where+    integralUpsize = fromIntegral+instance IntegralUpsize Word Natural where+    integralUpsize = fromIntegral+instance IntegralUpsize Word Word64 where+    integralUpsize = wordToWord64++instance IntegralUpsize Word64 Integer where+    integralUpsize = fromIntegral+instance IntegralUpsize Word64 Natural where+    integralUpsize = fromIntegral++instance IntegralUpsize Natural Integer where+    integralUpsize = fromIntegral++instance IntegralDownsize Int Int8 where+    integralDownsize      (I# i) = I8# (narrow8Int# i)+    integralDownsizeCheck = integralDownsizeBounded integralDownsize+instance IntegralDownsize Int Int16 where+    integralDownsize      (I# i) = I16# (narrow16Int# i)+    integralDownsizeCheck = integralDownsizeBounded integralDownsize+instance IntegralDownsize Int Int32 where+    integralDownsize      (I# i) = I32# (narrow32Int# i)+    integralDownsizeCheck = integralDownsizeBounded integralDownsize++instance IntegralDownsize Int64 Int8 where+    integralDownsize      i = integralDownsize (int64ToInt i)+    integralDownsizeCheck = integralDownsizeBounded integralDownsize+instance IntegralDownsize Int64 Int16 where+    integralDownsize      i = integralDownsize (int64ToInt i)+    integralDownsizeCheck = integralDownsizeBounded integralDownsize+instance IntegralDownsize Int64 Int32 where+    integralDownsize      i = integralDownsize (int64ToInt i)+    integralDownsizeCheck = integralDownsizeBounded integralDownsize+instance IntegralDownsize Int64 Int where+    integralDownsize      i = int64ToInt i+    integralDownsizeCheck = integralDownsizeBounded integralDownsize++instance IntegralDownsize Word64 Word8 where+    integralDownsize      (W64# i) = W8# (narrow8Word# (word64ToWord# i))+    integralDownsizeCheck = integralDownsizeBounded integralDownsize+instance IntegralDownsize Word64 Word16 where+    integralDownsize      (W64# i) = W16# (narrow16Word# (word64ToWord# i))+    integralDownsizeCheck = integralDownsizeBounded integralDownsize+instance IntegralDownsize Word64 Word32 where+    integralDownsize      (W64# i) = W32# (narrow32Word# (word64ToWord# i))+    integralDownsizeCheck = integralDownsizeBounded integralDownsize++instance IntegralDownsize Word Word8 where+    integralDownsize (W# w) = W8# (narrow8Word# w)+    integralDownsizeCheck = integralDownsizeBounded integralDownsize+instance IntegralDownsize Word Word16 where+    integralDownsize (W# w) = W16# (narrow16Word# w)+    integralDownsizeCheck = integralDownsizeBounded integralDownsize+instance IntegralDownsize Word Word32 where+    integralDownsize (W# w) = W32# (narrow32Word# w)+    integralDownsizeCheck = integralDownsizeBounded integralDownsize++instance IntegralDownsize Word32 Word8 where+    integralDownsize      (W32# i) = W8# (narrow8Word# i)+    integralDownsizeCheck = integralDownsizeBounded integralDownsize+instance IntegralDownsize Word32 Word16 where+    integralDownsize      (W32# i) = W16# (narrow16Word# i)+    integralDownsizeCheck = integralDownsizeBounded integralDownsize++instance IntegralDownsize Word16 Word8 where+    integralDownsize      (W16# i) = W8# (narrow8Word# i)+    integralDownsizeCheck = integralDownsizeBounded integralDownsize++instance IntegralDownsize Integer Int8 where+    integralDownsize = fromIntegral+    integralDownsizeCheck = integralDownsizeBounded integralDownsize+instance IntegralDownsize Integer Int16 where+    integralDownsize = fromIntegral+    integralDownsizeCheck = integralDownsizeBounded integralDownsize+instance IntegralDownsize Integer Int32 where+    integralDownsize = fromIntegral+    integralDownsizeCheck = integralDownsizeBounded integralDownsize+instance IntegralDownsize Integer Int64 where+    integralDownsize = fromIntegral+    integralDownsizeCheck = integralDownsizeBounded integralDownsize++instance IntegralDownsize Integer Word8 where+    integralDownsize = fromIntegral+    integralDownsizeCheck = integralDownsizeBounded integralDownsize+instance IntegralDownsize Integer Word16 where+    integralDownsize = fromIntegral+    integralDownsizeCheck = integralDownsizeBounded integralDownsize+instance IntegralDownsize Integer Word32 where+    integralDownsize = fromIntegral+    integralDownsizeCheck = integralDownsizeBounded integralDownsize+instance IntegralDownsize Integer Word64 where+    integralDownsize = fromIntegral+    integralDownsizeCheck = integralDownsizeBounded integralDownsize+instance IntegralDownsize Integer Natural where+    integralDownsize i+        | i >= 0    = fromIntegral i+        | otherwise = 0+    integralDownsizeCheck i+        | i >= 0    = Just (fromIntegral i)+        | otherwise = Nothing++instance IntegralDownsize Natural Word8 where+    integralDownsize = fromIntegral+    integralDownsizeCheck = integralDownsizeBounded integralDownsize+instance IntegralDownsize Natural Word16 where+    integralDownsize = fromIntegral+    integralDownsizeCheck = integralDownsizeBounded integralDownsize+instance IntegralDownsize Natural Word32 where+    integralDownsize = fromIntegral+    integralDownsizeCheck = integralDownsizeBounded integralDownsize+instance IntegralDownsize Natural Word64 where+    integralDownsize = fromIntegral+    integralDownsizeCheck = integralDownsizeBounded integralDownsize++instance IntegralCast Word Int where+    integralCast (W# w) = I# (word2Int# w)+instance IntegralCast Int Word where+    integralCast (I# i) = W# (int2Word# i)+instance IntegralCast Word64 Int64 where+#if WORD_SIZE_IN_BITS == 64+    integralCast (W64# i) = I64# (word2Int# i)+#else+    integralCast (W64# i) = I64# (word64ToInt64# i)+#endif+instance IntegralCast Int64 Word64 where+#if WORD_SIZE_IN_BITS == 64+    integralCast (I64# i) = W64# (int2Word# i)+#else+    integralCast (I64# i) = W64# (int64ToWord64# i)+#endif++instance IntegralCast Int8 Word8 where+    integralCast (I8# i) = W8# (narrow8Word# (int2Word# i))++instance IntegralCast Int16 Word16 where+    integralCast (I16# i) = W16# (narrow16Word# (int2Word# i))++instance IntegralCast Int32 Word32 where+    integralCast (I32# i) = W32# (narrow32Word# (int2Word# i))++instance IntegralCast Word8 Int8 where+    integralCast (W8# i) = I8# (narrow8Int# (word2Int# i))++instance IntegralCast Word16 Int16 where+    integralCast (W16# i) = I16# (narrow16Int# (word2Int# i))++instance IntegralCast Word32 Int32 where+    integralCast (W32# i) = I32# (narrow32Int# (word2Int# i))++intToInt64 :: Int -> Int64+#if WORD_SIZE_IN_BITS == 64+intToInt64 (I# i) = I64# i+#else+intToInt64 (I# i) = I64# (intToInt64# i)+#endif++int64ToInt :: Int64 -> Int+#if WORD_SIZE_IN_BITS == 64+int64ToInt (I64# i) = I# i+#else+int64ToInt (I64# i) = I# (int64ToInt# i)+#endif++wordToWord64 :: Word -> Word64+#if WORD_SIZE_IN_BITS == 64+wordToWord64 (W# i) = W64# i+#else+wordToWord64 (W# i) = W64# (wordToWord64# i)+#endif++word64ToWord :: Word64 -> Word+#if WORD_SIZE_IN_BITS == 64+word64ToWord (W64# i) = W# i+#else+word64ToWord (W64# i) = W# (word64ToWord# i)+#endif++#if WORD_SIZE_IN_BITS == 64+word64ToWord# :: Word# -> Word#+word64ToWord# i = i+{-# INLINE word64ToWord# #-}+#endif++#if WORD_SIZE_IN_BITS == 64+word64ToWord32s :: Word64 -> (# Word32, Word32 #)+word64ToWord32s (W64# w64) = (# W32# (uncheckedShiftRL# w64 32#), W32# (narrow32Word# w64) #)+#else+word64ToWord32s :: Word64 -> (# Word32, Word32 #)+word64ToWord32s (W64# w64) = (# W32# (word64ToWord# (uncheckedShiftRL64# w64 32#)), W32# (word64ToWord# w64) #)+#endif++wordToChar :: Word -> Char+wordToChar (W# word) = C# (chr# (word2Int# word))++wordToInt :: Word -> Int+wordToInt (W# word) = I# (word2Int# word)++charToInt :: Char -> Int+charToInt (C# x) = I# (ord# x)
+ Basement/Monad.hs view
@@ -0,0 +1,136 @@+-- |+-- Module      : Basement.Monad+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : portable+--+-- Allow to run operation in ST and IO, without having to+-- distinguinsh between the two. Most operations exposes+-- the bare nuts and bolts of how IO and ST actually+-- works, and relatively easy to shoot yourself in the foot+--+-- this is highly similar to the Control.Monad.Primitive+-- in the primitive package+--+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE ExistentialQuantification #-}+module Basement.Monad+    ( PrimMonad(..)+    , MonadFailure(..)+    , unPrimMonad_+    , unsafePrimCast+    , unsafePrimToST+    , unsafePrimToIO+    , unsafePrimFromIO+    , primTouch+    ) where++import qualified Prelude+import           GHC.ST+import           GHC.STRef+import           GHC.IORef+import           GHC.IO+import           GHC.Prim+import           Basement.Compat.Base (Exception, (.), ($), Applicative)++-- | Primitive monad that can handle mutation.+--+-- For example: IO and ST.+class (Prelude.Functor m, Applicative m, Prelude.Monad m) => PrimMonad m where+    -- | type of state token associated with the PrimMonad m+    type PrimState m+    -- | type of variable associated with the PrimMonad m+    type PrimVar m :: * -> *+    -- | Unwrap the State# token to pass to a function a primitive function that returns an unboxed state and a value.+    primitive :: (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a+    -- | Throw Exception in the primitive monad+    primThrow :: Exception e => e -> m a+    -- | Run a Prim monad from a dedicated state#+    unPrimMonad  :: m a -> State# (PrimState m) -> (# State# (PrimState m), a #)++    -- | Build a new variable in the Prim Monad+    primVarNew :: a -> m (PrimVar m a)+    -- | Read the variable in the Prim Monad+    primVarRead :: PrimVar m a -> m a+    -- | Write the variable in the Prim Monad+    primVarWrite :: PrimVar m a -> a -> m ()++-- | just like `unwrapPrimMonad` but throw away the result and return just the new State#+unPrimMonad_ :: PrimMonad m => m () -> State# (PrimState m) -> State# (PrimState m)+unPrimMonad_ p st =+    case unPrimMonad p st of+        (# st', () #) -> st'+{-# INLINE unPrimMonad_ #-}++instance PrimMonad IO where+    type PrimState IO = RealWorld+    type PrimVar IO = IORef+    primitive = IO+    {-# INLINE primitive #-}+    primThrow = throwIO+    unPrimMonad (IO p) = p+    {-# INLINE unPrimMonad #-}+    primVarNew = newIORef+    primVarRead = readIORef+    primVarWrite = writeIORef++instance PrimMonad (ST s) where+    type PrimState (ST s) = s+    type PrimVar (ST s) = STRef s+    primitive = ST+    {-# INLINE primitive #-}+    primThrow = unsafeIOToST . throwIO+    unPrimMonad (ST p) = p+    {-# INLINE unPrimMonad #-}+    primVarNew = newSTRef+    primVarRead = readSTRef+    primVarWrite = writeSTRef++-- | Convert a prim monad to another prim monad.+--+-- The net effect is that it coerce the state repr to another,+-- so the runtime representation should be the same, otherwise+-- hilary ensues.+unsafePrimCast :: (PrimMonad m1, PrimMonad m2) => m1 a -> m2 a+unsafePrimCast m = primitive (unsafeCoerce# (unPrimMonad m))+{-# INLINE unsafePrimCast #-}++-- | Convert any prim monad to an ST monad+unsafePrimToST :: PrimMonad prim => prim a -> ST s a+unsafePrimToST = unsafePrimCast+{-# INLINE unsafePrimToST #-}++-- | Convert any prim monad to an IO monad+unsafePrimToIO :: PrimMonad prim => prim a -> IO a+unsafePrimToIO = unsafePrimCast+{-# INLINE unsafePrimToIO #-}++-- | Convert any IO monad to a prim monad+unsafePrimFromIO :: PrimMonad prim => IO a -> prim a+unsafePrimFromIO = unsafePrimCast+{-# INLINE unsafePrimFromIO #-}++-- | Touch primitive lifted to any prim monad+primTouch :: PrimMonad m => a -> m ()+primTouch x = unsafePrimFromIO $ primitive $ \s -> case touch# x s of { s2 -> (# s2, () #) }+{-# INLINE primTouch #-}++-- | Monad that can represent failure+--+-- Similar to MonadFail but with a parametrized Failure linked to the Monad+class Prelude.Monad m => MonadFailure m where+    -- | The associated type with the MonadFailure, representing what+    -- failure can be encoded in this monad+    type Failure m++    -- | Raise a Failure through a monad.+    mFail :: Failure m -> m ()++instance MonadFailure Prelude.Maybe where+    type Failure Prelude.Maybe = ()+    mFail _ = Prelude.Nothing+instance MonadFailure (Prelude.Either a) where+    type Failure (Prelude.Either a) = a+    mFail a = Prelude.Left a
+ Basement/MutableBuilder.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Basement.MutableBuilder+    ( Builder(..)+    , BuildingState(..)+    ) where++import           Basement.Compat.Base+import           Basement.Compat.MonadTrans+import           Basement.Types.OffsetSize+import           Basement.Monad++newtype Builder collection mutCollection step state err a = Builder+    { runBuilder :: State (Offset step, BuildingState collection mutCollection step (PrimState state), Maybe err) state a }+    deriving (Functor, Applicative, Monad)++-- | The in-progress state of a building operation.+--+-- The previous buffers are in reverse order, and+-- this contains the current buffer and the state of+-- progress packing the elements inside.+data BuildingState collection mutCollection step state = BuildingState+    { prevChunks     :: [collection]+    , prevChunksSize :: !(CountOf step)+    , curChunk       :: mutCollection state+    , chunkSize      :: !(CountOf step)+    }++instance Monad state => MonadFailure (Builder collection mutCollection step state err) where+    type Failure (Builder collection mutCollection step state err) = err+    mFail builderError = Builder $ State $ \(offset, bs, _)  ->+        return ((), (offset, bs, Just builderError))
+ Basement/Nat.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE CPP                       #-}+{-# LANGUAGE KindSignatures            #-}+{-# LANGUAGE DataKinds                 #-}+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE TypeOperators             #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE UndecidableInstances      #-}+#if __GLASGOW_HASKELL__ < 800+{-# LANGUAGE ConstraintKinds           #-}+#endif+module Basement.Nat+    ( Nat+    , KnownNat+    , natVal+    , type (<=), type (<=?), type (+), type (*), type (^), type (-)+    , CmpNat+    -- * Nat convertion+    , natValNatural+    , natValInt+    , natValInt8+    , natValInt16+    , natValInt32+    , natValInt64+    , natValWord+    , natValWord8+    , natValWord16+    , natValWord32+    , natValWord64+    -- * Maximum bounds+    , NatNumMaxBound+    -- * Constraint+    , NatInBoundOf+    , NatWithinBound+    ) where++#include "MachDeps.h"++import           GHC.TypeLits+import           Basement.Compat.Base+import           Basement.Compat.Natural+import           Data.Int (Int8, Int16, Int32, Int64)+import           Data.Word (Word8, Word16, Word32, Word64)+import qualified Prelude (fromIntegral)++#if __GLASGOW_HASKELL__ >= 800+import           Data.Type.Bool+#endif++natValNatural :: forall n proxy . KnownNat n => proxy n -> Natural+natValNatural n = Prelude.fromIntegral (natVal n)++natValInt :: forall n proxy . (KnownNat n, NatWithinBound Int n) => proxy n -> Int+natValInt n = Prelude.fromIntegral (natVal n)++natValInt64 :: forall n proxy . (KnownNat n, NatWithinBound Int64 n) => proxy n -> Int64+natValInt64 n = Prelude.fromIntegral (natVal n)++natValInt32 :: forall n proxy . (KnownNat n, NatWithinBound Int32 n) => proxy n -> Int32+natValInt32 n = Prelude.fromIntegral (natVal n)++natValInt16 :: forall n proxy . (KnownNat n, NatWithinBound Int16 n) => proxy n -> Int16+natValInt16 n = Prelude.fromIntegral (natVal n)++natValInt8 :: forall n proxy . (KnownNat n, NatWithinBound Int8 n) => proxy n -> Int8+natValInt8 n = Prelude.fromIntegral (natVal n)++natValWord :: forall n proxy . (KnownNat n, NatWithinBound Word n) => proxy n -> Word+natValWord n = Prelude.fromIntegral (natVal n)++natValWord64 :: forall n proxy . (KnownNat n, NatWithinBound Word64 n) => proxy n -> Word64+natValWord64 n = Prelude.fromIntegral (natVal n)++natValWord32 :: forall n proxy . (KnownNat n, NatWithinBound Word32 n) => proxy n -> Word32+natValWord32 n = Prelude.fromIntegral (natVal n)++natValWord16 :: forall n proxy . (KnownNat n, NatWithinBound Word16 n) => proxy n -> Word16+natValWord16 n = Prelude.fromIntegral (natVal n)++natValWord8 :: forall n proxy . (KnownNat n, NatWithinBound Word8 n) => proxy n -> Word8+natValWord8 n = Prelude.fromIntegral (natVal n)++-- | Get Maximum bounds of different Integral / Natural types related to Nat+type family NatNumMaxBound ty where+    NatNumMaxBound Int64  = 0x7fffffffffffffff+    NatNumMaxBound Int32  = 0x7fffffff+    NatNumMaxBound Int16  = 0x7fff+    NatNumMaxBound Int8   = 0x7f+    NatNumMaxBound Word64 = 0xffffffffffffffff+    NatNumMaxBound Word32 = 0xffffffff+    NatNumMaxBound Word16 = 0xffff+    NatNumMaxBound Word8  = 0xff+#if WORD_SIZE_IN_BITS == 64+    NatNumMaxBound Int    = NatNumMaxBound Int64+    NatNumMaxBound Word   = NatNumMaxBound Word64+#else+    NatNumMaxBound Int    = NatNumMaxBound Int32+    NatNumMaxBound Word   = NatNumMaxBound Word32+#endif++-- | Check if a Nat is in bounds of another integral / natural types+type family NatInBoundOf ty n where+    NatInBoundOf Integer n = 'True+    NatInBoundOf Natural n = 'True+    NatInBoundOf ty      n = n <=? NatNumMaxBound ty++-- | Constraint to check if a natural is within a specific bounds of a type.+--+-- i.e. given a Nat `n`, is it possible to convert it to `ty` without losing information+#if __GLASGOW_HASKELL__ >= 800+type family NatWithinBound ty (n :: Nat) where+    NatWithinBound ty n = If (NatInBoundOf ty n)+        (() ~ ())+        (TypeError ('Text "Natural " ':<>: 'ShowType n ':<>: 'Text " is out of bounds for " ':<>: 'ShowType ty))+#else+type NatWithinBound ty n = NatInBoundOf ty n ~ 'True+#endif
+ Basement/NonEmpty.hs view
@@ -0,0 +1,25 @@+-- |+-- Module      : Basement.NonEmpty+-- License     : BSD-style+-- Maintainer  : Foundation+-- Stability   : experimental+-- Portability : portable+--+-- A newtype wrapper around a non-empty Collection.++module Basement.NonEmpty+    ( NonEmpty(..)+    ) where++import           Basement.Exception+import           Basement.Compat.Base++-- | NonEmpty property for any Collection+newtype NonEmpty a = NonEmpty { getNonEmpty :: a }+    deriving (Show,Eq)++instance IsList c => IsList (NonEmpty c) where+    type Item (NonEmpty c) = Item c+    toList      = toList . getNonEmpty+    fromList [] = throw NonEmptyCollectionIsEmpty+    fromList l  = NonEmpty . fromList $ l
+ Basement/NormalForm.hs view
@@ -0,0 +1,123 @@+module Basement.NormalForm+    ( NormalForm(..)+    , deepseq+    , force+    ) where++import Basement.Compat.Base+import Basement.Compat.Natural+import Basement.Types.OffsetSize+import Basement.Types.Char7+import Basement.Endianness+import Foreign.C.Types++-- | Data that can be fully evaluated in Normal Form+--+class NormalForm a where+    toNormalForm :: a -> ()++deepseq :: NormalForm a => a -> b -> b+deepseq a b = toNormalForm a `seq` b++force :: NormalForm a => a -> a+force a = toNormalForm a `seq` a++-----+-- GHC / base types++instance NormalForm Int8    where toNormalForm !_ = ()+instance NormalForm Int16   where toNormalForm !_ = ()+instance NormalForm Int32   where toNormalForm !_ = ()+instance NormalForm Int64   where toNormalForm !_ = ()+instance NormalForm Int     where toNormalForm !_ = ()+instance NormalForm Integer where toNormalForm !_ = ()++instance NormalForm Word8   where toNormalForm !_ = ()+instance NormalForm Word16  where toNormalForm !_ = ()+instance NormalForm Word32  where toNormalForm !_ = ()+instance NormalForm Word64  where toNormalForm !_ = ()+instance NormalForm Word    where toNormalForm !_ = ()+instance NormalForm Natural where toNormalForm !_ = ()++instance NormalForm Float  where toNormalForm !_ = ()+instance NormalForm Double where toNormalForm !_ = ()++instance NormalForm Char7 where toNormalForm !_ = ()+instance NormalForm Char where toNormalForm !_ = ()+instance NormalForm Bool where toNormalForm !_ = ()+instance NormalForm ()   where toNormalForm !_ = ()++-----+-- C Types+instance NormalForm CChar  where toNormalForm !_ = ()+instance NormalForm CUChar where toNormalForm !_ = ()+instance NormalForm CSChar where toNormalForm !_ = ()++instance NormalForm CShort  where toNormalForm !_ = ()+instance NormalForm CUShort where toNormalForm !_ = ()+instance NormalForm CInt    where toNormalForm !_ = ()+instance NormalForm CUInt   where toNormalForm !_ = ()+instance NormalForm CLong   where toNormalForm !_ = ()+instance NormalForm CULong  where toNormalForm !_ = ()+instance NormalForm CLLong  where toNormalForm !_ = ()+instance NormalForm CULLong where toNormalForm !_ = ()++instance NormalForm CFloat  where toNormalForm !_ = ()+instance NormalForm CDouble where toNormalForm !_ = ()++instance NormalForm (Ptr a) where toNormalForm !_ = ()++-----+-- Basic Foundation primitive types+instance NormalForm (Offset a) where toNormalForm !_ = ()+instance NormalForm (CountOf a) where toNormalForm !_ = ()++-----+-- composed type++instance NormalForm a => NormalForm (Maybe a) where+    toNormalForm Nothing  = ()+    toNormalForm (Just a) = toNormalForm a `seq` ()+instance (NormalForm l, NormalForm r) => NormalForm (Either l r) where+    toNormalForm (Left l)  = toNormalForm l `seq` ()+    toNormalForm (Right r) = toNormalForm r `seq` ()+instance NormalForm a => NormalForm (LE a) where+    toNormalForm (LE a) = toNormalForm a `seq` ()+instance NormalForm a => NormalForm (BE a) where+    toNormalForm (BE a) = toNormalForm a `seq` ()++instance NormalForm a => NormalForm [a] where+    toNormalForm []     = ()+    toNormalForm (x:xs) = toNormalForm x `seq` toNormalForm xs++instance (NormalForm a, NormalForm b) => NormalForm (a,b) where+    toNormalForm (a,b) = toNormalForm a `seq` toNormalForm b++instance (NormalForm a, NormalForm b, NormalForm c) => NormalForm (a,b,c) where+    toNormalForm (a,b,c) = toNormalForm a `seq` toNormalForm b `seq` toNormalForm c++instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d) => NormalForm (a,b,c,d) where+    toNormalForm (a,b,c,d) = toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d++instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d, NormalForm e)+      => NormalForm (a,b,c,d,e) where+    toNormalForm (a,b,c,d,e) =+        toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d `seq`+        toNormalForm e++instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d, NormalForm e, NormalForm f)+      => NormalForm (a,b,c,d,e,f) where+    toNormalForm (a,b,c,d,e,f) =+        toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d `seq`+        toNormalForm e `seq` toNormalForm f++instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d, NormalForm e, NormalForm f, NormalForm g)+      => NormalForm (a,b,c,d,e,f,g) where+    toNormalForm (a,b,c,d,e,f,g) =+        toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d `seq`+        toNormalForm e `seq` toNormalForm f `seq` toNormalForm g+instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d, NormalForm e, NormalForm f, NormalForm g, NormalForm h)+      => NormalForm (a,b,c,d,e,f,g,h) where+    toNormalForm (a,b,c,d,e,f,g,h) =+        toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d `seq`+        toNormalForm e `seq` toNormalForm f `seq` toNormalForm g `seq` toNormalForm h
+ Basement/Numerical/Additive.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE MagicHash         #-}+module Basement.Numerical.Additive+    ( Additive(..)+    ) where++#include "MachDeps.h"++import           Basement.Compat.Base+import           Basement.Compat.Natural+import           Basement.Numerical.Number+import qualified Prelude+import           GHC.Types+import           GHC.Prim+import           GHC.Int+import           GHC.Word+import           Foreign.C.Types++#if WORD_SIZE_IN_BITS < 64+import           GHC.IntWord64+#endif++-- | Represent class of things that can be added together,+-- contains a neutral element and is commutative.+--+-- > x + azero = x+-- > azero + x = x+-- > x + y = y + x+--+class Additive a where+    {-# MINIMAL azero, (+) #-}+    azero :: a           -- the identity element over addition+    (+)   :: a -> a -> a -- the addition++    scale :: IsNatural n => n -> a -> a -- scale: repeated addition+    scale 0 _ = azero+    scale 1 a = a+    scale 2 a = a + a+    scale n a = a + scale (pred n) a -- TODO optimise. define by group of 2.++infixl 6 +++instance Additive Integer where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive Int where+    azero = 0+    (I# a) + (I# b) = I# (a +# b)+    scale = scaleNum+instance Additive Int8 where+    azero = 0+    (I8# a) + (I8# b) = I8# (narrow8Int# (a +# b))+    scale = scaleNum+instance Additive Int16 where+    azero = 0+    (I16# a) + (I16# b) = I16# (narrow16Int# (a +# b))+    scale = scaleNum+instance Additive Int32 where+    azero = 0+    (I32# a) + (I32# b) = I32# (narrow32Int# (a +# b))+    scale = scaleNum+instance Additive Int64 where+    azero = 0+#if WORD_SIZE_IN_BITS == 64+    (I64# a) + (I64# b) = I64# (a +# b)+#else+    (I64# a) + (I64# b) = I64# (a `plusInt64#` b)+#endif+    scale = scaleNum+instance Additive Word where+    azero = 0+    (W# a) + (W# b) = W# (a `plusWord#` b)+    scale = scaleNum+instance Additive Natural where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive Word8 where+    azero = 0+    (W8# a) + (W8# b) = W8# (narrow8Word# (a `plusWord#` b))+    scale = scaleNum+instance Additive Word16 where+    azero = 0+    (W16# a) + (W16# b) = W16# (narrow16Word# (a `plusWord#` b))+    scale = scaleNum+instance Additive Word32 where+    azero = 0+    (W32# a) + (W32# b) = W32# (narrow32Word# (a `plusWord#` b))+    scale = scaleNum+instance Additive Word64 where+    azero = 0+#if WORD_SIZE_IN_BITS == 64+    (W64# a) + (W64# b) = W64# (a `plusWord#` b)+#else+    (W64# a) + (W64# b) = W64# (int64ToWord64# (word64ToInt64# a `plusInt64#` word64ToInt64# b))+#endif+    scale = scaleNum+instance Additive Prelude.Float where+    azero = 0.0+    (F# a) + (F# b) = F# (a `plusFloat#` b)+    scale = scaleNum+instance Additive Prelude.Double where+    azero = 0.0+    (D# a) + (D# b) = D# (a +## b)+    scale = scaleNum+instance Additive CSize where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum++scaleNum :: (Prelude.Num a, IsNatural n) => n -> a -> a+scaleNum n a = (Prelude.fromIntegral $ toNatural n) Prelude.* a
+ Basement/Numerical/Multiplicative.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+module Basement.Numerical.Multiplicative+    ( Multiplicative(..)+    , IDivisible(..)+    , Divisible(..)+    , recip+    ) where++import           Basement.Compat.Base+import           Basement.Compat.Natural+import           Basement.Numerical.Number+import           Basement.Numerical.Additive+import qualified Prelude++-- | Represent class of things that can be multiplied together+--+-- > x * midentity = x+-- > midentity * x = x+class Multiplicative a where+    {-# MINIMAL midentity, (*) #-}+    -- | Identity element over multiplication+    midentity :: a++    -- | Multiplication of 2 elements that result in another element+    (*) :: a -> a -> a++    -- | Raise to power, repeated multiplication+    -- e.g.+    -- > a ^ 2 = a * a+    -- > a ^ 10 = (a ^ 5) * (a ^ 5) ..+    --(^) :: (IsNatural n) => a -> n -> a+    (^) :: (IsNatural n, IDivisible n) => a -> n -> a+    -- default (^) :: (IDivisible n, IsNatural n, Multiplicative a) => a -> n -> a+    (^) = power++-- | Represent types that supports an euclidian division+--+-- > (x ‘div‘ y) * y + (x ‘mod‘ y) == x+class (Additive a, Multiplicative a) => IDivisible a where+    {-# MINIMAL (div, mod) | divMod #-}+    div :: a -> a -> a+    div a b = fst $ divMod a b+    mod :: a -> a -> a+    mod a b = snd $ divMod a b+    divMod :: a -> a -> (a, a)+    divMod a b = (div a b, mod a b)++-- | Support for division between same types+--+-- This is likely to change to represent specific mathematic divisions+class Multiplicative a => Divisible a where+    {-# MINIMAL (/) #-}+    (/) :: a -> a -> a++infixl 7  *, /+infixr 8  ^++instance Multiplicative Integer where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative Int where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative Int8 where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative Int16 where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative Int32 where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative Int64 where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative Natural where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative Word where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative Word8 where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative Word16 where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative Word32 where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative Word64 where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative Prelude.Float where+    midentity = 1.0+    (*) = (Prelude.*)+instance Multiplicative Prelude.Double where+    midentity = 1.0+    (*) = (Prelude.*)+instance Multiplicative Prelude.Rational where+    midentity = 1.0+    (*) = (Prelude.*)++instance IDivisible Integer where+    div = Prelude.div+    mod = Prelude.mod+instance IDivisible Int where+    div = Prelude.div+    mod = Prelude.mod+instance IDivisible Int8 where+    div = Prelude.div+    mod = Prelude.mod+instance IDivisible Int16 where+    div = Prelude.div+    mod = Prelude.mod+instance IDivisible Int32 where+    div = Prelude.div+    mod = Prelude.mod+instance IDivisible Int64 where+    div = Prelude.div+    mod = Prelude.mod+instance IDivisible Natural where+    div = Prelude.quot+    mod = Prelude.rem+instance IDivisible Word where+    div = Prelude.quot+    mod = Prelude.rem+instance IDivisible Word8 where+    div = Prelude.quot+    mod = Prelude.rem+instance IDivisible Word16 where+    div = Prelude.quot+    mod = Prelude.rem+instance IDivisible Word32 where+    div = Prelude.quot+    mod = Prelude.rem+instance IDivisible Word64 where+    div = Prelude.quot+    mod = Prelude.rem++instance Divisible Prelude.Rational where+    (/) = (Prelude./)+instance Divisible Float where+    (/) = (Prelude./)+instance Divisible Double where+    (/) = (Prelude./)++recip :: Divisible a => a -> a+recip x = midentity / x++power :: (IsNatural n, IDivisible n, Multiplicative a) => a -> n -> a+power a n+    | n == 0    = midentity+    | otherwise = squaring midentity a n+  where+    squaring y x i+        | i == 0    = y+        | i == 1    = x * y+        | even i    = squaring y (x*x) (i`div`2)+        | otherwise = squaring (x*y) (x*x) (pred i`div` 2)++even :: (IDivisible n, IsIntegral n) => n -> Bool+even n = (n `mod` 2) == 0
+ Basement/Numerical/Number.hs view
@@ -0,0 +1,64 @@+module Basement.Numerical.Number+    ( IsIntegral(..)+    , IsNatural(..)+    ) where++import           Basement.Compat.Base+import           Basement.Compat.Natural+import qualified Prelude+import           Foreign.C.Types++-- | Number literals, convertible through the generic Integer type.+--+-- all number are Enum'erable, meaning that you can move to+-- next element+class (Enum a, Eq a, Ord a, Integral a) => IsIntegral a where+    {-# MINIMAL toInteger #-}+    toInteger :: a -> Integer++-- | Non Negative Number literals, convertible through the generic Natural type+class (Enum a, Eq a, Ord a, Integral a, IsIntegral a) => IsNatural a where+    {-# MINIMAL toNatural #-}+    toNatural :: a -> Natural++instance IsIntegral Integer where+    toInteger i = i+instance IsIntegral Int where+    toInteger i = Prelude.toInteger i+instance IsIntegral Int8 where+    toInteger i = Prelude.toInteger i+instance IsIntegral Int16 where+    toInteger i = Prelude.toInteger i+instance IsIntegral Int32 where+    toInteger i = Prelude.toInteger i+instance IsIntegral Int64 where+    toInteger i = Prelude.toInteger i+instance IsIntegral Natural where+    toInteger i = Prelude.toInteger i+instance IsIntegral Word where+    toInteger i = Prelude.toInteger i+instance IsIntegral Word8 where+    toInteger i = Prelude.toInteger i+instance IsIntegral Word16 where+    toInteger i = Prelude.toInteger i+instance IsIntegral Word32 where+    toInteger i = Prelude.toInteger i+instance IsIntegral Word64 where+    toInteger i = Prelude.toInteger i+instance IsIntegral CSize where+    toInteger i = Prelude.toInteger i++instance IsNatural Natural where+    toNatural i = i+instance IsNatural Word where+    toNatural i = Prelude.fromIntegral i+instance IsNatural Word8 where+    toNatural i = Prelude.fromIntegral i+instance IsNatural Word16 where+    toNatural i = Prelude.fromIntegral i+instance IsNatural Word32 where+    toNatural i = Prelude.fromIntegral i+instance IsNatural Word64 where+    toNatural i = Prelude.fromIntegral i+instance IsNatural CSize where+    toNatural i = Prelude.fromIntegral i
+ Basement/Numerical/Subtractive.hs view
@@ -0,0 +1,74 @@+module Basement.Numerical.Subtractive+    ( Subtractive(..)+    ) where++import           Basement.Compat.Base+import           Basement.Compat.Natural+import           Basement.IntegralConv+import qualified Prelude++-- | Represent class of things that can be subtracted.+--+--+-- Note that the result is not necessary of the same type+-- as the operand depending on the actual type.+--+-- For example:+--+-- > (-) :: Int -> Int -> Int+-- > (-) :: DateTime -> DateTime -> Seconds+-- > (-) :: Ptr a -> Ptr a -> PtrDiff+-- > (-) :: Natural -> Natural -> Maybe Natural+class Subtractive a where+    type Difference a+    (-) :: a -> a -> Difference a++infixl 6 -++instance Subtractive Integer where+    type Difference Integer = Integer+    (-) = (Prelude.-)+instance Subtractive Int where+    type Difference Int = Int+    (-) = (Prelude.-)+instance Subtractive Int8 where+    type Difference Int8 = Int8+    (-) = (Prelude.-)+instance Subtractive Int16 where+    type Difference Int16 = Int16+    (-) = (Prelude.-)+instance Subtractive Int32 where+    type Difference Int32 = Int32+    (-) = (Prelude.-)+instance Subtractive Int64 where+    type Difference Int64 = Int64+    (-) = (Prelude.-)+instance Subtractive Natural where+    type Difference Natural = Maybe Natural+    (-) a b+        | b > a     = Nothing+        | otherwise = Just (a Prelude.- b)+instance Subtractive Word where+    type Difference Word = Word+    (-) = (Prelude.-)+instance Subtractive Word8 where+    type Difference Word8 = Word8+    (-) = (Prelude.-)+instance Subtractive Word16 where+    type Difference Word16 = Word16+    (-) = (Prelude.-)+instance Subtractive Word32 where+    type Difference Word32 = Word32+    (-) = (Prelude.-)+instance Subtractive Word64 where+    type Difference Word64 = Word64+    (-) = (Prelude.-)+instance Subtractive Prelude.Float where+    type Difference Prelude.Float = Prelude.Float+    (-) = (Prelude.-)+instance Subtractive Prelude.Double where+    type Difference Prelude.Double = Prelude.Double+    (-) = (Prelude.-)+instance Subtractive Prelude.Char where+    type Difference Prelude.Char = Prelude.Int+    (-) a b = (Prelude.-) (charToInt a) (charToInt b)
+ Basement/PrimType.hs view
@@ -0,0 +1,644 @@+-- Module      : Basement.PrimType+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : portable+--+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+module Basement.PrimType+    ( PrimType(..)+    , PrimMemoryComparable+    , primBaIndex+    , primMbaRead+    , primMbaWrite+    , primArrayIndex+    , primMutableArrayRead+    , primMutableArrayWrite+    , primOffsetOfE+    , primOffsetRecast+    , sizeRecast+    , offsetAsSize+    , sizeAsOffset+    , sizeInBytes+    , offsetInBytes+    , offsetInElements+    , offsetIsAligned+    , primWordGetByteAndShift+    , primWord64GetByteAndShift+    , primWord64GetHiLo+    ) where++#include "MachDeps.h"++import           GHC.Prim+import           GHC.Int+import           GHC.Types+import           GHC.Word+import           Data.Bits+import           Foreign.C.Types+import           Data.Proxy+import           Basement.Compat.Base+import           Basement.Numerical.Subtractive+import           Basement.Types.OffsetSize+import           Basement.Types.Char7 (Char7(..))+import           Basement.Endianness+import           Basement.Monad+import qualified Prelude (quot)++#if WORD_SIZE_IN_BITS < 64+import           GHC.IntWord64+#endif++#ifdef FOUNDATION_BOUNDS_CHECK++divBytes :: PrimType ty => Offset ty -> (Int -> Int)+divBytes ofs = \x -> x `Prelude.quot` (getSize Proxy ofs)+  where+    getSize :: PrimType ty => Proxy ty -> Offset ty -> Int+    getSize p _ = let (CountOf sz) = primSizeInBytes p in sz++baLength :: PrimType ty => Offset ty -> ByteArray# -> Int+baLength ofs ba = divBytes ofs (I# (sizeofByteArray# ba))++mbaLength :: PrimType ty => Offset ty -> MutableByteArray# st -> Int+mbaLength ofs ba = divBytes ofs (I# (sizeofMutableByteArray# ba))++aLength :: Array# ty -> Int+aLength ba = I# (sizeofArray# ba)++maLength :: MutableArray# st ty -> Int+maLength ba = I# (sizeofMutableArray# ba)++boundCheckError :: [Char] -> Offset ty -> Int -> a+boundCheckError ty (Offset ofs) len =+    error (ty <> " offset=" <> show ofs <> " len=" <> show len)++baCheck :: PrimType ty => ByteArray# -> Offset ty -> Bool+baCheck ba ofs@(Offset o) = o < 0 || o >= baLength ofs ba++mbaCheck :: PrimType ty => MutableByteArray# st -> Offset ty -> Bool+mbaCheck mba ofs@(Offset o) = o < 0 || o >= mbaLength ofs mba++aCheck :: Array# ty -> Offset ty -> Bool+aCheck ba (Offset o) = o < 0 || o >= aLength ba++maCheck :: MutableArray# st ty -> Offset ty -> Bool+maCheck ma (Offset o) = o < 0 || o >= maLength ma++primBaIndex :: PrimType ty => ByteArray# -> Offset ty -> ty+primBaIndex ba ofs+    | baCheck ba ofs = boundCheckError "bytearray-index" ofs (baLength ofs ba)+    | otherwise      = primBaUIndex ba ofs+{-# NOINLINE primBaIndex #-}++primMbaRead :: (PrimType ty, PrimMonad prim) => MutableByteArray# (PrimState prim) -> Offset ty -> prim ty+primMbaRead mba ofs+    | mbaCheck mba ofs = boundCheckError "mutablebytearray-read" ofs (mbaLength ofs mba)+    | otherwise        = primMbaURead mba ofs+{-# NOINLINE primMbaRead #-}++primMbaWrite :: (PrimType ty, PrimMonad prim) => MutableByteArray# (PrimState prim) -> Offset ty -> ty -> prim ()+primMbaWrite mba ofs ty+    | mbaCheck mba ofs = boundCheckError "mutablebytearray-write" ofs (mbaLength ofs mba)+    | otherwise        = primMbaUWrite mba ofs ty+{-# NOINLINE primMbaWrite #-}++primArrayIndex :: Array# ty -> Offset ty -> ty+primArrayIndex a o@(Offset (I# ofs))+    | aCheck a o = boundCheckError "array-index" o (aLength a)+    | otherwise  = let !(# v #) = indexArray# a ofs in v+{-# NOINLINE primArrayIndex #-}++primMutableArrayRead :: PrimMonad prim => MutableArray# (PrimState prim) ty -> Offset ty -> prim ty+primMutableArrayRead ma o@(Offset (I# ofs))+    | maCheck ma o = boundCheckError "array-read" o (maLength ma)+    | otherwise    = primitive $ \s1 -> readArray# ma ofs s1+{-# NOINLINE primMutableArrayRead #-}++primMutableArrayWrite :: PrimMonad prim => MutableArray# (PrimState prim) ty -> Offset ty -> ty -> prim ()+primMutableArrayWrite ma o@(Offset (I# ofs)) v+    | maCheck ma o = boundCheckError "array-write" o (maLength ma)+    | otherwise    = primitive $ \s1 -> let !s2 = writeArray# ma ofs v s1 in (# s2, () #)+{-# NOINLINE primMutableArrayWrite #-}++#else++primBaIndex :: PrimType ty => ByteArray# -> Offset ty -> ty+primBaIndex = primBaUIndex+{-# INLINE primBaIndex #-}++primMbaRead :: (PrimType ty, PrimMonad prim) => MutableByteArray# (PrimState prim) -> Offset ty -> prim ty+primMbaRead = primMbaURead+{-# INLINE primMbaRead #-}++primMbaWrite :: (PrimType ty, PrimMonad prim) => MutableByteArray# (PrimState prim) -> Offset ty -> ty -> prim ()+primMbaWrite = primMbaUWrite+{-# INLINE primMbaWrite #-}++primArrayIndex :: Array# ty -> Offset ty -> ty+primArrayIndex a (Offset (I# ofs)) = let !(# v #) = indexArray# a ofs in v+{-# INLINE primArrayIndex #-}++primMutableArrayRead :: PrimMonad prim => MutableArray# (PrimState prim) ty -> Offset ty -> prim ty+primMutableArrayRead ma (Offset (I# ofs)) = primitive $ \s1 -> readArray# ma ofs s1+{-# INLINE primMutableArrayRead #-}++primMutableArrayWrite :: PrimMonad prim => MutableArray# (PrimState prim) ty -> Offset ty -> ty -> prim ()+primMutableArrayWrite ma (Offset (I# ofs)) v =+    primitive $ \s1 -> let !s2 = writeArray# ma ofs v s1 in (# s2, () #)+{-# INLINE primMutableArrayWrite #-}++#endif++-- | Represent the accessor for types that can be stored in the UArray and MUArray.+--+-- Types need to be a instance of storable and have fixed sized.+class Eq ty => PrimType ty where+    -- | get the size in bytes of a ty element+    primSizeInBytes :: Proxy ty -> CountOf Word8++    -- | get the shift size+    primShiftToBytes :: Proxy ty -> Int++    -----+    -- ByteArray section+    -----++    -- | return the element stored at a specific index+    primBaUIndex :: ByteArray# -> Offset ty -> ty++    -----+    -- MutableByteArray section+    -----++    -- | Read an element at an index in a mutable array+    primMbaURead :: PrimMonad prim+                => MutableByteArray# (PrimState prim) -- ^ mutable array to read from+                -> Offset ty                         -- ^ index of the element to retrieve+                -> prim ty                           -- ^ the element returned++    -- | Write an element to a specific cell in a mutable array.+    primMbaUWrite :: PrimMonad prim+                 => MutableByteArray# (PrimState prim) -- ^ mutable array to modify+                 -> Offset ty                         -- ^ index of the element to modify+                 -> ty                                 -- ^ the new value to store+                 -> prim ()++    -----+    -- Addr# section+    -----++    -- | Read from Address, without a state. the value read should be considered a constant for all+    -- pratical purpose, otherwise bad thing will happens.+    primAddrIndex :: Addr# -> Offset ty -> ty++    -- | Read a value from Addr in a specific primitive monad+    primAddrRead :: PrimMonad prim+                 => Addr#+                 -> Offset ty+                 -> prim ty+    -- | Write a value to Addr in a specific primitive monad+    primAddrWrite :: PrimMonad prim+                  => Addr#+                  -> Offset ty+                  -> ty+                  -> prim ()++sizeInt, sizeWord :: CountOf Word8+shiftInt, shiftWord :: Int+#if WORD_SIZE_IN_BITS == 64+sizeInt = CountOf 8+sizeWord = CountOf 8+shiftInt = 3+shiftWord = 3+#else+sizeInt = CountOf 4+sizeWord = CountOf 4+shiftInt = 2+shiftWord = 2+#endif++{-# SPECIALIZE [3] primBaUIndex :: ByteArray# -> Offset Word8 -> Word8 #-}++instance PrimType Int where+    primSizeInBytes _ = sizeInt+    {-# INLINE primSizeInBytes #-}+    primShiftToBytes _ = shiftInt+    {-# INLINE primShiftToBytes #-}+    primBaUIndex ba (Offset (I# n)) = I# (indexIntArray# ba n)+    {-# INLINE primBaUIndex #-}+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readIntArray# mba n s1 in (# s2, I# r #)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset (I# n)) (I# w) = primitive $ \s1 -> (# writeIntArray# mba n w s1, () #)+    {-# INLINE primMbaUWrite #-}+    primAddrIndex addr (Offset (I# n)) = I# (indexIntOffAddr# addr n)+    {-# INLINE primAddrIndex #-}+    primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readIntOffAddr# addr n s1 in (# s2, I# r #)+    {-# INLINE primAddrRead #-}+    primAddrWrite addr (Offset (I# n)) (I# w) = primitive $ \s1 -> (# writeIntOffAddr# addr n w s1, () #)+    {-# INLINE primAddrWrite #-}++instance PrimType Word where+    primSizeInBytes _ = sizeWord+    {-# INLINE primSizeInBytes #-}+    primShiftToBytes _ = shiftWord+    {-# INLINE primShiftToBytes #-}+    primBaUIndex ba (Offset (I# n)) = W# (indexWordArray# ba n)+    {-# INLINE primBaUIndex #-}+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWordArray# mba n s1 in (# s2, W# r #)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset (I# n)) (W# w) = primitive $ \s1 -> (# writeWordArray# mba n w s1, () #)+    {-# INLINE primMbaUWrite #-}+    primAddrIndex addr (Offset (I# n)) = W# (indexWordOffAddr# addr n)+    {-# INLINE primAddrIndex #-}+    primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWordOffAddr# addr n s1 in (# s2, W# r #)+    {-# INLINE primAddrRead #-}+    primAddrWrite addr (Offset (I# n)) (W# w) = primitive $ \s1 -> (# writeWordOffAddr# addr n w s1, () #)+    {-# INLINE primAddrWrite #-}++instance PrimType Word8 where+    primSizeInBytes _ = CountOf 1+    {-# INLINE primSizeInBytes #-}+    primShiftToBytes _ = 0+    {-# INLINE primShiftToBytes #-}+    primBaUIndex ba (Offset (I# n)) = W8# (indexWord8Array# ba n)+    {-# INLINE primBaUIndex #-}+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWord8Array# mba n s1 in (# s2, W8# r #)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset (I# n)) (W8# w) = primitive $ \s1 -> (# writeWord8Array# mba n w s1, () #)+    {-# INLINE primMbaUWrite #-}+    primAddrIndex addr (Offset (I# n)) = W8# (indexWord8OffAddr# addr n)+    {-# INLINE primAddrIndex #-}+    primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWord8OffAddr# addr n s1 in (# s2, W8# r #)+    {-# INLINE primAddrRead #-}+    primAddrWrite addr (Offset (I# n)) (W8# w) = primitive $ \s1 -> (# writeWord8OffAddr# addr n w s1, () #)+    {-# INLINE primAddrWrite #-}++instance PrimType Word16 where+    primSizeInBytes _ = CountOf 2+    {-# INLINE primSizeInBytes #-}+    primShiftToBytes _ = 1+    {-# INLINE primShiftToBytes #-}+    primBaUIndex ba (Offset (I# n)) = W16# (indexWord16Array# ba n)+    {-# INLINE primBaUIndex #-}+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWord16Array# mba n s1 in (# s2, W16# r #)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset (I# n)) (W16# w) = primitive $ \s1 -> (# writeWord16Array# mba n w s1, () #)+    {-# INLINE primMbaUWrite #-}+    primAddrIndex addr (Offset (I# n)) = W16# (indexWord16OffAddr# addr n)+    {-# INLINE primAddrIndex #-}+    primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWord16OffAddr# addr n s1 in (# s2, W16# r #)+    {-# INLINE primAddrRead #-}+    primAddrWrite addr (Offset (I# n)) (W16# w) = primitive $ \s1 -> (# writeWord16OffAddr# addr n w s1, () #)+    {-# INLINE primAddrWrite #-}+instance PrimType Word32 where+    primSizeInBytes _ = CountOf 4+    {-# INLINE primSizeInBytes #-}+    primShiftToBytes _ = 2+    {-# INLINE primShiftToBytes #-}+    primBaUIndex ba (Offset (I# n)) = W32# (indexWord32Array# ba n)+    {-# INLINE primBaUIndex #-}+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWord32Array# mba n s1 in (# s2, W32# r #)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset (I# n)) (W32# w) = primitive $ \s1 -> (# writeWord32Array# mba n w s1, () #)+    {-# INLINE primMbaUWrite #-}+    primAddrIndex addr (Offset (I# n)) = W32# (indexWord32OffAddr# addr n)+    {-# INLINE primAddrIndex #-}+    primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWord32OffAddr# addr n s1 in (# s2, W32# r #)+    {-# INLINE primAddrRead #-}+    primAddrWrite addr (Offset (I# n)) (W32# w) = primitive $ \s1 -> (# writeWord32OffAddr# addr n w s1, () #)+    {-# INLINE primAddrWrite #-}+instance PrimType Word64 where+    primSizeInBytes _ = CountOf 8+    {-# INLINE primSizeInBytes #-}+    primShiftToBytes _ = 3+    {-# INLINE primShiftToBytes #-}+    primBaUIndex ba (Offset (I# n)) = W64# (indexWord64Array# ba n)+    {-# INLINE primBaUIndex #-}+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWord64Array# mba n s1 in (# s2, W64# r #)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset (I# n)) (W64# w) = primitive $ \s1 -> (# writeWord64Array# mba n w s1, () #)+    {-# INLINE primMbaUWrite #-}+    primAddrIndex addr (Offset (I# n)) = W64# (indexWord64OffAddr# addr n)+    {-# INLINE primAddrIndex #-}+    primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWord64OffAddr# addr n s1 in (# s2, W64# r #)+    {-# INLINE primAddrRead #-}+    primAddrWrite addr (Offset (I# n)) (W64# w) = primitive $ \s1 -> (# writeWord64OffAddr# addr n w s1, () #)+    {-# INLINE primAddrWrite #-}+instance PrimType Int8 where+    primSizeInBytes _ = CountOf 1+    {-# INLINE primSizeInBytes #-}+    primShiftToBytes _ = 0+    {-# INLINE primShiftToBytes #-}+    primBaUIndex ba (Offset (I# n)) = I8# (indexInt8Array# ba n)+    {-# INLINE primBaUIndex #-}+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readInt8Array# mba n s1 in (# s2, I8# r #)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset (I# n)) (I8# w) = primitive $ \s1 -> (# writeInt8Array# mba n w s1, () #)+    {-# INLINE primMbaUWrite #-}+    primAddrIndex addr (Offset (I# n)) = I8# (indexInt8OffAddr# addr n)+    {-# INLINE primAddrIndex #-}+    primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readInt8OffAddr# addr n s1 in (# s2, I8# r #)+    {-# INLINE primAddrRead #-}+    primAddrWrite addr (Offset (I# n)) (I8# w) = primitive $ \s1 -> (# writeInt8OffAddr# addr n w s1, () #)+    {-# INLINE primAddrWrite #-}+instance PrimType Int16 where+    primSizeInBytes _ = CountOf 2+    {-# INLINE primSizeInBytes #-}+    primShiftToBytes _ = 1+    {-# INLINE primShiftToBytes #-}+    primBaUIndex ba (Offset (I# n)) = I16# (indexInt16Array# ba n)+    {-# INLINE primBaUIndex #-}+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readInt16Array# mba n s1 in (# s2, I16# r #)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset (I# n)) (I16# w) = primitive $ \s1 -> (# writeInt16Array# mba n w s1, () #)+    {-# INLINE primMbaUWrite #-}+    primAddrIndex addr (Offset (I# n)) = I16# (indexInt16OffAddr# addr n)+    {-# INLINE primAddrIndex #-}+    primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readInt16OffAddr# addr n s1 in (# s2, I16# r #)+    {-# INLINE primAddrRead #-}+    primAddrWrite addr (Offset (I# n)) (I16# w) = primitive $ \s1 -> (# writeInt16OffAddr# addr n w s1, () #)+    {-# INLINE primAddrWrite #-}+instance PrimType Int32 where+    primSizeInBytes _ = CountOf 4+    {-# INLINE primSizeInBytes #-}+    primShiftToBytes _ = 2+    {-# INLINE primShiftToBytes #-}+    primBaUIndex ba (Offset (I# n)) = I32# (indexInt32Array# ba n)+    {-# INLINE primBaUIndex #-}+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readInt32Array# mba n s1 in (# s2, I32# r #)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset (I# n)) (I32# w) = primitive $ \s1 -> (# writeInt32Array# mba n w s1, () #)+    {-# INLINE primMbaUWrite #-}+    primAddrIndex addr (Offset (I# n)) = I32# (indexInt32OffAddr# addr n)+    {-# INLINE primAddrIndex #-}+    primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readInt32OffAddr# addr n s1 in (# s2, I32# r #)+    {-# INLINE primAddrRead #-}+    primAddrWrite addr (Offset (I# n)) (I32# w) = primitive $ \s1 -> (# writeInt32OffAddr# addr n w s1, () #)+    {-# INLINE primAddrWrite #-}+instance PrimType Int64 where+    primSizeInBytes _ = CountOf 8+    {-# INLINE primSizeInBytes #-}+    primShiftToBytes _ = 3+    {-# INLINE primShiftToBytes #-}+    primBaUIndex ba (Offset (I# n)) = I64# (indexInt64Array# ba n)+    {-# INLINE primBaUIndex #-}+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readInt64Array# mba n s1 in (# s2, I64# r #)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset (I# n)) (I64# w) = primitive $ \s1 -> (# writeInt64Array# mba n w s1, () #)+    {-# INLINE primMbaUWrite #-}+    primAddrIndex addr (Offset (I# n)) = I64# (indexInt64OffAddr# addr n)+    {-# INLINE primAddrIndex #-}+    primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readInt64OffAddr# addr n s1 in (# s2, I64# r #)+    {-# INLINE primAddrRead #-}+    primAddrWrite addr (Offset (I# n)) (I64# w) = primitive $ \s1 -> (# writeInt64OffAddr# addr n w s1, () #)+    {-# INLINE primAddrWrite #-}++instance PrimType Float where+    primSizeInBytes _ = CountOf 4+    {-# INLINE primSizeInBytes #-}+    primShiftToBytes _ = 2+    {-# INLINE primShiftToBytes #-}+    primBaUIndex ba (Offset (I# n)) = F# (indexFloatArray# ba n)+    {-# INLINE primBaUIndex #-}+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readFloatArray# mba n s1 in (# s2, F# r #)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset (I# n)) (F# w) = primitive $ \s1 -> (# writeFloatArray# mba n w s1, () #)+    {-# INLINE primMbaUWrite #-}+    primAddrIndex addr (Offset (I# n)) = F# (indexFloatOffAddr# addr n)+    {-# INLINE primAddrIndex #-}+    primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readFloatOffAddr# addr n s1 in (# s2, F# r #)+    {-# INLINE primAddrRead #-}+    primAddrWrite addr (Offset (I# n)) (F# w) = primitive $ \s1 -> (# writeFloatOffAddr# addr n w s1, () #)+    {-# INLINE primAddrWrite #-}+instance PrimType Double where+    primSizeInBytes _ = CountOf 8+    {-# INLINE primSizeInBytes #-}+    primShiftToBytes _ = 3+    {-# INLINE primShiftToBytes #-}+    primBaUIndex ba (Offset (I# n)) = D# (indexDoubleArray# ba n)+    {-# INLINE primBaUIndex #-}+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readDoubleArray# mba n s1 in (# s2, D# r #)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset (I# n)) (D# w) = primitive $ \s1 -> (# writeDoubleArray# mba n w s1, () #)+    {-# INLINE primMbaUWrite #-}+    primAddrIndex addr (Offset (I# n)) = D# (indexDoubleOffAddr# addr n)+    {-# INLINE primAddrIndex #-}+    primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readDoubleOffAddr# addr n s1 in (# s2, D# r #)+    {-# INLINE primAddrRead #-}+    primAddrWrite addr (Offset (I# n)) (D# w) = primitive $ \s1 -> (# writeDoubleOffAddr# addr n w s1, () #)+    {-# INLINE primAddrWrite #-}++instance PrimType Char where+    primSizeInBytes _ = CountOf 4+    {-# INLINE primSizeInBytes #-}+    primShiftToBytes _ = 2+    {-# INLINE primShiftToBytes #-}+    primBaUIndex ba (Offset (I# n)) = C# (indexWideCharArray# ba n)+    {-# INLINE primBaUIndex #-}+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWideCharArray# mba n s1 in (# s2, C# r #)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset (I# n)) (C# w) = primitive $ \s1 -> (# writeWideCharArray# mba n w s1, () #)+    {-# INLINE primMbaUWrite #-}+    primAddrIndex addr (Offset (I# n)) = C# (indexWideCharOffAddr# addr n)+    {-# INLINE primAddrIndex #-}+    primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWideCharOffAddr# addr n s1 in (# s2, C# r #)+    {-# INLINE primAddrRead #-}+    primAddrWrite addr (Offset (I# n)) (C# w) = primitive $ \s1 -> (# writeWideCharOffAddr# addr n w s1, () #)+    {-# INLINE primAddrWrite #-}++instance PrimType CChar where+    primSizeInBytes _ = CountOf 1+    {-# INLINE primSizeInBytes #-}+    primShiftToBytes _ = 0+    {-# INLINE primShiftToBytes #-}+    primBaUIndex ba (Offset n) = CChar (primBaUIndex ba (Offset n))+    {-# INLINE primBaUIndex #-}+    primMbaURead mba (Offset n) = CChar <$> primMbaURead mba (Offset n)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset n) (CChar int8) = primMbaUWrite mba (Offset n) int8+    {-# INLINE primMbaUWrite #-}+    primAddrIndex addr (Offset n) = CChar $ primAddrIndex addr (Offset n)+    {-# INLINE primAddrIndex #-}+    primAddrRead addr (Offset n) = CChar <$> primAddrRead addr (Offset n)+    {-# INLINE primAddrRead #-}+    primAddrWrite addr (Offset n) (CChar int8) = primAddrWrite addr (Offset n) int8+    {-# INLINE primAddrWrite #-}+instance PrimType CUChar where+    primSizeInBytes _ = CountOf 1+    {-# INLINE primSizeInBytes #-}+    primShiftToBytes _ = 0+    {-# INLINE primShiftToBytes #-}+    primBaUIndex ba (Offset n) = CUChar (primBaUIndex ba (Offset n :: Offset Word8))+    {-# INLINE primBaUIndex #-}+    primMbaURead mba (Offset n) = CUChar <$> primMbaURead mba (Offset n :: Offset Word8)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset n) (CUChar w8) = primMbaUWrite mba (Offset n) w8+    {-# INLINE primMbaUWrite #-}+    primAddrIndex addr (Offset n) = CUChar $ primAddrIndex addr (Offset n :: Offset Word8)+    {-# INLINE primAddrIndex #-}+    primAddrRead addr (Offset n) = CUChar <$> primAddrRead addr (Offset n :: Offset Word8)+    {-# INLINE primAddrRead #-}+    primAddrWrite addr (Offset n) (CUChar w8) = primAddrWrite addr (Offset n) w8+    {-# INLINE primAddrWrite #-}++instance PrimType Char7 where+    primSizeInBytes _ = CountOf 1+    {-# INLINE primSizeInBytes #-}+    primShiftToBytes _ = 0+    {-# INLINE primShiftToBytes #-}+    primBaUIndex ba (Offset n) = Char7 (primBaUIndex ba (Offset n :: Offset Word8))+    {-# INLINE primBaUIndex #-}+    primMbaURead mba (Offset n) = Char7 <$> primMbaURead mba (Offset n :: Offset Word8)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset n) (Char7 w8) = primMbaUWrite mba (Offset n) w8+    {-# INLINE primMbaUWrite #-}+    primAddrIndex addr (Offset n) = Char7 $ primAddrIndex addr (Offset n :: Offset Word8)+    {-# INLINE primAddrIndex #-}+    primAddrRead addr (Offset n) = Char7 <$> primAddrRead addr (Offset n :: Offset Word8)+    {-# INLINE primAddrRead #-}+    primAddrWrite addr (Offset n) (Char7 w8) = primAddrWrite addr (Offset n) w8+    {-# INLINE primAddrWrite #-}++instance PrimType a => PrimType (LE a) where+    primSizeInBytes _ = primSizeInBytes (Proxy :: Proxy a)+    {-# INLINE primSizeInBytes #-}+    primShiftToBytes _ = primShiftToBytes (Proxy :: Proxy a)+    {-# INLINE primShiftToBytes #-}+    primBaUIndex ba (Offset a) = LE $ primBaUIndex ba (Offset a)+    {-# INLINE primBaUIndex #-}+    primMbaURead ba (Offset a) = LE <$> primMbaURead ba (Offset a)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset a) (LE w) = primMbaUWrite mba (Offset a) w+    {-# INLINE primMbaUWrite #-}+    primAddrIndex addr (Offset a) = LE $ primAddrIndex addr (Offset a)+    {-# INLINE primAddrIndex #-}+    primAddrRead addr (Offset a) = LE <$> primAddrRead addr (Offset a)+    {-# INLINE primAddrRead #-}+    primAddrWrite addr (Offset a) (LE w) = primAddrWrite addr (Offset a) w+    {-# INLINE primAddrWrite #-}+instance PrimType a => PrimType (BE a) where+    primSizeInBytes _ = primSizeInBytes (Proxy :: Proxy a)+    {-# INLINE primSizeInBytes #-}+    primShiftToBytes _ = primShiftToBytes (Proxy :: Proxy a)+    {-# INLINE primShiftToBytes #-}+    primBaUIndex ba (Offset a) = BE $ primBaUIndex ba (Offset a)+    {-# INLINE primBaUIndex #-}+    primMbaURead ba (Offset a) = BE <$> primMbaURead ba (Offset a)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset a) (BE w) = primMbaUWrite mba (Offset a) w+    {-# INLINE primMbaUWrite #-}+    primAddrIndex addr (Offset a) = BE $ primAddrIndex addr (Offset a)+    {-# INLINE primAddrIndex #-}+    primAddrRead addr (Offset a) = BE <$> primAddrRead addr (Offset a)+    {-# INLINE primAddrRead #-}+    primAddrWrite addr (Offset a) (BE w) = primAddrWrite addr (Offset a) w+    {-# INLINE primAddrWrite #-}++-- | A constraint class for serializable type that have an unique+-- memory compare representation+--+-- e.g. Float and Double have -0.0 and 0.0 which are Eq individual,+-- yet have a different memory representation which doesn't allow+-- for memcmp operation+class PrimMemoryComparable ty where++instance PrimMemoryComparable Int where+instance PrimMemoryComparable Word where+instance PrimMemoryComparable Word8 where+instance PrimMemoryComparable Word16 where+instance PrimMemoryComparable Word32 where+instance PrimMemoryComparable Word64 where+instance PrimMemoryComparable Int8 where+instance PrimMemoryComparable Int16 where+instance PrimMemoryComparable Int32 where+instance PrimMemoryComparable Int64 where+instance PrimMemoryComparable Char where+instance PrimMemoryComparable CChar where+instance PrimMemoryComparable CUChar where+instance PrimMemoryComparable a => PrimMemoryComparable (LE a) where+instance PrimMemoryComparable a => PrimMemoryComparable (BE a) where++-- | Cast a CountOf linked to type A (CountOf A) to a CountOf linked to type B (CountOf B)+sizeRecast :: forall a b . (PrimType a, PrimType b) => CountOf a -> CountOf b+sizeRecast sz = CountOf (bytes `Prelude.quot` szB)+  where !szA             = primSizeInBytes (Proxy :: Proxy a)+        !(CountOf szB)   = primSizeInBytes (Proxy :: Proxy b)+        !(CountOf bytes) = sizeOfE szA sz+{-# INLINE [1] sizeRecast #-}+{-# RULES "sizeRecast from Word8" [2] forall a . sizeRecast a = sizeRecastBytes a #-}++sizeRecastBytes :: forall b . PrimType b => CountOf Word8 -> CountOf b+sizeRecastBytes (CountOf w) = CountOf (w `Prelude.quot` szB)+  where !(CountOf szB) = primSizeInBytes (Proxy :: Proxy b)+{-# INLINE [1] sizeRecastBytes #-}++sizeInBytes :: forall a . PrimType a => CountOf a -> CountOf Word8+sizeInBytes sz = sizeOfE (primSizeInBytes (Proxy :: Proxy a)) sz++offsetInBytes :: forall a . PrimType a => Offset a -> Offset Word8+offsetInBytes ofs = offsetShiftL (primShiftToBytes (Proxy :: Proxy a)) ofs+{-# INLINE [2] offsetInBytes #-}+{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word64 -> Offset Word8 #-}+{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word32 -> Offset Word8 #-}+{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word16 -> Offset Word8 #-}+{-# RULES "offsetInBytes Bytes" [3] forall x . offsetInBytes x = x #-}++offsetInElements :: forall a . PrimType a => Offset Word8 -> Offset a+offsetInElements ofs = offsetShiftR (primShiftToBytes (Proxy :: Proxy a)) ofs+{-# INLINE [2] offsetInElements #-}+{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word64 -> Offset Word8 #-}+{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word32 -> Offset Word8 #-}+{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word16 -> Offset Word8 #-}+{-# RULES "offsetInElements Bytes" [3] forall x . offsetInElements x = x #-}++primOffsetRecast :: forall a b . (PrimType a, PrimType b) => Offset a -> Offset b+primOffsetRecast !ofs =+    let !(Offset bytes) = offsetOfE szA ofs+     in Offset (bytes `Prelude.quot` szB)+  where+    !szA        = primSizeInBytes (Proxy :: Proxy a)+    !(CountOf szB) = primSizeInBytes (Proxy :: Proxy b)+{-# INLINE [1] primOffsetRecast #-}+{-# RULES "primOffsetRecast W8" [3] forall a . primOffsetRecast a = primOffsetRecastBytes a #-}++offsetIsAligned :: forall a . PrimType a => Proxy a -> Offset Word8 -> Bool+offsetIsAligned _ (Offset ofs) = (ofs .&. mask) == 0+   where (CountOf sz) = primSizeInBytes (Proxy :: Proxy a)+         mask = sz - 1+{-# INLINE [1] offsetIsAligned #-}+{-# SPECIALIZE [3] offsetIsAligned :: Proxy Word64 -> Offset Word8 -> Bool #-}+{-# RULES "offsetInAligned Bytes" [3] forall (prx :: Proxy Word8) x . offsetIsAligned prx x = True #-}++primOffsetRecastBytes :: forall b . PrimType b => Offset Word8 -> Offset b+primOffsetRecastBytes (Offset 0) = Offset 0+primOffsetRecastBytes (Offset o) = Offset (szA `Prelude.quot` o)+  where !(CountOf szA) = primSizeInBytes (Proxy :: Proxy b)+{-# INLINE [1] primOffsetRecastBytes #-}++primOffsetOfE :: forall a . PrimType a => Offset a -> Offset Word8+primOffsetOfE = offsetInBytes+{-# DEPRECATED primOffsetOfE "use offsetInBytes" #-}++primWordGetByteAndShift :: Word# -> (# Word#, Word# #)+primWordGetByteAndShift w = (# and# w 0xff##, uncheckedShiftRL# w 8# #)+{-# INLINE primWordGetByteAndShift #-}++#if WORD_SIZE_IN_BITS == 64+primWord64GetByteAndShift :: Word# -> (# Word#, Word# #)+primWord64GetByteAndShift = primWord64GetByteAndShift++primWord64GetHiLo :: Word# -> (# Word#, Word# #)+primWord64GetHiLo w = (# uncheckedShiftRL# w 32# , and# w 0xffffffff## #)+#else+primWord64GetByteAndShift :: Word64# -> (# Word#, Word64# #)+primWord64GetByteAndShift w = (# and# (word64ToWord# w) 0xff##, uncheckedShiftRL64# w 8# #)++primWord64GetHiLo :: Word64# -> (# Word#, Word# #)+primWord64GetHiLo w = (# word64ToWord# (uncheckedShiftRL64# w 32#), word64ToWord# w #)+#endif+{-# INLINE primWord64GetByteAndShift #-}
+ Basement/Runtime.hs view
@@ -0,0 +1,31 @@+-- |+-- Module      : Basement.Runtime+-- License     : BSD-style+-- Maintainer  : foundation+--+-- Global configuration environment+module Basement.Runtime+    where++import           Basement.Compat.Base+import           Basement.Types.OffsetSize+import           System.Environment+import           System.IO.Unsafe (unsafePerformIO)+import           Text.Read        (readMaybe)++-- | Defines the maximum size in bytes of unpinned arrays.+--+-- You can change this value by setting the environment variable+-- @HS_FOUNDATION_UARRAY_UNPINNED_MAX@ to an unsigned integer number.+--+-- Note: We use 'unsafePerformIO' here. If the environment variable+-- changes during runtime and the runtime system decides to recompute+-- this value, referential transparency is violated (like the First+-- Order violated the Galactic Concordance!).+--+-- TODO The default value of 1024 bytes is arbitrarily chosen for now.+unsafeUArrayUnpinnedMaxSize :: CountOf Word8+unsafeUArrayUnpinnedMaxSize = unsafePerformIO $ do+    maxSize <- (>>= readMaybe) <$> lookupEnv "HS_FOUNDATION_UARRAY_UNPINNED_MAX"+    pure $ maybe (CountOf 1024) CountOf maxSize+{-# NOINLINE unsafeUArrayUnpinnedMaxSize #-}
+ Basement/Show.hs view
@@ -0,0 +1,14 @@+module Basement.Show+    where++import qualified Prelude+import           Basement.Compat.Base+import           Basement.UTF8.Base (String)++-- | Use the Show class to create a String.+--+-- Note that this is not efficient, since+-- an intermediate [Char] is going to be+-- created before turning into a real String.+show :: Prelude.Show a => a -> String+show = fromList . Prelude.show
+ Basement/String.hs view
@@ -0,0 +1,1403 @@+-- |+-- Module      : Basement.String+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : portable+--+-- A String type backed by a UTF8 encoded byte array and all the necessary+-- functions to manipulate the string.+--+-- You can think of String as a specialization of a byte array that+-- have element of type Char.+--+-- The String data must contain UTF8 valid data.+--+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE NoImplicitPrelude          #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UnboxedTuples              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE CPP                        #-}+module Basement.String+    ( String(..)+    , MutableString(..)+    , create+    , replicate+    , length+    -- * Binary conversion+    , Encoding(..)+    , fromBytes+    , fromChunkBytes+    , fromBytesUnsafe+    , fromBytesLenient+    , toBytes+    , mutableValidate+    , copy+    , ValidationFailure(..)+    , index+    , null+    , drop+    , take+    , splitAt+    , revDrop+    , revTake+    , revSplitAt+    , splitOn+    , sub+    , elem+    , indices+    , intersperse+    , span+    , break+    , breakElem+    , breakLine+    , dropWhile+    , singleton+    , charMap+    , snoc+    , cons+    , unsnoc+    , uncons+    , find+    , findIndex+    , sortBy+    , filter+    , reverse+    , replace+    , builderAppend+    , builderBuild+    , builderBuild_+    , readInteger+    , readIntegral+    , readNatural+    , readDouble+    , readRational+    , readFloatingExact+    , upper+    , lower+    , isPrefixOf+    , isSuffixOf+    , isInfixOf+    , stripPrefix+    , stripSuffix+    , all+    , any+    -- * Legacy utility+    , lines+    , words+    , toBase64+    , toBase64URL+    , toBase64OpenBSD+    ) where++import           Basement.UArray           (UArray)+import qualified Basement.UArray           as Vec+import qualified Basement.UArray           as C+import qualified Basement.UArray.Mutable   as MVec+import           Basement.Compat.Bifunctor+import           Basement.Compat.Base+import           Basement.Compat.Natural+import           Basement.Compat.MonadTrans+import           Basement.Compat.Primitive+import           Basement.Types.OffsetSize+import           Basement.Numerical.Additive+import           Basement.Numerical.Subtractive+import           Basement.Numerical.Multiplicative+import           Basement.Numerical.Number+import           Basement.Monad+import           Basement.PrimType+import           Basement.FinalPtr+import           Basement.IntegralConv+import           Basement.Floating+import           Basement.MutableBuilder+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.UTF8.BA as PrimBA+import qualified Basement.UTF8.Addr as PrimAddr+import qualified Basement.String.BA as BackendBA+import qualified Basement.String.Addr as BackendAddr+import           GHC.Prim+import           GHC.ST+import           GHC.Types+import           GHC.Word+#if MIN_VERSION_base(4,9,0)+import           GHC.Char+#endif++ -- temporary+import qualified Data.List+import           Data.Ratio+import           Data.Char (toUpper, toLower)+import qualified Prelude++import qualified Basement.String.Encoding.Encoding   as Encoder+import qualified Basement.String.Encoding.ASCII7     as Encoder+import qualified Basement.String.Encoding.UTF16      as Encoder+import qualified Basement.String.Encoding.UTF32      as Encoder+import qualified Basement.String.Encoding.ISO_8859_1 as Encoder++-- | UTF8 Encoder+data EncoderUTF8 = EncoderUTF8++instance Encoder.Encoding EncoderUTF8 where+    type Unit EncoderUTF8 = Word8+    type Error EncoderUTF8 = ValidationFailure+    encodingNext  _ = \ofs -> Right . nextWithIndexer ofs+    encodingWrite _ = writeWithBuilder++-- | Validate a bytearray for UTF8'ness+--+-- On success Nothing is returned+-- On Failure the position along with the failure reason+validate :: UArray Word8+         -> Offset8+         -> CountOf Word8+         -> (Offset8, Maybe ValidationFailure)+validate array ofsStart sz = C.unsafeDewrap goBa goAddr array+  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)+    end = ofsStart `offsetPlusE` sz++-- | Similar to 'validate' but works on a 'MutableByteArray'+mutableValidate :: PrimMonad prim+                => MVec.MUArray Word8 (PrimState prim)+                -> Offset Word8+                -> CountOf Word8+                -> prim (Offset Word8, Maybe ValidationFailure)+mutableValidate mba ofsStart sz = do+    loop ofsStart+  where+    end = ofsStart `offsetPlusE` sz++    loop ofs+        | ofs > end  = error "mutableValidate: internal error: went pass offset"+        | ofs == end = return (end, Nothing)+        | otherwise  = do+            r <- one ofs+            case r of+                (nextOfs, Nothing)  -> loop nextOfs+                (pos, Just failure) -> return (pos, Just failure)++    one pos = do+        h <- Vec.unsafeRead mba pos+        let nbConts = getNbBytes h+        if nbConts == 0xff+            then return (pos, Just InvalidHeader)+            else if pos + 1 + Offset nbConts > end+                then return (pos, Just MissingByte)+                else do+                    case nbConts of+                        0 -> return (pos + 1, Nothing)+                        1 -> do+                            c1 <- Vec.unsafeRead mba (pos + 1)+                            if isContinuation c1+                                then return (pos + 2, Nothing)+                                else return (pos, Just InvalidContinuation)+                        2 -> do+                            c1 <- Vec.unsafeRead mba (pos + 1)+                            c2 <- Vec.unsafeRead mba (pos + 2)+                            if isContinuation c1 && isContinuation c2+                                then return (pos + 3, Nothing)+                                else return (pos, Just InvalidContinuation)+                        3 -> do+                            c1 <- Vec.unsafeRead mba (pos + 1)+                            c2 <- Vec.unsafeRead mba (pos + 2)+                            c3 <- Vec.unsafeRead mba (pos + 3)+                            if isContinuation c1 && isContinuation c2 && isContinuation c3+                                then return (pos + 4, Nothing)+                                else return (pos, Just InvalidContinuation)+                        _ -> error "internal error"++nextWithIndexer :: (Offset Word8 -> Word8)+                -> Offset Word8+                -> (Char, Offset Word8)+nextWithIndexer getter off =+    case getNbBytes# h of+        0# -> (toChar h, off + 1)+        1# -> (toChar (decode2 (getter $ off + 1)), off + 2)+        2# -> (toChar (decode3 (getter $ off + 1) (getter $ off + 2)), off + 3)+        3# -> (toChar (decode4 (getter $ off + 1) (getter $ off + 2) (getter $ off + 3))+              , off + 4)+        r -> error ("next: internal error: invalid input: " <> show (I# r) <> " " <> show (W# h))+  where+    !(W8# h) = getter off++    toChar :: Word# -> Char+    toChar w = C# (chr# (word2Int# w))++    decode2 :: Word8 -> Word#+    decode2 (W8# c1) =+        or# (uncheckedShiftL# (and# h 0x1f##) 6#)+            (and# c1 0x3f##)++    decode3 :: Word8 -> Word8 -> Word#+    decode3 (W8# c1) (W8# c2) =+        or# (uncheckedShiftL# (and# h 0xf##) 12#)+            (or# (uncheckedShiftL# (and# c1 0x3f##) 6#)+                 (and# c2 0x3f##))++    decode4 :: Word8 -> Word8 -> Word8 -> Word#+    decode4 (W8# c1) (W8# c2) (W8# c3) =+        or# (uncheckedShiftL# (and# h 0x7##) 18#)+            (or# (uncheckedShiftL# (and# c1 0x3f##) 12#)+                (or# (uncheckedShiftL# (and# c2 0x3f##) 6#)+                    (and# c3 0x3f##))+            )++writeWithBuilder :: (PrimMonad st, Monad st)+                 => Char+                 -> Builder (UArray Word8) (MVec.MUArray Word8) Word8 st err ()+writeWithBuilder 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 = Vec.builderAppend (W8# x)++    encode2 = do+        let x1  = or# (uncheckedShiftRL# x 6#) 0xc0##+            x2  = toContinuation x+        Vec.builderAppend (W8# x1) >> Vec.builderAppend (W8# x2)++    encode3 = do+        let x1  = or# (uncheckedShiftRL# x 12#) 0xe0##+            x2  = toContinuation (uncheckedShiftRL# x 6#)+            x3  = toContinuation x+        Vec.builderAppend (W8# x1) >> Vec.builderAppend (W8# x2) >> Vec.builderAppend (W8# x3)++    encode4 = do+        let x1  = or# (uncheckedShiftRL# x 18#) 0xf0##+            x2  = toContinuation (uncheckedShiftRL# x 12#)+            x3  = toContinuation (uncheckedShiftRL# x 6#)+            x4  = toContinuation x+        Vec.builderAppend (W8# x1) >> Vec.builderAppend (W8# x2) >> Vec.builderAppend (W8# x3) >> Vec.builderAppend (W8# x4)++    toContinuation :: Word# -> Word#+    toContinuation w = or# (and# w 0x3f##) 0x80##++writeUTF8Char :: PrimMonad prim => MutableString (PrimState prim) -> Offset8 -> UTF8Char -> prim ()+writeUTF8Char (MutableString mba) i (UTF8_1 x1) =+    Vec.unsafeWrite mba i     x1+writeUTF8Char (MutableString mba) i (UTF8_2 x1 x2) = do+    Vec.unsafeWrite mba i     x1+    Vec.unsafeWrite mba (i+1) x2+writeUTF8Char (MutableString mba) i (UTF8_3 x1 x2 x3) = do+    Vec.unsafeWrite mba i     x1+    Vec.unsafeWrite mba (i+1) x2+    Vec.unsafeWrite mba (i+2) x3+writeUTF8Char (MutableString mba) i (UTF8_4 x1 x2 x3 x4) = do+    Vec.unsafeWrite mba i     x1+    Vec.unsafeWrite mba (i+1) x2+    Vec.unsafeWrite mba (i+2) x3+    Vec.unsafeWrite mba (i+3) x4+{-# INLINE writeUTF8Char #-}++unsafeFreezeShrink :: PrimMonad prim => MutableString (PrimState prim) -> CountOf Word8 -> prim String+unsafeFreezeShrink (MutableString mba) s = String <$> Vec.unsafeFreezeShrink mba s+{-# INLINE unsafeFreezeShrink #-}++------------------------------------------------------------------------+-- real functions++-- | Check if a String is null+null :: String -> Bool+null (String ba) = C.length ba == 0++-- we don't know in constant time the count of character in string,+-- however if we estimate bounds of what N characters would+-- take in space (between N and N*4). If the count is thus bigger than+-- the number of bytes, then we know for sure that it's going to+-- be out of bounds+countCharMoreThanBytes :: CountOf Char -> UArray Word8 -> Bool+countCharMoreThanBytes (CountOf chars) ba = chars >= bytes+  where (CountOf bytes) = C.length ba++-- | Create a string composed of a number @n of Chars (Unicode code points).+--+-- if the input @s contains less characters than required, then the input string is returned.+take :: CountOf Char -> String -> String+take n s@(String ba)+    | n <= 0                      = mempty+    | countCharMoreThanBytes n ba = s+    | otherwise                   = String $ Vec.unsafeTake (offsetAsSize $ indexN n s) ba++-- | Create a string with the remaining Chars after dropping @n Chars from the beginning+drop :: CountOf Char -> String -> String+drop n s@(String ba)+    | n <= 0                      = s+    | countCharMoreThanBytes n ba = mempty+    | otherwise                   = String $ Vec.drop (offsetAsSize $ indexN n s) ba++-- | Split a string at the Offset specified (in Char) returning both+-- the leading part and the remaining part.+splitAt :: CountOf Char -> String -> (String, String)+splitAt n s@(String ba)+    | n <= 0                      = (mempty, s)+    | countCharMoreThanBytes n ba = (s, mempty)+    | otherwise                   =+        let (v1,v2) = C.splitAt (offsetAsSize $ indexN n s) ba+         in (String v1, String v2)++-- | Return the offset (in bytes) of the N'th sequence in an UTF8 String+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+      where+        !len = start `offsetPlusE` Vec.length ba+        loop :: Offset Word8 -> Offset Char -> Offset Word8+        loop !idx !i+            | idx >= len || i .==# n = sizeAsOffset (idx - start)+            | otherwise              = loop (idx `offsetPlusE` d) (i + Offset 1)+          where d = skipNextHeaderValue (primBaIndex ma idx)+    {-# INLINE goVec #-}++    goAddr :: Ptr Word8 -> Offset Word8 -> ST s (Offset Word8)+    goAddr (Ptr ptr) !start = return $ loop start (Offset 0)+      where+        !len = start `offsetPlusE` Vec.length ba+        loop :: Offset Word8 -> Offset Char -> Offset Word8+        loop !idx !i+            | idx >= len || i .==# n = sizeAsOffset (idx - start)+            | otherwise              = loop (idx `offsetPlusE` d) (i + Offset 1)+          where d = skipNextHeaderValue (primAddrIndex ptr idx)+    {-# INLINE goAddr #-}+{-# INLINE indexN #-}++-- inverse a CountOf that is specified from the end (e.g. take n Chars from the end)+--+-- rev{Take,Drop,SplitAt} TODO optimise:+-- we can process the string from the end using a skipPrev instead of getting the length+countFromStart :: String -> CountOf Char -> CountOf Char+countFromStart s sz@(CountOf sz')+    | sz >= len = CountOf 0+    | otherwise = CountOf (len' - sz')+  where len@(CountOf len') = length s++-- | Similar to 'take' but from the end+revTake :: CountOf Char -> String -> String+revTake n v = drop (countFromStart v n) v++-- | Similar to 'drop' but from the end+revDrop :: CountOf Char -> String -> String+revDrop n v = take (countFromStart v n) v++-- | Similar to 'splitAt' but from the end+revSplitAt :: CountOf Char -> String -> (String, String)+revSplitAt n v = (drop idx v, take idx v) where idx = countFromStart v n++-- | Split on the input string using the predicate as separator+--+-- e.g.+--+-- > splitOn (== ',') ","          == ["",""]+-- > splitOn (== ',') ",abc,"      == ["","abc",""]+-- > splitOn (== ':') "abc"        == ["abc"]+-- > splitOn (== ':') "abc::def"   == ["abc","","def"]+-- > splitOn (== ':') "::abc::def" == ["","","abc","","def"]+--+splitOn :: (Char -> Bool) -> String -> [String]+splitOn predicate s+    | sz == CountOf 0 = [mempty]+    | otherwise    = loop azero azero+  where+    !sz = size s+    end = azero `offsetPlusE` sz+    loop prevIdx idx+        | idx == end = [sub s prevIdx idx]+        | otherwise =+            let !(Step c idx') = next s idx+             in if predicate c+                    then sub s prevIdx idx : loop idx' idx'+                    else loop prevIdx idx'++-- | Internal call to make a substring given offset in bytes.+--+-- This is unsafe considering that one can create a substring+-- starting and/or ending on the middle of a UTF8 sequence.+sub :: String -> Offset8 -> Offset8 -> String+sub (String ba) start end = String $ Vec.sub ba start end++-- | Internal call to split at a given index in offset of bytes.+--+-- This is unsafe considering that one can split in the middle of a+-- UTF8 sequence, so use with care.+splitIndex :: Offset8 -> String -> (String, String)+splitIndex idx (String ba) = (String v1, String v2)+  where (v1,v2) = C.splitAt (offsetAsSize idx) ba++-- | Break a string into 2 strings at the location where the predicate return True+break :: (Char -> Bool) -> String -> (String, String)+break predicate s@(String ba) = runST $ Vec.unsafeIndexer ba go+  where+    !sz = size s+    end = azero `offsetPlusE` sz++    go :: (Offset Word8 -> Word8) -> ST st (String, String)+    go getIdx = loop (Offset 0)+      where+        !nextI = nextWithIndexer getIdx+        loop idx+            | idx == end = return (s, mempty)+            | otherwise  = do+                let (c, idx') = nextI idx+                case predicate c of+                    True  -> return $ splitIndex idx s+                    False -> loop idx'+        {-# INLINE loop #-}+{-# INLINE [2] break #-}++#if MIN_VERSION_base(4,9,0)+{-# RULES "break (== 'c')" [3] forall c . break (eqChar c) = breakElem c #-}+#else+{-# RULES "break (== 'c')" [3] forall c . break (== c) = breakElem c #-}+#endif++-- | Break a string into 2 strings at the first occurence of the character+breakElem :: Char -> String -> (String, String)+breakElem !el s@(String ba)+    | sz == 0   = (mempty, mempty)+    | otherwise =+        case asUTF8Char el of+            UTF8_1 w -> let !(v1,v2) = Vec.breakElem w ba in (String v1, String v2)+            _        -> runST $ Vec.unsafeIndexer ba go+  where+    sz = size s+    end = azero `offsetPlusE` sz++    go :: (Offset Word8 -> Word8) -> ST st (String, String)+    go getIdx = loop (Offset 0)+      where+        !nextI = nextWithIndexer getIdx+        loop idx+            | idx == end = return (s, mempty)+            | otherwise  = do+                let (c, idx') = nextI idx+                case el == c of+                    True  -> return $ splitIndex idx s+                    False -> loop idx'++-- | Same as break but cut on a line feed with an optional carriage return.+--+-- This is the same operation as 'breakElem LF' dropping the last character of the+-- string if it's a CR.+--+-- Also for efficiency reason (streaming), it returns if the last character was a CR character.+breakLine :: String -> Either Bool (String, String)+breakLine (String arr) = bimap String String <$> Vec.breakLine arr++-- | Apply a @predicate@ to the string to return the longest prefix that satisfy the predicate and+-- the remaining+span :: (Char -> Bool) -> String -> (String, String)+span predicate s = break (not . predicate) s++-- | Drop character from the beginning while the predicate is true+dropWhile :: (Char -> Bool) -> String -> String+dropWhile predicate = snd . break (not . predicate)++-- | Return whereas the string contains a specific character or not+elem :: Char -> String -> Bool+elem !el s@(String ba) =+    case asUTF8Char el of+        UTF8_1 w -> Vec.elem w ba+        _        -> runST $ Vec.unsafeIndexer ba go+  where+    sz = size s+    end = azero `offsetPlusE` sz++    go :: (Offset Word8 -> Word8) -> ST st Bool+    go getIdx = loop (Offset 0)+      where+        !nextI = nextWithIndexer getIdx+        loop !idx+            | idx == end = return False+            | otherwise  = do+                let (c, idx') = nextI idx+                case el == c of+                    True  -> return True+                    False -> loop idx'++-- | Intersperse the character @sep@ between each character in the string+--+-- > intersperse ' ' "Hello Foundation"+-- "H e l l o   F o u n d a t i o n"+intersperse :: Char -> String -> String+intersperse sep src = case length src - 1 of+    Nothing   -> src+    Just 0    -> src+    Just gaps -> runST $ unsafeCopyFrom src dstBytes go+        where+          lastSrcI :: Offset Char+          lastSrcI = 0 `offsetPlusE` gaps+          dstBytes = (size src :: CountOf Word8) + (gaps `scale` charToBytes (fromEnum sep))++          go :: String -> Offset Char -> Offset8 -> MutableString s -> Offset8 -> ST s (Offset8, Offset8)+          go src' srcI srcIdx dst dstIdx+              | srcI == lastSrcI = do+                  nextDstIdx <- write dst dstIdx c+                  return (nextSrcIdx, nextDstIdx)+              | otherwise        = do+                  nextDstIdx  <- write dst dstIdx c+                  nextDstIdx' <- write dst nextDstIdx sep+                  return (nextSrcIdx, nextDstIdx')+            where+              !(Step c nextSrcIdx) = next src' srcIdx++-- | Allocate a new @String@ with a fill function that has access to the characters of+--   the source @String@.+unsafeCopyFrom :: String -- ^ Source string+               -> CountOf Word8  -- ^ Length of the destination string in bytes+               -> (String -> Offset Char -> Offset8 -> MutableString s -> Offset8 -> ST s (Offset8, Offset8))+               -- ^ Function called for each character in the source String+               -> ST s String -- ^ Returns the filled new string+unsafeCopyFrom src dstBytes f = new dstBytes >>= fill (Offset 0) (Offset 0) (Offset 0) f >>= freeze+  where+    srcLen = length src+    end = Offset 0 `offsetPlusE` srcLen+    fill srcI srcIdx dstIdx f' dst'+        | srcI == end = return dst'+        | otherwise = do (nextSrcIdx, nextDstIdx) <- f' src srcI srcIdx dst' dstIdx+                         fill (srcI + Offset 1) nextSrcIdx nextDstIdx f' dst'++-- | Length of a String using CountOf+--+-- this size is available in o(n)+length :: String -> CountOf Char+length (String arr)+    | start == end = 0+    | otherwise    = C.onBackend goVec (\_ -> pure . goAddr) arr+  where+    (C.ValidRange !start !end) = offsetsValidRange arr+    goVec ma = PrimBA.length ma start end+    goAddr (Ptr ptr) = PrimAddr.length ptr start end++-- | Replicate a character @c@ @n@ times to create a string of length @n@+replicate :: CountOf Char -> Char -> String+replicate (CountOf n) c = runST (new nbBytes >>= fill)+  where+    nbBytes   = scale (integralCast n :: Word) sz+    sz = charToBytes (fromEnum c)+    fill :: PrimMonad prim => MutableString (PrimState prim) -> prim String+    fill ms = loop (Offset 0)+      where+        loop idx+            | idx .==# nbBytes = freeze ms+            | otherwise        = write ms idx c >>= loop++-- | Copy the String+--+-- The slice of memory is copied to a new slice, making the new string+-- independent from the original string..+copy :: String -> String+copy (String s) = String (Vec.copy s)++-- | Create a single element String+singleton :: Char -> String+singleton c = runST $ do+    ms <- new nbBytes+    _  <- write ms (Offset 0) c+    freeze ms+  where+    !nbBytes = charToBytes (fromEnum c)++-- | Unsafely create a string of up to @sz@ bytes.+--+-- The callback @f@ needs to return the number of bytes filled in the underlaying+-- bytes buffer. No check is made on the callback return values, and if it's not+-- contained without the bounds, bad things will happen.+create :: PrimMonad prim => CountOf Word8 -> (MutableString (PrimState prim) -> prim (Offset Word8)) -> prim String+create sz f = do+    ms     <- new sz+    filled <- f ms+    if filled .==# sz+        then freeze ms+        else do+            (String ba) <- freeze ms+            pure $ String $ C.take (offsetAsSize filled) ba++-- | Monomorphically map the character in a string and return the transformed one+charMap :: (Char -> Char) -> String -> String+charMap f src+    | srcSz == 0 = mempty+    | otherwise  =+        let !(elems, nbBytes) = allocateAndFill [] (Offset 0) (CountOf 0)+         in runST $ do+                dest <- new nbBytes+                copyLoop dest elems (Offset 0 `offsetPlusE` nbBytes)+                freeze dest+  where+    !srcSz = size src+    srcEnd = azero `offsetPlusE` srcSz++    allocateAndFill :: [(String, CountOf Word8)]+                    -> Offset8+                    -> CountOf Word8+                    -> ([(String,CountOf Word8)], CountOf Word8)+    allocateAndFill acc idx bytesWritten+        | idx == srcEnd = (acc, bytesWritten)+        | otherwise     =+            let (el@(_,addBytes), idx') = runST $ do+                    -- make sure we allocate at least 4 bytes for the destination for the last few bytes+                    -- otherwise allocating less would bring the danger of spinning endlessly+                    -- and never succeeding.+                    let !diffBytes = srcEnd - idx+                        !allocatedBytes = if diffBytes <= CountOf 4 then CountOf 4 else diffBytes+                    ms <- new allocatedBytes+                    (dstIdx, srcIdx) <- fill ms allocatedBytes idx+                    s <- freeze ms+                    return ((s, dstIdx), srcIdx)+             in allocateAndFill (el : acc) idx' (bytesWritten + addBytes)++    fill :: PrimMonad prim+         => MutableString (PrimState prim)+         -> CountOf Word8+         -> Offset8+         -> prim (CountOf Word8, Offset8)+    fill mba dsz srcIdxOrig =+        loop (Offset 0) srcIdxOrig+      where+        endDst = (Offset 0) `offsetPlusE` dsz+        loop dstIdx srcIdx+            | srcIdx == srcEnd = return (offsetAsSize dstIdx, srcIdx)+            | dstIdx == endDst = return (offsetAsSize dstIdx, srcIdx)+            | otherwise        =+                let !(Step c srcIdx') = next src srcIdx+                    c' = f c -- the mapped char+                    !nbBytes = charToBytes (fromEnum c')+                 in -- check if we have room in the destination buffer+                    if dstIdx `offsetPlusE` nbBytes <= sizeAsOffset dsz+                        then do dstIdx' <- write mba dstIdx c'+                                loop dstIdx' srcIdx'+                        else return (offsetAsSize dstIdx, srcIdx)++    copyLoop _   []     (Offset 0) = return ()+    copyLoop _   []     n          = error ("charMap invalid: " <> show n)+    copyLoop ms@(MutableString mba) ((String ba, sz):xs) end = do+        let start = end `offsetMinusE` sz+        Vec.unsafeCopyAtRO mba start ba (Offset 0) sz+        copyLoop ms xs start++-- | Append a Char to the end of the String and return this new String+snoc :: String -> Char -> String+snoc s@(String ba) c+    | len == CountOf 0 = singleton c+    | otherwise     = runST $ do+        ms@(MutableString mba) <- new (len + nbBytes)+        Vec.unsafeCopyAtRO mba (Offset 0) ba (Offset 0) len+        _ <- write ms (azero `offsetPlusE` len) c+        freeze ms+  where+    !len     = size s+    !nbBytes = charToBytes (fromEnum c)++-- | Prepend a Char to the beginning of the String and return this new String+cons :: Char -> String -> String+cons c s@(String ba)+  | len == CountOf 0 = singleton c+  | otherwise     = runST $ do+      ms@(MutableString mba) <- new (len + nbBytes)+      idx <- write ms (Offset 0) c+      Vec.unsafeCopyAtRO mba idx ba (Offset 0) len+      freeze ms+  where+    !len     = size s+    !nbBytes = charToBytes (fromEnum c)++-- | Extract the String stripped of the last character and the last character if not empty+--+-- If empty, Nothing is returned+unsnoc :: String -> Maybe (String, Char)+unsnoc s@(String arr)+    | sz == 0   = Nothing+    | otherwise =+        let !(StepBack c idx) = prev s (sizeAsOffset sz)+         in Just (String $ Vec.take (offsetAsSize idx) arr, c)+  where+    sz = size s++-- | Extract the First character of a string, and the String stripped of the first character.+--+-- If empty, Nothing is returned+uncons :: String -> Maybe (Char, String)+uncons s@(String ba)+    | null s    = Nothing+    | otherwise =+        let !(Step c idx) = next s azero+         in Just (c, String $ Vec.drop (offsetAsSize idx) ba)++-- | Look for a predicate in the String and return the matched character, if any.+find :: (Char -> Bool) -> String -> Maybe Char+find predicate s = loop (Offset 0)+  where+    !sz = size s+    end = Offset 0 `offsetPlusE` sz+    loop idx+        | idx == end = Nothing+        | otherwise =+            let !(Step c idx') = next s idx+             in case predicate c of+                    True  -> Just c+                    False -> loop idx'++-- | Sort the character in a String using a specific sort function+--+-- TODO: optimise not going through a list+sortBy :: (Char -> Char -> Ordering) -> String -> String+sortBy sortF s = fromList $ Data.List.sortBy sortF $ toList s -- FIXME for tests++-- | Filter characters of a string using the predicate+filter :: (Char -> Bool) -> String -> String+filter predicate (String arr) = runST $ do+    (finalSize, dst) <- newNative sz $ \mba ->+        C.onBackendPrim (\ba -> BackendBA.copyFilter predicate sz mba ba start)+                        (\fptr -> withFinalPtr fptr $ \(Ptr addr) -> BackendAddr.copyFilter predicate sz mba addr start)+                        arr+    freezeShrink finalSize dst+  where+    !sz    = C.length arr+    !start = C.offset arr++-- | Reverse a string+reverse :: String -> String+reverse s@(String ba) = runST $ do+    ms <- new len+    loop ms (Offset 0) (Offset 0 `offsetPlusE` len)+  where+    !len = size s+    -- write those bytes+    loop :: PrimMonad prim => MutableString (PrimState prim) -> Offset8 -> Offset8 -> prim String+    loop ms@(MutableString mba) si didx+        | didx == Offset 0 = freeze ms+        | otherwise = do+            let !h = Vec.unsafeIndex ba si+                !nb = CountOf (getNbBytes h + 1)+                d  = didx `offsetMinusE` nb+            case nb of+                CountOf 1 -> Vec.unsafeWrite mba d h+                CountOf 2 -> do+                    Vec.unsafeWrite mba d       h+                    Vec.unsafeWrite mba (d + 1) (Vec.unsafeIndex ba (si + 1))+                CountOf 3 -> do+                    Vec.unsafeWrite mba d       h+                    Vec.unsafeWrite mba (d + 1) (Vec.unsafeIndex ba (si + 1))+                    Vec.unsafeWrite mba (d + 2) (Vec.unsafeIndex ba (si + 2))+                CountOf 4 -> do+                    Vec.unsafeWrite mba d       h+                    Vec.unsafeWrite mba (d + 1) (Vec.unsafeIndex  ba (si + 1))+                    Vec.unsafeWrite mba (d + 2) (Vec.unsafeIndex ba (si + 2))+                    Vec.unsafeWrite mba (d + 3) (Vec.unsafeIndex ba (si + 3))+                _  -> return () -- impossible+            loop ms (si `offsetPlusE` nb) d++-- Finds where are the insertion points when we search for a `needle`+-- within an `haystack`.+indices :: String -> String -> [Offset8]+indices (String ned) (String hy) = Vec.indices ned hy++-- | Replace all the occurrencies of `needle` with `replacement` in+-- the `haystack` string.+replace :: String -> String -> String -> String+replace (String needle) (String replacement) (String haystack) =+  String $ Vec.replace needle replacement haystack++-- | Return the nth character in a String+--+-- Compared to an array, the string need to be scanned from the beginning+-- since the UTF8 encoding is variable.+index :: String -> Offset Char -> Maybe Char+index s n+    | ofs >= end = Nothing+    | otherwise  =+        let (Step !c _) = next s ofs+         in Just c+  where+    !nbBytes = size s+    end = 0 `offsetPlusE` nbBytes+    ofs = indexN (offsetAsSize n) s++-- | Return the index in unit of Char of the first occurence of the predicate returning True+--+-- If not found, Nothing is returned+findIndex :: (Char -> Bool) -> String -> Maybe (Offset Char)+findIndex predicate s = loop 0 0+  where+    !sz = size s+    loop ofs idx+        | idx .==# sz = Nothing+        | otherwise   =+            let !(Step c idx') = next s idx+             in case predicate c of+                    True  -> Just ofs+                    False -> loop (ofs+1) idx'++-- | Various String Encoding that can be use to convert to and from bytes+data Encoding+    = ASCII7+    | UTF8+    | UTF16+    | UTF32+    | ISO_8859_1+    deriving (Typeable, Data, Eq, Ord, Show, Enum, Bounded)++fromEncoderBytes :: ( Encoder.Encoding encoding+                    , PrimType (Encoder.Unit encoding)+                    )+                 => encoding+                 -> UArray Word8+                 -> (String, Maybe ValidationFailure, UArray Word8)+fromEncoderBytes enc bytes =+    case runST $ Encoder.convertFromTo enc EncoderUTF8 (Vec.recast bytes) of+        -- TODO: Don't swallow up specific error (second element of pair)+        -- TODO: Confused why all this recasting is necessary. I "typed hole"-ed my way to get this function to compile.  Feels like there should be a cleaner method.+        Left (off, _) ->+            let (b1, b2) = Vec.splitAt (offsetAsSize off) (Vec.recast bytes)+            in (String $ Vec.recast b1, Just BuildingFailure, Vec.recast b2)+        Right converted -> (String converted, Nothing, mempty)++-- | Convert a ByteArray to a string assuming a specific encoding.+--+-- It returns a 3-tuple of:+--+-- * The string that has been succesfully converted without any error+-- * An optional validation error+-- * The remaining buffer that hasn't been processed (either as a result of an error, or because the encoded sequence is not fully available)+--+-- Considering a stream of data that is fetched chunk by chunk, it's valid to assume+-- that some sequence might fall in a chunk boundary. When converting chunks,+-- if the error is Nothing and the remaining buffer is not empty, then this buffer+-- need to be prepended to the next chunk+fromBytes :: Encoding -> UArray Word8 -> (String, Maybe ValidationFailure, UArray Word8)+fromBytes ASCII7     bytes = fromEncoderBytes Encoder.ASCII7     bytes+fromBytes ISO_8859_1 bytes = fromEncoderBytes Encoder.ISO_8859_1 bytes+fromBytes UTF16      bytes = fromEncoderBytes Encoder.UTF16      bytes+fromBytes UTF32      bytes = fromEncoderBytes Encoder.UTF32      bytes+fromBytes UTF8       bytes+    | C.null bytes = (mempty, Nothing, mempty)+    | otherwise    =+        case validate bytes (Offset 0) (C.length bytes) of+            (_, Nothing)  -> (fromBytesUnsafe bytes, Nothing, mempty)+            (pos, Just vf) ->+                let (b1, b2) = C.splitAt (offsetAsSize pos) bytes+                 in (fromBytesUnsafe b1, toErr vf, b2)+  where+    toErr MissingByte         = Nothing+    toErr InvalidHeader       = Just InvalidHeader+    toErr InvalidContinuation = Just InvalidContinuation+    toErr BuildingFailure     = Just BuildingFailure++-- | Convert a UTF8 array of bytes to a String.+--+-- If there's any error in the stream, it will automatically+-- insert replacement bytes to replace invalid sequences.+--+-- In the case of sequence that fall in the middle of 2 chunks,+-- the remaining buffer is supposed to be preprended to the+-- next chunk, and resume the parsing.+fromBytesLenient :: UArray Word8 -> (String, UArray Word8)+fromBytesLenient bytes+    | C.null bytes = (mempty, mempty)+    | otherwise    =+        case validate bytes (Offset 0) (C.length bytes) of+            (_, Nothing)                   -> (fromBytesUnsafe bytes, mempty)+            -- TODO: Should anything be done in the 'BuildingFailure' case?+            (_, Just BuildingFailure) -> error "fromBytesLenient: FIXME!"+            (pos, Just MissingByte) ->+                let (b1,b2) = C.splitAt (offsetAsSize pos) bytes+                 in (fromBytesUnsafe b1, b2)+            (pos, Just InvalidHeader) ->+                let (b1,b2) = C.splitAt (offsetAsSize pos) bytes+                    (_,b3)  = C.splitAt 1 b2+                    (s3, r) = fromBytesLenient b3+                 in (mconcat [fromBytesUnsafe b1,replacement, s3], r)+            (pos, Just InvalidContinuation) ->+                let (b1,b2) = C.splitAt (offsetAsSize pos) bytes+                    (_,b3)  = C.splitAt 1 b2+                    (s3, r) = fromBytesLenient b3+                 in (mconcat [fromBytesUnsafe b1,replacement, s3], r)+  where+    -- This is the replacement character U+FFFD used for any invalid header or continuation+    replacement :: String+    !replacement = fromBytesUnsafe $ fromList [0xef,0xbf,0xbd]++-- | Decode a stream of binary chunks containing UTF8 encoding in a list of valid String+--+-- Chunk not necessarily contains a valid string, as+-- a UTF8 sequence could be split over 2 chunks.+fromChunkBytes :: [UArray Word8] -> [String]+fromChunkBytes l = loop l+  where+    loop []         = []+    loop [bytes]    =+        case validate bytes (Offset 0) (C.length bytes) of+            (_, Nothing)  -> [fromBytesUnsafe bytes]+            (_, Just err) -> doErr err+    loop (bytes:cs@(c1:c2)) =+        case validate bytes (Offset 0) (C.length bytes) of+            (_, Nothing) -> fromBytesUnsafe bytes : loop cs+            (pos, Just MissingByte) ->+                let (b1,b2) = C.splitAt (offsetAsSize pos) bytes+                 in fromBytesUnsafe b1 : loop ((b2 `mappend` c1) : c2)+            (_, Just err) -> doErr err+    doErr err = error ("fromChunkBytes: " <> show err)++-- | Convert a Byte Array representing UTF8 data directly to a string without checking for UTF8 validity+--+-- If the input contains invalid sequences, it will trigger runtime async errors when processing data.+--+-- In doubt, use 'fromBytes'+fromBytesUnsafe :: UArray Word8 -> String+fromBytesUnsafe = String++toEncoderBytes :: ( Encoder.Encoding encoding+                  , PrimType (Encoder.Unit encoding)+                  , Exception (Encoder.Error encoding)+                  )+               => encoding+               -> UArray Word8+               -> UArray Word8+toEncoderBytes enc bytes = Vec.recast $+  case runST $ Encoder.convertFromTo EncoderUTF8 enc bytes of+    Left _ -> error "toEncoderBytes: FIXME!"+    Right converted -> converted++-- | Convert a String to a bytearray in a specific encoding+--+-- if the encoding is UTF8, the underlying buffer is returned without extra allocation or any processing+--+-- In any other encoding, some allocation and processing are done to convert.+toBytes :: Encoding -> String -> UArray Word8+toBytes UTF8       (String bytes) = bytes+toBytes ASCII7     (String bytes) = toEncoderBytes Encoder.ASCII7     bytes+toBytes ISO_8859_1 (String bytes) = toEncoderBytes Encoder.ISO_8859_1 bytes+toBytes UTF16      (String bytes) = toEncoderBytes Encoder.UTF16      bytes+toBytes UTF32      (String bytes) = toEncoderBytes Encoder.UTF32      bytes++-- | Split lines in a string using newline as separation.+--+-- Note that carriage return preceding a newline are also strip for+-- maximum compatibility between Windows and Unix system.+lines :: String -> [String]+lines s =+    case breakLine s of+        Left _         -> [s]+        Right (line,r) -> line : lines r++-- | Split words in a string using spaces as separation+--+-- > words "Hello Foundation"+-- [ "Hello", "Foundation" ]+words :: String -> [String]+words = fmap fromList . Prelude.words . toList++-- | Append a character to a String builder+builderAppend :: PrimMonad state => Char -> Builder String MutableString Word8 state err ()+builderAppend c = Builder $ State $ \(i, st, e) ->+    if offsetAsSize i + nbBytes >= chunkSize st+        then do+            cur      <- unsafeFreezeShrink (curChunk st) (offsetAsSize i)+            newChunk <- new (chunkSize st)+            writeUTF8Char newChunk (Offset 0) utf8Char+            return ((), (sizeAsOffset nbBytes, st { prevChunks     = cur : prevChunks st+                                                  , prevChunksSize = offsetAsSize i + prevChunksSize st+                                                  , curChunk       = newChunk+                                                  }, e))+        else do+            writeUTF8Char (curChunk st) i utf8Char+            return ((), (i + sizeAsOffset nbBytes, st, e))+  where+    utf8Char = asUTF8Char c+    nbBytes  = numBytes utf8Char++-- | Create a new String builder using chunks of @sizeChunksI@+builderBuild :: PrimMonad m => Int -> Builder String MutableString Word8 m err () -> m (Either err String)+builderBuild sizeChunksI sb+    | sizeChunksI <= 3 = builderBuild 64 sb+    | otherwise        = do+        firstChunk         <- new sizeChunks+        ((), (i, st, e)) <- runState (runBuilder sb) (Offset 0, BuildingState [] (CountOf 0) firstChunk sizeChunks, Nothing)+        case e of+          Just err -> return (Left err)+          Nothing -> do+            cur <- unsafeFreezeShrink (curChunk st) (offsetAsSize i)+            -- Build final array+            let totalSize = prevChunksSize st + offsetAsSize i+            final <- Vec.new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= Vec.unsafeFreeze+            return . Right . String $ final+  where+    sizeChunks = CountOf sizeChunksI++    fillFromEnd _    []            mba = return mba+    fillFromEnd !end (String x:xs) mba = do+        let sz = Vec.length x+        let start = end `sizeSub` sz+        Vec.unsafeCopyAtRO mba (sizeAsOffset start) x (Offset 0) sz+        fillFromEnd start xs mba++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)+             -> (Ptr Word8 -> Offset Word8 -> ST s a)+             -> String+             -> a+stringDewrap withBa withPtr (String ba) = C.unsafeDewrap withBa withPtr ba+{-# INLINE stringDewrap #-}++-- | Read an Integer from a String+--+-- Consume an optional minus sign and many digits until end of string.+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+  where+    !sz = size str+    withBa ba ofs =+        let negativeSign = PrimBA.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+            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+                _                                             -> Nothing+      where !endOfs = ofs `offsetPlusE` sz+{-# SPECIALISE readIntegral :: String -> Maybe Integer #-}+{-# SPECIALISE readIntegral :: String -> Maybe Int #-}++readInteger :: String -> Maybe Integer+readInteger = readIntegral++-- | Read a Natural from a String+--+-- Consume many digits until end of string.+readNatural :: String -> Maybe Natural+readNatural str+    | sz == 0   = Nothing+    | otherwise = stringDewrap withBa (\(Ptr ptr) -> pure . withPtr ptr) str+  where+    !sz = size str+    withBa ba stringStart =+        case decimalDigitsBA 0 ba eofs stringStart of+            (# acc, True, endOfs #) | endOfs > stringStart -> Just acc+            _                                              -> Nothing+      where eofs = stringStart `offsetPlusE` sz+    withPtr addr stringStart =+        case decimalDigitsPtr 0 addr eofs stringStart of+            (# acc, True, endOfs #) | endOfs > stringStart -> Just acc+            _                                              -> Nothing+      where eofs = stringStart `offsetPlusE` sz++-- | Try to read a Double+readDouble :: String -> Maybe Double+readDouble s =+    readFloatingExact s $ \isNegative integral floatingDigits mExponant ->+        Just $ applySign isNegative $ case (floatingDigits, mExponant) of+            (0, Nothing)              ->                         naturalToDouble integral+            (0, Just exponent)        -> withExponant exponent $ naturalToDouble integral+            (floating, Nothing)       ->                         applyFloating floating $ naturalToDouble integral+            (floating, Just exponent) -> withExponant exponent $ applyFloating floating $ naturalToDouble integral+  where+    applySign True = negate+    applySign False = id+    withExponant e v = v * doubleExponant 10 e+    applyFloating digits n = n / (10 Prelude.^ digits)++-- | Try to read a floating number as a Rational+--+-- Note that for safety reason, only exponent between -10000 and 10000 is allowed+-- as otherwise DoS/OOM is very likely. if you don't want this behavior,+-- switching to a scientific type (not provided yet) that represent the+-- exponent separately is the advised solution.+readRational :: String -> Maybe Prelude.Rational+readRational s =+    readFloatingExact s $ \isNegative integral floatingDigits mExponant ->+        case mExponant of+            Just exponent+                | exponent < -10000 || exponent > 10000 -> Nothing+                | otherwise                             -> Just $ modF isNegative integral % (10 Prelude.^ (integralCast floatingDigits - exponent))+            Nothing                                     -> Just $ modF isNegative integral % (10 Prelude.^ floatingDigits)+  where+    modF True  = negate . integralUpsize+    modF False = integralUpsize+++type ReadFloatingCallback a = Bool      -- sign+                           -> Natural   -- integral part+                           -> Word      -- number of digits in floating section+                           -> Maybe Int -- optional integer representing exponent in base 10+                           -> Maybe a++-- | Read an Floating like number of the form:+--+--   [ '-' ] <numbers> [ '.' <numbers> ] [ ( 'e' | 'E' ) [ '-' ] <number> ]+--+-- Call a function with:+--+-- * A boolean representing if the number is negative+-- * The digits part represented as a single natural number (123.456 is represented as 123456)+-- * The number of digits in the fractional part (e.g. 123.456 => 3)+-- * The exponent if any+--+-- The code is structured as a simple state machine that:+--+-- * Optionally Consume a '-' sign+-- * Consume number for the integral part+-- * Optionally+--   * Consume '.'+--   * Consume remaining digits if not already end of string+-- * Optionally Consume a 'e' or 'E' follow by an optional '-' and a number+--+readFloatingExact :: String -> ReadFloatingCallback a -> Maybe a+readFloatingExact str f+    | sz == 0   = Nothing+    | otherwise = stringDewrap withBa withPtr str+  where+    !sz = size str++    withBa ba stringStart =+        let !isNegative = PrimBA.expectAscii ba stringStart 0x2d+         in consumeIntegral isNegative (if isNegative then stringStart+1 else stringStart)+      where+        eofs = stringStart `offsetPlusE` sz+        consumeIntegral !isNegative startOfs =+            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+                        then consumeFloat isNegative acc (endOfs + 1)+                        else consumeExponant isNegative acc 0 endOfs+                _                                            -> Nothing++        consumeFloat isNegative integral startOfs =+            case decimalDigitsBA integral ba eofs startOfs of+                (# acc, True, endOfs #) | endOfs > startOfs -> let (CountOf !diff) = endOfs - startOfs+                                                                in f isNegative acc (integralCast diff) Nothing+                (# acc, False, endOfs #) | endOfs > startOfs -> let (CountOf !diff) = endOfs - startOfs+                                                                in consumeExponant isNegative acc (integralCast diff) endOfs+                _                                           -> Nothing++        consumeExponant !isNegative !integral !floatingDigits !startOfs+            | startOfs == eofs = f isNegative integral floatingDigits Nothing+            | otherwise        =+                -- consume 'E' or 'e'+                case PrimBA.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+                                 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+         in consumeIntegral isNegative (if isNegative then stringStart+1 else stringStart)+      where+        eofs = stringStart `offsetPlusE` sz+        consumeIntegral !isNegative startOfs =+            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+                        then consumeFloat isNegative acc (endOfs + 1)+                        else consumeExponant isNegative acc 0 endOfs+                _                                            -> Nothing++        consumeFloat isNegative integral startOfs =+            case decimalDigitsPtr integral ptr eofs startOfs of+                (# acc, True, endOfs #) | endOfs > startOfs -> let (CountOf !diff) = endOfs - startOfs+                                                                in f isNegative acc (integralCast diff) Nothing+                (# acc, False, endOfs #) | endOfs > startOfs -> let (CountOf !diff) = endOfs - startOfs+                                                                in consumeExponant isNegative acc (integralCast diff) endOfs+                _                                           -> Nothing++        consumeExponant !isNegative !integral !floatingDigits !startOfs+            | startOfs == eofs = f isNegative integral floatingDigits Nothing+            | otherwise        =+                -- consume 'E' or 'e'+                case PrimAddr.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+                                 in consumeExponantNumber exponentNegative (if exponentNegative then ofs + 1 else ofs)++            consumeExponantNumber exponentNegative ofs =+                case decimalDigitsPtr 0 ptr eofs ofs of+                    (# acc, True, endOfs #) | endOfs > ofs -> f isNegative integral floatingDigits (Just $! if exponentNegative then negate acc else acc)+                    _                                      -> Nothing++-- | Take decimal digits and accumulate it in `acc`+--+-- The loop starts at the offset specified and finish either when:+--+-- * It reach the end of the string+-- * It reach a non-ASCII character+-- * It reach an ASCII character that is not a digit (0 to 9)+--+-- Otherwise each iterations:+--+-- * Transform the ASCII digits into a number+-- * scale the accumulator by 10+-- * Add the number (between 0 and 9) to the accumulator+--+-- It then returns:+--+-- * The new accumulated value+-- * Whether it stop by end of string or not+-- * The end offset when the loop stopped+--+-- If end offset == start offset then no digits have been consumed by+-- this function+decimalDigitsBA :: (IntegralUpsize Word8 acc, Additive acc, Multiplicative acc, Integral acc)+                => acc+                -> ByteArray#+                -> Offset Word8 -- end offset+                -> Offset Word8 -- start offset+                -> (# acc, Bool, Offset Word8 #)+decimalDigitsBA startAcc ba !endOfs !startOfs = loop startAcc startOfs+  where+    loop !acc !ofs+        | ofs == endOfs = (# acc, True, ofs #)+        | otherwise     =+            case PrimBA.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 #) #-}++-- | same as decimalDigitsBA specialized for ptr #+decimalDigitsPtr :: (IntegralUpsize Word8 acc, Additive acc, Multiplicative acc, Integral acc)+                 => acc+                 -> Addr#+                 -> Offset Word8 -- end offset+                 -> Offset Word8 -- start offset+                 -> (# acc, Bool, Offset Word8 #)+decimalDigitsPtr startAcc ptr !endOfs !startOfs = loop startAcc startOfs+  where+    loop !acc !ofs+        | ofs == endOfs = (# acc, True, ofs #)+        | otherwise     =+            case PrimAddr.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 #) #-}++-- | Convert a 'String' to the upper-case equivalent.+--   Does not properly support multicharacter Unicode conversions.+upper :: String -> String+upper = charMap toUpper++-- | Convert a 'String' to the upper-case equivalent.+--   Does not properly support multicharacter Unicode conversions.+lower :: String -> String+lower = charMap toLower++-- | 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++-- | Check whether the first string is a suffix of the second string.+isSuffixOf :: String -> String -> Bool+isSuffixOf (String needle) (String haystack)+    | needleLen > hayLen = False+    | otherwise          = needle == C.revTake needleLen haystack+  where+    needleLen = C.length needle+    hayLen    = C.length haystack++-- | Check whether the first string is contains within the second string.+--+-- TODO: implemented the naive way and thus terribly inefficient, reimplement properly+isInfixOf :: String -> String -> Bool+isInfixOf (String needle) (String haystack)+    = loop (hayLen - needleLen) haystack+    where+      needleLen = C.length needle+      hayLen    = C.length haystack+      loop Nothing    _         = False+      loop (Just cnt) haystack' = needle == C.take needleLen haystack' || loop (cnt-1) (C.drop 1 haystack')++-- | Try to strip a prefix from the start of a String.+--+-- If the prefix is not starting the string, then Nothing is returned,+-- otherwise the striped string is returned+stripPrefix :: String -> String -> Maybe String+stripPrefix (String suffix) (String arr)+    | C.isPrefixOf suffix arr = Just $ String $ C.drop (C.length suffix) arr+    | otherwise               = Nothing++-- | Try to strip a suffix from the end of a String.+--+-- If the suffix is not ending the string, then Nothing is returned,+-- otherwise the striped string is returned+stripSuffix :: String -> String -> Maybe String+stripSuffix (String prefix) (String arr)+    | C.isSuffixOf prefix arr = Just $ String $ C.revDrop (C.length prefix) arr+    | otherwise               = Nothing++all :: (Char -> Bool) -> String -> Bool+all predicate (String arr) = C.onBackend goNative (\_ -> pure . goAddr) arr+  where+    !(C.ValidRange start end) = C.offsetsValidRange arr+    goNative ba = PrimBA.all predicate ba start end+    goAddr (Ptr addr) = PrimAddr.all predicate addr start end++any :: (Char -> Bool) -> String -> Bool+any predicate (String arr) = C.onBackend goNative (\_ -> pure . goAddr) arr+  where+    !(C.ValidRange start end) = C.offsetsValidRange arr+    goNative ba = PrimBA.any predicate ba start end+    goAddr (Ptr addr) = PrimAddr.any predicate addr start end++-- | Transform string @src@ to base64 binary representation.+toBase64 :: String -> String+toBase64 (String src) = fromBytesUnsafe . Vec.toBase64Internal set src $ True+  where+    !set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"#++-- | Transform string @src@ to URL-safe base64 binary representation.+-- The result will be either padded or unpadded, depending on the boolean+-- @padded@ argument.+toBase64URL :: Bool -> String -> String+toBase64URL padded (String src) = fromBytesUnsafe . Vec.toBase64Internal set src $ padded+  where+    !set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_"#++-- | Transform string @src@ to OpenBSD base64 binary representation.+toBase64OpenBSD :: String -> String+toBase64OpenBSD (String src) = fromBytesUnsafe . Vec.toBase64Internal set src $ False+  where+    !set = "./ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"#
+ Basement/String/Addr.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE NoImplicitPrelude          #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE CPP                        #-}+module Basement.String.Addr+    ( copyFilter+    , validate+    ) where++import           GHC.Prim+import           GHC.ST+import           Basement.Compat.Base+import           Basement.Numerical.Additive+import           Basement.Types.OffsetSize++import qualified Basement.UTF8.BA   as PrimBA+import qualified Basement.UTF8.Addr as PrimBackend+import           Basement.UTF8.Helper+import           Basement.UTF8.Table+import           Basement.UTF8.Types++copyFilter :: (Char -> Bool)+           -> CountOf Word8+           -> MutableByteArray# s+           -> PrimBackend.Immutable+           -> Offset Word8+           -> ST s (CountOf Word8)+copyFilter predicate !sz dst src start = loop (Offset 0) start+  where+    !end = start `offsetPlusE` sz+    loop !d !s+        | s == end  = pure (offsetAsSize d)+        | otherwise =+            let !h = PrimBackend.primIndex src s+             in case headerIsAscii h of+                    True | predicate (toChar1 h) -> PrimBA.primWrite dst d h >> loop (d + Offset 1) (s + Offset 1)+                         | otherwise             -> loop d (s + Offset 1)+                    False ->+                        case PrimBackend.next src s of+                            Step c s' | predicate c -> PrimBA.write dst d c >>= \d' -> loop d' s'+                                      | otherwise   -> loop d s'++validate :: Offset Word8+         -> PrimBackend.Immutable+         -> Offset Word8+         -> (Offset Word8, Maybe ValidationFailure)+validate end ba ofsStart = loop ofsStart+  where+    loop !ofs+        | ofs > end  = error ("validate: internal error: went pass offset : ofs=" <> show ofs <> " end=" <> show end)+        | ofs == end = (end, Nothing)+        | otherwise  =+            let !h = PrimBackend.primIndex ba ofs in+            case headerIsAscii h of+                True  -> loop (ofs + Offset 1)+                False ->+                    case one (CountOf $ getNbBytes h) ofs of+                        (nextOfs, Nothing)  -> loop nextOfs+                        (pos, Just failure) -> (pos, Just failure)++    one (CountOf 0xff) pos = (pos, Just InvalidHeader)+    one nbConts pos+        | ((pos+Offset 1) `offsetPlusE` nbConts) > end = (pos, Just MissingByte)+        | otherwise =+            case nbConts of+                CountOf 1 ->+                    let c1 = PrimBackend.primIndex ba (pos + Offset 1)+                    in if isContinuation c1+                        then (pos + Offset 2, Nothing)+                        else (pos, Just InvalidContinuation)+                CountOf 2 ->+                    let c1 = PrimBackend.primIndex ba (pos + Offset 1)+                        c2 = PrimBackend.primIndex ba (pos + Offset 2)+                     in if isContinuation c1 && isContinuation c2+                            then (pos + Offset 3, Nothing)+                            else (pos, Just InvalidContinuation)+                CountOf 3 ->+                    let c1 = PrimBackend.primIndex ba (pos + Offset 1)+                        c2 = PrimBackend.primIndex ba (pos + Offset 2)+                        c3 = PrimBackend.primIndex ba (pos + Offset 3)+                     in if isContinuation c1 && isContinuation c2 && isContinuation c3+                            then (pos + Offset 4, Nothing)+                            else (pos, Just InvalidContinuation)+                CountOf _ -> error "internal error"
+ Basement/String/BA.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE NoImplicitPrelude          #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE CPP                        #-}+module Basement.String.BA+    ( copyFilter+    , validate+    ) where++import           GHC.Prim+import           GHC.ST+import           Basement.Compat.Base+import           Basement.Numerical.Additive+import           Basement.Types.OffsetSize++import qualified Basement.UTF8.BA as PrimBA+import qualified Basement.UTF8.BA as PrimBackend+import           Basement.UTF8.Helper+import           Basement.UTF8.Table+import           Basement.UTF8.Types++copyFilter :: (Char -> Bool)+           -> CountOf Word8+           -> MutableByteArray# s+           -> PrimBackend.Immutable+           -> Offset Word8+           -> ST s (CountOf Word8)+copyFilter predicate !sz dst src start = loop (Offset 0) start+  where+    !end = start `offsetPlusE` sz+    loop !d !s+        | s == end  = pure (offsetAsSize d)+        | otherwise =+            let !h = PrimBackend.primIndex src s+             in case headerIsAscii h of+                    True | predicate (toChar1 h) -> PrimBA.primWrite dst d h >> loop (d + Offset 1) (s + Offset 1)+                         | otherwise             -> loop d (s + Offset 1)+                    False ->+                        case PrimBackend.next src s of+                            Step c s' | predicate c -> PrimBA.write dst d c >>= \d' -> loop d' s'+                                      | otherwise   -> loop d s'++validate :: Offset Word8+         -> PrimBackend.Immutable+         -> Offset Word8+         -> (Offset Word8, Maybe ValidationFailure)+validate end ba ofsStart = loop ofsStart+  where+    loop !ofs+        | ofs > end  = error ("validate: internal error: went pass offset : ofs=" <> show ofs <> " end=" <> show end)+        | ofs == end = (end, Nothing)+        | otherwise  =+            let !h = PrimBackend.primIndex ba ofs in+            case headerIsAscii h of+                True  -> loop (ofs + Offset 1)+                False ->+                    case one (CountOf $ getNbBytes h) ofs of+                        (nextOfs, Nothing)  -> loop nextOfs+                        (pos, Just failure) -> (pos, Just failure)++    one (CountOf 0xff) pos = (pos, Just InvalidHeader)+    one nbConts pos+        | ((pos+Offset 1) `offsetPlusE` nbConts) > end = (pos, Just MissingByte)+        | otherwise =+            case nbConts of+                CountOf 1 ->+                    let c1 = PrimBackend.primIndex ba (pos + Offset 1)+                    in if isContinuation c1+                        then (pos + Offset 2, Nothing)+                        else (pos, Just InvalidContinuation)+                CountOf 2 ->+                    let c1 = PrimBackend.primIndex ba (pos + Offset 1)+                        c2 = PrimBackend.primIndex ba (pos + Offset 2)+                     in if isContinuation c1 && isContinuation c2+                            then (pos + Offset 3, Nothing)+                            else (pos, Just InvalidContinuation)+                CountOf 3 ->+                    let c1 = PrimBackend.primIndex ba (pos + Offset 1)+                        c2 = PrimBackend.primIndex ba (pos + Offset 2)+                        c3 = PrimBackend.primIndex ba (pos + Offset 3)+                     in if isContinuation c1 && isContinuation c2 && isContinuation c3+                            then (pos + Offset 4, Nothing)+                            else (pos, Just InvalidContinuation)+                CountOf _ -> error "internal error"
+ Basement/String/Encoding/ASCII7.hs view
@@ -0,0 +1,84 @@+-- |+-- Module      : Basement.String.Encoding.ASCII7+-- License     : BSD-style+-- Maintainer  : Foundation+-- Stability   : experimental+-- Portability : portable+--++{-# LANGUAGE MagicHash #-}++module Basement.String.Encoding.ASCII7+    ( ASCII7(..)+    , ASCII7_Invalid(..)+    ) where++import Basement.Compat.Base+import Basement.Types.OffsetSize+import Basement.Numerical.Additive+import Basement.Monad++import GHC.Prim+import GHC.Word+import GHC.Types+import Basement.UArray+import Basement.UArray.Mutable (MUArray)+import Basement.MutableBuilder++import Basement.String.Encoding.Encoding++-- | validate a given byte is within ASCII characters encoring size+--+-- This function check the 8th bit is set to 0+--+isAscii :: Word8 -> Bool+isAscii (W8# w) = W8# (and# w 0x80## ) == 0+{-# INLINE isAscii #-}++data ASCII7_Invalid+    = ByteOutOfBound Word8+    | CharNotAscii   Char+  deriving (Typeable, Show, Eq)+instance Exception ASCII7_Invalid++data ASCII7 = ASCII7++instance Encoding ASCII7 where+    type Unit ASCII7 = Word8+    type Error ASCII7 = ASCII7_Invalid+    encodingNext  _ = next+    encodingWrite _ = write++-- | consume an Ascii7 char and return the Unicode point and the position+-- of the next possible Ascii7 char+--+next :: (Offset Word8 -> Word8)+          -- ^ method to access a given byte+     -> Offset Word8+          -- ^ index of the byte+     -> Either ASCII7_Invalid (Char, Offset Word8)+          -- ^ either successfully validated the ASCII char and returned the+          -- next index or fail with an error+next getter off+    | isAscii w8 = Right (toChar w, off + 1)+    | otherwise  = Left $ ByteOutOfBound w8+  where+    !w8@(W8# w) = getter off+    toChar :: Word# -> Char+    toChar a = C# (chr# (word2Int# a))++-- Write ascii char+--+-- > build 64 $ sequence_ write "this is a simple list of char..."+--+write :: (PrimMonad st, Monad st)+      => Char+           -- ^ expecting it to be a valid Ascii character.+           -- otherwise this function will throw an exception+      -> Builder (UArray Word8) (MUArray Word8) Word8 st err ()+write c+    | c < toEnum 0x80 = builderAppend $ w8 c+    | otherwise       = throw $ CharNotAscii c+  where+    w8 :: Char -> Word8+    w8 (C# ch) = W8# (int2Word# (ord# ch))
+ Basement/String/Encoding/Encoding.hs view
@@ -0,0 +1,102 @@+-- |+-- Module      : Basement.String.Encoding.Encoding+-- License     : BSD-style+-- Maintainer  : Foundation+-- Stability   : experimental+-- Portability : portable+--++{-# LANGUAGE FlexibleContexts #-}++module Basement.String.Encoding.Encoding+    ( Encoding(..)+    , convertFromTo+    ) where++import           Basement.Compat.Base+import           Basement.Types.OffsetSize+import           Basement.Monad+import           Basement.PrimType+import           Basement.MutableBuilder+import           Basement.Numerical.Additive+import           Basement.UArray (UArray)+import           Basement.UArray.Mutable (MUArray)+import qualified Basement.UArray as Vec++class Encoding encoding where+    -- | the unit element use for the encoding.+    -- i.e. Word8 for ASCII7 or UTF8, Word16 for UTF16...+    --+    type Unit encoding++    -- | define the type of error handling you want to use for the+    -- next function.+    --+    -- > type Error UTF8 = Either UTF8_Invalid+    --+    type Error encoding++    -- | consume an `Unit encoding` and return the Unicode point and the position+    -- of the next possible `Unit encoding`+    --+    encodingNext :: encoding+                      -- ^ only used for type deduction+                -> (Offset (Unit encoding) -> Unit encoding)+                      -- ^ method to access a given `Unit encoding`+                      -- (see `unsafeIndexer`)+                -> Offset (Unit encoding)+                      -- ^ offset of the `Unit encoding` where starts the+                      -- encoding of a given unicode+                -> Either (Error encoding) (Char, Offset (Unit encoding)) -- ^ either successfully validated the `Unit encoding`+                      -- and returned the next offset or fail with an+                      -- `Error encoding`++    -- Write a unicode point encoded into one or multiple `Unit encoding`+    --+    -- > build 64 $ sequence_ (write UTF8) "this is a simple list of char..."+    --+    encodingWrite :: (PrimMonad st, Monad st)+                  => encoding+                      -- ^ only used for type deduction+                  -> Char+                      -- ^ the unicode character to encode+                  -> Builder (UArray (Unit encoding))+                             (MUArray (Unit encoding))+                             (Unit encoding) st err ()++-- | helper to convert a given Array in a given encoding into an array+-- with another encoding.+--+-- This is a helper to convert from one String encoding to another.+-- This function is (quite) slow and needs some work.+--+-- ```+-- let s16 = ... -- string in UTF16+-- -- create s8, a UTF8 String+-- let s8  = runST $ convertWith UTF16 UTF8 (toBytes s16)+--+-- print s8+-- ```+--+convertFromTo :: ( PrimMonad st, Monad st+                 , Encoding input, PrimType (Unit input)+                 , Encoding output, PrimType (Unit output)+                 )+              => input+                -- ^ Input's encoding type+              -> output+                -- ^ Output's encoding type+              -> UArray (Unit input)+                -- ^ the input raw array+              -> st (Either (Offset (Unit input), Error input) (UArray (Unit output)))+convertFromTo inputEncodingTy outputEncodingTy bytes+    | Vec.null bytes = return . return $ mempty+    | otherwise      = Vec.unsafeIndexer bytes $ \t -> Vec.builderBuild 64 (loop azero t)+  where+    lastUnit = Vec.length bytes++    loop off getter+      | off .==# lastUnit = return ()+      | otherwise = case encodingNext inputEncodingTy getter off of+          Left err -> mFail (off, err)+          Right (c, noff) -> encodingWrite outputEncodingTy c >> loop noff getter
+ Basement/String/Encoding/ISO_8859_1.hs view
@@ -0,0 +1,64 @@+-- |+-- Module      : Basement.String.Encoding.ISO_8859_1+-- License     : BSD-style+-- Maintainer  : Foundation+-- Stability   : experimental+-- Portability : portable+--++{-# LANGUAGE MagicHash #-}++module Basement.String.Encoding.ISO_8859_1+    ( ISO_8859_1(..)+    , ISO_8859_1_Invalid(..)+    ) where++import Basement.Compat.Base+import Basement.Types.OffsetSize+import Basement.Numerical.Additive+import Basement.Monad++import GHC.Prim+import GHC.Word+import GHC.Types+import Basement.UArray+import Basement.UArray.Mutable (MUArray)+import Basement.MutableBuilder++import Basement.String.Encoding.Encoding++-- offset of size one+aone :: Offset Word8+aone = Offset 1++data ISO_8859_1_Invalid+    = NotISO_8859_1 Char+  deriving (Typeable, Show, Eq)+instance Exception ISO_8859_1_Invalid++data ISO_8859_1 = ISO_8859_1++instance Encoding ISO_8859_1 where+    type Unit ISO_8859_1 = Word8+    type Error ISO_8859_1 = ISO_8859_1_Invalid+    encodingNext  _ = next+    encodingWrite _ = write++next :: (Offset Word8 -> Word8)+     -> Offset Word8+     -> Either ISO_8859_1_Invalid (Char, Offset Word8)+next getter off = Right (toChar w, off + aone)+  where+    !(W8# w) = getter off+    toChar :: Word# -> Char+    toChar a = C# (chr# (word2Int# a))++write :: (PrimMonad st, Monad st)+      => Char+      -> Builder (UArray Word8) (MUArray Word8) Word8 st err ()+write c@(C# ch)+    | c <= toEnum 0xFF = builderAppend (W8# x)+    | otherwise        = throw $ NotISO_8859_1 c+  where+    x :: Word#+    !x = int2Word# (ord# ch)
+ Basement/String/Encoding/UTF16.hs view
@@ -0,0 +1,97 @@+-- |+-- Module      : Basement.String.Encoding.UTF16+-- License     : BSD-style+-- Maintainer  : Foundation+-- Stability   : experimental+-- Portability : portable+--+{-# LANGUAGE MagicHash #-}+module Basement.String.Encoding.UTF16+    ( UTF16(..)+    , UTF16_Invalid(..)+    ) where++import GHC.Prim+import GHC.Word+import GHC.Types+import Data.Bits+import qualified Prelude+import Basement.Compat.Base+import Basement.Types.OffsetSize+import Basement.Monad+import Basement.Numerical.Additive+import Basement.UArray+import Basement.UArray.Mutable (MUArray)+import Basement.MutableBuilder++import Basement.String.Encoding.Encoding++data UTF16_Invalid+    = InvalidContinuation+    | InvalidUnicode Char+  deriving (Show, Eq, Typeable)+instance Exception UTF16_Invalid++data UTF16 = UTF16++instance Encoding UTF16 where+    type Unit UTF16 = Word16+    type Error UTF16 = UTF16_Invalid+    encodingNext  _ = next+    encodingWrite _ = write+++--+-- U+0000 to U+D7FF and U+E000 to U+FFFF : 1 bytes+-- U+10000 to U+10FFFF :+--    * 0x010000 is subtracted from the code point, leaving a 20-bit number in the range 0..0x0FFFFF.+--    * The top ten bits (a number in the range 0..0x03FF) are added to 0xD800 to give the first 16-bit code unit+--      or high surrogate, which will be in the range 0xD800..0xDBFF.+--    * The low ten bits (also in the range 0..0x03FF) are added to 0xDC00 to give the second 16-bit code unit+--      or low surrogate, which will be in the range 0xDC00..0xDFFF.++next :: (Offset Word16 -> Word16)+     -> Offset Word16+     -> Either UTF16_Invalid (Char, Offset Word16)+next getter off+    | h <  0xd800 = Right (toChar hh, off + Offset 1)+    | h >= 0xe000 = Right (toChar hh, off + Offset 1)+    | otherwise   = nextContinuation+  where+    h :: Word16+    !h@(W16# hh) = getter off+    toChar :: Word# -> Char+    toChar w = C# (chr# (word2Int# w))+    to32 :: Word16 -> Word32+    to32 (W16# w) = W32# w++    nextContinuation+        | cont >= 0xdc00 && cont < 0xe00 =+            let !(W32# w) = ((to32 h .&. 0x3ff) `shiftL` 10)+                         .|. (to32 cont .&. 0x3ff)+             in Right (toChar w, off + Offset 2)+        | otherwise = Left InvalidContinuation+      where+        cont :: Word16+        !cont = getter $ off + Offset 1++write :: (PrimMonad st, Monad st)+      => Char+      -> Builder (UArray Word16) (MUArray Word16) Word16 st err ()+write c+    | c < toEnum 0xd800   = builderAppend $ w16 c+    | c > toEnum 0x10000  = let (w1, w2) = wHigh c in builderAppend w1 >> builderAppend w2+    | c > toEnum 0x10ffff = throw $ InvalidUnicode c+    | c >= toEnum 0xe000  = builderAppend $ w16 c+    | otherwise = throw $ InvalidUnicode c+  where+    w16 :: Char -> Word16+    w16 (C# ch) = W16# (int2Word# (ord# ch))++    to16 :: Word32 -> Word16+    to16 = Prelude.fromIntegral++    wHigh :: Char -> (Word16, Word16)+    wHigh (C# ch) =+        let v = W32# (minusWord# (int2Word# (ord# ch)) 0x10000##)+         in (0xdc00 .|. to16 (v `shiftR` 10), 0xd800 .|. to16 (v .&. 0x3ff))
+ Basement/String/Encoding/UTF32.hs view
@@ -0,0 +1,55 @@+-- |+-- Module      : Basement.String.Encoding.UTF32+-- License     : BSD-style+-- Maintainer  : Foundation+-- Stability   : experimental+-- Portability : portable+--+{-# LANGUAGE MagicHash #-}+module Basement.String.Encoding.UTF32+    ( UTF32(..)+    , UTF32_Invalid+    ) where++import GHC.Prim+import GHC.Word+import GHC.Types+import Basement.Compat.Base+import Basement.Types.OffsetSize+import Basement.Monad+import Basement.Numerical.Additive+import Basement.UArray+import Basement.UArray.Mutable (MUArray)+import Basement.MutableBuilder++import Basement.String.Encoding.Encoding++data UTF32 = UTF32++data UTF32_Invalid = UTF32_Invalid+  deriving (Typeable, Show, Eq, Ord, Enum, Bounded)+instance Exception UTF32_Invalid++instance Encoding UTF32 where+    type Unit UTF32 = Word32+    type Error UTF32 = UTF32_Invalid+    encodingNext  _ = next+    encodingWrite _ = write++next :: (Offset Word32 -> Word32)+     -> Offset Word32+     -> Either UTF32_Invalid (Char, Offset Word32)+next getter off = Right (char, off + Offset 1)+  where+    !(W32# hh) = getter off+    char :: Char+    char = C# (chr# (word2Int# hh))++write :: (PrimMonad st, Monad st)+      => Char+      -> Builder (UArray Word32) (MUArray Word32) Word32 st err ()+write c = builderAppend w32+  where+    !(C# ch) = c+    w32 :: Word32+    w32 = W32# (int2Word# (ord# ch))
+ Basement/These.hs view
@@ -0,0 +1,36 @@+-- |+-- Module      : Basement.These+-- License     : BSD-style+-- Maintainer  : Nicolas Di Prima <nicolas@primetype.co.uk>+-- Stability   : stable+-- Portability : portable+--+-- @These a b@, sum type to represent either @a@ or @b@ or both.+--+module Basement.These+    ( These(..)+    ) where++import Basement.Compat.Base+import Basement.NormalForm+import Basement.Compat.Bifunctor++-- | Either a or b or both.+data These a b+    = This a+    | That b+    | These a b+  deriving (Eq, Ord, Show, Typeable)++instance (NormalForm a, NormalForm b) => NormalForm (These a b) where+    toNormalForm (This a) = toNormalForm a+    toNormalForm (That b) = toNormalForm b+    toNormalForm (These a b) = toNormalForm a `seq` toNormalForm b++instance Bifunctor These where+    bimap fa _  (This a)    = This  (fa a)+    bimap _  fb (That b)    = That  (fb b)+    bimap fa fb (These a b) = These (fa a) (fb b)++instance Functor (These a) where+    fmap = second
+ Basement/Types/AsciiString.hs view
@@ -0,0 +1,61 @@+-- |+-- Module      : Foundation.Primitives.Types.AsciiString+-- License     : BSD-style+-- Maintainer  : Haskell Foundation+-- Stability   : experimental+-- Portability : portable+--+-- A AsciiString type backed by a `ASCII` encoded byte array and all the necessary+-- functions to manipulate the string.+--+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+module Basement.Types.AsciiString+    ( AsciiString(..)+    , MutableAsciiString(..)+    -- * Binary conversion+    , fromBytesUnsafe+    , fromBytes+    ) where++import           Basement.Compat.Base+import           Basement.Types.Char7+import           Basement.UArray.Base+import qualified Basement.Types.Char7 as Char7+import qualified Basement.UArray as A (all, unsafeRecast)++-- | Opaque packed array of characters in the ASCII encoding+newtype AsciiString = AsciiString { toBytes :: UArray Char7 }+    deriving (Typeable, Monoid, Eq, Ord)++newtype MutableAsciiString st = MutableAsciiString (MUArray Char7 st)+    deriving (Typeable)++instance Show AsciiString where+    show = fmap Char7.toChar . toList+instance IsString AsciiString where+    fromString = fromList . fmap Char7.fromCharMask+instance IsList AsciiString where+    type Item AsciiString = Char7+    fromList = AsciiString . fromList+    toList (AsciiString chars) = toList chars++-- | Convert a Byte Array representing ASCII data directly to an AsciiString without checking for ASCII validity+--+-- If the input contains invalid Char7 value (anything above 0x7f),+-- it will trigger runtime async errors when processing data.+--+-- In doubt, use 'fromBytes'+fromBytesUnsafe :: UArray Word8 -> AsciiString+fromBytesUnsafe = AsciiString . A.unsafeRecast++-- | Convert a Byte Array representing ASCII checking validity.+--+-- If the byte array is not valid, then Nothing is returned+fromBytes :: UArray Word8 -> Maybe AsciiString+fromBytes arr+    | A.all (\x -> x < 0x80) arr = Just $ AsciiString $ A.unsafeRecast arr+    | otherwise                  = Nothing
+ Basement/Types/Char7.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE MagicHash                  #-}+module Basement.Types.Char7+    ( Char7(..)+    , toChar+    , fromCharMask+    , fromChar+    , fromByteMask+    , fromByte+    -- * individual ASCII Characters+    , c7_LF+    , c7_CR+    , c7_minus+    , c7_a+    , c7_A+    , c7_z+    , c7_Z+    , c7_0+    , c7_1+    , c7_2+    , c7_3+    , c7_4+    , c7_5+    , c7_6+    , c7_7+    , c7_8+    , c7_9+    ) where++import GHC.Prim+import GHC.Word+import GHC.Types+import Data.Bits+import Data.Maybe+import Basement.Compat.Base+import Basement.Compat.Primitive (bool#)++-- | ASCII value between 0x0 and 0x7f+newtype Char7 = Char7 { toByte :: Word8 }+    deriving (Show,Eq,Ord,Typeable)++-- | Convert a 'Char7' to a unicode code point 'Char'+toChar :: Char7 -> Char+toChar !(Char7 (W8# w)) = C# (chr# (word2Int# w))++-- | Try to convert a 'Char' to a 'Char7'+-- +-- If the code point is non ascii, then Nothing is returned.+fromChar :: Char -> Maybe Char7+fromChar !(C# c#)+    | bool# (ltChar# c# (chr# 0x80#)) = Just $ Char7 $ W8# (int2Word# (ord# c#))+    | otherwise                       = Nothing++-- | Try to convert 'Word8' to a 'Char7'+--+-- If the byte got higher bit set, then Nothing is returned.+fromByte :: Word8 -> Maybe Char7+fromByte !w+    | (w .&. 0x80) == 0 = Just $ Char7 w+    | otherwise         = Nothing++-- | Convert a 'Char' to a 'Char7' ignoring all higher bits+fromCharMask :: Char -> Char7+fromCharMask !(C# c#) = Char7 $ W8# (and# (int2Word# (ord# c#)) 0x7f##)++-- | Convert a 'Byte' to a 'Char7' ignoring the higher bit+fromByteMask :: Word8 -> Char7+fromByteMask !(W8# w#) = Char7 $ W8# (and# w# 0x7f##)++c7_LF :: Char7+c7_LF = Char7 0xa++c7_CR :: Char7+c7_CR = Char7 0xd++c7_minus :: Char7+c7_minus = Char7 0x2d++c7_a :: Char7+c7_a = Char7 0x61++c7_A :: Char7+c7_A = Char7 0x41++c7_z :: Char7+c7_z = Char7 0x7a++c7_Z :: Char7+c7_Z = Char7 0x5a++c7_0, c7_1, c7_2, c7_3, c7_4, c7_5, c7_6, c7_7, c7_8, c7_9 :: Char7+c7_0 = Char7 0x30+c7_1 = Char7 0x31+c7_2 = Char7 0x32+c7_3 = Char7 0x33+c7_4 = Char7 0x34+c7_5 = Char7 0x35+c7_6 = Char7 0x36+c7_7 = Char7 0x37+c7_8 = Char7 0x38+c7_9 = Char7 0x39
+ Basement/Types/OffsetSize.hs view
@@ -0,0 +1,250 @@+-- |+-- Module      : Basement.Types.OffsetSize+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : portable+--+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE CPP                        #-}+module Basement.Types.OffsetSize+    ( FileSize(..)+    , Offset(..)+    , Offset8+    , offsetOfE+    , offsetPlusE+    , offsetMinusE+    , offsetRecast+    , offsetCast+    , offsetSub+    , offsetShiftL+    , offsetShiftR+    , sizeCast+    , sizeLastOffset+    , sizeAsOffset+    , sizeSub+    , countOfRoundUp+    , offsetAsSize+    , (+.)+    , (.==#)+    , CountOf(..)+    , sizeOfE+    , csizeOfOffset+    , csizeOfSize+    , sizeOfCSSize+    , sizeOfCSize+    ) where++#include "MachDeps.h"++import GHC.Types+import GHC.Word+import GHC.Int+import GHC.Prim+import Foreign.C.Types+import System.Posix.Types (CSsize (..))+import Data.Bits+import Basement.Compat.Base+import Data.Proxy+import Basement.From+import Basement.Numerical.Number+import Basement.Numerical.Additive+import Basement.Numerical.Subtractive+import Basement.Numerical.Multiplicative+import Basement.IntegralConv+import Data.List (foldl')+import qualified Prelude++#if WORD_SIZE_IN_BITS < 64+import GHC.IntWord64+#endif++-- | File size in bytes+newtype FileSize = FileSize Word64+    deriving (Show,Eq,Ord)++-- | Offset in bytes used for memory addressing (e.g. in a vector, string, ..)+type Offset8 = Offset Word8++-- | Offset in a data structure consisting of elements of type 'ty'.+--+-- Int is a terrible backing type which is hard to get away from,+-- considering that GHC/Haskell are mostly using this for offset.+-- Trying to bring some sanity by a lightweight wrapping.+newtype Offset ty = Offset Int+    deriving (Show,Eq,Ord,Enum,Additive,Typeable,Integral,Prelude.Num)++instance IsIntegral (Offset ty) where+    toInteger (Offset i) = toInteger i+instance IsNatural (Offset ty) where+    toNatural (Offset i) = toNatural (integralCast i :: Word)+instance Subtractive (Offset ty) where+    type Difference (Offset ty) = CountOf ty+    (Offset a) - (Offset b) = CountOf (a-b)+instance IntegralCast Int (Offset ty) where+    integralCast i = Offset i+instance IntegralCast Word (Offset ty) where+    integralCast (W# w) = Offset (I# (word2Int# w))++(+.) :: Offset ty -> Int -> Offset ty+(+.) (Offset a) b = Offset (a + b)+{-# INLINE (+.) #-}++-- . is offset (as a pointer from a beginning), and # is the size (amount of data)+(.==#) :: Offset ty -> CountOf ty -> Bool+(.==#) (Offset ofs) (CountOf sz) = ofs == sz+{-# INLINE (.==#) #-}++offsetOfE :: CountOf Word8 -> Offset ty -> Offset8+offsetOfE (CountOf sz) (Offset ty) = Offset (ty * sz)++offsetPlusE :: Offset ty -> CountOf ty -> Offset ty+offsetPlusE (Offset ofs) (CountOf sz) = Offset (ofs + sz)++offsetMinusE :: Offset ty -> CountOf ty -> Offset ty+offsetMinusE (Offset ofs) (CountOf sz) = Offset (ofs - sz)++-- | subtract 2 CountOf values of the same type.+--+-- m need to be greater than n, otherwise negative count error ensue+-- use the safer (-) version if unsure.+offsetSub :: Offset a -> Offset a -> Offset a+offsetSub (Offset m) (Offset n) = Offset (m - n)++offsetRecast :: CountOf Word8 -> CountOf Word8 -> Offset ty -> Offset ty2+offsetRecast szTy (CountOf szTy2) ofs =+    let (Offset bytes) = offsetOfE szTy ofs+     in Offset (bytes `div` szTy2)++offsetShiftR :: Int -> Offset ty -> Offset ty2+offsetShiftR n (Offset o) = Offset (o `unsafeShiftR` n)++offsetShiftL :: Int -> Offset ty -> Offset ty2+offsetShiftL n (Offset o) = Offset (o `unsafeShiftL` n)++offsetCast :: Proxy (a -> b) -> Offset a -> Offset b+offsetCast _ (Offset o) = Offset o+{-# INLINE offsetCast #-}++sizeCast :: Proxy (a -> b) -> CountOf a -> CountOf b+sizeCast _ (CountOf sz) = CountOf sz+{-# INLINE sizeCast #-}++-- | subtract 2 CountOf values of the same type.+--+-- m need to be greater than n, otherwise negative count error ensue+-- use the safer (-) version if unsure.+sizeSub :: CountOf a -> CountOf a -> CountOf a+sizeSub (CountOf m) (CountOf n)+    | diff >= 0 = CountOf diff+    | otherwise = error "sizeSub negative size"+  where+    diff = m - n++-- TODO add a callstack, or a construction to prevent size == 0 error+sizeLastOffset :: CountOf a -> Offset a+sizeLastOffset (CountOf s)+    | s > 0     = Offset (pred s)+    | otherwise = error "last offset on size 0"++sizeAsOffset :: CountOf a -> Offset a+sizeAsOffset (CountOf a) = Offset a+{-# INLINE sizeAsOffset #-}++offsetAsSize :: Offset a -> CountOf a+offsetAsSize (Offset a) = CountOf a+{-# INLINE offsetAsSize #-}++-- | CountOf of a data structure.+--+-- More specifically, it represents the number of elements of type `ty` that fit+-- into the data structure.+--+-- >>> length (fromList ['a', 'b', 'c', '🌟']) :: CountOf Char+-- CountOf 4+--+-- Same caveats as 'Offset' apply here.+newtype CountOf ty = CountOf Int+    deriving (Show,Eq,Ord,Enum,Typeable,Integral)++instance Prelude.Num (CountOf ty) where+    fromInteger a = CountOf (fromInteger a)+    (+) (CountOf a) (CountOf b) = CountOf (a+b)+    (-) (CountOf a) (CountOf b)+        | b > a     = CountOf 0+        | otherwise = CountOf (a - b)+    (*) (CountOf a) (CountOf b) = CountOf (a*b)+    abs a = a+    negate _ = error "cannot negate CountOf: use Foundation Numerical hierarchy for this function to not be exposed to CountOf"+    signum (CountOf a) = CountOf (Prelude.signum a)++instance From (CountOf ty) Int where+    from (CountOf n) = n+instance From (CountOf ty) Word where+    from (CountOf n) = from n++instance IsIntegral (CountOf ty) where+    toInteger (CountOf i) = toInteger i+instance IsNatural (CountOf ty) where+    toNatural (CountOf i) = toNatural (integralCast i :: Word)++instance Additive (CountOf ty) where+    azero = CountOf 0+    (+) (CountOf a) (CountOf b) = CountOf (a+b)++instance Subtractive (CountOf ty) where+    type Difference (CountOf ty) = Maybe (CountOf ty)+    (CountOf a) - (CountOf b) | a >= b    = Just . CountOf $ a - b+                              | otherwise = Nothing++instance Monoid (CountOf ty) where+    mempty = azero+    mappend = (+)+    mconcat = foldl' (+) 0++instance IntegralCast Int (CountOf ty) where+    integralCast i = CountOf i+instance IntegralCast Word (CountOf ty) where+    integralCast (W# w) = CountOf (I# (word2Int# w))++sizeOfE :: CountOf Word8 -> CountOf ty -> CountOf Word8+sizeOfE (CountOf sz) (CountOf ty) = CountOf (ty * sz)++-- | alignment need to be a power of 2+countOfRoundUp :: Int -> CountOf ty -> CountOf ty+countOfRoundUp alignment (CountOf n) = CountOf ((n + (alignment-1)) .&. complement (alignment-1))++-- when #if WORD_SIZE_IN_BITS < 64 the 2 following are wrong+-- instead of using FromIntegral and being silently wrong+-- explicit pattern match to sort it out.++csizeOfSize :: CountOf Word8 -> CSize+#if WORD_SIZE_IN_BITS < 64+csizeOfSize (CountOf (I# sz)) = CSize (W32# (int2Word# sz))+#else+csizeOfSize (CountOf (I# sz)) = CSize (W64# (int2Word# sz))+#endif++csizeOfOffset :: Offset8 -> CSize+#if WORD_SIZE_IN_BITS < 64+csizeOfOffset (Offset (I# sz)) = CSize (W32# (int2Word# sz))+#else+csizeOfOffset (Offset (I# sz)) = CSize (W64# (int2Word# sz))+#endif++sizeOfCSSize :: CSsize -> CountOf Word8+sizeOfCSSize (CSsize (-1))      = error "invalid size: CSSize is -1"+#if WORD_SIZE_IN_BITS < 64+sizeOfCSSize (CSsize (I32# sz)) = CountOf (I# sz)+#else+sizeOfCSSize (CSsize (I64# sz)) = CountOf (I# sz)+#endif++sizeOfCSize :: CSize -> CountOf Word8+#if WORD_SIZE_IN_BITS < 64+sizeOfCSize (CSize (W32# sz)) = CountOf (I# (word2Int# sz))+#else+sizeOfCSize (CSize (W64# sz)) = CountOf (I# (word2Int# sz))+#endif
+ Basement/Types/Ptr.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE MagicHash #-}+module Basement.Types.Ptr+    ( Addr(..)+    , addrPlus+    , addrPlusSz+    , addrPlusCSz+    , Ptr(..)+    , ptrPlus+    , ptrPlusSz+    , ptrPlusCSz+    , castPtr+    ) where++import           Basement.Compat.Base+import           Basement.Types.OffsetSize+import           GHC.Ptr+import           GHC.Prim+import           GHC.Types+import           Foreign.C.Types++data Addr = Addr Addr#+    deriving (Eq,Ord)++addrPlus :: Addr -> Offset Word8 -> Addr+addrPlus (Addr addr) (Offset (I# i)) = Addr (plusAddr# addr i)++addrPlusSz :: Addr -> CountOf Word8 -> Addr+addrPlusSz (Addr addr) (CountOf (I# i)) = Addr (plusAddr# addr i)++addrPlusCSz :: Addr -> CSize -> Addr+addrPlusCSz addr = addrPlusSz addr . sizeOfCSize++ptrPlus :: Ptr a -> Offset Word8 -> Ptr a+ptrPlus (Ptr addr) (Offset (I# i)) = Ptr (plusAddr# addr i)++ptrPlusSz :: Ptr a -> CountOf Word8 -> Ptr a+ptrPlusSz (Ptr addr) (CountOf (I# i)) = Ptr (plusAddr# addr i)++ptrPlusCSz :: Ptr a -> CSize -> Ptr a+ptrPlusCSz ptr = ptrPlusSz ptr . sizeOfCSize
+ Basement/UArray.hs view
@@ -0,0 +1,963 @@+-- |+-- Module      : Basement.UArray+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : portable+--+-- An unboxed array of primitive types+--+-- All the cells in the array are in one chunk of contiguous+-- memory.+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Rank2Types #-}+module Basement.UArray+    ( UArray(..)+    , PrimType(..)+    -- * methods+    , copy+    , unsafeCopyAtRO+    -- * internal methods+    -- , copyAddr+    , recast+    , unsafeRecast+    , length+    , freeze+    , unsafeFreeze+    , thaw+    , unsafeThaw+    -- * Creation+    , new+    , create+    , createFromIO+    , createFromPtr+    , sub+    , copyToPtr+    , withPtr+    , withMutablePtr+    , unsafeFreezeShrink+    , freezeShrink+    , unsafeSlide+    -- * accessors+    , update+    , unsafeUpdate+    , unsafeIndex+    , unsafeIndexer+    , unsafeDewrap+    , unsafeRead+    , unsafeWrite+    -- * Functions+    , equalMemcmp+    , singleton+    , replicate+    , map+    , mapIndex+    , findIndex+    , revFindIndex+    , index+    , null+    , take+    , unsafeTake+    , drop+    , unsafeDrop+    , splitAt+    , revDrop+    , revTake+    , revSplitAt+    , splitOn+    , break+    , breakElem+    , breakLine+    , elem+    , indices+    , intersperse+    , span+    , cons+    , snoc+    , uncons+    , unsnoc+    , find+    , sortBy+    , filter+    , reverse+    , replace+    , foldr+    , foldl'+    , foldr1+    , foldl1'+    , all+    , any+    , isPrefixOf+    , isSuffixOf+    , foreignMem+    , fromForeignPtr+    , builderAppend+    , builderBuild+    , builderBuild_+    , toHexadecimal+    , toBase64Internal+    ) where++import           Control.Monad (when)+import           GHC.Prim+import           GHC.Types+import           GHC.Word+import           GHC.ST+import           GHC.Ptr+import           GHC.ForeignPtr (ForeignPtr)+import           Foreign.Marshal.Utils (copyBytes)+import           Basement.Compat.Base+import           Basement.Compat.Primitive+import           Data.Proxy+import           Basement.Types.OffsetSize+import           Basement.Compat.MonadTrans+import           Basement.NonEmpty+import           Basement.Monad+import           Basement.PrimType+import           Basement.FinalPtr+import           Basement.Exception+import           Basement.Utils+import           Basement.UArray.Base+import           Basement.Block (Block(..), MutableBlock(..))+import           Basement.UArray.Mutable hiding (sub, copyToPtr)+import           Basement.Numerical.Additive+import           Basement.Numerical.Subtractive+import           Basement.Numerical.Multiplicative+import           Basement.MutableBuilder+import           Basement.Bindings.Memory (sysHsMemFindByteBa, sysHsMemFindByteAddr)+import qualified Basement.Compat.ExtList as List+import qualified Basement.Base16 as Base16+import qualified Basement.UArray.BA as PrimBA+import qualified Basement.UArray.Addr as PrimAddr++-- | Copy every cells of an existing array to a new array+copy :: PrimType ty => UArray ty -> UArray ty+copy array = runST (thaw array >>= unsafeFreeze)++-- | Thaw an array to a mutable array.+--+-- the array is not modified, instead a new mutable array is created+-- and every values is copied, before returning the mutable array.+thaw :: (PrimMonad prim, PrimType ty) => UArray ty -> prim (MUArray ty (PrimState prim))+thaw array = do+    ma <- new (length array)+    unsafeCopyAtRO ma azero array (Offset 0) (length array)+    pure ma+{-# INLINE thaw #-}++-- | Return the element at a specific index from an array.+--+-- If the index @n is out of bounds, an error is raised.+index :: PrimType ty => UArray ty -> Offset ty -> ty+index array n+    | isOutOfBound n len = outOfBound OOB_Index n len+    | otherwise          = unsafeIndex array n+  where+    !len = length array+{-# INLINE index #-}++foreignMem :: PrimType ty+           => FinalPtr ty -- ^ the start pointer with a finalizer+           -> CountOf ty  -- ^ the number of elements (in elements, not bytes)+           -> UArray ty+foreignMem fptr nb = UArray (Offset 0) nb (UArrayAddr fptr)++fromForeignPtr :: PrimType ty+               => (ForeignPtr ty, Int, Int) -- ForeignPtr, an offset in prim elements, a size in prim elements+               -> UArray ty+fromForeignPtr (fptr, ofs, len) = UArray (Offset ofs) (CountOf len) (UArrayAddr $ toFinalPtrForeign fptr)+++-- | Allocate a new array with a fill function that has access to the elements of+--   the source array.+unsafeCopyFrom :: (PrimType a, PrimType b)+               => UArray a -- ^ Source array+               -> CountOf b -- ^ Length of the destination array+               -> (UArray a -> Offset a -> MUArray b s -> ST s ())+               -- ^ Function called for each element in the source array+               -> ST s (UArray b) -- ^ Returns the filled new array+unsafeCopyFrom v' newLen f = new newLen >>= fill 0 >>= unsafeFreeze+  where len = length v'+        fill i r'+            | i .==# len = pure r'+            | otherwise  = do f v' i r'+                              fill (i + 1) r'++freeze :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> prim (UArray ty)+freeze ma = do+    ma' <- new len+    copyAt ma' (Offset 0) ma (Offset 0) len+    unsafeFreeze ma'+  where len = mutableLength ma++freezeShrink :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> CountOf ty -> prim (UArray ty)+freezeShrink ma n = do+    ma' <- new n+    copyAt ma' (Offset 0) ma (Offset 0) n+    unsafeFreeze ma'++unsafeSlide :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> Offset ty -> Offset ty -> prim ()+unsafeSlide mua s e = doSlide mua s e+  where+    doSlide :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> Offset ty -> Offset ty -> prim ()+    doSlide (MUArray mbStart _ (MUArrayMBA (MutableBlock mba))) start end  =+        primMutableByteArraySlideToStart mba (offsetInBytes $ mbStart+start) (offsetInBytes end)+    doSlide (MUArray mbStart _ (MUArrayAddr fptr)) start end = withFinalPtr fptr $ \(Ptr addr) ->+        primMutableAddrSlideToStart addr (offsetInBytes $ mbStart+start) (offsetInBytes end)++-- | Create a new array of size @n by settings each cells through the+-- function @f.+create :: forall ty . PrimType ty+       => CountOf ty           -- ^ the size of the array+       -> (Offset ty -> ty) -- ^ the function that set the value at the index+       -> UArray ty         -- ^ the array created+create n initializer+    | n == 0    = mempty+    | otherwise = runST (new n >>= iter initializer)+  where+    iter :: (PrimType ty, PrimMonad prim) => (Offset ty -> ty) -> MUArray ty (PrimState prim) -> prim (UArray ty)+    iter f ma = loop 0+      where+        loop i+            | i .==# n  = unsafeFreeze ma+            | otherwise = unsafeWrite ma i (f i) >> loop (i+1)+        {-# INLINE loop #-}+    {-# INLINE iter #-}++-- | Create a pinned array that is filled by a 'filler' function (typically an IO call like hGetBuf)+createFromIO :: PrimType ty+             => CountOf ty                  -- ^ the size of the array+             -> (Ptr ty -> IO (CountOf ty)) -- ^ filling function that+             -> IO (UArray ty)+createFromIO size filler+    | size == 0 = pure mempty+    | otherwise = do+        mba <- newPinned size+        r   <- withMutablePtr mba $ \p -> filler p+        case r of+            0             -> pure mempty -- make sure we don't keep our array referenced by using empty+            _ | r < 0     -> error "filler returned negative number"+              | otherwise -> unsafeFreezeShrink mba r++-- | Freeze a chunk of memory pointed, of specific size into a new unboxed array+createFromPtr :: PrimType ty+              => Ptr ty+              -> CountOf ty+              -> IO (UArray ty)+createFromPtr p s = do+    ma <- new s+    copyFromPtr p s ma+    unsafeFreeze ma++-----------------------------------------------------------------------+-- higher level collection implementation+-----------------------------------------------------------------------++singleton :: PrimType ty => ty -> UArray ty+singleton ty = create 1 (const ty)++replicate :: PrimType ty => CountOf ty -> ty -> UArray ty+replicate sz ty = create sz (const ty)++-- | update an array by creating a new array with the updates.+--+-- the operation copy the previous array, modify it in place, then freeze it.+update :: PrimType ty+       => UArray ty+       -> [(Offset ty, ty)]+       -> UArray ty+update array modifiers = runST (thaw array >>= doUpdate modifiers)+  where doUpdate l ma = loop l+          where loop []         = unsafeFreeze ma+                loop ((i,v):xs) = write ma i v >> loop xs+                {-# INLINE loop #-}+        {-# INLINE doUpdate #-}++unsafeUpdate :: PrimType ty+             => UArray ty+             -> [(Offset ty, ty)]+             -> UArray ty+unsafeUpdate array modifiers = runST (thaw array >>= doUpdate modifiers)+  where doUpdate l ma = loop l+          where loop []         = unsafeFreeze ma+                loop ((i,v):xs) = unsafeWrite ma i v >> loop xs+                {-# INLINE loop #-}+        {-# INLINE doUpdate #-}++-- | Copy all the block content to the memory starting at the destination address+copyToPtr :: forall ty prim . (PrimType ty, PrimMonad prim)+          => UArray ty -- ^ the source array to copy+          -> Ptr ty    -- ^ The destination address where the copy is going to start+          -> prim ()+copyToPtr arr dst@(Ptr dst#) = onBackendPrim copyBa copyPtr arr+  where+    !(Offset os@(I# os#)) = offsetInBytes $ offset arr+    !(CountOf szBytes@(I# szBytes#)) = sizeInBytes $ length arr+    copyBa ba = primitive $ \s1 -> (# compatCopyByteArrayToAddr# ba os# dst# szBytes# s1, () #)+    copyPtr fptr = unsafePrimFromIO $ withFinalPtr fptr $ \ptr -> copyBytes dst (ptr `plusPtr` os) szBytes++withPtr :: forall ty prim a . (PrimMonad prim, PrimType ty)+        => UArray ty+        -> (Ptr ty -> prim a)+        -> prim a+withPtr a f+    | isPinned a == Pinned =+        onBackendPrim (\ba -> f (Ptr (byteArrayContents# ba) `plusPtr` os))+                      (\fptr -> withFinalPtr fptr $ \ptr -> f (ptr `plusPtr` os))+                      a+    | otherwise = do+        arr <- do+            trampoline <- newPinned (length a)+            unsafeCopyAtRO trampoline 0 a 0 (length a)+            unsafeFreeze trampoline+        r <- withPtr arr f+        touch arr+        pure r+  where+    !sz          = primSizeInBytes (Proxy :: Proxy ty)+    !(Offset os) = offsetOfE sz $ offset a+{-# INLINE withPtr #-}++-- | Recast an array of type a to an array of b+--+-- a and b need to have the same size otherwise this+-- raise an async exception+recast :: forall a b . (PrimType a, PrimType b) => UArray a -> UArray b+recast array+    | aTypeSize == bTypeSize = unsafeRecast array+    | missing   == 0         = unsafeRecast array+    | otherwise = throw $ InvalidRecast+                      (RecastSourceSize      alen)+                      (RecastDestinationSize $ alen + missing)+  where+    aTypeSize = primSizeInBytes (Proxy :: Proxy a)+    bTypeSize@(CountOf bs) = primSizeInBytes (Proxy :: Proxy b)+    (CountOf alen) = sizeInBytes (length array)+    missing = alen `mod` bs++unsafeRecast :: (PrimType a, PrimType b) => UArray a -> UArray b+unsafeRecast (UArray start len backend) = UArray (primOffsetRecast start) (sizeRecast len) $+    case backend of+        UArrayAddr fptr     -> UArrayAddr (castFinalPtr fptr)+        UArrayBA (Block ba) -> UArrayBA (Block ba)+{-# INLINE [1] unsafeRecast #-}+{-# SPECIALIZE [3] unsafeRecast :: PrimType a => UArray Word8 -> UArray a #-}++null :: UArray ty -> Bool+null arr = length arr == 0++-- | Take a count of elements from the array and create an array with just those elements+take :: CountOf ty -> UArray ty -> UArray ty+take n arr@(UArray start len backend)+    | n <= 0    = empty+    | n >= len  = arr+    | otherwise = UArray start n backend++unsafeTake :: CountOf ty -> UArray ty -> UArray ty+unsafeTake sz (UArray start _ ba) = UArray start sz ba++-- | Drop a count of elements from the array and return the new array minus those dropped elements+drop :: CountOf ty -> UArray ty -> UArray ty+drop n arr@(UArray start len backend)+    | n <= 0                             = arr+    | Just newLen <- len - n, newLen > 0 = UArray (start `offsetPlusE` n) newLen backend+    | otherwise                          = empty++unsafeDrop :: CountOf ty -> UArray ty -> UArray ty+unsafeDrop n (UArray start sz backend) = UArray (start `offsetPlusE` n) (sz `sizeSub` n) backend++-- | Split an array into two, with a count of at most N elements in the first one+-- and the remaining in the other.+splitAt :: CountOf ty -> UArray ty -> (UArray ty, UArray ty)+splitAt nbElems arr@(UArray start len backend)+    | nbElems <= 0                               = (empty, arr)+    | Just nbTails <- len - nbElems, nbTails > 0 = (UArray start                         nbElems backend+                                                   ,UArray (start `offsetPlusE` nbElems) nbTails backend)+    | otherwise                                  = (arr, empty)++breakElem :: PrimType ty => ty -> UArray ty -> (UArray ty, UArray ty)+breakElem !ty arr@(UArray start len backend)+    | k == end   = (arr, empty)+    | k == start = (empty, arr)+    | otherwise  = ( UArray start (offsetAsSize k `sizeSub` offsetAsSize start) backend+                   , UArray k     (len `sizeSub` (offsetAsSize k `sizeSub` offsetAsSize start)) backend)+  where+    !end = start `offsetPlusE` len+    !k = onBackend goBa (\fptr -> pure . goAddr fptr) arr+    goBa ba = PrimBA.findIndexElem ty ba start end+    goAddr _ (Ptr addr) = PrimAddr.findIndexElem ty addr start end+{-# NOINLINE [3] breakElem #-}+{-# RULES "breakElem Word8" [3] breakElem = breakElemByte #-}+{-# SPECIALIZE [3] breakElem :: Word32 -> UArray Word32 -> (UArray Word32, UArray Word32) #-}++breakElemByte :: Word8 -> UArray Word8 -> (UArray Word8, UArray Word8)+breakElemByte !ty arr@(UArray start len backend)+    | 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)+  where+    !end = start `offsetPlusE` len+    !k = onBackend goBa (\fptr -> pure . goAddr fptr) arr+    goBa ba = sysHsMemFindByteBa ba start end ty+    goAddr _ (Ptr addr) = sysHsMemFindByteAddr addr start end ty++-- | Similar to breakElem specialized to split on linefeed+--+-- it either returns:+-- * Left. no line has been found, and whether the last character is a CR+-- * Right, a line has been found with an optional CR, and it returns+--   the array of bytes on the left of the CR/LF, and the+--   the array of bytes on the right of the LF.+--+breakLine :: UArray Word8 -> Either Bool (UArray Word8, UArray Word8)+breakLine arr@(UArray start len backend)+    | end == start = Left False+    | k2 == end    = Left (k1 /= k2)+    | otherwise    = let newArray start' len' = if len' == 0 then empty else UArray start' len' backend+                      in Right (newArray start (k1-start), newArray (k2+1) (end - (k2+1)))+  where+    !end = start `offsetPlusE` len+    -- return (offset of CR, offset of LF, whether the last element was a carriage return+    !(k1, k2) = onBackend goBa (\fptr -> pure . goAddr fptr) arr+    lineFeed = 0xa+    carriageReturn = 0xd+    goBa ba =+        let k = sysHsMemFindByteBa ba start end lineFeed+            cr = k > start && PrimBA.primIndex 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+         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)+countFromStart :: UArray ty -> CountOf ty -> CountOf ty+countFromStart v sz@(CountOf sz')+    | sz >= len = CountOf 0+    | otherwise = CountOf (len' - sz')+  where len@(CountOf len') = length v++-- | Take the N elements from the end of the array+revTake :: CountOf ty -> UArray ty -> UArray ty+revTake n v = drop (countFromStart v n) v++-- | Drop the N elements from the end of the array+revDrop :: CountOf ty -> UArray ty -> UArray ty+revDrop n v = take (countFromStart v n) v++-- | Split an array at the N element from the end, and return+-- the last N elements in the first part of the tuple, and whatever first+-- elements remaining in the second+revSplitAt :: CountOf ty -> UArray ty -> (UArray ty, UArray ty)+revSplitAt n v = (drop sz v, take sz v) where sz = countFromStart v n++splitOn :: PrimType ty => (ty -> Bool) -> UArray ty -> [UArray ty]+splitOn xpredicate ivec+    | len == 0  = [mempty]+    | otherwise = runST $ unsafeIndexer ivec (pureST . go ivec xpredicate)+  where+    !len = length ivec+    go v predicate getIdx = loop 0 0+      where+        loop !prevIdx !idx+            | idx .==# len = [sub v prevIdx idx]+            | otherwise    =+                let e = getIdx idx+                    idx' = idx + 1+                 in if predicate e+                        then sub v prevIdx idx : loop idx' idx'+                        else loop prevIdx idx'+    {-# INLINE go #-}++sub :: PrimType ty => UArray ty -> Offset ty -> Offset ty -> UArray ty+sub (UArray start len backend) startIdx expectedEndIdx+    | startIdx >= endIdx = mempty+    | otherwise          = UArray (start + startIdx) newLen backend+  where+    newLen = endIdx - startIdx+    endIdx = min expectedEndIdx (0 `offsetPlusE` len)++findIndex :: PrimType ty => ty -> UArray ty -> Maybe (Offset ty)+findIndex ty arr+    | k == end  = Nothing+    | otherwise = Just (k `offsetSub` start)+  where+    !k = onBackend goBa (\_ -> pure . goAddr) arr+    !start = offset arr+    !end = start `offsetPlusE` length arr+    goBa ba = PrimBA.findIndexElem ty ba start end+    goAddr (Ptr addr) = PrimAddr.findIndexElem ty addr start end+{-# SPECIALIZE [3] findIndex :: Word8 -> UArray Word8 -> Maybe (Offset Word8) #-}++revFindIndex :: PrimType ty => ty -> UArray ty -> Maybe (Offset ty)+revFindIndex ty arr+    | k == end  = Nothing+    | otherwise = Just (k `offsetSub` start)+  where+    !k = onBackend goBa (\_ -> pure . goAddr) arr+    !start = offset arr+    !end = start `offsetPlusE` length arr+    goBa ba = PrimBA.revFindIndexElem ty ba start end+    goAddr (Ptr addr) = PrimAddr.revFindIndexElem ty addr start end+{-# SPECIALIZE [3] revFindIndex :: Word8 -> UArray Word8 -> Maybe (Offset Word8) #-}++break :: forall ty . PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty)+break xpredicate xv+    | len == 0  = (mempty, mempty)+    | otherwise = runST $ unsafeIndexer xv (go xv xpredicate)+  where+    !len = length xv+    go :: PrimType ty => UArray ty -> (ty -> Bool) -> (Offset ty -> ty) -> ST s (UArray ty, UArray ty)+    go v predicate getIdx = pure (findBreak $ Offset 0)+      where+        findBreak !i+            | i .==# len           = (v, mempty)+            | predicate (getIdx i) = splitAt (offsetAsSize i) v+            | otherwise            = findBreak (i + Offset 1)+        {-# INLINE findBreak #-}+    {-# INLINE go #-}+{-# NOINLINE [2] break #-}+{-# SPECIALIZE [2] break :: (Word8 -> Bool) -> UArray Word8 -> (UArray Word8, UArray Word8) #-}++{-+{-# RULES "break (== ty)" [3] forall (x :: forall ty . PrimType ty => ty) . break (== x) = breakElem x #-}+{-# RULES "break (ty ==)" [3] forall (x :: forall ty . PrimType ty => ty) . break (x ==) = breakElem x #-}+{-# RULES "break (== ty)" [3] forall (x :: Word8) . break (== x) = breakElem x #-}+-}++elem :: PrimType ty => ty -> UArray ty -> Bool+elem !ty arr = onBackend goBa (\_ -> pure . goAddr) arr /= end+  where+    !start = offset arr+    !end = start `offsetPlusE` length arr+    goBa ba = PrimBA.findIndexElem ty ba start end+    goAddr (Ptr addr) = PrimAddr.findIndexElem ty addr start end+{-# SPECIALIZE [2] elem :: Word8 -> UArray Word8 -> Bool #-}++intersperse :: forall ty . PrimType ty => ty -> UArray ty -> UArray ty+intersperse sep v = case len - 1 of+    Nothing -> v+    Just 0 -> v+    Just gaps -> runST $ unsafeCopyFrom v (len + gaps) go+  where+    len = length v++    go :: PrimType ty => UArray ty -> Offset ty -> MUArray ty s -> ST s ()+    go oldV oldI newV+        | (oldI + 1) .==# len = unsafeWrite newV newI e+        | otherwise           = do+            unsafeWrite newV newI e+            unsafeWrite newV (newI + 1) sep+      where+        e = unsafeIndex oldV oldI+        newI = scale (2 :: Word) oldI++span :: PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty)+span p = break (not . p)++map :: (PrimType a, PrimType b) => (a -> b) -> UArray a -> UArray b+map f a = create lenB (\i -> f $ unsafeIndex a (offsetCast Proxy i))+  where !lenB = sizeCast (Proxy :: Proxy (a -> b)) (length a)++mapIndex :: (PrimType a, PrimType b) => (Offset b -> a -> b) -> UArray a -> UArray b+mapIndex f a = create (sizeCast Proxy $ length a) (\i -> f i $ unsafeIndex a (offsetCast Proxy i))++cons :: PrimType ty => ty -> UArray ty -> UArray ty+cons e vec+    | len == CountOf 0 = singleton e+    | otherwise     = runST $ do+        muv <- new (len + 1)+        unsafeCopyAtRO muv 1 vec 0 len+        unsafeWrite muv 0 e+        unsafeFreeze muv+  where+    !len = length vec++snoc :: PrimType ty => UArray ty -> ty -> UArray ty+snoc vec e+    | len == CountOf 0 = singleton e+    | otherwise     = runST $ do+        muv <- new (len + CountOf 1)+        unsafeCopyAtRO muv (Offset 0) vec (Offset 0) len+        unsafeWrite muv (0 `offsetPlusE` length vec) e+        unsafeFreeze muv+  where+     !len = length vec++uncons :: PrimType ty => UArray ty -> Maybe (ty, UArray ty)+uncons vec+    | nbElems == 0 = Nothing+    | otherwise    = Just (unsafeIndex vec 0, sub vec 1 (0 `offsetPlusE` nbElems))+  where+    !nbElems = length vec++unsnoc :: PrimType ty => UArray ty -> Maybe (UArray ty, ty)+unsnoc vec = case length vec - 1 of+    Nothing -> Nothing+    Just newLen -> Just (sub vec 0 lastElem, unsafeIndex vec lastElem)+                     where !lastElem = 0 `offsetPlusE` newLen++find :: PrimType ty => (ty -> Bool) -> UArray ty -> Maybe ty+find predicate vec = loop 0+  where+    !len = length vec+    loop i+        | i .==# len = Nothing+        | otherwise  =+            let e = unsafeIndex vec i+             in if predicate e then Just e else loop (i+1)++sortBy :: forall ty . PrimType ty => (ty -> ty -> Ordering) -> UArray ty -> UArray ty+sortBy xford vec+    | len == 0  = mempty+    | otherwise = runST (thaw vec >>= doSort xford)+  where+    len = length vec+    doSort :: (PrimType ty, PrimMonad prim) => (ty -> ty -> Ordering) -> MUArray ty (PrimState prim) -> prim (UArray ty)+    doSort ford ma = qsort 0 (sizeLastOffset len) >> unsafeFreeze ma+      where+        qsort lo hi+            | lo >= hi  = pure ()+            | otherwise = do+                p <- partition lo hi+                qsort lo (pred p)+                qsort (p+1) hi+        partition lo hi = do+            pivot <- unsafeRead ma hi+            let loop i j+                    | j == hi   = pure i+                    | otherwise = do+                        aj <- unsafeRead ma j+                        i' <- if ford aj pivot == GT+                                then pure i+                                else do+                                    ai <- unsafeRead ma i+                                    unsafeWrite ma j ai+                                    unsafeWrite ma i aj+                                    pure $ i + 1+                        loop i' (j+1)++            i <- loop lo lo+            ai  <- unsafeRead ma i+            ahi <- unsafeRead ma hi+            unsafeWrite ma hi ai+            unsafeWrite ma i ahi+            pure i++filter :: forall ty . PrimType ty => (ty -> Bool) -> UArray ty -> UArray ty+filter predicate arr = runST $ do+    (newLen, ma) <- newNative (length arr) $ \mba ->+            onBackendPrim (\ba -> PrimBA.filter predicate mba ba start end)+                          (\fptr -> withFinalPtr fptr $ \(Ptr addr) ->+                                        PrimAddr.filter predicate mba addr start end)+                          arr+    unsafeFreezeShrink ma newLen+  where+    !len   = length arr+    !start = offset arr+    !end   = start `offsetPlusE` len++reverse :: PrimType ty => UArray ty -> UArray ty+reverse a+    | len == 0  = mempty+    | otherwise = runST $ do+        ((), ma) <- newNative len $ \mba -> onBackendPrim (goNative mba)+                                                          (\fptr -> withFinalPtr fptr $ goAddr mba)+                                                          a+        unsafeFreeze ma+  where+    !len = length a+    !end = 0 `offsetPlusE` len+    !start = offset a+    !endI = sizeAsOffset ((start + end) - Offset 1)++    goNative :: MutableByteArray# s -> ByteArray# -> ST s ()+    goNative !ma !ba = loop 0+      where+        loop !i+            | i == end  = pure ()+            | otherwise = primMbaWrite ma i (primBaIndex ba (sizeAsOffset (endI - i))) >> loop (i+1)+    goAddr :: MutableByteArray# s -> Ptr ty -> ST s ()+    goAddr !ma (Ptr addr) = loop 0+      where+        loop !i+            | i == end  = pure ()+            | otherwise = primMbaWrite ma i (primAddrIndex addr (sizeAsOffset (endI - i))) >> loop (i+1)+{-# SPECIALIZE [3] reverse :: UArray Word8 -> UArray Word8 #-}++-- Finds where are the insertion points when we search for a `needle`+-- within an `haystack`.+-- Throws an error in case `needle` is empty.+indices :: PrimType ty => UArray ty -> UArray ty -> [Offset ty]+indices needle hy+  | needleLen <= 0 = error "Basement.UArray.indices: needle is empty."+  | otherwise = case haystackLen < needleLen of+                  True  -> []+                  False -> go (Offset 0) []+  where+    !haystackLen = length hy++    !needleLen = length needle++    go currentOffset ipoints+      | (currentOffset `offsetPlusE` needleLen) > (sizeAsOffset haystackLen) = ipoints+      | otherwise =+        let matcher = take needleLen . drop (offsetAsSize currentOffset) $ hy+        in case matcher == needle of+             -- TODO: Move away from right-appending as it's gonna be slow.+             True  -> go (currentOffset `offsetPlusE` needleLen) (ipoints <> [currentOffset])+             False -> go (currentOffset + 1) ipoints++-- | Replace all the occurrencies of `needle` with `replacement` in+-- the `haystack` string.+replace :: PrimType ty => UArray ty -> UArray ty -> UArray ty -> UArray ty+replace (needle :: UArray ty) replacement haystack = runST $ do+    case null needle of+      True -> error "Basement.UArray.replace: empty needle"+      False -> do+        let insertionPoints = indices needle haystack+        let !occs           = List.length insertionPoints+        let !newLen         = haystackLen `sizeSub` (multBy needleLen occs) + (multBy replacementLen occs)+        ms <- new newLen+        loop ms (Offset 0) (Offset 0) insertionPoints+  where++    multBy (CountOf x) y = CountOf (x * y)++    !needleLen = length needle++    !replacementLen = length replacement++    !haystackLen = length haystack++    -- Go through each insertion point and copy things over.+    -- We keep around the offset to the original string to+    -- be able to copy bytes which didn't change.+    loop :: PrimMonad prim+         => MUArray ty (PrimState prim)+         -> Offset ty+         -> Offset ty+         -> [Offset ty]+         -> prim (UArray ty)+    loop mba currentOffset offsetInOriginalString [] = do+      -- Finalise the string+      let !unchangedDataLen = sizeAsOffset haystackLen - offsetInOriginalString+      unsafeCopyAtRO mba currentOffset haystack offsetInOriginalString unchangedDataLen+      freeze mba+    loop mba currentOffset offsetInOriginalString (x:xs) = do+        -- 1. Copy from the old string.+        let !unchangedDataLen = (x - offsetInOriginalString)+        unsafeCopyAtRO mba currentOffset haystack offsetInOriginalString unchangedDataLen+        let !newOffset = currentOffset `offsetPlusE` unchangedDataLen+        -- 2. Copy the replacement.+        unsafeCopyAtRO mba newOffset replacement (Offset 0) replacementLen+        let !offsetInOriginalString' = offsetInOriginalString `offsetPlusE` unchangedDataLen `offsetPlusE` needleLen+        loop mba (newOffset `offsetPlusE` replacementLen) offsetInOriginalString' xs+{-# SPECIALIZE [3] replace :: UArray Word8 -> UArray Word8 -> UArray Word8 -> UArray Word8 #-}++foldr :: PrimType ty => (ty -> a -> a) -> a -> UArray ty -> a+foldr f initialAcc vec = loop 0+  where+    !len = length vec+    loop i+        | i .==# len = initialAcc+        | otherwise  = unsafeIndex vec i `f` loop (i+1)++foldl' :: PrimType ty => (a -> ty -> a) -> a -> UArray ty -> a+foldl' f initialAcc arr = onBackend goNative (\_ -> pure . goAddr) arr+  where+    !len = length arr+    !start = offset arr+    !end = start `offsetPlusE` len+    goNative ba = PrimBA.foldl f initialAcc ba start end+    goAddr (Ptr ptr) = PrimAddr.foldl f initialAcc ptr start end+{-# SPECIALIZE [3] foldl' :: (a -> Word8 -> a) -> a -> UArray Word8 -> a #-}++foldl1' :: PrimType ty => (ty -> ty -> ty) -> NonEmpty (UArray ty) -> ty+foldl1' f (NonEmpty arr) = onBackend goNative (\_ -> pure . goAddr) arr+  where+    !len = length arr+    !start = offset arr+    !end = start `offsetPlusE` len+    goNative ba = PrimBA.foldl1 f ba start end+    goAddr (Ptr ptr) = PrimAddr.foldl1 f ptr start end+{-# SPECIALIZE [3] foldl1' :: (Word8 -> Word8 -> Word8) -> NonEmpty (UArray Word8) -> Word8 #-}++foldr1 :: PrimType ty => (ty -> ty -> ty) -> NonEmpty (UArray ty) -> ty+foldr1 f arr = let (initialAcc, rest) = revSplitAt 1 $ getNonEmpty arr+               in foldr f (unsafeIndex initialAcc 0) rest++all :: PrimType ty => (ty -> Bool) -> UArray ty -> Bool+all predicate arr = onBackend (\ba -> PrimBA.all predicate ba start end)+                              (\_ (Ptr ptr) -> pure (PrimAddr.all predicate ptr start end))+                              arr+  where+    start = offset arr+    end = start `offsetPlusE` length arr+{-# SPECIALIZE [3] all :: (Word8 -> Bool) -> UArray Word8 -> Bool #-}++any :: PrimType ty => (ty -> Bool) -> UArray ty -> Bool+any predicate arr = onBackend (\ba -> PrimBA.any predicate ba start end)+                              (\_ (Ptr ptr) -> pure (PrimAddr.any predicate ptr start end))+                              arr+  where+    start = offset arr+    end = start `offsetPlusE` length arr+{-# SPECIALIZE [3] any :: (Word8 -> Bool) -> UArray Word8 -> Bool #-}++builderAppend :: (PrimType ty, PrimMonad state) => ty -> Builder (UArray ty) (MUArray ty) ty state err ()+builderAppend v = Builder $ State $ \(i, st, e) ->+    if offsetAsSize i == chunkSize st+        then do+            cur      <- unsafeFreeze (curChunk st)+            newChunk <- new (chunkSize st)+            unsafeWrite newChunk 0 v+            pure ((), (Offset 1, st { prevChunks     = cur : prevChunks st+                                    , prevChunksSize = chunkSize st + prevChunksSize st+                                    , curChunk       = newChunk+                                    }, e))+        else do+            unsafeWrite (curChunk st) i v+            pure ((), (i + 1, st, e))++builderBuild :: (PrimType ty, PrimMonad m) => Int -> Builder (UArray ty) (MUArray ty) ty m err () -> m (Either err (UArray ty))+builderBuild sizeChunksI ab+    | sizeChunksI <= 0 = builderBuild 64 ab+    | otherwise        = do+        first         <- new sizeChunks+        ((), (i, st, e)) <- runState (runBuilder ab) (Offset 0, BuildingState [] (CountOf 0) first sizeChunks, Nothing)+        case e of+          Just err -> pure (Left err)+          Nothing -> do+            cur <- unsafeFreezeShrink (curChunk st) (offsetAsSize i)+            -- Build final array+            let totalSize = prevChunksSize st + offsetAsSize i+            bytes <- new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= unsafeFreeze+            pure (Right bytes)+  where+      sizeChunks = CountOf sizeChunksI++      fillFromEnd _    []     mua = pure mua+      fillFromEnd !end (x:xs) mua = do+          let sz = length x+          let start = end `sizeSub` sz+          unsafeCopyAtRO mua (sizeAsOffset start) x (Offset 0) sz+          fillFromEnd start xs mua++builderBuild_ :: (PrimType ty, PrimMonad m) => Int -> Builder (UArray ty) (MUArray ty) ty m () () -> m (UArray ty)+builderBuild_ sizeChunksI ab = either (\() -> internalError "impossible output") id <$> builderBuild sizeChunksI ab++toHexadecimal :: PrimType ty => UArray ty -> UArray Word8+toHexadecimal ba+    | len == CountOf 0 = mempty+    | otherwise     = runST $ do+        ma <- new (len `scale` 2)+        unsafeIndexer b8 (go ma)+        unsafeFreeze ma+  where+    b8 = unsafeRecast ba+    !len = length b8+    !endOfs = Offset 0 `offsetPlusE` len++    go :: MUArray Word8 s -> (Offset Word8 -> Word8) -> ST s ()+    go !ma !getAt = loop 0 0+      where+        loop !dIdx !sIdx+            | sIdx == endOfs = pure ()+            | otherwise      = do+                let !(W8# !w)       = getAt sIdx+                    !(# wHi, wLo #) = Base16.unsafeConvertByte w+                unsafeWrite ma dIdx     (W8# wHi)+                unsafeWrite ma (dIdx+1) (W8# wLo)+                loop (dIdx + 2) (sIdx+1)++toBase64Internal :: PrimType ty => Addr# -> UArray ty -> Bool -> UArray Word8+toBase64Internal table src padded+    | len == CountOf 0 = mempty+    | otherwise = runST $ do+        ma <- new dstLen+        unsafeIndexer b8 (go ma)+        unsafeFreeze ma+  where+    b8 = unsafeRecast src+    !len = length b8+    !dstLen = outputLengthBase64 padded len+    !endOfs = Offset 0 `offsetPlusE` len+    !dstEndOfs = Offset 0 `offsetPlusE` dstLen++    go :: MUArray Word8 s -> (Offset Word8 -> Word8) -> ST s ()+    go !ma !getAt = loop 0 0+      where+        eqChar = 0x3d :: Word8++        loop !sIdx !dIdx+            | sIdx == endOfs = when padded $ do+                when (dIdx `offsetPlusE` CountOf 1 <= dstEndOfs) $ unsafeWrite ma dIdx eqChar+                when (dIdx `offsetPlusE` CountOf 2 == dstEndOfs) $ unsafeWrite ma (dIdx `offsetPlusE` CountOf 1) eqChar+            | otherwise = do+                let !b2Idx = sIdx `offsetPlusE` CountOf 1+                    !b3Idx = sIdx `offsetPlusE` CountOf 2++                    !b2Available = b2Idx < endOfs+                    !b3Available = b3Idx < endOfs++                    !b1 = getAt sIdx+                    !b2 = if b2Available then getAt b2Idx else 0+                    !b3 = if b3Available then getAt b3Idx else 0++                    (w,x,y,z) = convert3 table b1 b2 b3++                    sNextIncr = 1 + fromEnum b2Available + fromEnum b3Available+                    dNextIncr = 1 + sNextIncr++                unsafeWrite ma dIdx w+                unsafeWrite ma (dIdx `offsetPlusE` CountOf 1) x++                when b2Available $ unsafeWrite ma (dIdx `offsetPlusE` CountOf 2) y+                when b3Available $ unsafeWrite ma (dIdx `offsetPlusE` CountOf 3) z++                loop (sIdx `offsetPlusE` CountOf sNextIncr) (dIdx `offsetPlusE` CountOf dNextIncr)++outputLengthBase64 :: Bool -> CountOf Word8 -> CountOf Word8+outputLengthBase64 padding (CountOf inputLenInt) = outputLength+  where+    outputLength = if padding then CountOf lenWithPadding else CountOf lenWithoutPadding+    lenWithPadding+        | m == 0    = 4 * d+        | otherwise = 4 * (d + 1)+    lenWithoutPadding+        | m == 0    = 4 * d+        | otherwise = 4 * d + m + 1+    (d,m) = inputLenInt `divMod` 3++convert3 :: Addr# -> Word8 -> Word8 -> Word8 -> (Word8, Word8, Word8, Word8)+convert3 table (W8# a) (W8# b) (W8# c) =+    let !w = narrow8Word# (uncheckedShiftRL# a 2#)+        !x = or# (and# (uncheckedShiftL# a 4#) 0x30##) (uncheckedShiftRL# b 4#)+        !y = or# (and# (uncheckedShiftL# b 2#) 0x3c##) (uncheckedShiftRL# c 6#)+        !z = and# c 0x3f##+     in (idx w, idx x, idx y, idx z)+  where+    idx :: Word# -> Word8+    idx i = W8# (indexWord8OffAddr# table (word2Int# i))++isPrefixOf :: PrimType ty => UArray ty -> UArray ty -> Bool+isPrefixOf pre arr+    | pLen > pArr = False+    | otherwise   = pre == unsafeTake pLen arr+  where+    !pLen = length pre+    !pArr = length arr+{-# SPECIALIZE [3] isPrefixOf :: UArray Word8 -> UArray Word8 -> Bool #-}++isSuffixOf :: PrimType ty => UArray ty -> UArray ty -> Bool+isSuffixOf suffix arr+    | pLen > pArr = False+    | otherwise   = suffix == revTake pLen arr+  where+    !pLen = length suffix+    !pArr = length arr+{-# SPECIALIZE [3] isSuffixOf :: UArray Word8 -> UArray Word8 -> Bool #-}
+ Basement/UArray/Addr.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE CPP                        #-}+module Basement.UArray.Addr+    ( findIndexElem+    , revFindIndexElem+    , findIndexPredicate+    , foldl+    , foldr+    , foldl1+    , all+    , any+    , filter+    , primIndex+    ) where++import           GHC.Types+import           GHC.Prim+import           Basement.Compat.Base+import           Basement.Numerical.Additive+import           Basement.Types.OffsetSize+import           Basement.PrimType+import           Basement.Monad++type Immutable = Addr#++primIndex :: PrimType ty => Immutable -> Offset ty -> ty+primIndex = primAddrIndex++findIndexElem :: PrimType ty => ty -> Immutable -> Offset ty -> Offset ty -> Offset ty+findIndexElem ty ba startIndex endIndex = loop startIndex+  where+    loop !i+        | i < endIndex && t /= ty = loop (i+1)+        | otherwise               = i+      where t = primIndex ba i+{-# INLINE findIndexElem #-}++revFindIndexElem :: PrimType ty => ty -> Immutable -> Offset ty -> Offset ty -> Offset ty+revFindIndexElem ty ba startIndex endIndex+    | endIndex > startIndex = loop (endIndex `offsetMinusE` 1)+    | otherwise             = endIndex+  where+    loop !i+        | t == ty        = i+        | i > startIndex = loop (i `offsetMinusE` 1)+        | otherwise      = endIndex+      where t = primIndex ba i+{-# INLINE revFindIndexElem #-}++findIndexPredicate :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Offset ty+findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex+  where+    loop !i+        | i < endIndex && not found = loop (i+1)+        | otherwise                 = i+      where found = predicate (primIndex ba i)+{-# INLINE findIndexPredicate #-}++foldl :: PrimType ty => (a -> ty -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a+foldl f !initialAcc ba !startIndex !endIndex = loop startIndex initialAcc+  where+    loop !i !acc+        | i == endIndex = acc+        | otherwise     = loop (i+1) (f acc (primIndex ba i))+{-# INLINE foldl #-}++foldr :: PrimType ty => (ty -> a -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a+foldr f !initialAcc ba startIndex endIndex = loop startIndex+  where+    loop !i+        | i == endIndex = initialAcc+        | otherwise     = primIndex ba i `f` loop (i+1)+{-# INLINE foldr #-}++foldl1 :: PrimType ty => (ty -> ty -> ty) -> Immutable -> Offset ty -> Offset ty -> ty+foldl1 f ba startIndex endIndex = loop (startIndex+1) (primIndex ba startIndex)+  where+    loop !i !acc+        | i == endIndex = acc+        | otherwise     = loop (i+1) (f acc (primIndex ba i))+{-# INLINE foldl1 #-}++filter :: (PrimMonad prim, PrimType ty)+       => (ty -> Bool) -> MutableByteArray# (PrimState prim) -> Immutable -> Offset ty -> Offset ty -> prim (CountOf ty)+filter predicate dst src start end = loop azero start+  where+    loop !d !s+        | s == end    = pure (offsetAsSize d)+        | predicate v = primMbaWrite dst d v >> loop (d+Offset 1) (s+Offset 1)+        | otherwise   = loop d (s+Offset 1)+      where+        v = primIndex src s++all :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool+all predicate ba start end = loop start+  where+    loop !i+        | i == end                   = True+        | predicate (primIndex ba i) = loop (i+1)+        | otherwise                  = False+{-# INLINE all #-}++any :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool+any predicate ba start end = loop start+  where+    loop !i+        | i == end                   = False+        | predicate (primIndex ba i) = True+        | otherwise                  = loop (i+1)+{-# INLINE any #-}
+ Basement/UArray/BA.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE CPP                        #-}+module Basement.UArray.BA+    ( findIndexElem+    , revFindIndexElem+    , findIndexPredicate+    , foldl+    , foldr+    , foldl1+    , all+    , any+    , filter+    , primIndex+    ) where++import           GHC.Types+import           GHC.Prim+import           Basement.Compat.Base+import           Basement.Numerical.Additive+import           Basement.Types.OffsetSize+import           Basement.PrimType+import           Basement.Monad++type Immutable = ByteArray#++primIndex :: PrimType ty => Immutable -> Offset ty -> ty+primIndex = primBaIndex++findIndexElem :: PrimType ty => ty -> Immutable -> Offset ty -> Offset ty -> Offset ty+findIndexElem ty ba startIndex endIndex = loop startIndex+  where+    loop !i+        | i < endIndex && t /= ty = loop (i+1)+        | otherwise               = i+      where t = primIndex ba i+{-# INLINE findIndexElem #-}++revFindIndexElem :: PrimType ty => ty -> Immutable -> Offset ty -> Offset ty -> Offset ty+revFindIndexElem ty ba startIndex endIndex+    | endIndex > startIndex = loop (endIndex `offsetMinusE` 1)+    | otherwise             = endIndex+  where+    loop !i+        | t == ty        = i+        | i > startIndex = loop (i `offsetMinusE` 1)+        | otherwise      = endIndex+      where t = primIndex ba i+{-# INLINE revFindIndexElem #-}++findIndexPredicate :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Offset ty+findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex+  where+    loop !i+        | i < endIndex && not found = loop (i+1)+        | otherwise                 = i+      where found = predicate (primIndex ba i)+{-# INLINE findIndexPredicate #-}++foldl :: PrimType ty => (a -> ty -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a+foldl f !initialAcc ba !startIndex !endIndex = loop startIndex initialAcc+  where+    loop !i !acc+        | i == endIndex = acc+        | otherwise     = loop (i+1) (f acc (primIndex ba i))+{-# INLINE foldl #-}++foldr :: PrimType ty => (ty -> a -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a+foldr f !initialAcc ba startIndex endIndex = loop startIndex+  where+    loop !i+        | i == endIndex = initialAcc+        | otherwise     = primIndex ba i `f` loop (i+1)+{-# INLINE foldr #-}++foldl1 :: PrimType ty => (ty -> ty -> ty) -> Immutable -> Offset ty -> Offset ty -> ty+foldl1 f ba startIndex endIndex = loop (startIndex+1) (primIndex ba startIndex)+  where+    loop !i !acc+        | i == endIndex = acc+        | otherwise     = loop (i+1) (f acc (primIndex ba i))+{-# INLINE foldl1 #-}++filter :: (PrimMonad prim, PrimType ty)+       => (ty -> Bool) -> MutableByteArray# (PrimState prim) -> Immutable -> Offset ty -> Offset ty -> prim (CountOf ty)+filter predicate dst src start end = loop azero start+  where+    loop !d !s+        | s == end    = pure (offsetAsSize d)+        | predicate v = primMbaWrite dst d v >> loop (d+Offset 1) (s+Offset 1)+        | otherwise   = loop d (s+Offset 1)+      where+        v = primIndex src s++all :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool+all predicate ba start end = loop start+  where+    loop !i+        | i == end                   = True+        | predicate (primIndex ba i) = loop (i+1)+        | otherwise                  = False+{-# INLINE all #-}++any :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool+any predicate ba start end = loop start+  where+    loop !i+        | i == end                   = False+        | predicate (primIndex ba i) = True+        | otherwise                  = loop (i+1)+{-# INLINE any #-}
+ Basement/UArray/Base.hs view
@@ -0,0 +1,550 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+module Basement.UArray.Base+    ( MUArray(..)+    , UArray(..)+    , MUArrayBackend(..)+    , UArrayBackend(..)+    -- * New mutable array creation+    , newUnpinned+    , newPinned+    , newNative+    , new+    -- * Pinning status+    , isPinned+    , isMutablePinned+    -- * Mutable array accessor+    , unsafeRead+    , unsafeWrite+    -- * Freezing routines+    , unsafeFreezeShrink+    , unsafeFreeze+    , unsafeThaw+    -- * Array accessor+    , unsafeIndex+    , unsafeIndexer+    , onBackend+    , onBackendPrim+    , onMutableBackend+    , unsafeDewrap+    , unsafeDewrap2+    -- * Basic lowlevel functions+    , empty+    , length+    , offset+    , ValidRange(..)+    , offsetsValidRange+    , equal+    , equalMemcmp+    , compare+    , copyAt+    , unsafeCopyAtRO+    , touch+    -- * temporary+    , pureST+    ) where++import           GHC.Prim+import           GHC.Types+import           GHC.Ptr+import           GHC.ST+import           Basement.Compat.Primitive+import           Basement.Monad+import           Basement.PrimType+import           Basement.Compat.Base+import qualified Basement.Runtime as Runtime+import           Data.Proxy+import qualified Basement.Compat.ExtList as List+import           Basement.Types.OffsetSize+import           Basement.FinalPtr+import           Basement.NormalForm+import           Basement.Block (MutableBlock(..), Block(..))+import qualified Basement.Block as BLK+import qualified Basement.Block.Base as BLK (touch)+import qualified Basement.Block.Mutable as MBLK+import           Basement.Numerical.Additive+import           Basement.Bindings.Memory+import           Foreign.C.Types+import           System.IO.Unsafe (unsafeDupablePerformIO)++-- | A Mutable array of types built on top of GHC primitive.+--+-- Element in this array can be modified in place.+data MUArray ty st = MUArray {-# UNPACK #-} !(Offset ty)+                             {-# UNPACK #-} !(CountOf ty)+                                            !(MUArrayBackend ty st)++data MUArrayBackend ty st = MUArrayMBA (MutableBlock ty st) | MUArrayAddr (FinalPtr ty)+++-- | An array of type built on top of GHC primitive.+--+-- The elements need to have fixed sized and the representation is a+-- packed contiguous array in memory that can easily be passed+-- to foreign interface+data UArray ty = UArray {-# UNPACK #-} !(Offset ty)+                        {-# UNPACK #-} !(CountOf ty)+                                       !(UArrayBackend ty)+    deriving (Typeable)++data UArrayBackend ty = UArrayBA !(Block ty) | UArrayAddr !(FinalPtr ty)+    deriving (Typeable)++instance Data ty => Data (UArray ty) where+    dataTypeOf _ = arrayType+    toConstr _   = error "toConstr"+    gunfold _ _  = error "gunfold"++arrayType :: DataType+arrayType = mkNoRepType "Foundation.UArray"++instance NormalForm (UArray ty) where+    toNormalForm (UArray _ _ !_) = ()+instance (PrimType ty, Show ty) => Show (UArray ty) where+    show v = show (toList v)+instance (PrimType ty, Eq ty) => Eq (UArray ty) where+    (==) = equal+instance (PrimType ty, Ord ty) => Ord (UArray ty) where+    {-# SPECIALIZE instance Ord (UArray Word8) #-}+    compare = vCompare++instance PrimType ty => Monoid (UArray ty) where+    mempty  = empty+    mappend = append+    mconcat = concat++instance PrimType ty => IsList (UArray ty) where+    type Item (UArray ty) = ty+    fromList = vFromList+    toList = vToList++length :: UArray ty -> CountOf ty+length (UArray _ len _) = len+{-# INLINE[1] length #-}++offset :: UArray ty -> Offset ty+offset (UArray ofs _ _) = ofs+{-# INLINE[1] offset #-}++data ValidRange ty = ValidRange {-# UNPACK #-} !(Offset ty) {-# UNPACK #-} !(Offset ty)++offsetsValidRange :: UArray ty -> ValidRange ty+offsetsValidRange (UArray ofs len _) = ValidRange ofs (ofs `offsetPlusE` len)++-- | Return if the array is pinned in memory+--+-- note that Foreign array are considered pinned+isPinned :: UArray ty -> PinnedStatus+isPinned (UArray _ _ (UArrayAddr {})) = Pinned+isPinned (UArray _ _ (UArrayBA blk))  = BLK.isPinned blk++-- | Return if a mutable array is pinned in memory+isMutablePinned :: MUArray ty st -> PinnedStatus+isMutablePinned (MUArray _ _ (MUArrayAddr {})) = Pinned+isMutablePinned (MUArray _ _ (MUArrayMBA mb))  = BLK.isMutablePinned mb++-- | Create a new pinned mutable array of size @n.+--+-- all the cells are uninitialized and could contains invalid values.+--+-- All mutable arrays are allocated on a 64 bits aligned addresses+newPinned :: forall prim ty . (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MUArray ty (PrimState prim))+newPinned n = MUArray 0 n . MUArrayMBA <$> MBLK.newPinned n++newUnpinned :: forall prim ty . (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MUArray ty (PrimState prim))+newUnpinned n = MUArray 0 n . MUArrayMBA <$> MBLK.new n++newNative :: (PrimMonad prim, PrimType ty)+          => CountOf ty+          -> (MutableByteArray# (PrimState prim) -> prim a) -- ^ move to a MutableBlock+          -> prim (a, MUArray ty (PrimState prim))+newNative n f = do+    mb@(MutableBlock mba) <- MBLK.new n+    a <- f mba+    pure (a, MUArray 0 n (MUArrayMBA mb))++-- | Create a new mutable array of size @n.+--+-- When memory for a new array is allocated, we decide if that memory region+-- should be pinned (will not be copied around by GC) or unpinned (can be+-- moved around by GC) depending on its size.+--+-- You can change the threshold value used by setting the environment variable+-- @HS_FOUNDATION_UARRAY_UNPINNED_MAX@.+new :: (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MUArray ty (PrimState prim))+new sz+    | sizeRecast sz <= maxSizeUnpinned = newUnpinned sz+    | otherwise                        = newPinned sz+  where+    -- Safe to use here: If the value changes during runtime, this will only+    -- have an impact on newly created arrays.+    maxSizeUnpinned = Runtime.unsafeUArrayUnpinnedMaxSize+{-# INLINE new #-}++-- | read from a cell in a mutable array without bounds checking.+--+-- Reading from invalid memory can return unpredictable and invalid values.+-- use 'read' if unsure.+unsafeRead :: (PrimMonad prim, PrimType ty) => MUArray ty (PrimState prim) -> Offset ty -> prim ty+unsafeRead (MUArray start _ (MUArrayMBA (MutableBlock mba))) i = primMbaRead mba (start + i)+unsafeRead (MUArray start _ (MUArrayAddr fptr)) i = withFinalPtr fptr $ \(Ptr addr) -> primAddrRead addr (start + i)+{-# INLINE unsafeRead #-}+++-- | write to a cell in a mutable array without bounds checking.+--+-- Writing with invalid bounds will corrupt memory and your program will+-- become unreliable. use 'write' if unsure.+unsafeWrite :: (PrimMonad prim, PrimType ty) => MUArray ty (PrimState prim) -> Offset ty -> ty -> prim ()+unsafeWrite (MUArray start _ (MUArrayMBA mb)) i v = MBLK.unsafeWrite mb (start+i) v+unsafeWrite (MUArray start _ (MUArrayAddr fptr)) i v = withFinalPtr fptr $ \(Ptr addr) -> primAddrWrite addr (start+i) v+{-# INLINE unsafeWrite #-}++-- | Return the element at a specific index from an array without bounds checking.+--+-- Reading from invalid memory can return unpredictable and invalid values.+-- use 'index' if unsure.+unsafeIndex :: forall ty . PrimType ty => UArray ty -> Offset ty -> ty+unsafeIndex (UArray start _ (UArrayBA ba)) n = BLK.unsafeIndex ba (start + n)+unsafeIndex (UArray start _ (UArrayAddr fptr)) n = withUnsafeFinalPtr fptr (\(Ptr addr) -> return (primAddrIndex addr (start+n)) :: IO ty)+{-# INLINE unsafeIndex #-}++unsafeIndexer :: (PrimMonad prim, PrimType ty) => UArray ty -> ((Offset ty -> ty) -> prim a) -> prim a+unsafeIndexer (UArray start _ (UArrayBA ba)) f = f (\n -> BLK.unsafeIndex ba (start + n))+unsafeIndexer (UArray start _ (UArrayAddr fptr)) f = withFinalPtr fptr $ \(Ptr addr) -> f (\n -> primAddrIndex addr (start + n))+{-# INLINE unsafeIndexer #-}++-- | Freeze a mutable array into an array.+--+-- the MUArray must not be changed after freezing.+unsafeFreeze :: PrimMonad prim => MUArray ty (PrimState prim) -> prim (UArray ty)+unsafeFreeze (MUArray start len (MUArrayMBA mba)) =+    UArray start len . UArrayBA <$> MBLK.unsafeFreeze mba+unsafeFreeze (MUArray start len (MUArrayAddr fptr)) =+    pure $ UArray start len (UArrayAddr fptr)+{-# INLINE unsafeFreeze #-}++unsafeFreezeShrink :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> CountOf ty -> prim (UArray ty)+unsafeFreezeShrink (MUArray start _ backend) n = unsafeFreeze (MUArray start n backend)+{-# INLINE unsafeFreezeShrink #-}++-- | Thaw an immutable array.+--+-- The UArray must not be used after thawing.+unsafeThaw :: (PrimType ty, PrimMonad prim) => UArray ty -> prim (MUArray ty (PrimState prim))+unsafeThaw (UArray start len (UArrayBA blk)) = MUArray start len . MUArrayMBA <$> BLK.unsafeThaw blk+unsafeThaw (UArray start len (UArrayAddr fptr)) = pure $ MUArray start len (MUArrayAddr fptr)+{-# INLINE unsafeThaw #-}++onBackend :: (ByteArray# -> a)+          -> (FinalPtr ty -> Ptr ty -> ST s a)+          -> UArray ty+          -> a+onBackend onBa _      (UArray _ _ (UArrayBA (Block ba))) = onBa ba+onBackend _    onAddr (UArray _ _ (UArrayAddr fptr))     = withUnsafeFinalPtr fptr (onAddr fptr)+{-# INLINE onBackend #-}++onBackendPrim :: PrimMonad prim+              => (ByteArray# -> prim a)+              -> (FinalPtr ty -> prim a)+              -> UArray ty+              -> prim a+onBackendPrim onBa _      (UArray _ _ (UArrayBA (Block ba))) = onBa ba+onBackendPrim _    onAddr (UArray _ _ (UArrayAddr fptr))     = onAddr fptr+{-# INLINE onBackendPrim #-}++onMutableBackend :: PrimMonad prim+                 => (MutableByteArray# (PrimState prim) -> prim a)+                 -> (FinalPtr ty -> prim a)+                 -> MUArray ty (PrimState prim)+                 -> prim a+onMutableBackend onMba _      (MUArray _ _ (MUArrayMBA (MutableBlock mba)))   = onMba mba+onMutableBackend _     onAddr (MUArray _ _ (MUArrayAddr fptr)) = onAddr fptr+{-# INLINE onMutableBackend #-}+++unsafeDewrap :: (ByteArray# -> 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+{-# INLINE unsafeDewrap #-}++unsafeDewrap2 :: (ByteArray# -> ByteArray# -> a)+              -> (Ptr ty -> Ptr ty -> ST s a)+              -> (ByteArray# -> Ptr ty -> ST s a)+              -> (Ptr ty -> ByteArray# -> ST s a)+              -> UArray ty+              -> UArray ty+              -> a+unsafeDewrap2 f g h i (UArray _ _ back1) (UArray _ _ back2) =+    case (back1, back2) of+        (UArrayBA (Block ba1), UArrayBA (Block ba2)) -> f ba1 ba2+        (UArrayAddr fptr1, UArrayAddr fptr2)         -> withUnsafeFinalPtr fptr1 $ \ptr1 -> withFinalPtr fptr2 $ \ptr2 -> g ptr1 ptr2+        (UArrayBA (Block ba1), UArrayAddr fptr2)     -> withUnsafeFinalPtr fptr2 $ \ptr2 -> h ba1 ptr2+        (UArrayAddr fptr1, UArrayBA (Block ba2))     -> withUnsafeFinalPtr fptr1 $ \ptr1 -> i ptr1 ba2+{-# INLINE [2] unsafeDewrap2 #-}++pureST :: a -> ST s a+pureST = pure++-- | make an array from a list of elements.+vFromList :: PrimType ty => [ty] -> UArray ty+vFromList l = runST $ do+    ma <- new (CountOf len)+    iter azero l $ \i x -> unsafeWrite ma i x+    unsafeFreeze ma+  where len = List.length l+        iter _  []     _ = return ()+        iter !i (x:xs) z = z i x >> iter (i+1) xs z++-- | transform an array to a list.+vToList :: forall ty . PrimType ty => UArray ty -> [ty]+vToList a+    | len == 0  = []+    | otherwise = unsafeDewrap goBa goPtr a+  where+    !len = length a+    goBa ba start = loop start+      where+        !end = start `offsetPlusE` len+        loop !i | i == end  = []+                | otherwise = primBaIndex ba i : loop (i+1)+    goPtr (Ptr addr) start = pureST (loop start)+      where+        !end = start `offsetPlusE` len+        loop !i | i == end  = []+                | otherwise = primAddrIndex addr i : loop (i+1)++-- | Check if two vectors are identical+equal :: (PrimType ty, Eq ty) => UArray ty -> UArray ty -> Bool+equal a b+    | la /= lb  = False+    | otherwise = unsafeDewrap2 goBaBa goPtrPtr goBaPtr goPtrBa a b+  where+    !start1 = offset a+    !start2 = offset b+    !end = start1 `offsetPlusE` la+    !la = length a+    !lb = length b+    goBaBa ba1 ba2 = loop start1 start2+      where+        loop !i !o | i == end  = True+                   | otherwise = primBaIndex ba1 i == primBaIndex ba2 o && loop (i+o1) (o+o1)+    goPtrPtr (Ptr addr1) (Ptr addr2) = pureST (loop start1 start2)+      where+        loop !i !o | i == end  = True+                   | otherwise = primAddrIndex addr1 i == primAddrIndex addr2 o && loop (i+o1) (o+o1)+    goBaPtr ba1 (Ptr addr2) = pureST (loop start1 start2)+      where+        loop !i !o | i == end  = True+                   | otherwise = primBaIndex ba1 i == primAddrIndex addr2 o && loop (i+o1) (o+o1)+    goPtrBa (Ptr addr1) ba2 = pureST (loop start1 start2)+      where+        loop !i !o | i == end  = True+                   | otherwise = primAddrIndex addr1 i == primBaIndex ba2 o && loop (i+o1) (o+o1)++    o1 = Offset (I# 1#)+{-# RULES "UArray/Eq/Word8" [3] equal = equalBytes #-}+{-# INLINEABLE [2] equal #-}++equalBytes :: UArray Word8 -> UArray Word8 -> Bool+equalBytes a b+    | la /= lb  = False+    | otherwise = memcmp a b (sizeInBytes la) == 0+  where+    !la = length a+    !lb = length b++equalMemcmp :: PrimType ty => UArray ty -> UArray ty -> Bool+equalMemcmp a b+    | la /= lb  = False+    | otherwise = memcmp a b (sizeInBytes la) == 0+  where+    !la = length a+    !lb = length b++-- | Compare 2 vectors+vCompare :: (Ord ty, PrimType ty) => UArray ty -> UArray ty -> Ordering+vCompare a@(UArray start1 la _) b@(UArray start2 lb _) = unsafeDewrap2 goBaBa goPtrPtr goBaPtr goPtrBa a b+  where+    !end = start1 `offsetPlusE` min la lb+    o1 = Offset (I# 1#)+    goBaBa ba1 ba2 = loop start1 start2+      where+        loop !i !o | i == end   = la `compare` lb+                   | v1 == v2   = loop (i + o1) (o + o1)+                   | otherwise  = v1 `compare` v2+          where v1 = primBaIndex ba1 i+                v2 = primBaIndex ba2 o+    goPtrPtr (Ptr addr1) (Ptr addr2) = pureST (loop start1 start2)+      where+        loop !i !o | i == end   = la `compare` lb+                   | v1 == v2   = loop (i + o1) (o + o1)+                   | otherwise  = v1 `compare` v2+          where v1 = primAddrIndex addr1 i+                v2 = primAddrIndex addr2 o+    goBaPtr ba1 (Ptr addr2) = pureST (loop start1 start2)+      where+        loop !i !o | i == end   = la `compare` lb+                   | v1 == v2   = loop (i + o1) (o + o1)+                   | otherwise  = v1 `compare` v2+          where v1 = primBaIndex ba1 i+                v2 = primAddrIndex addr2 o+    goPtrBa (Ptr addr1) ba2 = pureST (loop start1 start2)+      where+        loop !i !o | i == end   = la `compare` lb+                   | v1 == v2   = loop (i + o1) (o + o1)+                   | otherwise  = v1 `compare` v2+          where v1 = primAddrIndex addr1 i+                v2 = primBaIndex ba2 o+-- {-# SPECIALIZE [3] vCompare :: UArray Word8 -> UArray Word8 -> Ordering = vCompareBytes #-}+{-# RULES "UArray/Ord/Word8" [3] vCompare = vCompareBytes #-}+{-# INLINEABLE [2] vCompare #-}++vCompareBytes :: UArray Word8 -> UArray Word8 -> Ordering+vCompareBytes = vCompareMemcmp++vCompareMemcmp :: (Ord ty, PrimType ty) => UArray ty -> UArray ty -> Ordering+vCompareMemcmp a b = cintToOrdering $ memcmp a b sz+  where+    la = length a+    lb = length b+    sz = sizeInBytes $ min la lb+    cintToOrdering :: CInt -> Ordering+    cintToOrdering 0 = la `compare` lb+    cintToOrdering r | r < 0     = LT+                     | otherwise = GT+{-# SPECIALIZE [3] vCompareMemcmp :: UArray Word8 -> UArray Word8 -> Ordering #-}++memcmp :: PrimType ty => UArray ty -> UArray ty -> CountOf Word8 -> CInt+memcmp a@(UArray (offsetInBytes -> o1) _ _) b@(UArray (offsetInBytes -> o2) _ _) sz = unsafeDewrap2+    (\s1 s2 -> unsafeDupablePerformIO $ sysHsMemcmpBaBa s1 o1 s2 o2 sz)+    (\s1 s2 -> unsafePrimToST $ sysHsMemcmpPtrPtr s1 o1 s2 o2 sz)+    (\s1 s2 -> unsafePrimToST $ sysHsMemcmpBaPtr s1 o1 s2 o2 sz)+    (\s1 s2 -> unsafePrimToST $ sysHsMemcmpPtrBa s1 o1 s2 o2 sz)+    a b+{-# SPECIALIZE [3] memcmp :: UArray Word8 -> UArray Word8 -> CountOf Word8 -> CInt #-}++-- | Copy a number of elements from an array to another array with offsets+copyAt :: forall prim ty . (PrimMonad prim, PrimType ty)+       => MUArray ty (PrimState prim) -- ^ destination array+       -> Offset ty                  -- ^ offset at destination+       -> MUArray ty (PrimState prim) -- ^ source array+       -> Offset ty                  -- ^ offset at source+       -> CountOf ty                    -- ^ number of elements to copy+       -> prim ()+copyAt (MUArray dstStart _ (MUArrayMBA (MutableBlock dstMba))) ed (MUArray srcStart _ (MUArrayMBA (MutableBlock srcBa))) es n =+    primitive $ \st -> (# copyMutableByteArray# srcBa os dstMba od nBytes st, () #)+  where+    !sz                 = primSizeInBytes (Proxy :: Proxy ty)+    !(Offset (I# os))   = offsetOfE sz (srcStart + es)+    !(Offset (I# od))   = offsetOfE sz (dstStart + ed)+    !(CountOf (I# nBytes)) = sizeOfE sz n+copyAt (MUArray dstStart _ (MUArrayMBA (MutableBlock dstMba))) ed (MUArray srcStart _ (MUArrayAddr srcFptr)) es n =+    withFinalPtr srcFptr $ \srcPtr ->+        let !(Ptr srcAddr) = srcPtr `plusPtr` os+         in primitive $ \s -> (# compatCopyAddrToByteArray# srcAddr dstMba od nBytes s, () #)+  where+    !sz                 = primSizeInBytes (Proxy :: Proxy ty)+    !(Offset os)        = offsetOfE sz (srcStart + es)+    !(Offset (I# od))   = offsetOfE sz (dstStart + ed)+    !(CountOf (I# nBytes)) = sizeOfE sz n+copyAt dst od src os n = loop od os+  where+    !endIndex = os `offsetPlusE` n+    loop !d !i+        | i == endIndex = return ()+        | otherwise     = unsafeRead src i >>= unsafeWrite dst d >> loop (d+1) (i+1)++-- TODO Optimise with copyByteArray#+-- | Copy @n@ sequential elements from the specified offset in a source array+--   to the specified position in a destination array.+--+--   This function does not check bounds. Accessing invalid memory can return+--   unpredictable and invalid values.+unsafeCopyAtRO :: forall prim ty . (PrimMonad prim, PrimType ty)+               => MUArray ty (PrimState prim) -- ^ destination array+               -> Offset ty                   -- ^ offset at destination+               -> UArray ty                   -- ^ source array+               -> Offset ty                   -- ^ offset at source+               -> CountOf ty                     -- ^ number of elements to copy+               -> prim ()+unsafeCopyAtRO (MUArray dstStart _ (MUArrayMBA (MutableBlock dstMba))) ed (UArray srcStart _ (UArrayBA (Block srcBa))) es n =+    primitive $ \st -> (# copyByteArray# srcBa os dstMba od nBytes st, () #)+  where+    sz = primSizeInBytes (Proxy :: Proxy ty)+    !(Offset (I# os))   = offsetOfE sz (srcStart+es)+    !(Offset (I# od))   = offsetOfE sz (dstStart+ed)+    !(CountOf (I# nBytes)) = sizeOfE sz n+unsafeCopyAtRO (MUArray dstStart _ (MUArrayMBA (MutableBlock dstMba))) ed (UArray srcStart _ (UArrayAddr srcFptr)) es n =+    withFinalPtr srcFptr $ \srcPtr ->+        let !(Ptr srcAddr) = srcPtr `plusPtr` os+         in primitive $ \s -> (# compatCopyAddrToByteArray# srcAddr dstMba od nBytes s, () #)+  where+    sz  = primSizeInBytes (Proxy :: Proxy ty)+    !(Offset os)        = offsetOfE sz (srcStart+es)+    !(Offset (I# od))   = offsetOfE sz (dstStart+ed)+    !(CountOf (I# nBytes)) = sizeOfE sz n+unsafeCopyAtRO dst od src os n = loop od os+  where+    !endIndex = os `offsetPlusE` n+    loop d i+        | i == endIndex = return ()+        | otherwise     = unsafeWrite dst d (unsafeIndex src i) >> loop (d+1) (i+1)++empty_ :: Block ()+empty_ = runST $ primitive $ \s1 ->+    case newByteArray# 0# s1           of { (# s2, mba #) ->+    case unsafeFreezeByteArray# mba s2 of { (# s3, ba  #) ->+        (# s3, Block ba #) }}++empty :: UArray ty+empty = UArray 0 0 (UArrayBA $ Block ba) where !(Block ba) = empty_++-- | Append 2 arrays together by creating a new bigger array+append :: PrimType ty => UArray ty -> UArray ty -> UArray ty+append a b+    | la == azero = b+    | lb == azero = a+    | otherwise = runST $ do+        r  <- new (la+lb)+        ma <- unsafeThaw a+        mb <- unsafeThaw b+        copyAt r (Offset 0) ma (Offset 0) la+        copyAt r (sizeAsOffset la) mb (Offset 0) lb+        unsafeFreeze r+  where+    !la = length a+    !lb = length b++concat :: PrimType ty => [UArray ty] -> UArray ty+concat [] = empty+concat l  =+    case filterAndSum (CountOf 0) [] l of+        (_,[])            -> empty+        (_,[x])           -> x+        (totalLen,chunks) -> runST $ do+            r <- new totalLen+            doCopy r (Offset 0) chunks+            unsafeFreeze r+  where+    -- TODO would go faster not to reverse but pack from the end instead+    filterAndSum !totalLen acc []     = (totalLen, List.reverse acc)+    filterAndSum !totalLen acc (x:xs)+        | len == CountOf 0 = filterAndSum totalLen acc xs+        | otherwise      = filterAndSum (len+totalLen) (x:acc) xs+      where len = length x++    doCopy _ _ []     = return ()+    doCopy r i (x:xs) = do+        unsafeCopyAtRO r i x (Offset 0) lx+        doCopy r (i `offsetPlusE` lx) xs+      where lx = length x++touch :: PrimMonad prim => UArray ty -> prim ()+touch (UArray _ _ (UArrayBA blk))    = BLK.touch blk+touch (UArray _ _ (UArrayAddr fptr)) = touchFinalPtr fptr
+ Basement/UArray/Mutable.hs view
@@ -0,0 +1,196 @@+-- |+-- Module      : Basement.UArray.Mutable -- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : portable+--+-- A simple array abstraction that allow to use typed+-- array of bytes where the array is pinned in memory+-- to allow easy use with Foreign interfaces, ByteString+-- and always aligned to 64 bytes.+--+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Basement.UArray.Mutable+    ( MUArray(..)+    -- * Property queries+    , sizeInMutableBytesOfContent+    , mutableLength+    , mutableOffset+    , mutableSame+    , onMutableBackend+    -- * Allocation & Copy+    , new+    , newPinned+    , newNative+    , mutableForeignMem+    , copyAt+    , copyFromPtr+    , copyToPtr+    , sub+    -- , copyAddr+    -- * Reading and Writing cells+    , unsafeWrite+    , unsafeRead+    , write+    , read+    , withMutablePtr+    ) where++import           GHC.Prim+import           GHC.Types+import           GHC.Ptr+import           Basement.Compat.Base+import           Basement.Compat.Primitive+import           Data.Proxy+import           Basement.Types.OffsetSize+import           Basement.Monad+import           Basement.PrimType+import           Basement.FinalPtr+import           Basement.Exception+import qualified Basement.Block.Mutable as MBLK+import           Basement.Block         (MutableBlock(..))+import           Basement.UArray.Base hiding (empty)+import           Basement.Numerical.Subtractive+import           Foreign.Marshal.Utils (copyBytes)++sizeInMutableBytesOfContent :: forall ty s . PrimType ty => MUArray ty s -> CountOf Word8+sizeInMutableBytesOfContent _ = primSizeInBytes (Proxy :: Proxy ty)+{-# INLINE sizeInMutableBytesOfContent #-}++-- | read a cell in a mutable array.+--+-- If the index is out of bounds, an error is raised.+read :: (PrimMonad prim, PrimType ty) => MUArray ty (PrimState prim) -> Offset ty -> prim ty+read array n+    | isOutOfBound n len = primOutOfBound OOB_Read n len+    | otherwise          = unsafeRead array n+  where len = mutableLength array+{-# INLINE read #-}++-- | Write to a cell in a mutable array.+--+-- If the index is out of bounds, an error is raised.+write :: (PrimMonad prim, PrimType ty) => MUArray ty (PrimState prim) -> Offset ty -> ty -> prim ()+write array n val+    | isOutOfBound n len = primOutOfBound OOB_Write n len+    | otherwise          = unsafeWrite array n val+  where+    len = mutableLength array+{-# INLINE write #-}++empty :: (PrimType ty, PrimMonad prim) => prim (MUArray ty (PrimState prim))+empty = MUArray 0 0 . MUArrayMBA <$> MBLK.mutableEmpty++mutableSame :: MUArray ty st -> MUArray ty st -> Bool+mutableSame (MUArray sa ea (MUArrayMBA (MutableBlock ma))) (MUArray sb eb (MUArrayMBA (MutableBlock mb))) = (sa == sb) && (ea == eb) && bool# (sameMutableByteArray# ma mb)+mutableSame (MUArray s1 e1 (MUArrayAddr f1)) (MUArray s2 e2 (MUArrayAddr f2)) = (s1 == s2) && (e1 == e2) && finalPtrSameMemory f1 f2+mutableSame _ _ = False++mutableForeignMem :: (PrimMonad prim, PrimType ty)+                  => FinalPtr ty -- ^ the start pointer with a finalizer+                  -> Int         -- ^ the number of elements (in elements, not bytes)+                  -> prim (MUArray ty (PrimState prim))+mutableForeignMem fptr nb = pure $ MUArray (Offset 0) (CountOf nb) (MUArrayAddr fptr)++sub :: (PrimMonad prim, PrimType ty)+    => MUArray ty (PrimState prim)+    -> Int -- The number of elements to drop ahead+    -> Int -- Then the number of element to retain+    -> prim (MUArray ty (PrimState prim))+sub (MUArray start sz back) dropElems' takeElems+    | takeElems <= 0 = empty+    | Just keepElems <- sz - dropElems, keepElems > 0 +                     = pure $ MUArray (start `offsetPlusE` dropElems) (min (CountOf takeElems) keepElems) back+    | otherwise      = empty+  where+    dropElems = max 0 (CountOf dropElems')+++-- | return the numbers of elements in a mutable array+mutableLength :: PrimType ty => MUArray ty st -> CountOf ty+mutableLength (MUArray _ end _)   = end++withMutablePtrHint :: forall ty prim a . (PrimMonad prim, PrimType ty)+                   => Bool+                   -> Bool+                   -> MUArray ty (PrimState prim)+                   -> (Ptr ty -> prim a)+                   -> prim a+withMutablePtrHint _ _ (MUArray start _ (MUArrayAddr fptr))  f =+    withFinalPtr fptr (\ptr -> f (ptr `plusPtr` os))+  where+    sz           = primSizeInBytes (Proxy :: Proxy ty)+    !(Offset os) = offsetOfE sz start+withMutablePtrHint skipCopy skipCopyBack vec@(MUArray start vecSz (MUArrayMBA (MutableBlock a))) f+    | isMutablePinned vec == Pinned = mutableByteArrayContent a >>= \ptr -> f (ptr `plusPtr` os)+    | otherwise                     = do+        trampoline <- newPinned vecSz+        if not skipCopy+            then copyAt trampoline 0 vec 0 vecSz+            else pure ()+        r <- withMutablePtr trampoline f+        if not skipCopyBack+            then copyAt vec 0 trampoline 0 vecSz+            else pure ()+        pure r+  where+    !(Offset os) = offsetOfE sz start+    sz           = primSizeInBytes (Proxy :: Proxy ty)++    mutableByteArrayContent :: PrimMonad prim => MutableByteArray# (PrimState prim) -> prim (Ptr ty)+    mutableByteArrayContent mba = primitive $ \s1 ->+        case unsafeFreezeByteArray# mba s1 of+            (# s2, ba #) -> (# s2, Ptr (byteArrayContents# ba) #)++-- | Create a pointer on the beginning of the mutable array+-- and call a function 'f'.+--+-- The mutable buffer can be mutated by the 'f' function+-- and the change will be reflected in the mutable array+--+-- If the mutable array is unpinned, a trampoline buffer+-- is created and the data is only copied when 'f' return.+withMutablePtr :: (PrimMonad prim, PrimType ty)+               => MUArray ty (PrimState prim)+               -> (Ptr ty -> prim a)+               -> prim a+withMutablePtr = withMutablePtrHint False False++-- | Copy from a pointer, @count@ elements, into the mutable array+copyFromPtr :: forall prim ty . (PrimMonad prim, PrimType ty)+            => Ptr ty -> CountOf ty -> MUArray ty (PrimState prim) -> prim ()+copyFromPtr src@(Ptr src#) count marr+    | count > arrSz = primOutOfBound OOB_MemCopy (sizeAsOffset count) arrSz+    | otherwise     = onMutableBackend copyNative copyPtr marr+  where+    arrSz = mutableLength marr+    ofs = mutableOffset marr++    sz = primSizeInBytes (Proxy :: Proxy ty)+    !(CountOf bytes@(I# bytes#)) = sizeOfE sz count+    !(Offset od@(I# od#)) = offsetOfE sz ofs++    copyNative mba = primitive $ \st -> (# copyAddrToByteArray# src# mba od# bytes# st, () #)+    copyPtr fptr = withFinalPtr fptr $ \dst ->+        unsafePrimFromIO $ copyBytes (dst `plusPtr` od) src bytes++-- | Copy all the block content to the memory starting at the destination address+copyToPtr :: forall ty prim . (PrimType ty, PrimMonad prim)+          => MUArray ty (PrimState prim) -- ^ the source mutable array to copy+          -> Ptr ty                      -- ^ The destination address where the copy is going to start+          -> prim ()+copyToPtr marr dst@(Ptr dst#) = onMutableBackend copyNative copyPtr marr+  where+    copyNative mba = primitive $ \s1 ->+        case unsafeFreezeByteArray# mba s1 of+            (# s2, ba #) -> (# compatCopyByteArrayToAddr# ba os# dst# szBytes# s2, () #)+    copyPtr fptr = unsafePrimFromIO $ withFinalPtr fptr $ \ptr ->+        copyBytes dst (ptr `plusPtr` os) szBytes++    !(Offset os@(I# os#)) = offsetInBytes $ mutableOffset marr+    !(CountOf szBytes@(I# szBytes#)) = sizeInBytes $ mutableLength marr++mutableOffset :: MUArray ty st -> Offset ty+mutableOffset (MUArray ofs _ _) = ofs
+ Basement/UTF8/Addr.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE CPP                        #-}+module Basement.UTF8.Addr+    ( Immutable+    , Mutable+    -- * functions+    , nextAscii+    , nextAsciiDigit+    , expectAscii+    , next+    , prev+    , prevSkip+    , write+    , toList+    , all+    , any+    , foldr+    , length+    -- temporary+    , primIndex+    , primIndex64+    , primRead+    , primWrite+    ) where++import           GHC.Int+import           GHC.Types+import           GHC.Word+import           GHC.Prim+import           Data.Bits+import           Basement.Compat.Base hiding (toList)+import           Basement.Compat.Primitive+import           Data.Proxy+import           Basement.Numerical.Additive+import           Basement.Numerical.Subtractive+import           Basement.Types.OffsetSize+import           Basement.Monad+import           Basement.PrimType+import           Basement.UTF8.Helper+import           Basement.UTF8.Table+import           Basement.UTF8.Types++type Immutable = Addr#+type Mutable (prim :: * -> *) = Addr#++primWrite :: PrimMonad prim => Mutable prim -> Offset Word8 -> Word8 -> prim ()+primWrite = primAddrWrite++primRead :: PrimMonad prim => Mutable prim -> Offset Word8 -> prim Word8+primRead = primAddrRead++primIndex :: Immutable -> Offset Word8 -> Word8+primIndex = primAddrIndex++primIndex64 :: Immutable -> Offset Word64 -> Word64+primIndex64 = primAddrIndex++nextAscii :: Immutable -> Offset Word8 -> StepASCII+nextAscii ba n = StepASCII w+  where+    !w = primIndex ba n+{-# INLINE nextAscii #-}++-- | nextAsciiBa specialized to get a digit between 0 and 9 (included)+nextAsciiDigit :: Immutable -> Offset Word8 -> StepDigit+nextAsciiDigit ba n = StepDigit (primIndex ba n - 0x30)+{-# INLINE nextAsciiDigit #-}++expectAscii :: Immutable -> Offset Word8 -> Word8 -> Bool+expectAscii ba n v = primIndex ba n == v+{-# INLINE expectAscii #-}++next :: Immutable -> Offset8 -> Step+next ba n =+    case getNbBytes h of+        0 -> Step (toChar1 h) (n + Offset 1)+        1 -> Step (toChar2 h (primIndex ba (n + Offset 1))) (n + Offset 2)+        2 -> Step (toChar3 h (primIndex ba (n + Offset 1))+                             (primIndex ba (n + Offset 2))) (n + Offset 3)+        3 -> Step (toChar4 h (primIndex ba (n + Offset 1))+                             (primIndex ba (n + Offset 2))+                             (primIndex ba (n + Offset 3))) (n + Offset 4)+        r -> error ("next: internal error: invalid input: offset=" <> show n <> " table=" <> show r <> " h=" <> show h)+  where+    !h = primIndex ba n+{-# INLINE next #-}++-- Given a non null offset, give the previous character and the offset of this character+-- will fail bad if apply at the beginning of string or an empty string.+prev :: Immutable -> Offset Word8 -> StepBack+prev ba offset =+    case primIndex ba prevOfs1 of+        (W8# v1) | isContinuation# v1 -> atLeast2 (maskContinuation# v1)+                 | otherwise          -> StepBack (toChar# v1) prevOfs1+  where+    sz1 = CountOf 1+    !prevOfs1 = offset `offsetMinusE` sz1+    prevOfs2 = prevOfs1 `offsetMinusE` sz1+    prevOfs3 = prevOfs2 `offsetMinusE` sz1+    prevOfs4 = prevOfs3 `offsetMinusE` sz1+    atLeast2 !v  =+        case primIndex ba prevOfs2 of+            (W8# v2) | isContinuation# v2 -> atLeast3 (or# (uncheckedShiftL# (maskContinuation# v2) 6#) v)+                     | otherwise          -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader2# v2) 6#) v)) prevOfs2+    atLeast3 !v =+        case primIndex ba prevOfs3 of+            (W8# v3) | isContinuation# v3 -> atLeast4 (or# (uncheckedShiftL# (maskContinuation# v3) 12#) v)+                     | otherwise          -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader3# v3) 12#) v)) prevOfs3+    atLeast4 !v =+        case primIndex ba prevOfs4 of+            (W8# v4) -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader4# v4) 18#) v)) prevOfs4++prevSkip :: Immutable -> Offset Word8 -> Offset Word8+prevSkip ba offset = loop (offset `offsetMinusE` sz1)+  where+    sz1 = CountOf 1+    loop o+        | isContinuation (primIndex ba o) = loop (o `offsetMinusE` sz1)+        | otherwise                       = o++write :: PrimMonad prim => Mutable prim -> Offset8 -> Char -> prim Offset8+write mba !i !c+    | bool# (ltWord# x 0x80##   ) = encode1+    | bool# (ltWord# x 0x800##  ) = encode2+    | bool# (ltWord# x 0x10000##) = encode3+    | otherwise                   = encode4+  where+    !(I# xi) = fromEnum c+    !x       = int2Word# xi++    encode1 = primWrite mba i (W8# x) >> pure (i + Offset 1)+    encode2 = do+        let x1  = or# (uncheckedShiftRL# x 6#) 0xc0##+            x2  = toContinuation x+        primWrite mba i     (W8# x1)+        primWrite mba (i+1) (W8# x2)+        pure (i + Offset 2)++    encode3 = do+        let x1  = or# (uncheckedShiftRL# x 12#) 0xe0##+            x2  = toContinuation (uncheckedShiftRL# x 6#)+            x3  = toContinuation x+        primWrite mba i            (W8# x1)+        primWrite mba (i+Offset 1) (W8# x2)+        primWrite mba (i+Offset 2) (W8# x3)+        pure (i + Offset 3)++    encode4 = do+        let x1  = or# (uncheckedShiftRL# x 18#) 0xf0##+            x2  = toContinuation (uncheckedShiftRL# x 12#)+            x3  = toContinuation (uncheckedShiftRL# x 6#)+            x4  = toContinuation x+        primWrite mba i            (W8# x1)+        primWrite mba (i+Offset 1) (W8# x2)+        primWrite mba (i+Offset 2) (W8# x3)+        primWrite mba (i+Offset 3) (W8# x4)+        pure (i + Offset 4)++    toContinuation :: Word# -> Word#+    toContinuation w = or# (and# w 0x3f##) 0x80##+{-# INLINE write #-}++toList :: Immutable -> Offset Word8 -> Offset Word8 -> [Char]+toList ba !start !end = loop start+  where+    loop !idx+        | idx == end = []+        | otherwise  = c : loop idx'+      where (Step c idx') = next ba idx++all :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool+all predicate ba start end = loop start+  where+    loop !idx+        | idx == end  = True+        | predicate c = loop idx'+        | otherwise   = False+      where (Step c idx') = next ba idx+{-# INLINE all #-}++any :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool+any predicate ba start end = loop start+  where+    loop !idx+        | idx == end  = False+        | predicate c = True+        | otherwise   = loop idx'+      where (Step c idx') = next ba idx+{-# INLINE any #-}++foldr :: Immutable -> Offset Word8 -> Offset Word8 -> (Char -> a -> a) -> a -> a+foldr dat start end f acc = loop start+  where+    loop !i+        | i == end  = acc+        | otherwise =+            let (Step c i') = next dat i+             in c `f` loop i'+{-# INLINE foldr #-}++length :: Immutable -> Offset Word8 -> Offset Word8 -> CountOf Char+length dat start end+    | start == end = 0+    | otherwise    = processStart 0 start+  where+    end64 :: Offset Word64+    end64 = offsetInElements end++    prx64 :: Proxy Word64+    prx64 = Proxy++    mask64_80 :: Word64+    mask64_80 = 0x8080808080808080++    processStart :: CountOf Char -> Offset Word8 -> CountOf Char+    processStart !c !i+        | i == end                = c+        | offsetIsAligned prx64 i = processAligned c (offsetInElements i)+        | otherwise               =+            let h    = primIndex dat i+                cont = (h .&. 0xc0) == 0x80+                c'   = if cont then c else c+1+             in processStart c' (i+1)+    processAligned :: CountOf Char -> Offset Word64 -> CountOf Char+    processAligned !c !i+        | i >= end64 = processEnd c (offsetInBytes i)+        | otherwise  =+            let !h   = primIndex64 dat i+                !h80 = h .&. mask64_80+             in if h80 == 0+                 then processAligned (c+8) (i+1)+                 else let !nbAscii = if h80 == mask64_80 then 0 else CountOf (8 - popCount h80)+                          !nbHigh  = CountOf $ popCount (h .&. (h80 `unsafeShiftR` 1))+                       in processAligned (c + nbAscii + nbHigh) (i+1)+    processEnd !c !i+        | i == end  = c+        | otherwise =+            let h    = primIndex dat i+                cont = (h .&. 0xc0) == 0x80+                c'   = if cont then c else c+1+             in processStart c' (i+1)+{-# INLINE length #-}
+ Basement/UTF8/BA.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE CPP                        #-}+module Basement.UTF8.BA+    ( Immutable+    , Mutable+    -- * functions+    , nextAscii+    , nextAsciiDigit+    , expectAscii+    , next+    , prev+    , prevSkip+    , write+    , toList+    , all+    , any+    , foldr+    , length+    -- temporary+    , primIndex+    , primIndex64+    , primRead+    , primWrite+    ) where++import           GHC.Int+import           GHC.Types+import           GHC.Word+import           GHC.Prim+import           Data.Bits+import           Basement.Compat.Base hiding (toList)+import           Basement.Compat.Primitive+import           Data.Proxy+import           Basement.Numerical.Additive+import           Basement.Numerical.Subtractive+import           Basement.Types.OffsetSize+import           Basement.Monad+import           Basement.PrimType+import           Basement.UTF8.Helper+import           Basement.UTF8.Table+import           Basement.UTF8.Types++type Immutable = ByteArray#+type Mutable prim = MutableByteArray# (PrimState prim)++primWrite :: PrimMonad prim => Mutable prim -> Offset Word8 -> Word8 -> prim ()+primWrite = primMbaWrite++primRead :: PrimMonad prim => Mutable prim -> Offset Word8 -> prim Word8+primRead = primMbaRead++primIndex :: Immutable -> Offset Word8 -> Word8+primIndex = primBaIndex++primIndex64 :: Immutable -> Offset Word64 -> Word64+primIndex64 = primBaIndex++nextAscii :: Immutable -> Offset Word8 -> StepASCII+nextAscii ba n = StepASCII w+  where+    !w = primIndex ba n+{-# INLINE nextAscii #-}++-- | nextAsciiBa specialized to get a digit between 0 and 9 (included)+nextAsciiDigit :: Immutable -> Offset Word8 -> StepDigit+nextAsciiDigit ba n = StepDigit (primIndex ba n - 0x30)+{-# INLINE nextAsciiDigit #-}++expectAscii :: Immutable -> Offset Word8 -> Word8 -> Bool+expectAscii ba n v = primIndex ba n == v+{-# INLINE expectAscii #-}++next :: Immutable -> Offset8 -> Step+next ba n =+    case getNbBytes h of+        0 -> Step (toChar1 h) (n + Offset 1)+        1 -> Step (toChar2 h (primIndex ba (n + Offset 1))) (n + Offset 2)+        2 -> Step (toChar3 h (primIndex ba (n + Offset 1))+                             (primIndex ba (n + Offset 2))) (n + Offset 3)+        3 -> Step (toChar4 h (primIndex ba (n + Offset 1))+                             (primIndex ba (n + Offset 2))+                             (primIndex ba (n + Offset 3))) (n + Offset 4)+        r -> error ("next: internal error: invalid input: offset=" <> show n <> " table=" <> show r <> " h=" <> show h)+  where+    !h = primIndex ba n+{-# INLINE next #-}++-- Given a non null offset, give the previous character and the offset of this character+-- will fail bad if apply at the beginning of string or an empty string.+prev :: Immutable -> Offset Word8 -> StepBack+prev ba offset =+    case primIndex ba prevOfs1 of+        (W8# v1) | isContinuation# v1 -> atLeast2 (maskContinuation# v1)+                 | otherwise          -> StepBack (toChar# v1) prevOfs1+  where+    sz1 = CountOf 1+    !prevOfs1 = offset `offsetMinusE` sz1+    prevOfs2 = prevOfs1 `offsetMinusE` sz1+    prevOfs3 = prevOfs2 `offsetMinusE` sz1+    prevOfs4 = prevOfs3 `offsetMinusE` sz1+    atLeast2 !v  =+        case primIndex ba prevOfs2 of+            (W8# v2) | isContinuation# v2 -> atLeast3 (or# (uncheckedShiftL# (maskContinuation# v2) 6#) v)+                     | otherwise          -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader2# v2) 6#) v)) prevOfs2+    atLeast3 !v =+        case primIndex ba prevOfs3 of+            (W8# v3) | isContinuation# v3 -> atLeast4 (or# (uncheckedShiftL# (maskContinuation# v3) 12#) v)+                     | otherwise          -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader3# v3) 12#) v)) prevOfs3+    atLeast4 !v =+        case primIndex ba prevOfs4 of+            (W8# v4) -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader4# v4) 18#) v)) prevOfs4++prevSkip :: Immutable -> Offset Word8 -> Offset Word8+prevSkip ba offset = loop (offset `offsetMinusE` sz1)+  where+    sz1 = CountOf 1+    loop o+        | isContinuation (primIndex ba o) = loop (o `offsetMinusE` sz1)+        | otherwise                       = o++write :: PrimMonad prim => Mutable prim -> Offset8 -> Char -> prim Offset8+write mba !i !c+    | bool# (ltWord# x 0x80##   ) = encode1+    | bool# (ltWord# x 0x800##  ) = encode2+    | bool# (ltWord# x 0x10000##) = encode3+    | otherwise                   = encode4+  where+    !(I# xi) = fromEnum c+    !x       = int2Word# xi++    encode1 = primWrite mba i (W8# x) >> pure (i + Offset 1)+    encode2 = do+        let x1  = or# (uncheckedShiftRL# x 6#) 0xc0##+            x2  = toContinuation x+        primWrite mba i     (W8# x1)+        primWrite mba (i+1) (W8# x2)+        pure (i + Offset 2)++    encode3 = do+        let x1  = or# (uncheckedShiftRL# x 12#) 0xe0##+            x2  = toContinuation (uncheckedShiftRL# x 6#)+            x3  = toContinuation x+        primWrite mba i            (W8# x1)+        primWrite mba (i+Offset 1) (W8# x2)+        primWrite mba (i+Offset 2) (W8# x3)+        pure (i + Offset 3)++    encode4 = do+        let x1  = or# (uncheckedShiftRL# x 18#) 0xf0##+            x2  = toContinuation (uncheckedShiftRL# x 12#)+            x3  = toContinuation (uncheckedShiftRL# x 6#)+            x4  = toContinuation x+        primWrite mba i            (W8# x1)+        primWrite mba (i+Offset 1) (W8# x2)+        primWrite mba (i+Offset 2) (W8# x3)+        primWrite mba (i+Offset 3) (W8# x4)+        pure (i + Offset 4)++    toContinuation :: Word# -> Word#+    toContinuation w = or# (and# w 0x3f##) 0x80##+{-# INLINE write #-}++toList :: Immutable -> Offset Word8 -> Offset Word8 -> [Char]+toList ba !start !end = loop start+  where+    loop !idx+        | idx == end = []+        | otherwise  = c : loop idx'+      where (Step c idx') = next ba idx++all :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool+all predicate ba start end = loop start+  where+    loop !idx+        | idx == end  = True+        | predicate c = loop idx'+        | otherwise   = False+      where (Step c idx') = next ba idx+{-# INLINE all #-}++any :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool+any predicate ba start end = loop start+  where+    loop !idx+        | idx == end  = False+        | predicate c = True+        | otherwise   = loop idx'+      where (Step c idx') = next ba idx+{-# INLINE any #-}++foldr :: Immutable -> Offset Word8 -> Offset Word8 -> (Char -> a -> a) -> a -> a+foldr dat start end f acc = loop start+  where+    loop !i+        | i == end  = acc+        | otherwise =+            let (Step c i') = next dat i+             in c `f` loop i'+{-# INLINE foldr #-}++length :: Immutable -> Offset Word8 -> Offset Word8 -> CountOf Char+length dat start end+    | start == end = 0+    | otherwise    = processStart 0 start+  where+    end64 :: Offset Word64+    end64 = offsetInElements end++    prx64 :: Proxy Word64+    prx64 = Proxy++    mask64_80 :: Word64+    mask64_80 = 0x8080808080808080++    processStart :: CountOf Char -> Offset Word8 -> CountOf Char+    processStart !c !i+        | i == end                = c+        | offsetIsAligned prx64 i = processAligned c (offsetInElements i)+        | otherwise               =+            let h    = primIndex dat i+                cont = (h .&. 0xc0) == 0x80+                c'   = if cont then c else c+1+             in processStart c' (i+1)+    processAligned :: CountOf Char -> Offset Word64 -> CountOf Char+    processAligned !c !i+        | i >= end64 = processEnd c (offsetInBytes i)+        | otherwise  =+            let !h   = primIndex64 dat i+                !h80 = h .&. mask64_80+             in if h80 == 0+                 then processAligned (c+8) (i+1)+                 else let !nbAscii = if h80 == mask64_80 then 0 else CountOf (8 - popCount h80)+                          !nbHigh  = CountOf $ popCount (h .&. (h80 `unsafeShiftR` 1))+                       in processAligned (c + nbAscii + nbHigh) (i+1)+    processEnd !c !i+        | i == end  = c+        | otherwise =+            let h    = primIndex dat i+                cont = (h .&. 0xc0) == 0x80+                c'   = if cont then c else c+1+             in processStart c' (i+1)+{-# INLINE length #-}
+ Basement/UTF8/Base.hs view
@@ -0,0 +1,202 @@+-- |+-- Module      : Basement.String+-- License     : BSD-style+-- Maintainer  : Foundation+--+-- A String type backed by a UTF8 encoded byte array and all the necessary+-- functions to manipulate the string.+--+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE CPP                        #-}+module Basement.UTF8.Base+    where++import           GHC.ST (ST, runST)+import           GHC.Types+import           GHC.Word+import           GHC.Prim+import           Basement.Compat.Base+import           Basement.Numerical.Additive+import           Basement.Compat.Bifunctor+import           Basement.NormalForm+import           Basement.Types.OffsetSize+import           Basement.PrimType+import           Basement.Monad+import           Basement.FinalPtr+import           Basement.UTF8.Helper+import           Basement.UTF8.Types+import qualified Basement.UTF8.BA       as PrimBA+import qualified Basement.UTF8.Addr     as PrimAddr+import           Basement.UArray           (UArray)+import qualified Basement.UArray           as Vec+import qualified Basement.UArray           as C+import qualified Basement.UArray.Mutable   as MVec+import           Basement.UArray.Base   as Vec (offset, pureST, onBackend)+import           GHC.CString                        (unpackCString#, unpackCStringUtf8#)++import           Data.Data+import           Basement.Compat.ExtList as List++-- | Opaque packed array of characters in the UTF8 encoding+newtype String = String (UArray Word8)+    deriving (Typeable, Monoid, Eq, Ord)++-- | Mutable String Buffer.+--+-- Use as an *append* buffer, as UTF8 variable encoding+-- doesn't really allow to change previously written+-- character without potentially shifting bytes.+newtype MutableString st = MutableString (MVec.MUArray Word8 st)+    deriving (Typeable)++instance Show String where+    show = show . sToList+instance IsString String where+    fromString = sFromList+instance IsList String where+    type Item String = Char+    fromList = sFromList+    toList = sToList++instance Data String where+    toConstr s   = mkConstr stringType (show s) [] Prefix+    dataTypeOf _ = stringType+    gunfold _ _  = error "gunfold"++instance NormalForm String where+    toNormalForm (String ba) = toNormalForm ba++stringType :: DataType+stringType = mkNoRepType "Foundation.String"++-- | size in bytes.+--+-- this size is available in o(1)+size :: String -> CountOf Word8+size (String ba) = Vec.length ba++-- | Convert a String to a list of characters+--+-- The list is lazily created as evaluation needed+sToList :: String -> [Char]+sToList s = loop 0+  where+    !nbBytes = size s+    loop idx+        | idx .==# nbBytes = []+        | otherwise        =+            let !(Step c idx') = next s idx in c : loop idx'++{-# RULES "String sFromList" forall s .  sFromList (unpackCString# s) = fromModified s #-}+{-# RULES "String sFromList" forall s .  sFromList (unpackCStringUtf8# s) = fromModified s #-}++-- | assuming the given Addr# is a valid modified UTF-8 sequence of bytes+--+-- We only modify the given Unicode Null-character (0xC080) into a null bytes+--+-- FIXME: need to evaluate the kind of modified UTF8 GHC is actually expecting+-- it is plausible they only handle the Null Bytes, which this function actually+-- does.+fromModified :: Addr# -> String+fromModified addr = countAndCopy 0 0+  where+    countAndCopy :: CountOf Word8 -> Offset Word8 -> String+    countAndCopy count ofs =+        case primAddrIndex addr ofs of+            0x00 -> runST $ do+                        ((), mb) <- MVec.newNative count (copy count)+                        String <$> Vec.unsafeFreeze mb+            0xC0 -> case primAddrIndex addr (ofs+1) of+                        0x80 -> countAndCopy (count+1) (ofs+2)+                        _    -> countAndCopy (count+2) (ofs+2)+            _    -> countAndCopy (count+1) (ofs+1)++    copy :: CountOf Word8 -> MutableByteArray# st -> ST st ()+    copy count mba = loop 0 0+      where loop o i+                | o .==# count = pure ()+                | otherwise    =+                    case primAddrIndex addr i of+                        0xC0 -> case primAddrIndex addr (i+1) of+                                    0x80 -> primMbaUWrite mba o 0x00 >> loop (o+1) (i+2)+                                    b2   -> primMbaUWrite mba o 0xC0 >> primMbaUWrite mba (o+1) b2 >> loop (o+2) (i+2)+                        b1   -> primMbaUWrite mba o b1 >> loop (o+1) (i+1)+++-- | Create a new String from a list of characters+--+-- The list is strictly and fully evaluated before+-- creating the new String, as the size need to be+-- computed before filling.+sFromList :: [Char] -> String+sFromList l = runST (new bytes >>= startCopy)+  where+    -- count how many bytes+    !bytes = List.sum $ fmap (charToBytes . fromEnum) l++    startCopy :: MutableString (PrimState (ST st)) -> ST st String+    startCopy ms = loop 0 l+      where+        loop _   []     = freeze ms+        loop idx (c:xs) = write ms idx c >>= \idx' -> loop idx' xs+{-# INLINE [0] sFromList #-}++next :: String -> Offset8 -> Step+next (String array) !n = Vec.onBackend nextNative nextAddr array+  where+    !start = Vec.offset array+    reoffset (Step a ofs) = Step a (ofs `offsetSub` start)+    nextNative ba        = reoffset (PrimBA.next ba (start + n))+    nextAddr _ (Ptr ptr) = pureST $ reoffset (PrimAddr.next ptr (start + n))++prev :: String -> Offset8 -> StepBack+prev (String array) !n = Vec.onBackend prevNative prevAddr array+  where+    !start = Vec.offset array+    reoffset (StepBack a ofs) = StepBack a (ofs `offsetSub` start)+    prevNative ba        = reoffset (PrimBA.prev ba (start + n))+    prevAddr _ (Ptr ptr) = pureST $ reoffset (PrimAddr.prev ptr (start + n))++-- A variant of 'next' when you want the next character+-- to be ASCII only.+nextAscii :: String -> Offset8 -> StepASCII+nextAscii (String ba) n = StepASCII w+  where+    !w = Vec.unsafeIndex ba n++expectAscii :: String -> Offset8 -> Word8 -> Bool+expectAscii (String ba) n v = Vec.unsafeIndex ba n == v+{-# INLINE expectAscii #-}++write :: PrimMonad prim => MutableString (PrimState prim) -> Offset8 -> Char -> prim Offset8+write (MutableString marray) ofs c =+    MVec.onMutableBackend (\mba -> PrimBA.write mba (start + ofs) c)+                          (\fptr -> withFinalPtr fptr $ \(Ptr ptr) -> PrimAddr.write ptr (start + ofs) c)+                          marray+  where start = MVec.mutableOffset marray++-- | Allocate a MutableString of a specific size in bytes.+new :: PrimMonad prim+    => CountOf Word8 -- ^ in number of bytes, not of elements.+    -> prim (MutableString (PrimState prim))+new n = MutableString `fmap` MVec.new n++newNative :: PrimMonad prim+          => CountOf Word8 -- ^ in number of bytes, not of elements.+          -> (MutableByteArray# (PrimState prim) -> prim a)+          -> prim (a, MutableString (PrimState prim))+newNative n f = second MutableString `fmap` MVec.newNative n f++freeze :: PrimMonad prim => MutableString (PrimState prim) -> prim String+freeze (MutableString mba) = String `fmap` C.unsafeFreeze mba+{-# INLINE freeze #-}++freezeShrink :: PrimMonad prim+             => CountOf Word8+             -> MutableString (PrimState prim)+             -> prim String+freezeShrink n (MutableString mba) = String `fmap` C.unsafeFreezeShrink mba n
+ Basement/UTF8/Helper.hs view
@@ -0,0 +1,147 @@+-- |+-- Module      : Basement.UTF8.Helper+-- License     : BSD-style+-- Maintainer  : Foundation+--+-- Some low level helpers to use UTF8+--+-- Most helpers are lowlevel and unsafe, don't use+-- directly.+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE NoImplicitPrelude          #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE CPP                        #-}+module Basement.UTF8.Helper+    where++import           Basement.Compat.Base+import           Basement.Compat.Primitive+import           Basement.Types.OffsetSize+import           GHC.Prim+import           GHC.Types+import           GHC.Word++-- mask an UTF8 continuation byte (stripping the leading 10 and returning 6 valid bits)+maskContinuation# :: Word# -> Word#+maskContinuation# v = and# v 0x3f##+{-# INLINE maskContinuation# #-}++-- mask a UTF8 header for 2 bytes encoding (110xxxxx and 5 valid bits)+maskHeader2# :: Word# -> Word#+maskHeader2# h = and# h 0x1f##+{-# INLINE maskHeader2# #-}++-- mask a UTF8 header for 3 bytes encoding (1110xxxx and 4 valid bits)+maskHeader3# :: Word# -> Word#+maskHeader3# h = and# h 0xf##+{-# INLINE maskHeader3# #-}++-- mask a UTF8 header for 3 bytes encoding (11110xxx and 3 valid bits)+maskHeader4# :: Word# -> Word#+maskHeader4# h = and# h 0x7##+{-# INLINE maskHeader4# #-}++or3# :: Word# -> Word# -> Word# -> Word#+or3# a b c = or# a (or# b c)+{-# INLINE or3# #-}++or4# :: Word# -> Word# -> Word# -> Word# -> Word#+or4# a b c d = or# (or# a b) (or# c d)+{-# INLINE or4# #-}++toChar# :: Word# -> Char+toChar# w = C# (chr# (word2Int# w))+{-# INLINE toChar# #-}++toChar1 :: Word8 -> Char+toChar1 (W8# w) = toChar# w++toChar2 :: Word8 -> Word8 -> Char+toChar2 (W8# w1) (W8# w2)=+    toChar# (or# (uncheckedShiftL# (maskHeader2# w1) 6#) (maskContinuation# w2))++toChar3 :: Word8 -> Word8 -> Word8 -> Char+toChar3 (W8# w1) (W8# w2) (W8# w3) =+    toChar# (or3# (uncheckedShiftL# (maskHeader3# w1) 12#)+                  (uncheckedShiftL# (maskContinuation# w2) 6#)+                  (maskContinuation# w3)+            )++toChar4 :: Word8 -> Word8 -> Word8 -> Word8 -> Char+toChar4 (W8# w1) (W8# w2) (W8# w3) (W8# w4) =+    toChar# (or4# (uncheckedShiftL# (maskHeader4# w1) 18#)+                  (uncheckedShiftL# (maskContinuation# w2) 12#)+                  (uncheckedShiftL# (maskContinuation# w3) 6#)+                  (maskContinuation# w4)+            )++-- | Different way to encode a Character in UTF8 represented as an ADT+data UTF8Char =+      UTF8_1 {-# UNPACK #-} !Word8+    | UTF8_2 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8+    | UTF8_3 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8+    | UTF8_4 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8++-- | Transform a Unicode code point 'Char' into+--+-- note that we expect here a valid unicode code point in the *allowed* range.+-- bits will be lost if going above 0x10ffff+asUTF8Char :: Char -> UTF8Char+asUTF8Char !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 = UTF8_1 (W8# x)+      encode2 =+          let !x1 = W8# (or# (uncheckedShiftRL# x 6#) 0xc0##)+              !x2 = toContinuation x+           in UTF8_2 x1 x2+      encode3 =+          let !x1 = W8# (or# (uncheckedShiftRL# x 12#) 0xe0##)+              !x2 = toContinuation (uncheckedShiftRL# x 6#)+              !x3 = toContinuation x+           in UTF8_3 x1 x2 x3+      encode4 =+          let !x1 = W8# (or# (uncheckedShiftRL# x 18#) 0xf0##)+              !x2 = toContinuation (uncheckedShiftRL# x 12#)+              !x3 = toContinuation (uncheckedShiftRL# x 6#)+              !x4 = toContinuation x+           in UTF8_4 x1 x2 x3 x4++      toContinuation :: Word# -> Word8+      toContinuation w = W8# (or# (and# w 0x3f##) 0x80##)+      {-# INLINE toContinuation #-}++-- given the encoding of UTF8 Char, get the number of bytes of this sequence+numBytes :: UTF8Char -> CountOf Word8+numBytes UTF8_1{} = CountOf 1+numBytes UTF8_2{} = CountOf 2+numBytes UTF8_3{} = CountOf 3+numBytes UTF8_4{} = CountOf 4++-- given the leading byte of a utf8 sequence, get the number of bytes of this sequence+skipNextHeaderValue :: Word8 -> CountOf Word8+skipNextHeaderValue !x+    | x < 0xC0  = CountOf 1 -- 0b11000000+    | x < 0xE0  = CountOf 2 -- 0b11100000+    | x < 0xF0  = CountOf 3 -- 0b11110000+    | otherwise = CountOf 4+{-# INLINE skipNextHeaderValue #-}++headerIsAscii :: Word8 -> Bool+headerIsAscii x = x < 0x80++charToBytes :: Int -> CountOf Word8+charToBytes c+    | c < 0x80     = CountOf 1+    | c < 0x800    = CountOf 2+    | c < 0x10000  = CountOf 3+    | c < 0x110000 = CountOf 4+    | otherwise    = error ("invalid code point: " `mappend` show c)
+ Basement/UTF8/Table.hs view
@@ -0,0 +1,82 @@+-- |+-- Module      : Basement.UTF8.Table+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : portable+--+-- UTF8 lookup tables for fast continuation & nb bytes per header queries+{-# LANGUAGE MagicHash #-}+module Basement.UTF8.Table+    ( isContinuation+    , getNbBytes+    , isContinuation#+    , getNbBytes#+    ) where++import           GHC.Prim+import           GHC.Types+import           GHC.Word+import           Basement.Compat.Base++-- | Check if the byte is a continuation byte+isContinuation :: Word8 -> Bool+isContinuation (W8# w) = isContinuation# w+{-# INLINE isContinuation #-}++-- | Get the number of following bytes given the first byte of a UTF8 sequence.+getNbBytes :: Word8 -> Int+getNbBytes (W8# w) = I# (getNbBytes# w)+{-# INLINE getNbBytes #-}++-- | Check if the byte is a continuation byte+isContinuation# :: Word# -> Bool+isContinuation# w = W# (indexWord8OffAddr# (unTable contTable) (word2Int# w)) /= W# 0##+{-# INLINE isContinuation# #-}++-- | Get the number of following bytes given the first byte of a UTF8 sequence.+getNbBytes# :: Word# -> Int#+getNbBytes# w = word2Int# (indexWord8OffAddr# (unTable headTable) (word2Int# w))+{-# INLINE getNbBytes# #-}++data Table = Table { unTable :: !Addr# }++contTable :: Table+contTable = Table+        "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#+{-# NOINLINE contTable #-}++headTable :: Table+headTable = Table+        "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+        \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\+        \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\+        \\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\+        \\x03\x03\x03\x03\x03\x03\x03\x03\xff\xff\xff\xff\xff\xff\xff\xff"#+{-# NOINLINE headTable #-}
+ Basement/UTF8/Types.hs view
@@ -0,0 +1,50 @@+module Basement.UTF8.Types+    (+    -- * Stepper+      Step(..)+    , StepBack(..)+    , StepASCII(..)+    , StepDigit(..)+    , isValidStepASCII+    , isValidStepDigit+    -- * Unicode Errors+    , ValidationFailure(..)+    ) where++import           Basement.Compat.Base+import           Basement.Types.OffsetSize++-- | Step when walking a String+--+-- this is a return value composed of :+-- * the unicode code point read (Char) which need to be+--   between 0 and 0x10ffff (inclusive)+-- * The next offset to start reading the next unicode code point (or end)+data Step = Step {-# UNPACK #-} !Char {-# UNPACK #-} !(Offset Word8)++-- | Similar to Step but used when processing the string from the end.+--+-- The stepper is thus the previous character, and the offset of+-- the beginning of the previous character+data StepBack = StepBack {-# UNPACK #-} !Char {-# UNPACK #-} !(Offset Word8)++-- | Step when processing digits. the value is between 0 and 9 to be valid+newtype StepDigit = StepDigit Word8++-- | Step when processing ASCII character+newtype StepASCII = StepASCII Word8++isValidStepASCII :: StepASCII -> Bool+isValidStepASCII (StepASCII w) = w < 0x80++isValidStepDigit :: StepDigit -> Bool+isValidStepDigit (StepDigit w) = w < 0xa++-- | Possible failure related to validating bytes of UTF8 sequences.+data ValidationFailure = InvalidHeader+                       | InvalidContinuation+                       | MissingByte+                       | BuildingFailure+                       deriving (Show,Eq,Typeable)++instance Exception ValidationFailure
+ Basement/Utils.hs view
@@ -0,0 +1,72 @@+-- |+-- Module      : Basement.Utils+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : portable+--+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+module Basement.Utils+    ( primCopyFreezedBytes+    , primCopyFreezedBytesOffset+    , primCopyFreezedW32+    , primCopyFreezedW64+    , primMutableAddrSlideToStart+    , primMutableByteArraySlideToStart+    ) where++import           Basement.Compat.Base+import           Basement.Types.OffsetSize+import           Basement.Compat.Primitive+import           Basement.Monad+import           GHC.Prim+import           GHC.Types++-- | Copy all bytes from a byteArray# to a mutableByteArray#+primCopyFreezedBytes :: PrimMonad m => MutableByteArray# (PrimState m) -> ByteArray# -> m ()+primCopyFreezedBytes mba ba = primitive $ \st ->+    (# copyByteArray# ba 0# mba 0# (sizeofByteArray# ba) st , () #)+{-# INLINE primCopyFreezedBytes #-}++-- | Copy @nbBytes bytes from a byteArray# to a mutableByteArray# starting at an offset+primCopyFreezedBytesOffset :: PrimMonad m => MutableByteArray# (PrimState m) -> Int# -> ByteArray# -> Int# -> m ()+primCopyFreezedBytesOffset mba ofs ba nbBytes = primitive $ \st ->+    (# copyByteArray# ba 0# mba ofs nbBytes st , () #)+{-# INLINE primCopyFreezedBytesOffset #-}++-- | same as 'primCopyFreezedBytes' except copy using 32 bits word+primCopyFreezedW32 :: PrimMonad m => MutableByteArray# (PrimState m) -> ByteArray# -> m ()+primCopyFreezedW32 mba ba = primitive $ \st -> (# loop st 0#, () #)+  where+    !len = quotInt# (sizeofByteArray# ba) 8#+    loop !st !n+        | bool# (n ==# len) = st+        | otherwise         = loop (writeWord32Array# mba n (indexWord32Array# ba n) st) (n +# 1#)+    {-# INLINE loop #-}+{-# INLINE primCopyFreezedW32 #-}++-- | same as 'primCopyFreezedBytes' except copy using 64 bits word+primCopyFreezedW64 :: PrimMonad m => MutableByteArray# (PrimState m) -> ByteArray# -> m ()+primCopyFreezedW64 mba ba = primitive $ \st -> (# loop st 0#, () #)+  where+    !len = quotInt# (sizeofByteArray# ba) 8#+    loop !st !n+        | bool# (n ==# len) = st+        | otherwise         = loop (writeWord64Array# mba n (indexWord64Array# ba n) st) (n +# 1#)+    {-# INLINE loop #-}+{-# INLINE primCopyFreezedW64 #-}++primMutableByteArraySlideToStart :: PrimMonad m => MutableByteArray# (PrimState m) -> Offset8 -> Offset8 -> m ()+primMutableByteArraySlideToStart mba (Offset (I# ofs)) (Offset (I# end)) = primitive $ \st ->+    (# copyMutableByteArray# mba 0# mba ofs (end -# ofs) st, () #)++primMutableAddrSlideToStart :: PrimMonad m => Addr# -> Offset8 -> Offset8 -> m ()+primMutableAddrSlideToStart addr (Offset (I# ofsIni)) (Offset (I# end)) = primitive $ \st -> (# loop st 0# ofsIni, () #)+  where+    loop !st !dst !ofs+        | bool# (ofs ==# end) = st+        | otherwise           =+            case readWord8OffAddr# addr ofs st of { (# st', v #) ->+            case writeWord8OffAddr# addr dst v st' of { st'' ->+                loop st'' (dst +# 1#) (ofs +# 1#) }}
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2015-2017 Vincent Hanquez <vincent@snarc.org>+Copyright (c) 2017      Foundation Maintainers++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ basement.cabal view
@@ -0,0 +1,129 @@+name:                basement+version:             0.0.0+synopsis:            Foundation scrap box of array & string+description:         Foundation most basic primitives without any dependencies+homepage:            https://github.com/haskell-foundation/foundation#readme+license:             BSD3+license-file:        LICENSE+copyright:           2015-2017 Vincent Hanquez <vincent@snarc.org>+                     2017      Foundation Maintainers+maintainer:          vincent@snarc.org+copyright:           Vincent Hanquez+category:            Web+build-type:          Simple+homepage:            https://github.com/haskell-foundation/foundation+bug-reports:         https://github.com/haskell-foundation/foundation/issues+cabal-version:       >=1.10+tested-with:         GHC==8.2.1, GHC==8.0.2, GHC==7.10.3+extra-source-files:  cbits/*.h++source-repository head+  type: git+  location: https://github.com/haskell-foundation/foundation.git++library+  hs-source-dirs:    .+  exposed-modules:   +                     Basement.Imports++                     Basement.Base16+                     Basement.Bindings.Memory+                     Basement.Endianness+                     Basement.Environment+                     Basement.PrimType++                     Basement.Exception+                     Basement.From++                     Basement.Types.Char7+                     Basement.Types.OffsetSize+                     Basement.Types.Ptr+                     Basement.Types.AsciiString+                     Basement.Monad+                     Basement.MutableBuilder+                     Basement.FinalPtr++                     Basement.Nat++                     -- Extended Types+                     Basement.BoxedArray+                     Basement.Block+                     Basement.Block.Mutable+                     Basement.UArray+                     Basement.UArray.Mutable+                     Basement.String+                     Basement.NonEmpty+                     +                     -- Utils+                     Basement.NormalForm+                     Basement.These++                     -- numeric stuff+                     Basement.IntegralConv+                     Basement.Floating+                     Basement.Numerical.Number+                     Basement.Numerical.Additive+                     Basement.Numerical.Subtractive+                     Basement.Numerical.Multiplicative+                     Basement.Bounded++                     -- compat / base redefinition+                     Basement.Compat.Base+                     Basement.Compat.Bifunctor+                     Basement.Compat.CallStack+                     Basement.Compat.ExtList+                     Basement.Compat.IsList+                     Basement.Compat.Identity+                     Basement.Compat.Primitive+                     Basement.Compat.PrimTypes+                     Basement.Compat.MonadTrans+                     Basement.Compat.Natural+                     Basement.Compat.NumLiteral+                     Basement.Compat.Typeable+  if impl(ghc >= 8.0)+    exposed-modules: Basement.BlockN++  other-modules:+                     Basement.Error+                     Basement.Show+                     Basement.Runtime++                     Basement.Utils++                     Basement.Block.Base++                     Basement.UTF8.Addr+                     Basement.UTF8.BA+                     Basement.UTF8.Base+                     Basement.UTF8.Helper+                     Basement.UTF8.Table+                     Basement.UTF8.Types++                     Basement.UArray.Addr+                     Basement.UArray.BA+                     Basement.UArray.Base++                     Basement.String.BA+                     Basement.String.Addr+                     Basement.String.Encoding.Encoding+                     Basement.String.Encoding.UTF16+                     Basement.String.Encoding.UTF32+                     Basement.String.Encoding.ASCII7+                     Basement.String.Encoding.ISO_8859_1+++  build-depends:       base >= 4.7 && < 5+                     , ghc-prim+  default-language:    Haskell2010+  default-extensions: NoImplicitPrelude+                      RebindableSyntax+                      TypeFamilies+                      BangPatterns+                      DeriveDataTypeable+  if (arch(i386) || arch(x86_64))+    cpp-options: -DARCH_IS_LITTLE_ENDIAN+  else+    cpp-options: -DARCH_IS_UNKNOWN_ENDIAN+  include-dirs:      cbits+  c-sources:         cbits/foundation_mem.c+                     cbits/foundation_rts.c
+ cbits/foundation_mem.c view
@@ -0,0 +1,14 @@+#include <string.h>+#include <stdint.h>+#include "foundation_prim.h"++int _foundation_memcmp(const void *s1, FsOffset off1, const void *s2, FsOffset off2, FsCountOf n)+{+	return memcmp(s1 + off1, s2 + off2, n);+}++FsOffset _foundation_mem_findbyte(uint8_t * const arr, FsOffset startofs, FsOffset endofs, uint8_t ty)+{+    uint8_t *r = memchr(arr + startofs, ty, endofs - startofs);+    return ((r == NULL) ? endofs : r - arr);+}
+ cbits/foundation_prim.h view
@@ -0,0 +1,8 @@+#ifndef FOUNDATION_PRIM_H+#define FOUNDATION_PRIM_H+#include "Rts.h"++typedef StgInt FsOffset;+typedef StgInt FsCountOf;++#endif
+ cbits/foundation_rts.c view
@@ -0,0 +1,8 @@+#include "Rts.h"++#if __GLASGOW_HASKELL__ < 802+int foundation_is_bytearray_pinned(void *p)+{+    return Bdescr((StgPtr) p)->flags & BF_PINNED;+}+#endif