basement-0.0.4/Basement/0000755000000000000000000000000013201626577013246 5ustar0000000000000000basement-0.0.4/Basement/Alg/0000755000000000000000000000000013201545546013745 5ustar0000000000000000basement-0.0.4/Basement/Alg/Foreign/0000755000000000000000000000000013201545546015336 5ustar0000000000000000basement-0.0.4/Basement/Alg/Native/0000755000000000000000000000000013201545546015173 5ustar0000000000000000basement-0.0.4/Basement/Bindings/0000755000000000000000000000000013141321320014760 5ustar0000000000000000basement-0.0.4/Basement/Block/0000755000000000000000000000000013175306665014303 5ustar0000000000000000basement-0.0.4/Basement/Compat/0000755000000000000000000000000013201626577014471 5ustar0000000000000000basement-0.0.4/Basement/Numerical/0000755000000000000000000000000013201544137015154 5ustar0000000000000000basement-0.0.4/Basement/Sized/0000755000000000000000000000000013201544137014313 5ustar0000000000000000basement-0.0.4/Basement/String/0000755000000000000000000000000013150326767014515 5ustar0000000000000000basement-0.0.4/Basement/String/Encoding/0000755000000000000000000000000013150326767016243 5ustar0000000000000000basement-0.0.4/Basement/Terminal/0000755000000000000000000000000013201626577015021 5ustar0000000000000000basement-0.0.4/Basement/Types/0000755000000000000000000000000013201544137014341 5ustar0000000000000000basement-0.0.4/Basement/UArray/0000755000000000000000000000000013201545546014445 5ustar0000000000000000basement-0.0.4/Basement/UTF8/0000755000000000000000000000000013176251306013767 5ustar0000000000000000basement-0.0.4/cbits/0000755000000000000000000000000013201626577012614 5ustar0000000000000000basement-0.0.4/Basement/Imports.hs0000644000000000000000000000705013175306665015244 0ustar0000000000000000-- | -- Module : Basement.Imports -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : portable -- -- re-export of all the base prelude and basic primitive stuffs {-# LANGUAGE CPP #-} 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 (..) #if MIN_VERSION_base(4,10,0) -- , (Basement.Compat.Semigroup.<>) , Basement.Compat.Semigroup.Semigroup(..) #else , (Data.Monoid.<>) , Basement.Compat.Semigroup.Semigroup #endif , 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.Compat.Semigroup import qualified Basement.UArray import qualified Basement.BoxedArray import qualified Basement.UTF8.Base import qualified Basement.Error import qualified Basement.Show import qualified Basement.PrimType import qualified Basement.Types.OffsetSize import qualified Basement.Types.AsciiString import qualified Basement.Types.Char7 import qualified GHC.Exts import qualified GHC.Generics import qualified GHC.Ptr import GHC.Exts (fromString) -- | for support of if .. then .. else ifThenElse :: Prelude.Bool -> a -> a -> a ifThenElse Prelude.True e1 _ = e1 ifThenElse Prelude.False _ e2 = e2 -- | IEEE754 Floating point Binary32, simple precision (Also known as Float) type FP32 = Prelude.Float -- | IEEE754 Floating point Binary64, double precision (Also known as Double) type FP64 = Prelude.Double basement-0.0.4/Basement/Base16.hs0000644000000000000000000000534013162720757014626 0ustar0000000000000000{-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE BangPatterns #-} module Basement.Base16 ( unsafeConvertByte , hexWord16 , hexWord32 , escapeByte , Base16Escape(..) ) where import GHC.Prim import GHC.Types import GHC.Word import Basement.Types.Char7 data Base16Escape = Base16Escape {-# UNPACK #-} !Char7 {-# UNPACK #-} !Char7 -- | 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 #-} escapeByte :: Word8 -> Base16Escape escapeByte !(W8# b) = Base16Escape (r tableHi b) (r tableLo b) where r :: Table -> Word# -> Char7 r (Table !table) index = Char7 (W8# (indexWord8OffAddr# table (word2Int# index))) {-# INLINE escapeByte #-} -- | hex word16 hexWord16 :: Word16 -> (Char, Char, Char, Char) hexWord16 (W16# w) = (toChar w1,toChar w2,toChar w3,toChar w4) where toChar :: Word# -> Char toChar c = C# (chr# (word2Int# c)) !(# w1, w2 #) = unsafeConvertByte (uncheckedShiftRL# w 8#) !(# w3, w4 #) = unsafeConvertByte (and# w 0xff##) -- | hex word32 hexWord32 :: Word32 -> (Char, Char, Char, Char, Char, Char, Char, Char) hexWord32 (W32# w) = (toChar w1,toChar w2,toChar w3,toChar w4 ,toChar w5,toChar w6,toChar w7,toChar w8) where toChar :: Word# -> Char toChar c = C# (chr# (word2Int# c)) !(# w1, w2 #) = unsafeConvertByte (uncheckedShiftRL# w 24#) !(# w3, w4 #) = unsafeConvertByte (and# (uncheckedShiftRL# w 16#) 0xff##) !(# w5, w6 #) = unsafeConvertByte (and# (uncheckedShiftRL# w 8#) 0xff##) !(# w7, w8 #) = unsafeConvertByte (and# w 0xff##) data Table = Table Addr# tableLo:: Table tableLo = Table "0123456789abcdef0123456789abcdef\ \0123456789abcdef0123456789abcdef\ \0123456789abcdef0123456789abcdef\ \0123456789abcdef0123456789abcdef\ \0123456789abcdef0123456789abcdef\ \0123456789abcdef0123456789abcdef\ \0123456789abcdef0123456789abcdef\ \0123456789abcdef0123456789abcdef"# tableHi :: Table tableHi = Table "00000000000000001111111111111111\ \22222222222222223333333333333333\ \44444444444444445555555555555555\ \66666666666666667777777777777777\ \88888888888888889999999999999999\ \aaaaaaaaaaaaaaaabbbbbbbbbbbbbbbb\ \ccccccccccccccccdddddddddddddddd\ \eeeeeeeeeeeeeeeeffffffffffffffff"# basement-0.0.4/Basement/Bindings/Memory.hs0000644000000000000000000000221713141321320016566 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnliftedFFITypes #-} module Basement.Bindings.Memory where import GHC.IO import GHC.Prim import GHC.Word import Foreign.C.Types import Foreign.Ptr import Basement.Types.OffsetSize foreign import ccall unsafe "_foundation_memcmp" sysHsMemcmpBaBa :: ByteArray# -> Offset Word8 -> ByteArray# -> Offset Word8 -> CountOf Word8 -> IO CInt foreign import ccall unsafe "_foundation_memcmp" sysHsMemcmpBaPtr :: ByteArray# -> Offset Word8 -> Ptr a -> Offset Word8 -> CountOf Word8 -> IO CInt foreign import ccall unsafe "_foundation_memcmp" sysHsMemcmpPtrBa :: Ptr a -> Offset Word8 -> ByteArray# -> Offset Word8 -> CountOf Word8 -> IO CInt foreign import ccall unsafe "_foundation_memcmp" sysHsMemcmpPtrPtr :: Ptr a -> Offset Word8 -> Ptr b -> Offset Word8 -> CountOf Word8 -> IO CInt foreign import ccall unsafe "_foundation_mem_findbyte" sysHsMemFindByteBa :: ByteArray# -> Offset Word8 -> Offset Word8 -> Word8 -> Offset Word8 foreign import ccall unsafe "_foundation_mem_findbyte" sysHsMemFindByteAddr :: Addr# -> Offset Word8 -> Offset Word8 -> Word8 -> Offset Word8 basement-0.0.4/Basement/Endianness.hs0000644000000000000000000000703713141321320015655 0ustar0000000000000000-- | -- Module : Basement.Endianness -- License : BSD-style -- Maintainer : Haskell Foundation -- Stability : experimental -- Portability : portable -- -- Set endianness tag to a given primitive. This will help for serialising -- data for protocols (such as the network protocols). -- {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Basement.Endianness ( ByteSwap -- * Big Endian , BE(..), toBE, fromBE -- * Little Endian , LE(..), toLE, fromLE -- * System Endianness , Endianness(..) , endianness ) where import Basement.Compat.Base import Data.Word (byteSwap16, byteSwap32, byteSwap64) #if defined(ARCH_IS_LITTLE_ENDIAN) || defined(ARCH_IS_BIG_ENDIAN) #else import Foreign.Marshal.Alloc (alloca) import Foreign.Ptr (castPtr) import Foreign.Storable (poke, peek) import Data.Word (Word8, Word32) import System.IO.Unsafe (unsafePerformIO) #endif import Data.Bits -- #if !defined(ARCH_IS_LITTLE_ENDIAN) && !defined(ARCH_IS_BIG_ENDIAN) -- import Foundation.System.Info (endianness, Endianness(..)) -- #endif data Endianness = LittleEndian | BigEndian deriving (Eq, Show) -- | Little Endian value newtype LE a = LE { unLE :: a } deriving (Show, Eq, Typeable, Bits) instance (ByteSwap a, Ord a) => Ord (LE a) where compare e1 e2 = compare (fromLE e1) (fromLE e2) -- | Big Endian value newtype BE a = BE { unBE :: a } deriving (Show, Eq, Typeable, Bits) instance (ByteSwap a, Ord a) => Ord (BE a) where compare e1 e2 = compare (fromBE e1) (fromBE e2) -- | Convert a value in cpu endianess to big endian toBE :: ByteSwap a => a -> BE a #ifdef ARCH_IS_LITTLE_ENDIAN toBE = BE . byteSwap #elif ARCH_IS_BIG_ENDIAN toBE = BE #else toBE = BE . (if endianness == LittleEndian then byteSwap else id) #endif {-# INLINE toBE #-} -- | Convert from a big endian value to the cpu endianness fromBE :: ByteSwap a => BE a -> a #ifdef ARCH_IS_LITTLE_ENDIAN fromBE (BE a) = byteSwap a #elif ARCH_IS_BIG_ENDIAN fromBE (BE a) = a #else fromBE (BE a) = if endianness == LittleEndian then byteSwap a else a #endif {-# INLINE fromBE #-} -- | Convert a value in cpu endianess to little endian toLE :: ByteSwap a => a -> LE a #ifdef ARCH_IS_LITTLE_ENDIAN toLE = LE #elif ARCH_IS_BIG_ENDIAN toLE = LE . byteSwap #else toLE = LE . (if endianness == LittleEndian then id else byteSwap) #endif {-# INLINE toLE #-} -- | Convert from a little endian value to the cpu endianness fromLE :: ByteSwap a => LE a -> a #ifdef ARCH_IS_LITTLE_ENDIAN fromLE (LE a) = a #elif ARCH_IS_BIG_ENDIAN fromLE (LE a) = byteSwap a #else fromLE (LE a) = if endianness == LittleEndian then a else byteSwap a #endif {-# INLINE fromLE #-} -- | endianness of the current architecture endianness :: Endianness #ifdef ARCH_IS_LITTLE_ENDIAN endianness = LittleEndian #elif ARCH_IS_BIG_ENDIAN endianness = BigEndian #else -- ! ARCH_IS_UNKNOWN_ENDIAN endianness = unsafePerformIO $ bytesToEndianness <$> word32ToByte input where input :: Word32 input = 0x01020304 {-# NOINLINE endianness #-} word32ToByte :: Word32 -> IO Word8 word32ToByte word = alloca $ \wordPtr -> do poke wordPtr word peek (castPtr wordPtr) bytesToEndianness :: Word8 -> Endianness bytesToEndianness 1 = BigEndian bytesToEndianness _ = LittleEndian #endif -- | Class of types that can be byte-swapped. -- -- e.g. Word16, Word32, Word64 class ByteSwap a where byteSwap :: a -> a instance ByteSwap Word16 where byteSwap = byteSwap16 instance ByteSwap Word32 where byteSwap = byteSwap32 instance ByteSwap Word64 where byteSwap = byteSwap64 basement-0.0.4/Basement/Environment.hs0000644000000000000000000000100313141321320016055 0ustar0000000000000000module Basement.Environment ( getArgs , lookupEnv ) where import Basement.Compat.Base import Basement.UTF8.Base (String) import qualified System.Environment as Sys (getArgs, lookupEnv) -- | Returns a list of the program's command line arguments (not including the program name). getArgs :: IO [String] getArgs = fmap fromList <$> Sys.getArgs -- | Lookup variable in the environment lookupEnv :: String -> IO (Maybe String) lookupEnv s = fmap fromList <$> Sys.lookupEnv (toList s) basement-0.0.4/Basement/PrimType.hs0000644000000000000000000010263213162720757015360 0ustar0000000000000000-- 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.Types.Word128 (Word128(..)) import Basement.Types.Word256 (Word256(..)) 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 Word128 where primSizeInBytes _ = CountOf 16 {-# INLINE primSizeInBytes #-} primShiftToBytes _ = 4 {-# INLINE primShiftToBytes #-} primBaUIndex ba n = Word128 (W64# (indexWord64Array# ba n1)) (W64# (indexWord64Array# ba n2)) where (# n1, n2 #) = offset128_64 n {-# INLINE primBaUIndex #-} primMbaURead mba n = primitive $ \s1 -> let !(# s2, r1 #) = readWord64Array# mba n1 s1 !(# s3, r2 #) = readWord64Array# mba n2 s2 in (# s3, Word128 (W64# r1) (W64# r2) #) where (# n1, n2 #) = offset128_64 n {-# INLINE primMbaURead #-} primMbaUWrite mba n (Word128 (W64# w1) (W64# w2)) = primitive $ \s1 -> let !s2 = writeWord64Array# mba n1 w1 s1 in (# writeWord64Array# mba n2 w2 s2, () #) where (# n1, n2 #) = offset128_64 n {-# INLINE primMbaUWrite #-} primAddrIndex addr n = Word128 (W64# (indexWord64OffAddr# addr n1)) (W64# (indexWord64OffAddr# addr n2)) where (# n1, n2 #) = offset128_64 n {-# INLINE primAddrIndex #-} primAddrRead addr n = primitive $ \s1 -> let !(# s2, r1 #) = readWord64OffAddr# addr n1 s1 !(# s3, r2 #) = readWord64OffAddr# addr n2 s2 in (# s3, Word128 (W64# r1) (W64# r2) #) where (# n1, n2 #) = offset128_64 n {-# INLINE primAddrRead #-} primAddrWrite addr n (Word128 (W64# w1) (W64# w2)) = primitive $ \s1 -> let !s2 = writeWord64OffAddr# addr n1 w1 s1 in (# writeWord64OffAddr# addr n2 w2 s2, () #) where (# n1, n2 #) = offset128_64 n {-# INLINE primAddrWrite #-} instance PrimType Word256 where primSizeInBytes _ = CountOf 32 {-# INLINE primSizeInBytes #-} primShiftToBytes _ = 5 {-# INLINE primShiftToBytes #-} primBaUIndex ba n = Word256 (W64# (indexWord64Array# ba n1)) (W64# (indexWord64Array# ba n2)) (W64# (indexWord64Array# ba n3)) (W64# (indexWord64Array# ba n4)) where (# n1, n2, n3, n4 #) = offset256_64 n {-# INLINE primBaUIndex #-} primMbaURead mba n = primitive $ \s1 -> let !(# s2, r1 #) = readWord64Array# mba n1 s1 !(# s3, r2 #) = readWord64Array# mba n2 s2 !(# s4, r3 #) = readWord64Array# mba n3 s3 !(# s5, r4 #) = readWord64Array# mba n4 s4 in (# s5, Word256 (W64# r1) (W64# r2) (W64# r3) (W64# r4) #) where (# n1, n2, n3, n4 #) = offset256_64 n {-# INLINE primMbaURead #-} primMbaUWrite mba n (Word256 (W64# w1) (W64# w2) (W64# w3) (W64# w4)) = primitive $ \s1 -> let !s2 = writeWord64Array# mba n1 w1 s1 !s3 = writeWord64Array# mba n2 w2 s2 !s4 = writeWord64Array# mba n3 w3 s3 in (# writeWord64Array# mba n4 w4 s4, () #) where (# n1, n2, n3, n4 #) = offset256_64 n {-# INLINE primMbaUWrite #-} primAddrIndex addr n = Word256 (W64# (indexWord64OffAddr# addr n1)) (W64# (indexWord64OffAddr# addr n2)) (W64# (indexWord64OffAddr# addr n3)) (W64# (indexWord64OffAddr# addr n4)) where (# n1, n2, n3, n4 #) = offset256_64 n {-# INLINE primAddrIndex #-} primAddrRead addr n = primitive $ \s1 -> let !(# s2, r1 #) = readWord64OffAddr# addr n1 s1 !(# s3, r2 #) = readWord64OffAddr# addr n2 s2 !(# s4, r3 #) = readWord64OffAddr# addr n3 s3 !(# s5, r4 #) = readWord64OffAddr# addr n4 s4 in (# s5, Word256 (W64# r1) (W64# r2) (W64# r3) (W64# r4) #) where (# n1, n2, n3, n4 #) = offset256_64 n {-# INLINE primAddrRead #-} primAddrWrite addr n (Word256 (W64# w1) (W64# w2) (W64# w3) (W64# w4)) = primitive $ \s1 -> let !s2 = writeWord64OffAddr# addr n1 w1 s1 !s3 = writeWord64OffAddr# addr n2 w2 s2 !s4 = writeWord64OffAddr# addr n3 w3 s3 in (# writeWord64OffAddr# addr n4 w4 s4, () #) where (# n1, n2, n3, n4 #) = offset256_64 n {-# INLINE primAddrWrite #-} instance PrimType Int8 where primSizeInBytes _ = CountOf 1 {-# INLINE primSizeInBytes #-} 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 Word128 where instance PrimMemoryComparable Word256 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 offset128_64 :: Offset Word128 -> (# Int#, Int# #) offset128_64 (Offset (I# i)) = (# n , n +# 1# #) where !n = uncheckedIShiftL# i 1# offset256_64 :: Offset Word256 -> (# Int#, Int#, Int#, Int# #) offset256_64 (Offset (I# i)) = (# n , n +# 1#, n +# 2#, n +# 3# #) where !n = uncheckedIShiftL# i 2# -- | Cast a CountOf linked to type A (CountOf A) to a CountOf linked to type B (CountOf B) sizeRecast :: forall a b . (PrimType a, PrimType b) => CountOf a -> CountOf b sizeRecast sz = CountOf (bytes `Prelude.quot` szB) where !szA = primSizeInBytes (Proxy :: Proxy a) !(CountOf szB) = primSizeInBytes (Proxy :: Proxy b) !(CountOf bytes) = sizeOfE szA sz {-# INLINE [1] sizeRecast #-} {-# RULES "sizeRecast from Word8" [2] forall a . sizeRecast a = sizeRecastBytes a #-} sizeRecastBytes :: forall b . PrimType b => CountOf Word8 -> CountOf b sizeRecastBytes (CountOf w) = CountOf (w `Prelude.quot` szB) where !(CountOf szB) = primSizeInBytes (Proxy :: Proxy b) {-# INLINE [1] sizeRecastBytes #-} sizeInBytes :: forall a . PrimType a => CountOf a -> CountOf Word8 sizeInBytes sz = sizeOfE (primSizeInBytes (Proxy :: Proxy a)) sz offsetInBytes :: forall a . PrimType a => Offset a -> Offset Word8 offsetInBytes ofs = offsetShiftL (primShiftToBytes (Proxy :: Proxy a)) ofs {-# INLINE [2] offsetInBytes #-} {-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word64 -> Offset Word8 #-} {-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word32 -> Offset Word8 #-} {-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word16 -> Offset Word8 #-} {-# RULES "offsetInBytes Bytes" [3] forall x . offsetInBytes x = x #-} offsetInElements :: forall a . PrimType a => Offset Word8 -> Offset a offsetInElements ofs = offsetShiftR (primShiftToBytes (Proxy :: Proxy a)) ofs {-# INLINE [2] offsetInElements #-} {-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word64 -> Offset Word8 #-} {-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word32 -> Offset Word8 #-} {-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word16 -> Offset Word8 #-} {-# RULES "offsetInElements Bytes" [3] forall x . offsetInElements x = x #-} primOffsetRecast :: forall a b . (PrimType a, PrimType b) => Offset a -> Offset b primOffsetRecast !ofs = let !(Offset bytes) = offsetOfE szA ofs in Offset (bytes `Prelude.quot` szB) where !szA = primSizeInBytes (Proxy :: Proxy a) !(CountOf szB) = primSizeInBytes (Proxy :: Proxy b) {-# INLINE [1] primOffsetRecast #-} {-# RULES "primOffsetRecast W8" [3] forall a . primOffsetRecast a = primOffsetRecastBytes a #-} offsetIsAligned :: forall a . PrimType a => Proxy a -> Offset Word8 -> Bool offsetIsAligned _ (Offset ofs) = (ofs .&. mask) == 0 where (CountOf sz) = primSizeInBytes (Proxy :: Proxy a) mask = sz - 1 {-# INLINE [1] offsetIsAligned #-} {-# SPECIALIZE [3] offsetIsAligned :: Proxy Word64 -> Offset Word8 -> Bool #-} {-# RULES "offsetInAligned Bytes" [3] forall (prx :: Proxy Word8) x . offsetIsAligned prx x = True #-} primOffsetRecastBytes :: forall b . PrimType b => Offset Word8 -> Offset b primOffsetRecastBytes (Offset 0) = Offset 0 primOffsetRecastBytes (Offset o) = Offset (szA `Prelude.quot` o) where !(CountOf szA) = primSizeInBytes (Proxy :: Proxy b) {-# INLINE [1] primOffsetRecastBytes #-} primOffsetOfE :: forall a . PrimType a => Offset a -> Offset Word8 primOffsetOfE = offsetInBytes {-# DEPRECATED primOffsetOfE "use offsetInBytes" #-} primWordGetByteAndShift :: Word# -> (# Word#, Word# #) primWordGetByteAndShift w = (# and# w 0xff##, uncheckedShiftRL# w 8# #) {-# INLINE primWordGetByteAndShift #-} #if WORD_SIZE_IN_BITS == 64 primWord64GetByteAndShift :: Word# -> (# Word#, Word# #) primWord64GetByteAndShift = primWord64GetByteAndShift primWord64GetHiLo :: Word# -> (# Word#, Word# #) primWord64GetHiLo w = (# uncheckedShiftRL# w 32# , and# w 0xffffffff## #) #else primWord64GetByteAndShift :: Word64# -> (# Word#, Word64# #) primWord64GetByteAndShift w = (# and# (word64ToWord# w) 0xff##, uncheckedShiftRL64# w 8# #) primWord64GetHiLo :: Word64# -> (# Word#, Word# #) primWord64GetHiLo w = (# word64ToWord# (uncheckedShiftRL64# w 32#), word64ToWord# w #) #endif {-# INLINE primWord64GetByteAndShift #-} basement-0.0.4/Basement/Exception.hs0000644000000000000000000000431413141321320015517 0ustar0000000000000000-- | -- 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 basement-0.0.4/Basement/From.hs0000644000000000000000000002254513172057505014511 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UndecidableInstances #-} -- | -- Module : Basement.From -- License : BSD-style -- Maintainer : Haskell Foundation -- -- Flexible Type convertion -- -- From is multi parameter type class that allow converting -- from a to b. -- -- Only type that are valid to convert to another type -- should be From instance; otherwise TryFrom should be used. -- -- Into (resp TryInto) allows the contrary instances to be able -- to specify the destination type before the source. This is -- practical with TypeApplication module Basement.From ( From(..) , Into , TryFrom(..) , TryInto , into , tryInto ) where import Basement.Compat.Base -- basic instances import GHC.Types import GHC.Prim import GHC.Int import GHC.Word import Basement.Numerical.Number import Basement.Numerical.Conversion import qualified Basement.Block as Block import qualified Basement.BoxedArray as BoxArray import qualified Basement.UArray as UArray import qualified Basement.String as String import qualified Basement.Types.AsciiString as AsciiString import Basement.Types.Word128 (Word128(..)) import Basement.Types.Word256 (Word256(..)) import qualified Basement.Types.Word128 as Word128 import qualified Basement.Types.Word256 as Word256 import Basement.These import Basement.PrimType (PrimType) import Basement.Types.OffsetSize import Basement.Compat.Natural import qualified Prelude (fromIntegral) -- nat instances #if __GLASGOW_HASKELL__ >= 800 import Basement.Nat import qualified Basement.Sized.Block as BlockN import Basement.Bounded #endif -- | Class of things that can be converted from a to b. -- -- In a valid instance, the source should be always representable by the destination, -- otherwise the instance should be using 'TryFrom' class From a b where from :: a -> b 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 -- Simple numerical instances instance From Int Word where from (I# i) = W# (int2Word# i) instance From Word Int where from (W# w) = I# (word2Int# w) instance IsNatural n => From n Natural where from = toNatural instance IsIntegral n => From n Integer where from = toInteger instance From Int8 Int16 where from (I8# i) = I16# i instance From Int8 Int32 where from (I8# i) = I32# i instance From Int8 Int64 where from (I8# i) = intToInt64 (I# i) instance From Int8 Int where from (I8# i) = I# i instance From Int16 Int32 where from (I16# i) = I32# i instance From Int16 Int64 where from (I16# i) = intToInt64 (I# i) instance From Int16 Int where from (I16# i) = I# i instance From Int32 Int64 where from (I32# i) = intToInt64 (I# i) instance From Int32 Int where from (I32# i) = I# i instance From Int Int64 where from = intToInt64 instance From Word8 Word16 where from (W8# i) = W16# i instance From Word8 Word32 where from (W8# i) = W32# i instance From Word8 Word64 where from (W8# i) = wordToWord64 (W# i) instance From Word8 Word128 where from (W8# i) = Word128 0 (wordToWord64 $ W# i) instance From Word8 Word256 where from (W8# i) = Word256 0 0 0 (wordToWord64 $ W# i) instance From Word8 Word where from (W8# i) = W# i instance From Word8 Int16 where from (W8# w) = I16# (word2Int# w) instance From Word8 Int32 where from (W8# w) = I32# (word2Int# w) instance From Word8 Int64 where from (W8# w) = intToInt64 (I# (word2Int# w)) instance From Word8 Int where from (W8# w) = I# (word2Int# w) instance From Word16 Word32 where from (W16# i) = W32# i instance From Word16 Word64 where from (W16# i) = wordToWord64 (W# i) instance From Word16 Word128 where from (W16# i) = Word128 0 (wordToWord64 $ W# i) instance From Word16 Word256 where from (W16# i) = Word256 0 0 0 (wordToWord64 $ W# i) instance From Word16 Word where from (W16# i) = W# i instance From Word32 Word64 where from (W32# i) = wordToWord64 (W# i) instance From Word32 Word128 where from (W32# i) = Word128 0 (wordToWord64 $ W# i) instance From Word32 Word256 where from (W32# i) = Word256 0 0 0 (wordToWord64 $ W# i) instance From Word32 Word where from (W32# i) = W# i instance From Word64 Word128 where from w = Word128 0 w instance From Word64 Word256 where from w = Word256 0 0 0 w instance From Word Word64 where from = wordToWord64 -- Simple prelude types instance From (Maybe a) (Either () a) where from (Just x) = Right x from Nothing = Left () -- basic basement types instance From (CountOf ty) Int where from (CountOf n) = n instance From (CountOf ty) Word where from (CountOf n) = from n instance From (Either a b) (These a b) where from (Left a) = This a from (Right b) = That b -- basement instances -- uarrays instance PrimType ty => From (Block.Block ty) (UArray.UArray ty) where from = UArray.fromBlock instance PrimType ty => From (BoxArray.Array ty) (UArray.UArray ty) where from = BoxArray.mapToUnboxed id -- blocks instance PrimType ty => From (UArray.UArray ty) (Block.Block ty) where from = UArray.toBlock instance PrimType ty => From (BoxArray.Array ty) (Block.Block ty) where from = UArray.toBlock . BoxArray.mapToUnboxed id -- boxed array instance PrimType ty => From (UArray.UArray ty) (BoxArray.Array ty) where from = BoxArray.mapFromUnboxed id instance From String.String (UArray.UArray Word8) where from = String.toBytes String.UTF8 instance From AsciiString.AsciiString String.String where from = String.fromBytesUnsafe . UArray.unsafeRecast . AsciiString.toBytes instance From AsciiString.AsciiString (UArray.UArray Word8) where from = UArray.unsafeRecast . AsciiString.toBytes instance TryFrom (UArray.UArray Word8) String.String where tryFrom arr = case String.fromBytes String.UTF8 arr of (s, Nothing, _) -> Just s (_, Just _, _) -> Nothing #if __GLASGOW_HASKELL__ >= 800 instance From (BlockN.BlockN n ty) (Block.Block ty) where from = BlockN.toBlock instance (NatWithinBound Int n, PrimType ty) => From (BlockN.BlockN n ty) (UArray.UArray ty) where from = UArray.fromBlock . BlockN.toBlock instance (NatWithinBound Int n, PrimType ty) => From (BlockN.BlockN n ty) (BoxArray.Array ty) where from = BoxArray.mapFromUnboxed id . UArray.fromBlock . BlockN.toBlock instance (NatWithinBound (CountOf ty) n, KnownNat n, PrimType ty) => TryFrom (Block.Block ty) (BlockN.BlockN n ty) where tryFrom = BlockN.toBlockN instance (NatWithinBound (CountOf ty) n, KnownNat n, PrimType ty) => TryFrom (UArray.UArray ty) (BlockN.BlockN n ty) where tryFrom = BlockN.toBlockN . UArray.toBlock instance (NatWithinBound (CountOf ty) n, KnownNat n, PrimType ty) => TryFrom (BoxArray.Array ty) (BlockN.BlockN n ty) where tryFrom = BlockN.toBlockN . UArray.toBlock . BoxArray.mapToUnboxed id instance (KnownNat n, NatWithinBound Word8 n) => From (Zn64 n) Word8 where from = narrow . unZn64 where narrow (W64# w) = W8# (narrow8Word# (word64ToWord# w)) instance (KnownNat n, NatWithinBound Word16 n) => From (Zn64 n) Word16 where from = narrow . unZn64 where narrow (W64# w) = W16# (narrow16Word# (word64ToWord# w)) instance (KnownNat n, NatWithinBound Word32 n) => From (Zn64 n) Word32 where from = narrow . unZn64 where narrow (W64# w) = W32# (narrow32Word# (word64ToWord# w)) instance From (Zn64 n) Word64 where from = unZn64 instance From (Zn64 n) Word128 where from = from . unZn64 instance From (Zn64 n) Word256 where from = from . unZn64 instance (KnownNat n, NatWithinBound Word8 n) => From (Zn n) Word8 where from = narrow . naturalToWord64 . unZn where narrow (W64# w) = W8# (narrow8Word# (word64ToWord# w)) instance (KnownNat n, NatWithinBound Word16 n) => From (Zn n) Word16 where from = narrow . naturalToWord64 . unZn where narrow (W64# w) = W16# (narrow16Word# (word64ToWord# w)) instance (KnownNat n, NatWithinBound Word32 n) => From (Zn n) Word32 where from = narrow . naturalToWord64 . unZn where narrow (W64# w) = W32# (narrow32Word# (word64ToWord# w)) instance (KnownNat n, NatWithinBound Word64 n) => From (Zn n) Word64 where from = naturalToWord64 . unZn instance (KnownNat n, NatWithinBound Word128 n) => From (Zn n) Word128 where from = Word128.fromNatural . unZn instance (KnownNat n, NatWithinBound Word256 n) => From (Zn n) Word256 where from = Word256.fromNatural . unZn instance (KnownNat n, NatWithinBound Word64 n) => From (Zn n) (Zn64 n) where from = zn64 . naturalToWord64 . unZn instance KnownNat n => From (Zn64 n) (Zn n) where from = zn . from . unZn64 naturalToWord64 :: Natural -> Word64 naturalToWord64 = Prelude.fromIntegral #endif basement-0.0.4/Basement/Types/Char7.hs0000644000000000000000000000411213150274334015641 0ustar0000000000000000{-# LANGUAGE MagicHash #-} module Basement.Types.Char7 ( Char7(..) , toChar , fromCharMask , fromChar , fromByteMask , fromByte -- * individual ASCII Characters , c7_LF , c7_CR , c7_minus , c7_a , c7_A , c7_z , c7_Z , c7_0 , c7_1 , c7_2 , c7_3 , c7_4 , c7_5 , c7_6 , c7_7 , c7_8 , c7_9 ) where import GHC.Prim import GHC.Word import GHC.Types import Data.Bits import Data.Maybe import Basement.Compat.Base import Basement.Compat.Primitive (bool#) -- | ASCII value between 0x0 and 0x7f newtype Char7 = Char7 { toByte :: Word8 } deriving (Show,Eq,Ord,Typeable) -- | Convert a 'Char7' to a unicode code point 'Char' toChar :: Char7 -> Char toChar !(Char7 (W8# w)) = C# (chr# (word2Int# w)) -- | Try to convert a 'Char' to a 'Char7' -- -- If the code point is non ascii, then Nothing is returned. fromChar :: Char -> Maybe Char7 fromChar !(C# c#) | bool# (ltChar# c# (chr# 0x80#)) = Just $ Char7 $ W8# (int2Word# (ord# c#)) | otherwise = Nothing -- | Try to convert 'Word8' to a 'Char7' -- -- If the byte got higher bit set, then Nothing is returned. fromByte :: Word8 -> Maybe Char7 fromByte !w | (w .&. 0x80) == 0 = Just $ Char7 w | otherwise = Nothing -- | Convert a 'Char' to a 'Char7' ignoring all higher bits fromCharMask :: Char -> Char7 fromCharMask !(C# c#) = Char7 $ W8# (and# (int2Word# (ord# c#)) 0x7f##) -- | Convert a 'Byte' to a 'Char7' ignoring the higher bit fromByteMask :: Word8 -> Char7 fromByteMask !(W8# w#) = Char7 $ W8# (and# w# 0x7f##) c7_LF :: Char7 c7_LF = Char7 0xa c7_CR :: Char7 c7_CR = Char7 0xd c7_minus :: Char7 c7_minus = Char7 0x2d c7_a :: Char7 c7_a = Char7 0x61 c7_A :: Char7 c7_A = Char7 0x41 c7_z :: Char7 c7_z = Char7 0x7a c7_Z :: Char7 c7_Z = Char7 0x5a c7_0, c7_1, c7_2, c7_3, c7_4, c7_5, c7_6, c7_7, c7_8, c7_9 :: Char7 c7_0 = Char7 0x30 c7_1 = Char7 0x31 c7_2 = Char7 0x32 c7_3 = Char7 0x33 c7_4 = Char7 0x34 c7_5 = Char7 0x35 c7_6 = Char7 0x36 c7_7 = Char7 0x37 c7_8 = Char7 0x38 c7_9 = Char7 0x39 basement-0.0.4/Basement/Types/OffsetSize.hs0000644000000000000000000002044013201544137016756 0ustar0000000000000000-- | -- Module : Basement.Types.OffsetSize -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : portable -- {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-} {-# OPTIONS_GHC -fno-prof-auto #-} 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 , Countable , Offsetable , natValCountOf , natValOffset ) 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 Basement.Compat.Semigroup import Data.Proxy import Basement.Numerical.Number import Basement.Numerical.Additive import Basement.Numerical.Subtractive import Basement.Numerical.Multiplicative import Basement.Nat 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 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 Semigroup (CountOf ty) where (<>) = (+) 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 natValCountOf :: forall n ty proxy . (KnownNat n, NatWithinBound (CountOf ty) n) => proxy n -> CountOf ty natValCountOf n = CountOf $ Prelude.fromIntegral (natVal n) natValOffset :: forall n ty proxy . (KnownNat n, NatWithinBound (Offset ty) n) => proxy n -> Offset ty natValOffset n = Offset $ Prelude.fromIntegral (natVal n) type instance NatNumMaxBound (CountOf x) = NatNumMaxBound Int type instance NatNumMaxBound (Offset x) = NatNumMaxBound Int type Countable ty n = NatWithinBound (CountOf ty) n type Offsetable ty n = NatWithinBound (Offset ty) n basement-0.0.4/Basement/Types/Ptr.hs0000644000000000000000000000202313141321320015425 0ustar0000000000000000{-# LANGUAGE MagicHash #-} module Basement.Types.Ptr ( Addr(..) , addrPlus , addrPlusSz , addrPlusCSz , Ptr(..) , ptrPlus , ptrPlusSz , ptrPlusCSz , castPtr ) where import Basement.Compat.Base import Basement.Types.OffsetSize import GHC.Ptr import GHC.Prim import GHC.Types import Foreign.C.Types data Addr = Addr Addr# deriving (Eq,Ord) addrPlus :: Addr -> Offset Word8 -> Addr addrPlus (Addr addr) (Offset (I# i)) = Addr (plusAddr# addr i) addrPlusSz :: Addr -> CountOf Word8 -> Addr addrPlusSz (Addr addr) (CountOf (I# i)) = Addr (plusAddr# addr i) addrPlusCSz :: Addr -> CSize -> Addr addrPlusCSz addr = addrPlusSz addr . sizeOfCSize ptrPlus :: Ptr a -> Offset Word8 -> Ptr a ptrPlus (Ptr addr) (Offset (I# i)) = Ptr (plusAddr# addr i) ptrPlusSz :: Ptr a -> CountOf Word8 -> Ptr a ptrPlusSz (Ptr addr) (CountOf (I# i)) = Ptr (plusAddr# addr i) ptrPlusCSz :: Ptr a -> CSize -> Ptr a ptrPlusCSz ptr = ptrPlusSz ptr . sizeOfCSize basement-0.0.4/Basement/Types/AsciiString.hs0000644000000000000000000000425013175306665017131 0ustar0000000000000000-- | -- 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.Compat.Semigroup 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, Semigroup, Monoid, Eq, Ord) newtype MutableAsciiString st = MutableAsciiString (MUArray Char7 st) deriving (Typeable) instance Show AsciiString where show = fmap Char7.toChar . toList instance IsString AsciiString where fromString = fromList . fmap Char7.fromCharMask instance IsList AsciiString where type Item AsciiString = Char7 fromList = AsciiString . fromList toList (AsciiString chars) = toList chars -- | Convert a Byte Array representing ASCII data directly to an AsciiString without checking for ASCII validity -- -- If the input contains invalid Char7 value (anything above 0x7f), -- it will trigger runtime async errors when processing data. -- -- In doubt, use 'fromBytes' fromBytesUnsafe :: UArray Word8 -> AsciiString fromBytesUnsafe = AsciiString . A.unsafeRecast -- | Convert a Byte Array representing ASCII checking validity. -- -- If the byte array is not valid, then Nothing is returned fromBytes :: UArray Word8 -> Maybe AsciiString fromBytes arr | A.all (\x -> x < 0x80) arr = Just $ AsciiString $ A.unsafeRecast arr | otherwise = Nothing basement-0.0.4/Basement/Types/Word128.hs0000644000000000000000000001636713162720757016072 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} module Basement.Types.Word128 ( Word128(..) , (+) , (-) , (*) , quot , rem , bitwiseAnd , bitwiseOr , bitwiseXor , fromNatural ) where import GHC.Prim import GHC.Word import GHC.Types import qualified Prelude (fromInteger, show, Num(..), quot, rem, mod) import Data.Bits hiding (complement, popCount, bit, testBit , rotateL, rotateR, shiftL, shiftR) import qualified Data.Bits as Bits import Data.Function (on) import Foreign.C import Foreign.Ptr import Foreign.Storable import Basement.Compat.Base import Basement.Compat.Natural import Basement.Compat.Primitive (bool#) import Basement.Numerical.Conversion import Basement.Numerical.Number #include "MachDeps.h" -- | 128 bits Word data Word128 = Word128 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 deriving (Eq) instance Show Word128 where show w = Prelude.show (toNatural w) instance Enum Word128 where toEnum i = Word128 0 $ int64ToWord64 (intToInt64 i) fromEnum (Word128 _ a0) = wordToInt (word64ToWord a0) succ (Word128 a1 a0) | a0 == maxBound = Word128 (succ a1) 0 | otherwise = Word128 a1 (succ a0) pred (Word128 a1 a0) | a0 == minBound = Word128 (pred a1) maxBound | otherwise = Word128 a1 (pred a0) instance Bounded Word128 where minBound = Word128 minBound minBound maxBound = Word128 maxBound maxBound instance Ord Word128 where compare (Word128 a1 a0) (Word128 b1 b0) = case compare a1 b1 of EQ -> compare a0 b0 r -> r (<) (Word128 a1 a0) (Word128 b1 b0) = case compare a1 b1 of EQ -> a0 < b0 r -> r == LT (<=) (Word128 a1 a0) (Word128 b1 b0) = case compare a1 b1 of EQ -> a0 <= b0 r -> r == LT instance Storable Word128 where sizeOf _ = 16 alignment _ = 16 peek p = Word128 <$> peek (castPtr p ) <*> peek (castPtr p `plusPtr` 8) poke p (Word128 a1 a0) = do poke (castPtr p ) a1 poke (castPtr p `plusPtr` 8) a0 instance Integral Word128 where fromInteger = literal instance HasNegation Word128 where negate = complement instance IsIntegral Word128 where toInteger (Word128 a1 a0) = (toInteger a1 `unsafeShiftL` 64) .|. toInteger a0 instance IsNatural Word128 where toNatural (Word128 a1 a0) = (toNatural a1 `unsafeShiftL` 64) .|. toNatural a0 instance Prelude.Num Word128 where abs w = w signum w@(Word128 a1 a0) | a1 == 0 && a0 == 0 = w | otherwise = Word128 0 1 fromInteger = literal (+) = (+) (-) = (-) (*) = (*) instance Bits.Bits Word128 where (.&.) = bitwiseAnd (.|.) = bitwiseOr xor = bitwiseXor complement = complement shiftL = shiftL shiftR = shiftR rotateL = rotateL rotateR = rotateR bitSize _ = 128 bitSizeMaybe _ = Just 128 isSigned _ = False testBit = testBit bit = bit popCount = popCount -- | Add 2 Word128 (+) :: Word128 -> Word128 -> Word128 #if WORD_SIZE_IN_BITS < 64 (+) = applyBiWordOnNatural (Prelude.+) #else (+) (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) = Word128 (W64# s1) (W64# s0) where !(# carry, s0 #) = plusWord2# a0 b0 s1 = plusWord# (plusWord# a1 b1) carry #endif -- temporary available until native operation available applyBiWordOnNatural :: (Natural -> Natural -> Natural) -> Word128 -> Word128 -> Word128 applyBiWordOnNatural f = (fromNatural .) . (f `on` toNatural) -- | Subtract 2 Word128 (-) :: Word128 -> Word128 -> Word128 (-) a b | a >= b = applyBiWordOnNatural (Prelude.-) a b | otherwise = complement $ applyBiWordOnNatural (Prelude.-) b a -- | Multiplication (*) :: Word128 -> Word128 -> Word128 (*) = applyBiWordOnNatural (Prelude.*) -- | Division quot :: Word128 -> Word128 -> Word128 quot = applyBiWordOnNatural Prelude.quot -- | Modulo rem :: Word128 -> Word128 -> Word128 rem = applyBiWordOnNatural Prelude.rem -- | Bitwise and bitwiseAnd :: Word128 -> Word128 -> Word128 bitwiseAnd (Word128 a1 a0) (Word128 b1 b0) = Word128 (a1 .&. b1) (a0 .&. b0) -- | Bitwise or bitwiseOr :: Word128 -> Word128 -> Word128 bitwiseOr (Word128 a1 a0) (Word128 b1 b0) = Word128 (a1 .|. b1) (a0 .|. b0) -- | Bitwise xor bitwiseXor :: Word128 -> Word128 -> Word128 bitwiseXor (Word128 a1 a0) (Word128 b1 b0) = Word128 (a1 `Bits.xor` b1) (a0 `Bits.xor` b0) -- | Bitwise complement complement :: Word128 -> Word128 complement (Word128 a1 a0) = Word128 (Bits.complement a1) (Bits.complement a0) -- | Population count popCount :: Word128 -> Int popCount (Word128 a1 a0) = Bits.popCount a1 Prelude.+ Bits.popCount a0 -- | Bitwise Shift Left shiftL :: Word128 -> Int -> Word128 shiftL w@(Word128 a1 a0) n | n < 0 || n > 127 = Word128 0 0 | n == 64 = Word128 a0 0 | n == 0 = w | n > 64 = Word128 (a0 `Bits.unsafeShiftL` (n Prelude.- 64)) 0 | otherwise = Word128 ((a1 `Bits.unsafeShiftL` n) .|. (a0 `Bits.unsafeShiftR` (64 Prelude.- n))) (a0 `Bits.unsafeShiftL` n) -- | Bitwise Shift Right shiftR :: Word128 -> Int -> Word128 shiftR w@(Word128 a1 a0) n | n < 0 || n > 127 = Word128 0 0 | n == 64 = Word128 0 a1 | n == 0 = w | n > 64 = Word128 0 (a1 `Bits.unsafeShiftR` (n Prelude.- 64)) | otherwise = Word128 (a1 `Bits.unsafeShiftR` n) ((a1 `Bits.unsafeShiftL` (inv64 n)) .|. (a0 `Bits.unsafeShiftR` n)) -- | Bitwise rotate Left rotateL :: Word128 -> Int -> Word128 rotateL (Word128 a1 a0) n' | n == 0 = Word128 a1 a0 | n == 64 = Word128 a0 a1 | n < 64 = Word128 (comb64 a1 n a0 (inv64 n)) (comb64 a0 n a1 (inv64 n)) | otherwise = let n = n Prelude.- 64 in Word128 (comb64 a0 n a1 (inv64 n)) (comb64 a1 n a0 (inv64 n)) where n :: Int n | n' >= 0 = n' `Prelude.mod` 128 | otherwise = 128 Prelude.- (n' `Prelude.mod` 128) -- | Bitwise rotate Left rotateR :: Word128 -> Int -> Word128 rotateR w n = rotateL w (128 Prelude.- n) inv64 :: Int -> Int inv64 i = 64 Prelude.- i comb64 :: Word64 -> Int -> Word64 -> Int -> Word64 comb64 x i y j = (x `Bits.unsafeShiftL` i) .|. (y `Bits.unsafeShiftR` j) -- | Test bit testBit :: Word128 -> Int -> Bool testBit (Word128 a1 a0) n | n < 0 || n > 127 = False | n > 63 = Bits.testBit a1 (n Prelude.- 64) | otherwise = Bits.testBit a0 n -- | bit bit :: Int -> Word128 bit n | n < 0 || n > 127 = Word128 0 0 | n > 63 = Word128 (Bits.bit (n Prelude.- 64)) 0 | otherwise = Word128 0 (Bits.bit n) literal :: Integer -> Word128 literal i = Word128 (Prelude.fromInteger (i `Bits.unsafeShiftR` 64)) (Prelude.fromInteger i) fromNatural :: Natural -> Word128 fromNatural n = Word128 (Prelude.fromInteger (naturalToInteger n `Bits.unsafeShiftR` 64)) (Prelude.fromInteger $ naturalToInteger n) basement-0.0.4/Basement/Types/Word256.hs0000644000000000000000000002633613162720757016071 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} module Basement.Types.Word256 ( Word256(..) , (+) , (-) , (*) , quot , rem , bitwiseAnd , bitwiseOr , bitwiseXor , fromNatural ) where import GHC.Prim import GHC.Word import GHC.Types import qualified Prelude (fromInteger, show, Num(..), quot, rem, mod) import Data.Bits hiding (complement, popCount, bit, testBit , rotateL, rotateR, shiftL, shiftR) import qualified Data.Bits as Bits import Data.Function (on) import Foreign.C import Foreign.Ptr import Foreign.Storable import Basement.Compat.Base import Basement.Compat.Natural import Basement.Compat.Primitive (bool#) import Basement.Numerical.Conversion import Basement.Numerical.Number #include "MachDeps.h" -- | 256 bits Word data Word256 = Word256 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 deriving (Eq) instance Show Word256 where show w = Prelude.show (toNatural w) instance Enum Word256 where toEnum i = Word256 0 0 0 $ int64ToWord64 (intToInt64 i) fromEnum (Word256 _ _ _ a0) = wordToInt (word64ToWord a0) succ (Word256 a3 a2 a1 a0) | a0 == maxBound = if a1 == maxBound then if a2 == maxBound then Word256 (succ a3) 0 0 0 else Word256 a3 (succ a2) 0 0 else Word256 a3 a2 (succ a1) 0 | otherwise = Word256 a3 a2 a1 (succ a0) pred (Word256 a3 a2 a1 a0) | a0 == minBound = if a1 == minBound then if a2 == minBound then Word256 (pred a3) maxBound maxBound maxBound else Word256 a3 (pred a2) maxBound maxBound else Word256 a3 a2 (pred a1) maxBound | otherwise = Word256 a3 a2 a1 (pred a0) instance Bounded Word256 where minBound = Word256 minBound minBound minBound minBound maxBound = Word256 maxBound maxBound maxBound maxBound instance Ord Word256 where compare (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) = compareEq a3 b3 $ compareEq a2 b2 $ compareEq a1 b1 $ compare a0 b0 where compareEq x y next = case compare x y of EQ -> next r -> r (<) (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) = compareLt a3 b3 $ compareLt a2 b2 $ compareLt a1 b1 (a0 < b0) where compareLt x y next = case compare x y of EQ -> next r -> r == LT instance Storable Word256 where sizeOf _ = 32 alignment _ = 32 peek p = Word256 <$> peek (castPtr p ) <*> peek (castPtr p `plusPtr` 8) <*> peek (castPtr p `plusPtr` 16) <*> peek (castPtr p `plusPtr` 24) poke p (Word256 a3 a2 a1 a0) = do poke (castPtr p ) a3 poke (castPtr p `plusPtr` 8 ) a2 poke (castPtr p `plusPtr` 16) a1 poke (castPtr p `plusPtr` 24) a0 instance Integral Word256 where fromInteger = literal instance HasNegation Word256 where negate = complement instance IsIntegral Word256 where toInteger (Word256 a3 a2 a1 a0) = (toInteger a3 `Bits.unsafeShiftL` 192) Bits..|. (toInteger a2 `Bits.unsafeShiftL` 128) Bits..|. (toInteger a1 `Bits.unsafeShiftL` 64) Bits..|. toInteger a0 instance IsNatural Word256 where toNatural (Word256 a3 a2 a1 a0) = (toNatural a3 `Bits.unsafeShiftL` 192) Bits..|. (toNatural a2 `Bits.unsafeShiftL` 128) Bits..|. (toNatural a1 `Bits.unsafeShiftL` 64) Bits..|. toNatural a0 instance Prelude.Num Word256 where abs w = w signum w@(Word256 a3 a2 a1 a0) | a3 == 0 && a2 == 0 && a1 == 0 && a0 == 0 = w | otherwise = Word256 0 0 0 1 fromInteger = literal (+) = (+) (-) = (-) (*) = (*) instance Bits.Bits Word256 where (.&.) = bitwiseAnd (.|.) = bitwiseOr xor = bitwiseXor complement = complement shiftL = shiftL shiftR = shiftR rotateL = rotateL rotateR = rotateR bitSize _ = 256 bitSizeMaybe _ = Just 256 isSigned _ = False testBit = testBit bit = bit popCount = popCount -- | Add 2 Word256 (+) :: Word256 -> Word256 -> Word256 #if WORD_SIZE_IN_BITS < 64 (+) = applyBiWordOnNatural (Prelude.+) #else (+) (Word256 (W64# a3) (W64# a2) (W64# a1) (W64# a0)) (Word256 (W64# b3) (W64# b2) (W64# b1) (W64# b0)) = Word256 (W64# s3) (W64# s2) (W64# s1) (W64# s0) where !(# c0, s0 #) = plusWord2# a0 b0 !(# c1, s1 #) = plusWord3# a1 b1 c0 !(# c2, s2 #) = plusWord3# a2 b2 c1 !s3 = plusWord3NoCarry# a3 b3 c2 plusWord3NoCarry# a b c = plusWord# (plusWord# a b) c plusWord3# a b c | bool# (eqWord# carry 0##) = plusWord2# x c | otherwise = case plusWord2# x c of (# carry2, x' #) | bool# (eqWord# carry2 0##) -> (# carry, x' #) | otherwise -> (# plusWord# carry carry2, x' #) where (# carry, x #) = plusWord2# a b #endif -- temporary available until native operation available applyBiWordOnNatural :: (Natural -> Natural -> Natural) -> Word256 -> Word256 -> Word256 applyBiWordOnNatural f = (fromNatural .) . (f `on` toNatural) -- | Subtract 2 Word256 (-) :: Word256 -> Word256 -> Word256 (-) a b | a >= b = applyBiWordOnNatural (Prelude.-) a b | otherwise = complement $ applyBiWordOnNatural (Prelude.-) b a -- | Multiplication (*) :: Word256 -> Word256 -> Word256 (*) = applyBiWordOnNatural (Prelude.*) -- | Division quot :: Word256 -> Word256 -> Word256 quot = applyBiWordOnNatural Prelude.quot -- | Modulo rem :: Word256 -> Word256 -> Word256 rem = applyBiWordOnNatural Prelude.rem -- | Bitwise and bitwiseAnd :: Word256 -> Word256 -> Word256 bitwiseAnd (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) = Word256 (a3 Bits..&. b3) (a2 Bits..&. b2) (a1 Bits..&. b1) (a0 Bits..&. b0) -- | Bitwise or bitwiseOr :: Word256 -> Word256 -> Word256 bitwiseOr (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) = Word256 (a3 Bits..|. b3) (a2 Bits..|. b2) (a1 Bits..|. b1) (a0 Bits..|. b0) -- | Bitwise xor bitwiseXor :: Word256 -> Word256 -> Word256 bitwiseXor (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) = Word256 (a3 `Bits.xor` b3) (a2 `Bits.xor` b2) (a1 `Bits.xor` b1) (a0 `Bits.xor` b0) -- | Bitwise complement complement :: Word256 -> Word256 complement (Word256 a3 a2 a1 a0) = Word256 (Bits.complement a3) (Bits.complement a2) (Bits.complement a1) (Bits.complement a0) -- | Population count popCount :: Word256 -> Int popCount (Word256 a3 a2 a1 a0) = Bits.popCount a3 Prelude.+ Bits.popCount a2 Prelude.+ Bits.popCount a1 Prelude.+ Bits.popCount a0 -- | Bitwise Shift Left shiftL :: Word256 -> Int -> Word256 shiftL w@(Word256 a3 a2 a1 a0) n | n < 0 || n > 255 = Word256 0 0 0 0 | n == 0 = w | n == 64 = Word256 a2 a1 a0 0 | n == 128 = Word256 a1 a0 0 0 | n == 192 = Word256 a0 0 0 0 | n < 64 = mkWordShift a3 a2 a1 a0 n | n < 128 = mkWordShift a2 a1 a0 0 (n Prelude.- 64) | n < 192 = mkWordShift a1 a0 0 0 (n Prelude.- 128) | otherwise = mkWordShift a0 0 0 0 (n Prelude.- 192) where mkWordShift :: Word64 -> Word64 -> Word64 -> Word64 -> Int -> Word256 mkWordShift w x y z s = Word256 (comb64 w s x s') (comb64 x s y s') (comb64 y s z s') (z `Bits.unsafeShiftL` s) where s' = inv64 s -- | Bitwise Shift Right shiftR :: Word256 -> Int -> Word256 shiftR w@(Word256 a3 a2 a1 a0) n | n < 0 || n > 255 = Word256 0 0 0 0 | n == 0 = w | n == 64 = Word256 0 a3 a2 a1 | n == 128 = Word256 0 0 a3 a2 | n == 192 = Word256 0 0 0 a3 | n < 64 = mkWordShift a3 a2 a1 a0 n | n < 128 = mkWordShift 0 a3 a2 a1 (n Prelude.- 64) | n < 192 = mkWordShift 0 0 a3 a2 (n Prelude.- 128) | otherwise = Word256 0 0 0 (a3 `Bits.unsafeShiftR` (n Prelude.- 192)) where mkWordShift :: Word64 -> Word64 -> Word64 -> Word64 -> Int -> Word256 mkWordShift w x y z s = Word256 (w `Bits.unsafeShiftR` s) (comb64 w s' x s) (comb64 x s' y s) (comb64 y s' z s) where s' = inv64 s -- | Bitwise rotate Left rotateL :: Word256 -> Int -> Word256 rotateL (Word256 a3 a2 a1 a0) n' | n == 0 = Word256 a3 a2 a1 a0 | n == 192 = Word256 a0 a3 a2 a1 | n == 128 = Word256 a1 a0 a3 a2 | n == 64 = Word256 a2 a1 a0 a3 | n < 64 = Word256 (comb64 a3 n a2 (inv64 n)) (comb64 a2 n a1 (inv64 n)) (comb64 a1 n a0 (inv64 n)) (comb64 a0 n a3 (inv64 n)) | n < 128 = let n = n Prelude.- 64 in Word256 (comb64 a2 n a1 (inv64 n)) (comb64 a1 n a0 (inv64 n)) (comb64 a0 n a3 (inv64 n)) (comb64 a3 n a2 (inv64 n)) | n < 192 = let n = n Prelude.- 128 in Word256 (comb64 a1 n a0 (inv64 n)) (comb64 a0 n a3 (inv64 n)) (comb64 a3 n a2 (inv64 n)) (comb64 a2 n a1 (inv64 n)) | otherwise = let n = n Prelude.- 192 in Word256 (comb64 a0 n a3 (inv64 n)) (comb64 a3 n a2 (inv64 n)) (comb64 a2 n a1 (inv64 n)) (comb64 a1 n a0 (inv64 n)) where n :: Int n | n' >= 0 = n' `Prelude.mod` 256 | otherwise = 256 Prelude.- (n' `Prelude.mod` 256) -- | Bitwise rotate Left rotateR :: Word256 -> Int -> Word256 rotateR w n = rotateL w (256 Prelude.- n) inv64 :: Int -> Int inv64 i = 64 Prelude.- i comb64 :: Word64 -> Int -> Word64 -> Int -> Word64 comb64 x i y j = (x `Bits.unsafeShiftL` i) .|. (y `Bits.unsafeShiftR` j) -- | Test bit testBit :: Word256 -> Int -> Bool testBit (Word256 a3 a2 a1 a0) n | n < 0 || n > 255 = False | n > 191 = Bits.testBit a3 (n Prelude.- 192) | n > 127 = Bits.testBit a2 (n Prelude.- 128) | n > 63 = Bits.testBit a1 (n Prelude.- 64) | otherwise = Bits.testBit a0 n -- | bit bit :: Int -> Word256 bit n | n < 0 || n > 255 = Word256 0 0 0 0 | n > 191 = Word256 (Bits.bit (n Prelude.- 192)) 0 0 0 | n > 127 = Word256 0 (Bits.bit (n Prelude.- 128)) 0 0 | n > 63 = Word256 0 0 (Bits.bit (n Prelude.- 64)) 0 | otherwise = Word256 0 0 0 (Bits.bit n) literal :: Integer -> Word256 literal i = Word256 (Prelude.fromInteger (i `Bits.unsafeShiftR` 192)) (Prelude.fromInteger (i `Bits.unsafeShiftR` 128)) (Prelude.fromInteger (i `Bits.unsafeShiftR` 64)) (Prelude.fromInteger i) fromNatural :: Natural -> Word256 fromNatural n = Word256 (Prelude.fromInteger (naturalToInteger n `Bits.unsafeShiftR` 192)) (Prelude.fromInteger (naturalToInteger n `Bits.unsafeShiftR` 128)) (Prelude.fromInteger (naturalToInteger n `Bits.unsafeShiftR` 64)) (Prelude.fromInteger $ naturalToInteger n) basement-0.0.4/Basement/Monad.hs0000644000000000000000000001073013164707711014637 0ustar0000000000000000-- | -- 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 basement-0.0.4/Basement/MutableBuilder.hs0000644000000000000000000000233513141321320016462 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Basement.MutableBuilder ( Builder(..) , BuildingState(..) ) where import Basement.Compat.Base import Basement.Compat.MonadTrans import Basement.Types.OffsetSize import Basement.Monad newtype Builder collection mutCollection step state err a = Builder { runBuilder :: State (Offset step, BuildingState collection mutCollection step (PrimState state), Maybe err) state a } deriving (Functor, Applicative, Monad) -- | The in-progress state of a building operation. -- -- The previous buffers are in reverse order, and -- this contains the current buffer and the state of -- progress packing the elements inside. data BuildingState collection mutCollection step state = BuildingState { prevChunks :: [collection] , prevChunksSize :: !(CountOf step) , curChunk :: mutCollection state , chunkSize :: !(CountOf step) } instance Monad state => MonadFailure (Builder collection mutCollection step state err) where type Failure (Builder collection mutCollection step state err) = err mFail builderError = Builder $ State $ \(offset, bs, _) -> return ((), (offset, bs, Just builderError)) basement-0.0.4/Basement/FinalPtr.hs0000644000000000000000000000742513141321320015306 0ustar0000000000000000-- | -- 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_ #-} basement-0.0.4/Basement/Nat.hs0000644000000000000000000001111213201544137014307 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ConstraintKinds #-} 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 Basement.Types.Char7 (Char7) import Basement.Types.Word128 (Word128) import Basement.Types.Word256 (Word256) import Data.Int (Int8, Int16, Int32, Int64) import Data.Word (Word8, Word16, Word32, Word64) import qualified Prelude (fromIntegral) #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 :: Nat type instance NatNumMaxBound Char = 0x10ffff type instance NatNumMaxBound Char7 = 0x7f type instance NatNumMaxBound Int64 = 0x7fffffffffffffff type instance NatNumMaxBound Int32 = 0x7fffffff type instance NatNumMaxBound Int16 = 0x7fff type instance NatNumMaxBound Int8 = 0x7f type instance NatNumMaxBound Word256 = 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff type instance NatNumMaxBound Word128 = 0xffffffffffffffffffffffffffffffff type instance NatNumMaxBound Word64 = 0xffffffffffffffff type instance NatNumMaxBound Word32 = 0xffffffff type instance NatNumMaxBound Word16 = 0xffff type instance NatNumMaxBound Word8 = 0xff #if WORD_SIZE_IN_BITS == 64 type instance NatNumMaxBound Int = NatNumMaxBound Int64 type instance NatNumMaxBound Word = NatNumMaxBound Word64 #else type instance NatNumMaxBound Int = NatNumMaxBound Int32 type instance NatNumMaxBound Word = NatNumMaxBound Word32 #endif -- | Check if a Nat is in bounds of another integral / natural types type family NatInBoundOf ty n where NatInBoundOf Integer n = 'True NatInBoundOf Natural n = 'True NatInBoundOf ty n = n <=? NatNumMaxBound ty -- | Constraint to check if a natural is within a specific bounds of a type. -- -- i.e. given a Nat `n`, is it possible to convert it to `ty` without losing information #if __GLASGOW_HASKELL__ >= 800 type family NatWithinBound ty (n :: Nat) where NatWithinBound ty n = If (NatInBoundOf ty n) (() ~ ()) (TypeError ('Text "Natural " ':<>: 'ShowType n ':<>: 'Text " is out of bounds for " ':<>: 'ShowType ty)) #else type NatWithinBound ty n = NatInBoundOf ty n ~ 'True #endif basement-0.0.4/Basement/BoxedArray.hs0000644000000000000000000006224713201545546015651 0ustar0000000000000000-- | -- 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 #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} module Basement.BoxedArray ( Array , MArray , empty , length , mutableLength , copy , unsafeCopyAtRO , thaw , new , create , unsafeFreeze , unsafeThaw , freeze , unsafeWrite , unsafeRead , unsafeIndex , write , read , index , singleton , replicate , null , take , drop , splitAt , revTake , revDrop , revSplitAt , splitOn , sub , intersperse , span , spanEnd , break , breakEnd , mapFromUnboxed , mapToUnboxed , 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 Data.Proxy import Basement.Numerical.Additive import Basement.Numerical.Subtractive import Basement.NonEmpty import Basement.Compat.Base import qualified Basement.Alg.Class as Alg import qualified Basement.Alg.Mutable as Alg import Basement.Compat.MonadTrans import Basement.Compat.Semigroup import Basement.Types.OffsetSize import Basement.PrimType import Basement.NormalForm import Basement.Monad import Basement.UArray.Base (UArray) import qualified Basement.UArray.Base as UArray import Basement.Exception import Basement.MutableBuilder import qualified Basement.Compat.ExtList as List -- | 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 Semigroup (Array a) where (<>) = append 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 fromListN len = vFromListN (CountOf len) 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 = List.length l loop _ [] ma = unsafeFreeze ma loop i (x:xs) ma = unsafeWrite ma i x >> loop (i+1) xs ma -- | just like vFromList but with a length hint. -- -- The resulting array is guarantee to have been allocated to the length -- specified, but the slice might point to the initialized cells only in -- case the length is bigger than the list. -- -- If the length is too small, then the list is truncated. -- vFromListN :: forall a . CountOf a -> [a] -> Array a vFromListN len l = runST $ do ma <- new len sz <- loop 0 l ma unsafeFreezeShrink ma sz where -- TODO rewrite without ma as parameter loop :: Offset a -> [a] -> MArray a s -> ST s (CountOf a) loop i [] _ = return (offsetAsSize i) loop i (x:xs) ma | i .==# len = return (offsetAsSize i) | otherwise = unsafeWrite ma i x >> loop (i+1) xs ma vToList :: Array a -> [a] vToList v | len == 0 = [] | 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) breakEnd :: (ty -> Bool) -> Array ty -> (Array ty, Array ty) breakEnd predicate v = findBreak (sizeAsOffset len) where !len = length v findBreak !i | i == 0 = (v, empty) | predicate e = splitAt (offsetAsSize i) v | otherwise = findBreak i' where e = unsafeIndex v i' i' = i `offsetSub` 1 intersperse :: ty -> Array ty -> Array ty intersperse sep v = case len - 1 of Nothing -> v 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) spanEnd :: (ty -> Bool) -> Array ty -> (Array ty, Array ty) spanEnd p = breakEnd (not . p) map :: (a -> b) -> Array a -> Array b map f a = create (sizeCast Proxy $ length a) (\i -> f $ unsafeIndex a (offsetCast Proxy i)) mapFromUnboxed :: PrimType a => (a -> b) -> UArray a -> Array b mapFromUnboxed f arr = vFromListN (sizeCast Proxy $ UArray.length arr) . fmap f . toList $ arr mapToUnboxed :: PrimType b => (a -> b) -> Array a -> UArray b mapToUnboxed f arr = UArray.vFromListN (sizeCast Proxy $ length arr) . fmap f . toList $ arr {- mapIndex :: (Int -> a -> b) -> Array a -> Array b 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) instance (PrimMonad prim, st ~ PrimState prim) => Alg.RandomAccess (MArray ty st) prim ty where read (MArray _ _ mba) = primMutableArrayRead mba write (MArray _ _ mba) = primMutableArrayWrite mba 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 = Alg.inplaceSortBy ford 0 len ma >> unsafeFreeze ma filter :: forall ty . (ty -> Bool) -> Array ty -> Array ty filter predicate vec = runST (new len >>= copyFilterFreeze predicate (unsafeIndex vec)) where !len = length vec copyFilterFreeze :: PrimMonad prim => (ty -> Bool) -> (Offset ty -> ty) -> MArray ty (PrimState prim) -> prim (Array ty) copyFilterFreeze predi getVec mvec = loop (Offset 0) (Offset 0) >>= freezeUntilIndex mvec where loop d s | s .==# len = pure d | predi v = unsafeWrite mvec d v >> loop (d+1) (s+1) | otherwise = loop d (s+1) where v = getVec s freezeUntilIndex :: PrimMonad prim => MArray ty (PrimState prim) -> Offset ty -> prim (Array ty) freezeUntilIndex mvec d = do m <- new (offsetAsSize d) copyAt m (Offset 0) mvec (Offset 0) (offsetAsSize d) unsafeFreeze m unsafeFreezeShrink :: PrimMonad prim => MArray ty (PrimState prim) -> CountOf ty -> prim (Array ty) unsafeFreezeShrink (MArray start _ ma) n = unsafeFreeze (MArray start n ma) reverse :: Array ty -> Array ty reverse a = create len toEnd where len@(CountOf s) = length a toEnd (Offset i) = unsafeIndex a (Offset (s - 1 - i)) foldr :: (ty -> a -> a) -> a -> Array ty -> a foldr f initialAcc vec = loop 0 where len = length vec loop !i | i .==# len = initialAcc | otherwise = unsafeIndex vec i `f` loop (i+1) foldl' :: (a -> ty -> a) -> a -> Array ty -> a foldl' f initialAcc vec = loop 0 initialAcc where len = length vec loop !i !acc | i .==# len = acc | otherwise = loop (i+1) (f acc (unsafeIndex vec i)) foldl1' :: (ty -> ty -> ty) -> NonEmpty (Array ty) -> ty foldl1' f arr = let (initialAcc, rest) = splitAt 1 $ getNonEmpty arr in foldl' f (unsafeIndex initialAcc 0) rest foldr1 :: (ty -> ty -> ty) -> NonEmpty (Array ty) -> ty foldr1 f arr = let (initialAcc, rest) = revSplitAt 1 $ getNonEmpty arr in foldr f (unsafeIndex initialAcc 0) rest all :: (ty -> Bool) -> Array ty -> Bool all p ba = loop 0 where len = length ba loop !i | i .==# len = True | not $ p (unsafeIndex ba i) = False | otherwise = loop (i + 1) any :: (ty -> Bool) -> Array ty -> Bool any p ba = loop 0 where len = length ba loop !i | i .==# len = False | p (unsafeIndex ba i) = True | otherwise = loop (i + 1) isPrefixOf :: Eq ty => Array ty -> Array ty -> Bool isPrefixOf pre arr | pLen > pArr = False | otherwise = pre == take pLen arr where !pLen = length pre !pArr = length arr isSuffixOf :: Eq ty => Array ty -> Array ty -> Bool isSuffixOf suffix arr | pLen > pArr = False | otherwise = suffix == revTake pLen arr where !pLen = length suffix !pArr = length arr builderAppend :: PrimMonad state => ty -> Builder (Array ty) (MArray ty) ty state err () builderAppend v = Builder $ State $ \(i, st, e) -> if i .==# chunkSize st then do cur <- unsafeFreeze (curChunk st) newChunk <- new (chunkSize st) unsafeWrite newChunk 0 v pure ((), (Offset 1, st { prevChunks = cur : prevChunks st , prevChunksSize = chunkSize st + prevChunksSize st , curChunk = newChunk }, e)) else do unsafeWrite (curChunk st) i v pure ((), (i+1, st, e)) builderBuild :: PrimMonad m => Int -> Builder (Array ty) (MArray ty) ty m err () -> m (Either err (Array ty)) builderBuild sizeChunksI ab | sizeChunksI <= 0 = builderBuild 64 ab | otherwise = do first <- new sizeChunks ((), (i, st, e)) <- runState (runBuilder ab) (Offset 0, BuildingState [] (CountOf 0) first sizeChunks, Nothing) case e of Just err -> pure (Left err) Nothing -> do cur <- unsafeFreezeShrink (curChunk st) (offsetAsSize i) -- Build final array let totalSize = prevChunksSize st + offsetAsSize i bytes <- new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= unsafeFreeze pure (Right bytes) where sizeChunks = CountOf sizeChunksI fillFromEnd _ [] mua = pure mua fillFromEnd !end (x:xs) mua = do let sz = length x let start = end `sizeSub` sz unsafeCopyAtRO mua (sizeAsOffset start) x (Offset 0) sz fillFromEnd start xs mua builderBuild_ :: PrimMonad m => Int -> Builder (Array ty) (MArray ty) ty m () () -> m (Array ty) builderBuild_ sizeChunksI ab = either (\() -> internalError "impossible output") id <$> builderBuild sizeChunksI ab basement-0.0.4/Basement/Block.hs0000644000000000000000000003126113201545546014633 0ustar0000000000000000-- | -- 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 #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} 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 , breakEnd , 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 import qualified Basement.Alg.Native.Prim as Prim import qualified Basement.Alg.Mutable as MutAlg import qualified Basement.Alg.Class as Alg import qualified Basement.Alg.PrimArray as Alg instance (PrimMonad prim, st ~ PrimState prim, PrimType ty) => Alg.RandomAccess (MutableBlock ty st) prim ty where read (MutableBlock mba) = primMbaRead mba write (MutableBlock mba) = primMbaWrite mba instance (PrimType ty) => Alg.Indexable (Block ty) ty where index (Block ba) = primBaIndex ba {-# INLINE index #-} -- | Copy all the block content to the memory starting at the destination address unsafeCopyToPtr :: forall ty prim . PrimMonad prim => Block ty -- ^ the source block to copy -> 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) #-} breakEnd :: PrimType ty => (ty -> Bool) -> Block ty -> (Block ty, Block ty) breakEnd predicate blk | k == end = (blk, mempty) | otherwise = splitAt (offsetAsSize (k+1)) blk where k = Alg.revFindIndexPredicate predicate blk 0 end end = 0 `offsetPlusE` len !len = length blk {-# SPECIALIZE [2] breakEnd :: (Word8 -> Bool) -> Block Word8 -> (Block Word8, Block Word8) #-} span :: PrimType ty => (ty -> Bool) -> Block ty -> (Block ty, Block ty) span p = break (not . p) 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 :: PrimType ty => (ty -> ty -> Ordering) -> Block ty -> Block ty sortBy ford vec | len == 0 = mempty | otherwise = runST $ do mblock@(MutableBlock mba) <- thaw vec MutAlg.inplaceSortBy ford 0 len mblock unsafeFreeze mblock where len = length vec {-# SPECIALIZE [2] sortBy :: (Word8 -> Word8 -> Ordering) -> Block Word8 -> Block Word8 #-} intersperse :: forall ty . PrimType ty => ty -> Block ty -> Block ty intersperse sep blk = case len - 1 of Nothing -> blk Just 0 -> blk Just size -> runST $ do mb <- new (len+size) go mb unsafeFreeze mb where !len = length blk go :: MutableBlock ty s -> ST s () go mb = loop 0 0 where loop !o !i | (i + 1) .==# len = unsafeWrite mb o (unsafeIndex blk i) | otherwise = do unsafeWrite mb o (unsafeIndex blk i) unsafeWrite mb (o+1) sep loop (o+2) (i+1) basement-0.0.4/Basement/Block/Mutable.hs0000644000000000000000000000730613172057505016227 0ustar0000000000000000-- | -- 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 interop with the C layer -- as address. -- -- Note that sadly the bytearray primitive type automatically create -- a pinned bytearray if the size is bigger than a certain threshold -- -- 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 #-} -- | Set all mutable block element to a value iterSet :: (PrimType ty, PrimMonad prim) => (Offset ty -> ty) -> MutableBlock ty (PrimState prim) -> prim () iterSet f ma = loop 0 where !sz = mutableLengthSize ma loop i | i .==# sz = pure () | otherwise = unsafeWrite ma i (f i) >> loop (i+1) {-# INLINE loop #-} -- | read a cell in a mutable array. -- -- If the index is out of bounds, an error is raised. read :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> Offset ty -> prim ty read array n | isOutOfBound n len = primOutOfBound OOB_Read n len | otherwise = unsafeRead array n where len = mutableLengthSize array {-# INLINE read #-} -- | Write to a cell in a mutable array. -- -- If the index is out of bounds, an error is raised. write :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> Offset ty -> ty -> prim () write array n val | isOutOfBound n len = primOutOfBound OOB_Write n len | otherwise = unsafeWrite array n val where len = mutableLengthSize array {-# INLINE write #-} basement-0.0.4/Basement/UArray.hs0000644000000000000000000010570513201545546015011 0ustar0000000000000000-- | -- 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 #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} module Basement.UArray ( UArray(..) , PrimType(..) -- * methods , copy , unsafeCopyAtRO -- * internal methods -- , copyAddr , recast , unsafeRecast , length , freeze , unsafeFreeze , thaw , unsafeThaw -- * Creation , vFromListN , new , create , createFromIO , createFromPtr , sub , copyToPtr , withPtr , withMutablePtr , unsafeFreezeShrink , freezeShrink , fromBlock , toBlock -- * 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 , breakEnd , breakElem , breakLine , elem , indices , intersperse , span , spanEnd , 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.UArray.Base import Basement.Block (Block(..), MutableBlock(..)) import qualified Basement.Block as BLK import qualified Basement.Block.Base as BLK (withPtr, unsafeWrite) 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.Alg.Native.Prim as PrimBA import qualified Basement.Alg.Foreign.Prim as PrimAddr import qualified Basement.Alg.Mutable as Alg import qualified Basement.Alg.Class as Alg import qualified Basement.Alg.PrimArray as Alg -- | 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) -- | Create a UArray from a Block -- -- The block is still used by the uarray fromBlock :: PrimType ty => Block ty -> UArray ty fromBlock blk = UArray 0 (BLK.length blk) (UArrayBA blk) -- | Allocate a new array with a fill function that has access to the elements of -- the source array. unsafeCopyFrom :: (PrimType a, PrimType b) => 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' -- | 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 (Block 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 (\blk -> BLK.withPtr blk $ \ptr -> f (ptr `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 withPtr arr f 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) -- TODO: return Maybe k | k == end = (arr, empty) | k == start = (empty, arr) | otherwise = ( UArray start (offsetAsSize k `sizeSub` offsetAsSize start) backend , UArray k (len `sizeSub` (offsetAsSize k `sizeSub` offsetAsSize start)) backend) where !end = start `offsetPlusE` len !k = onBackendPure' arr $ Alg.findIndexElem ty {-# NOINLINE [3] breakElem #-} {-# RULES "breakElem Word8" [4] 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 = onBackendPure goBa goAddr arr goBa (Block 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) = onBackendPure goBa goAddr arr lineFeed = 0xa carriageReturn = 0xd goBa (Block 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 -- TODO: check for end could be done in algorithm | k == end = Nothing | otherwise = Just (k `offsetSub` start) where !k = onBackendPure' arr $ Alg.findIndexElem ty !start = offset arr !end = start `offsetPlusE` length arr {-# SPECIALIZE [3] findIndex :: Word8 -> UArray Word8 -> Maybe (Offset Word8) #-} revFindIndex :: PrimType ty => ty -> UArray ty -> Maybe (Offset ty) revFindIndex ty arr -- TODO: check for end could be done in algorithm | k == end = Nothing | otherwise = Just (k `offsetSub` start) where !k = onBackendPure' arr $ Alg.revFindIndexElem ty !start = offset arr !end = start `offsetPlusE` length arr {-# SPECIALIZE [3] revFindIndex :: Word8 -> UArray Word8 -> Maybe (Offset Word8) #-} break :: forall ty . PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty) break predicate arr -- TODO2: check for end could be done in algorithm? but maybe more ops are involved | k == end = (arr, mempty) | otherwise = splitAt (offsetAsSize (k `offsetSub` start)) arr where !k = onBackendPure' arr $ Alg.findIndexPredicate predicate !start = offset arr !end = start `offsetPlusE` length arr {- {-# SPECIALIZE [3] findIndex :: Word8 -> UArray Word8 -> Maybe (Offset Word8) #-} | 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 #-} -} -- | Similar to break but start the search of the breakpoint from the end -- -- > breakEnd (> 0) [1,2,3,0,0,0] -- ([1,2,3], [0,0,0]) breakEnd :: forall ty . PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty) breakEnd predicate arr -- TODO2: check for end could be done in algorithm? but maybe more ops are involved | k == end = (arr, mempty) | otherwise = splitAt (offsetAsSize (k+1) `sizeSub` offsetAsSize start) arr where !k = onBackendPure' arr $ Alg.revFindIndexPredicate predicate !start = offset arr !end = start `offsetPlusE` length arr {-# SPECIALIZE [3] breakEnd :: (Word8 -> Bool) -> UArray Word8 -> (UArray Word8, UArray Word8) #-} elem :: PrimType ty => ty -> UArray ty -> Bool --elem !ty arr = onBackendPure goBa goAddr arr /= end -- check for end could be done in algorithm? isNothing? elem !ty arr = onBackendPure' arr (Alg.findIndexElem ty) /= end where !start = offset arr !end = start `offsetPlusE` length arr {-# 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) spanEnd :: PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty) spanEnd p = breakEnd (not . p) map :: (PrimType a, PrimType b) => (a -> b) -> UArray a -> UArray b map f a = create lenB (\i -> f $ unsafeIndex a (offsetCast Proxy i)) where !lenB = sizeCast (Proxy :: Proxy (a -> b)) (length a) 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 ford vec = runST $ do mvec <- thaw vec onMutableBackend goNative (\fptr -> withFinalPtr fptr goAddr) mvec unsafeFreeze mvec where !len = length vec !start = offset vec goNative :: MutableBlock ty s -> ST s () goNative mb = Alg.inplaceSortBy ford start len mb goAddr :: Ptr ty -> ST s () goAddr (Ptr addr) = Alg.inplaceSortBy ford start len (Ptr addr :: Ptr ty) {-# SPECIALIZE [3] sortBy :: (Word8 -> Word8 -> Ordering) -> UArray Word8 -> UArray Word8 #-} filter :: forall ty . PrimType ty => (ty -> Bool) -> UArray ty -> UArray ty filter predicate arr = runST $ do (newLen, ma) <- newNative (length arr) $ \(MutableBlock mba) -> onBackendPrim (\block -> Alg.filter predicate mba block start end) (\fptr -> withFinalPtr fptr $ \ptr@(Ptr !_) -> Alg.filter predicate mba ptr start end) arr unsafeFreezeShrink ma newLen where !len = length arr !start = offset arr !end = start `offsetPlusE` len reverse :: forall ty . 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 :: MutableBlock ty s -> Block ty -> ST s () goNative !ma (Block !ba) = loop 0 where loop !i | i == end = pure () | otherwise = BLK.unsafeWrite ma i (primBaIndex ba (sizeAsOffset (endI - i))) >> loop (i+1) goAddr :: MutableBlock ty s -> Ptr ty -> ST s () goAddr !ma (Ptr addr) = loop 0 where loop !i | i == end = pure () | otherwise = BLK.unsafeWrite ma i (primAddrIndex addr (sizeAsOffset (endI - i))) >> loop (i+1) {-# SPECIALIZE [3] reverse :: UArray Word8 -> UArray Word8 #-} {-# SPECIALIZE [3] reverse :: UArray Word32 -> UArray Word32 #-} {-# SPECIALIZE [3] reverse :: UArray Char -> UArray Char #-} -- 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 !(CountOf 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 = onBackendPure' arr (Alg.foldl f initialAcc) {-# SPECIALIZE [3] foldl' :: (a -> Word8 -> a) -> a -> UArray Word8 -> a #-} foldl1' :: PrimType ty => (ty -> ty -> ty) -> NonEmpty (UArray ty) -> ty foldl1' f (NonEmpty arr) = onBackendPure' arr (Alg.foldl1 f) {-# 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 = onBackendPure' arr $ Alg.all predicate {-# SPECIALIZE [3] all :: (Word8 -> Bool) -> UArray Word8 -> Bool #-} any :: PrimType ty => (ty -> Bool) -> UArray ty -> Bool any predicate arr = onBackendPure' arr $ Alg.any predicate {-# SPECIALIZE [3] any :: (Word8 -> Bool) -> UArray Word8 -> Bool #-} builderAppend :: (PrimType ty, PrimMonad state) => ty -> Builder (UArray ty) (MUArray ty) ty state err () builderAppend v = Builder $ State $ \(i, st, e) -> if offsetAsSize i == chunkSize st then do cur <- unsafeFreeze (curChunk st) newChunk <- new (chunkSize st) unsafeWrite newChunk 0 v pure ((), (Offset 1, st { prevChunks = cur : prevChunks st , prevChunksSize = chunkSize st + prevChunksSize st , curChunk = newChunk }, e)) else do unsafeWrite (curChunk st) i v pure ((), (i + 1, st, e)) builderBuild :: (PrimType ty, PrimMonad m) => Int -> Builder (UArray ty) (MUArray ty) ty m err () -> m (Either err (UArray ty)) builderBuild sizeChunksI ab | sizeChunksI <= 0 = builderBuild 64 ab | otherwise = do first <- new sizeChunks ((), (i, st, e)) <- runState (runBuilder ab) (Offset 0, BuildingState [] (CountOf 0) first sizeChunks, Nothing) case e of Just err -> pure (Left err) Nothing -> do cur <- unsafeFreezeShrink (curChunk st) (offsetAsSize i) -- Build final array let totalSize = prevChunksSize st + offsetAsSize i bytes <- new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= unsafeFreeze pure (Right bytes) where sizeChunks = CountOf sizeChunksI fillFromEnd _ [] mua = pure mua fillFromEnd !end (x:xs) mua = do let sz = length x let start = end `sizeSub` sz unsafeCopyAtRO mua (sizeAsOffset start) x (Offset 0) sz fillFromEnd start xs mua builderBuild_ :: (PrimType ty, PrimMonad m) => Int -> Builder (UArray ty) (MUArray ty) ty m () () -> m (UArray ty) builderBuild_ sizeChunksI ab = either (\() -> internalError "impossible output") id <$> builderBuild sizeChunksI ab toHexadecimal :: PrimType ty => UArray ty -> UArray Word8 toHexadecimal ba | len == CountOf 0 = mempty | otherwise = runST $ do ma <- new (len `scale` 2) unsafeIndexer b8 (go ma) unsafeFreeze ma where b8 = unsafeRecast ba !len = length b8 !endOfs = Offset 0 `offsetPlusE` len go :: MUArray Word8 s -> (Offset Word8 -> Word8) -> ST s () go !ma !getAt = loop 0 0 where loop !dIdx !sIdx | sIdx == endOfs = pure () | otherwise = do let !(W8# !w) = getAt sIdx !(# wHi, wLo #) = Base16.unsafeConvertByte w unsafeWrite ma dIdx (W8# wHi) unsafeWrite ma (dIdx+1) (W8# wLo) loop (dIdx + 2) (sIdx+1) toBase64Internal :: PrimType ty => Addr# -> UArray ty -> Bool -> UArray Word8 toBase64Internal table src padded | len == CountOf 0 = mempty | otherwise = runST $ do ma <- new dstLen unsafeIndexer b8 (go ma) unsafeFreeze ma where b8 = unsafeRecast src !len = length b8 !dstLen = outputLengthBase64 padded len !endOfs = Offset 0 `offsetPlusE` len !dstEndOfs = Offset 0 `offsetPlusE` dstLen go :: MUArray Word8 s -> (Offset Word8 -> Word8) -> ST s () go !ma !getAt = loop 0 0 where eqChar = 0x3d :: Word8 loop !sIdx !dIdx | sIdx == endOfs = when padded $ do when (dIdx `offsetPlusE` CountOf 1 <= dstEndOfs) $ unsafeWrite ma dIdx eqChar when (dIdx `offsetPlusE` CountOf 2 == dstEndOfs) $ unsafeWrite ma (dIdx `offsetPlusE` CountOf 1) eqChar | otherwise = do let !b2Idx = sIdx `offsetPlusE` CountOf 1 !b3Idx = sIdx `offsetPlusE` CountOf 2 !b2Available = b2Idx < endOfs !b3Available = b3Idx < endOfs !b1 = getAt sIdx !b2 = if b2Available then getAt b2Idx else 0 !b3 = if b3Available then getAt b3Idx else 0 (w,x,y,z) = convert3 table b1 b2 b3 sNextIncr = 1 + fromEnum b2Available + fromEnum b3Available dNextIncr = 1 + sNextIncr unsafeWrite ma dIdx w unsafeWrite ma (dIdx `offsetPlusE` CountOf 1) x when b2Available $ unsafeWrite ma (dIdx `offsetPlusE` CountOf 2) y when b3Available $ unsafeWrite ma (dIdx `offsetPlusE` CountOf 3) z loop (sIdx `offsetPlusE` CountOf sNextIncr) (dIdx `offsetPlusE` CountOf dNextIncr) outputLengthBase64 :: Bool -> CountOf Word8 -> CountOf Word8 outputLengthBase64 padding (CountOf inputLenInt) = outputLength where outputLength = if padding then CountOf lenWithPadding else CountOf lenWithoutPadding lenWithPadding | m == 0 = 4 * d | otherwise = 4 * (d + 1) lenWithoutPadding | m == 0 = 4 * d | otherwise = 4 * d + m + 1 (d,m) = inputLenInt `divMod` 3 convert3 :: Addr# -> Word8 -> Word8 -> Word8 -> (Word8, Word8, Word8, Word8) convert3 table (W8# a) (W8# b) (W8# c) = let !w = narrow8Word# (uncheckedShiftRL# a 2#) !x = or# (and# (uncheckedShiftL# a 4#) 0x30##) (uncheckedShiftRL# b 4#) !y = or# (and# (uncheckedShiftL# b 2#) 0x3c##) (uncheckedShiftRL# c 6#) !z = and# c 0x3f## in (idx w, idx x, idx y, idx z) where idx :: Word# -> Word8 idx i = W8# (indexWord8OffAddr# table (word2Int# i)) isPrefixOf :: PrimType ty => UArray ty -> UArray ty -> Bool isPrefixOf pre arr | pLen > pArr = False | otherwise = pre == unsafeTake pLen arr where !pLen = length pre !pArr = length arr {-# SPECIALIZE [3] isPrefixOf :: UArray Word8 -> UArray Word8 -> Bool #-} isSuffixOf :: PrimType ty => UArray ty -> UArray ty -> Bool isSuffixOf suffix arr | pLen > pArr = False | otherwise = suffix == revTake pLen arr where !pLen = length suffix !pArr = length arr {-# SPECIALIZE [3] isSuffixOf :: UArray Word8 -> UArray Word8 -> Bool #-} basement-0.0.4/Basement/UArray/Mutable.hs0000644000000000000000000001656213172057505016404 0ustar0000000000000000-- | -- 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 as BLK 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 mb)) f | BLK.isMutablePinned mb == Pinned = MBLK.mutableWithPtr mb (\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) -- | 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 (MutableBlock 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 (MutableBlock mba) = primitive $ \s1 -> case unsafeFreezeByteArray# mba s1 of (# s2, ba #) -> (# compatCopyByteArrayToAddr# ba os# dst# szBytes# s2, () #) copyPtr fptr = unsafePrimFromIO $ withFinalPtr fptr $ \ptr -> copyBytes dst (ptr `plusPtr` os) szBytes !(Offset os@(I# os#)) = offsetInBytes $ mutableOffset marr !(CountOf szBytes@(I# szBytes#)) = sizeInBytes $ mutableLength marr mutableOffset :: MUArray ty st -> Offset ty mutableOffset (MUArray ofs _ _) = ofs basement-0.0.4/Basement/String.hs0000644000000000000000000016106413176251306015053 0ustar0000000000000000-- | -- 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 , spanEnd , break , breakEnd , 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.Block.Mutable (Block(..), MutableBlock(..)) 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.Alg.Native.UTF8 as PrimBA import qualified Basement.Alg.Foreign.UTF8 as PrimAddr import qualified Basement.Alg.Native.String as BackendBA import qualified Basement.Alg.Foreign.String as BackendAddr import GHC.Prim import GHC.ST import GHC.Types 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 #-} breakEnd :: (Char -> Bool) -> String -> (String, String) breakEnd predicate s@(String arr) | k == end = (s, mempty) | otherwise = splitIndex k s where k = C.onBackend goVec (\_ -> pure . goAddr) arr (C.ValidRange !start !end) = offsetsValidRange arr goVec (Block ba) = let k = BackendBA.revFindIndexPredicate predicate ba start end in if k == end then end else PrimBA.nextSkip ba k goAddr (Ptr addr) = let k = BackendAddr.revFindIndexPredicate predicate addr start end in if k == end then end else PrimAddr.nextSkip addr k {-# INLINE [2] breakEnd #-} #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 -- | Apply a @predicate@ to the string to return the longest suffix that satisfy the predicate and -- the remaining spanEnd :: (Char -> Bool) -> String -> (String, String) spanEnd predicate s = breakEnd (not . predicate) s -- | Drop character from the beginning while the predicate is true dropWhile :: (Char -> Bool) -> String -> String dropWhile predicate = snd . break (not . predicate) -- | 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 (Block 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 $ \(MutableBlock mba) -> C.onBackendPrim (\(Block ba) -> BackendBA.copyFilter predicate sz mba ba start) (\fptr -> withFinalPtr fptr $ \(Ptr addr) -> BackendAddr.copyFilter predicate sz mba addr start) arr freezeShrink finalSize dst where !sz = C.length arr !start = C.offset arr -- | Reverse a string reverse :: String -> String reverse (String arr) = runST $ do ((), dst) <- newNative (C.length arr) $ \(MutableBlock mba) -> C.onBackendPrim (\(Block ba) -> PrimBA.reverse mba 0 ba start end) (\fptr -> withFinalPtr fptr $ \(Ptr addr) -> PrimAddr.reverse mba 0 addr start end) arr freeze dst where !(C.ValidRange start end) = C.offsetsValidRange arr -- 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 goBA (\_ -> pure . goAddr) arr where !(C.ValidRange start end) = C.offsetsValidRange arr goBA (Block ba) = PrimBA.all predicate ba start end goAddr (Ptr addr) = PrimAddr.all predicate addr start end any :: (Char -> Bool) -> String -> Bool any predicate (String arr) = C.onBackend goBA (\_ -> pure . goAddr) arr where !(C.ValidRange start end) = C.offsetsValidRange arr goBA (Block ba) = PrimBA.any predicate ba start end goAddr (Ptr addr) = PrimAddr.any predicate addr start end -- | Transform string @src@ to base64 binary representation. toBase64 :: String -> String toBase64 (String src) = fromBytesUnsafe . Vec.toBase64Internal set src $ True where !set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"# -- | Transform string @src@ to URL-safe base64 binary representation. -- The result will be either padded or unpadded, depending on the boolean -- @padded@ argument. toBase64URL :: Bool -> String -> String toBase64URL padded (String src) = fromBytesUnsafe . Vec.toBase64Internal set src $ padded where !set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_"# -- | Transform string @src@ to OpenBSD base64 binary representation. toBase64OpenBSD :: String -> String toBase64OpenBSD (String src) = fromBytesUnsafe . Vec.toBase64Internal set src $ False where !set = "./ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"# basement-0.0.4/Basement/NonEmpty.hs0000644000000000000000000000123613141321320015332 0ustar0000000000000000-- | -- Module : Basement.NonEmpty -- License : BSD-style -- Maintainer : Foundation -- Stability : experimental -- Portability : portable -- -- A newtype wrapper around a non-empty Collection. module Basement.NonEmpty ( NonEmpty(..) ) where import Basement.Exception import Basement.Compat.Base -- | NonEmpty property for any Collection newtype NonEmpty a = NonEmpty { getNonEmpty :: a } deriving (Show,Eq) instance IsList c => IsList (NonEmpty c) where type Item (NonEmpty c) = Item c toList = toList . getNonEmpty fromList [] = throw NonEmptyCollectionIsEmpty fromList l = NonEmpty . fromList $ l basement-0.0.4/Basement/NormalForm.hs0000644000000000000000000001224313201544137015647 0ustar0000000000000000module Basement.NormalForm ( NormalForm(..) , deepseq , force ) where import Basement.Compat.Base import Basement.Compat.Natural import Basement.Types.OffsetSize import Basement.Types.Char7 import Basement.Types.Word128 (Word128) import Basement.Types.Word256 (Word256) import Basement.Bounded 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 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 !_ = () instance NormalForm Char7 where toNormalForm !_ = () instance NormalForm Word128 where toNormalForm !_ = () instance NormalForm Word256 where toNormalForm !_ = () instance NormalForm (Zn n) where toNormalForm = toNormalForm . unZn instance NormalForm (Zn64 n) where toNormalForm = toNormalForm . unZn64 ----- -- composed type instance NormalForm a => NormalForm (Maybe a) where toNormalForm Nothing = () toNormalForm (Just a) = toNormalForm a `seq` () instance (NormalForm l, NormalForm r) => NormalForm (Either l r) where toNormalForm (Left l) = toNormalForm l `seq` () toNormalForm (Right r) = toNormalForm r `seq` () instance NormalForm a => NormalForm (LE a) where toNormalForm (LE a) = toNormalForm a `seq` () instance NormalForm a => NormalForm (BE a) where toNormalForm (BE a) = toNormalForm a `seq` () instance NormalForm a => NormalForm [a] where toNormalForm [] = () toNormalForm (x:xs) = toNormalForm x `seq` toNormalForm xs instance (NormalForm a, NormalForm b) => NormalForm (a,b) where toNormalForm (a,b) = toNormalForm a `seq` toNormalForm b instance (NormalForm a, NormalForm b, NormalForm c) => NormalForm (a,b,c) where toNormalForm (a,b,c) = toNormalForm a `seq` toNormalForm b `seq` toNormalForm c instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d) => NormalForm (a,b,c,d) where toNormalForm (a,b,c,d) = toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d, NormalForm e) => NormalForm (a,b,c,d,e) where toNormalForm (a,b,c,d,e) = toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d `seq` toNormalForm e instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d, NormalForm e, NormalForm f) => NormalForm (a,b,c,d,e,f) where toNormalForm (a,b,c,d,e,f) = toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d `seq` toNormalForm e `seq` toNormalForm f instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d, NormalForm e, NormalForm f, NormalForm g) => NormalForm (a,b,c,d,e,f,g) where toNormalForm (a,b,c,d,e,f,g) = toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d `seq` toNormalForm e `seq` toNormalForm f `seq` toNormalForm g instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d, NormalForm e, NormalForm f, NormalForm g, NormalForm h) => NormalForm (a,b,c,d,e,f,g,h) where toNormalForm (a,b,c,d,e,f,g,h) = toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d `seq` toNormalForm e `seq` toNormalForm f `seq` toNormalForm g `seq` toNormalForm h basement-0.0.4/Basement/These.hs0000644000000000000000000000166713141321320014641 0ustar0000000000000000-- | -- 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 basement-0.0.4/Basement/Terminal.hs0000644000000000000000000000143113201626577015354 0ustar0000000000000000{-# LANGUAGE CPP #-} module Basement.Terminal ( initialize , getDimensions ) where import Basement.Compat.Base import Basement.Terminal.Size (getDimensions) #ifdef mingw32_HOST_OS import System.IO (hSetEncoding, utf8, hPutStrLn, stderr, stdin, stdout) import System.Win32.Console (setConsoleCP, setConsoleOutputCP, getConsoleCP, getConsoleOutputCP) #endif initialize :: IO () initialize = do #ifdef mingw32_HOST_OS query getConsoleOutputCP (\e -> setConsoleOutputCP e >> hSetEncoding stdout utf8 >> hSetEncoding stderr utf8) utf8Code query getConsoleCP (\e -> setConsoleCP e >> hSetEncoding stdin utf8) utf8Code where utf8Code = 65001 query get set expected = do v <- get if v == expected then pure () else set expected #else pure () #endif basement-0.0.4/Basement/Terminal/ANSI.hs0000644000000000000000000001113513201626577016110 0ustar0000000000000000-- | -- Module : Basement.Terminal.ANSI -- License : BSD-style -- Maintainer : Vincent Hanquez -- -- ANSI Terminal escape for cursor and attributes manipulations -- -- On Unix system, it should be supported by most terminal emulators. -- -- On Windows system, all escape sequences are empty for maximum -- compatibility purpose, and easy implementation. newer version -- of Windows 10 supports ANSI escape now, but we'll need -- some kind of detection. -- {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} module Basement.Terminal.ANSI ( -- * Types Escape , Displacement , ColorComponent , GrayComponent , RGBComponent -- * Simple ANSI escape factory functions , cursorUp , cursorDown , cursorForward , cursorBack , cursorNextLine , cursorPrevLine , cursorHorizontalAbsolute , cursorPosition , eraseScreenFromCursor , eraseScreenToCursor , eraseScreenAll , eraseLineFromCursor , eraseLineToCursor , eraseLineAll , scrollUp , scrollDown , sgrReset , sgrForeground , sgrBackground , sgrForegroundGray24 , sgrBackgroundGray24 , sgrForegroundColor216 , sgrBackgroundColor216 ) where import Basement.String import Basement.Bounded import Basement.Imports import Basement.Numerical.Multiplicative import Basement.Numerical.Additive #ifndef mingw32_HOST_OS #define SUPPORT_ANSI_ESCAPE #endif type Escape = String type Displacement = Word64 -- | Simple color component on 8 color terminal (maximum compatibility) type ColorComponent = Zn64 8 -- | Gray color compent on 256colors terminals type GrayComponent = Zn64 24 -- | Color compent on 256colors terminals type RGBComponent = Zn64 6 cursorUp, cursorDown, cursorForward, cursorBack , cursorNextLine, cursorPrevLine , cursorHorizontalAbsolute :: Displacement -> Escape cursorUp n = csi1 n "A" cursorDown n = csi1 n "B" cursorForward n = csi1 n "C" cursorBack n = csi1 n "D" cursorNextLine n = csi1 n "E" cursorPrevLine n = csi1 n "F" cursorHorizontalAbsolute n = csi1 n "G" cursorPosition :: Displacement -> Displacement -> Escape cursorPosition row col = csi2 row col "H" eraseScreenFromCursor , eraseScreenToCursor , eraseScreenAll , eraseLineFromCursor , eraseLineToCursor , eraseLineAll :: Escape eraseScreenFromCursor = csi1 0 "J" eraseScreenToCursor = csi1 1 "J" eraseScreenAll = csi1 2 "J" eraseLineFromCursor = csi1 0 "K" eraseLineToCursor = csi1 1 "K" eraseLineAll = csi1 2 "K" scrollUp, scrollDown :: Displacement -> Escape scrollUp n = csi1 n "S" scrollDown n = csi1 n "T" -- | All attribute off sgrReset :: Escape sgrReset = csi1 0 "m" -- | 8 Colors + Bold attribute for foreground sgrForeground :: ColorComponent -> Bool -> Escape sgrForeground n bold | bold = csi2 (30+unZn64 n) 1 "m" | otherwise = csi1 (30+unZn64 n) "m" -- | 8 Colors + Bold attribute for background sgrBackground :: ColorComponent -> Bool -> Escape sgrBackground n bold | bold = csi2 (40+unZn64 n) 1 "m" | otherwise = csi1 (40+unZn64 n) "m" -- 256 colors mode sgrForegroundGray24, sgrBackgroundGray24 :: GrayComponent -> Escape sgrForegroundGray24 v = csi3 38 5 (0xE8 + unZn64 v) "m" sgrBackgroundGray24 v = csi3 48 5 (0xE8 + unZn64 v) "m" sgrForegroundColor216 :: RGBComponent -- ^ Red component -> RGBComponent -- ^ Green component -> RGBComponent -- ^ Blue component -> Escape sgrForegroundColor216 r g b = csi3 38 5 (0x10 + 36 * unZn64 r + 6 * unZn64 g + unZn64 b) "m" sgrBackgroundColor216 :: RGBComponent -- ^ Red component -> RGBComponent -- ^ Green component -> RGBComponent -- ^ Blue component -> Escape sgrBackgroundColor216 r g b = csi3 48 5 (0x10 + 36 * unZn64 r + 6 * unZn64 g + unZn64 b) "m" #ifdef SUPPORT_ANSI_ESCAPE csi0 :: String -> String csi0 suffix = mconcat ["\ESC[", suffix] csi1 :: Displacement -> String -> String csi1 p1 suffix = mconcat ["\ESC[", pshow p1, suffix] csi2 :: Displacement -> Displacement -> String -> String csi2 p1 p2 suffix = mconcat ["\ESC[", pshow p1, ";", pshow p2, suffix] csi3 :: Displacement -> Displacement -> Displacement -> String -> String csi3 p1 p2 p3 suffix = mconcat ["\ESC[", pshow p1, ";", pshow p2, ";", pshow p3, suffix] pshow = show #else csi0 :: String -> String csi0 _ = "" csi1 :: Displacement -> String -> String csi1 _ _ = "" csi2 :: Displacement -> Displacement -> String -> String csi2 _ _ _ = "" csi3 :: Displacement -> Displacement -> Displacement -> String -> String csi3 _ _ _ _ = "" #endif basement-0.0.4/Basement/IntegralConv.hs0000644000000000000000000002273513175306501016176 0ustar0000000000000000{-# LANGUAGE MagicHash #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE FlexibleInstances #-} module Basement.IntegralConv ( IntegralDownsize(..) , IntegralUpsize(..) , IntegralCast(..) , intToInt64 , int64ToInt , wordToWord64 , word64ToWord32s , Word32x2(..) , word64ToWord , wordToChar , wordToInt , charToInt ) where import GHC.Types import GHC.Prim import GHC.Int import GHC.Word import Prelude (Integer, fromIntegral) import Basement.Compat.Base import Basement.Compat.Natural import Basement.Numerical.Number import Basement.Numerical.Conversion -- | 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 IsIntegral a => IntegralUpsize a Integer where integralUpsize = toInteger instance IsNatural a => IntegralUpsize a Natural where integralUpsize = toNatural instance IntegralUpsize Int8 Int16 where integralUpsize (I8# i) = I16# i instance IntegralUpsize Int8 Int32 where 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 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 Int32 Int64 where integralUpsize (I32# i) = intToInt64 (I# i) instance IntegralUpsize Int32 Int where integralUpsize (I32# i) = I# i instance IntegralUpsize Int Int64 where integralUpsize = intToInt64 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 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 Word32 Word64 where integralUpsize (W32# i) = wordToWord64 (W# i) instance IntegralUpsize Word32 Word where integralUpsize (W32# i) = W# i instance IntegralUpsize Word Word64 where integralUpsize = wordToWord64 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 integralCast = word64ToInt64 instance IntegralCast Int64 Word64 where integralCast = int64ToWord64 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)) basement-0.0.4/Basement/Floating.hs0000644000000000000000000000452313172057505015345 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE BangPatterns #-} module Basement.Floating ( integerToDouble , naturalToDouble , doubleExponant , integerToFloat , naturalToFloat , wordToFloat , floatToWord , wordToDouble , doubleToWord ) where import GHC.Types import GHC.Prim import GHC.Float import GHC.Word import GHC.ST 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 wordToFloat :: Word32 -> Float wordToFloat (W32# x) = runST $ ST $ \s1 -> case newByteArray# 4# s1 of { (# s2, mbarr #) -> case writeWord32Array# mbarr 0# x s2 of { s3 -> case readFloatArray# mbarr 0# s3 of { (# s4, f #) -> (# s4, F# f #) }}} {-# INLINE wordToFloat #-} floatToWord :: Float -> Word32 floatToWord (F# x) = runST $ ST $ \s1 -> case newByteArray# 4# s1 of { (# s2, mbarr #) -> case writeFloatArray# mbarr 0# x s2 of { s3 -> case readWord32Array# mbarr 0# s3 of { (# s4, w #) -> (# s4, W32# w #) }}} {-# INLINE floatToWord #-} wordToDouble :: Word64 -> Double wordToDouble (W64# x) = runST $ ST $ \s1 -> case newByteArray# 8# s1 of { (# s2, mbarr #) -> case writeWord64Array# mbarr 0# x s2 of { s3 -> case readDoubleArray# mbarr 0# s3 of { (# s4, f #) -> (# s4, D# f #) }}} {-# INLINE wordToDouble #-} doubleToWord :: Double -> Word64 doubleToWord (D# x) = runST $ ST $ \s1 -> case newByteArray# 8# s1 of { (# s2, mbarr #) -> case writeDoubleArray# mbarr 0# x s2 of { s3 -> case readWord64Array# mbarr 0# s3 of { (# s4, w #) -> (# s4, W64# w #) }}} {-# INLINE doubleToWord #-} basement-0.0.4/Basement/Numerical/Number.hs0000644000000000000000000000411113162720757016747 0ustar0000000000000000module Basement.Numerical.Number ( IsIntegral(..) , IsNatural(..) ) where import Basement.Compat.Base import Basement.Compat.Natural import Data.Bits import qualified Prelude import Foreign.C.Types -- | Number literals, convertible through the generic Integer type. -- -- all number are Enum'erable, meaning that you can move to -- next element class (Enum a, Eq a, Ord a, Integral a) => IsIntegral a where {-# MINIMAL toInteger #-} toInteger :: a -> Integer -- | Non Negative Number literals, convertible through the generic Natural type class (Enum a, Eq a, Ord a, Integral a, IsIntegral a) => IsNatural a where {-# MINIMAL toNatural #-} toNatural :: a -> Natural instance IsIntegral Integer where toInteger i = i instance IsIntegral Int where toInteger i = Prelude.toInteger i instance IsIntegral Int8 where toInteger i = Prelude.toInteger i instance IsIntegral Int16 where toInteger i = Prelude.toInteger i instance IsIntegral Int32 where toInteger i = Prelude.toInteger i instance IsIntegral Int64 where toInteger i = Prelude.toInteger i instance IsIntegral Natural where toInteger i = Prelude.toInteger i instance IsIntegral Word where toInteger i = Prelude.toInteger i instance IsIntegral Word8 where toInteger i = Prelude.toInteger i instance IsIntegral Word16 where toInteger i = Prelude.toInteger i instance IsIntegral Word32 where toInteger i = Prelude.toInteger i instance IsIntegral Word64 where toInteger i = Prelude.toInteger i instance IsIntegral CSize where toInteger i = Prelude.toInteger i instance IsNatural Natural where toNatural i = i instance IsNatural Word where toNatural i = Prelude.fromIntegral i instance IsNatural Word8 where toNatural i = Prelude.fromIntegral i instance IsNatural Word16 where toNatural i = Prelude.fromIntegral i instance IsNatural Word32 where toNatural i = Prelude.fromIntegral i instance IsNatural Word64 where toNatural i = Prelude.fromIntegral i instance IsNatural CSize where toNatural i = Prelude.fromIntegral i basement-0.0.4/Basement/Numerical/Additive.hs0000644000000000000000000000737013201544137017250 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-prof-auto #-} 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 import Basement.Bounded import Basement.Nat import Basement.Types.Word128 (Word128) import Basement.Types.Word256 (Word256) import qualified Basement.Types.Word128 as Word128 import qualified Basement.Types.Word256 as Word256 #if WORD_SIZE_IN_BITS < 64 import GHC.IntWord64 #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 Word128 where azero = 0 (+) = (Word128.+) scale = scaleNum instance Additive Word256 where azero = 0 (+) = (Word256.+) 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 instance (KnownNat n, NatWithinBound Word64 n) => Additive (Zn64 n) where azero = zn64 0 (+) = (Prelude.+) scale = scaleNum instance KnownNat n => Additive (Zn n) where azero = zn 0 (+) = (Prelude.+) scale = scaleNum scaleNum :: (Prelude.Num a, IsNatural n) => n -> a -> a scaleNum n a = (Prelude.fromIntegral $ toNatural n) Prelude.* a basement-0.0.4/Basement/Numerical/Subtractive.hs0000644000000000000000000000556013201544137020011 0ustar0000000000000000{-# LANGUAGE UndecidableInstances #-} module Basement.Numerical.Subtractive ( Subtractive(..) ) where import Basement.Compat.Base import Basement.Compat.Natural import Basement.IntegralConv import Basement.Bounded import Basement.Nat import Basement.Types.Word128 (Word128) import Basement.Types.Word256 (Word256) import qualified Basement.Types.Word128 as Word128 import qualified Basement.Types.Word256 as Word256 import qualified Prelude -- | Represent class of things that can be subtracted. -- -- -- 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 Word128 where type Difference Word128 = Word128 (-) = (Word128.-) instance Subtractive Word256 where type Difference Word256 = Word256 (-) = (Word256.-) instance Subtractive Prelude.Float where type Difference Prelude.Float = Prelude.Float (-) = (Prelude.-) 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) instance (KnownNat n, NatWithinBound Word64 n) => Subtractive (Zn64 n) where type Difference (Zn64 n) = Zn64 n (-) a b = (Prelude.-) a b instance KnownNat n => Subtractive (Zn n) where type Difference (Zn n) = Zn n (-) a b = (Prelude.-) a b basement-0.0.4/Basement/Numerical/Multiplicative.hs0000644000000000000000000001150313162720757020515 0ustar0000000000000000{-# 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 Basement.Types.Word128 (Word128) import Basement.Types.Word256 (Word256) import qualified Basement.Types.Word128 as Word128 import qualified Basement.Types.Word256 as Word256 import qualified Prelude -- | Represent class of things that can be multiplied together -- -- > 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 Word128 where midentity = 1 (*) = (Word128.*) instance Multiplicative Word256 where midentity = 1 (*) = (Word256.*) 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 IDivisible Word128 where div = Word128.quot mod = Word128.rem instance IDivisible Word256 where div = Word256.quot mod = Word256.rem instance Divisible Prelude.Rational where (/) = (Prelude./) instance Divisible Float where (/) = (Prelude./) instance Divisible Double where (/) = (Prelude./) recip :: Divisible a => a -> a recip x = midentity / x power :: (IsNatural n, IDivisible n, Multiplicative a) => a -> n -> a power a n | n == 0 = midentity | otherwise = squaring midentity a n where squaring y x i | i == 0 = y | i == 1 = x * y | even i = squaring y (x*x) (i`div`2) | otherwise = squaring (x*y) (x*x) (pred i`div` 2) even :: (IDivisible n, IsIntegral n) => n -> Bool even n = (n `mod` 2) == 0 basement-0.0.4/Basement/Bounded.hs0000644000000000000000000000710313201544137015152 0ustar0000000000000000-- | -- 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 #-} {-# LANGUAGE UndecidableInstances #-} 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) instance (KnownNat n, NatWithinBound Word64 n) => Prelude.Num (Zn64 n) where fromInteger = zn64 . Prelude.fromInteger (+) = add64 (-) = sub64 (*) = mul64 abs a = a negate _ = error "cannot negate Zn64: use Foundation Numerical hierarchy for this function to not be exposed to Zn64" signum (Zn64 a) = Zn64 (Prelude.signum a) -- | 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) -- | Add 2 Zn64 add64 :: forall n . (KnownNat n, NatWithinBound Word64 n) => Zn64 n -> Zn64 n -> Zn64 n add64 (Zn64 a) (Zn64 b) = Zn64 ((a Prelude.+ b) `Prelude.mod` natValWord64 (Proxy :: Proxy n)) -- | subtract 2 Zn64 sub64 :: forall n . (KnownNat n, NatWithinBound Word64 n) => Zn64 n -> Zn64 n -> Zn64 n sub64 (Zn64 a) (Zn64 b) = Zn64 ((a Prelude.- b) `Prelude.mod` natValWord64 (Proxy :: Proxy n)) -- | Multiply 2 Zn64 mul64 :: forall n . (KnownNat n, NatWithinBound Word64 n) => Zn64 n -> Zn64 n -> Zn64 n mul64 (Zn64 a) (Zn64 b) = Zn64 ((a Prelude.* b) `Prelude.mod` natValWord64 (Proxy :: Proxy n)) -- | A type level bounded natural newtype Zn (n :: Nat) = Zn { unZn :: Natural } deriving (Show,Eq,Ord) instance KnownNat n => Prelude.Num (Zn n) where fromInteger = zn . Prelude.fromInteger (+) = add (-) = sub (*) = mul abs a = a negate _ = error "cannot negate Zn: use Foundation Numerical hierarchy for this function to not be exposed to Zn" signum = Zn . Prelude.signum . unZn -- | 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) -- | Add 2 Zn add :: forall n . KnownNat n => Zn n -> Zn n -> Zn n add (Zn a) (Zn b) = Zn ((a Prelude.+ b) `Prelude.mod` natValNatural (Proxy :: Proxy n)) -- | subtract 2 Zn sub :: forall n . KnownNat n => Zn n -> Zn n -> Zn n sub (Zn a) (Zn b) = Zn ((a Prelude.- b) `Prelude.mod` natValNatural (Proxy :: Proxy n)) -- | Multiply 2 Zn mul :: forall n . KnownNat n => Zn n -> Zn n -> Zn n mul (Zn a) (Zn b) = Zn ((a Prelude.* b) `Prelude.mod` natValNatural (Proxy :: Proxy n)) basement-0.0.4/Basement/Compat/Base.hs0000644000000000000000000000513313141321320015656 0ustar0000000000000000-- | -- 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 basement-0.0.4/Basement/Compat/Bifunctor.hs0000644000000000000000000000577713201626577017000 0ustar0000000000000000-- | -- Module : Basement.Compat.Bifunctor -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : portable -- -- A bifunctor is a type constructor that takes -- two type arguments and is a functor in /both/ arguments. That -- is, unlike with 'Functor', a type constructor such as 'Either' -- does not need to be partially applied for a 'Bifunctor' -- instance, and the methods in this class permit mapping -- functions over the 'Left' value or the 'Right' value, -- or both at the same time. -- -- 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@ -- -- ==== __Examples__ -- -- >>> bimap toUpper (+1) ('j', 3) -- ('J',4) -- -- >>> bimap toUpper (+1) (Left 'j') -- Left 'J' -- -- >>> bimap toUpper (+1) (Right 3) -- Right 4 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'@ -- -- ==== __Examples__ -- -- >>> first toUpper ('j', 3) -- ('J',3) -- -- >>> first toUpper (Left 'j') -- Left 'J' first :: (a -> b) -> p a c -> p b c first f = bimap f P.id -- | Map covariantly over the second argument. -- -- @'second' ≡ 'bimap' 'id'@ -- -- ==== __Examples__ -- >>> second (+1) ('j', 3) -- ('j',4) -- -- >>> second (+1) (Right 3) -- Right 4 second :: (b -> c) -> p a b -> p a c second = bimap P.id instance Bifunctor (,) where bimap f g ~(a, b) = (f a, g b) instance Bifunctor ((,,) x1) where bimap f g ~(x1, a, b) = (x1, f a, g b) instance Bifunctor ((,,,) x1 x2) where bimap f g ~(x1, x2, a, b) = (x1, x2, f a, g b) instance Bifunctor ((,,,,) x1 x2 x3) where bimap f g ~(x1, x2, x3, a, b) = (x1, x2, x3, f a, g b) instance Bifunctor ((,,,,,) x1 x2 x3 x4) where bimap f g ~(x1, x2, x3, x4, a, b) = (x1, x2, x3, x4, f a, g b) instance Bifunctor ((,,,,,,) x1 x2 x3 x4 x5) where bimap f g ~(x1, x2, x3, x4, x5, a, b) = (x1, x2, x3, x4, x5, f a, g b) instance Bifunctor P.Either where bimap f _ (P.Left a) = P.Left (f a) bimap _ g (P.Right b) = P.Right (g b) instance Bifunctor Const where bimap f _ (Const a) = Const (f a) instance Bifunctor (K1 i) where bimap f _ (K1 c) = K1 (f c) #endif basement-0.0.4/Basement/Compat/CallStack.hs0000644000000000000000000000063513141321320016647 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE ConstraintKinds #-} module Basement.Compat.CallStack ( HasCallStack ) where #if MIN_VERSION_base(4,9,0) import GHC.Stack (HasCallStack) #elif MIN_VERSION_base(4,8,1) import qualified GHC.Stack type HasCallStack = (?callStack :: GHC.Stack.CallStack) #else import GHC.Exts (Constraint) type HasCallStack = (() :: Constraint) #endif basement-0.0.4/Basement/Compat/ExtList.hs0000644000000000000000000000173313172057505016421 0ustar0000000000000000{-# LANGUAGE CPP #-} module Basement.Compat.ExtList ( length , null , sum , reverse , (!!) ) where import Basement.Compat.Base import Basement.Numerical.Additive import Basement.Types.OffsetSize import qualified GHC.List as List -- | Compute the size of the list length :: [a] -> CountOf a #if MIN_VERSION_base(4,8,0) length = CountOf . List.foldl' (\c _ -> c+1) 0 #else length = CountOf . 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) (!!) :: [a] -> Offset a -> a [] !! _ = error "invalid offset for !!" (x:_) !! 0 = x (_:xs) !! i = xs !! pred i basement-0.0.4/Basement/Compat/IsList.hs0000644000000000000000000000126513141321320016215 0ustar0000000000000000-- | -- 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 basement-0.0.4/Basement/Compat/Identity.hs0000644000000000000000000000151713141321320016577 0ustar0000000000000000-- | -- 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 basement-0.0.4/Basement/Compat/Primitive.hs0000644000000000000000000001325713141321320016762 0ustar0000000000000000-- | -- 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 basement-0.0.4/Basement/Compat/PrimTypes.hs0000644000000000000000000000136313141321320016741 0ustar0000000000000000-- | -- 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# basement-0.0.4/Basement/Compat/MonadTrans.hs0000644000000000000000000000304013141321320017045 0ustar0000000000000000-- | -- Module : Basement.Compat.MonadTrans -- License : BSD-style -- Maintainer : Psychohistorians -- Stability : experimental -- Portability : portable -- -- An internal and really simple monad transformers, -- without any bells and whistse. module Basement.Compat.MonadTrans ( State(..) , Reader(..) ) where import Basement.Compat.Base import Control.Monad ((>=>)) -- | Simple State monad newtype State s m a = State { runState :: s -> m (a, s) } instance Monad m => Functor (State s m) where fmap f fa = State $ runState fa >=> (\(a, s2) -> return (f a, s2)) instance Monad m => Applicative (State s m) where pure a = State $ \st -> return (a,st) fab <*> fa = State $ \s1 -> do (ab,s2) <- runState fab s1 (a,s3) <- runState fa s2 return (ab a, s3) instance Monad m => Monad (State r m) where return a = State $ \st -> return (a,st) ma >>= mb = State $ \s1 -> do (a,s2) <- runState ma s1 runState (mb a) s2 -- | Simple Reader monad newtype Reader r m a = Reader { runReader :: r -> m a } instance Monad m => Functor (Reader r m) where fmap f fa = Reader $ runReader fa >=> (\a -> return (f a)) instance Monad m => Applicative (Reader r m) where pure a = Reader $ \_ -> return a fab <*> fa = Reader $ \r -> do a <- runReader fa r ab <- runReader fab r return $ ab a instance Monad m => Monad (Reader r m) where return a = Reader $ \_ -> return a ma >>= mb = Reader $ \r -> do a <- runReader ma r runReader (mb a) r basement-0.0.4/Basement/Compat/Semigroup.hs0000644000000000000000000001166513201626066017001 0ustar0000000000000000{-# LANGUAGE CPP #-} #if !(MIN_VERSION_base(4,9,0)) {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} #endif module Basement.Compat.Semigroup ( Semigroup(..) , ListNonEmpty(..) ) where #if MIN_VERSION_base(4,9,0) import Data.Semigroup import qualified Data.List.NonEmpty as LNE type ListNonEmpty = LNE.NonEmpty #else import Prelude import Data.Data (Data) import Data.Monoid (Monoid(..)) import GHC.Generics (Generic) import Data.Typeable -- errorWithoutStackTrace infixr 6 <> infixr 5 :| data ListNonEmpty a = a :| [a] deriving ( Eq, Ord, Show, Read, Data, Typeable, Generic ) -- | The class of semigroups (types with an associative binary operation). -- -- @since 4.9.0.0 class Semigroup a where -- | An associative operation. -- -- @ -- (a '<>' b) '<>' c = a '<>' (b '<>' c) -- @ -- -- If @a@ is also a 'Monoid' we further require -- -- @ -- ('<>') = 'mappend' -- @ (<>) :: a -> a -> a default (<>) :: Monoid a => a -> a -> a (<>) = mappend -- | Reduce a non-empty list with @\<\>@ -- -- The default definition should be sufficient, but this can be -- overridden for efficiency. -- sconcat :: ListNonEmpty a -> a sconcat (a :| as) = go a as where go b (c:cs) = b <> go c cs go b [] = b -- | Repeat a value @n@ times. -- -- Given that this works on a 'Semigroup' it is allowed to fail if -- you request 0 or fewer repetitions, and the default definition -- will do so. -- -- By making this a member of the class, idempotent semigroups and monoids can -- upgrade this to execute in /O(1)/ by picking -- @stimes = stimesIdempotent@ or @stimes = stimesIdempotentMonoid@ -- respectively. stimes :: Integral b => b -> a -> a stimes y0 x0 | y0 <= 0 = errorWithoutStackTrace "stimes: positive multiplier expected" | otherwise = f x0 y0 where f x y | even y = f (x <> x) (y `quot` 2) | y == 1 = x | otherwise = g (x <> x) (pred y `quot` 2) x g x y z | even y = g (x <> x) (y `quot` 2) z | y == 1 = x <> z | otherwise = g (x <> x) (pred y `quot` 2) (x <> z) instance Semigroup a => Semigroup (Maybe a) where Nothing <> b = b a <> Nothing = a Just a <> Just b = Just (a <> b) stimes _ Nothing = Nothing stimes n (Just a) = case compare n 0 of LT -> errorWithoutStackTrace "stimes: Maybe, negative multiplier" EQ -> Nothing GT -> Just (stimes n a) instance Semigroup [a] where (<>) = (++) instance Semigroup (Either a b) where Left _ <> b = b a <> _ = a stimes = stimesIdempotent instance (Semigroup a, Semigroup b) => Semigroup (a, b) where (a,b) <> (a',b') = (a<>a',b<>b') stimes n (a,b) = (stimes n a, stimes n b) instance (Semigroup a, Semigroup b, Semigroup c) => Semigroup (a, b, c) where (a,b,c) <> (a',b',c') = (a<>a',b<>b',c<>c') stimes n (a,b,c) = (stimes n a, stimes n b, stimes n c) instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d) => Semigroup (a, b, c, d) where (a,b,c,d) <> (a',b',c',d') = (a<>a',b<>b',c<>c',d<>d') stimes n (a,b,c,d) = (stimes n a, stimes n b, stimes n c, stimes n d) instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d, Semigroup e) => Semigroup (a, b, c, d, e) where (a,b,c,d,e) <> (a',b',c',d',e') = (a<>a',b<>b',c<>c',d<>d',e<>e') stimes n (a,b,c,d,e) = (stimes n a, stimes n b, stimes n c, stimes n d, stimes n e) -- | This is a valid definition of 'stimes' for a 'Monoid'. -- -- Unlike the default definition of 'stimes', it is defined for 0 -- and so it should be preferred where possible. stimesMonoid :: (Integral b, Monoid a) => b -> a -> a stimesMonoid n x0 = case compare n 0 of LT -> errorWithoutStackTrace "stimesMonoid: negative multiplier" EQ -> mempty GT -> f x0 n where f x y | even y = f (x `mappend` x) (y `quot` 2) | y == 1 = x | otherwise = g (x `mappend` x) (pred y `quot` 2) x g x y z | even y = g (x `mappend` x) (y `quot` 2) z | y == 1 = x `mappend` z | otherwise = g (x `mappend` x) (pred y `quot` 2) (x `mappend` z) -- | This is a valid definition of 'stimes' for an idempotent 'Monoid'. -- -- When @mappend x x = x@, this definition should be preferred, because it -- works in /O(1)/ rather than /O(log n)/ stimesIdempotentMonoid :: (Integral b, Monoid a) => b -> a -> a stimesIdempotentMonoid n x = case compare n 0 of LT -> errorWithoutStackTrace "stimesIdempotentMonoid: negative multiplier" EQ -> mempty GT -> x -- | This is a valid definition of 'stimes' for an idempotent 'Semigroup'. -- -- When @x <> x = x@, this definition should be preferred, because it -- works in /O(1)/ rather than /O(log n)/. stimesIdempotent :: Integral b => b -> a -> a stimesIdempotent n x | n <= 0 = errorWithoutStackTrace "stimesIdempotent: positive multiplier expected" | otherwise = x #if !MIN_VERSION_base(4,9,0) errorWithoutStackTrace = error #endif #endif basement-0.0.4/Basement/Compat/Natural.hs0000644000000000000000000000327013162720757016436 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Basement.Compat.Natural ( Natural , integerToNatural , naturalToInteger ) where #if MIN_VERSION_base(4,8,0) import Numeric.Natural import Prelude (Integer, abs, fromInteger, toInteger) #else import Prelude (Show(..),Eq,Ord,Enum,Num(..),Real(..),Integral(..),Integer,error,(<), (>), otherwise, toInteger) import Data.Bits import Data.Typeable newtype Natural = Natural Integer deriving (Eq,Ord,Enum,Typeable,Bits) 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) naturalToInteger :: Natural -> Integer naturalToInteger n = toInteger n basement-0.0.4/Basement/Compat/NumLiteral.hs0000644000000000000000000001041413201626577017101 0ustar0000000000000000-- | -- 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 Foreign.Ptr (IntPtr) 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 IntPtr where fromInteger a = Prelude.fromInteger a instance Integral CSize where fromInteger a = Prelude.fromInteger a instance Integral CShort where fromInteger a = Prelude.fromInteger a instance Integral CUShort where fromInteger a = Prelude.fromInteger a instance Integral CInt where fromInteger a = Prelude.fromInteger a instance Integral CUInt where fromInteger a = Prelude.fromInteger a instance Integral CLong where fromInteger a = Prelude.fromInteger a instance Integral CULong 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 CIntPtr where fromInteger a = Prelude.fromInteger a instance Integral Float where fromInteger a = Prelude.fromInteger a instance Integral Double where fromInteger a = Prelude.fromInteger a instance Integral CFloat where fromInteger a = Prelude.fromInteger a instance Integral CDouble where fromInteger a = Prelude.fromInteger a instance HasNegation Integer where negate = Prelude.negate instance HasNegation Int where negate = Prelude.negate instance HasNegation Int8 where negate = Prelude.negate instance HasNegation Int16 where negate = Prelude.negate instance HasNegation Int32 where negate = Prelude.negate instance HasNegation Int64 where negate = Prelude.negate instance HasNegation Word where negate = Prelude.negate instance HasNegation Word8 where negate = Prelude.negate instance HasNegation Word16 where negate = Prelude.negate instance HasNegation Word32 where negate = Prelude.negate instance HasNegation Word64 where negate = Prelude.negate instance HasNegation CInt where negate = Prelude.negate instance HasNegation Float where negate = Prelude.negate instance HasNegation Double where negate = Prelude.negate instance HasNegation CFloat where negate = Prelude.negate instance HasNegation CDouble where negate = Prelude.negate instance Fractional Rational where fromRational a = Prelude.fromRational a instance Fractional Float where fromRational a = Prelude.fromRational a instance Fractional Double where fromRational a = Prelude.fromRational a instance Fractional CFloat where fromRational a = Prelude.fromRational a instance Fractional CDouble where fromRational a = Prelude.fromRational a basement-0.0.4/Basement/Compat/Typeable.hs0000644000000000000000000000146413141321320016554 0ustar0000000000000000-- | -- 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 basement-0.0.4/Basement/BlockN.hs0000644000000000000000000000032213172057505014743 0ustar0000000000000000-- | -- Module : Basement.Block -- License : BSD-style -- Maintainer : Haskell Foundation -- -- A Nat-sized version of Block module Basement.BlockN (module X) where import Basement.Sized.Block as X basement-0.0.4/Basement/Sized/Block.hs0000644000000000000000000001177013201544137015707 0ustar0000000000000000-- | -- Module : Basement.Sized.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 #-} {-# LANGUAGE ConstraintKinds #-} module Basement.Sized.Block ( BlockN , MutableBlockN , toBlockN , toBlock , singleton , replicate , thaw , freeze , index , indexStatic , 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.Types.OffsetSize import Basement.NormalForm import Basement.PrimType (PrimType) import Basement.Types.OffsetSize (CountOf(..), Offset(..), offsetSub) newtype BlockN (n :: Nat) a = BlockN { unBlock :: Block a } deriving (NormalForm, Eq, Show) newtype MutableBlockN (n :: Nat) ty st = MutableBlockN { unMBlock :: MutableBlock ty st } toBlockN :: forall n ty . (PrimType ty, KnownNat n, Countable ty 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, Countable ty n, PrimType ty) => ty -> BlockN n ty replicate a = BlockN (B.replicate (toCount @n) a) thaw :: (KnownNat n, PrimMonad prim, PrimType ty) => BlockN n ty -> prim (MutableBlockN n ty (PrimState prim)) thaw b = MutableBlockN <$> B.thaw (unBlock b) freeze :: (PrimMonad prim, PrimType ty, Countable ty n) => MutableBlockN n ty (PrimState prim) -> prim (BlockN n ty) freeze b = BlockN <$> B.freeze (unMBlock b) indexStatic :: forall i n ty . (KnownNat i, CmpNat i n ~ 'LT, PrimType ty, Offsetable ty i) => BlockN n ty -> ty indexStatic b = unsafeIndex (unBlock b) (toOffset @i) index :: forall i n ty . PrimType ty => BlockN n ty -> Offset ty -> ty index b ofs = B.index (unBlock b) ofs 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 , KnownNat j , Offsetable ty i , Offsetable ty j ) => BlockN n ty -> BlockN (j-i) ty sub block = BlockN (B.sub (unBlock block) (toOffset @i) (toOffset @j)) uncons :: forall n ty . (CmpNat 0 n ~ 'LT, PrimType ty, KnownNat n, Offsetable ty n) => BlockN n ty -> (ty, BlockN (n-1) ty) uncons b = (indexStatic @0 b, BlockN (B.sub (unBlock b) 1 (toOffset @n))) unsnoc :: forall n ty . (CmpNat 0 n ~ 'LT, KnownNat n, PrimType ty, Offsetable ty n) => BlockN n ty -> (BlockN (n-1) ty, ty) unsnoc b = ( BlockN (B.sub (unBlock b) 0 (toOffset @n `offsetSub` 1)) , unsafeIndex (unBlock b) (toOffset @n `offsetSub` 1)) splitAt :: forall i n ty . (CmpNat i n ~ 'LT, PrimType ty, KnownNat i, Countable ty i) => BlockN n ty -> (BlockN i ty, BlockN (n-i) ty) splitAt b = let (left, right) = B.splitAt (toCount @i) (unBlock b) in (BlockN left, BlockN right) 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, Countable ty n) => CountOf ty toCount = natValCountOf (Proxy @n) toOffset :: forall n ty . (KnownNat n, Offsetable ty n) => Offset ty toOffset = natValOffset (Proxy @n) basement-0.0.4/Basement/Sized/UVect.hs0000644000000000000000000001216213172057505015704 0ustar0000000000000000{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ConstraintKinds #-} module Basement.Sized.UVect ( UVect , MUVect , unUVect , toUVect , empty , singleton , replicate , thaw , freeze , index , map , foldl' , foldr , cons , snoc , elem , sub , uncons , unsnoc , splitAt , all , any , find , reverse , sortBy , intersperse ) where import Basement.Compat.Base import Basement.Nat import Basement.NormalForm import Basement.Types.OffsetSize import Basement.Monad import Basement.PrimType (PrimType) import qualified Basement.UArray as A import qualified Basement.UArray.Mutable as A hiding (sub) import Data.Proxy newtype UVect (n :: Nat) a = UVect { unUVect :: A.UArray a } deriving (NormalForm, Eq, Show) newtype MUVect (n :: Nat) ty st = MUVect { unMUVect :: A.MUArray ty st } toUVect :: forall n ty . (PrimType ty, KnownNat n, Countable ty n) => A.UArray ty -> Maybe (UVect n ty) toUVect b | expected == A.length b = Just (UVect b) | otherwise = Nothing where expected = toCount @n empty :: PrimType ty => UVect 0 ty empty = UVect mempty singleton :: PrimType ty => ty -> UVect 1 ty singleton a = UVect (A.singleton a) create :: forall ty (n :: Nat) . (PrimType ty, Countable ty n, KnownNat n) => (Offset ty -> ty) -> UVect n ty create f = UVect $ A.create sz f where sz = natValCountOf (Proxy :: Proxy n) replicate :: forall n ty . (KnownNat n, Countable ty n, PrimType ty) => ty -> UVect n ty replicate a = UVect (A.replicate (toCount @n) a) thaw :: (KnownNat n, PrimMonad prim, PrimType ty) => UVect n ty -> prim (MUVect n ty (PrimState prim)) thaw b = MUVect <$> A.thaw (unUVect b) freeze :: (PrimMonad prim, PrimType ty, Countable ty n) => MUVect n ty (PrimState prim) -> prim (UVect n ty) freeze b = UVect <$> A.freeze (unMUVect b) write :: (PrimMonad prim, PrimType ty) => MUVect n ty (PrimState prim) -> Offset ty -> ty -> prim () write (MUVect ma) ofs v = A.write ma ofs v read :: (PrimMonad prim, PrimType ty) => MUVect n ty (PrimState prim) -> Offset ty -> prim ty read (MUVect ma) ofs = A.read ma ofs indexStatic :: forall i n ty . (KnownNat i, CmpNat i n ~ 'LT, PrimType ty, Offsetable ty i) => UVect n ty -> ty indexStatic b = A.unsafeIndex (unUVect b) (toOffset @i) index :: forall i n ty . PrimType ty => UVect n ty -> Offset ty -> ty index b ofs = A.index (unUVect b) ofs map :: (PrimType a, PrimType b) => (a -> b) -> UVect n a -> UVect n b map f b = UVect (A.map f (unUVect b)) foldl' :: PrimType ty => (a -> ty -> a) -> a -> UVect n ty -> a foldl' f acc b = A.foldl' f acc (unUVect b) foldr :: PrimType ty => (ty -> a -> a) -> a -> UVect n ty -> a foldr f acc b = A.foldr f acc (unUVect b) cons :: PrimType ty => ty -> UVect n ty -> UVect (n+1) ty cons e = UVect . A.cons e . unUVect snoc :: PrimType ty => UVect n ty -> ty -> UVect (n+1) ty snoc b = UVect . A.snoc (unUVect b) sub :: forall i j n ty . ( (i <=? n) ~ 'True , (j <=? n) ~ 'True , (i <=? j) ~ 'True , PrimType ty , KnownNat i , KnownNat j , Offsetable ty i , Offsetable ty j ) => UVect n ty -> UVect (j-i) ty sub block = UVect (A.sub (unUVect block) (toOffset @i) (toOffset @j)) uncons :: forall n ty . (CmpNat 0 n ~ 'LT, PrimType ty, KnownNat n, Offsetable ty n) => UVect n ty -> (ty, UVect (n-1) ty) uncons b = (indexStatic @0 b, UVect (A.sub (unUVect b) 1 (toOffset @n))) unsnoc :: forall n ty . (CmpNat 0 n ~ 'LT, KnownNat n, PrimType ty, Offsetable ty n) => UVect n ty -> (UVect (n-1) ty, ty) unsnoc b = ( UVect (A.sub (unUVect b) 0 (toOffset @n `offsetSub` 1)) , A.unsafeIndex (unUVect b) (toOffset @n `offsetSub` 1)) splitAt :: forall i n ty . (CmpNat i n ~ 'LT, PrimType ty, KnownNat i, Countable ty i) => UVect n ty -> (UVect i ty, UVect (n-i) ty) splitAt b = let (left, right) = A.splitAt (toCount @i) (unUVect b) in (UVect left, UVect right) elem :: PrimType ty => ty -> UVect n ty -> Bool elem e b = A.elem e (unUVect b) all :: PrimType ty => (ty -> Bool) -> UVect n ty -> Bool all p b = A.all p (unUVect b) any :: PrimType ty => (ty -> Bool) -> UVect n ty -> Bool any p b = A.any p (unUVect b) find :: PrimType ty => (ty -> Bool) -> UVect n ty -> Maybe ty find p b = A.find p (unUVect b) reverse :: PrimType ty => UVect n ty -> UVect n ty reverse = UVect . A.reverse . unUVect sortBy :: PrimType ty => (ty -> ty -> Ordering) -> UVect n ty -> UVect n ty sortBy f b = UVect (A.sortBy f (unUVect b)) intersperse :: (CmpNat n 1 ~ 'GT, PrimType ty) => ty -> UVect n ty -> UVect (n+n-1) ty intersperse sep b = UVect (A.intersperse sep (unUVect b)) toCount :: forall n ty . (KnownNat n, Countable ty n) => CountOf ty toCount = natValCountOf (Proxy @n) toOffset :: forall n ty . (KnownNat n, Offsetable ty n) => Offset ty toOffset = natValOffset (Proxy @n) basement-0.0.4/Basement/Sized/Vect.hs0000644000000000000000000001123613172057505015560 0ustar0000000000000000{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ConstraintKinds #-} module Basement.Sized.Vect ( Vect , MVect , unVect , toVect , empty , singleton , replicate , thaw , freeze , index , map , foldl' , foldr , cons , snoc , elem , sub , uncons , unsnoc , splitAt , all , any , find , reverse , sortBy , intersperse ) where import Basement.Compat.Base import Basement.Nat import Basement.NormalForm import Basement.Types.OffsetSize import Basement.Monad import Basement.PrimType (PrimType) import qualified Basement.BoxedArray as A --import qualified Basement.BoxedArray.Mutable as A hiding (sub) import Data.Proxy newtype Vect (n :: Nat) a = Vect { unVect :: A.Array a } deriving (NormalForm, Eq, Show) newtype MVect (n :: Nat) ty st = MVect { unMVect :: A.MArray ty st } instance Functor (Vect n) where fmap = map toVect :: forall n ty . (KnownNat n, Countable ty n) => A.Array ty -> Maybe (Vect n ty) toVect b | expected == A.length b = Just (Vect b) | otherwise = Nothing where expected = toCount @n empty :: Vect 0 ty empty = Vect A.empty singleton :: ty -> Vect 1 ty singleton a = Vect (A.singleton a) create :: forall a (n :: Nat) . (Countable a n, KnownNat n) => (Offset a -> a) -> Vect n a create f = Vect $ A.create sz f where sz = natValCountOf (Proxy :: Proxy n) replicate :: forall n ty . (KnownNat n, Countable ty n) => ty -> Vect n ty replicate a = Vect (A.replicate (toCount @n) a) thaw :: (KnownNat n, PrimMonad prim) => Vect n ty -> prim (MVect n ty (PrimState prim)) thaw b = MVect <$> A.thaw (unVect b) freeze :: (PrimMonad prim, Countable ty n) => MVect n ty (PrimState prim) -> prim (Vect n ty) freeze b = Vect <$> A.freeze (unMVect b) write :: PrimMonad prim => MVect n ty (PrimState prim) -> Offset ty -> ty -> prim () write (MVect ma) ofs v = A.write ma ofs v read :: PrimMonad prim => MVect n ty (PrimState prim) -> Offset ty -> prim ty read (MVect ma) ofs = A.read ma ofs indexStatic :: forall i n ty . (KnownNat i, CmpNat i n ~ 'LT, Offsetable ty i) => Vect n ty -> ty indexStatic b = A.unsafeIndex (unVect b) (toOffset @i) index :: Vect n ty -> Offset ty -> ty index b ofs = A.index (unVect b) ofs map :: (a -> b) -> Vect n a -> Vect n b map f b = Vect (fmap f (unVect b)) foldl' :: (a -> ty -> a) -> a -> Vect n ty -> a foldl' f acc b = A.foldl' f acc (unVect b) foldr :: (ty -> a -> a) -> a -> Vect n ty -> a foldr f acc b = A.foldr f acc (unVect b) cons :: ty -> Vect n ty -> Vect (n+1) ty cons e = Vect . A.cons e . unVect snoc :: Vect n ty -> ty -> Vect (n+1) ty snoc b = Vect . A.snoc (unVect b) sub :: forall i j n ty . ( (i <=? n) ~ 'True , (j <=? n) ~ 'True , (i <=? j) ~ 'True , KnownNat i , KnownNat j , Offsetable ty i , Offsetable ty j ) => Vect n ty -> Vect (j-i) ty sub block = Vect (A.sub (unVect block) (toOffset @i) (toOffset @j)) uncons :: forall n ty . (CmpNat 0 n ~ 'LT, KnownNat n, Offsetable ty n) => Vect n ty -> (ty, Vect (n-1) ty) uncons b = (indexStatic @0 b, Vect (A.sub (unVect b) 1 (toOffset @n))) unsnoc :: forall n ty . (CmpNat 0 n ~ 'LT, KnownNat n, Offsetable ty n) => Vect n ty -> (Vect (n-1) ty, ty) unsnoc b = ( Vect (A.sub (unVect b) 0 (toOffset @n `offsetSub` 1)) , A.unsafeIndex (unVect b) (toOffset @n `offsetSub` 1)) splitAt :: forall i n ty . (CmpNat i n ~ 'LT, KnownNat i, Countable ty i) => Vect n ty -> (Vect i ty, Vect (n-i) ty) splitAt b = let (left, right) = A.splitAt (toCount @i) (unVect b) in (Vect left, Vect right) elem :: Eq ty => ty -> Vect n ty -> Bool elem e b = A.elem e (unVect b) all :: (ty -> Bool) -> Vect n ty -> Bool all p b = A.all p (unVect b) any :: (ty -> Bool) -> Vect n ty -> Bool any p b = A.any p (unVect b) find :: (ty -> Bool) -> Vect n ty -> Maybe ty find p b = A.find p (unVect b) reverse :: Vect n ty -> Vect n ty reverse = Vect . A.reverse . unVect sortBy :: (ty -> ty -> Ordering) -> Vect n ty -> Vect n ty sortBy f b = Vect (A.sortBy f (unVect b)) intersperse :: (CmpNat n 1 ~ 'GT) => ty -> Vect n ty -> Vect (n+n-1) ty intersperse sep b = Vect (A.intersperse sep (unVect b)) toCount :: forall n ty . (KnownNat n, Countable ty n) => CountOf ty toCount = natValCountOf (Proxy @n) toOffset :: forall n ty . (KnownNat n, Offsetable ty n) => Offset ty toOffset = natValOffset (Proxy @n) basement-0.0.4/Basement/Sized/List.hs0000644000000000000000000001776613172057505015610 0ustar0000000000000000-- | -- Module : Basement.Sized.List -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : portable -- -- A Nat-sized list abstraction -- -- Using this module is limited to GHC 7.10 and above. -- {-# LANGUAGE KindSignatures #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE AllowAmbiguousTypes #-} module Basement.Sized.List ( ListN , toListN , unListN , length , create , createFrom , empty , singleton , uncons , cons , index , indexStatic , map , elem , foldl , foldl' , foldr , append , minimum , maximum , head , tail , take , drop , splitAt , zip, zip3, zip4, zip5 , zipWith, zipWith3, zipWith4, zipWith5 , replicate -- * Applicative And Monadic , replicateM , mapM , mapM_ ) where import Data.Proxy import qualified Data.List import Basement.Compat.Base import Basement.Nat import Basement.NormalForm import Basement.Numerical.Additive import Basement.Numerical.Subtractive import Basement.Types.OffsetSize import Basement.Compat.ExtList ((!!)) import qualified Prelude import qualified Control.Monad as M (replicateM, mapM, mapM_) impossible :: a impossible = error "ListN: internal error: the impossible happened" newtype ListN (n :: Nat) a = ListN { unListN :: [a] } deriving (Eq,Ord) instance Show a => Show (ListN n a) where show (ListN l) = show l instance NormalForm a => NormalForm (ListN n a) where toNormalForm (ListN l) = toNormalForm l toListN :: forall (n :: Nat) a . (KnownNat n, NatWithinBound Int n) => [a] -> Maybe (ListN n a) toListN l | expected == Prelude.fromIntegral (Prelude.length l) = Just (ListN l) | otherwise = Nothing where expected = natValInt (Proxy :: Proxy n) replicateM :: forall (n :: Nat) m a . (NatWithinBound Int n, Monad m, KnownNat n) => m a -> m (ListN n a) replicateM action = ListN <$> M.replicateM (Prelude.fromIntegral $ natVal (Proxy :: Proxy n)) action mapM :: Monad m => (a -> m b) -> ListN n a -> m (ListN n b) mapM f (ListN l) = ListN <$> M.mapM f l mapM_ :: Monad m => (a -> m b) -> ListN n a -> m () mapM_ f (ListN l) = M.mapM_ f l replicate :: forall (n :: Nat) a . (NatWithinBound Int n, KnownNat n) => a -> ListN n a replicate a = ListN $ Prelude.replicate (Prelude.fromIntegral $ natVal (Proxy :: Proxy n)) a uncons :: CmpNat n 0 ~ 'GT => ListN n a -> (a, ListN (n-1) a) uncons (ListN (x:xs)) = (x, ListN xs) uncons _ = impossible cons :: a -> ListN n a -> ListN (n+1) a cons a (ListN l) = ListN (a : l) empty :: ListN 0 a empty = ListN [] length :: forall a (n :: Nat) . (KnownNat n, NatWithinBound Int n) => ListN n a -> Int length _ = natValInt (Proxy :: Proxy n) create :: forall a (n :: Nat) . KnownNat n => (Integer -> a) -> ListN n a create f = ListN $ Prelude.map f [0..(len-1)] where len = natVal (Proxy :: Proxy n) createFrom :: forall a (n :: Nat) (start :: Nat) . (KnownNat n, KnownNat start) => Proxy start -> (Integer -> a) -> ListN n a createFrom p f = ListN $ Prelude.map f [idx..(idx+len-1)] where len = natVal (Proxy :: Proxy n) idx = natVal p singleton :: a -> ListN 1 a singleton a = ListN [a] elem :: Eq a => a -> ListN n a -> Bool elem a (ListN l) = Prelude.elem a l append :: ListN n a -> ListN m a -> ListN (n+m) a append (ListN l1) (ListN l2) = ListN (l1 <> l2) maximum :: (Ord a, CmpNat n 0 ~ 'GT) => ListN n a -> a maximum (ListN l) = Prelude.maximum l minimum :: (Ord a, CmpNat n 0 ~ 'GT) => ListN n a -> a minimum (ListN l) = Prelude.minimum l head :: CmpNat n 0 ~ 'GT => ListN n a -> a head (ListN (x:_)) = x head _ = impossible tail :: CmpNat n 0 ~ 'GT => ListN n a -> ListN (n-1) a tail (ListN (_:xs)) = ListN xs tail _ = impossible take :: forall a (m :: Nat) (n :: Nat) . (KnownNat m, NatWithinBound Int m, m <= n) => ListN n a -> ListN m a take (ListN l) = ListN (Prelude.take n l) where n = natValInt (Proxy :: Proxy m) drop :: forall a d (m :: Nat) (n :: Nat) . (KnownNat d, NatWithinBound Int d, (n - m) ~ d, m <= n) => ListN n a -> ListN m a drop (ListN l) = ListN (Prelude.drop n l) where n = natValInt (Proxy :: Proxy d) splitAt :: forall a d (m :: Nat) (n :: Nat) . (KnownNat d, NatWithinBound Int d, (n - m) ~ d, m <= n) => ListN n a -> (ListN m a, ListN (n-m) a) splitAt (ListN l) = let (l1, l2) = Prelude.splitAt n l in (ListN l1, ListN l2) where n = natValInt (Proxy :: Proxy d) indexStatic :: forall i n a . (KnownNat i, CmpNat i n ~ 'LT, Offsetable a i) => ListN n a -> a indexStatic (ListN l) = l !! (natValOffset (Proxy :: Proxy i)) index :: ListN n ty -> Offset ty -> ty index (ListN l) ofs = l !! ofs map :: (a -> b) -> ListN n a -> ListN n b map f (ListN l) = ListN (Prelude.map f l) foldl :: (b -> a -> b) -> b -> ListN n a -> b foldl f acc (ListN l) = Prelude.foldl f acc l foldl' :: (b -> a -> b) -> b -> ListN n a -> b foldl' f acc (ListN l) = Data.List.foldl' f acc l foldr :: (a -> b -> b) -> b -> ListN n a -> b foldr f acc (ListN l) = Prelude.foldr f acc l zip :: ListN n a -> ListN n b -> ListN n (a,b) zip (ListN l1) (ListN l2) = ListN (Prelude.zip l1 l2) zip3 :: ListN n a -> ListN n b -> ListN n c -> ListN n (a,b,c) zip3 (ListN x1) (ListN x2) (ListN x3) = ListN (loop x1 x2 x3) where loop (l1:l1s) (l2:l2s) (l3:l3s) = (l1,l2,l3) : loop l1s l2s l3s loop [] _ _ = [] loop _ _ _ = impossible zip4 :: ListN n a -> ListN n b -> ListN n c -> ListN n d -> ListN n (a,b,c,d) zip4 (ListN x1) (ListN x2) (ListN x3) (ListN x4) = ListN (loop x1 x2 x3 x4) where loop (l1:l1s) (l2:l2s) (l3:l3s) (l4:l4s) = (l1,l2,l3,l4) : loop l1s l2s l3s l4s loop [] _ _ _ = [] loop _ _ _ _ = impossible zip5 :: ListN n a -> ListN n b -> ListN n c -> ListN n d -> ListN n e -> ListN n (a,b,c,d,e) zip5 (ListN x1) (ListN x2) (ListN x3) (ListN x4) (ListN x5) = ListN (loop x1 x2 x3 x4 x5) where loop (l1:l1s) (l2:l2s) (l3:l3s) (l4:l4s) (l5:l5s) = (l1,l2,l3,l4,l5) : loop l1s l2s l3s l4s l5s loop [] _ _ _ _ = [] loop _ _ _ _ _ = impossible zipWith :: (a -> b -> x) -> ListN n a -> ListN n b -> ListN n x zipWith f (ListN (v1:vs)) (ListN (w1:ws)) = ListN (f v1 w1 : unListN (zipWith f (ListN vs) (ListN ws))) zipWith _ (ListN []) _ = ListN [] zipWith _ _ _ = impossible zipWith3 :: (a -> b -> c -> x) -> ListN n a -> ListN n b -> ListN n c -> ListN n x zipWith3 f (ListN (v1:vs)) (ListN (w1:ws)) (ListN (x1:xs)) = ListN (f v1 w1 x1 : unListN (zipWith3 f (ListN vs) (ListN ws) (ListN xs))) zipWith3 _ (ListN []) _ _ = ListN [] zipWith3 _ _ _ _ = impossible zipWith4 :: (a -> b -> c -> d -> x) -> ListN n a -> ListN n b -> ListN n c -> ListN n d -> ListN n x zipWith4 f (ListN (v1:vs)) (ListN (w1:ws)) (ListN (x1:xs)) (ListN (y1:ys)) = ListN (f v1 w1 x1 y1 : unListN (zipWith4 f (ListN vs) (ListN ws) (ListN xs) (ListN ys))) zipWith4 _ (ListN []) _ _ _ = ListN [] zipWith4 _ _ _ _ _ = impossible zipWith5 :: (a -> b -> c -> d -> e -> x) -> ListN n a -> ListN n b -> ListN n c -> ListN n d -> ListN n e -> ListN n x zipWith5 f (ListN (v1:vs)) (ListN (w1:ws)) (ListN (x1:xs)) (ListN (y1:ys)) (ListN (z1:zs)) = ListN (f v1 w1 x1 y1 z1 : unListN (zipWith5 f (ListN vs) (ListN ws) (ListN xs) (ListN ys) (ListN zs))) zipWith5 _ (ListN []) _ _ _ _ = ListN [] zipWith5 _ _ _ _ _ _ = impossible basement-0.0.4/Basement/Error.hs0000644000000000000000000000175713150204234014666 0ustar0000000000000000{-# LANGUAGE MagicHash #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE TypeInType #-} #endif module Basement.Error ( error ) where import GHC.Prim import Basement.UTF8.Base import Basement.Compat.CallStack #if MIN_VERSION_base(4,9,0) import GHC.Types (RuntimeRep) import GHC.Exception (errorCallWithCallStackException) -- | stop execution and displays an error message error :: forall (r :: RuntimeRep) . forall (a :: TYPE r) . HasCallStack => String -> a error s = raise# (errorCallWithCallStackException (sToList s) ?callstack) #elif MIN_VERSION_base(4,7,0) import GHC.Exception (errorCallException) error :: String -> a error s = raise# (errorCallException (sToList s)) #else import GHC.Types import GHC.Exception error :: String -> a error s = throw (ErrorCall (sToList s)) #endif basement-0.0.4/Basement/Show.hs0000644000000000000000000000060213141321320014475 0ustar0000000000000000module Basement.Show where import qualified Prelude import Basement.Compat.Base import Basement.UTF8.Base (String) -- | Use the Show class to create a String. -- -- Note that this is not efficient, since -- an intermediate [Char] is going to be -- created before turning into a real String. show :: Prelude.Show a => a -> String show = fromList . Prelude.show basement-0.0.4/Basement/Runtime.hs0000644000000000000000000000223413141321320015203 0ustar0000000000000000-- | -- Module : Basement.Runtime -- License : BSD-style -- Maintainer : foundation -- -- Global configuration environment module Basement.Runtime where import Basement.Compat.Base import Basement.Types.OffsetSize import System.Environment import System.IO.Unsafe (unsafePerformIO) import Text.Read (readMaybe) -- | Defines the maximum size in bytes of unpinned arrays. -- -- You can change this value by setting the environment variable -- @HS_FOUNDATION_UARRAY_UNPINNED_MAX@ to an unsigned integer number. -- -- Note: We use 'unsafePerformIO' here. If the environment variable -- changes during runtime and the runtime system decides to recompute -- this value, referential transparency is violated (like the First -- Order violated the Galactic Concordance!). -- -- TODO The default value of 1024 bytes is arbitrarily chosen for now. unsafeUArrayUnpinnedMaxSize :: CountOf Word8 unsafeUArrayUnpinnedMaxSize = unsafePerformIO $ do maxSize <- (>>= readMaybe) <$> lookupEnv "HS_FOUNDATION_UARRAY_UNPINNED_MAX" pure $ maybe (CountOf 1024) CountOf maxSize {-# NOINLINE unsafeUArrayUnpinnedMaxSize #-} basement-0.0.4/Basement/Alg/Class.hs0000644000000000000000000000064013201545546015346 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} module Basement.Alg.Class ( Indexable, index , RandomAccess, read, write ) where import Basement.Types.OffsetSize class Indexable container ty where index :: container -> (Offset ty) -> ty class RandomAccess container prim ty where read :: container -> (Offset ty) -> prim ty write :: container -> (Offset ty) -> ty -> prim () basement-0.0.4/Basement/Alg/Mutable.hs0000644000000000000000000000604713201545546015701 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} module Basement.Alg.Mutable ( inplaceSortBy ) where import GHC.Types import GHC.Prim import Basement.Compat.Base import Basement.Numerical.Additive import Basement.Numerical.Multiplicative import Basement.Types.OffsetSize import Basement.PrimType import Basement.Monad import Basement.Alg.Class inplaceSortBy :: (PrimMonad prim, RandomAccess container prim ty) => (ty -> ty -> Ordering) -- ^ Function defining the ordering relationship -> (Offset ty) -- ^ Offset to first element to sort -> (CountOf ty) -- ^ Number of elements to sort -> container -- ^ Data to be sorted -> prim () inplaceSortBy ford start len mvec = qsort start (start `offsetPlusE` len `offsetSub` 1) where qsort lo hi | lo >= hi = pure () | otherwise = do p <- partition lo hi qsort lo (pred p) qsort (p+1) hi pivotStrategy (Offset low) hi@(Offset high) = do let mid = Offset $ (low + high) `div` 2 pivot <- read mvec mid read mvec hi >>= write mvec mid write mvec hi pivot -- move pivot @ pivotpos := hi pure pivot partition lo hi = do pivot <- pivotStrategy lo hi -- RETURN: index of pivot with [=pivot] -- INVARIANT: i & j are valid array indices; pivotpos==hi let go i j = do -- INVARIANT: k <= pivotpos let fw k = do ak <- read mvec k if ford ak pivot == LT then fw (k+1) else pure (k, ak) (i, ai) <- fw i -- POST: ai >= pivot -- INVARIANT: k >= i let bw k | k==i = pure (i, ai) | otherwise = do ak <- read mvec k if ford ak pivot /= LT then bw (pred k) else pure (k, ak) (j, aj) <- bw j -- POST: i==j OR (aj=pivot AND (i==j OR aj=p AND aj= pivot -- complete partitioning by swapping pivot to the center write mvec hi ai write mvec i pivot pure i go lo hi {-# INLINE inplaceSortBy #-} basement-0.0.4/Basement/Alg/PrimArray.hs0000644000000000000000000001032013201545546016203 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MagicHash #-} module Basement.Alg.PrimArray ( Indexable, index , findIndexElem , revFindIndexElem , findIndexPredicate , revFindIndexPredicate , foldl , foldr , foldl1 , all , any , filter ) where import GHC.Types import GHC.Prim import Basement.Alg.Class import Basement.Compat.Base import Basement.Numerical.Additive import Basement.Numerical.Multiplicative import Basement.Types.OffsetSize import Basement.PrimType import Basement.Monad findIndexElem :: (Indexable container ty, Eq ty) => ty -> container -> 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 = index ba i {-# INLINE findIndexElem #-} revFindIndexElem :: (Indexable container ty, Eq ty) => ty -> container -> Offset ty -> Offset ty -> Offset ty revFindIndexElem ty ba startIndex endIndex | endIndex > startIndex = loop (endIndex `offsetMinusE` 1) | otherwise = endIndex where loop !i | t == ty = i | i > startIndex = loop (i `offsetMinusE` 1) | otherwise = endIndex where t = index ba i {-# INLINE revFindIndexElem #-} findIndexPredicate :: Indexable container ty => (ty -> Bool) -> container -> 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 (index ba i) {-# INLINE findIndexPredicate #-} revFindIndexPredicate :: Indexable container ty => (ty -> Bool) -> container -> Offset ty -> Offset ty -> Offset ty revFindIndexPredicate predicate ba startIndex endIndex | endIndex > startIndex = loop (endIndex `offsetMinusE` 1) | otherwise = endIndex where loop !i | found = i | i > startIndex = loop (i `offsetMinusE` 1) | otherwise = endIndex where found = predicate (index ba i) {-# INLINE revFindIndexPredicate #-} foldl :: Indexable container ty => (a -> ty -> a) -> a -> container -> 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 (index ba i)) {-# INLINE foldl #-} foldr :: Indexable container ty => (ty -> a -> a) -> a -> container -> Offset ty -> Offset ty -> a foldr f !initialAcc ba startIndex endIndex = loop startIndex where loop !i | i == endIndex = initialAcc | otherwise = index ba i `f` loop (i+1) {-# INLINE foldr #-} foldl1 :: Indexable container ty => (ty -> ty -> ty) -> container -> Offset ty -> Offset ty -> ty foldl1 f ba startIndex endIndex = loop (startIndex+1) (index ba startIndex) where loop !i !acc | i == endIndex = acc | otherwise = loop (i+1) (f acc (index ba i)) {-# INLINE foldl1 #-} filter :: (PrimMonad prim, PrimType ty, Indexable container ty) => (ty -> Bool) -> MutableByteArray# (PrimState prim) -> container -> 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 = index src s {-# INLINE filter #-} all :: Indexable container ty => (ty -> Bool) -> container -> Offset ty -> Offset ty -> Bool all predicate ba start end = loop start where loop !i | i == end = True | predicate (index ba i) = loop (i+1) | otherwise = False {-# INLINE all #-} any :: Indexable container ty => (ty -> Bool) -> container -> Offset ty -> Offset ty -> Bool any predicate ba start end = loop start where loop !i | i == end = False | predicate (index ba i) = True | otherwise = loop (i+1) {-# INLINE any #-} basement-0.0.4/Basement/Alg/Native/Prim.hs0000644000000000000000000000164113162720724016437 0ustar0000000000000000{-# LANGUAGE MagicHash #-} module Basement.Alg.Native.Prim ( Immutable , Mutable , primIndex , primIndex64 , primRead , primWrite ) where import GHC.Types import GHC.Prim import GHC.Word import Basement.Types.OffsetSize import Basement.PrimType import Basement.Monad type Immutable = ByteArray# type Mutable st = MutableByteArray# st primIndex :: PrimType ty => Immutable -> Offset ty -> ty primIndex = primBaIndex {-# INLINE primIndex #-} primIndex64 :: Immutable -> Offset Word64 -> Word64 primIndex64 = primIndex {-# INLINE primIndex64 #-} primRead :: (PrimMonad prim, PrimType ty) => Mutable (PrimState prim) -> Offset ty -> prim ty primRead = primMbaRead {-# INLINE primRead #-} primWrite :: (PrimMonad prim, PrimType ty) => Mutable (PrimState prim) -> Offset ty -> ty -> prim () primWrite = primMbaWrite {-# INLINE primWrite #-} basement-0.0.4/Basement/Alg/Native/UTF8.hs0000644000000000000000000002440713176251306016263 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} module Basement.Alg.Native.UTF8 ( Immutable , Mutable -- * functions , nextAscii , nextAsciiDigit , expectAscii , next , nextSkip , prev , prevSkip , write , toList , all , any , foldr , length , reverse -- temporary , primIndex64 , primRead8 , primWrite8 ) where import GHC.Int import GHC.Types import GHC.Word import GHC.Prim import Data.Bits import Basement.Compat.Base hiding (toList) import Basement.Compat.Primitive import Basement.Alg.Native.Prim import qualified Basement.Alg.Native.Prim as PrimNative -- NO SUBST import Data.Proxy import Basement.Numerical.Additive import Basement.Numerical.Subtractive import Basement.Types.OffsetSize import Basement.Monad import Basement.PrimType import Basement.UTF8.Helper import Basement.UTF8.Table import Basement.UTF8.Types primWrite8 :: PrimMonad prim => Mutable (PrimState prim) -> Offset Word8 -> Word8 -> prim () primWrite8 = primWrite {-# INLINE primWrite8 #-} primRead8 :: PrimMonad prim => Mutable (PrimState prim) -> Offset Word8 -> prim Word8 primRead8 = primRead {-# INLINE primRead8 #-} primIndex8 :: Immutable -> Offset Word8 -> Word8 primIndex8 = primIndex {-# INLINE primIndex8 #-} nextAscii :: Immutable -> Offset Word8 -> StepASCII nextAscii ba n = StepASCII w where !w = primIndex ba n {-# INLINE nextAscii #-} -- | nextAsciiBa specialized to get a digit between 0 and 9 (included) nextAsciiDigit :: Immutable -> Offset Word8 -> StepDigit nextAsciiDigit ba n = StepDigit (primIndex8 ba n - 0x30) {-# INLINE nextAsciiDigit #-} expectAscii :: Immutable -> Offset Word8 -> Word8 -> Bool expectAscii ba n v = primIndex8 ba n == v {-# INLINE expectAscii #-} next :: Immutable -> Offset8 -> Step next ba n = case getNbBytes h of 0 -> Step (toChar1 h) (n + Offset 1) 1 -> Step (toChar2 h (primIndex8 ba (n + Offset 1))) (n + Offset 2) 2 -> Step (toChar3 h (primIndex8 ba (n + Offset 1)) (primIndex8 ba (n + Offset 2))) (n + Offset 3) 3 -> Step (toChar4 h (primIndex8 ba (n + Offset 1)) (primIndex8 ba (n + Offset 2)) (primIndex8 ba (n + Offset 3))) (n + Offset 4) r -> error ("next: internal error: invalid input: offset=" <> show n <> " table=" <> show r <> " h=" <> show h) where !h = primIndex8 ba n {-# INLINE next #-} nextSkip :: Immutable -> Offset Word8 -> Offset Word8 nextSkip ba n = n + 1 + Offset (getNbBytes (primIndex8 ba n)) {-# INLINE nextSkip #-} -- Given a non null offset, give the previous character and the offset of this character -- will fail bad if apply at the beginning of string or an empty string. prev :: Immutable -> Offset Word8 -> StepBack prev ba offset = case primIndex8 ba prevOfs1 of (W8# v1) | isContinuation# v1 -> atLeast2 (maskContinuation# v1) | otherwise -> StepBack (toChar# v1) prevOfs1 where sz1 = CountOf 1 !prevOfs1 = offset `offsetMinusE` sz1 prevOfs2 = prevOfs1 `offsetMinusE` sz1 prevOfs3 = prevOfs2 `offsetMinusE` sz1 prevOfs4 = prevOfs3 `offsetMinusE` sz1 atLeast2 !v = case primIndex8 ba prevOfs2 of (W8# v2) | isContinuation# v2 -> atLeast3 (or# (uncheckedShiftL# (maskContinuation# v2) 6#) v) | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader2# v2) 6#) v)) prevOfs2 atLeast3 !v = case primIndex8 ba prevOfs3 of (W8# v3) | isContinuation# v3 -> atLeast4 (or# (uncheckedShiftL# (maskContinuation# v3) 12#) v) | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader3# v3) 12#) v)) prevOfs3 atLeast4 !v = case primIndex8 ba prevOfs4 of (W8# v4) -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader4# v4) 18#) v)) prevOfs4 prevSkip :: Immutable -> Offset Word8 -> Offset Word8 prevSkip ba offset = loop (offset `offsetMinusE` sz1) where sz1 = CountOf 1 loop o | isContinuation (primIndex8 ba o) = loop (o `offsetMinusE` sz1) | otherwise = o write :: PrimMonad prim => Mutable (PrimState prim) -> Offset8 -> Char -> prim Offset8 write mba !i !c | bool# (ltWord# x 0x80## ) = encode1 | bool# (ltWord# x 0x800## ) = encode2 | bool# (ltWord# x 0x10000##) = encode3 | otherwise = encode4 where !(I# xi) = fromEnum c !x = int2Word# xi encode1 = primWrite8 mba i (W8# x) >> pure (i + Offset 1) encode2 = do let x1 = or# (uncheckedShiftRL# x 6#) 0xc0## x2 = toContinuation x primWrite8 mba i (W8# x1) primWrite8 mba (i+1) (W8# x2) pure (i + Offset 2) encode3 = do let x1 = or# (uncheckedShiftRL# x 12#) 0xe0## x2 = toContinuation (uncheckedShiftRL# x 6#) x3 = toContinuation x primWrite8 mba i (W8# x1) primWrite8 mba (i+Offset 1) (W8# x2) primWrite8 mba (i+Offset 2) (W8# x3) pure (i + Offset 3) encode4 = do let x1 = or# (uncheckedShiftRL# x 18#) 0xf0## x2 = toContinuation (uncheckedShiftRL# x 12#) x3 = toContinuation (uncheckedShiftRL# x 6#) x4 = toContinuation x primWrite8 mba i (W8# x1) primWrite8 mba (i+Offset 1) (W8# x2) primWrite8 mba (i+Offset 2) (W8# x3) primWrite8 mba (i+Offset 3) (W8# x4) pure (i + Offset 4) toContinuation :: Word# -> Word# toContinuation w = or# (and# w 0x3f##) 0x80## {-# INLINE write #-} toList :: Immutable -> Offset Word8 -> Offset Word8 -> [Char] toList ba !start !end = loop start where loop !idx | idx == end = [] | otherwise = c : loop idx' where (Step c idx') = next ba idx all :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool all predicate ba start end = loop start where loop !idx | idx == end = True | predicate c = loop idx' | otherwise = False where (Step c idx') = next ba idx {-# INLINE all #-} any :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool any predicate ba start end = loop start where loop !idx | idx == end = False | predicate c = True | otherwise = loop idx' where (Step c idx') = next ba idx {-# INLINE any #-} foldr :: Immutable -> Offset Word8 -> Offset Word8 -> (Char -> a -> a) -> a -> a foldr dat start end f acc = loop start where loop !i | i == end = acc | otherwise = let (Step c i') = next dat i in c `f` loop i' {-# INLINE foldr #-} length :: Immutable -> Offset Word8 -> Offset Word8 -> CountOf Char length dat start end | start == end = 0 | otherwise = processStart 0 start where end64 :: Offset Word64 end64 = offsetInElements end prx64 :: Proxy Word64 prx64 = Proxy mask64_80 :: Word64 mask64_80 = 0x8080808080808080 processStart :: CountOf Char -> Offset Word8 -> CountOf Char processStart !c !i | i == end = c | offsetIsAligned prx64 i = processAligned c (offsetInElements i) | otherwise = let h = primIndex8 dat i cont = (h .&. 0xc0) == 0x80 c' = if cont then c else c+1 in processStart c' (i+1) processAligned :: CountOf Char -> Offset Word64 -> CountOf Char processAligned !c !i | i >= end64 = processEnd c (offsetInBytes i) | otherwise = let !h = primIndex64 dat i !h80 = h .&. mask64_80 in if h80 == 0 then processAligned (c+8) (i+1) else let !nbAscii = if h80 == mask64_80 then 0 else CountOf (8 - popCount h80) !nbHigh = CountOf $ popCount (h .&. (h80 `unsafeShiftR` 1)) in processAligned (c + nbAscii + nbHigh) (i+1) processEnd !c !i | i == end = c | otherwise = let h = primIndex8 dat i cont = (h .&. 0xc0) == 0x80 c' = if cont then c else c+1 in processStart c' (i+1) {-# INLINE length #-} reverse :: PrimMonad prim => MutableByteArray# (PrimState prim) -- ^ Destination buffer -> Offset Word8 -- ^ Destination start -> Immutable -- ^ Source buffer -> Offset Word8 -- ^ Source start -> Offset Word8 -- ^ Source end -> prim () reverse dst dstOfs src start end | start == end = pure () | otherwise = loop (dstOfs `offsetPlusE` (offsetAsSize (end `offsetSub` start)) `offsetSub` 1) start where loop !d !s | s == end = pure () | headerIsAscii h = PrimNative.primWrite dst d h >> loop (d `offsetSub` 1) (s + 1) | otherwise = do case getNbBytes h of 1 -> do PrimNative.primWrite dst (d `offsetSub` 1) h PrimNative.primWrite dst d (primIndex8 src (s + 1)) loop (d `offsetSub` 2) (s + 2) 2 -> do PrimNative.primWrite dst (d `offsetSub` 2) h PrimNative.primWrite dst (d `offsetSub` 1) (primIndex8 src (s + 1)) PrimNative.primWrite dst d (primIndex8 src (s + 2)) loop (d `offsetSub` 3) (s + 3) 3 -> do PrimNative.primWrite dst (d `offsetSub` 3) h PrimNative.primWrite dst (d `offsetSub` 2) (primIndex8 src (s + 1)) PrimNative.primWrite dst (d `offsetSub` 1) (primIndex8 src (s + 2)) PrimNative.primWrite dst d (primIndex8 src (s + 3)) loop (d `offsetSub` 4) (s + 4) _ -> error "impossible" where h = primIndex8 src s {-# INLINE reverse #-} basement-0.0.4/Basement/Alg/Native/String.hs0000644000000000000000000001160213176251306016774 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} module Basement.Alg.Native.String ( copyFilter , validate , findIndexPredicate , revFindIndexPredicate ) where import GHC.Prim import GHC.ST import Basement.Compat.Base import Basement.Numerical.Additive import Basement.Types.OffsetSize import qualified Basement.Alg.Native.Prim as PrimNative -- NO SUBST import qualified Basement.Alg.Native.UTF8 as UTF8Native -- NO SUBST import qualified Basement.Alg.Native.Prim as PrimBackend import qualified Basement.Alg.Native.UTF8 as UTF8Backend import Basement.UTF8.Helper import Basement.UTF8.Table import Basement.UTF8.Types copyFilter :: (Char -> Bool) -> CountOf Word8 -> MutableByteArray# s -> PrimBackend.Immutable -> Offset Word8 -> ST s (CountOf Word8) copyFilter predicate !sz dst src start = loop (Offset 0) start where !end = start `offsetPlusE` sz loop !d !s | s == end = pure (offsetAsSize d) | otherwise = let !h = PrimBackend.primIndex src s in case headerIsAscii h of True | predicate (toChar1 h) -> PrimNative.primWrite dst d h >> loop (d + Offset 1) (s + Offset 1) | otherwise -> loop d (s + Offset 1) False -> case UTF8Backend.next src s of Step c s' | predicate c -> UTF8Native.write dst d c >>= \d' -> loop d' s' | otherwise -> loop d s' validate :: Offset Word8 -> PrimBackend.Immutable -> Offset Word8 -> (Offset Word8, Maybe ValidationFailure) validate end ba ofsStart = loop4 ofsStart where loop4 !ofs | ofs4 < end = let h1 = PrimBackend.primIndex ba ofs h2 = PrimBackend.primIndex ba (ofs+1) h3 = PrimBackend.primIndex ba (ofs+2) h4 = PrimBackend.primIndex ba (ofs+3) in if headerIsAscii h1 && headerIsAscii h2 && headerIsAscii h3 && headerIsAscii h4 then loop4 ofs4 else loop ofs | otherwise = loop ofs where !ofs4 = ofs+4 loop !ofs | ofs == end = (end, Nothing) | headerIsAscii h = loop (ofs + Offset 1) | otherwise = multi (CountOf $ getNbBytes h) ofs where h = PrimBackend.primIndex ba ofs multi (CountOf 0xff) pos = (pos, Just InvalidHeader) multi nbConts pos | (posNext `offsetPlusE` nbConts) > end = (pos, Just MissingByte) | otherwise = case nbConts of CountOf 1 -> let c1 = PrimBackend.primIndex ba posNext in if isContinuation c1 then loop (pos + Offset 2) else (pos, Just InvalidContinuation) CountOf 2 -> let c1 = PrimBackend.primIndex ba posNext c2 = PrimBackend.primIndex ba (pos + Offset 2) in if isContinuation2 c1 c2 then loop (pos + Offset 3) else (pos, Just InvalidContinuation) CountOf _ -> let c1 = PrimBackend.primIndex ba posNext c2 = PrimBackend.primIndex ba (pos + Offset 2) c3 = PrimBackend.primIndex ba (pos + Offset 3) in if isContinuation3 c1 c2 c3 then loop (pos + Offset 4) else (pos, Just InvalidContinuation) where posNext = pos + Offset 1 findIndexPredicate :: (Char -> Bool) -> PrimBackend.Immutable -> Offset Word8 -> Offset Word8 -> Offset Word8 findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex where loop !i | i < endIndex && not (predicate c) = loop (i') | otherwise = i where Step c i' = UTF8Backend.next ba i {-# INLINE findIndexPredicate #-} revFindIndexPredicate :: (Char -> Bool) -> PrimBackend.Immutable -> Offset Word8 -> Offset Word8 -> Offset Word8 revFindIndexPredicate predicate ba startIndex endIndex | endIndex > startIndex = loop endIndex | otherwise = endIndex where loop !i | predicate c = i' | i' > startIndex = loop i' | otherwise = endIndex where StepBack c i' = UTF8Backend.prev ba i {-# INLINE revFindIndexPredicate #-} basement-0.0.4/Basement/Alg/Foreign/Prim.hs0000644000000000000000000000162113172057505016601 0ustar0000000000000000{-# LANGUAGE MagicHash #-} module Basement.Alg.Foreign.Prim ( Immutable , Mutable , primIndex , primIndex64 , primRead , primWrite ) where import GHC.Types import GHC.Prim import GHC.Word import Basement.Types.OffsetSize import Basement.PrimType import Basement.Monad type Immutable = Addr# type Mutable st = Addr# primIndex :: PrimType ty => Immutable -> Offset ty -> ty primIndex = primAddrIndex {-# INLINE primIndex #-} primIndex64 :: Immutable -> Offset Word64 -> Word64 primIndex64 = primIndex {-# INLINE primIndex64 #-} primRead :: (PrimMonad prim, PrimType ty) => Mutable (PrimState prim) -> Offset ty -> prim ty primRead = primAddrRead {-# INLINE primRead #-} primWrite :: (PrimMonad prim, PrimType ty) => Mutable (PrimState prim) -> Offset ty -> ty -> prim () primWrite = primAddrWrite {-# INLINE primWrite #-}basement-0.0.4/Basement/Alg/Foreign/UTF8.hs0000644000000000000000000002441113176251306016421 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} module Basement.Alg.Foreign.UTF8 ( Immutable , Mutable -- * functions , nextAscii , nextAsciiDigit , expectAscii , next , nextSkip , prev , prevSkip , write , toList , all , any , foldr , length , reverse -- temporary , primIndex64 , primRead8 , primWrite8 ) where import GHC.Int import GHC.Types import GHC.Word import GHC.Prim import Data.Bits import Basement.Compat.Base hiding (toList) import Basement.Compat.Primitive import Basement.Alg.Foreign.Prim import qualified Basement.Alg.Native.Prim as PrimNative -- NO SUBST import Data.Proxy import Basement.Numerical.Additive import Basement.Numerical.Subtractive import Basement.Types.OffsetSize import Basement.Monad import Basement.PrimType import Basement.UTF8.Helper import Basement.UTF8.Table import Basement.UTF8.Types primWrite8 :: PrimMonad prim => Mutable (PrimState prim) -> Offset Word8 -> Word8 -> prim () primWrite8 = primWrite {-# INLINE primWrite8 #-} primRead8 :: PrimMonad prim => Mutable (PrimState prim) -> Offset Word8 -> prim Word8 primRead8 = primRead {-# INLINE primRead8 #-} primIndex8 :: Immutable -> Offset Word8 -> Word8 primIndex8 = primIndex {-# INLINE primIndex8 #-} nextAscii :: Immutable -> Offset Word8 -> StepASCII nextAscii ba n = StepASCII w where !w = primIndex ba n {-# INLINE nextAscii #-} -- | nextAsciiBa specialized to get a digit between 0 and 9 (included) nextAsciiDigit :: Immutable -> Offset Word8 -> StepDigit nextAsciiDigit ba n = StepDigit (primIndex8 ba n - 0x30) {-# INLINE nextAsciiDigit #-} expectAscii :: Immutable -> Offset Word8 -> Word8 -> Bool expectAscii ba n v = primIndex8 ba n == v {-# INLINE expectAscii #-} next :: Immutable -> Offset8 -> Step next ba n = case getNbBytes h of 0 -> Step (toChar1 h) (n + Offset 1) 1 -> Step (toChar2 h (primIndex8 ba (n + Offset 1))) (n + Offset 2) 2 -> Step (toChar3 h (primIndex8 ba (n + Offset 1)) (primIndex8 ba (n + Offset 2))) (n + Offset 3) 3 -> Step (toChar4 h (primIndex8 ba (n + Offset 1)) (primIndex8 ba (n + Offset 2)) (primIndex8 ba (n + Offset 3))) (n + Offset 4) r -> error ("next: internal error: invalid input: offset=" <> show n <> " table=" <> show r <> " h=" <> show h) where !h = primIndex8 ba n {-# INLINE next #-} nextSkip :: Immutable -> Offset Word8 -> Offset Word8 nextSkip ba n = n + 1 + Offset (getNbBytes (primIndex8 ba n)) {-# INLINE nextSkip #-} -- Given a non null offset, give the previous character and the offset of this character -- will fail bad if apply at the beginning of string or an empty string. prev :: Immutable -> Offset Word8 -> StepBack prev ba offset = case primIndex8 ba prevOfs1 of (W8# v1) | isContinuation# v1 -> atLeast2 (maskContinuation# v1) | otherwise -> StepBack (toChar# v1) prevOfs1 where sz1 = CountOf 1 !prevOfs1 = offset `offsetMinusE` sz1 prevOfs2 = prevOfs1 `offsetMinusE` sz1 prevOfs3 = prevOfs2 `offsetMinusE` sz1 prevOfs4 = prevOfs3 `offsetMinusE` sz1 atLeast2 !v = case primIndex8 ba prevOfs2 of (W8# v2) | isContinuation# v2 -> atLeast3 (or# (uncheckedShiftL# (maskContinuation# v2) 6#) v) | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader2# v2) 6#) v)) prevOfs2 atLeast3 !v = case primIndex8 ba prevOfs3 of (W8# v3) | isContinuation# v3 -> atLeast4 (or# (uncheckedShiftL# (maskContinuation# v3) 12#) v) | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader3# v3) 12#) v)) prevOfs3 atLeast4 !v = case primIndex8 ba prevOfs4 of (W8# v4) -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader4# v4) 18#) v)) prevOfs4 prevSkip :: Immutable -> Offset Word8 -> Offset Word8 prevSkip ba offset = loop (offset `offsetMinusE` sz1) where sz1 = CountOf 1 loop o | isContinuation (primIndex8 ba o) = loop (o `offsetMinusE` sz1) | otherwise = o write :: PrimMonad prim => Mutable (PrimState prim) -> Offset8 -> Char -> prim Offset8 write mba !i !c | bool# (ltWord# x 0x80## ) = encode1 | bool# (ltWord# x 0x800## ) = encode2 | bool# (ltWord# x 0x10000##) = encode3 | otherwise = encode4 where !(I# xi) = fromEnum c !x = int2Word# xi encode1 = primWrite8 mba i (W8# x) >> pure (i + Offset 1) encode2 = do let x1 = or# (uncheckedShiftRL# x 6#) 0xc0## x2 = toContinuation x primWrite8 mba i (W8# x1) primWrite8 mba (i+1) (W8# x2) pure (i + Offset 2) encode3 = do let x1 = or# (uncheckedShiftRL# x 12#) 0xe0## x2 = toContinuation (uncheckedShiftRL# x 6#) x3 = toContinuation x primWrite8 mba i (W8# x1) primWrite8 mba (i+Offset 1) (W8# x2) primWrite8 mba (i+Offset 2) (W8# x3) pure (i + Offset 3) encode4 = do let x1 = or# (uncheckedShiftRL# x 18#) 0xf0## x2 = toContinuation (uncheckedShiftRL# x 12#) x3 = toContinuation (uncheckedShiftRL# x 6#) x4 = toContinuation x primWrite8 mba i (W8# x1) primWrite8 mba (i+Offset 1) (W8# x2) primWrite8 mba (i+Offset 2) (W8# x3) primWrite8 mba (i+Offset 3) (W8# x4) pure (i + Offset 4) toContinuation :: Word# -> Word# toContinuation w = or# (and# w 0x3f##) 0x80## {-# INLINE write #-} toList :: Immutable -> Offset Word8 -> Offset Word8 -> [Char] toList ba !start !end = loop start where loop !idx | idx == end = [] | otherwise = c : loop idx' where (Step c idx') = next ba idx all :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool all predicate ba start end = loop start where loop !idx | idx == end = True | predicate c = loop idx' | otherwise = False where (Step c idx') = next ba idx {-# INLINE all #-} any :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool any predicate ba start end = loop start where loop !idx | idx == end = False | predicate c = True | otherwise = loop idx' where (Step c idx') = next ba idx {-# INLINE any #-} foldr :: Immutable -> Offset Word8 -> Offset Word8 -> (Char -> a -> a) -> a -> a foldr dat start end f acc = loop start where loop !i | i == end = acc | otherwise = let (Step c i') = next dat i in c `f` loop i' {-# INLINE foldr #-} length :: Immutable -> Offset Word8 -> Offset Word8 -> CountOf Char length dat start end | start == end = 0 | otherwise = processStart 0 start where end64 :: Offset Word64 end64 = offsetInElements end prx64 :: Proxy Word64 prx64 = Proxy mask64_80 :: Word64 mask64_80 = 0x8080808080808080 processStart :: CountOf Char -> Offset Word8 -> CountOf Char processStart !c !i | i == end = c | offsetIsAligned prx64 i = processAligned c (offsetInElements i) | otherwise = let h = primIndex8 dat i cont = (h .&. 0xc0) == 0x80 c' = if cont then c else c+1 in processStart c' (i+1) processAligned :: CountOf Char -> Offset Word64 -> CountOf Char processAligned !c !i | i >= end64 = processEnd c (offsetInBytes i) | otherwise = let !h = primIndex64 dat i !h80 = h .&. mask64_80 in if h80 == 0 then processAligned (c+8) (i+1) else let !nbAscii = if h80 == mask64_80 then 0 else CountOf (8 - popCount h80) !nbHigh = CountOf $ popCount (h .&. (h80 `unsafeShiftR` 1)) in processAligned (c + nbAscii + nbHigh) (i+1) processEnd !c !i | i == end = c | otherwise = let h = primIndex8 dat i cont = (h .&. 0xc0) == 0x80 c' = if cont then c else c+1 in processStart c' (i+1) {-# INLINE length #-} reverse :: PrimMonad prim => MutableByteArray# (PrimState prim) -- ^ Destination buffer -> Offset Word8 -- ^ Destination start -> Immutable -- ^ Source buffer -> Offset Word8 -- ^ Source start -> Offset Word8 -- ^ Source end -> prim () reverse dst dstOfs src start end | start == end = pure () | otherwise = loop (dstOfs `offsetPlusE` (offsetAsSize (end `offsetSub` start)) `offsetSub` 1) start where loop !d !s | s == end = pure () | headerIsAscii h = PrimNative.primWrite dst d h >> loop (d `offsetSub` 1) (s + 1) | otherwise = do case getNbBytes h of 1 -> do PrimNative.primWrite dst (d `offsetSub` 1) h PrimNative.primWrite dst d (primIndex8 src (s + 1)) loop (d `offsetSub` 2) (s + 2) 2 -> do PrimNative.primWrite dst (d `offsetSub` 2) h PrimNative.primWrite dst (d `offsetSub` 1) (primIndex8 src (s + 1)) PrimNative.primWrite dst d (primIndex8 src (s + 2)) loop (d `offsetSub` 3) (s + 3) 3 -> do PrimNative.primWrite dst (d `offsetSub` 3) h PrimNative.primWrite dst (d `offsetSub` 2) (primIndex8 src (s + 1)) PrimNative.primWrite dst (d `offsetSub` 1) (primIndex8 src (s + 2)) PrimNative.primWrite dst d (primIndex8 src (s + 3)) loop (d `offsetSub` 4) (s + 4) _ -> error "impossible" where h = primIndex8 src s {-# INLINE reverse #-} basement-0.0.4/Basement/Alg/Foreign/String.hs0000644000000000000000000001160513176251306017142 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} module Basement.Alg.Foreign.String ( copyFilter , validate , findIndexPredicate , revFindIndexPredicate ) where import GHC.Prim import GHC.ST import Basement.Compat.Base import Basement.Numerical.Additive import Basement.Types.OffsetSize import qualified Basement.Alg.Native.Prim as PrimNative -- NO SUBST import qualified Basement.Alg.Native.UTF8 as UTF8Native -- NO SUBST import qualified Basement.Alg.Foreign.Prim as PrimBackend import qualified Basement.Alg.Foreign.UTF8 as UTF8Backend import Basement.UTF8.Helper import Basement.UTF8.Table import Basement.UTF8.Types copyFilter :: (Char -> Bool) -> CountOf Word8 -> MutableByteArray# s -> PrimBackend.Immutable -> Offset Word8 -> ST s (CountOf Word8) copyFilter predicate !sz dst src start = loop (Offset 0) start where !end = start `offsetPlusE` sz loop !d !s | s == end = pure (offsetAsSize d) | otherwise = let !h = PrimBackend.primIndex src s in case headerIsAscii h of True | predicate (toChar1 h) -> PrimNative.primWrite dst d h >> loop (d + Offset 1) (s + Offset 1) | otherwise -> loop d (s + Offset 1) False -> case UTF8Backend.next src s of Step c s' | predicate c -> UTF8Native.write dst d c >>= \d' -> loop d' s' | otherwise -> loop d s' validate :: Offset Word8 -> PrimBackend.Immutable -> Offset Word8 -> (Offset Word8, Maybe ValidationFailure) validate end ba ofsStart = loop4 ofsStart where loop4 !ofs | ofs4 < end = let h1 = PrimBackend.primIndex ba ofs h2 = PrimBackend.primIndex ba (ofs+1) h3 = PrimBackend.primIndex ba (ofs+2) h4 = PrimBackend.primIndex ba (ofs+3) in if headerIsAscii h1 && headerIsAscii h2 && headerIsAscii h3 && headerIsAscii h4 then loop4 ofs4 else loop ofs | otherwise = loop ofs where !ofs4 = ofs+4 loop !ofs | ofs == end = (end, Nothing) | headerIsAscii h = loop (ofs + Offset 1) | otherwise = multi (CountOf $ getNbBytes h) ofs where h = PrimBackend.primIndex ba ofs multi (CountOf 0xff) pos = (pos, Just InvalidHeader) multi nbConts pos | (posNext `offsetPlusE` nbConts) > end = (pos, Just MissingByte) | otherwise = case nbConts of CountOf 1 -> let c1 = PrimBackend.primIndex ba posNext in if isContinuation c1 then loop (pos + Offset 2) else (pos, Just InvalidContinuation) CountOf 2 -> let c1 = PrimBackend.primIndex ba posNext c2 = PrimBackend.primIndex ba (pos + Offset 2) in if isContinuation2 c1 c2 then loop (pos + Offset 3) else (pos, Just InvalidContinuation) CountOf _ -> let c1 = PrimBackend.primIndex ba posNext c2 = PrimBackend.primIndex ba (pos + Offset 2) c3 = PrimBackend.primIndex ba (pos + Offset 3) in if isContinuation3 c1 c2 c3 then loop (pos + Offset 4) else (pos, Just InvalidContinuation) where posNext = pos + Offset 1 findIndexPredicate :: (Char -> Bool) -> PrimBackend.Immutable -> Offset Word8 -> Offset Word8 -> Offset Word8 findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex where loop !i | i < endIndex && not (predicate c) = loop (i') | otherwise = i where Step c i' = UTF8Backend.next ba i {-# INLINE findIndexPredicate #-} revFindIndexPredicate :: (Char -> Bool) -> PrimBackend.Immutable -> Offset Word8 -> Offset Word8 -> Offset Word8 revFindIndexPredicate predicate ba startIndex endIndex | endIndex > startIndex = loop endIndex | otherwise = endIndex where loop !i | predicate c = i' | i' > startIndex = loop i' | otherwise = endIndex where StepBack c i' = UTF8Backend.prev ba i {-# INLINE revFindIndexPredicate #-} basement-0.0.4/Basement/Numerical/Conversion.hs0000644000000000000000000000416513162720757017655 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} module Basement.Numerical.Conversion ( intToInt64 , int64ToInt , wordToWord64 , word64ToWord , Word32x2(..) , word64ToWord32s , wordToChar , wordToInt , word64ToWord# , charToInt , int64ToWord64 , word64ToInt64 ) where #include "MachDeps.h" import GHC.Types import GHC.Prim import GHC.Int import GHC.Word #if WORD_SIZE_IN_BITS < 64 import GHC.IntWord64 #endif intToInt64 :: Int -> Int64 #if WORD_SIZE_IN_BITS == 64 intToInt64 (I# i) = I64# i #else intToInt64 (I# i) = I64# (intToInt64# i) #endif int64ToInt :: Int64 -> Int #if WORD_SIZE_IN_BITS == 64 int64ToInt (I64# i) = I# i #else int64ToInt (I64# i) = I# (int64ToInt# i) #endif wordToWord64 :: Word -> Word64 #if WORD_SIZE_IN_BITS == 64 wordToWord64 (W# i) = W64# i #else wordToWord64 (W# i) = W64# (wordToWord64# i) #endif word64ToWord :: Word64 -> Word #if WORD_SIZE_IN_BITS == 64 word64ToWord (W64# i) = W# i #else word64ToWord (W64# i) = W# (word64ToWord# i) #endif word64ToInt64 :: Word64 -> Int64 #if WORD_SIZE_IN_BITS == 64 word64ToInt64 (W64# i) = I64# (word2Int# i) #else word64ToInt64 (W64# i) = I64# (word64ToInt64# i) #endif int64ToWord64 :: Int64 -> Word64 #if WORD_SIZE_IN_BITS == 64 int64ToWord64 (I64# i) = W64# (int2Word# i) #else int64ToWord64 (I64# i) = W64# (int64ToWord64# i) #endif #if WORD_SIZE_IN_BITS == 64 word64ToWord# :: Word# -> Word# word64ToWord# i = i {-# INLINE word64ToWord# #-} #endif -- | 2 Word32s data Word32x2 = Word32x2 {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 #if WORD_SIZE_IN_BITS == 64 word64ToWord32s :: Word64 -> Word32x2 word64ToWord32s (W64# w64) = Word32x2 (W32# (uncheckedShiftRL# w64 32#)) (W32# (narrow32Word# w64)) #else word64ToWord32s :: Word64 -> Word32x2 word64ToWord32s (W64# w64) = Word32x2 (W32# (word64ToWord# (uncheckedShiftRL64# w64 32#))) (W32# (word64ToWord# w64)) #endif wordToChar :: Word -> Char wordToChar (W# word) = C# (chr# (word2Int# word)) wordToInt :: Word -> Int wordToInt (W# word) = I# (word2Int# word) charToInt :: Char -> Int charToInt (C# x) = I# (ord# x) basement-0.0.4/Basement/Block/Base.hs0000644000000000000000000003347713175306665015527 0ustar0000000000000000{-# 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 , withPtr , mutableWithPtr ) 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.Compat.Semigroup 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 => Semigroup (Block ty) where (<>) = append 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 #-} -- | Use the 'Ptr' to a block in a safer construct -- -- If the block is not pinned, this is a _dangerous_ operation withPtr :: PrimMonad prim => Block ty -> (Ptr ty -> prim a) -> prim a withPtr x@(Block ba) f = do let addr = Ptr (byteArrayContents# ba) f addr <* touch x touch :: PrimMonad prim => Block ty -> prim () touch (Block ba) = unsafePrimFromIO $ primitive $ \s -> case touch# ba s of { s2 -> (# s2, () #) } -- | Use the 'Ptr' to a mutable block in a safer construct -- -- If the block is not pinned, this is a _dangerous_ operation mutableWithPtr :: PrimMonad prim => MutableBlock ty (PrimState prim) -> (Ptr ty -> prim a) -> prim a mutableWithPtr mb f = do b <- unsafeFreeze mb withPtr b f basement-0.0.4/Basement/UTF8/Base.hs0000644000000000000000000002116413176251306015201 0ustar0000000000000000-- | -- 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 GHC.Exts (build) 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.Alg.Native.UTF8 as PrimBA import qualified Basement.Alg.Foreign.UTF8 as PrimAddr import Basement.UArray (UArray) import Basement.Block (MutableBlock) import qualified Basement.Block.Mutable as BLK import qualified Basement.UArray as Vec import qualified Basement.UArray as C import qualified Basement.UArray.Mutable as MVec import Basement.UArray.Base as Vec (offset, pureST, onBackend, ValidRange(..), offsetsValidRange) import GHC.CString (unpackCString#, unpackCStringUtf8#) import Data.Data import Basement.Compat.ExtList as List import Basement.Compat.Semigroup (Semigroup) -- | Opaque packed array of characters in the UTF8 encoding newtype String = String (UArray Word8) deriving (Typeable, Semigroup, 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 (String arr) = Vec.onBackend onBA onAddr arr where (Vec.ValidRange !start !end) = Vec.offsetsValidRange arr onBA (BLK.Block ba) = loop start where loop !idx | idx == end = [] | otherwise = let !(Step c idx') = PrimBA.next ba idx in c : loop idx' onAddr fptr (Ptr ptr) = pureST (loop start) where loop !idx | idx == end = [] | otherwise = let !(Step c idx') = PrimAddr.next ptr idx in c : loop idx' {-# NOINLINE sToList #-} sToListStream (String arr) k z = Vec.onBackend onBA onAddr arr where (Vec.ValidRange !start !end) = Vec.offsetsValidRange arr onBA (BLK.Block ba) = loop start where loop !idx | idx == end = z | otherwise = let !(Step c idx') = PrimBA.next ba idx in c `k` loop idx' onAddr fptr (Ptr ptr) = pureST (loop start) where loop !idx | idx == end = z | otherwise = let !(Step c idx') = PrimAddr.next ptr idx in c `k` loop idx' {-# RULES "String sToList" [~1] forall s . sToList s = build (\ k z -> sToListStream s k z) #-} {-# RULES "String toList" [~1] forall s . toList s = build (\ k z -> sToListStream s k z) #-} {-# 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 -> MutableBlock Word8 st -> ST st () copy count mba = loop 0 0 where loop o i | o .==# count = pure () | otherwise = case primAddrIndex addr i of 0xC0 -> case primAddrIndex addr (i+1) of 0x80 -> BLK.unsafeWrite mba o 0x00 >> loop (o+1) (i+2) b2 -> BLK.unsafeWrite mba o 0xC0 >> BLK.unsafeWrite mba (o+1) b2 >> loop (o+2) (i+2) b1 -> BLK.unsafeWrite mba o b1 >> loop (o+1) (i+1) -- | Create a new String from a list of characters -- -- 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 nextBA nextAddr array where !start = Vec.offset array reoffset (Step a ofs) = Step a (ofs `offsetSub` start) nextBA (BLK.Block ba) = reoffset (PrimBA.next ba (start + n)) nextAddr _ (Ptr ptr) = pureST $ reoffset (PrimAddr.next ptr (start + n)) prev :: String -> Offset8 -> StepBack prev (String array) !n = Vec.onBackend prevBA prevAddr array where !start = Vec.offset array reoffset (StepBack a ofs) = StepBack a (ofs `offsetSub` start) prevBA (BLK.Block ba) = reoffset (PrimBA.prev ba (start + n)) prevAddr _ (Ptr ptr) = pureST $ reoffset (PrimAddr.prev ptr (start + n)) -- 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 (\(BLK.MutableBlock 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. -> (MutableBlock Word8 (PrimState prim) -> prim a) -> prim (a, MutableString (PrimState prim)) newNative n f = second MutableString `fmap` MVec.newNative n f freeze :: PrimMonad prim => MutableString (PrimState prim) -> prim String freeze (MutableString mba) = String `fmap` C.unsafeFreeze mba {-# INLINE freeze #-} freezeShrink :: PrimMonad prim => CountOf Word8 -> MutableString (PrimState prim) -> prim String freezeShrink n (MutableString mba) = String `fmap` C.unsafeFreezeShrink mba n basement-0.0.4/Basement/UTF8/Helper.hs0000644000000000000000000001153513141321320015531 0ustar0000000000000000-- | -- Module : Basement.UTF8.Helper -- License : BSD-style -- Maintainer : Foundation -- -- Some low level helpers to use UTF8 -- -- Most helpers are lowlevel and unsafe, don't use -- directly. {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} module Basement.UTF8.Helper where import Basement.Compat.Base import Basement.Compat.Primitive import Basement.Types.OffsetSize import GHC.Prim import GHC.Types import GHC.Word -- mask an UTF8 continuation byte (stripping the leading 10 and returning 6 valid bits) maskContinuation# :: Word# -> Word# maskContinuation# v = and# v 0x3f## {-# INLINE maskContinuation# #-} -- mask a UTF8 header for 2 bytes encoding (110xxxxx and 5 valid bits) maskHeader2# :: Word# -> Word# maskHeader2# h = and# h 0x1f## {-# INLINE maskHeader2# #-} -- mask a UTF8 header for 3 bytes encoding (1110xxxx and 4 valid bits) maskHeader3# :: Word# -> Word# maskHeader3# h = and# h 0xf## {-# INLINE maskHeader3# #-} -- mask a UTF8 header for 3 bytes encoding (11110xxx and 3 valid bits) maskHeader4# :: Word# -> Word# maskHeader4# h = and# h 0x7## {-# INLINE maskHeader4# #-} or3# :: Word# -> Word# -> Word# -> Word# or3# a b c = or# a (or# b c) {-# INLINE or3# #-} or4# :: Word# -> Word# -> Word# -> Word# -> Word# or4# a b c d = or# (or# a b) (or# c d) {-# INLINE or4# #-} toChar# :: Word# -> Char toChar# w = C# (chr# (word2Int# w)) {-# INLINE toChar# #-} toChar1 :: Word8 -> Char toChar1 (W8# w) = toChar# w toChar2 :: Word8 -> Word8 -> Char toChar2 (W8# w1) (W8# w2)= toChar# (or# (uncheckedShiftL# (maskHeader2# w1) 6#) (maskContinuation# w2)) toChar3 :: Word8 -> Word8 -> Word8 -> Char toChar3 (W8# w1) (W8# w2) (W8# w3) = toChar# (or3# (uncheckedShiftL# (maskHeader3# w1) 12#) (uncheckedShiftL# (maskContinuation# w2) 6#) (maskContinuation# w3) ) toChar4 :: Word8 -> Word8 -> Word8 -> Word8 -> Char toChar4 (W8# w1) (W8# w2) (W8# w3) (W8# w4) = toChar# (or4# (uncheckedShiftL# (maskHeader4# w1) 18#) (uncheckedShiftL# (maskContinuation# w2) 12#) (uncheckedShiftL# (maskContinuation# w3) 6#) (maskContinuation# w4) ) -- | Different way to encode a Character in UTF8 represented as an ADT data UTF8Char = UTF8_1 {-# UNPACK #-} !Word8 | UTF8_2 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 | UTF8_3 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 | UTF8_4 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 -- | Transform a Unicode code point 'Char' into -- -- note that we expect here a valid unicode code point in the *allowed* range. -- bits will be lost if going above 0x10ffff asUTF8Char :: Char -> UTF8Char asUTF8Char !c | bool# (ltWord# x 0x80## ) = encode1 | bool# (ltWord# x 0x800## ) = encode2 | bool# (ltWord# x 0x10000##) = encode3 | otherwise = encode4 where !(I# xi) = fromEnum c !x = int2Word# xi encode1 = UTF8_1 (W8# x) encode2 = let !x1 = W8# (or# (uncheckedShiftRL# x 6#) 0xc0##) !x2 = toContinuation x in UTF8_2 x1 x2 encode3 = let !x1 = W8# (or# (uncheckedShiftRL# x 12#) 0xe0##) !x2 = toContinuation (uncheckedShiftRL# x 6#) !x3 = toContinuation x in UTF8_3 x1 x2 x3 encode4 = let !x1 = W8# (or# (uncheckedShiftRL# x 18#) 0xf0##) !x2 = toContinuation (uncheckedShiftRL# x 12#) !x3 = toContinuation (uncheckedShiftRL# x 6#) !x4 = toContinuation x in UTF8_4 x1 x2 x3 x4 toContinuation :: Word# -> Word8 toContinuation w = W8# (or# (and# w 0x3f##) 0x80##) {-# INLINE toContinuation #-} -- given the encoding of UTF8 Char, get the number of bytes of this sequence numBytes :: UTF8Char -> CountOf Word8 numBytes UTF8_1{} = CountOf 1 numBytes UTF8_2{} = CountOf 2 numBytes UTF8_3{} = CountOf 3 numBytes UTF8_4{} = CountOf 4 -- given the leading byte of a utf8 sequence, get the number of bytes of this sequence skipNextHeaderValue :: Word8 -> CountOf Word8 skipNextHeaderValue !x | x < 0xC0 = CountOf 1 -- 0b11000000 | x < 0xE0 = CountOf 2 -- 0b11100000 | x < 0xF0 = CountOf 3 -- 0b11110000 | otherwise = CountOf 4 {-# INLINE skipNextHeaderValue #-} headerIsAscii :: Word8 -> Bool headerIsAscii x = x < 0x80 charToBytes :: Int -> CountOf Word8 charToBytes c | c < 0x80 = CountOf 1 | c < 0x800 = CountOf 2 | c < 0x10000 = CountOf 3 | c < 0x110000 = CountOf 4 | otherwise = error ("invalid code point: " `mappend` show c) basement-0.0.4/Basement/UTF8/Table.hs0000644000000000000000000001125213176251306015353 0ustar0000000000000000-- | -- 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 , isContinuation2 , isContinuation3 , getNbBytes , isContinuation# , getNbBytes# ) where import GHC.Prim import GHC.Types import GHC.Word import Basement.Compat.Base import Basement.Compat.Primitive -- | Check if the byte is a continuation byte isContinuation :: Word8 -> Bool isContinuation (W8# w) = isContinuation# w {-# INLINE isContinuation #-} isContinuation2 :: Word8 -> Word8 -> Bool isContinuation2 (W8# w1) (W8# w2) = bool# (mask w1 `andI#` mask w2) where mask v = (and# 0xC0## v) `eqWord#` 0x80## {-# INLINE isContinuation2 #-} isContinuation3 :: Word8 -> Word8 -> Word8 -> Bool isContinuation3 (W8# w1) (W8# w2) (W8# w3) = bool# (mask w1) && bool# (mask w2) && bool# (mask w3) where mask v = (and# 0xC0## v) `eqWord#` 0x80## {-# INLINE isContinuation3 #-} -- | Number of bytes associated with a specific header byte -- -- If the header byte is invalid then NbBytesInvalid is returned, data NbBytesCont = NbBytesInvalid | NbBytesCont0 | NbBytesCont1 | NbBytesCont2 | NbBytesCont3 -- | Identical to 'NbBytesCont' but doesn't allow to represent any failure. -- -- Only use in validated place data NbBytesCont_ = NbBytesCont0_ | NbBytesCont1_ | NbBytesCont2_ | NbBytesCont3_ -- | 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 "\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\ \\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\ \\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\ \\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\ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ \\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\ \\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"# {-# NOINLINE contTable #-} headTable :: Table headTable = Table "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\ \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\ \\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\ \\x03\x03\x03\x03\x03\x03\x03\x03\xff\xff\xff\xff\xff\xff\xff\xff"# {-# NOINLINE headTable #-} basement-0.0.4/Basement/UTF8/Types.hs0000644000000000000000000000303613141321320015413 0ustar0000000000000000module Basement.UTF8.Types ( -- * Stepper Step(..) , StepBack(..) , StepASCII(..) , StepDigit(..) , isValidStepASCII , isValidStepDigit -- * Unicode Errors , ValidationFailure(..) ) where import Basement.Compat.Base import Basement.Types.OffsetSize -- | Step when walking a String -- -- this is a return value composed of : -- * the unicode code point read (Char) which need to be -- between 0 and 0x10ffff (inclusive) -- * The next offset to start reading the next unicode code point (or end) data Step = Step {-# UNPACK #-} !Char {-# UNPACK #-} !(Offset Word8) -- | Similar to Step but used when processing the string from the end. -- -- The stepper is thus the previous character, and the offset of -- the beginning of the previous character data StepBack = StepBack {-# UNPACK #-} !Char {-# UNPACK #-} !(Offset Word8) -- | Step when processing digits. the value is between 0 and 9 to be valid newtype StepDigit = StepDigit Word8 -- | Step when processing ASCII character newtype StepASCII = StepASCII Word8 isValidStepASCII :: StepASCII -> Bool isValidStepASCII (StepASCII w) = w < 0x80 isValidStepDigit :: StepDigit -> Bool isValidStepDigit (StepDigit w) = w < 0xa -- | Possible failure related to validating bytes of UTF8 sequences. data ValidationFailure = InvalidHeader | InvalidContinuation | MissingByte | BuildingFailure deriving (Show,Eq,Typeable) instance Exception ValidationFailure basement-0.0.4/Basement/UArray/Base.hs0000644000000000000000000006033713201545546015664 0ustar0000000000000000{-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} 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 , thaw , copy -- * Array accessor , unsafeIndex , unsafeIndexer , onBackend , onBackendPure , onBackendPure' , onBackendPrim , onMutableBackend , unsafeDewrap , unsafeDewrap2 -- * Basic lowlevel functions , vFromListN , empty , length , offset , ValidRange(..) , offsetsValidRange , equal , equalMemcmp , compare , copyAt , unsafeCopyAtRO , toBlock -- * 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 Basement.Compat.Semigroup import qualified Basement.Runtime as Runtime import Data.Proxy import qualified Basement.Compat.ExtList as List import qualified Basement.Alg.Class as Alg 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.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) instance PrimType ty => Alg.Indexable (Ptr ty) ty where index (Ptr addr) = primAddrIndex addr instance (PrimMonad prim, PrimType ty) => Alg.RandomAccess (Ptr ty) prim ty where read (Ptr addr) = primAddrRead addr write (Ptr addr) = primAddrWrite addr -- | 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 => Semigroup (UArray ty) where (<>) = append 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 fromListN len = vFromListN (CountOf len) 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 -> (MutableBlock ty (PrimState prim) -> prim a) -> prim (a, MUArray ty (PrimState prim)) newNative n f = do mb <- MBLK.new n a <- f mb 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 #-} -- | Thaw an array to a mutable array. -- -- the array is not modified, instead a new mutable array is created -- and every values is copied, before returning the mutable array. thaw :: (PrimMonad prim, PrimType ty) => UArray ty -> prim (MUArray ty (PrimState prim)) thaw array = do ma <- new (length array) unsafeCopyAtRO ma azero array (Offset 0) (length array) pure ma {-# INLINE thaw #-} -- | Copy every cells of an existing array to a new array copy :: PrimType ty => UArray ty -> UArray ty copy array = runST (thaw array >>= unsafeFreeze) onBackend :: (Block ty -> a) -> (FinalPtr ty -> Ptr ty -> ST s a) -> UArray ty -> a onBackend onBa _ (UArray _ _ (UArrayBA ba)) = onBa ba onBackend _ onAddr (UArray _ _ (UArrayAddr fptr)) = withUnsafeFinalPtr fptr $ \ptr@(Ptr !_) -> onAddr fptr ptr {-# INLINE onBackend #-} onBackendPure :: (Block ty -> a) -> (Ptr ty -> a) -> UArray ty -> a onBackendPure goBA goAddr arr = onBackend goBA (\_ -> pureST . goAddr) arr {-# INLINE onBackendPure #-} onBackendPure' :: PrimType ty => UArray ty -> (forall container. Alg.Indexable container ty => container -> Offset ty -> Offset ty -> a) -> a onBackendPure' arr f = onBackendPure (\c -> f c start end) (\c -> f c start end) arr where !len = length arr !start = offset arr !end = start `offsetPlusE` len {-# INLINE onBackendPure' #-} onBackendPrim :: PrimMonad prim => (Block ty -> prim a) -> (FinalPtr ty -> prim a) -> UArray ty -> prim a onBackendPrim onBa _ (UArray _ _ (UArrayBA ba)) = onBa ba onBackendPrim _ onAddr (UArray _ _ (UArrayAddr fptr)) = onAddr fptr {-# INLINE onBackendPrim #-} onMutableBackend :: PrimMonad prim => (MutableBlock ty (PrimState prim) -> prim a) -> (FinalPtr ty -> prim a) -> MUArray ty (PrimState prim) -> prim a onMutableBackend onMba _ (MUArray _ _ (MUArrayMBA 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 :: forall ty . PrimType ty => [ty] -> UArray ty vFromList l = runST $ do ((), ma) <- newNative len copyList unsafeFreeze ma where len = List.length l copyList :: MutableBlock ty s -> ST s () copyList mb = loop 0 l where loop _ [] = pure () loop !i (x:xs) = MBLK.unsafeWrite mb i x >> loop (i+1) xs -- | Make an array from a list of elements with a size hint. -- -- The list should be of the same size as the hint, as otherwise: -- -- * The length of the list is smaller than the hint: -- the array allocated is of the size of the hint, but is sliced -- to only represent the valid bits -- * The length of the list is bigger than the hint: -- The allocated array is the size of the hint, and the list is truncated to -- fit. vFromListN :: forall ty . PrimType ty => CountOf ty -> [ty] -> UArray ty vFromListN len l = runST $ do (sz, ma) <- newNative len copyList unsafeFreezeShrink ma sz where copyList :: MutableBlock ty s -> ST s (CountOf ty) copyList mb = loop 0 l where loop !i [] = pure (offsetAsSize i) loop !i (x:xs) | i .==# len = pure (offsetAsSize i) | otherwise = MBLK.unsafeWrite mb i x >> loop (i+1) xs -- | transform an array to a list. vToList :: forall ty . PrimType ty => UArray ty -> [ty] vToList a | 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 -- | Create a Block from a UArray. -- -- Note that because of the slice, the destination block -- is re-allocated and copied, unless the slice point -- at the whole array toBlock :: PrimType ty => UArray ty -> Block ty toBlock arr@(UArray start len (UArrayBA blk)) | start == 0 && BLK.length blk == len = blk | otherwise = toBlock $ copy arr toBlock arr = toBlock $ copy arr basement-0.0.4/Basement/String/Encoding/Encoding.hs0000644000000000000000000000716313141321320020310 0ustar0000000000000000-- | -- Module : Basement.String.Encoding.Encoding -- License : BSD-style -- Maintainer : Foundation -- Stability : experimental -- Portability : portable -- {-# LANGUAGE FlexibleContexts #-} module Basement.String.Encoding.Encoding ( Encoding(..) , convertFromTo ) where import Basement.Compat.Base import Basement.Types.OffsetSize import Basement.Monad import Basement.PrimType import Basement.MutableBuilder import Basement.Numerical.Additive import Basement.UArray (UArray) import Basement.UArray.Mutable (MUArray) import qualified Basement.UArray as Vec class Encoding encoding where -- | the unit element use for the encoding. -- i.e. Word8 for ASCII7 or UTF8, Word16 for UTF16... -- type Unit encoding -- | define the type of error handling you want to use for the -- next function. -- -- > type Error UTF8 = Either UTF8_Invalid -- type Error encoding -- | consume an `Unit encoding` and return the Unicode point and the position -- of the next possible `Unit encoding` -- encodingNext :: encoding -- ^ only used for type deduction -> (Offset (Unit encoding) -> Unit encoding) -- ^ method to access a given `Unit encoding` -- (see `unsafeIndexer`) -> Offset (Unit encoding) -- ^ offset of the `Unit encoding` where starts the -- encoding of a given unicode -> Either (Error encoding) (Char, Offset (Unit encoding)) -- ^ either successfully validated the `Unit encoding` -- and returned the next offset or fail with an -- `Error encoding` -- Write a unicode point encoded into one or multiple `Unit encoding` -- -- > build 64 $ sequence_ (write UTF8) "this is a simple list of char..." -- encodingWrite :: (PrimMonad st, Monad st) => encoding -- ^ only used for type deduction -> Char -- ^ the unicode character to encode -> Builder (UArray (Unit encoding)) (MUArray (Unit encoding)) (Unit encoding) st err () -- | helper to convert a given Array in a given encoding into an array -- with another encoding. -- -- This is a helper to convert from one String encoding to another. -- This function is (quite) slow and needs some work. -- -- ``` -- let s16 = ... -- string in UTF16 -- -- create s8, a UTF8 String -- let s8 = runST $ convertWith UTF16 UTF8 (toBytes s16) -- -- print s8 -- ``` -- convertFromTo :: ( PrimMonad st, Monad st , Encoding input, PrimType (Unit input) , Encoding output, PrimType (Unit output) ) => input -- ^ Input's encoding type -> output -- ^ Output's encoding type -> UArray (Unit input) -- ^ the input raw array -> st (Either (Offset (Unit input), Error input) (UArray (Unit output))) convertFromTo inputEncodingTy outputEncodingTy bytes | Vec.null bytes = return . return $ mempty | otherwise = Vec.unsafeIndexer bytes $ \t -> Vec.builderBuild 64 (loop azero t) where lastUnit = Vec.length bytes loop off getter | off .==# lastUnit = return () | otherwise = case encodingNext inputEncodingTy getter off of Left err -> mFail (off, err) Right (c, noff) -> encodingWrite outputEncodingTy c >> loop noff getter basement-0.0.4/Basement/String/Encoding/UTF16.hs0000644000000000000000000000573313141321320017370 0ustar0000000000000000-- | -- Module : Basement.String.Encoding.UTF16 -- License : BSD-style -- Maintainer : Foundation -- Stability : experimental -- Portability : portable -- {-# LANGUAGE MagicHash #-} module Basement.String.Encoding.UTF16 ( UTF16(..) , UTF16_Invalid(..) ) where import GHC.Prim import GHC.Word import GHC.Types import Data.Bits import qualified Prelude import Basement.Compat.Base import Basement.Types.OffsetSize import Basement.Monad import Basement.Numerical.Additive import Basement.UArray import Basement.UArray.Mutable (MUArray) import Basement.MutableBuilder import Basement.String.Encoding.Encoding data UTF16_Invalid = InvalidContinuation | InvalidUnicode Char deriving (Show, Eq, Typeable) instance Exception UTF16_Invalid data UTF16 = UTF16 instance Encoding UTF16 where type Unit UTF16 = Word16 type Error UTF16 = UTF16_Invalid encodingNext _ = next encodingWrite _ = write -- -- U+0000 to U+D7FF and U+E000 to U+FFFF : 1 bytes -- U+10000 to U+10FFFF : -- * 0x010000 is subtracted from the code point, leaving a 20-bit number in the range 0..0x0FFFFF. -- * The top ten bits (a number in the range 0..0x03FF) are added to 0xD800 to give the first 16-bit code unit -- or high surrogate, which will be in the range 0xD800..0xDBFF. -- * The low ten bits (also in the range 0..0x03FF) are added to 0xDC00 to give the second 16-bit code unit -- or low surrogate, which will be in the range 0xDC00..0xDFFF. next :: (Offset Word16 -> Word16) -> Offset Word16 -> Either UTF16_Invalid (Char, Offset Word16) next getter off | h < 0xd800 = Right (toChar hh, off + Offset 1) | h >= 0xe000 = Right (toChar hh, off + Offset 1) | otherwise = nextContinuation where h :: Word16 !h@(W16# hh) = getter off toChar :: Word# -> Char toChar w = C# (chr# (word2Int# w)) to32 :: Word16 -> Word32 to32 (W16# w) = W32# w nextContinuation | cont >= 0xdc00 && cont < 0xe00 = let !(W32# w) = ((to32 h .&. 0x3ff) `shiftL` 10) .|. (to32 cont .&. 0x3ff) in Right (toChar w, off + Offset 2) | otherwise = Left InvalidContinuation where cont :: Word16 !cont = getter $ off + Offset 1 write :: (PrimMonad st, Monad st) => Char -> Builder (UArray Word16) (MUArray Word16) Word16 st err () write c | c < toEnum 0xd800 = builderAppend $ w16 c | c > toEnum 0x10000 = let (w1, w2) = wHigh c in builderAppend w1 >> builderAppend w2 | c > toEnum 0x10ffff = throw $ InvalidUnicode c | c >= toEnum 0xe000 = builderAppend $ w16 c | otherwise = throw $ InvalidUnicode c where w16 :: Char -> Word16 w16 (C# ch) = W16# (int2Word# (ord# ch)) to16 :: Word32 -> Word16 to16 = Prelude.fromIntegral wHigh :: Char -> (Word16, Word16) wHigh (C# ch) = let v = W32# (minusWord# (int2Word# (ord# ch)) 0x10000##) in (0xdc00 .|. to16 (v `shiftR` 10), 0xd800 .|. to16 (v .&. 0x3ff)) basement-0.0.4/Basement/String/Encoding/UTF32.hs0000644000000000000000000000250213141321320017355 0ustar0000000000000000-- | -- Module : Basement.String.Encoding.UTF32 -- License : BSD-style -- Maintainer : Foundation -- Stability : experimental -- Portability : portable -- {-# LANGUAGE MagicHash #-} module Basement.String.Encoding.UTF32 ( UTF32(..) , UTF32_Invalid ) where import GHC.Prim import GHC.Word import GHC.Types import Basement.Compat.Base import Basement.Types.OffsetSize import Basement.Monad import Basement.Numerical.Additive import Basement.UArray import Basement.UArray.Mutable (MUArray) import Basement.MutableBuilder import Basement.String.Encoding.Encoding data UTF32 = UTF32 data UTF32_Invalid = UTF32_Invalid deriving (Typeable, Show, Eq, Ord, Enum, Bounded) instance Exception UTF32_Invalid instance Encoding UTF32 where type Unit UTF32 = Word32 type Error UTF32 = UTF32_Invalid encodingNext _ = next encodingWrite _ = write next :: (Offset Word32 -> Word32) -> Offset Word32 -> Either UTF32_Invalid (Char, Offset Word32) next getter off = Right (char, off + Offset 1) where !(W32# hh) = getter off char :: Char char = C# (chr# (word2Int# hh)) write :: (PrimMonad st, Monad st) => Char -> Builder (UArray Word32) (MUArray Word32) Word32 st err () write c = builderAppend w32 where !(C# ch) = c w32 :: Word32 w32 = W32# (int2Word# (ord# ch)) basement-0.0.4/Basement/String/Encoding/ASCII7.hs0000644000000000000000000000432213141321320017473 0ustar0000000000000000-- | -- Module : Basement.String.Encoding.ASCII7 -- License : BSD-style -- Maintainer : Foundation -- Stability : experimental -- Portability : portable -- {-# LANGUAGE MagicHash #-} module Basement.String.Encoding.ASCII7 ( ASCII7(..) , ASCII7_Invalid(..) ) where import Basement.Compat.Base import Basement.Types.OffsetSize import Basement.Numerical.Additive import Basement.Monad import GHC.Prim import GHC.Word import GHC.Types import Basement.UArray import Basement.UArray.Mutable (MUArray) import Basement.MutableBuilder import Basement.String.Encoding.Encoding -- | validate a given byte is within ASCII characters encoring size -- -- This function check the 8th bit is set to 0 -- isAscii :: Word8 -> Bool isAscii (W8# w) = W8# (and# w 0x80## ) == 0 {-# INLINE isAscii #-} data ASCII7_Invalid = ByteOutOfBound Word8 | CharNotAscii Char deriving (Typeable, Show, Eq) instance Exception ASCII7_Invalid data ASCII7 = ASCII7 instance Encoding ASCII7 where type Unit ASCII7 = Word8 type Error ASCII7 = ASCII7_Invalid encodingNext _ = next encodingWrite _ = write -- | consume an Ascii7 char and return the Unicode point and the position -- of the next possible Ascii7 char -- next :: (Offset Word8 -> Word8) -- ^ method to access a given byte -> Offset Word8 -- ^ index of the byte -> Either ASCII7_Invalid (Char, Offset Word8) -- ^ either successfully validated the ASCII char and returned the -- next index or fail with an error next getter off | isAscii w8 = Right (toChar w, off + 1) | otherwise = Left $ ByteOutOfBound w8 where !w8@(W8# w) = getter off toChar :: Word# -> Char toChar a = C# (chr# (word2Int# a)) -- Write ascii char -- -- > build 64 $ sequence_ write "this is a simple list of char..." -- write :: (PrimMonad st, Monad st) => Char -- ^ expecting it to be a valid Ascii character. -- otherwise this function will throw an exception -> Builder (UArray Word8) (MUArray Word8) Word8 st err () write c | c < toEnum 0x80 = builderAppend $ w8 c | otherwise = throw $ CharNotAscii c where w8 :: Char -> Word8 w8 (C# ch) = W8# (int2Word# (ord# ch)) basement-0.0.4/Basement/String/Encoding/ISO_8859_1.hs0000644000000000000000000000276713141321320020136 0ustar0000000000000000-- | -- Module : Basement.String.Encoding.ISO_8859_1 -- License : BSD-style -- Maintainer : Foundation -- Stability : experimental -- Portability : portable -- {-# LANGUAGE MagicHash #-} module Basement.String.Encoding.ISO_8859_1 ( ISO_8859_1(..) , ISO_8859_1_Invalid(..) ) where import Basement.Compat.Base import Basement.Types.OffsetSize import Basement.Numerical.Additive import Basement.Monad import GHC.Prim import GHC.Word import GHC.Types import Basement.UArray import Basement.UArray.Mutable (MUArray) import Basement.MutableBuilder import Basement.String.Encoding.Encoding -- offset of size one aone :: Offset Word8 aone = Offset 1 data ISO_8859_1_Invalid = NotISO_8859_1 Char deriving (Typeable, Show, Eq) instance Exception ISO_8859_1_Invalid data ISO_8859_1 = ISO_8859_1 instance Encoding ISO_8859_1 where type Unit ISO_8859_1 = Word8 type Error ISO_8859_1 = ISO_8859_1_Invalid encodingNext _ = next encodingWrite _ = write next :: (Offset Word8 -> Word8) -> Offset Word8 -> Either ISO_8859_1_Invalid (Char, Offset Word8) next getter off = Right (toChar w, off + aone) where !(W8# w) = getter off toChar :: Word# -> Char toChar a = C# (chr# (word2Int# a)) write :: (PrimMonad st, Monad st) => Char -> Builder (UArray Word8) (MUArray Word8) Word8 st err () write c@(C# ch) | c <= toEnum 0xFF = builderAppend (W8# x) | otherwise = throw $ NotISO_8859_1 c where x :: Word# !x = int2Word# (ord# ch) basement-0.0.4/Basement/Terminal/Size.hsc0000644000000000000000000001420513201626577016434 0ustar0000000000000000{-# LANGUAGE CApiFFI #-} module Basement.Terminal.Size ( getDimensions ) where import Foreign import Foreign.C import Basement.Compat.Base import Basement.Types.OffsetSize import Basement.Numerical.Subtractive import Basement.Numerical.Additive import Prelude (fromIntegral) #include "foundation_system.h" #ifdef FOUNDATION_SYSTEM_WINDOWS import System.Win32.Types (HANDLE, BOOL) import Graphics.Win32.Misc (getStdHandle, sTD_OUTPUT_HANDLE, StdHandleId) #include #elif defined FOUNDATION_SYSTEM_UNIX #include #endif #include #if __GLASGOW_HASKELL__ < 800 #let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) #endif #ifdef FOUNDATION_SYSTEM_UNIX data Winsize = Winsize { ws_row :: !Word16 , ws_col :: !Word16 , ws_xpixel :: !Word16 , ws_ypixel :: !Word16 } instance Storable Winsize where sizeOf _ = #{size struct winsize} alignment _ = #{alignment struct winsize} peek ptr = do r <- #{peek struct winsize, ws_row} ptr c <- #{peek struct winsize, ws_col} ptr x <- #{peek struct winsize, ws_xpixel} ptr y <- #{peek struct winsize, ws_ypixel} ptr return (Winsize r c x y) poke ptr (Winsize r c x y) = do #{poke struct winsize, ws_row} ptr r #{poke struct winsize, ws_col} ptr c #{poke struct winsize, ws_xpixel} ptr x #{poke struct winsize, ws_ypixel} ptr y #elif defined FOUNDATION_SYSTEM_WINDOWS type Handle = Ptr CChar -- void * data SmallRect = SmallRect { left :: !Int16 , top :: !Int16 , right :: !Int16 , bottom :: !Int16 } deriving (Show) instance Storable SmallRect where sizeOf _ = #{size SMALL_RECT} alignment _ = #{alignment SMALL_RECT} peek ptr = do l <- #{peek SMALL_RECT, Left} ptr r <- #{peek SMALL_RECT, Right} ptr t <- #{peek SMALL_RECT, Top} ptr b <- #{peek SMALL_RECT, Bottom} ptr return (SmallRect l t r b) poke ptr (SmallRect l t r b) = do #{poke SMALL_RECT, Left} ptr l #{poke SMALL_RECT, Top} ptr t #{poke SMALL_RECT, Right} ptr r #{poke SMALL_RECT, Bottom} ptr b data Coord = Coord { x :: !Int16 , y :: !Int16 } deriving (Show) instance Storable Coord where sizeOf _ = #{size COORD} alignment _ = #{alignment COORD} peek ptr = do x <- #{peek COORD, X} ptr y <- #{peek COORD, Y} ptr return (Coord x y) poke ptr (Coord x y) = do #{poke COORD, X} ptr x #{poke COORD, Y} ptr y data ConsoleScreenBufferInfo = ConsoleScreenBufferInfo { dwSize :: !Coord , dwCursorPosition :: !Coord , wAttributes :: !Word16 , srWindow :: !SmallRect , dwMaximumWindowSize :: !Coord } deriving (Show) instance Storable ConsoleScreenBufferInfo where sizeOf _ = #{size CONSOLE_SCREEN_BUFFER_INFO} alignment _ = #{alignment CONSOLE_SCREEN_BUFFER_INFO} peek ptr = do s <- #{peek CONSOLE_SCREEN_BUFFER_INFO, dwSize} ptr c <- #{peek CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition} ptr a <- #{peek CONSOLE_SCREEN_BUFFER_INFO, wAttributes} ptr w <- #{peek CONSOLE_SCREEN_BUFFER_INFO, srWindow} ptr m <- #{peek CONSOLE_SCREEN_BUFFER_INFO, dwMaximumWindowSize} ptr return (ConsoleScreenBufferInfo s c a w m) poke ptr (ConsoleScreenBufferInfo s c a w m) = do #{poke CONSOLE_SCREEN_BUFFER_INFO, dwSize} ptr s #{poke CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition} ptr c #{poke CONSOLE_SCREEN_BUFFER_INFO, wAttributes} ptr a #{poke CONSOLE_SCREEN_BUFFER_INFO, srWindow} ptr w #{poke CONSOLE_SCREEN_BUFFER_INFO, dwMaximumWindowSize} ptr m invalidHandleValue :: IntPtr invalidHandleValue = #{const INVALID_HANDLE_VALUE} stdOutputHandle :: CULong stdOutputHandle = #{const STD_OUTPUT_HANDLE} #endif -- defined FOUNDATION_SYSTEM_WINDOWS #ifdef FOUNDATION_SYSTEM_UNIX foreign import capi "sys/ioctl.h ioctl" c_ioctl :: CInt -> CULong -> Ptr a -> IO CInt -- | Get the terminal windows size tiocgwinsz :: CULong tiocgwinsz = Prelude.fromIntegral (#{const TIOCGWINSZ} :: Word) #elif defined FOUNDATION_SYSTEM_WINDOWS foreign import ccall "GetConsoleScreenBufferInfo" c_get_console_screen_buffer_info :: HANDLE -> Ptr ConsoleScreenBufferInfo -> IO BOOL #endif #ifdef FOUNDATION_SYSTEM_UNIX ioctlWinsize :: CInt -> IO (Maybe (CountOf Char, CountOf Char)) ioctlWinsize fd = alloca $ \winsizePtr -> do status <- c_ioctl fd tiocgwinsz winsizePtr if status == (-1 :: CInt) then pure Nothing else Just . toDimensions <$> peek winsizePtr where toDimensions winsize = ( CountOf . Prelude.fromIntegral . ws_col $ winsize , CountOf . Prelude.fromIntegral . ws_row $ winsize) #elif defined FOUNDATION_SYSTEM_WINDOWS getConsoleScreenBufferInfo :: HANDLE -> IO (Maybe ConsoleScreenBufferInfo) getConsoleScreenBufferInfo handle = alloca $ \infoPtr -> do status <- c_get_console_screen_buffer_info handle infoPtr if status then Just <$> peek infoPtr else pure Nothing winWinsize :: StdHandleId -> IO (Maybe (CountOf Char, CountOf Char)) winWinsize handleRef = (infoToDimensions <$>) <$> (getStdHandle handleRef >>= getConsoleScreenBufferInfo) where infoToDimensions info = let window = srWindow info width = Prelude.fromIntegral (right window - left window + 1) height = Prelude.fromIntegral (bottom window - top window + 1) in (CountOf width, CountOf height) #endif -- defined FOUNDATION_SYSTEM_WINDOWS -- | Return the size of the current terminal -- -- If the system is not supported or that querying the system result in an error -- then a default size of (80, 24) will be given back. getDimensions :: IO (CountOf Char, CountOf Char) getDimensions = #if defined FOUNDATION_SYSTEM_WINDOWS maybe defaultSize id <$> winWinsize sTD_OUTPUT_HANDLE #elif defined FOUNDATION_SYSTEM_UNIX maybe defaultSize id <$> ioctlWinsize 0 #else pure defaultSize #endif where defaultSize = (80, 24) basement-0.0.4/cbits/foundation_mem.c0000644000000000000000000000065613141321320015750 0ustar0000000000000000#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); } basement-0.0.4/cbits/foundation_rts.c0000644000000000000000000000023113141321320015767 0ustar0000000000000000#include "Rts.h" #if __GLASGOW_HASKELL__ < 802 int foundation_is_bytearray_pinned(void *p) { return Bdescr((StgPtr) p)->flags & BF_PINNED; } #endif basement-0.0.4/LICENSE0000644000000000000000000000300613141321320012471 0ustar0000000000000000Copyright (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. basement-0.0.4/Setup.hs0000644000000000000000000000005613141321320013122 0ustar0000000000000000import Distribution.Simple main = defaultMain basement-0.0.4/basement.cabal0000644000000000000000000001232013201626623014260 0ustar0000000000000000name: basement version: 0.0.4 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.Types.Word128 Basement.Types.Word256 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 -- Terminal Basement.Terminal Basement.Terminal.ANSI -- 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.Semigroup Basement.Compat.Natural Basement.Compat.NumLiteral Basement.Compat.Typeable if impl(ghc >= 8.0) exposed-modules: Basement.BlockN , Basement.Sized.Block , Basement.Sized.UVect , Basement.Sized.Vect if impl(ghc >= 7.10) exposed-modules: Basement.Sized.List other-modules: Basement.Error Basement.Show Basement.Runtime Basement.Alg.Class Basement.Alg.Mutable Basement.Alg.PrimArray Basement.Alg.Native.Prim Basement.Alg.Native.UTF8 Basement.Alg.Native.String Basement.Alg.Foreign.Prim Basement.Alg.Foreign.UTF8 Basement.Alg.Foreign.String Basement.Numerical.Conversion Basement.Block.Base Basement.UTF8.Base Basement.UTF8.Helper Basement.UTF8.Table Basement.UTF8.Types Basement.UArray.Base Basement.String.Encoding.Encoding Basement.String.Encoding.UTF16 Basement.String.Encoding.UTF32 Basement.String.Encoding.ASCII7 Basement.String.Encoding.ISO_8859_1 Basement.Terminal.Size build-depends: base >= 4.7 && < 5 , ghc-prim if os(windows) build-depends: Win32 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 basement-0.0.4/cbits/foundation_prim.h0000644000000000000000000000020113141321320016130 0ustar0000000000000000#ifndef FOUNDATION_PRIM_H #define FOUNDATION_PRIM_H #include "Rts.h" typedef StgInt FsOffset; typedef StgInt FsCountOf; #endif basement-0.0.4/cbits/foundation_system.h0000644000000000000000000000320313201626577016535 0ustar0000000000000000#ifndef FOUNDATION_SYSTEM_H # define FOUNDATION_SYSTEM_H #ifdef _WIN32 #define FOUNDATION_SYSTEM_WINDOWS #define FOUNDATION_SYSTEM_API_NO_CLOCK //define something for Windows (32-bit and 64-bit, this part is common) #ifdef _WIN64 #define FOUNDATION_SYSTEM_WINDOWS_64 //define something for Windows (64-bit only) #else #define FOUNDATION_SYSTEM_WINDOWS_32 //define something for Windows (32-bit only) #endif #elif __APPLE__ #include "TargetConditionals.h" #include "Availability.h" #if TARGET_OS_MAC #define FOUNDATION_SYSTEM_UNIX #define FOUNDATION_SYSTEM_MACOS #if !defined(__MAC_10_12) || __MAC_OS_X_VERSION_MIN_REQUIRED < __MAC_10_12 #define FOUNDATION_SYSTEM_API_NO_CLOCK #endif // Other kinds of Mac OS #else # error "foundation: system: Unknown Apple platform" #endif #elif __linux__ #define FOUNDATION_SYSTEM_UNIX #define FOUNDATION_SYSTEM_LINUX // linux #elif defined(__FreeBSD__) #define FOUNDATION_SYSTEM_UNIX #define FOUNDATION_SYSTEM_BSD #define FOUNDATION_SYSTEM_FREEBSD // freeBSD #elif defined(__NetBSD__) #define FOUNDATION_SYSTEM_UNIX #define FOUNDATION_SYSTEM_BSD #define FOUNDATION_SYSTEM_NETBSD // NetBSD #elif defined(__OpenBSD__) #define FOUNDATION_SYSTEM_UNIX #define FOUNDATION_SYSTEM_BSD #define FOUNDATION_SYSTEM_OPENBSD // OpenBSD #elif __unix__ // all unices not caught above #define FOUNDATION_SYSTEM_UNIX // Unix #elif defined(_POSIX_VERSION) #define FOUNDATION_SYSTEM_UNIX // POSIX #else # error "foundation: system: Unknown compiler" #endif #endif