diff --git a/Basement/Base16.hs b/Basement/Base16.hs new file mode 100644 --- /dev/null +++ b/Basement/Base16.hs @@ -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"# + diff --git a/Basement/Bindings/Memory.hs b/Basement/Bindings/Memory.hs new file mode 100644 --- /dev/null +++ b/Basement/Bindings/Memory.hs @@ -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 diff --git a/Basement/Block.hs b/Basement/Block.hs new file mode 100644 --- /dev/null +++ b/Basement/Block.hs @@ -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) diff --git a/Basement/Block/Base.hs b/Basement/Block/Base.hs new file mode 100644 --- /dev/null +++ b/Basement/Block/Base.hs @@ -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, () #) } + diff --git a/Basement/Block/Mutable.hs b/Basement/Block/Mutable.hs new file mode 100644 --- /dev/null +++ b/Basement/Block/Mutable.hs @@ -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< 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 #-} diff --git a/Basement/BlockN.hs b/Basement/BlockN.hs new file mode 100644 --- /dev/null +++ b/Basement/BlockN.hs @@ -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)) diff --git a/Basement/Bounded.hs b/Basement/Bounded.hs new file mode 100644 --- /dev/null +++ b/Basement/Bounded.hs @@ -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) diff --git a/Basement/BoxedArray.hs b/Basement/BoxedArray.hs new file mode 100644 --- /dev/null +++ b/Basement/BoxedArray.hs @@ -0,0 +1,741 @@ +-- | +-- Module : Basement.BoxedArray +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Basement/Compat/Base.hs b/Basement/Compat/Base.hs new file mode 100644 --- /dev/null +++ b/Basement/Compat/Base.hs @@ -0,0 +1,91 @@ +-- | +-- Module : Basement.Compat.Base +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Basement/Compat/Bifunctor.hs b/Basement/Compat/Bifunctor.hs new file mode 100644 --- /dev/null +++ b/Basement/Compat/Bifunctor.hs @@ -0,0 +1,83 @@ +-- | +-- Module : Basement.Compat.Bifunctor +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Basement/Compat/CallStack.hs b/Basement/Compat/CallStack.hs new file mode 100644 --- /dev/null +++ b/Basement/Compat/CallStack.hs @@ -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 diff --git a/Basement/Compat/ExtList.hs b/Basement/Compat/ExtList.hs new file mode 100644 --- /dev/null +++ b/Basement/Compat/ExtList.hs @@ -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) diff --git a/Basement/Compat/Identity.hs b/Basement/Compat/Identity.hs new file mode 100644 --- /dev/null +++ b/Basement/Compat/Identity.hs @@ -0,0 +1,37 @@ +-- | +-- Module : Basement.Compat.Identity +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Basement/Compat/IsList.hs b/Basement/Compat/IsList.hs new file mode 100644 --- /dev/null +++ b/Basement/Compat/IsList.hs @@ -0,0 +1,36 @@ +-- | +-- Module : Basement.Compat.IsList +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Basement/Compat/MonadTrans.hs b/Basement/Compat/MonadTrans.hs new file mode 100644 --- /dev/null +++ b/Basement/Compat/MonadTrans.hs @@ -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 diff --git a/Basement/Compat/Natural.hs b/Basement/Compat/Natural.hs new file mode 100644 --- /dev/null +++ b/Basement/Compat/Natural.hs @@ -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) diff --git a/Basement/Compat/NumLiteral.hs b/Basement/Compat/NumLiteral.hs new file mode 100644 --- /dev/null +++ b/Basement/Compat/NumLiteral.hs @@ -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 diff --git a/Basement/Compat/PrimTypes.hs b/Basement/Compat/PrimTypes.hs new file mode 100644 --- /dev/null +++ b/Basement/Compat/PrimTypes.hs @@ -0,0 +1,36 @@ +-- | +-- Module : Basement.Compat.PrimTypes +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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# diff --git a/Basement/Compat/Primitive.hs b/Basement/Compat/Primitive.hs new file mode 100644 --- /dev/null +++ b/Basement/Compat/Primitive.hs @@ -0,0 +1,175 @@ +-- | +-- Module : Basement.Compat.Primitive +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Basement/Compat/Typeable.hs b/Basement/Compat/Typeable.hs new file mode 100644 --- /dev/null +++ b/Basement/Compat/Typeable.hs @@ -0,0 +1,37 @@ +-- | +-- Module : Basement.Compat.Typeable +-- License : BSD-style +-- Maintainer : Nicolas Di Prima +-- 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 diff --git a/Basement/Endianness.hs b/Basement/Endianness.hs new file mode 100644 --- /dev/null +++ b/Basement/Endianness.hs @@ -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 diff --git a/Basement/Environment.hs b/Basement/Environment.hs new file mode 100644 --- /dev/null +++ b/Basement/Environment.hs @@ -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) diff --git a/Basement/Error.hs b/Basement/Error.hs new file mode 100644 --- /dev/null +++ b/Basement/Error.hs @@ -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 diff --git a/Basement/Exception.hs b/Basement/Exception.hs new file mode 100644 --- /dev/null +++ b/Basement/Exception.hs @@ -0,0 +1,69 @@ +-- | +-- Module : Basement.Exception +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Basement/FinalPtr.hs b/Basement/FinalPtr.hs new file mode 100644 --- /dev/null +++ b/Basement/FinalPtr.hs @@ -0,0 +1,112 @@ +-- | +-- Module : Basement.FinalPtr +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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_ #-} diff --git a/Basement/Floating.hs b/Basement/Floating.hs new file mode 100644 --- /dev/null +++ b/Basement/Floating.hs @@ -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 diff --git a/Basement/From.hs b/Basement/From.hs new file mode 100644 --- /dev/null +++ b/Basement/From.hs @@ -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 diff --git a/Basement/Imports.hs b/Basement/Imports.hs new file mode 100644 --- /dev/null +++ b/Basement/Imports.hs @@ -0,0 +1,114 @@ +-- | +-- Module : Basement.Imports +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Basement/IntegralConv.hs b/Basement/IntegralConv.hs new file mode 100644 --- /dev/null +++ b/Basement/IntegralConv.hs @@ -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) diff --git a/Basement/Monad.hs b/Basement/Monad.hs new file mode 100644 --- /dev/null +++ b/Basement/Monad.hs @@ -0,0 +1,136 @@ +-- | +-- Module : Basement.Monad +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Basement/MutableBuilder.hs b/Basement/MutableBuilder.hs new file mode 100644 --- /dev/null +++ b/Basement/MutableBuilder.hs @@ -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)) diff --git a/Basement/Nat.hs b/Basement/Nat.hs new file mode 100644 --- /dev/null +++ b/Basement/Nat.hs @@ -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 diff --git a/Basement/NonEmpty.hs b/Basement/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/Basement/NonEmpty.hs @@ -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 diff --git a/Basement/NormalForm.hs b/Basement/NormalForm.hs new file mode 100644 --- /dev/null +++ b/Basement/NormalForm.hs @@ -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 diff --git a/Basement/Numerical/Additive.hs b/Basement/Numerical/Additive.hs new file mode 100644 --- /dev/null +++ b/Basement/Numerical/Additive.hs @@ -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 diff --git a/Basement/Numerical/Multiplicative.hs b/Basement/Numerical/Multiplicative.hs new file mode 100644 --- /dev/null +++ b/Basement/Numerical/Multiplicative.hs @@ -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 diff --git a/Basement/Numerical/Number.hs b/Basement/Numerical/Number.hs new file mode 100644 --- /dev/null +++ b/Basement/Numerical/Number.hs @@ -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 diff --git a/Basement/Numerical/Subtractive.hs b/Basement/Numerical/Subtractive.hs new file mode 100644 --- /dev/null +++ b/Basement/Numerical/Subtractive.hs @@ -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) diff --git a/Basement/PrimType.hs b/Basement/PrimType.hs new file mode 100644 --- /dev/null +++ b/Basement/PrimType.hs @@ -0,0 +1,644 @@ +-- Module : Basement.PrimType +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 #-} diff --git a/Basement/Runtime.hs b/Basement/Runtime.hs new file mode 100644 --- /dev/null +++ b/Basement/Runtime.hs @@ -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 #-} diff --git a/Basement/Show.hs b/Basement/Show.hs new file mode 100644 --- /dev/null +++ b/Basement/Show.hs @@ -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 diff --git a/Basement/String.hs b/Basement/String.hs new file mode 100644 --- /dev/null +++ b/Basement/String.hs @@ -0,0 +1,1403 @@ +-- | +-- Module : Basement.String +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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: +-- +-- [ '-' ] [ '.' ] [ ( 'e' | 'E' ) [ '-' ] ] +-- +-- 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"# diff --git a/Basement/String/Addr.hs b/Basement/String/Addr.hs new file mode 100644 --- /dev/null +++ b/Basement/String/Addr.hs @@ -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" diff --git a/Basement/String/BA.hs b/Basement/String/BA.hs new file mode 100644 --- /dev/null +++ b/Basement/String/BA.hs @@ -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" diff --git a/Basement/String/Encoding/ASCII7.hs b/Basement/String/Encoding/ASCII7.hs new file mode 100644 --- /dev/null +++ b/Basement/String/Encoding/ASCII7.hs @@ -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)) diff --git a/Basement/String/Encoding/Encoding.hs b/Basement/String/Encoding/Encoding.hs new file mode 100644 --- /dev/null +++ b/Basement/String/Encoding/Encoding.hs @@ -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 diff --git a/Basement/String/Encoding/ISO_8859_1.hs b/Basement/String/Encoding/ISO_8859_1.hs new file mode 100644 --- /dev/null +++ b/Basement/String/Encoding/ISO_8859_1.hs @@ -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) diff --git a/Basement/String/Encoding/UTF16.hs b/Basement/String/Encoding/UTF16.hs new file mode 100644 --- /dev/null +++ b/Basement/String/Encoding/UTF16.hs @@ -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)) diff --git a/Basement/String/Encoding/UTF32.hs b/Basement/String/Encoding/UTF32.hs new file mode 100644 --- /dev/null +++ b/Basement/String/Encoding/UTF32.hs @@ -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)) diff --git a/Basement/These.hs b/Basement/These.hs new file mode 100644 --- /dev/null +++ b/Basement/These.hs @@ -0,0 +1,36 @@ +-- | +-- Module : Basement.These +-- License : BSD-style +-- Maintainer : Nicolas Di Prima +-- 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 diff --git a/Basement/Types/AsciiString.hs b/Basement/Types/AsciiString.hs new file mode 100644 --- /dev/null +++ b/Basement/Types/AsciiString.hs @@ -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 diff --git a/Basement/Types/Char7.hs b/Basement/Types/Char7.hs new file mode 100644 --- /dev/null +++ b/Basement/Types/Char7.hs @@ -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 diff --git a/Basement/Types/OffsetSize.hs b/Basement/Types/OffsetSize.hs new file mode 100644 --- /dev/null +++ b/Basement/Types/OffsetSize.hs @@ -0,0 +1,250 @@ +-- | +-- Module : Basement.Types.OffsetSize +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Basement/Types/Ptr.hs b/Basement/Types/Ptr.hs new file mode 100644 --- /dev/null +++ b/Basement/Types/Ptr.hs @@ -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 diff --git a/Basement/UArray.hs b/Basement/UArray.hs new file mode 100644 --- /dev/null +++ b/Basement/UArray.hs @@ -0,0 +1,963 @@ +-- | +-- Module : Basement.UArray +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 #-} diff --git a/Basement/UArray/Addr.hs b/Basement/UArray/Addr.hs new file mode 100644 --- /dev/null +++ b/Basement/UArray/Addr.hs @@ -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 #-} diff --git a/Basement/UArray/BA.hs b/Basement/UArray/BA.hs new file mode 100644 --- /dev/null +++ b/Basement/UArray/BA.hs @@ -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 #-} diff --git a/Basement/UArray/Base.hs b/Basement/UArray/Base.hs new file mode 100644 --- /dev/null +++ b/Basement/UArray/Base.hs @@ -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 diff --git a/Basement/UArray/Mutable.hs b/Basement/UArray/Mutable.hs new file mode 100644 --- /dev/null +++ b/Basement/UArray/Mutable.hs @@ -0,0 +1,196 @@ +-- | +-- Module : Basement.UArray.Mutable -- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Basement/UTF8/Addr.hs b/Basement/UTF8/Addr.hs new file mode 100644 --- /dev/null +++ b/Basement/UTF8/Addr.hs @@ -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 #-} diff --git a/Basement/UTF8/BA.hs b/Basement/UTF8/BA.hs new file mode 100644 --- /dev/null +++ b/Basement/UTF8/BA.hs @@ -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 #-} diff --git a/Basement/UTF8/Base.hs b/Basement/UTF8/Base.hs new file mode 100644 --- /dev/null +++ b/Basement/UTF8/Base.hs @@ -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 diff --git a/Basement/UTF8/Helper.hs b/Basement/UTF8/Helper.hs new file mode 100644 --- /dev/null +++ b/Basement/UTF8/Helper.hs @@ -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) diff --git a/Basement/UTF8/Table.hs b/Basement/UTF8/Table.hs new file mode 100644 --- /dev/null +++ b/Basement/UTF8/Table.hs @@ -0,0 +1,82 @@ +-- | +-- Module : Basement.UTF8.Table +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 #-} diff --git a/Basement/UTF8/Types.hs b/Basement/UTF8/Types.hs new file mode 100644 --- /dev/null +++ b/Basement/UTF8/Types.hs @@ -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 diff --git a/Basement/Utils.hs b/Basement/Utils.hs new file mode 100644 --- /dev/null +++ b/Basement/Utils.hs @@ -0,0 +1,72 @@ +-- | +-- Module : Basement.Utils +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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#) }} diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2015-2017 Vincent Hanquez +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/basement.cabal b/basement.cabal new file mode 100644 --- /dev/null +++ b/basement.cabal @@ -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 + 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 diff --git a/cbits/foundation_mem.c b/cbits/foundation_mem.c new file mode 100644 --- /dev/null +++ b/cbits/foundation_mem.c @@ -0,0 +1,14 @@ +#include +#include +#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); +} diff --git a/cbits/foundation_prim.h b/cbits/foundation_prim.h new file mode 100644 --- /dev/null +++ b/cbits/foundation_prim.h @@ -0,0 +1,8 @@ +#ifndef FOUNDATION_PRIM_H +#define FOUNDATION_PRIM_H +#include "Rts.h" + +typedef StgInt FsOffset; +typedef StgInt FsCountOf; + +#endif diff --git a/cbits/foundation_rts.c b/cbits/foundation_rts.c new file mode 100644 --- /dev/null +++ b/cbits/foundation_rts.c @@ -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