diff --git a/Foundation.hs b/Foundation.hs --- a/Foundation.hs +++ b/Foundation.hs @@ -27,7 +27,7 @@ , Prelude.either , Prelude.flip , Prelude.const - , Foundation.Primitive.Error.error + , Basement.Imports.error , Foundation.IO.Terminal.putStr , Foundation.IO.Terminal.putStrLn --, print @@ -44,7 +44,7 @@ , Foundation.Primitive.force -- ** Type classes , Prelude.Show - , show + , Basement.Imports.show , Prelude.Ord (..) , Prelude.Eq (..) , Prelude.Bounded (..) @@ -53,7 +53,7 @@ , Integral (..) , Fractional (..) , HasNegation (..) - , Foundation.Class.Bifunctor.Bifunctor (..) + , Basement.Compat.Bifunctor.Bifunctor (..) , Control.Applicative.Applicative (..) , Prelude.Monad (..) , (Control.Monad.=<<) @@ -74,11 +74,13 @@ , Prelude.Ordering (..) , Prelude.Bool (..) , Prelude.Char + , Char7 , Prelude.IO , Prelude.Either (..) -- ** Numbers , 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 + , Word128, Word256 , Prelude.Int , Prelude.Integer , Natural @@ -135,14 +137,14 @@ , Control.Exception.SomeException , Control.Exception.IOException -- ** Proxy - , Foundation.Internal.Proxy.Proxy(..) - , Foundation.Internal.Proxy.asProxyTypeOf + , Data.Proxy.Proxy(..) + , Data.Proxy.asProxyTypeOf -- ** Partial , Foundation.Partial.Partial , Foundation.Partial.partial , Foundation.Partial.PartialError , Foundation.Partial.fromPartial - , Foundation.Internal.Base.ifThenElse + , Basement.Compat.Base.ifThenElse -- ** Old Prelude Strings as [Char] with bridge back and forth , LString ) where @@ -166,39 +168,34 @@ import qualified Foundation.IO.Terminal import GHC.Exts (IsString(..)) -import Foundation.Internal.IsList -import qualified Foundation.Internal.Base (ifThenElse) -import qualified Foundation.Internal.Proxy -import qualified Foundation.Primitive.Error +import Basement.Compat.IsList +import qualified Basement.Compat.Base (ifThenElse) +import qualified Data.Proxy import qualified Foundation.Numerical import qualified Foundation.Partial import Foundation.Tuple -import qualified Foundation.Class.Bifunctor -import Foundation.Primitive.Types.OffsetSize (CountOf(..), Offset(..)) +import qualified Basement.Compat.Bifunctor +import Basement.Types.OffsetSize (CountOf(..), Offset(..)) +import Basement.Types.Word128 (Word128) +import Basement.Types.Word256 (Word256) +import Basement.Types.Char7 (Char7) import qualified Foundation.Primitive -import Foundation.Primitive.Show -import Foundation.Internal.NumLiteral -import Foundation.Internal.Natural +import qualified Basement.Imports +import Basement.Environment (getArgs) +import Basement.Compat.NumLiteral +import Basement.Compat.Natural import qualified Data.Maybe import qualified Data.Either import qualified Data.Function import qualified Data.Tuple -import qualified System.Environment -import qualified Data.List - - default (Prelude.Integer, Prelude.Double) -- | Alias to Prelude String ([Char]) for compatibility purpose type LString = Prelude.String - --- | Returns a list of the program's command line arguments (not including the program name). -getArgs :: Prelude.IO [String] -getArgs = (Data.List.map fromList <$> System.Environment.getArgs) fromCount :: CountOf ty -> Prelude.Int fromCount (CountOf n) = n diff --git a/Foundation/Array.hs b/Foundation/Array.hs --- a/Foundation/Array.hs +++ b/Foundation/Array.hs @@ -23,9 +23,9 @@ , OutOfBound ) where -import Foundation.Primitive.Exception -import Foundation.Array.Boxed -import Foundation.Array.Unboxed -import Foundation.Array.Unboxed.Mutable +import Basement.Exception +import Basement.BoxedArray +import Basement.UArray +import Basement.UArray.Mutable import Foundation.Array.Bitmap import Foundation.Array.Chunked.Unboxed diff --git a/Foundation/Array/Bitmap.hs b/Foundation/Array/Bitmap.hs --- a/Foundation/Array/Bitmap.hs +++ b/Foundation/Array/Bitmap.hs @@ -29,14 +29,14 @@ , cons ) where -import Foundation.Array.Unboxed (UArray) -import qualified Foundation.Array.Unboxed as A -import Foundation.Array.Unboxed.Mutable (MUArray) -import Foundation.Class.Bifunctor (first, second) -import Foundation.Primitive.Exception -import Foundation.Internal.Base -import Foundation.Primitive.Types.OffsetSize -import Foundation.Primitive.Monad +import Basement.UArray (UArray) +import qualified Basement.UArray as A +import Basement.UArray.Mutable (MUArray) +import Basement.Compat.Bifunctor (first, second, bimap) +import Basement.Exception +import Basement.Compat.Base +import Basement.Types.OffsetSize +import Basement.Monad import qualified Foundation.Collection as C import Foundation.Numerical import Data.Bits @@ -100,6 +100,7 @@ revDrop n = unoptimised (C.revDrop n) splitOn = splitOn break = break + breakEnd = breakEnd span = span filter = filter reverse = reverse @@ -371,6 +372,9 @@ if predicate (unsafeIndex v i) then splitAt (offsetAsSize i) v else findBreak (i+1) + +breakEnd :: (Bool -> Bool) -> Bitmap -> (Bitmap, Bitmap) +breakEnd predicate = bimap fromList fromList . C.breakEnd predicate . toList span :: (Bool -> Bool) -> Bitmap -> (Bitmap, Bitmap) span p = break (not . p) diff --git a/Foundation/Array/Boxed.hs b/Foundation/Array/Boxed.hs deleted file mode 100644 --- a/Foundation/Array/Boxed.hs +++ /dev/null @@ -1,742 +0,0 @@ --- | --- Module : Foundation.Array.Boxed --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : portable --- --- Simple boxed array abstraction --- -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Foundation.Array.Boxed - ( Array - , MArray - , empty - , length - , mutableLength - , copy - , unsafeCopyAtRO - , thaw - , new - , unsafeFreeze - , unsafeThaw - , freeze - , unsafeWrite - , unsafeRead - , unsafeIndex - , write - , read - , index - , singleton - , replicate - , null - , take - , drop - , splitAt - , revTake - , revDrop - , revSplitAt - , splitOn - , sub - , intersperse - , span - , break - , cons - , snoc - , uncons - , unsnoc - -- , findIndex - , sortBy - , filter - , reverse - , elem - , find - , foldl' - , foldr - , foldl1' - , foldr1 - , all - , any - , isPrefixOf - , isSuffixOf - , builderAppend - , builderBuild - , builderBuild_ - ) where - -import GHC.Prim -import GHC.Types -import GHC.ST -import Foundation.Numerical -import Foundation.Collection.NonEmpty -import Foundation.Internal.Base -import Foundation.Internal.Proxy -import Foundation.Internal.MonadTrans -import Foundation.Primitive.Types.OffsetSize -import Foundation.Primitive.Types -import Foundation.Primitive.NormalForm -import Foundation.Primitive.Monad -import Foundation.Primitive.Exception -import Foundation.Boot.Builder -import qualified Foundation.Boot.List as List - --- | Array of a -data Array a = Array {-# UNPACK #-} !(Offset a) - {-# UNPACK #-} !(CountOf a) - (Array# a) - deriving (Typeable) - -instance Data ty => Data (Array ty) where - dataTypeOf _ = arrayType - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - -arrayType :: DataType -arrayType = mkNoRepType "Foundation.Array" - -instance NormalForm a => NormalForm (Array a) where - toNormalForm arr = loop 0 - where - !sz = length arr - loop !i - | i .==# sz = () - | otherwise = unsafeIndex arr i `seq` loop (i+1) - --- | Mutable Array of a -data MArray a st = MArray {-# UNPACK #-} !(Offset a) - {-# UNPACK #-} !(CountOf a) - (MutableArray# st a) - deriving (Typeable) - -instance Functor Array where - fmap = map - -instance Monoid (Array a) where - mempty = empty - mappend = append - mconcat = concat - -instance Show a => Show (Array a) where - show v = show (toList v) - -instance Eq a => Eq (Array a) where - (==) = equal -instance Ord a => Ord (Array a) where - compare = vCompare - -instance IsList (Array ty) where - type Item (Array ty) = ty - fromList = vFromList - toList = vToList - --- | return the numbers of elements in a mutable array -mutableLength :: MArray ty st -> Int -mutableLength (MArray _ (CountOf len) _) = len -{-# INLINE mutableLength #-} - --- | return the numbers of elements in a mutable array -mutableLengthSize :: MArray ty st -> CountOf ty -mutableLengthSize (MArray _ size _) = size -{-# INLINE mutableLengthSize #-} - --- | Return the element at a specific index from an array. --- --- If the index @n is out of bounds, an error is raised. -index :: Array ty -> Offset ty -> ty -index array n - | isOutOfBound n len = outOfBound OOB_Index n len - | otherwise = unsafeIndex array n - where len = length array -{-# INLINE index #-} - --- | Return the element at a specific index from an array without bounds checking. --- --- Reading from invalid memory can return unpredictable and invalid values. --- use 'index' if unsure. -unsafeIndex :: Array ty -> Offset ty -> ty -unsafeIndex (Array start _ a) ofs = primArrayIndex a (start+ofs) -{-# INLINE unsafeIndex #-} - --- | read a cell in a mutable array. --- --- If the index is out of bounds, an error is raised. -read :: PrimMonad prim => MArray ty (PrimState prim) -> Offset ty -> prim ty -read array n - | isOutOfBound n len = primOutOfBound OOB_Read n len - | otherwise = unsafeRead array n - where len = mutableLengthSize array -{-# INLINE read #-} - --- | read from a cell in a mutable array without bounds checking. --- --- Reading from invalid memory can return unpredictable and invalid values. --- use 'read' if unsure. -unsafeRead :: PrimMonad prim => MArray ty (PrimState prim) -> Offset ty -> prim ty -unsafeRead (MArray start _ ma) i = primMutableArrayRead ma (start + i) -{-# INLINE unsafeRead #-} - --- | Write to a cell in a mutable array. --- --- If the index is out of bounds, an error is raised. -write :: PrimMonad prim => MArray ty (PrimState prim) -> Offset ty -> ty -> prim () -write array n val - | isOutOfBound n len = primOutOfBound OOB_Write n len - | otherwise = unsafeWrite array n val - where len = mutableLengthSize array -{-# INLINE write #-} - --- | write to a cell in a mutable array without bounds checking. --- --- Writing with invalid bounds will corrupt memory and your program will --- become unreliable. use 'write' if unsure. -unsafeWrite :: PrimMonad prim => MArray ty (PrimState prim) -> Offset ty -> ty -> prim () -unsafeWrite (MArray start _ ma) ofs v = - primMutableArrayWrite ma (start + ofs) v -{-# INLINE unsafeWrite #-} - --- | Freeze a mutable array into an array. --- --- the MArray must not be changed after freezing. -unsafeFreeze :: PrimMonad prim => MArray ty (PrimState prim) -> prim (Array ty) -unsafeFreeze (MArray ofs sz ma) = primitive $ \s1 -> - case unsafeFreezeArray# ma s1 of - (# s2, a #) -> (# s2, Array ofs sz a #) -{-# INLINE unsafeFreeze #-} - --- | Thaw an immutable array. --- --- The Array must not be used after thawing. -unsafeThaw :: PrimMonad prim => Array ty -> prim (MArray ty (PrimState prim)) -unsafeThaw (Array ofs sz a) = primitive $ \st -> (# st, MArray ofs sz (unsafeCoerce# a) #) -{-# INLINE unsafeThaw #-} - --- | Thaw an array to a mutable array. --- --- the array is not modified, instead a new mutable array is created --- and every values is copied, before returning the mutable array. -thaw :: PrimMonad prim => Array ty -> prim (MArray ty (PrimState prim)) -thaw array = do - m <- new (length array) - unsafeCopyAtRO m (Offset 0) array (Offset 0) (length array) - pure m -{-# INLINE thaw #-} - -freeze :: PrimMonad prim => MArray ty (PrimState prim) -> prim (Array ty) -freeze marray = do - m <- new sz - copyAt m (Offset 0) marray (Offset 0) sz - unsafeFreeze m - where - sz = mutableLengthSize marray - --- | Copy the element to a new element array -copy :: Array ty -> Array ty -copy a = runST (unsafeThaw a >>= freeze) - --- | Copy a number of elements from an array to another array with offsets -copyAt :: PrimMonad prim - => MArray ty (PrimState prim) -- ^ destination array - -> Offset ty -- ^ offset at destination - -> MArray ty (PrimState prim) -- ^ source array - -> Offset ty -- ^ offset at source - -> CountOf ty -- ^ number of elements to copy - -> prim () -copyAt dst od src os n = loop od os - where -- !endIndex = os `offsetPlusE` n - loop d s - | s .==# n = pure () - | otherwise = unsafeRead src s >>= unsafeWrite dst d >> loop (d+1) (s+1) - --- | Copy @n@ sequential elements from the specified offset in a source array --- to the specified position in a destination array. --- --- This function does not check bounds. Accessing invalid memory can return --- unpredictable and invalid values. -unsafeCopyAtRO :: PrimMonad prim - => MArray ty (PrimState prim) -- ^ destination array - -> Offset ty -- ^ offset at destination - -> Array ty -- ^ source array - -> Offset ty -- ^ offset at source - -> CountOf ty -- ^ number of elements to copy - -> prim () -unsafeCopyAtRO (MArray (Offset (I# dstart)) _ da) (Offset (I# dofs)) - (Array (Offset (I# sstart)) _ sa) (Offset (I# sofs)) - (CountOf (I# n)) = - primitive $ \st -> - (# copyArray# sa (sstart +# sofs) da (dstart +# dofs) n st, () #) - --- | Allocate a new array with a fill function that has access to the elements of --- the source array. -unsafeCopyFrom :: Array ty -- ^ Source array - -> CountOf ty -- ^ Length of the destination array - -> (Array ty -> Offset ty -> MArray ty s -> ST s ()) - -- ^ Function called for each element in the source array - -> ST s (Array ty) -- ^ Returns the filled new array -unsafeCopyFrom v' newLen f = new newLen >>= fill (Offset 0) f >>= unsafeFreeze - where len = length v' - endIdx = Offset 0 `offsetPlusE` len - fill i f' r' - | i == endIdx = pure r' - | otherwise = do f' v' i r' - fill (i + Offset 1) f' r' - --- | Create a new mutable array of size @n. --- --- all the cells are uninitialized and could contains invalid values. --- --- All mutable arrays are allocated on a 64 bits aligned addresses --- and always contains a number of bytes multiples of 64 bits. -new :: PrimMonad prim => CountOf ty -> prim (MArray ty (PrimState prim)) -new sz@(CountOf (I# n)) = primitive $ \s1 -> - case newArray# n (error "vector: internal error uninitialized vector") s1 of - (# s2, ma #) -> (# s2, MArray (Offset 0) sz ma #) - --- | Create a new array of size @n by settings each cells through the --- function @f. -create :: forall ty . CountOf ty -- ^ the size of the array - -> (Offset ty -> ty) -- ^ the function that set the value at the index - -> Array ty -- ^ the array created -create n initializer = runST (new n >>= iter initializer) - where - iter :: PrimMonad prim => (Offset ty -> ty) -> MArray ty (PrimState prim) -> prim (Array ty) - iter f ma = loop 0 - where - loop s - | s .==# n = unsafeFreeze ma - | otherwise = unsafeWrite ma s (f s) >> loop (s+1) - {-# INLINE loop #-} - {-# INLINE iter #-} - ------------------------------------------------------------------------ --- higher level collection implementation ------------------------------------------------------------------------ -equal :: Eq a => Array a -> Array a -> Bool -equal a b = (len == length b) && eachEqual 0 - where - len = length a - eachEqual !i - | i .==# len = True - | unsafeIndex a i /= unsafeIndex b i = False - | otherwise = eachEqual (i+1) - -vCompare :: Ord a => Array a -> Array a -> Ordering -vCompare a b = loop 0 - where - !la = length a - !lb = length b - loop n - | n .==# la = if la == lb then EQ else LT - | n .==# lb = GT - | otherwise = - case unsafeIndex a n `compare` unsafeIndex b n of - EQ -> loop (n+1) - r -> r - -empty :: Array a -empty = runST $ onNewArray 0 (\_ s -> s) - -length :: Array a -> CountOf a -length (Array _ sz _) = sz - -vFromList :: [a] -> Array a -vFromList l = runST (new len >>= loop 0 l) - where - len = CountOf $ List.length l - loop _ [] ma = unsafeFreeze ma - loop i (x:xs) ma = unsafeWrite ma i x >> loop (i+1) xs ma - -vToList :: Array a -> [a] -vToList v - | len == 0 = [] - | otherwise = fmap (unsafeIndex v) [0..sizeLastOffset len] - where !len = length v - --- | Append 2 arrays together by creating a new bigger array -append :: Array ty -> Array ty -> Array ty -append a b = runST $ do - r <- new (la+lb) - unsafeCopyAtRO r (Offset 0) a (Offset 0) la - unsafeCopyAtRO r (sizeAsOffset la) b (Offset 0) lb - unsafeFreeze r - where la = length a - lb = length b - -concat :: [Array ty] -> Array ty -concat l = runST $ do - r <- new (mconcat $ fmap length l) - loop r (Offset 0) l - unsafeFreeze r - where loop _ _ [] = pure () - loop r i (x:xs) = do - unsafeCopyAtRO r i x (Offset 0) lx - loop r (i `offsetPlusE` lx) xs - where lx = length x - -{- -modify :: PrimMonad m - => Array a - -> (MArray (PrimState m) a -> m ()) - -> m (Array a) -modify (Array a) f = primitive $ \st -> do - case thawArray# a 0# (sizeofArray# a) st of - (# st2, mv #) -> - case internal_ (f $ MArray mv) st2 of - st3 -> - case unsafeFreezeArray# mv st3 of - (# st4, a' #) -> (# st4, Array a' #) --} - ------------------------------------------------------------------------ --- helpers - -onNewArray :: PrimMonad m - => Int - -> (MutableArray# (PrimState m) a -> State# (PrimState m) -> State# (PrimState m)) - -> m (Array a) -onNewArray len@(I# len#) f = primitive $ \st -> do - case newArray# len# (error "onArray") st of { (# st2, mv #) -> - case f mv st2 of { st3 -> - case unsafeFreezeArray# mv st3 of { (# st4, a #) -> - (# st4, Array (Offset 0) (CountOf len) a #) }}} - ------------------------------------------------------------------------ - - -null :: Array ty -> Bool -null = (==) 0 . length - -take :: CountOf ty -> Array ty -> Array ty -take nbElems a@(Array start len arr) - | nbElems <= 0 = empty - | n == len = a - | otherwise = Array start n arr - where - n = min nbElems len - -drop :: CountOf ty -> Array ty -> Array ty -drop nbElems a@(Array start len arr) - | nbElems <= 0 = a - | n == len = empty - | otherwise = Array (start `offsetPlusE` n) (len - n) arr - where - n = min nbElems len - -splitAt :: CountOf ty -> Array ty -> (Array ty, Array ty) -splitAt nbElems a@(Array start len arr) - | nbElems <= 0 = (empty, a) - | n == len = (a, empty) - | otherwise = - (Array start n arr, Array (start `offsetPlusE` n) (len - n) arr) - where - n = min nbElems len - --- inverse a CountOf that is specified from the end (e.g. take n elements from the end) -countFromStart :: Array ty -> CountOf ty -> CountOf ty -countFromStart v sz@(CountOf sz') - | sz >= len = CountOf 0 - | otherwise = CountOf (len' - sz') - where len@(CountOf len') = length v - -revTake :: CountOf ty -> Array ty -> Array ty -revTake n v = drop (countFromStart v n) v - -revDrop :: CountOf ty -> Array ty -> Array ty -revDrop n v = take (countFromStart v n) v - -revSplitAt :: CountOf ty -> Array ty -> (Array ty, Array ty) -revSplitAt n v = (drop idx v, take idx v) where idx = countFromStart v n - -splitOn :: (ty -> Bool) -> Array ty -> [Array ty] -splitOn predicate vec - | len == CountOf 0 = [mempty] - | otherwise = loop (Offset 0) (Offset 0) - where - !len = length vec - !endIdx = Offset 0 `offsetPlusE` len - loop prevIdx idx - | idx == endIdx = [sub vec prevIdx idx] - | otherwise = - let e = unsafeIndex vec idx - idx' = idx + 1 - in if predicate e - then sub vec prevIdx idx : loop idx' idx' - else loop prevIdx idx' - -sub :: Array ty -> Offset ty -> Offset ty -> Array ty -sub (Array start len a) startIdx expectedEndIdx - | startIdx == endIdx = empty - | otherwise = Array (start + startIdx) newLen a - where - newLen = endIdx - startIdx - endIdx = min expectedEndIdx (sizeAsOffset len) - -break :: (ty -> Bool) -> Array ty -> (Array ty, Array ty) -break predicate v = findBreak 0 - where - !len = length v - findBreak i - | i .==# len = (v, empty) - | otherwise = - if predicate (unsafeIndex v i) - then splitAt (offsetAsSize i) v - else findBreak (i+1) - -intersperse :: ty -> Array ty -> Array ty -intersperse sep v - | len <= CountOf 1 = v - | otherwise = runST $ unsafeCopyFrom v ((len + len) - CountOf 1) (go (Offset 0 `offsetPlusE` (len - CountOf 1)) sep) - where len = length v - -- terminate 1 before the end - - go :: Offset ty -> ty -> Array ty -> Offset ty -> MArray ty s -> ST s () - go endI sep' oldV oldI newV - | oldI == endI = unsafeWrite newV dst e - | otherwise = do - unsafeWrite newV dst e - unsafeWrite newV (dst + 1) sep' - where - e = unsafeIndex oldV oldI - dst = oldI + oldI - -span :: (ty -> Bool) -> Array ty -> (Array ty, Array ty) -span p = break (not . p) - -map :: (a -> b) -> Array a -> Array b -map f a = create (sizeCast Proxy $ length a) (\i -> f $ unsafeIndex a (offsetCast Proxy i)) - -{- -mapIndex :: (Int -> a -> b) -> Array a -> Array b -mapIndex f a = create (length a) (\i -> f i $ unsafeIndex a i) --} - -singleton :: ty -> Array ty -singleton e = runST $ do - a <- new 1 - unsafeWrite a 0 e - unsafeFreeze a - -replicate :: CountOf ty -> ty -> Array ty -replicate sz ty = create sz (const ty) - -cons :: ty -> Array ty -> Array ty -cons e vec - | len == CountOf 0 = singleton e - | otherwise = runST $ do - mv <- new (len + CountOf 1) - unsafeWrite mv 0 e - unsafeCopyAtRO mv (Offset 1) vec (Offset 0) len - unsafeFreeze mv - where - !len = length vec - -snoc :: Array ty -> ty -> Array ty -snoc vec e - | len == 0 = singleton e - | otherwise = runST $ do - mv <- new (len + 1) - unsafeCopyAtRO mv 0 vec 0 len - unsafeWrite mv (sizeAsOffset len) e - unsafeFreeze mv - where - !len = length vec - -uncons :: Array ty -> Maybe (ty, Array ty) -uncons vec - | len == 0 = Nothing - | otherwise = Just (unsafeIndex vec 0, drop 1 vec) - where - !len = length vec - -unsnoc :: Array ty -> Maybe (Array ty, ty) -unsnoc vec - | len == 0 = Nothing - | otherwise = Just (take (len - 1) vec, unsafeIndex vec (sizeLastOffset len)) - where - !len = length vec - -elem :: Eq ty => ty -> Array ty -> Bool -elem !ty arr = loop 0 - where - !sz = length arr - loop !i | i .==# sz = False - | t == ty = True - | otherwise = loop (i+1) - where t = unsafeIndex arr i - -find :: (ty -> Bool) -> Array ty -> Maybe ty -find predicate vec = loop 0 - where - !len = length vec - loop i - | i .==# len = Nothing - | otherwise = - let e = unsafeIndex vec i - in if predicate e then Just e else loop (i+1) - -sortBy :: forall ty . (ty -> ty -> Ordering) -> Array ty -> Array ty -sortBy xford vec - | len == 0 = empty - | otherwise = runST (thaw vec >>= doSort xford) - where - len = length vec - doSort :: PrimMonad prim => (ty -> ty -> Ordering) -> MArray ty (PrimState prim) -> prim (Array ty) - doSort ford ma = qsort 0 (sizeLastOffset len) >> unsafeFreeze ma - where - qsort lo hi - | lo >= hi = pure () - | otherwise = do - p <- partition lo hi - qsort lo (pred p) - qsort (p+1) hi - partition lo hi = do - pivot <- unsafeRead ma hi - let loop i j - | j == hi = pure i - | otherwise = do - aj <- unsafeRead ma j - i' <- if ford aj pivot == GT - then pure i - else do - ai <- unsafeRead ma i - unsafeWrite ma j ai - unsafeWrite ma i aj - pure $ i + 1 - loop i' (j+1) - - i <- loop lo lo - ai <- unsafeRead ma i - ahi <- unsafeRead ma hi - unsafeWrite ma hi ai - unsafeWrite ma i ahi - pure i - -filter :: forall ty . (ty -> Bool) -> Array ty -> Array ty -filter predicate vec = runST (new len >>= copyFilterFreeze predicate (unsafeIndex vec)) - where - !len = length vec - copyFilterFreeze :: PrimMonad prim => (ty -> Bool) -> (Offset ty -> ty) -> MArray ty (PrimState prim) -> prim (Array ty) - copyFilterFreeze predi getVec mvec = loop (Offset 0) (Offset 0) >>= freezeUntilIndex mvec - where - loop d s - | s .==# len = pure d - | predi v = unsafeWrite mvec d v >> loop (d+1) (s+1) - | otherwise = loop d (s+1) - where - v = getVec s - -freezeUntilIndex :: PrimMonad prim => MArray ty (PrimState prim) -> Offset ty -> prim (Array ty) -freezeUntilIndex mvec d = do - m <- new (offsetAsSize d) - copyAt m (Offset 0) mvec (Offset 0) (offsetAsSize d) - unsafeFreeze m - -unsafeFreezeShrink :: PrimMonad prim => MArray ty (PrimState prim) -> CountOf ty -> prim (Array ty) -unsafeFreezeShrink (MArray start _ ma) n = unsafeFreeze (MArray start n ma) - -reverse :: Array ty -> Array ty -reverse a = create len toEnd - where - len@(CountOf s) = length a - toEnd (Offset i) = unsafeIndex a (Offset (s - 1 - i)) - -foldr :: (ty -> a -> a) -> a -> Array ty -> a -foldr f initialAcc vec = loop 0 - where - len = length vec - loop !i - | i .==# len = initialAcc - | otherwise = unsafeIndex vec i `f` loop (i+1) - -foldl' :: (a -> ty -> a) -> a -> Array ty -> a -foldl' f initialAcc vec = loop 0 initialAcc - where - len = length vec - loop !i !acc - | i .==# len = acc - | otherwise = loop (i+1) (f acc (unsafeIndex vec i)) - -foldl1' :: (ty -> ty -> ty) -> NonEmpty (Array ty) -> ty -foldl1' f arr = let (initialAcc, rest) = splitAt 1 $ getNonEmpty arr - in foldl' f (unsafeIndex initialAcc 0) rest - -foldr1 :: (ty -> ty -> ty) -> NonEmpty (Array ty) -> ty -foldr1 f arr = let (initialAcc, rest) = revSplitAt 1 $ getNonEmpty arr - in foldr f (unsafeIndex initialAcc 0) rest - -all :: (ty -> Bool) -> Array ty -> Bool -all p ba = loop 0 - where - len = length ba - loop !i - | i .==# len = True - | not $ p (unsafeIndex ba i) = False - | otherwise = loop (i + 1) - -any :: (ty -> Bool) -> Array ty -> Bool -any p ba = loop 0 - where - len = length ba - loop !i - | i .==# len = False - | p (unsafeIndex ba i) = True - | otherwise = loop (i + 1) - -isPrefixOf :: Eq ty => Array ty -> Array ty -> Bool -isPrefixOf pre arr - | pLen > pArr = False - | otherwise = pre == take pLen arr - where - !pLen = length pre - !pArr = length arr - -isSuffixOf :: Eq ty => Array ty -> Array ty -> Bool -isSuffixOf suffix arr - | pLen > pArr = False - | otherwise = suffix == revTake pLen arr - where - !pLen = length suffix - !pArr = length arr - -builderAppend :: PrimMonad state => ty -> Builder (Array ty) (MArray ty) ty state err () -builderAppend v = Builder $ State $ \(i, st, e) -> - if i .==# chunkSize st - then do - cur <- unsafeFreeze (curChunk st) - newChunk <- new (chunkSize st) - unsafeWrite newChunk 0 v - pure ((), (Offset 1, st { prevChunks = cur : prevChunks st - , prevChunksSize = chunkSize st + prevChunksSize st - , curChunk = newChunk - }, e)) - else do - unsafeWrite (curChunk st) i v - pure ((), (i+1, st, e)) - -builderBuild :: PrimMonad m => Int -> Builder (Array ty) (MArray ty) ty m err () -> m (Either err (Array ty)) -builderBuild sizeChunksI ab - | sizeChunksI <= 0 = builderBuild 64 ab - | otherwise = do - first <- new sizeChunks - ((), (i, st, e)) <- runState (runBuilder ab) (Offset 0, BuildingState [] (CountOf 0) first sizeChunks, Nothing) - case e of - Just err -> pure (Left err) - Nothing -> do - cur <- unsafeFreezeShrink (curChunk st) (offsetAsSize i) - -- Build final array - let totalSize = prevChunksSize st + offsetAsSize i - bytes <- new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= unsafeFreeze - pure (Right bytes) - where - sizeChunks = CountOf sizeChunksI - - fillFromEnd _ [] mua = pure mua - fillFromEnd !end (x:xs) mua = do - let sz = length x - unsafeCopyAtRO mua (sizeAsOffset (end - sz)) x (Offset 0) sz - fillFromEnd (end - sz) xs mua - -builderBuild_ :: PrimMonad m => Int -> Builder (Array ty) (MArray ty) ty m () () -> m (Array ty) -builderBuild_ sizeChunksI ab = either (\() -> internalError "impossible output") id <$> builderBuild sizeChunksI ab diff --git a/Foundation/Array/Chunked/Unboxed.hs b/Foundation/Array/Chunked/Unboxed.hs --- a/Foundation/Array/Chunked/Unboxed.hs +++ b/Foundation/Array/Chunked/Unboxed.hs @@ -18,19 +18,20 @@ import Data.Typeable import Control.Arrow ((***)) -import Foundation.Array.Boxed (Array) -import qualified Foundation.Array.Boxed as A -import Foundation.Primitive.Exception -import Foundation.Array.Unboxed (UArray) -import qualified Foundation.Array.Unboxed as U -import Foundation.Class.Bifunctor -import qualified Foundation.Collection as C -import Foundation.Internal.Base -import Foundation.Primitive.Types.OffsetSize +import Basement.BoxedArray (Array) +import qualified Basement.BoxedArray as A +import Basement.Exception +import Basement.UArray (UArray) +import qualified Basement.UArray as U +import Basement.Compat.Bifunctor +import Basement.Compat.Base +import Basement.Types.OffsetSize +import Basement.PrimType +import GHC.ST + import Foundation.Numerical -import Foundation.Primitive.Types import Foundation.Primitive -import GHC.ST +import qualified Foundation.Collection as C newtype ChunkedUArray ty = ChunkedUArray (Array (UArray ty)) @@ -75,6 +76,7 @@ revDrop = revDrop splitOn = splitOn break = break + breakEnd = breakEnd intersperse = intersperse filter = filter reverse = reverse @@ -231,10 +233,14 @@ ) revTake :: PrimType ty => CountOf ty -> ChunkedUArray ty -> ChunkedUArray ty -revTake n c = drop (length c - n) c +revTake n c = case length c - n of + Nothing -> c + Just elems -> drop elems c revDrop :: PrimType ty => CountOf ty -> ChunkedUArray ty -> ChunkedUArray ty -revDrop n c = take (length c - n) c +revDrop n c = case length c - n of + Nothing -> empty + Just keepElems -> take keepElems c -- TODO: Improve implementation. splitOn :: PrimType ty => (ty -> Bool) -> ChunkedUArray ty -> [ChunkedUArray ty] @@ -243,6 +249,10 @@ -- TODO: Improve implementation. break :: PrimType ty => (ty -> Bool) -> ChunkedUArray ty -> (ChunkedUArray ty, ChunkedUArray ty) break p = bimap fromList fromList . C.break p . toList + +-- TODO: Improve implementation. +breakEnd :: PrimType ty => (ty -> Bool) -> ChunkedUArray ty -> (ChunkedUArray ty, ChunkedUArray ty) +breakEnd p = bimap fromList fromList . C.breakEnd p . toList -- TODO: Improve implementation. intersperse :: PrimType ty => ty -> ChunkedUArray ty -> ChunkedUArray ty diff --git a/Foundation/Array/Internal.hs b/Foundation/Array/Internal.hs --- a/Foundation/Array/Internal.hs +++ b/Foundation/Array/Internal.hs @@ -24,5 +24,5 @@ , withMutablePtr ) where -import Foundation.Array.Unboxed -import Foundation.Array.Unboxed.Mutable hiding (copyToPtr) +import Basement.UArray +import Basement.UArray.Mutable hiding (copyToPtr) diff --git a/Foundation/Array/Unboxed.hs b/Foundation/Array/Unboxed.hs deleted file mode 100644 --- a/Foundation/Array/Unboxed.hs +++ /dev/null @@ -1,953 +0,0 @@ --- | --- Module : Foundation.Array.Unboxed --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : portable --- --- An unboxed array of primitive types --- --- All the cells in the array are in one chunk of contiguous --- memory. -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Rank2Types #-} -module Foundation.Array.Unboxed - ( UArray(..) - , PrimType(..) - -- * methods - , copy - , unsafeCopyAtRO - -- * internal methods - -- , copyAddr - , recast - , unsafeRecast - , length - , freeze - , unsafeFreeze - , thaw - , unsafeThaw - -- * Creation - , new - , create - , createFromIO - , createFromPtr - , sub - , copyToPtr - , withPtr - , withMutablePtr - , unsafeFreezeShrink - , freezeShrink - , unsafeSlide - -- * accessors - , update - , unsafeUpdate - , unsafeIndex - , unsafeIndexer - , unsafeDewrap - , unsafeRead - , unsafeWrite - -- * Functions - , equalMemcmp - , singleton - , replicate - , map - , mapIndex - , findIndex - , index - , null - , take - , unsafeTake - , drop - , unsafeDrop - , splitAt - , revDrop - , revTake - , revSplitAt - , splitOn - , break - , breakElem - , breakLine - , elem - , indices - , intersperse - , span - , cons - , snoc - , uncons - , unsnoc - , find - , sortBy - , filter - , reverse - , replace - , foldr - , foldl' - , foldr1 - , foldl1' - , all - , any - , isPrefixOf - , isSuffixOf - , foreignMem - , fromForeignPtr - , builderAppend - , builderBuild - , builderBuild_ - , toHexadecimal - , toBase64Internal - ) where - -import Control.Monad (when) -import GHC.Prim -import GHC.Types -import GHC.Word -import GHC.ST -import GHC.Ptr -import GHC.ForeignPtr (ForeignPtr) -import Foreign.Marshal.Utils (copyBytes) -import Foundation.Internal.Base -import Foundation.Internal.Primitive -import Foundation.Internal.Proxy -import Foundation.Primitive.Types.OffsetSize -import Foundation.Internal.MonadTrans -import Foundation.Collection.NonEmpty -import Foundation.Primitive.Monad -import Foundation.Primitive.Types -import Foundation.Primitive.FinalPtr -import Foundation.Primitive.Utils -import Foundation.Primitive.Exception -import Foundation.Primitive.UArray.Base -import Foundation.Primitive.Block (Block(..), MutableBlock(..)) -import Foundation.Array.Unboxed.Mutable hiding (sub, copyToPtr) -import Foundation.Numerical -import Foundation.Boot.Builder -import Foundation.System.Bindings.Hs (sysHsMemFindByteBa, sysHsMemFindByteAddr) -import qualified Foundation.Boot.List as List -import qualified Foundation.Primitive.Base16 as Base16 -import qualified Foundation.Primitive.UArray.BA as PrimBA -import qualified Foundation.Primitive.UArray.Addr as PrimAddr - --- | Copy every cells of an existing array to a new array -copy :: PrimType ty => UArray ty -> UArray ty -copy array = runST (thaw array >>= unsafeFreeze) - --- | Thaw an array to a mutable array. --- --- the array is not modified, instead a new mutable array is created --- and every values is copied, before returning the mutable array. -thaw :: (PrimMonad prim, PrimType ty) => UArray ty -> prim (MUArray ty (PrimState prim)) -thaw array = do - ma <- new (length array) - unsafeCopyAtRO ma azero array (Offset 0) (length array) - pure ma -{-# INLINE thaw #-} - --- | Return the element at a specific index from an array. --- --- If the index @n is out of bounds, an error is raised. -index :: PrimType ty => UArray ty -> Offset ty -> ty -index array n - | isOutOfBound n len = outOfBound OOB_Index n len - | otherwise = unsafeIndex array n - where - !len = length array -{-# INLINE index #-} - -foreignMem :: PrimType ty - => FinalPtr ty -- ^ the start pointer with a finalizer - -> CountOf ty -- ^ the number of elements (in elements, not bytes) - -> UArray ty -foreignMem fptr nb = UArray (Offset 0) nb (UArrayAddr fptr) - -fromForeignPtr :: PrimType ty - => (ForeignPtr ty, Int, Int) -- ForeignPtr, an offset in prim elements, a size in prim elements - -> UArray ty -fromForeignPtr (fptr, ofs, len) = UArray (Offset ofs) (CountOf len) (UArrayAddr $ toFinalPtrForeign fptr) - - --- | Allocate a new array with a fill function that has access to the elements of --- the source array. -unsafeCopyFrom :: (PrimType a, PrimType b) - => UArray a -- ^ Source array - -> CountOf b -- ^ Length of the destination array - -> (UArray a -> Offset a -> MUArray b s -> ST s ()) - -- ^ Function called for each element in the source array - -> ST s (UArray b) -- ^ Returns the filled new array -unsafeCopyFrom v' newLen f = new newLen >>= fill 0 >>= unsafeFreeze - where len = length v' - fill i r' - | i .==# len = pure r' - | otherwise = do f v' i r' - fill (i + 1) r' - -freeze :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> prim (UArray ty) -freeze ma = do - ma' <- new len - copyAt ma' (Offset 0) ma (Offset 0) len - unsafeFreeze ma' - where len = mutableLength ma - -freezeShrink :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> CountOf ty -> prim (UArray ty) -freezeShrink ma n = do - ma' <- new n - copyAt ma' (Offset 0) ma (Offset 0) n - unsafeFreeze ma' - -unsafeSlide :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> Offset ty -> Offset ty -> prim () -unsafeSlide mua s e = doSlide mua s e - where - doSlide :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> Offset ty -> Offset ty -> prim () - doSlide (MUArray mbStart _ (MUArrayMBA (MutableBlock mba))) start end = - primMutableByteArraySlideToStart mba (offsetInBytes $ mbStart+start) (offsetInBytes end) - doSlide (MUArray mbStart _ (MUArrayAddr fptr)) start end = withFinalPtr fptr $ \(Ptr addr) -> - primMutableAddrSlideToStart addr (offsetInBytes $ mbStart+start) (offsetInBytes end) - --- | Create a new array of size @n by settings each cells through the --- function @f. -create :: forall ty . PrimType ty - => CountOf ty -- ^ the size of the array - -> (Offset ty -> ty) -- ^ the function that set the value at the index - -> UArray ty -- ^ the array created -create n initializer - | n == 0 = mempty - | otherwise = runST (new n >>= iter initializer) - where - iter :: (PrimType ty, PrimMonad prim) => (Offset ty -> ty) -> MUArray ty (PrimState prim) -> prim (UArray ty) - iter f ma = loop 0 - where - loop i - | i .==# n = unsafeFreeze ma - | otherwise = unsafeWrite ma i (f i) >> loop (i+1) - {-# INLINE loop #-} - {-# INLINE iter #-} - --- | Create a pinned array that is filled by a 'filler' function (typically an IO call like hGetBuf) -createFromIO :: PrimType ty - => CountOf ty -- ^ the size of the array - -> (Ptr ty -> IO (CountOf ty)) -- ^ filling function that - -> IO (UArray ty) -createFromIO size filler - | size == 0 = pure mempty - | otherwise = do - mba <- newPinned size - r <- withMutablePtr mba $ \p -> filler p - case r of - 0 -> pure mempty -- make sure we don't keep our array referenced by using empty - _ | r < 0 -> error "filler returned negative number" - | otherwise -> unsafeFreezeShrink mba r - --- | Freeze a chunk of memory pointed, of specific size into a new unboxed array -createFromPtr :: PrimType ty - => Ptr ty - -> CountOf ty - -> IO (UArray ty) -createFromPtr p s = do - ma <- new s - copyFromPtr p s ma - unsafeFreeze ma - ------------------------------------------------------------------------ --- higher level collection implementation ------------------------------------------------------------------------ - -singleton :: PrimType ty => ty -> UArray ty -singleton ty = create 1 (const ty) - -replicate :: PrimType ty => CountOf ty -> ty -> UArray ty -replicate sz ty = create sz (const ty) - --- | update an array by creating a new array with the updates. --- --- the operation copy the previous array, modify it in place, then freeze it. -update :: PrimType ty - => UArray ty - -> [(Offset ty, ty)] - -> UArray ty -update array modifiers = runST (thaw array >>= doUpdate modifiers) - where doUpdate l ma = loop l - where loop [] = unsafeFreeze ma - loop ((i,v):xs) = write ma i v >> loop xs - {-# INLINE loop #-} - {-# INLINE doUpdate #-} - -unsafeUpdate :: PrimType ty - => UArray ty - -> [(Offset ty, ty)] - -> UArray ty -unsafeUpdate array modifiers = runST (thaw array >>= doUpdate modifiers) - where doUpdate l ma = loop l - where loop [] = unsafeFreeze ma - loop ((i,v):xs) = unsafeWrite ma i v >> loop xs - {-# INLINE loop #-} - {-# INLINE doUpdate #-} - --- | Copy all the block content to the memory starting at the destination address -copyToPtr :: forall ty prim . (PrimType ty, PrimMonad prim) - => UArray ty -- ^ the source array to copy - -> Ptr ty -- ^ The destination address where the copy is going to start - -> prim () -copyToPtr arr dst@(Ptr dst#) = onBackendPrim copyBa copyPtr arr - where - !(Offset os@(I# os#)) = offsetInBytes $ offset arr - !(CountOf szBytes@(I# szBytes#)) = sizeInBytes $ length arr - copyBa ba = primitive $ \s1 -> (# compatCopyByteArrayToAddr# ba os# dst# szBytes# s1, () #) - copyPtr fptr = unsafePrimFromIO $ withFinalPtr fptr $ \ptr -> copyBytes dst (ptr `plusPtr` os) szBytes - -withPtr :: forall ty prim a . (PrimMonad prim, PrimType ty) - => UArray ty - -> (Ptr ty -> prim a) - -> prim a -withPtr a f - | isPinned a == Pinned = - onBackendPrim (\ba -> f (Ptr (byteArrayContents# ba) `plusPtr` os)) - (\fptr -> withFinalPtr fptr $ \ptr -> f (ptr `plusPtr` os)) - a - | otherwise = do - arr <- do - trampoline <- newPinned (length a) - unsafeCopyAtRO trampoline 0 a 0 (length a) - unsafeFreeze trampoline - r <- withPtr arr f - touch arr - pure r - where - !sz = primSizeInBytes (Proxy :: Proxy ty) - !(Offset os) = offsetOfE sz $ offset a -{-# INLINE withPtr #-} - --- | Recast an array of type a to an array of b --- --- a and b need to have the same size otherwise this --- raise an async exception -recast :: forall a b . (PrimType a, PrimType b) => UArray a -> UArray b -recast array - | aTypeSize == bTypeSize = unsafeRecast array - | missing == 0 = unsafeRecast array - | otherwise = throw $ InvalidRecast - (RecastSourceSize alen) - (RecastDestinationSize $ alen + missing) - where - aTypeSize = primSizeInBytes (Proxy :: Proxy a) - bTypeSize@(CountOf bs) = primSizeInBytes (Proxy :: Proxy b) - (CountOf alen) = sizeInBytes (length array) - missing = alen `mod` bs - -unsafeRecast :: (PrimType a, PrimType b) => UArray a -> UArray b -unsafeRecast (UArray start len backend) = UArray (primOffsetRecast start) (sizeRecast len) $ - case backend of - UArrayAddr fptr -> UArrayAddr (castFinalPtr fptr) - UArrayBA (Block ba) -> UArrayBA (Block ba) -{-# INLINE [1] unsafeRecast #-} -{-# SPECIALIZE [3] unsafeRecast :: PrimType a => UArray Word8 -> UArray a #-} - -null :: UArray ty -> Bool -null arr = length arr == 0 - --- | Take a count of elements from the array and create an array with just those elements -take :: CountOf ty -> UArray ty -> UArray ty -take n arr@(UArray start len backend) - | n <= 0 = empty - | n >= len = arr - | otherwise = UArray start n backend - -unsafeTake :: CountOf ty -> UArray ty -> UArray ty -unsafeTake sz (UArray start _ ba) = UArray start sz ba - --- | Drop a count of elements from the array and return the new array minus those dropped elements -drop :: CountOf ty -> UArray ty -> UArray ty -drop n arr@(UArray start len backend) - | n <= 0 = arr - | n >= len = empty - | otherwise = UArray (start `offsetPlusE` n) (len - n) backend - -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) - | n == len = (arr, empty) - | otherwise = (UArray start n backend, UArray (start `offsetPlusE` n) (len - n) backend) - where - n = min nbElems len - -breakElem :: PrimType ty => ty -> UArray ty -> (UArray ty, UArray ty) -breakElem !ty arr@(UArray start len backend) - | k == end = (arr, empty) - | k == start = (empty, arr) - | otherwise = ( UArray start (offsetAsSize k - offsetAsSize start) backend - , UArray k (len - (offsetAsSize k - offsetAsSize start)) backend) - where - !end = start `offsetPlusE` len - !k = onBackend goBa (\fptr -> pure . goAddr fptr) arr - goBa ba = PrimBA.findIndexElem ty ba start end - goAddr _ (Ptr addr) = PrimAddr.findIndexElem ty addr start end -{-# NOINLINE [3] breakElem #-} -{-# RULES "breakElem Word8" [3] breakElem = breakElemByte #-} -{-# SPECIALIZE [3] breakElem :: Word32 -> UArray Word32 -> (UArray Word32, UArray Word32) #-} - -breakElemByte :: Word8 -> UArray Word8 -> (UArray Word8, UArray Word8) -breakElemByte !ty arr@(UArray start len backend) - | k == end = (arr, empty) - | k == start = (empty, arr) - | otherwise = ( UArray start (offsetAsSize k - offsetAsSize start) backend - , UArray k (len - (offsetAsSize k - offsetAsSize start)) backend) - where - !end = start `offsetPlusE` len - !k = onBackend goBa (\fptr -> pure . goAddr fptr) arr - goBa ba = sysHsMemFindByteBa ba start end ty - goAddr _ (Ptr addr) = sysHsMemFindByteAddr addr start end ty - --- | Similar to breakElem specialized to split on linefeed --- --- it either returns: --- * Left. no line has been found, and whether the last character is a CR --- * Right, a line has been found with an optional CR, and it returns --- the array of bytes on the left of the CR/LF, and the --- the array of bytes on the right of the LF. --- -breakLine :: UArray Word8 -> Either Bool (UArray Word8, UArray Word8) -breakLine arr@(UArray start len backend) - | end == start = Left False - | k2 == end = Left (k1 /= k2) - | k2 == start = Right (empty, if k2 + 1 == end then empty else unsafeDrop 1 arr) - | otherwise = Right ( unsafeTake (offsetAsSize k1 - offsetAsSize start) arr - , if k2+1 == end then empty else UArray (k2+1) (len - (offsetAsSize (k2+1) - offsetAsSize start)) backend) - where - !end = start `offsetPlusE` len - -- return (offset of CR, offset of LF, whether the last element was a carriage return - !(k1, k2) = onBackend goBa (\fptr -> pure . goAddr fptr) arr - lineFeed = 0xa - carriageReturn = 0xd - goBa ba = - let k = sysHsMemFindByteBa ba start end lineFeed - cr = if k > start then PrimBA.primIndex ba (k `offsetSub` 1) == carriageReturn else False - in (if cr then k `offsetSub` 1 else k, k) - goAddr _ (Ptr addr) = - let k = sysHsMemFindByteAddr addr start end lineFeed - cr = if k > start then PrimAddr.primIndex addr (k `offsetSub` 1) == carriageReturn else False - 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 :: forall ty . PrimType ty => ty -> UArray ty -> Maybe (Offset ty) -findIndex tyOuter ba = runST $ unsafeIndexer ba (go tyOuter) - where - !len = length ba - - go :: PrimType ty => ty -> (Offset ty -> ty) -> ST s (Maybe (Offset ty)) - go ty getIdx = loop (Offset 0) - where - loop ofs - | ofs .==# len = pure Nothing - | getIdx ofs == ty = pure $ Just ofs - | otherwise = loop (ofs + Offset 1) -{-# SPECIALIZE [3] findIndex :: Word8 -> UArray Word8 -> Maybe (Offset Word8) #-} - -break :: forall ty . PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty) -break xpredicate xv - | len == 0 = (mempty, mempty) - | otherwise = runST $ unsafeIndexer xv (go xv xpredicate) - where - !len = length xv - go :: PrimType ty => UArray ty -> (ty -> Bool) -> (Offset ty -> ty) -> ST s (UArray ty, UArray ty) - go v predicate getIdx = pure (findBreak $ Offset 0) - where - findBreak !i - | i .==# len = (v, mempty) - | predicate (getIdx i) = splitAt (offsetAsSize i) v - | otherwise = findBreak (i + Offset 1) - {-# INLINE findBreak #-} - {-# INLINE go #-} -{-# NOINLINE [2] break #-} -{-# SPECIALIZE [2] break :: (Word8 -> Bool) -> UArray Word8 -> (UArray Word8, UArray Word8) #-} - -{- -{-# RULES "break (== ty)" [3] forall (x :: forall ty . PrimType ty => ty) . break (== x) = breakElem x #-} -{-# RULES "break (ty ==)" [3] forall (x :: forall ty . PrimType ty => ty) . break (x ==) = breakElem x #-} -{-# RULES "break (== ty)" [3] forall (x :: Word8) . break (== x) = breakElem x #-} --} - -elem :: PrimType ty => ty -> UArray ty -> Bool -elem !ty arr = onBackend goBa (\_ -> pure . goAddr) arr /= end - where - !start = offset arr - !end = start `offsetPlusE` length arr - goBa ba = PrimBA.findIndexElem ty ba start end - goAddr (Ptr addr) = PrimAddr.findIndexElem ty addr start end -{-# SPECIALIZE [2] elem :: Word8 -> UArray Word8 -> Bool #-} - -intersperse :: forall ty . PrimType ty => ty -> UArray ty -> UArray ty -intersperse sep v - | len <= 1 = v - | otherwise = runST $ unsafeCopyFrom v newSize (go sep) - where - len = length v - newSize = (scale (2:: Word) len) - 1 - - go :: PrimType ty => ty -> UArray ty -> Offset ty -> MUArray ty s -> ST s () - go sep' oldV oldI newV - | oldI .==# (len - 1) = unsafeWrite newV newI e - | otherwise = do - unsafeWrite newV newI e - unsafeWrite newV (newI + 1) sep' - where - e = unsafeIndex oldV oldI - newI = scale (2 :: Word) oldI - -span :: PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty) -span p = break (not . p) - -map :: (PrimType a, PrimType b) => (a -> b) -> UArray a -> UArray b -map f a = create lenB (\i -> f $ unsafeIndex a (offsetCast Proxy i)) - where !lenB = sizeCast (Proxy :: Proxy (a -> b)) (length a) - -mapIndex :: (PrimType a, PrimType b) => (Offset b -> a -> b) -> UArray a -> UArray b -mapIndex f a = create (sizeCast Proxy $ length a) (\i -> f i $ unsafeIndex a (offsetCast Proxy i)) - -cons :: PrimType ty => ty -> UArray ty -> UArray ty -cons e vec - | len == CountOf 0 = singleton e - | otherwise = runST $ do - muv <- new (len + 1) - unsafeCopyAtRO muv 1 vec 0 len - unsafeWrite muv 0 e - unsafeFreeze muv - where - !len = length vec - -snoc :: PrimType ty => UArray ty -> ty -> UArray ty -snoc vec e - | len == CountOf 0 = singleton e - | otherwise = runST $ do - muv <- new (len + CountOf 1) - unsafeCopyAtRO muv (Offset 0) vec (Offset 0) len - unsafeWrite muv (0 `offsetPlusE` length vec) e - unsafeFreeze muv - where - !len = length vec - -uncons :: PrimType ty => UArray ty -> Maybe (ty, UArray ty) -uncons vec - | nbElems == 0 = Nothing - | otherwise = Just (unsafeIndex vec 0, sub vec 1 (0 `offsetPlusE` nbElems)) - where - !nbElems = length vec - -unsnoc :: PrimType ty => UArray ty -> Maybe (UArray ty, ty) -unsnoc vec - | nbElems == 0 = Nothing - | otherwise = Just (sub vec 0 lastElem, unsafeIndex vec lastElem) - where - !lastElem = 0 `offsetPlusE` (nbElems - 1) - !nbElems = length vec - -find :: PrimType ty => (ty -> Bool) -> UArray ty -> Maybe ty -find predicate vec = loop 0 - where - !len = length vec - loop i - | i .==# len = Nothing - | otherwise = - let e = unsafeIndex vec i - in if predicate e then Just e else loop (i+1) - -sortBy :: forall ty . PrimType ty => (ty -> ty -> Ordering) -> UArray ty -> UArray ty -sortBy xford vec - | len == 0 = mempty - | otherwise = runST (thaw vec >>= doSort xford) - where - len = length vec - doSort :: (PrimType ty, PrimMonad prim) => (ty -> ty -> Ordering) -> MUArray ty (PrimState prim) -> prim (UArray ty) - doSort ford ma = qsort 0 (sizeLastOffset len) >> unsafeFreeze ma - where - qsort lo hi - | lo >= hi = pure () - | otherwise = do - p <- partition lo hi - qsort lo (pred p) - qsort (p+1) hi - partition lo hi = do - pivot <- unsafeRead ma hi - let loop i j - | j == hi = pure i - | otherwise = do - aj <- unsafeRead ma j - i' <- if ford aj pivot == GT - then pure i - else do - ai <- unsafeRead ma i - unsafeWrite ma j ai - unsafeWrite ma i aj - pure $ i + 1 - loop i' (j+1) - - i <- loop lo lo - ai <- unsafeRead ma i - ahi <- unsafeRead ma hi - unsafeWrite ma hi ai - unsafeWrite ma i ahi - pure i - -filter :: forall ty . PrimType ty => (ty -> Bool) -> UArray ty -> UArray ty -filter predicate arr = runST $ do - (newLen, ma) <- newNative (length arr) $ \mba -> - onBackendPrim (\ba -> PrimBA.filter predicate mba ba start end) - (\fptr -> withFinalPtr fptr $ \(Ptr addr) -> - PrimAddr.filter predicate mba addr start end) - arr - unsafeFreezeShrink ma newLen - where - !len = length arr - !start = offset arr - !end = start `offsetPlusE` len - -reverse :: PrimType ty => UArray ty -> UArray ty -reverse a - | len == 0 = mempty - | otherwise = runST $ do - ((), ma) <- newNative len $ \mba -> onBackendPrim (goNative mba) - (\fptr -> withFinalPtr fptr $ goAddr mba) - a - unsafeFreeze ma - where - !len = length a - !end = 0 `offsetPlusE` len - !start = offset a - !endI = sizeAsOffset ((start + end) - Offset 1) - - goNative :: MutableByteArray# s -> ByteArray# -> ST s () - goNative !ma !ba = loop 0 - where - loop !i - | i == end = pure () - | otherwise = primMbaWrite ma i (primBaIndex ba (sizeAsOffset (endI - i))) >> loop (i+1) - goAddr :: MutableByteArray# s -> Ptr ty -> ST s () - goAddr !ma (Ptr addr) = loop 0 - where - loop !i - | i == end = pure () - | otherwise = primMbaWrite ma i (primAddrIndex addr (sizeAsOffset (endI - i))) >> loop (i+1) -{-# SPECIALIZE [3] reverse :: UArray Word8 -> UArray Word8 #-} - --- Finds where are the insertion points when we search for a `needle` --- within an `haystack`. --- Throws an error in case `needle` is empty. -indices :: PrimType ty => UArray ty -> UArray ty -> [Offset ty] -indices needle hy - | needleLen <= 0 = error "Foundation.Array.Unboxed.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 "Foundation.Array.Unboxed.replace: empty needle" - False -> do - let insertionPoints = indices needle haystack - let !occs = List.length insertionPoints - let !newLen = haystackLen - (multBy needleLen occs) + (multBy replacementLen occs) - ms <- new newLen - loop ms (Offset 0) (Offset 0) insertionPoints - where - - multBy (CountOf x) y = CountOf (x * y) - - !needleLen = length needle - - !replacementLen = length replacement - - !haystackLen = length haystack - - -- Go through each insertion point and copy things over. - -- We keep around the offset to the original string to - -- be able to copy bytes which didn't change. - loop :: PrimMonad prim - => MUArray ty (PrimState prim) - -> Offset ty - -> Offset ty - -> [Offset ty] - -> prim (UArray ty) - loop mba currentOffset offsetInOriginalString [] = do - -- Finalise the string - let !unchangedDataLen = sizeAsOffset haystackLen - offsetInOriginalString - unsafeCopyAtRO mba currentOffset haystack offsetInOriginalString unchangedDataLen - freeze mba - loop mba currentOffset offsetInOriginalString (x:xs) = do - -- 1. Copy from the old string. - let !unchangedDataLen = (x - offsetInOriginalString) - unsafeCopyAtRO mba currentOffset haystack offsetInOriginalString unchangedDataLen - let !newOffset = currentOffset `offsetPlusE` unchangedDataLen - -- 2. Copy the replacement. - unsafeCopyAtRO mba newOffset replacement (Offset 0) replacementLen - let !offsetInOriginalString' = offsetInOriginalString `offsetPlusE` unchangedDataLen `offsetPlusE` needleLen - loop mba (newOffset `offsetPlusE` replacementLen) offsetInOriginalString' xs -{-# SPECIALIZE [3] replace :: UArray Word8 -> UArray Word8 -> UArray Word8 -> UArray Word8 #-} - -foldr :: PrimType ty => (ty -> a -> a) -> a -> UArray ty -> a -foldr f initialAcc vec = loop 0 - where - !len = length vec - loop i - | i .==# len = initialAcc - | otherwise = unsafeIndex vec i `f` loop (i+1) - -foldl' :: PrimType ty => (a -> ty -> a) -> a -> UArray ty -> a -foldl' f initialAcc arr = onBackend goNative (\_ -> pure . goAddr) arr - where - !len = length arr - !start = offset arr - !end = start `offsetPlusE` len - goNative ba = PrimBA.foldl f initialAcc ba start end - goAddr (Ptr ptr) = PrimAddr.foldl f initialAcc ptr start end -{-# SPECIALIZE [3] foldl' :: (a -> Word8 -> a) -> a -> UArray Word8 -> a #-} - -foldl1' :: PrimType ty => (ty -> ty -> ty) -> NonEmpty (UArray ty) -> ty -foldl1' f (NonEmpty arr) = onBackend goNative (\_ -> pure . goAddr) arr - where - !len = length arr - !start = offset arr - !end = start `offsetPlusE` len - goNative ba = PrimBA.foldl1 f ba start end - goAddr (Ptr ptr) = PrimAddr.foldl1 f ptr start end -{-# SPECIALIZE [3] foldl1' :: (Word8 -> Word8 -> Word8) -> NonEmpty (UArray Word8) -> Word8 #-} - -foldr1 :: PrimType ty => (ty -> ty -> ty) -> NonEmpty (UArray ty) -> ty -foldr1 f arr = let (initialAcc, rest) = revSplitAt 1 $ getNonEmpty arr - in foldr f (unsafeIndex initialAcc 0) rest - -all :: PrimType ty => (ty -> Bool) -> UArray ty -> Bool -all predicate arr = onBackend (\ba -> PrimBA.all predicate ba start end) - (\_ (Ptr ptr) -> pure (PrimAddr.all predicate ptr start end)) - arr - where - start = offset arr - end = start `offsetPlusE` length arr -{-# SPECIALIZE [3] all :: (Word8 -> Bool) -> UArray Word8 -> Bool #-} - -any :: PrimType ty => (ty -> Bool) -> UArray ty -> Bool -any predicate arr = onBackend (\ba -> PrimBA.any predicate ba start end) - (\_ (Ptr ptr) -> pure (PrimAddr.any predicate ptr start end)) - arr - where - start = offset arr - end = start `offsetPlusE` length arr -{-# SPECIALIZE [3] any :: (Word8 -> Bool) -> UArray Word8 -> Bool #-} - -builderAppend :: (PrimType ty, PrimMonad state) => ty -> Builder (UArray ty) (MUArray ty) ty state err () -builderAppend v = Builder $ State $ \(i, st, e) -> - if offsetAsSize i == chunkSize st - then do - cur <- unsafeFreeze (curChunk st) - newChunk <- new (chunkSize st) - unsafeWrite newChunk 0 v - pure ((), (Offset 1, st { prevChunks = cur : prevChunks st - , prevChunksSize = chunkSize st + prevChunksSize st - , curChunk = newChunk - }, e)) - else do - unsafeWrite (curChunk st) i v - pure ((), (i + 1, st, e)) - -builderBuild :: (PrimType ty, PrimMonad m) => Int -> Builder (UArray ty) (MUArray ty) ty m err () -> m (Either err (UArray ty)) -builderBuild sizeChunksI ab - | sizeChunksI <= 0 = builderBuild 64 ab - | otherwise = do - first <- new sizeChunks - ((), (i, st, e)) <- runState (runBuilder ab) (Offset 0, BuildingState [] (CountOf 0) first sizeChunks, Nothing) - case e of - Just err -> pure (Left err) - Nothing -> do - cur <- unsafeFreezeShrink (curChunk st) (offsetAsSize i) - -- Build final array - let totalSize = prevChunksSize st + offsetAsSize i - bytes <- new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= unsafeFreeze - pure (Right bytes) - where - sizeChunks = CountOf sizeChunksI - - fillFromEnd _ [] mua = pure mua - fillFromEnd !end (x:xs) mua = do - let sz = length x - unsafeCopyAtRO mua (sizeAsOffset (end - sz)) x (Offset 0) sz - fillFromEnd (end - sz) xs mua - -builderBuild_ :: (PrimType ty, PrimMonad m) => Int -> Builder (UArray ty) (MUArray ty) ty m () () -> m (UArray ty) -builderBuild_ sizeChunksI ab = either (\() -> internalError "impossible output") id <$> builderBuild sizeChunksI ab - -toHexadecimal :: PrimType ty => UArray ty -> UArray Word8 -toHexadecimal ba - | len == CountOf 0 = mempty - | otherwise = runST $ do - ma <- new (len `scale` 2) - unsafeIndexer b8 (go ma) - unsafeFreeze ma - where - b8 = unsafeRecast ba - !len = length b8 - !endOfs = Offset 0 `offsetPlusE` len - - go :: MUArray Word8 s -> (Offset Word8 -> Word8) -> ST s () - go !ma !getAt = loop 0 0 - where - loop !dIdx !sIdx - | sIdx == endOfs = pure () - | otherwise = do - let !(W8# !w) = getAt sIdx - (# wHi, wLo #) = Base16.unsafeConvertByte w - unsafeWrite ma dIdx (W8# wHi) - unsafeWrite ma (dIdx+1) (W8# wLo) - loop (dIdx + 2) (sIdx+1) - -toBase64Internal :: PrimType ty => Addr# -> UArray ty -> Bool -> UArray Word8 -toBase64Internal table src padded - | len == CountOf 0 = mempty - | otherwise = runST $ do - ma <- new dstLen - unsafeIndexer b8 (go ma) - unsafeFreeze ma - where - b8 = unsafeRecast src - !len = length b8 - !dstLen = outputLengthBase64 padded len - !endOfs = Offset 0 `offsetPlusE` len - !dstEndOfs = Offset 0 `offsetPlusE` dstLen - - go :: MUArray Word8 s -> (Offset Word8 -> Word8) -> ST s () - go !ma !getAt = loop 0 0 - where - eqChar = 0x3d :: Word8 - - loop !sIdx !dIdx - | sIdx == endOfs = when padded $ do - when (dIdx `offsetPlusE` CountOf 1 <= dstEndOfs) $ unsafeWrite ma dIdx eqChar - when (dIdx `offsetPlusE` CountOf 2 == dstEndOfs) $ unsafeWrite ma (dIdx `offsetPlusE` CountOf 1) eqChar - | otherwise = do - let !b2Idx = sIdx `offsetPlusE` CountOf 1 - !b3Idx = sIdx `offsetPlusE` CountOf 2 - - !b2Available = b2Idx < endOfs - !b3Available = b3Idx < endOfs - - !b1 = getAt sIdx - !b2 = if b2Available then getAt b2Idx else 0 - !b3 = if b3Available then getAt b3Idx else 0 - - (w,x,y,z) = convert3 table b1 b2 b3 - - sNextIncr = 1 + fromEnum b2Available + fromEnum b3Available - dNextIncr = 1 + sNextIncr - - unsafeWrite ma dIdx w - unsafeWrite ma (dIdx `offsetPlusE` CountOf 1) x - - when b2Available $ unsafeWrite ma (dIdx `offsetPlusE` CountOf 2) y - when b3Available $ unsafeWrite ma (dIdx `offsetPlusE` CountOf 3) z - - loop (sIdx `offsetPlusE` CountOf sNextIncr) (dIdx `offsetPlusE` CountOf dNextIncr) - -outputLengthBase64 :: Bool -> CountOf Word8 -> CountOf Word8 -outputLengthBase64 padding (CountOf inputLenInt) = outputLength - where - outputLength = if padding then CountOf lenWithPadding else CountOf lenWithoutPadding - lenWithPadding - | m == 0 = 4 * d - | otherwise = 4 * (d + 1) - lenWithoutPadding - | m == 0 = 4 * d - | otherwise = 4 * d + m + 1 - (d,m) = inputLenInt `divMod` 3 - -convert3 :: Addr# -> Word8 -> Word8 -> Word8 -> (Word8, Word8, Word8, Word8) -convert3 table (W8# a) (W8# b) (W8# c) = - let !w = narrow8Word# (uncheckedShiftRL# a 2#) - !x = or# (and# (uncheckedShiftL# a 4#) 0x30##) (uncheckedShiftRL# b 4#) - !y = or# (and# (uncheckedShiftL# b 2#) 0x3c##) (uncheckedShiftRL# c 6#) - !z = and# c 0x3f## - in (idx w, idx x, idx y, idx z) - where - idx :: Word# -> Word8 - idx i = W8# (indexWord8OffAddr# table (word2Int# i)) - -isPrefixOf :: PrimType ty => UArray ty -> UArray ty -> Bool -isPrefixOf pre arr - | pLen > pArr = False - | otherwise = pre == unsafeTake pLen arr - where - !pLen = length pre - !pArr = length arr -{-# SPECIALIZE [3] isPrefixOf :: UArray Word8 -> UArray Word8 -> Bool #-} - -isSuffixOf :: PrimType ty => UArray ty -> UArray ty -> Bool -isSuffixOf suffix arr - | pLen > pArr = False - | otherwise = suffix == revTake pLen arr - where - !pLen = length suffix - !pArr = length arr -{-# SPECIALIZE [3] isSuffixOf :: UArray Word8 -> UArray Word8 -> Bool #-} diff --git a/Foundation/Array/Unboxed/ByteArray.hs b/Foundation/Array/Unboxed/ByteArray.hs deleted file mode 100644 --- a/Foundation/Array/Unboxed/ByteArray.hs +++ /dev/null @@ -1,37 +0,0 @@ -module Foundation.Array.Unboxed.ByteArray - ( MutableByteArray - , mutableByteArraySet - -- , mutableByteArraySetBetween - -- , mutableByteArrayMove - ) where - -import Foundation.Internal.Base -import Foundation.Primitive.Types.OffsetSize -import Foundation.Primitive.Monad -import Foundation.Array.Unboxed.Mutable -import Control.Monad (forM_) - --- | Mutable Byte Array alias -type MutableByteArray st = MUArray Word8 st - -mutableByteArraySet :: PrimMonad prim => MUArray Word8 (PrimState prim) -> Word8 -> prim () -mutableByteArraySet mba val = do - -- naive haskell way. TODO: call memset or a 32-bit/64-bit method - forM_ [0..(sizeLastOffset len)] $ \i -> unsafeWrite mba i val - where - len = mutableLength mba - -{- -mutableByteArraySetBetween :: PrimMonad prim => MUArray Word8 (PrimState prim) -> Word8 -> Offset Word8 -> CountOf Word8 -> prim () -mutableByteArraySetBetween mba val offset size - | offset < 0 = primOutOfBound OOB_MemSet offset len - | offset > len || offset+size > len = primOutOfBound OOB_MemSet (offset `OffsetPlusE` size) len - | otherwise = - -- TODO same as mutableByteArraySet - forM_ [offset..(offset + sizeLastOffset size)] $ \i -> unsafeWrite mba i val - where - len = mutableLengthSize mba - -mutableByteArrayMove :: PrimMonad prim => MUArray Word8 (PrimState prim) -> Int -> Int -> Int -> prim () -mutableByteArrayMove _mba _ofs _sz = undefined - -} diff --git a/Foundation/Array/Unboxed/Mutable.hs b/Foundation/Array/Unboxed/Mutable.hs deleted file mode 100644 --- a/Foundation/Array/Unboxed/Mutable.hs +++ /dev/null @@ -1,195 +0,0 @@ --- | --- Module : Foundation.Array.Unboxed.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 Foundation.Array.Unboxed.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 Foundation.Internal.Base -import Foundation.Internal.Primitive -import Foundation.Internal.Proxy -import Foundation.Primitive.Types.OffsetSize -import Foundation.Primitive.Monad -import Foundation.Primitive.Types -import Foundation.Primitive.FinalPtr -import Foundation.Primitive.Exception -import qualified Foundation.Primitive.Block.Mutable as MBLK -import Foundation.Primitive.Block (MutableBlock(..)) -import Foundation.Primitive.UArray.Base hiding (empty) -import Foundation.Numerical -import Foreign.Marshal.Utils (copyBytes) - -sizeInMutableBytesOfContent :: forall ty s . PrimType ty => MUArray ty s -> Size8 -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 - | resultEmpty = empty - | otherwise = pure $ MUArray (start `offsetPlusE` dropElems) (min (CountOf takeElems) (sz - dropElems)) back - where - dropElems = max 0 (CountOf dropElems') - resultEmpty = dropElems >= sz - --- | return the numbers of elements in a mutable array -mutableLength :: PrimType ty => MUArray ty st -> CountOf ty -mutableLength (MUArray _ end _) = end - -withMutablePtrHint :: forall ty prim a . (PrimMonad prim, PrimType ty) - => Bool - -> Bool - -> MUArray ty (PrimState prim) - -> (Ptr ty -> prim a) - -> prim a -withMutablePtrHint _ _ (MUArray start _ (MUArrayAddr fptr)) f = - withFinalPtr fptr (\ptr -> f (ptr `plusPtr` os)) - where - sz = primSizeInBytes (Proxy :: Proxy ty) - !(Offset os) = offsetOfE sz start -withMutablePtrHint skipCopy skipCopyBack vec@(MUArray start vecSz (MUArrayMBA (MutableBlock a))) f - | isMutablePinned vec == Pinned = mutableByteArrayContent a >>= \ptr -> f (ptr `plusPtr` os) - | otherwise = do - trampoline <- newPinned vecSz - if not skipCopy - then copyAt trampoline 0 vec 0 vecSz - else pure () - r <- withMutablePtr trampoline f - if not skipCopyBack - then copyAt vec 0 trampoline 0 vecSz - else pure () - pure r - where - !(Offset os) = offsetOfE sz start - sz = primSizeInBytes (Proxy :: Proxy ty) - - mutableByteArrayContent :: PrimMonad prim => MutableByteArray# (PrimState prim) -> prim (Ptr ty) - mutableByteArrayContent mba = primitive $ \s1 -> - case unsafeFreezeByteArray# mba s1 of - (# s2, ba #) -> (# s2, Ptr (byteArrayContents# ba) #) - --- | Create a pointer on the beginning of the mutable array --- and call a function 'f'. --- --- The mutable buffer can be mutated by the 'f' function --- and the change will be reflected in the mutable array --- --- If the mutable array is unpinned, a trampoline buffer --- is created and the data is only copied when 'f' return. -withMutablePtr :: (PrimMonad prim, PrimType ty) - => MUArray ty (PrimState prim) - -> (Ptr ty -> prim a) - -> prim a -withMutablePtr = withMutablePtrHint False False - --- | Copy from a pointer, @count@ elements, into the mutable array -copyFromPtr :: forall prim ty . (PrimMonad prim, PrimType ty) - => Ptr ty -> CountOf ty -> MUArray ty (PrimState prim) -> prim () -copyFromPtr src@(Ptr src#) count marr - | count > arrSz = primOutOfBound OOB_MemCopy (sizeAsOffset count) arrSz - | otherwise = onMutableBackend copyNative copyPtr marr - where - arrSz = mutableLength marr - ofs = mutableOffset marr - - sz = primSizeInBytes (Proxy :: Proxy ty) - !(CountOf bytes@(I# bytes#)) = sizeOfE sz count - !(Offset od@(I# od#)) = offsetOfE sz $ ofs - - copyNative mba = primitive $ \st -> (# copyAddrToByteArray# src# mba od# bytes# st, () #) - copyPtr fptr = withFinalPtr fptr $ \dst -> - unsafePrimFromIO $ copyBytes (dst `plusPtr` od) src bytes - --- | Copy all the block content to the memory starting at the destination address -copyToPtr :: forall ty prim . (PrimType ty, PrimMonad prim) - => MUArray ty (PrimState prim) -- ^ the source mutable array to copy - -> Ptr ty -- ^ The destination address where the copy is going to start - -> prim () -copyToPtr marr dst@(Ptr dst#) = onMutableBackend copyNative copyPtr marr - where - copyNative mba = primitive $ \s1 -> - case unsafeFreezeByteArray# mba s1 of - (# s2, ba #) -> (# compatCopyByteArrayToAddr# ba os# dst# szBytes# s2, () #) - copyPtr fptr = unsafePrimFromIO $ withFinalPtr fptr $ \ptr -> - copyBytes dst (ptr `plusPtr` os) szBytes - - !(Offset os@(I# os#)) = offsetInBytes $ mutableOffset marr - !(CountOf szBytes@(I# szBytes#)) = sizeInBytes $ mutableLength marr - -mutableOffset :: MUArray ty st -> Offset ty -mutableOffset (MUArray ofs _ _) = ofs diff --git a/Foundation/Bits.hs b/Foundation/Bits.hs --- a/Foundation/Bits.hs +++ b/Foundation/Bits.hs @@ -7,7 +7,7 @@ , alignRoundDown ) where -import Foundation.Internal.Base +import Basement.Compat.Base import Foundation.Numerical import Data.Bits diff --git a/Foundation/Boot/Builder.hs b/Foundation/Boot/Builder.hs deleted file mode 100644 --- a/Foundation/Boot/Builder.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Foundation.Boot.Builder - ( Builder(..) - , BuildingState(..) - ) where - -import Foundation.Internal.Base -import Foundation.Internal.MonadTrans -import Foundation.Monad.Exception -import Foundation.Primitive.Types.OffsetSize -import Foundation.Primitive.Monad - -newtype Builder collection mutCollection step state err a = Builder - { runBuilder :: State (Offset step, BuildingState collection mutCollection step (PrimState state), Maybe err) state a } - deriving (Functor, Applicative, Monad) - --- | The in-progress state of a building operation. --- --- The previous buffers are in reverse order, and --- this contains the current buffer and the state of --- progress packing the elements inside. -data BuildingState collection mutCollection step state = BuildingState - { prevChunks :: [collection] - , prevChunksSize :: !(CountOf step) - , curChunk :: mutCollection state - , chunkSize :: !(CountOf step) - } - -instance Monad state => MonadFailure (Builder collection mutCollection step state err) where - type Failure (Builder collection mutCollection step state err) = err - mFail builderError = Builder $ State $ \(offset, bs, _) -> - return ((), (offset, bs, Just builderError)) diff --git a/Foundation/Boot/List.hs b/Foundation/Boot/List.hs deleted file mode 100644 --- a/Foundation/Boot/List.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE CPP #-} -module Foundation.Boot.List - ( length - , sum - , reverse - ) where - -import Foundation.Internal.Base -import Foundation.Numerical.Additive -import qualified GHC.List as List - --- | Compute the size of the list -length :: [a] -> Int -#if MIN_VERSION_base(4,8,0) -length = List.foldl' (\c _ -> c+1) 0 -#else -length = loop 0 - where loop !acc [] = acc - loop !acc (_:xs) = loop (1+acc) xs -#endif - --- | Sum the element in a list -sum :: Additive n => [n] -> n -sum [] = azero -sum (i:is) = loop i is - where - loop !acc [] = acc - loop !acc (x:xs) = loop (acc+x) xs - {-# INLINE loop #-} - -reverse :: [a] -> [a] -reverse l = go l [] - where - go [] acc = acc - go (x:xs) acc = go xs (x:acc) diff --git a/Foundation/Check.hs b/Foundation/Check.hs --- a/Foundation/Check.hs +++ b/Foundation/Check.hs @@ -36,9 +36,9 @@ , iterateProperty ) where -import Foundation.Primitive.Imports -import Foundation.Primitive.IntegralConv -import Foundation.Primitive.Types.OffsetSize +import Basement.Imports +import Basement.IntegralConv +import Basement.Types.OffsetSize import Foundation.Check.Gen import Foundation.Check.Arbitrary import Foundation.Check.Property diff --git a/Foundation/Check/Arbitrary.hs b/Foundation/Check/Arbitrary.hs --- a/Foundation/Check/Arbitrary.hs +++ b/Foundation/Check/Arbitrary.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} module Foundation.Check.Arbitrary ( Arbitrary(..) , frequency @@ -9,10 +10,15 @@ , between ) where -import Foundation.Primitive.Imports +import Basement.Imports import Foundation.Primitive -import Foundation.Primitive.IntegralConv -import Foundation.Primitive.Types.OffsetSize +import Basement.Nat +import Basement.IntegralConv +import Basement.Bounded +import Basement.Types.OffsetSize +import qualified Basement.Types.Char7 as Char7 +import Basement.Types.Word128 (Word128(..)) +import Basement.Types.Word256 (Word256(..)) import Foundation.Check.Gen import Foundation.Random import Foundation.Bits @@ -29,11 +35,20 @@ instance Arbitrary Natural where arbitrary = arbitraryNatural +instance (NatWithinBound Word64 n, KnownNat n) => Arbitrary (Zn64 n) where + arbitrary = zn64 <$> arbitrary +instance KnownNat n => Arbitrary (Zn n) where + arbitrary = zn <$> arbitraryNatural + -- prim types instance Arbitrary Int where arbitrary = int64ToInt <$> arbitraryInt64 instance Arbitrary Word where arbitrary = word64ToWord <$> arbitraryWord64 +instance Arbitrary Word256 where + arbitrary = Word256 <$> arbitraryWord64 <*> arbitraryWord64 <*> arbitraryWord64 <*> arbitraryWord64 +instance Arbitrary Word128 where + arbitrary = Word128 <$> arbitraryWord64 <*> arbitraryWord64 instance Arbitrary Word64 where arbitrary = arbitraryWord64 instance Arbitrary Word32 where @@ -52,6 +67,8 @@ arbitrary = integralDownsize <$> arbitraryInt64 instance Arbitrary Char where arbitrary = arbitraryChar +instance Arbitrary Char7 where + arbitrary = Char7.fromByteMask . integralDownsize <$> arbitraryWord64 instance Arbitrary (CountOf ty) where arbitrary = CountOf <$> arbitrary @@ -62,6 +79,10 @@ arbitrary = genWithParams $ \params -> fromList <$> (genMax (genMaxSizeString params) >>= \i -> replicateM (integralCast i) arbitrary) +instance Arbitrary AsciiString where + arbitrary = genWithParams $ \params -> + fromList <$> (genMax (genMaxSizeString params) >>= \i -> replicateM (integralCast i) arbitrary) + instance Arbitrary Float where arbitrary = arbitraryF32 instance Arbitrary Double where @@ -88,6 +109,10 @@ instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e, Arbitrary f) => Arbitrary (a,b,c,d,e,f) where arbitrary = (,,,,,) <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary a => Arbitrary [a] where + arbitrary = genWithParams $ \params -> + fromList <$> (genMax (genMaxSizeArray params) >>= \i -> replicateM (integralCast i) arbitrary) arbitraryInteger :: Gen Integer arbitraryInteger = diff --git a/Foundation/Check/Config.hs b/Foundation/Check/Config.hs --- a/Foundation/Check/Config.hs +++ b/Foundation/Check/Config.hs @@ -8,8 +8,8 @@ , configHelp ) where -import Foundation.Primitive.Imports -import Foundation.Primitive.IntegralConv +import Basement.Imports +import Basement.IntegralConv import Foundation.String.Read import Foundation.Check.Gen diff --git a/Foundation/Check/Gen.hs b/Foundation/Check/Gen.hs --- a/Foundation/Check/Gen.hs +++ b/Foundation/Check/Gen.hs @@ -12,14 +12,14 @@ , genWithParams ) where -import Foundation.Primitive.Imports +import Basement.Imports import Foundation.Collection import Foundation.Random +import qualified Foundation.Random.XorShift as XorShift import Foundation.String import Foundation.Numerical import Foundation.Hashing.SipHash import Foundation.Hashing.Hasher -import qualified Foundation.Array.Unboxed as A data GenParams = GenParams { genMaxSizeIntegral :: Word -- maximum number of bytes @@ -27,29 +27,23 @@ , genMaxSizeString :: Word -- maximum number of chars } -newtype GenRng = GenRng RNGv1 +newtype GenRng = GenRng XorShift.State type GenSeed = Word64 genRng :: GenSeed -> [String] -> (Word64 -> GenRng) -genRng seed groups = \iteration -> genRngNewNoFail $ A.unsafeRecast $ fromList [w1,w2,w3,iteration] +genRng seed groups = \iteration -> GenRng $ XorShift.initialize rngSeed (rngSeed * iteration) where - w1 = rngSeed - w2 = rngSeed * 2 - w3 = rngSeed * 4 - (SipHash rngSeed) = hashEnd $ hashMixBytes hashData iHashState hashData = toBytes UTF8 $ intercalate "::" groups iHashState :: Sip1_3 iHashState = hashNewParam (SipKey seed 0x12345678) -genRngNewNoFail :: A.UArray Word8 -> GenRng -genRngNewNoFail = maybe (error "impossible") GenRng . randomNewFrom - genGenerator :: GenRng -> (GenRng, GenRng) genGenerator (GenRng rng) = - let (newSeed, rngNext) = randomGenerate 32 rng - in (genRngNewNoFail newSeed, GenRng rngNext) + let (newSeed1, rngNext) = randomGenerateWord64 rng + (newSeed2, rngNext') = randomGenerateWord64 rngNext + in (GenRng $ XorShift.initialize newSeed1 newSeed2, GenRng rngNext') -- | Generator monad newtype Gen a = Gen { runGen :: GenRng -> GenParams -> a } diff --git a/Foundation/Check/Main.hs b/Foundation/Check/Main.hs --- a/Foundation/Check/Main.hs +++ b/Foundation/Check/Main.hs @@ -15,9 +15,9 @@ ( defaultMain ) where -import Foundation.Primitive.Imports -import Foundation.Primitive.IntegralConv -import Foundation.Primitive.Types.OffsetSize +import Basement.Imports +import Basement.IntegralConv +import Basement.Types.OffsetSize import Foundation.System.Info (os, OS(..)) import Foundation.Collection import Foundation.Numerical @@ -231,7 +231,7 @@ whenGroupOnly $ if groupHasSubGroup list then displayCurrent name else return () withState $ \s -> ((), s { testPath = push (testPath s) name, indent = indent s + 2 }) results <- mapM test list - withState $ \s -> ((), s { testPath = pop (testPath s), indent = indent s - 2 }) + withState $ \s -> ((), s { testPath = pop (testPath s), indent = indent s `sizeSub` 2 }) let totFail = sum $ fmap nbFail results tot = sum $ fmap nbTests results whenGroupOnly $ case (groupHasSubGroup list, totFail) of diff --git a/Foundation/Check/Print.hs b/Foundation/Check/Print.hs --- a/Foundation/Check/Print.hs +++ b/Foundation/Check/Print.hs @@ -12,9 +12,9 @@ import Foundation.Check.Property import Foundation.Check.Types -import Foundation.Primitive.Imports +import Basement.Imports import Foundation.Collection -import Foundation.Class.Bifunctor (bimap) +import Basement.Compat.Bifunctor (bimap) import Foundation.Numerical propertyToResult :: PropertyTestArg -> (PropertyResult, Bool) diff --git a/Foundation/Check/Property.hs b/Foundation/Check/Property.hs --- a/Foundation/Check/Property.hs +++ b/Foundation/Check/Property.hs @@ -16,9 +16,9 @@ , propertyFail ) where -import Foundation.Primitive.Imports hiding (Typeable) -import Foundation.Internal.Proxy (Proxy(..)) -import Foundation.Internal.Typeable +import Basement.Imports hiding (Typeable) +import Data.Proxy (Proxy(..)) +import Basement.Compat.Typeable import Foundation.Check.Gen import Foundation.Check.Arbitrary diff --git a/Foundation/Check/Types.hs b/Foundation/Check/Types.hs --- a/Foundation/Check/Types.hs +++ b/Foundation/Check/Types.hs @@ -24,7 +24,7 @@ , HasFailures ) where -import Foundation.Primitive.Imports +import Basement.Imports import Foundation.Collection import Foundation.Monad.State import Foundation.Check.Property diff --git a/Foundation/Class/Bifunctor.hs b/Foundation/Class/Bifunctor.hs --- a/Foundation/Class/Bifunctor.hs +++ b/Foundation/Class/Bifunctor.hs @@ -16,68 +16,7 @@ -- {-# LANGUAGE CPP #-} module Foundation.Class.Bifunctor - ( Bifunctor(..) + ( module Basement.Compat.Bifunctor ) where -#if MIN_VERSION_base(4,8,0) - -import Data.Bifunctor (Bifunctor(..)) - -#else - -import Control.Applicative ( Const(..) ) -import GHC.Generics ( K1(..) ) -import qualified Prelude as P - -class Bifunctor p where - {-# MINIMAL bimap | first, second #-} - - -- | Map over both arguments at the same time. - -- - -- @'bimap' f g ≡ 'first' f '.' 'second' g@ - bimap :: (a -> b) -> (c -> d) -> p a c -> p b d - bimap f g = first f P.. second g - - -- | Map covariantly over the first argument. - -- - -- @'first' f ≡ 'bimap' f 'id'@ - first :: (a -> b) -> p a c -> p b c - first f = bimap f P.id - - -- | Map covariantly over the second argument. - -- - -- @'second' ≡ 'bimap' 'id'@ - second :: (b -> c) -> p a b -> p a c - second = bimap P.id - - -instance Bifunctor (,) where - bimap f g ~(a, b) = (f a, g b) - -instance Bifunctor ((,,) x1) where - bimap f g ~(x1, a, b) = (x1, f a, g b) - -instance Bifunctor ((,,,) x1 x2) where - bimap f g ~(x1, x2, a, b) = (x1, x2, f a, g b) - -instance Bifunctor ((,,,,) x1 x2 x3) where - bimap f g ~(x1, x2, x3, a, b) = (x1, x2, x3, f a, g b) - -instance Bifunctor ((,,,,,) x1 x2 x3 x4) where - bimap f g ~(x1, x2, x3, x4, a, b) = (x1, x2, x3, x4, f a, g b) - -instance Bifunctor ((,,,,,,) x1 x2 x3 x4 x5) where - bimap f g ~(x1, x2, x3, x4, x5, a, b) = (x1, x2, x3, x4, x5, f a, g b) - - -instance Bifunctor P.Either where - bimap f _ (P.Left a) = P.Left (f a) - bimap _ g (P.Right b) = P.Right (g b) - -instance Bifunctor Const where - bimap f _ (Const a) = Const (f a) - -instance Bifunctor (K1 i) where - bimap f _ (K1 c) = K1 (f c) - -#endif +import Basement.Compat.Bifunctor diff --git a/Foundation/Class/Storable.hs b/Foundation/Class/Storable.hs --- a/Foundation/Class/Storable.hs +++ b/Foundation/Class/Storable.hs @@ -37,12 +37,14 @@ import qualified Foreign.Storable (peek, poke) import Foreign.C.Types (CChar, CUChar) -import Foundation.Internal.Base -import Foundation.Primitive.Types.OffsetSize +import Basement.Compat.Base +import Basement.Types.OffsetSize +import Basement.Types.Word128 (Word128(..)) +import Basement.Types.Word256 (Word256(..)) import Foundation.Collection import Foundation.Collection.Buildable (builderLift, build_) -import Foundation.Primitive.Types -import Foundation.Primitive.Endianness +import Basement.PrimType +import Basement.Endianness import Foundation.Numerical -- | Storable type of self determined size. @@ -164,6 +166,24 @@ instance Storable (LE Word64) where peek (Ptr addr) = LE <$> primAddrRead addr (Offset 0) poke (Ptr addr) = primAddrWrite addr (Offset 0) . unLE +instance Storable Word128 where + peek (Ptr addr) = primAddrRead addr (Offset 0) + poke (Ptr addr) = primAddrWrite addr (Offset 0) +instance Storable (BE Word128) where + peek (Ptr addr) = BE <$> primAddrRead addr (Offset 0) + poke (Ptr addr) = primAddrWrite addr (Offset 0) . unBE +instance Storable (LE Word128) where + peek (Ptr addr) = LE <$> primAddrRead addr (Offset 0) + poke (Ptr addr) = primAddrWrite addr (Offset 0) . unLE +instance Storable Word256 where + peek (Ptr addr) = primAddrRead addr (Offset 0) + poke (Ptr addr) = primAddrWrite addr (Offset 0) +instance Storable (BE Word256) where + peek (Ptr addr) = BE <$> primAddrRead addr (Offset 0) + poke (Ptr addr) = primAddrWrite addr (Offset 0) . unBE +instance Storable (LE Word256) where + peek (Ptr addr) = LE <$> primAddrRead addr (Offset 0) + poke (Ptr addr) = primAddrWrite addr (Offset 0) . unLE instance Storable (Ptr a) where peek = Foreign.Storable.peek poke = Foreign.Storable.poke @@ -225,6 +245,24 @@ instance StorableFixed (LE Word64) where size = const SIZEOF_WORD64 alignment = const ALIGNMENT_WORD64 +instance StorableFixed Word128 where + size = const 16 + alignment = const 16 +instance StorableFixed (BE Word128) where + size = const 16 + alignment = const 16 +instance StorableFixed (LE Word128) where + size = const 16 + alignment = const 16 +instance StorableFixed Word256 where + size = const 32 + alignment = const 32 +instance StorableFixed (BE Word256) where + size = const 32 + alignment = const 32 +instance StorableFixed (LE Word256) where + size = const 32 + alignment = const 32 instance StorableFixed (Ptr a) where size = const SIZEOF_HSPTR alignment = const ALIGNMENT_HSPTR diff --git a/Foundation/Collection/Buildable.hs b/Foundation/Collection/Buildable.hs --- a/Foundation/Collection/Buildable.hs +++ b/Foundation/Collection/Buildable.hs @@ -15,21 +15,21 @@ , build_ ) where -import Foundation.Array.Unboxed -import Foundation.Array.Unboxed.Mutable -import qualified Foundation.Array.Boxed as BA -import qualified Foundation.String.UTF8 as S +import Basement.UArray +import Basement.UArray.Mutable +import qualified Basement.BoxedArray as BA +import qualified Basement.String as S import Foundation.Collection.Element -import Foundation.Internal.Base -import Foundation.Primitive.Monad -import Foundation.Boot.Builder -import Foundation.Internal.MonadTrans +import Basement.Compat.Base +import Basement.Monad +import Basement.MutableBuilder +import Basement.Compat.MonadTrans -- $setup -- >>> import Control.Monad.ST --- >>> import Foundation.Array.Unboxed --- >>> import Foundation.Internal.Base --- >>> import Foundation.Primitive.OffsetSize +-- >>> import Basement.UArray +-- >>> import Basement.Compat.Base +-- >>> import Basement.OffsetSize -- | Collections that can be built chunk by chunk. -- diff --git a/Foundation/Collection/Collection.hs b/Foundation/Collection/Collection.hs --- a/Foundation/Collection/Collection.hs +++ b/Foundation/Collection/Collection.hs @@ -18,6 +18,8 @@ -- {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Foundation.Collection.Collection ( Collection(..) -- * NonEmpty Property @@ -30,15 +32,17 @@ , or ) where -import Foundation.Internal.Base hiding (and) -import Foundation.Primitive.Types.OffsetSize +import Basement.Compat.Base hiding (and) +import Basement.Types.OffsetSize +import Basement.Types.AsciiString +import Basement.Exception (NonEmptyCollectionIsEmpty(..)) import Foundation.Collection.Element -import Foundation.Collection.NonEmpty +import Basement.NonEmpty import qualified Data.List -import qualified Foundation.Primitive.Block as BLK -import qualified Foundation.Array.Unboxed as UV -import qualified Foundation.Array.Boxed as BA -import qualified Foundation.String.UTF8 as S +import qualified Basement.Block as BLK +import qualified Basement.UArray as UV +import qualified Basement.BoxedArray as BA +import qualified Basement.String as S -- | Smart constructor to create a NonEmpty collection -- @@ -53,16 +57,9 @@ -- and return an asynchronous error if it is. nonEmpty_ :: Collection c => c -> NonEmpty c nonEmpty_ c - | null c = error "nonEmpty_: assumption failed: collection is empty. consider using nonEmpty and adding proper cases" + | null c = throw NonEmptyCollectionIsEmpty | otherwise = NonEmpty c -type instance Element (NonEmpty a) = Element a - -instance Collection c => IsList (NonEmpty c) where - type Item (NonEmpty c) = Item c - toList = toList . getNonEmpty - fromList = nonEmpty_ . fromList - nonEmptyFmap :: Functor f => (a -> b) -> NonEmpty (f a) -> NonEmpty (f b) nonEmptyFmap f (NonEmpty l) = NonEmpty (fmap f l) @@ -138,7 +135,7 @@ all = BA.all any = BA.any - +deriving instance Collection AsciiString instance Collection S.String where null = S.null diff --git a/Foundation/Collection/Copy.hs b/Foundation/Collection/Copy.hs --- a/Foundation/Collection/Copy.hs +++ b/Foundation/Collection/Copy.hs @@ -3,11 +3,11 @@ ) where import GHC.ST (runST) -import Foundation.Internal.Base ((>>=)) -import qualified Foundation.Primitive.Block as BLK -import qualified Foundation.Array.Unboxed as UA -import qualified Foundation.Array.Boxed as BA -import qualified Foundation.String.UTF8 as S +import Basement.Compat.Base ((>>=)) +import qualified Basement.Block as BLK +import qualified Basement.UArray as UA +import qualified Basement.BoxedArray as BA +import qualified Basement.String as S class Copy a where copy :: a -> a diff --git a/Foundation/Collection/Element.hs b/Foundation/Collection/Element.hs --- a/Foundation/Collection/Element.hs +++ b/Foundation/Collection/Element.hs @@ -9,11 +9,14 @@ ( Element ) where -import Foundation.Internal.Base -import Foundation.Primitive.Block (Block) -import Foundation.Array.Unboxed (UArray) -import Foundation.Array.Boxed (Array) -import Foundation.String.UTF8 (String) +import Basement.Compat.Base +import Basement.Block (Block) +import Basement.UArray (UArray) +import Basement.BoxedArray (Array) +import Basement.String (String) +import Basement.Types.AsciiString (AsciiString) +import Basement.Types.Char7 (Char7) +import Basement.NonEmpty -- | Element type of a collection type family Element container @@ -22,3 +25,5 @@ type instance Element (UArray ty) = ty type instance Element (Array ty) = ty type instance Element String = Char +type instance Element AsciiString = Char7 +type instance Element (NonEmpty a) = Element a diff --git a/Foundation/Collection/Foldable.hs b/Foundation/Collection/Foldable.hs --- a/Foundation/Collection/Foldable.hs +++ b/Foundation/Collection/Foldable.hs @@ -1,5 +1,5 @@ -- | --- Module : Foundation.Primitive.Foldable +-- Module : Basement.Foldable -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental @@ -12,13 +12,13 @@ , Fold1able(..) ) where -import Foundation.Internal.Base +import Basement.Compat.Base import Foundation.Collection.Element -import Foundation.Collection.NonEmpty +import Basement.NonEmpty import qualified Data.List -import qualified Foundation.Array.Unboxed as UV -import qualified Foundation.Primitive.Block as BLK -import qualified Foundation.Array.Boxed as BA +import qualified Basement.UArray as UV +import qualified Basement.Block as BLK +import qualified Basement.BoxedArray as BA -- | Give the ability to fold a collection on itself class Foldable collection where diff --git a/Foundation/Collection/Indexed.hs b/Foundation/Collection/Indexed.hs --- a/Foundation/Collection/Indexed.hs +++ b/Foundation/Collection/Indexed.hs @@ -10,15 +10,15 @@ ( IndexedCollection(..) ) where -import Foundation.Internal.Base -import Foundation.Primitive.Types.OffsetSize +import Basement.Compat.Base +import Basement.Types.OffsetSize import Foundation.Collection.Element import qualified Data.List -import qualified Foundation.Primitive.Block as BLK -import qualified Foundation.Array.Unboxed as UV -import qualified Foundation.Array.Boxed as BA -import qualified Foundation.Primitive.Exception as A -import qualified Foundation.String.UTF8 as S +import qualified Basement.Block as BLK +import qualified Basement.UArray as UV +import qualified Basement.BoxedArray as BA +import qualified Basement.Exception as A +import qualified Basement.String as S -- | Collection of elements that can indexed by int class IndexedCollection c where diff --git a/Foundation/Collection/InnerFunctor.hs b/Foundation/Collection/InnerFunctor.hs --- a/Foundation/Collection/InnerFunctor.hs +++ b/Foundation/Collection/InnerFunctor.hs @@ -3,11 +3,11 @@ ( InnerFunctor(..) ) where -import Foundation.Internal.Base +import Basement.Compat.Base import Foundation.Collection.Element -import qualified Foundation.String.UTF8 as S -import qualified Foundation.Array.Unboxed as UV -import Foundation.Array.Boxed (Array) +import qualified Basement.String as S +import qualified Basement.UArray as UV +import Basement.BoxedArray (Array) -- | A monomorphic functor that maps the inner values to values of the same type class InnerFunctor c where diff --git a/Foundation/Collection/Keyed.hs b/Foundation/Collection/Keyed.hs --- a/Foundation/Collection/Keyed.hs +++ b/Foundation/Collection/Keyed.hs @@ -10,7 +10,7 @@ ( KeyedCollection(..) ) where -import Foundation.Internal.Base +import Basement.Compat.Base import qualified Data.List -- | Collection of things that can be looked up by Key diff --git a/Foundation/Collection/List.hs b/Foundation/Collection/List.hs --- a/Foundation/Collection/List.hs +++ b/Foundation/Collection/List.hs @@ -10,13 +10,14 @@ , revTake , revDrop , revSplitAt + , breakEnd , uncons , unsnoc ) where import qualified Data.List import Data.Tuple (swap) -import Foundation.Internal.Base +import Basement.Compat.Base import Foundation.Numerical -- | Simple helper to split a list repeatly when the predicate match @@ -44,6 +45,11 @@ revSplitAt n l = swap $ Data.List.splitAt (len - n) l where len = Data.List.length l + +breakEnd :: (a -> Bool) -> [a] -> ([a], [a]) +breakEnd predicate l = + let (l1,l2) = Data.List.break predicate (Data.List.reverse l) + in if Data.List.null l2 then (l, []) else (Data.List.reverse l2, Data.List.reverse l1) uncons :: [a] -> Maybe (a, [a]) uncons [] = Nothing diff --git a/Foundation/Collection/Mappable.hs b/Foundation/Collection/Mappable.hs --- a/Foundation/Collection/Mappable.hs +++ b/Foundation/Collection/Mappable.hs @@ -1,5 +1,5 @@ -- | --- Module : Foundation.Primitive.Mappable +-- Module : Basement.Mappable -- License : BSD-style -- Maintainer : Nicolas Di Prima -- Stability : experimental @@ -17,9 +17,9 @@ , forM_ ) where -import Foundation.Internal.Base +import Basement.Compat.Base import qualified Data.Traversable -import Foundation.Array.Boxed (Array) +import Basement.BoxedArray (Array) -- | Functors representing data structures that can be traversed from -- left to right. diff --git a/Foundation/Collection/Mutable.hs b/Foundation/Collection/Mutable.hs --- a/Foundation/Collection/Mutable.hs +++ b/Foundation/Collection/Mutable.hs @@ -9,14 +9,14 @@ ( MutableCollection(..) ) where -import Foundation.Primitive.Monad -import Foundation.Primitive.Types.OffsetSize -import qualified Foundation.Primitive.Block as BLK -import qualified Foundation.Primitive.Block.Mutable as BLK +import Basement.Monad +import Basement.Types.OffsetSize +import qualified Basement.Block as BLK +import qualified Basement.Block.Mutable as BLK -import qualified Foundation.Array.Unboxed.Mutable as MUV -import qualified Foundation.Array.Unboxed as UV -import qualified Foundation.Array.Boxed as BA +import qualified Basement.UArray.Mutable as MUV +import qualified Basement.UArray as UV +import qualified Basement.BoxedArray as BA -- | Collection of things that can be made mutable, modified and then freezed into an MutableFreezed collection class MutableCollection c where diff --git a/Foundation/Collection/NonEmpty.hs b/Foundation/Collection/NonEmpty.hs deleted file mode 100644 --- a/Foundation/Collection/NonEmpty.hs +++ /dev/null @@ -1,18 +0,0 @@ --- | --- Module : Foundation.Collection.NonEmpty --- License : BSD-style --- Maintainer : Foundation --- Stability : experimental --- Portability : portable --- --- A newtype wrapper around a non-empty Collection. - -module Foundation.Collection.NonEmpty - ( NonEmpty(..) - ) where - -import Foundation.Internal.Base - --- | NonEmpty property for any Collection -newtype NonEmpty a = NonEmpty { getNonEmpty :: a } - deriving (Show,Eq) diff --git a/Foundation/Collection/Sequential.hs b/Foundation/Collection/Sequential.hs --- a/Foundation/Collection/Sequential.hs +++ b/Foundation/Collection/Sequential.hs @@ -12,21 +12,24 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ConstrainedClassMethods #-} {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} module Foundation.Collection.Sequential ( Sequential(..) ) where -import Foundation.Internal.Base -import Foundation.Numerical.Subtractive -import Foundation.Primitive.Types.OffsetSize +import Basement.Compat.Base +import Basement.Numerical.Subtractive +import Basement.Types.OffsetSize +import Basement.Types.AsciiString (AsciiString(..)) import Foundation.Collection.Element import Foundation.Collection.Collection import qualified Foundation.Collection.List as ListExtra import qualified Data.List -import qualified Foundation.Array.Unboxed as UV -import qualified Foundation.Primitive.Block as BLK -import qualified Foundation.Array.Boxed as BA -import qualified Foundation.String.UTF8 as S +import qualified Basement.UArray as UV +import qualified Basement.Block as BLK +import qualified Basement.BoxedArray as BA +import qualified Basement.String as S -- | A set of methods for ordered colection class (IsList c, Item c ~ Element c, Monoid c, Collection c) => Sequential c where @@ -34,6 +37,7 @@ , ((revTake, revDrop) | revSplitAt) , splitOn , (break | span) + , (breakEnd | spanEnd) , intersperse , filter, reverse , uncons, unsnoc, snoc, cons @@ -73,6 +77,10 @@ break predicate = span (not . predicate) -- | Split a collection when the predicate return true + breakEnd :: (Element c -> Bool) -> c -> (c,c) + breakEnd predicate = spanEnd (not . predicate) + + -- | Split a collection when the predicate return true starting from the end of the collection breakElem :: Eq (Element c) => Element c -> c -> (c,c) breakElem c = break (== c) @@ -101,6 +109,10 @@ span :: (Element c -> Bool) -> c -> (c,c) span predicate = break (not . predicate) + -- | Split a collection while the predicate return true starting from the end of the collection + spanEnd :: (Element c -> Bool) -> c -> (c,c) + spanEnd predicate = breakEnd (not . predicate) + -- | Filter all the elements that satisfy the predicate filter :: (Element c -> Bool) -> c -> c @@ -178,19 +190,11 @@ -- | Takes two collections and returns True iff the first collection is an infix of the second. isInfixOf :: Eq (Element c) => c -> c -> Bool default isInfixOf :: Eq c => c -> c -> Bool - isInfixOf c1 c2 - | len1 > len2 = False - | otherwise = loop 0 - where - endofs = len2 - len1 - len1 = length c1 - len2 = length c2 - - loop i - | i == endofs = c1 == c2Sub - | c1 == c2Sub = True - | otherwise = loop (succ i) - where c2Sub = take len1 $ drop i c2 + isInfixOf c1 c2 = loop (len2 - len1) c2 + where len1 = length c1 + len2 = length c2 + loop (Just cnt) c2' = c1 == take len1 c2' || loop (cnt - 1) (drop 1 c2') + loop Nothing _ = False -- | Try to strip a prefix from a collection stripPrefix :: Eq (Element c) => c -> c -> Maybe c @@ -217,6 +221,7 @@ revSplitAt (CountOf n) = ListExtra.revSplitAt n splitOn = ListExtra.wordsWhen break = Data.List.break + breakEnd = ListExtra.breakEnd intersperse = Data.List.intersperse span = Data.List.span dropWhile = Data.List.dropWhile @@ -240,6 +245,7 @@ revSplitAt n = BLK.revSplitAt n splitOn = BLK.splitOn break = BLK.break + breakEnd = BLK.breakEnd intersperse = BLK.intersperse span = BLK.span filter = BLK.filter @@ -262,6 +268,7 @@ revSplitAt = UV.revSplitAt splitOn = UV.splitOn break = UV.break + breakEnd = UV.breakEnd breakElem = UV.breakElem intersperse = UV.intersperse span = UV.span @@ -287,6 +294,7 @@ revSplitAt = BA.revSplitAt splitOn = BA.splitOn break = BA.break + breakEnd = BA.breakEnd intersperse = BA.intersperse span = BA.span reverse = BA.reverse @@ -311,6 +319,7 @@ revSplitAt = S.revSplitAt splitOn = S.splitOn break = S.break + breakEnd = S.breakEnd breakElem = S.breakElem intersperse = S.intersperse span = S.span @@ -329,3 +338,5 @@ isInfixOf = S.isInfixOf stripPrefix = S.stripPrefix stripSuffix = S.stripSuffix + +deriving instance Sequential AsciiString diff --git a/Foundation/Collection/Zippable.hs b/Foundation/Collection/Zippable.hs --- a/Foundation/Collection/Zippable.hs +++ b/Foundation/Collection/Zippable.hs @@ -10,18 +10,20 @@ -- {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} - +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Foundation.Collection.Zippable ( BoxedZippable(..) , Zippable(..) ) where -import qualified Foundation.Array.Unboxed as UV -import qualified Foundation.Array.Boxed as BA -import qualified Foundation.String.UTF8 as S +import qualified Basement.UArray as UV +import qualified Basement.BoxedArray as BA +import qualified Basement.String as S import Foundation.Collection.Element import Foundation.Collection.Sequential -import Foundation.Internal.Base +import Basement.Compat.Base +import Basement.Types.AsciiString(AsciiString(..)) import qualified Prelude import GHC.ST @@ -96,6 +98,8 @@ go _ [] _ = return () go _ _ [] = return () go f' (a':as') (b':bs') = S.builderAppend (f' a' b') >> go f' as' bs' + +deriving instance Zippable AsciiString class Zippable col => BoxedZippable col where diff --git a/Foundation/Conduit.hs b/Foundation/Conduit.hs --- a/Foundation/Conduit.hs +++ b/Foundation/Conduit.hs @@ -25,7 +25,7 @@ import Foundation.Collection import Foundation.IO import Foundation.IO.File -import Foundation.Internal.Base +import Basement.Compat.Base import Foundation.Monad.Base import Foundation.Array import Foundation diff --git a/Foundation/Conduit/Internal.hs b/Foundation/Conduit/Internal.hs --- a/Foundation/Conduit/Internal.hs +++ b/Foundation/Conduit/Internal.hs @@ -30,10 +30,10 @@ , bracketConduit ) where -import Foundation.Primitive.Imports hiding (throw) +import Basement.Imports hiding (throw) import Foundation.Monad import Foundation.Numerical -import Foundation.Primitive.Monad +import Basement.Monad import Control.Monad ((>=>), liftM, void, mapM_, join) import Control.Exception (SomeException, mask_) import Data.IORef (atomicModifyIORef) diff --git a/Foundation/Conduit/Textual.hs b/Foundation/Conduit/Textual.hs --- a/Foundation/Conduit/Textual.hs +++ b/Foundation/Conduit/Textual.hs @@ -6,11 +6,11 @@ , toBytes ) where -import Foundation.Primitive.Imports hiding (throw) -import Foundation.Array.Unboxed (UArray) +import Basement.Imports hiding (throw) +import Basement.UArray (UArray) import Foundation.String (String) import Foundation.Collection -import qualified Foundation.String.UTF8 as S +import qualified Basement.String as S import Foundation.Conduit.Internal import Foundation.Monad import Data.Char (isSpace) diff --git a/Foundation/Convertible.hs b/Foundation/Convertible.hs deleted file mode 100644 --- a/Foundation/Convertible.hs +++ /dev/null @@ -1,24 +0,0 @@ --- | --- Module : Foundation.Convertible --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : portable --- -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -module Foundation.Convertible - ( Convertible(..) - ) where - -import Foundation.Internal.Base -import Foundation.Internal.Proxy - --- | Class of things that can be converted from a to b -class Convertible a b where - type Convert a b - convert :: Proxy b -> a -> Convert a b - -instance Convertible a a where - type Convert a a = a - convert _ = id diff --git a/Foundation/Foreign.hs b/Foundation/Foreign.hs --- a/Foundation/Foreign.hs +++ b/Foundation/Foreign.hs @@ -6,14 +6,14 @@ -- Portability : portable -- module Foundation.Foreign - ( module Foundation.Primitive.FinalPtr + ( module Basement.FinalPtr , V.foreignMem , V.mutableForeignMem , module Foreign.C.Types ) where -import Foundation.Primitive.FinalPtr -import qualified Foundation.Array.Unboxed as V -import qualified Foundation.Array.Unboxed.Mutable as V +import Basement.FinalPtr +import qualified Basement.UArray as V +import qualified Basement.UArray.Mutable as V import Foreign.C.Types diff --git a/Foundation/Foreign/Alloc.hs b/Foundation/Foreign/Alloc.hs --- a/Foundation/Foreign/Alloc.hs +++ b/Foundation/Foreign/Alloc.hs @@ -4,8 +4,8 @@ ) where import qualified Foreign.Marshal.Alloc as A (allocaBytes) -import Foundation.Primitive.Imports -import Foundation.Primitive.Types.OffsetSize +import Basement.Imports +import Basement.Types.OffsetSize allocaBytes :: CountOf Word8 -> (Ptr a -> IO b) -> IO b allocaBytes (CountOf i) f = A.allocaBytes i f diff --git a/Foundation/Foreign/MemoryMap/Posix.hsc b/Foundation/Foreign/MemoryMap/Posix.hsc --- a/Foundation/Foreign/MemoryMap/Posix.hsc +++ b/Foundation/Foreign/MemoryMap/Posix.hsc @@ -41,8 +41,8 @@ , fileMapRead ) where -import Foundation.Internal.Base -import Foundation.Primitive.Types.OffsetSize +import Basement.Compat.Base +import Basement.Types.OffsetSize import System.Posix.Types import Foreign.Ptr import Foreign.C.Types diff --git a/Foundation/Foreign/MemoryMap/Types.hs b/Foundation/Foreign/MemoryMap/Types.hs --- a/Foundation/Foreign/MemoryMap/Types.hs +++ b/Foundation/Foreign/MemoryMap/Types.hs @@ -12,9 +12,9 @@ ) where import GHC.Ptr -import Foundation.Primitive.FinalPtr -import Foundation.Primitive.Types.OffsetSize -import Foundation.Internal.Base +import Basement.FinalPtr +import Basement.Types.OffsetSize +import Basement.Compat.Base import Foundation.VFS (FilePath) -- | Contains all the information related to a file mapping, diff --git a/Foundation/Foreign/MemoryMap/Windows.hs b/Foundation/Foreign/MemoryMap/Windows.hs --- a/Foundation/Foreign/MemoryMap/Windows.hs +++ b/Foundation/Foreign/MemoryMap/Windows.hs @@ -7,9 +7,9 @@ import System.Win32.FileMapping import Control.Exception hiding (handle) -import Foundation.Internal.Base -import Foundation.Primitive.Types.OffsetSize -import Foundation.Primitive.FinalPtr +import Basement.Compat.Base +import Basement.Types.OffsetSize +import Basement.FinalPtr import Foundation.VFS import Foundation.Foreign.MemoryMap.Types diff --git a/Foundation/Hashing/FNV.hs b/Foundation/Hashing/FNV.hs --- a/Foundation/Hashing/FNV.hs +++ b/Foundation/Hashing/FNV.hs @@ -21,11 +21,11 @@ , FNV1a_64 ) where -import Foundation.Internal.Base -import qualified Foundation.Array.Unboxed as A -import Foundation.Primitive.Types.OffsetSize -import Foundation.Primitive.Types -import Foundation.Primitive.IntegralConv +import Basement.Compat.Base +import qualified Basement.UArray as A +import Basement.Types.OffsetSize +import Basement.PrimType +import Basement.IntegralConv import Foundation.Numerical import Foundation.Hashing.Hasher import Data.Bits diff --git a/Foundation/Hashing/Hashable.hs b/Foundation/Hashing/Hashable.hs --- a/Foundation/Hashing/Hashable.hs +++ b/Foundation/Hashing/Hashable.hs @@ -12,11 +12,10 @@ ( Hashable(..) ) where -import Foundation.Internal.Base -import Foundation.Internal.Natural -import Foundation.Primitive.IntegralConv -import Foundation.Numerical.Primitives -import Foundation.Numerical.Multiplicative +import Basement.Compat.Base +import Basement.Compat.Natural +import Basement.IntegralConv +import Basement.Numerical.Multiplicative import Foundation.Array import Foundation.Tuple import Foundation.String @@ -53,13 +52,13 @@ let b = integralDownsize (w :: Natural) :: Word8 in loop (w `div` 256) (hashMix8 b acc) instance Hashable Int8 where - hashMix w = hashMix8 (integralConvert w) + hashMix w = hashMix8 (integralCast w) instance Hashable Int16 where - hashMix w = hashMix16 (integralConvert w) + hashMix w = hashMix16 (integralCast w) instance Hashable Int32 where - hashMix w = hashMix32 (integralConvert w) + hashMix w = hashMix32 (integralCast w) instance Hashable Int64 where - hashMix w = hashMix64 (integralConvert w) + hashMix w = hashMix64 (integralCast w) instance Hashable Integer where hashMix i iacc | i == 0 = hashMix8 0 iacc diff --git a/Foundation/Hashing/Hasher.hs b/Foundation/Hashing/Hasher.hs --- a/Foundation/Hashing/Hasher.hs +++ b/Foundation/Hashing/Hasher.hs @@ -3,10 +3,10 @@ ( Hasher(..) ) where -import Foundation.Internal.Base -import Foundation.Primitive.IntegralConv +import Basement.Compat.Base +import Basement.IntegralConv import Foundation.Array (UArray) -import qualified Foundation.Array.Unboxed as A +import qualified Basement.UArray as A import Data.Bits -- | Incremental Hashing state. Represent an hashing algorithm diff --git a/Foundation/Hashing/SipHash.hs b/Foundation/Hashing/SipHash.hs --- a/Foundation/Hashing/SipHash.hs +++ b/Foundation/Hashing/SipHash.hs @@ -19,12 +19,12 @@ ) where import Data.Bits -import Foundation.Internal.Base -import Foundation.Primitive.Types.OffsetSize -import Foundation.Primitive.Types -import Foundation.Primitive.IntegralConv +import Basement.Compat.Base +import Basement.Types.OffsetSize +import Basement.PrimType +import Basement.IntegralConv import Foundation.Hashing.Hasher -import qualified Foundation.Array.Unboxed as A +import qualified Basement.UArray as A import Foundation.Array import Foundation.Numerical import Foundation.Bits @@ -190,9 +190,9 @@ goVec ba start = loop8 initSt initIncr start totalLen where loop8 !st !incr _ 0 = Sip st incr (currentLen + totalLen) - loop8 !st SipIncremental0 !ofs !l - | l < 8 = loop1 st SipIncremental0 ofs l - | otherwise = + loop8 !st SipIncremental0 !ofs !l = case l - 8 of + Nothing -> loop1 st SipIncremental0 ofs l + Just l8 -> let v = to64 56 (primBaIndex ba ofs) .|. to64 48 (primBaIndex ba (ofs + Offset 1)) .|. to64 40 (primBaIndex ba (ofs + Offset 2)) @@ -201,12 +201,12 @@ .|. to64 16 (primBaIndex ba (ofs + Offset 5)) .|. to64 8 (primBaIndex ba (ofs + Offset 6)) .|. to64 0 (primBaIndex ba (ofs + Offset 7)) - in loop8 (process c st v) SipIncremental0 (start + Offset 8) (l - 8) + in loop8 (process c st v) SipIncremental0 (start + Offset 8) l8 loop8 !st !incr !ofs !l = loop1 st incr ofs l - loop1 !st !incr _ 0 = Sip st incr (currentLen + totalLen) - loop1 !st !incr !ofs !l = - let (# st', incr' #) = mix8Prim c (primBaIndex ba ofs) st incr - in loop1 st' incr' (ofs + Offset 1) (l - 1) + loop1 !st !incr !ofs !l = case l - 1 of + Nothing -> Sip st incr (currentLen + totalLen) + Just l1 -> let (# st', incr' #) = mix8Prim c (primBaIndex ba ofs) st incr + in loop1 st' incr' (ofs + Offset 1) l1 to64 :: Int -> Word8 -> Word64 to64 0 !v = Prelude.fromIntegral v @@ -216,9 +216,9 @@ goAddr (Ptr ptr) start = return $ loop8 initSt initIncr start totalLen where loop8 !st !incr _ 0 = Sip st incr (currentLen + totalLen) - loop8 !st SipIncremental0 !ofs !l - | l < 8 = loop1 st SipIncremental0 ofs l - | otherwise = + loop8 !st SipIncremental0 !ofs !l = case l - 8 of + Nothing -> loop1 st SipIncremental0 ofs l + Just l8 -> let v = to64 56 (primAddrIndex ptr ofs) .|. to64 48 (primAddrIndex ptr (ofs + Offset 1)) .|. to64 40 (primAddrIndex ptr (ofs + Offset 2)) @@ -227,12 +227,12 @@ .|. to64 16 (primAddrIndex ptr (ofs + Offset 5)) .|. to64 8 (primAddrIndex ptr (ofs + Offset 6)) .|. to64 0 (primAddrIndex ptr (ofs + Offset 7)) - in loop8 (process c st v) SipIncremental0 (start + Offset 8) (l - 8) + in loop8 (process c st v) SipIncremental0 (start + Offset 8) l8 -- (l - 8) loop8 !st !incr !ofs !l = loop1 st incr ofs l - loop1 !st !incr _ 0 = Sip st incr (currentLen + totalLen) - loop1 !st !incr !ofs !l = - let (# st', incr' #) = mix8Prim c (primAddrIndex ptr ofs) st incr - in loop1 st' incr' (ofs + Offset 1) (l - 1) + loop1 !st !incr !ofs !l = case l - 1 of + Nothing -> Sip st incr (currentLen + totalLen) + Just l1 -> let (# st', incr' #) = mix8Prim c (primAddrIndex ptr ofs) st incr + in loop1 st' incr' (ofs + Offset 1) l1 doRound :: InternalState -> InternalState doRound (InternalState !v0 !v1 !v2 !v3) = diff --git a/Foundation/IO.hs b/Foundation/IO.hs --- a/Foundation/IO.hs +++ b/Foundation/IO.hs @@ -21,7 +21,6 @@ , Foundation.IO.File.hGet , Foundation.IO.File.hPut , Foundation.IO.File.readFile - , Foundation.IO.File.foldTextFile ) where import qualified Foundation.IO.Terminal diff --git a/Foundation/IO/File.hs b/Foundation/IO/File.hs --- a/Foundation/IO/File.hs +++ b/Foundation/IO/File.hs @@ -17,7 +17,6 @@ , hGetSome , hPut , readFile - , foldTextFile ) where import System.IO (Handle, IOMode) @@ -25,13 +24,12 @@ import qualified System.IO as S import Foundation.Collection import Foundation.VFS -import Foundation.Primitive.Types.OffsetSize -import Foundation.Primitive.Imports +import Basement.Types.OffsetSize +import Basement.Imports import Foundation.Array.Internal import Foundation.Numerical -import qualified Foundation.Array.Unboxed.Mutable as V -import qualified Foundation.Array.Unboxed as V -import qualified Foundation.String.UTF8 as S +import qualified Basement.UArray.Mutable as V +import qualified Basement.UArray as V import Control.Exception (bracket) import Foreign.Ptr (plusPtr) @@ -118,36 +116,6 @@ if r > 0 && r <= toRead then loop h (left - r) (dst `plusPtr` r) else error "readFile: " -- turn into proper error - --- | Fold over chunks file calling the callback function for each chunks --- read from the file, until the end of file. -foldTextFile :: (String -> a -> IO a) -- ^ Fold callback function - -> a -- ^ initial accumulator - -> FilePath -- ^ File to read - -> IO a -foldTextFile chunkf ini fp = do - buf <- V.newPinned (CountOf blockSize) - V.withMutablePtr buf $ \ptr -> - withFile fp S.ReadMode $ doFold buf ptr - where - doFold mv ptr handle = loop 0 ini - where - loop absPos acc = do - r <- S.hGetBuf handle ptr blockSize - if r > 0 && r <= blockSize - then do - (pos, validateRet) <- S.mutableValidate mv 0 (CountOf r) - s <- case validateRet of - Nothing -> S.fromBytesUnsafe `fmap` V.freezeShrink mv (CountOf r) - Just S.MissingByte -> do - sRet <- S.fromBytesUnsafe `fmap` V.freezeShrink mv (pos - 0) - V.unsafeSlide mv pos (Offset r) - return sRet - Just _ -> - error ("foldTextFile: invalid UTF8 sequence: byte position: " <> show (absPos + pos)) - chunkf s acc >>= loop (absPos + Offset r) - else error "foldTextFile: read failed" -- FIXME -{-# DEPRECATED foldTextFile "use conduit instead" #-} blockSize :: Int blockSize = 4096 diff --git a/Foundation/IO/FileMap.hs b/Foundation/IO/FileMap.hs --- a/Foundation/IO/FileMap.hs +++ b/Foundation/IO/FileMap.hs @@ -24,11 +24,11 @@ ) where import Control.Exception -import Foundation.Primitive.Types.OffsetSize -import Foundation.Primitive.Imports +import Basement.Types.OffsetSize +import Basement.Imports import Foundation.VFS (FilePath) -import Foundation.Primitive.FinalPtr -import qualified Foundation.Array.Unboxed as V +import Basement.FinalPtr +import qualified Basement.UArray as V import qualified Foundation.Foreign.MemoryMap as I import qualified Prelude diff --git a/Foundation/IO/Terminal.hs b/Foundation/IO/Terminal.hs --- a/Foundation/IO/Terminal.hs +++ b/Foundation/IO/Terminal.hs @@ -15,7 +15,7 @@ , exitSuccess ) where -import Foundation.Primitive.Imports +import Basement.Imports import qualified Prelude import System.IO (stdin, stdout) import System.Exit diff --git a/Foundation/Internal/Base.hs b/Foundation/Internal/Base.hs deleted file mode 100644 --- a/Foundation/Internal/Base.hs +++ /dev/null @@ -1,91 +0,0 @@ --- | --- Module : Foundation.Internal.Base --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : portable --- --- internal re-export of all the good base bits -module Foundation.Internal.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 - , Foundation.Internal.NumLiteral.Integral (..) - , Foundation.Internal.NumLiteral.Fractional (..) - , Foundation.Internal.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 - , Foundation.Internal.IsList.IsList (..) - , GHC.Exts.IsString (..) - , GHC.Generics.Generic (..) - , Prelude.Either (..) - , Data.Data.Data (..) - , Data.Data.mkNoRepType - , Data.Data.DataType - , Foundation.Internal.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 Foundation.Internal.IsList -import qualified Foundation.Internal.NumLiteral -import qualified Foundation.Internal.Typeable -import qualified GHC.Exts -import qualified GHC.Generics -import qualified GHC.Ptr -import GHC.Exts (fromString) - --- | Only to use internally for internal error cases -internalError :: [Prelude.Char] -> a -internalError s = Prelude.error ("Internal Error: the impossible happened: " Prelude.++ s) - --- | for support of if .. then .. else -ifThenElse :: Prelude.Bool -> a -> a -> a -ifThenElse Prelude.True e1 _ = e1 -ifThenElse Prelude.False _ e2 = e2 diff --git a/Foundation/Internal/ByteSwap.hs b/Foundation/Internal/ByteSwap.hs deleted file mode 100644 --- a/Foundation/Internal/ByteSwap.hs +++ /dev/null @@ -1,82 +0,0 @@ --- | --- Module : Foundation.Internal.ByteSwap --- License : BSD-style --- Maintainer : Foundation --- Stability : experimental --- Portability : portable --- - -{-# LANGUAGE CPP #-} - -module Foundation.Internal.ByteSwap - ( byteSwap16 - , byteSwap32 - , byteSwap64 - , ByteSwap - , byteSwap - ) where - -import Foundation.Internal.Base (Word16, Word32, Word64) - -#if MIN_VERSION_base(4,7,0) - -import Data.Word (byteSwap16, byteSwap32, byteSwap64) - -#else - -import Foundation.Internal.Base (fromInteger) - -import Data.Bits ((.|.), (.&.), unsafeShiftL, unsafeShiftR) - -import Data.Word (Word16, Word32, Word64) - --- | compatibility implementation (i.e. may be slow) --- --- Swap the bytes position (inverting order) as would be done in GHC >= 7.8 -byteSwap16 :: Word16 -> Word16 -byteSwap16 w = w1 .|. w2 - where - w1,w2 :: Word16 - w1 = (w `unsafeShiftL` 8) .&. 0xFF00 - w2 = (w `unsafeShiftR` 8) .&. 0x00FF - --- | compatibility implementation (i.e. may be slow) --- --- Swap the bytes position (inverting order) as would be done in GHC >= 7.8 -byteSwap32 :: Word32 -> Word32 -byteSwap32 w = w1 .|. w2 .|. w3 .|. w4 - where - w1,w2,w3,w4 :: Word32 - w1 = (w `unsafeShiftL` 24) .&. 0xFF000000 - w2 = (w `unsafeShiftR` 24) .&. 0x000000FF - w3 = (w `unsafeShiftL` 8) .&. 0x00FF0000 - w4 = (w `unsafeShiftR` 8) .&. 0x0000FF00 - --- | compatibility implementation (i.e. may be slow) --- --- Swap the bytes position (inverting order) as would be done in GHC >= 7.8 -byteSwap64 :: Word64 -> Word64 -byteSwap64 w = w1 .|. w2 .|. w3 .|. w4 .|. w5 .|. w6 .|. w7 .|. w8 - where - w1,w2,w3,w4,w5,w6,w7,w8 :: Word64 - w1 = (w `unsafeShiftL` 56) .&. 0xFF00000000000000 - w2 = (w `unsafeShiftR` 56) .&. 0x00000000000000FF - w3 = (w `unsafeShiftL` 40) .&. 0x00FF000000000000 - w4 = (w `unsafeShiftR` 40) .&. 0x000000000000FF00 - w5 = (w `unsafeShiftL` 24) .&. 0x0000FF0000000000 - w6 = (w `unsafeShiftR` 24) .&. 0x0000000000FF0000 - w7 = (w `unsafeShiftL` 8) .&. 0x000000FF00000000 - w8 = (w `unsafeShiftR` 8) .&. 0x00000000FF000000 -#endif - --- | Class of types that can be byte-swapped. --- --- e.g. Word16, Word32, Word64 -class ByteSwap a where - byteSwap :: a -> a -instance ByteSwap Word16 where - byteSwap = byteSwap16 -instance ByteSwap Word32 where - byteSwap = byteSwap32 -instance ByteSwap Word64 where - byteSwap = byteSwap64 diff --git a/Foundation/Internal/CallStack.hs b/Foundation/Internal/CallStack.hs deleted file mode 100644 --- a/Foundation/Internal/CallStack.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE ConstraintKinds #-} -module Foundation.Internal.CallStack - ( HasCallStack - ) where - -#if MIN_VERSION_base(4,9,0) - -import GHC.Stack (HasCallStack) - -#elif MIN_VERSION_base(4,8,1) - -import qualified GHC.Stack - -type HasCallStack = (?callStack :: GHC.Stack.CallStack) - -#else - -import GHC.Exts (Constraint) - -type HasCallStack = (() :: Constraint) - -#endif diff --git a/Foundation/Internal/Environment.hs b/Foundation/Internal/Environment.hs deleted file mode 100644 --- a/Foundation/Internal/Environment.hs +++ /dev/null @@ -1,47 +0,0 @@ --- | --- Module : Foundation.Internal.Environment --- License : BSD-style --- Maintainer : foundation --- --- environment variable compat - -{-# LANGUAGE CPP #-} - -module Foundation.Internal.Environment - ( lookupEnv, readMaybe - ) where - -#if MIN_VERSION_base(4,6,0) -import System.Environment (lookupEnv) -import Text.Read (readMaybe) -#else -import Foundation.Internal.Base -import System.Environment (getEnvironment) -import Data.List (lookup) -import Text.Read (Read, minPrec, readPrec, lift) -import Text.ParserCombinators.ReadP as P -import Text.ParserCombinators.ReadPrec (readPrec_to_S) -#endif - -#if !MIN_VERSION_base(4,6,0) -lookupEnv :: [Char] -> IO (Maybe [Char]) -lookupEnv envName = lookup envName <$> getEnvironment - -readEither :: Read a => [Char] -> Either [Char] a -readEither s = - case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of - [x] -> Right x - [] -> Left "Prelude.read: no parse" - _ -> Left "Prelude.read: ambiguous parse" - where - read' = - do x <- readPrec - lift P.skipSpaces - return x - -readMaybe :: Read a => [Char] -> Maybe a -readMaybe s = case readEither s of - Left _ -> Nothing - Right a -> Just a - -#endif diff --git a/Foundation/Internal/Identity.hs b/Foundation/Internal/Identity.hs deleted file mode 100644 --- a/Foundation/Internal/Identity.hs +++ /dev/null @@ -1,37 +0,0 @@ --- | --- Module : Foundation.Internal.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 Foundation.Internal.Identity - ( Identity(..) - ) where - -#if MIN_VERSION_base(4,8,0) - -import Data.Functor.Identity - -#else - -import Foundation.Internal.Base - -newtype Identity a = Identity { runIdentity :: a } - deriving (Eq, Ord) - -instance Functor Identity where - fmap f (Identity a) = Identity (f a) - -instance Applicative Identity where - pure a = Identity a - (<*>) fab fa = Identity $ runIdentity fab (runIdentity fa) - -instance Monad Identity where - return = pure - ma >>= mb = mb (runIdentity ma) - -#endif diff --git a/Foundation/Internal/IsList.hs b/Foundation/Internal/IsList.hs deleted file mode 100644 --- a/Foundation/Internal/IsList.hs +++ /dev/null @@ -1,36 +0,0 @@ --- | --- Module : Foundation.Internal.IsList --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : portable --- --- compat friendly version of IsList -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} -module Foundation.Internal.IsList - ( IsList(..) - ) where - -#if MIN_VERSION_base(4,7,0) - -import GHC.Exts - -#else - -import qualified Prelude - -class IsList l where - type Item l - fromList :: [Item l] -> l - toList :: l -> [Item l] - - fromListN :: Prelude.Int -> [Item l] -> l - fromListN _ = fromList - -instance IsList [a] where - type Item [a] = a - fromList = Prelude.id - toList = Prelude.id - -#endif diff --git a/Foundation/Internal/MonadTrans.hs b/Foundation/Internal/MonadTrans.hs deleted file mode 100644 --- a/Foundation/Internal/MonadTrans.hs +++ /dev/null @@ -1,50 +0,0 @@ --- | --- Module : Foundation.Internal.MonadTrans --- License : BSD-style --- Maintainer : Psychohistorians --- Stability : experimental --- Portability : portable --- --- An internal and really simple monad transformers, --- without any bells and whistse. -module Foundation.Internal.MonadTrans - ( State(..) - , Reader(..) - ) where - -import Foundation.Internal.Base -import Control.Monad ((>=>)) - --- | Simple State monad -newtype State s m a = State { runState :: s -> m (a, s) } - -instance Monad m => Functor (State s m) where - fmap f fa = State $ runState fa >=> (\(a, s2) -> return (f a, s2)) -instance Monad m => Applicative (State s m) where - pure a = State $ \st -> return (a,st) - fab <*> fa = State $ \s1 -> do - (ab,s2) <- runState fab s1 - (a,s3) <- runState fa s2 - return (ab a, s3) -instance Monad m => Monad (State r m) where - return a = State $ \st -> return (a,st) - ma >>= mb = State $ \s1 -> do - (a,s2) <- runState ma s1 - runState (mb a) s2 - --- | Simple Reader monad -newtype Reader r m a = Reader { runReader :: r -> m a } - -instance Monad m => Functor (Reader r m) where - fmap f fa = Reader $ runReader fa >=> (\a -> return (f a)) -instance Monad m => Applicative (Reader r m) where - pure a = Reader $ \_ -> return a - fab <*> fa = Reader $ \r -> do - a <- runReader fa r - ab <- runReader fab r - return $ ab a -instance Monad m => Monad (Reader r m) where - return a = Reader $ \_ -> return a - ma >>= mb = Reader $ \r -> do - a <- runReader ma r - runReader (mb a) r diff --git a/Foundation/Internal/Natural.hs b/Foundation/Internal/Natural.hs deleted file mode 100644 --- a/Foundation/Internal/Natural.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Foundation.Internal.Natural - ( Natural - , integerToNatural - ) where - -#if MIN_VERSION_base(4,8,0) - -import Numeric.Natural -import Prelude (Integer, abs, fromInteger) - -#else - -import Prelude (Show(..),Eq,Ord,Enum,Num(..),Real(..),Integral(..),Integer,error,(<), (>), otherwise) -import Data.Typeable - -newtype Natural = Natural Integer - deriving (Eq,Ord,Enum,Typeable) - -instance Show Natural where - show (Natural i) = show i - --- re-create the buggy Num instance for Natural -instance Num Natural where - fromInteger n - | n < 0 = error "natural should be positive: " - | otherwise = Natural n - (+) (Natural a) (Natural b) = Natural (a + b) - (-) (Natural a) (Natural b) - | r < 0 = error "natural should be positve" - | otherwise = Natural (a - b) - where r = (a - b) - (*) (Natural a) (Natural b) = Natural (a * b) - abs n = n - negate n = n - signum (Natural n) - | n > 0 = 1 - | otherwise = 0 - -instance Real Natural where - toRational (Natural n) = toRational n - -instance Integral Natural where - toInteger (Natural n) = n - divMod (Natural n) (Natural e) = let (a,b) = n `quotRem` e in (Natural a, Natural b) - quotRem (Natural n) (Natural e) = let (a,b) = n `quotRem` e in (Natural a, Natural b) - quot (Natural n) (Natural e) = Natural (n `quot` e) - rem (Natural n) (Natural e) = Natural (n `rem` e) - div = quot - mod = rem - -#endif - -integerToNatural :: Integer -> Natural -integerToNatural i = fromInteger (abs i) diff --git a/Foundation/Internal/NumLiteral.hs b/Foundation/Internal/NumLiteral.hs deleted file mode 100644 --- a/Foundation/Internal/NumLiteral.hs +++ /dev/null @@ -1,127 +0,0 @@ --- | --- Module : Foundation.Internal.NumLiteral --- License : BSD-style --- Maintainer : Foundation --- --- Literal support for Integral and Fractional -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -module Foundation.Internal.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 Foundation.Internal.Natural -import Foreign.C.Types -import System.Posix.Types - --- | Integral Literal support --- --- e.g. 123 :: Integer --- 123 :: Word8 -class Integral a where - fromInteger :: Integer -> a - --- | Fractional Literal support --- --- e.g. 1.2 :: Double --- 0.03 :: Float -class Fractional a where - fromRational :: Rational -> a - --- | Negation support --- --- e.g. -(f x) -class HasNegation a where - negate :: a -> a - -instance Integral Integer where - fromInteger a = a -instance Integral Natural where - fromInteger a = Prelude.fromInteger a -instance Integral Int where - fromInteger a = Prelude.fromInteger a -instance Integral Word where - fromInteger a = Prelude.fromInteger a -instance Integral Word8 where - fromInteger a = Prelude.fromInteger a -instance Integral Word16 where - fromInteger a = Prelude.fromInteger a -instance Integral Word32 where - fromInteger a = Prelude.fromInteger a -instance Integral Word64 where - fromInteger a = Prelude.fromInteger a -instance Integral Int8 where - fromInteger a = Prelude.fromInteger a -instance Integral Int16 where - fromInteger a = Prelude.fromInteger a -instance Integral Int32 where - fromInteger a = Prelude.fromInteger a -instance Integral Int64 where - fromInteger a = Prelude.fromInteger a -instance Integral CSize where - fromInteger a = Prelude.fromInteger a -instance Integral CInt where - fromInteger a = Prelude.fromInteger a -instance Integral COff where - fromInteger a = Prelude.fromInteger a -instance Integral CUIntPtr where - fromInteger a = Prelude.fromInteger a - -instance Integral Float where - fromInteger a = Prelude.fromInteger a -instance Integral Double where - fromInteger a = Prelude.fromInteger a -instance Integral CFloat where - fromInteger a = Prelude.fromInteger a -instance Integral CDouble where - fromInteger a = Prelude.fromInteger a - -instance HasNegation Integer where - negate = Prelude.negate -instance HasNegation Int where - negate = Prelude.negate -instance HasNegation Int8 where - negate = Prelude.negate -instance HasNegation Int16 where - negate = Prelude.negate -instance HasNegation Int32 where - negate = Prelude.negate -instance HasNegation Int64 where - negate = Prelude.negate -instance HasNegation Word where - negate = Prelude.negate -instance HasNegation Word8 where - negate = Prelude.negate -instance HasNegation Word16 where - negate = Prelude.negate -instance HasNegation Word32 where - negate = Prelude.negate -instance HasNegation Word64 where - negate = Prelude.negate -instance HasNegation CInt where - negate = Prelude.negate -instance HasNegation Float where - negate = Prelude.negate -instance HasNegation Double where - negate = Prelude.negate -instance HasNegation CFloat where - negate = Prelude.negate -instance HasNegation CDouble where - negate = Prelude.negate - -instance Fractional Rational where - fromRational a = Prelude.fromRational a -instance Fractional Float where - fromRational a = Prelude.fromRational a -instance Fractional Double where - fromRational a = Prelude.fromRational a -instance Fractional CFloat where - fromRational a = Prelude.fromRational a -instance Fractional CDouble where - fromRational a = Prelude.fromRational a diff --git a/Foundation/Internal/PrimTypes.hs b/Foundation/Internal/PrimTypes.hs deleted file mode 100644 --- a/Foundation/Internal/PrimTypes.hs +++ /dev/null @@ -1,36 +0,0 @@ --- | --- Module : Foundation.Internal.PrimTypes --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : portable --- -{-# LANGUAGE MagicHash #-} -module Foundation.Internal.PrimTypes - ( FileSize# - , Offset# - , CountOf# - , Bool# - , Pinned# - ) where - -import GHC.Prim - --- | File size in bytes -type FileSize# = Word64# - --- | Offset in a bytearray, string, type alias --- --- for code documentation purpose only, just a simple type alias on Int# -type Offset# = Int# - --- | CountOf in bytes type alias --- --- for code documentation purpose only, just a simple type alias on Int# -type CountOf# = Int# - --- | Lowlevel Boolean -type Bool# = Int# - --- | Pinning status -type Pinned# = Bool# diff --git a/Foundation/Internal/Primitive.hs b/Foundation/Internal/Primitive.hs deleted file mode 100644 --- a/Foundation/Internal/Primitive.hs +++ /dev/null @@ -1,179 +0,0 @@ --- | --- Module : Foundation.Internal.Primitive --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : portable --- -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE UnliftedFFITypes #-} -module Foundation.Internal.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 Foundation.Internal.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# #) -#if !MIN_VERSION_base(4,6,0) -compatQuotRemInt# a b = (# quotInt# a b, remInt# a b #) -#else -compatQuotRemInt# = quotRemInt# -#endif -{-# INLINE compatQuotRemInt# #-} - --- | A version friendly fo copyAddrToByteArray# --- --- only available from GHC 7.8 -compatCopyAddrToByteArray# :: Addr# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s -#if MIN_VERSION_base(4,7,0) -compatCopyAddrToByteArray# = copyAddrToByteArray# -#else -compatCopyAddrToByteArray# addr ba ofs sz stini = - loop ofs 0# stini - where - loop o i st - | bool# (i ==# sz) = st - | Prelude.otherwise = - case readWord8OffAddr# addr i st of - (# st2, w #) -> loop (o +# 1#) (i +# 1#) (writeWord8Array# ba o w st2) -#endif -{-# INLINE compatCopyAddrToByteArray# #-} - --- | A version friendly fo copyByteArrayToAddr# --- --- only available from GHC 7.8 -compatCopyByteArrayToAddr# :: ByteArray# -> Int# -> Addr# -> Int# -> State# s -> State# s -#if MIN_VERSION_base(4,7,0) -compatCopyByteArrayToAddr# = copyByteArrayToAddr# -#else -compatCopyByteArrayToAddr# ba ofs addr sz stini = - loop ofs 0# stini - where - loop o i st - | bool# (i ==# sz) = st - | Prelude.otherwise = - loop (o +# 1#) (i +# 1#) (writeWord8OffAddr# addr i (indexWord8Array# ba o) st) -#endif -{-# INLINE compatCopyByteArrayToAddr# #-} - --- | A mkWeak# version that keep working on 8.0 --- --- signature change in ghc-prim: --- * 0.4: mkWeak# :: o -> b -> c -> State# RealWorld -> (#State# RealWorld, Weak# b#) --- * 0.5 :mkWeak# :: o -> b -> (State# RealWorld -> (#State# RealWorld, c#)) -> State# RealWorld -> (#State# RealWorld, Weak# b#) --- -compatMkWeak# :: o -> b -> Prelude.IO () -> State# RealWorld -> (#State# RealWorld, Weak# b #) -#if __GLASGOW_HASKELL__ >= 800 -compatMkWeak# o b c s = mkWeak# o b (case c of { IO f -> f }) s -#else -compatMkWeak# o b c s = mkWeak# o b c s -#endif -{-# INLINE compatMkWeak# #-} - -compatGetSizeofMutableByteArray# :: MutableByteArray# s -> State# s -> (#State# s, Int# #) -#if __GLASGOW_HASKELL__ >= 800 -compatGetSizeofMutableByteArray# mba s = getSizeofMutableByteArray# mba s -#else -compatGetSizeofMutableByteArray# mba s = (# s, sizeofMutableByteArray# mba #) -#endif -{-# INLINE compatGetSizeofMutableByteArray# #-} - -compatShrinkMutableByteArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, MutableByteArray# s #) -#if __GLASGOW_HASKELL__ >= 800 -compatShrinkMutableByteArray# mba i s = - case shrinkMutableByteArray# mba i s of { s2 -> (# s2, mba #) } -#else -compatShrinkMutableByteArray# src i s = - -- not check whether i is smaller than the size of the buffer - case newAlignedPinnedByteArray# i 8# s of { (# s2, dst #) -> - case copyMutableByteArray# dst 0# src 0# i s2 of { s3 -> (# s3, dst #) }} -#endif -{-# INLINE compatShrinkMutableByteArray# #-} - ---shrinkMutableByteArray# :: MutableByteArray# s -> Int# -> State# s -> State# s -compatResizeMutableByteArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, MutableByteArray# s #) -#if __GLASGOW_HASKELL__ >= 800 -compatResizeMutableByteArray# mba i s = resizeMutableByteArray# mba i s -#else -compatResizeMutableByteArray# src i s = - case newAlignedPinnedByteArray# i 8# s of { (# s2, dst #) -> - case copyMutableByteArray# dst 0# src 0# nbBytes s2 of { s3 -> (# s3, dst #) }} - where - isGrow = bool# (i ># len) - nbBytes - | isGrow = len - | Prelude.otherwise = i - !len = sizeofMutableByteArray# src -#endif -{-# INLINE compatResizeMutableByteArray# #-} - -#if __GLASGOW_HASKELL__ >= 802 -compatIsByteArrayPinned# :: ByteArray# -> Pinned# -compatIsByteArrayPinned# ba = isByteArrayPinned# ba - -compatIsMutableByteArrayPinned# :: MutableByteArray# s -> Pinned# -compatIsMutableByteArrayPinned# ba = isMutableByteArrayPinned# ba -#else -foreign import ccall unsafe "foundation_is_bytearray_pinned" - compatIsByteArrayPinned# :: ByteArray# -> Pinned# - -foreign import ccall unsafe "foundation_is_bytearray_pinned" - compatIsMutableByteArrayPinned# :: MutableByteArray# s -> Pinned# -#endif diff --git a/Foundation/Internal/Proxy.hs b/Foundation/Internal/Proxy.hs deleted file mode 100644 --- a/Foundation/Internal/Proxy.hs +++ /dev/null @@ -1,32 +0,0 @@ --- | --- Module : Foundation.Internal.Proxy --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : portable --- -{-# LANGUAGE CPP #-} -module Foundation.Internal.Proxy - ( Proxy(..) - , asProxyTypeOf - ) where - -#if MIN_VERSION_base(4,7,0) -import Data.Proxy -#else -import qualified Prelude - -data Proxy a = Proxy - -instance Prelude.Show (Proxy a) where - showsPrec _ _ = Prelude.showString "Proxy" - --- | 'asProxyTypeOf' is a type-restricted version of 'const'. --- It is usually used as an infix operator, and its typing forces its first --- argument (which is usually overloaded) to have the same type as the tag --- of the second. -asProxyTypeOf :: a -> Proxy a -> a -asProxyTypeOf = Prelude.const -{-# INLINE asProxyTypeOf #-} - -#endif diff --git a/Foundation/Internal/Typeable.hs b/Foundation/Internal/Typeable.hs deleted file mode 100644 --- a/Foundation/Internal/Typeable.hs +++ /dev/null @@ -1,37 +0,0 @@ --- | --- Module : Foundation.Internal.Typeable --- License : BSD-style --- Maintainer : Nicolas Di Prima --- Stability : statble --- Portability : portable --- --- conveniently provide support for legacy and modern base --- - -{-# LANGUAGE CPP #-} - -module Foundation.Internal.Typeable - ( -#if MIN_VERSION_base(4,7,0) - Typeable -#else - Typeable(..) - , typeRep -#endif - ) where - -#if !MIN_VERSION_base(4,7,0) -import Foundation.Internal.Proxy (Proxy(..)) -import qualified Prelude (undefined) -#endif -import Data.Typeable - -#if !MIN_VERSION_base(4,7,0) --- this function does not exist prior base 4.7 -typeRep :: Typeable a => Proxy a -> TypeRep -typeRep = typeRep' Prelude.undefined - where - typeRep' :: Typeable a => a -> Proxy a -> TypeRep - typeRep' a _ = typeOf a - {-# INLINE typeRep' #-} -#endif diff --git a/Foundation/List/DList.hs b/Foundation/List/DList.hs --- a/Foundation/List/DList.hs +++ b/Foundation/List/DList.hs @@ -11,9 +11,9 @@ ( DList ) where -import Foundation.Internal.Base +import Basement.Compat.Base import Foundation.Collection -import Foundation.Class.Bifunctor +import Basement.Compat.Bifunctor newtype DList a = DList { unDList :: [a] -> [a] } deriving (Typeable) @@ -70,10 +70,12 @@ splitAt n = bimap fromList fromList . splitAt n . toList splitOn f = fmap fromList . splitOn f . toList break f = bimap fromList fromList . break f . toList + breakEnd f = bimap fromList fromList . breakEnd f . toList breakElem e = bimap fromList fromList . breakElem e . toList intersperse e = fromList . intersperse e . toList intercalate e = intercalate e . toList span f = bimap fromList fromList . span f . toList + spanEnd f = bimap fromList fromList . spanEnd f . toList filter f = fromList . filter f . toList partition f = bimap fromList fromList . partition f . toList reverse = fromList . reverse . toList diff --git a/Foundation/List/ListN.hs b/Foundation/List/ListN.hs --- a/Foundation/List/ListN.hs +++ b/Foundation/List/ListN.hs @@ -44,8 +44,8 @@ ) where import Data.Proxy -import Foundation.Internal.Base -import Foundation.Primitive.Nat +import Basement.Compat.Base +import Basement.Nat import Foundation.Numerical import qualified Prelude import qualified Control.Monad as M (replicateM) diff --git a/Foundation/Math/Trigonometry.hs b/Foundation/Math/Trigonometry.hs --- a/Foundation/Math/Trigonometry.hs +++ b/Foundation/Math/Trigonometry.hs @@ -3,7 +3,7 @@ ( Trigonometry(..) ) where -import Foundation.Internal.Base +import Basement.Compat.Base import qualified Prelude -- | Method to support basic trigonometric functions diff --git a/Foundation/Monad.hs b/Foundation/Monad.hs --- a/Foundation/Monad.hs +++ b/Foundation/Monad.hs @@ -10,11 +10,17 @@ , MonadBracket(..) , MonadTrans(..) , Identity(..) + , replicateM ) where +import Basement.Imports +import Basement.Types.OffsetSize +import Basement.Monad (MonadFailure(..)) import Foundation.Monad.MonadIO import Foundation.Monad.Exception import Foundation.Monad.Transformer +import Foundation.Numerical +import Control.Applicative (liftA2) #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity @@ -23,21 +29,15 @@ import Control.Monad.Fix import Control.Monad.Zip -import Foundation.Internal.Base +import Basement.Compat.Base -#if MIN_VERSION_base(4,6,0) import GHC.Generics (Generic1) -#endif -- | Identity functor and monad. (a non-strict monad) -- -- @since 4.8.0.0 newtype Identity a = Identity { runIdentity :: a } - deriving (Eq, Ord, Data, Generic, Typeable) - -#if MIN_VERSION_base(4,6,0) -deriving instance Generic1 Identity -#endif + deriving (Eq, Ord, Data, Generic, Generic1, Typeable) instance Functor Identity where fmap f (Identity x) = Identity (f x) @@ -58,3 +58,13 @@ munzip (Identity (x, y)) = (Identity x, Identity y) #endif + +-- | @'replicateM' n act@ performs the action @n@ times, +-- gathering the results. +replicateM :: Applicative m => CountOf a -> m a -> m [a] +replicateM (CountOf count) f = loop count + where + loop cnt + | cnt <= 0 = pure [] + | otherwise = liftA2 (:) f (loop (cnt - 1)) +{-# INLINEABLE replicateM #-} diff --git a/Foundation/Monad/Base.hs b/Foundation/Monad/Base.hs --- a/Foundation/Monad/Base.hs +++ b/Foundation/Monad/Base.hs @@ -10,7 +10,8 @@ , IdentityT ) where -import Foundation.Internal.Base (Functor(..), Applicative(..), Monad(..)) +import Basement.Compat.Base (Functor(..), Applicative(..), Monad(..)) +import Basement.Monad import Foundation.Monad.MonadIO import Foundation.Monad.Exception import Foundation.Monad.Transformer diff --git a/Foundation/Monad/Exception.hs b/Foundation/Monad/Exception.hs --- a/Foundation/Monad/Exception.hs +++ b/Foundation/Monad/Exception.hs @@ -1,25 +1,13 @@ {-# LANGUAGE ScopedTypeVariables #-} module Foundation.Monad.Exception - ( MonadFailure(..) - , MonadThrow(..) + ( MonadThrow(..) , MonadCatch(..) , MonadBracket(..) ) where -import Foundation.Internal.Base +import Basement.Compat.Base import qualified Control.Exception as E --- | Monad that can represent failure --- --- Similar to MonadFail but with a parametrized Failure linked to the Monad -class 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 () - -- | Monad that can throw exception class Monad m => MonadThrow m where -- | Throw immediatity an exception. @@ -46,13 +34,6 @@ -> (a -> m b) -- ^ inner action to perform with the resource -> m b - -instance MonadFailure Maybe where - type Failure Maybe = () - mFail _ = Nothing -instance MonadFailure (Either a) where - type Failure (Either a) = a - mFail a = Left a instance MonadThrow IO where throw = E.throwIO diff --git a/Foundation/Monad/Identity.hs b/Foundation/Monad/Identity.hs --- a/Foundation/Monad/Identity.hs +++ b/Foundation/Monad/Identity.hs @@ -8,7 +8,8 @@ , runIdentityT ) where -import Foundation.Internal.Base hiding (throw) +import Basement.Compat.Base hiding (throw) +import Basement.Monad (MonadFailure(..)) import Foundation.Monad.MonadIO import Foundation.Monad.Exception import Foundation.Monad.Transformer diff --git a/Foundation/Monad/MonadIO.hs b/Foundation/Monad/MonadIO.hs --- a/Foundation/Monad/MonadIO.hs +++ b/Foundation/Monad/MonadIO.hs @@ -6,7 +6,7 @@ #if MIN_VERSION_base(4,9,0) import Control.Monad.IO.Class #else -import Foundation.Internal.Base +import Basement.Compat.Base -- | Monads in which 'IO' computations may be embedded. class Monad m => MonadIO m where diff --git a/Foundation/Monad/Reader.hs b/Foundation/Monad/Reader.hs --- a/Foundation/Monad/Reader.hs +++ b/Foundation/Monad/Reader.hs @@ -11,7 +11,7 @@ , runReaderT ) where -import Foundation.Internal.Base (($), (.), const) +import Basement.Compat.Base (($), (.), const) import Foundation.Monad.Base class Monad m => MonadReader m where diff --git a/Foundation/Monad/State.hs b/Foundation/Monad/State.hs --- a/Foundation/Monad/State.hs +++ b/Foundation/Monad/State.hs @@ -10,8 +10,8 @@ , runStateT ) where -import Foundation.Class.Bifunctor (first) -import Foundation.Internal.Base (($), (.), const) +import Basement.Compat.Bifunctor (first) +import Basement.Compat.Base (($), (.), const) import Foundation.Monad.Base import Control.Monad ((>=>)) diff --git a/Foundation/Monad/Transformer.hs b/Foundation/Monad/Transformer.hs --- a/Foundation/Monad/Transformer.hs +++ b/Foundation/Monad/Transformer.hs @@ -2,7 +2,7 @@ ( MonadTrans(..) ) where -import Foundation.Internal.Base +import Basement.Compat.Base -- | Basic Transformer class class MonadTrans trans where diff --git a/Foundation/Network/HostName.hsc b/Foundation/Network/HostName.hsc --- a/Foundation/Network/HostName.hsc +++ b/Foundation/Network/HostName.hsc @@ -23,8 +23,8 @@ ) where import Foundation.Class.Storable -import Foundation.Internal.Base -import Foundation.Internal.Proxy +import Basement.Compat.Base +import Data.Proxy import Foundation.Hashing (Hashable) import Foundation.String import Foundation.Array diff --git a/Foundation/Network/IPv4.hs b/Foundation/Network/IPv4.hs --- a/Foundation/Network/IPv4.hs +++ b/Foundation/Network/IPv4.hs @@ -24,8 +24,8 @@ import Foundation.Class.Storable import Foundation.Hashing.Hashable -import Foundation.Internal.Base -import Foundation.Internal.Proxy +import Basement.Compat.Base +import Data.Proxy import Foundation.String (String) import Foundation.Primitive import Foundation.Bits diff --git a/Foundation/Network/IPv6.hs b/Foundation/Network/IPv6.hs --- a/Foundation/Network/IPv6.hs +++ b/Foundation/Network/IPv6.hs @@ -29,11 +29,11 @@ import Foundation.Class.Storable import Foundation.Hashing.Hashable -import Foundation.Numerical.Additive (scale) -import Foundation.Internal.Base -import Foundation.Internal.Proxy +import Basement.Numerical.Additive (scale) +import Basement.Compat.Base +import Data.Proxy import Foundation.Primitive -import Foundation.Primitive.Types.OffsetSize +import Basement.Types.OffsetSize import Foundation.Numerical import Foundation.Collection (Element, length, intercalate, replicate, null) import Foundation.Parser diff --git a/Foundation/Numerical.hs b/Foundation/Numerical.hs --- a/Foundation/Numerical.hs +++ b/Foundation/Numerical.hs @@ -30,11 +30,11 @@ , FloatingPoint(..) ) where -import Foundation.Internal.Base -import Foundation.Numerical.Number -import Foundation.Numerical.Additive -import Foundation.Numerical.Subtractive -import Foundation.Numerical.Multiplicative +import Basement.Compat.Base +import Basement.Numerical.Number +import Basement.Numerical.Additive +import Basement.Numerical.Subtractive +import Basement.Numerical.Multiplicative import Foundation.Numerical.Floating import qualified Prelude diff --git a/Foundation/Numerical/Additive.hs b/Foundation/Numerical/Additive.hs deleted file mode 100644 --- a/Foundation/Numerical/Additive.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} -module Foundation.Numerical.Additive - ( Additive(..) - ) where - -#include "MachDeps.h" - -import Foundation.Internal.Base -import Foundation.Internal.Natural -import Foundation.Numerical.Number -import qualified Prelude -import GHC.Types -import GHC.Prim -import GHC.Int -import GHC.Word -import Foreign.C.Types - -#if WORD_SIZE_IN_BITS < 64 -import GHC.IntWord64 -#endif - --- | Represent class of things that can be added together, --- contains a neutral element and is commutative. --- --- > x + azero = x --- > azero + x = x --- > x + y = y + x --- -class Additive a where - {-# MINIMAL azero, (+) #-} - azero :: a -- the identity element over addition - (+) :: a -> a -> a -- the addition - - scale :: IsNatural n => n -> a -> a -- scale: repeated addition - --default scale :: (Prelude.Num n, IsNatural n) => n -> a -> a - scale 0 _ = azero - scale 1 a = a - scale 2 a = a + a - scale n a = a + scale (pred n) a -- TODO optimise. define by group of 2. - -infixl 6 + - -instance Additive Integer where - azero = 0 - (+) = (Prelude.+) - scale = scaleNum -instance Additive Int where - azero = 0 - (I# a) + (I# b) = I# (a +# b) - scale = scaleNum -instance Additive Int8 where - azero = 0 - (I8# a) + (I8# b) = I8# (narrow8Int# (a +# b)) - scale = scaleNum -instance Additive Int16 where - azero = 0 - (I16# a) + (I16# b) = I16# (narrow16Int# (a +# b)) - scale = scaleNum -instance Additive Int32 where - azero = 0 - (I32# a) + (I32# b) = I32# (narrow32Int# (a +# b)) - scale = scaleNum -instance Additive Int64 where - azero = 0 -#if WORD_SIZE_IN_BITS == 64 - (I64# a) + (I64# b) = I64# (a +# b) -#else - (I64# a) + (I64# b) = I64# (a `plusInt64#` b) -#endif - scale = scaleNum -instance Additive Word where - azero = 0 - (W# a) + (W# b) = W# (a `plusWord#` b) - scale = scaleNum -instance Additive Natural where - azero = 0 - (+) = (Prelude.+) - scale = scaleNum -instance Additive Word8 where - azero = 0 - (W8# a) + (W8# b) = W8# (narrow8Word# (a `plusWord#` b)) - scale = scaleNum -instance Additive Word16 where - azero = 0 - (W16# a) + (W16# b) = W16# (narrow16Word# (a `plusWord#` b)) - scale = scaleNum -instance Additive Word32 where - azero = 0 - (W32# a) + (W32# b) = W32# (narrow32Word# (a `plusWord#` b)) - scale = scaleNum -instance Additive Word64 where - azero = 0 -#if WORD_SIZE_IN_BITS == 64 - (W64# a) + (W64# b) = W64# (a `plusWord#` b) -#else - (W64# a) + (W64# b) = W64# (int64ToWord64# (word64ToInt64# a `plusInt64#` word64ToInt64# b)) -#endif - scale = scaleNum -instance Additive Prelude.Float where - azero = 0.0 - (F# a) + (F# b) = F# (a `plusFloat#` b) - scale = scaleNum -instance Additive Prelude.Double where - azero = 0.0 - (D# a) + (D# b) = D# (a +## b) - scale = scaleNum -instance Additive CSize where - azero = 0 - (+) = (Prelude.+) - scale = scaleNum - -scaleNum :: (Prelude.Num a, IsNatural n) => n -> a -> a -scaleNum n a = (Prelude.fromIntegral $ toNatural n) Prelude.* a diff --git a/Foundation/Numerical/Floating.hs b/Foundation/Numerical/Floating.hs --- a/Foundation/Numerical/Floating.hs +++ b/Foundation/Numerical/Floating.hs @@ -3,8 +3,8 @@ ( FloatingPoint(..) ) where -import Foundation.Internal.Base -import Foundation.Internal.Proxy +import Basement.Compat.Base +import Data.Proxy import qualified Prelude -- | IEEE754 Floating Point diff --git a/Foundation/Numerical/Multiplicative.hs b/Foundation/Numerical/Multiplicative.hs deleted file mode 100644 --- a/Foundation/Numerical/Multiplicative.hs +++ /dev/null @@ -1,164 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -module Foundation.Numerical.Multiplicative - ( Multiplicative(..) - , IDivisible(..) - , Divisible(..) - , recip - ) where - -import Foundation.Internal.Base -import Foundation.Internal.Natural -import Foundation.Numerical.Number -import Foundation.Numerical.Additive -import qualified Prelude - --- | Represent class of things that can be multiplied together --- --- > x * midentity = x --- > midentity * x = x -class Multiplicative a where - {-# MINIMAL midentity, (*) #-} - -- | Identity element over multiplication - midentity :: a - - -- | Multiplication of 2 elements that result in another element - (*) :: a -> a -> a - - -- | Raise to power, repeated multiplication - -- e.g. - -- > a ^ 2 = a * a - -- > a ^ 10 = (a ^ 5) * (a ^ 5) .. - --(^) :: (IsNatural n) => a -> n -> a - (^) :: (IsNatural n, IDivisible n) => a -> n -> a - -- default (^) :: (IDivisible n, IsNatural n, Multiplicative a) => a -> n -> a - (^) = power - --- | Represent types that supports an euclidian division --- --- > (x ‘div‘ y) * y + (x ‘mod‘ y) == x -class (Additive a, Multiplicative a) => IDivisible a where - {-# MINIMAL (div, mod) | divMod #-} - div :: a -> a -> a - div a b = fst $ divMod a b - mod :: a -> a -> a - mod a b = snd $ divMod a b - divMod :: a -> a -> (a, a) - divMod a b = (div a b, mod a b) - --- | Support for division between same types --- --- This is likely to change to represent specific mathematic divisions -class Multiplicative a => Divisible a where - {-# MINIMAL (/) #-} - (/) :: a -> a -> a - -infixl 7 *, / -infixr 8 ^ - -instance Multiplicative Integer where - midentity = 1 - (*) = (Prelude.*) -instance Multiplicative Int where - midentity = 1 - (*) = (Prelude.*) -instance Multiplicative Int8 where - midentity = 1 - (*) = (Prelude.*) -instance Multiplicative Int16 where - midentity = 1 - (*) = (Prelude.*) -instance Multiplicative Int32 where - midentity = 1 - (*) = (Prelude.*) -instance Multiplicative Int64 where - midentity = 1 - (*) = (Prelude.*) -instance Multiplicative Natural where - midentity = 1 - (*) = (Prelude.*) -instance Multiplicative Word where - midentity = 1 - (*) = (Prelude.*) -instance Multiplicative Word8 where - midentity = 1 - (*) = (Prelude.*) -instance Multiplicative Word16 where - midentity = 1 - (*) = (Prelude.*) -instance Multiplicative Word32 where - midentity = 1 - (*) = (Prelude.*) -instance Multiplicative Word64 where - midentity = 1 - (*) = (Prelude.*) -instance Multiplicative Prelude.Float where - midentity = 1.0 - (*) = (Prelude.*) -instance Multiplicative Prelude.Double where - midentity = 1.0 - (*) = (Prelude.*) -instance Multiplicative Prelude.Rational where - midentity = 1.0 - (*) = (Prelude.*) - -instance IDivisible Integer where - div = Prelude.div - mod = Prelude.mod -instance IDivisible Int where - div = Prelude.div - mod = Prelude.mod -instance IDivisible Int8 where - div = Prelude.div - mod = Prelude.mod -instance IDivisible Int16 where - div = Prelude.div - mod = Prelude.mod -instance IDivisible Int32 where - div = Prelude.div - mod = Prelude.mod -instance IDivisible Int64 where - div = Prelude.div - mod = Prelude.mod -instance IDivisible Natural where - div = Prelude.quot - mod = Prelude.rem -instance IDivisible Word where - div = Prelude.quot - mod = Prelude.rem -instance IDivisible Word8 where - div = Prelude.quot - mod = Prelude.rem -instance IDivisible Word16 where - div = Prelude.quot - mod = Prelude.rem -instance IDivisible Word32 where - div = Prelude.quot - mod = Prelude.rem -instance IDivisible Word64 where - div = Prelude.quot - mod = Prelude.rem - -instance Divisible Prelude.Rational where - (/) = (Prelude./) -instance Divisible Float where - (/) = (Prelude./) -instance Divisible Double where - (/) = (Prelude./) - -recip :: Divisible a => a -> a -recip x = midentity / x - -power :: (IsNatural n, IDivisible n, Multiplicative a) => a -> n -> a -power a n - | n == 0 = midentity - | otherwise = squaring midentity a n - where - squaring y x i - | i == 0 = y - | i == 1 = x * y - | even i = squaring y (x*x) (i`div`2) - | otherwise = squaring (x*y) (x*x) (pred i`div` 2) - -even :: (IDivisible n, IsIntegral n) => n -> Bool -even n = (n `mod` 2) == 0 diff --git a/Foundation/Numerical/Number.hs b/Foundation/Numerical/Number.hs deleted file mode 100644 --- a/Foundation/Numerical/Number.hs +++ /dev/null @@ -1,64 +0,0 @@ -module Foundation.Numerical.Number - ( IsIntegral(..) - , IsNatural(..) - ) where - -import Foundation.Internal.Base -import Foundation.Internal.Natural -import qualified Prelude -import Foreign.C.Types - --- | Number literals, convertible through the generic Integer type. --- --- all number are Enum'erable, meaning that you can move to --- next element -class (Enum a, Eq a, Ord a, Integral a) => IsIntegral a where - {-# MINIMAL toInteger #-} - toInteger :: a -> Integer - --- | Non Negative Number literals, convertible through the generic Natural type -class (Enum a, Eq a, Ord a, Integral a, IsIntegral a) => IsNatural a where - {-# MINIMAL toNatural #-} - toNatural :: a -> Natural - -instance IsIntegral Integer where - toInteger i = i -instance IsIntegral Int where - toInteger i = Prelude.toInteger i -instance IsIntegral Int8 where - toInteger i = Prelude.toInteger i -instance IsIntegral Int16 where - toInteger i = Prelude.toInteger i -instance IsIntegral Int32 where - toInteger i = Prelude.toInteger i -instance IsIntegral Int64 where - toInteger i = Prelude.toInteger i -instance IsIntegral Natural where - toInteger i = Prelude.toInteger i -instance IsIntegral Word where - toInteger i = Prelude.toInteger i -instance IsIntegral Word8 where - toInteger i = Prelude.toInteger i -instance IsIntegral Word16 where - toInteger i = Prelude.toInteger i -instance IsIntegral Word32 where - toInteger i = Prelude.toInteger i -instance IsIntegral Word64 where - toInteger i = Prelude.toInteger i -instance IsIntegral CSize where - toInteger i = Prelude.toInteger i - -instance IsNatural Natural where - toNatural i = i -instance IsNatural Word where - toNatural i = Prelude.fromIntegral i -instance IsNatural Word8 where - toNatural i = Prelude.fromIntegral i -instance IsNatural Word16 where - toNatural i = Prelude.fromIntegral i -instance IsNatural Word32 where - toNatural i = Prelude.fromIntegral i -instance IsNatural Word64 where - toNatural i = Prelude.fromIntegral i -instance IsNatural CSize where - toNatural i = Prelude.fromIntegral i diff --git a/Foundation/Numerical/Primitives.hs b/Foundation/Numerical/Primitives.hs deleted file mode 100644 --- a/Foundation/Numerical/Primitives.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE CPP #-} -module Foundation.Numerical.Primitives - ( intToWord - , integralConvert - ) where - -import GHC.Types -import GHC.Prim -import GHC.Word -import GHC.Int -import qualified Prelude - --- | Convert an 'Int' into a 'Word' -intToWord :: Int -> Word -intToWord (I# i) = W# (int2Word# i) -{-# INLINE intToWord #-} - --- | Various conversion between integral number -class IntegralConvert a b where - -- | lossless integral convertion - integralConvert :: a -> b - -instance IntegralConvert Int8 Word8 where - integralConvert (I8# i) = W8# (int2Word# i) -instance IntegralConvert Int16 Word16 where - integralConvert (I16# i) = W16# (int2Word# i) -instance IntegralConvert Int32 Word32 where - integralConvert (I32# i) = W32# (int2Word# i) -instance IntegralConvert Int64 Word64 where - integralConvert i = Prelude.fromIntegral i diff --git a/Foundation/Numerical/Subtractive.hs b/Foundation/Numerical/Subtractive.hs deleted file mode 100644 --- a/Foundation/Numerical/Subtractive.hs +++ /dev/null @@ -1,74 +0,0 @@ -module Foundation.Numerical.Subtractive - ( Subtractive(..) - ) where - -import Foundation.Internal.Base -import Foundation.Internal.Natural -import Foundation.Primitive.IntegralConv -import qualified Prelude - --- | Represent class of things that can be subtracted. --- --- --- Note that the result is not necessary of the same type --- as the operand depending on the actual type. --- --- For example: --- --- > (-) :: Int -> Int -> Int --- > (-) :: DateTime -> DateTime -> Seconds --- > (-) :: Ptr a -> Ptr a -> PtrDiff --- > (-) :: Natural -> Natural -> Maybe Natural -class Subtractive a where - type Difference a - (-) :: a -> a -> Difference a - -infixl 6 - - -instance Subtractive Integer where - type Difference Integer = Integer - (-) = (Prelude.-) -instance Subtractive Int where - type Difference Int = Int - (-) = (Prelude.-) -instance Subtractive Int8 where - type Difference Int8 = Int8 - (-) = (Prelude.-) -instance Subtractive Int16 where - type Difference Int16 = Int16 - (-) = (Prelude.-) -instance Subtractive Int32 where - type Difference Int32 = Int32 - (-) = (Prelude.-) -instance Subtractive Int64 where - type Difference Int64 = Int64 - (-) = (Prelude.-) -instance Subtractive Natural where - type Difference Natural = Maybe Natural - (-) a b - | b > a = Nothing - | otherwise = Just (a Prelude.- b) -instance Subtractive Word where - type Difference Word = Word - (-) = (Prelude.-) -instance Subtractive Word8 where - type Difference Word8 = Word8 - (-) = (Prelude.-) -instance Subtractive Word16 where - type Difference Word16 = Word16 - (-) = (Prelude.-) -instance Subtractive Word32 where - type Difference Word32 = Word32 - (-) = (Prelude.-) -instance Subtractive Word64 where - type Difference Word64 = Word64 - (-) = (Prelude.-) -instance Subtractive Prelude.Float where - type Difference Prelude.Float = Prelude.Float - (-) = (Prelude.-) -instance Subtractive Prelude.Double where - type Difference Prelude.Double = Prelude.Double - (-) = (Prelude.-) -instance Subtractive Prelude.Char where - type Difference Prelude.Char = Prelude.Int - (-) a b = (Prelude.-) (charToInt a) (charToInt b) diff --git a/Foundation/Parser.hs b/Foundation/Parser.hs --- a/Foundation/Parser.hs +++ b/Foundation/Parser.hs @@ -63,8 +63,8 @@ import Control.Applicative (Alternative, empty, (<|>), many, some, optional) import Control.Monad (MonadPlus, mzero, mplus) -import Foundation.Internal.Base -import Foundation.Primitive.Types.OffsetSize +import Basement.Compat.Base +import Basement.Types.OffsetSize import Foundation.Numerical import Foundation.Collection hiding (take, takeWhile) import qualified Foundation.Collection as C @@ -227,7 +227,7 @@ success :: ParserSource input => input -> Offset (Element input) -> NoMore -> r -> Result input r success buf off _ = ParseOk rest where - !rest = subChunk buf off (length buf - offsetAsSize off) + !rest = subChunk buf off (length buf `sizeSub` offsetAsSize off) {-# INLINE success #-} -- | parse only the given input @@ -374,12 +374,11 @@ let lenI = sizeAsOffset (length buf) - off in if endOfParserSource buf off && n > 0 then err buf off nm $ NotEnough n - else if n <= lenI - then let t = subChunk buf off n - in ok buf (off + sizeAsOffset n) nm t - else let h = subChunk buf off lenI - in runParser_ (take $ n - lenI) buf (sizeAsOffset lenI) nm err $ - \buf' off' nm' t -> ok buf' off' nm' (h <> t) + else case n - lenI of + Just s | s > 0 -> let h = subChunk buf off lenI + in runParser_ (take s) buf (sizeAsOffset lenI) nm err $ + \buf' off' nm' t -> ok buf' off' nm' (h <> t) + _ -> ok buf (off + sizeAsOffset n) nm (subChunk buf off n) takeWhile :: ( ParserSource input, Sequential (Chunk input) ) @@ -422,9 +421,9 @@ let lenI = sizeAsOffset (length buf) - off in if endOfParserSource buf off && n > 0 then err buf off nm $ NotEnough n - else if n <= lenI - then ok buf (off + sizeAsOffset n) nm () - else runParser_ (skip $ n - lenI) buf (sizeAsOffset lenI) nm err ok + else case n - lenI of + Just s | s > 0 -> runParser_ (skip s) buf (sizeAsOffset lenI) nm err ok + _ -> ok buf (off + sizeAsOffset n) nm () skipWhile :: ( ParserSource input, Sequential (Chunk input) ) diff --git a/Foundation/Partial.hs b/Foundation/Partial.hs --- a/Foundation/Partial.hs +++ b/Foundation/Partial.hs @@ -23,8 +23,8 @@ , fromRight ) where -import Foundation.Internal.Base -import Foundation.Internal.Identity +import Basement.Compat.Base +import Basement.Compat.Identity -- | Partialiality wrapper. newtype Partial a = Partial (Identity a) diff --git a/Foundation/Primitive.hs b/Foundation/Primitive.hs --- a/Foundation/Primitive.hs +++ b/Foundation/Primitive.hs @@ -5,8 +5,6 @@ -- Stability : experimental -- Portability : portable -- --- Different collections (list, vector, string, ..) unified under 1 API. --- an API to rules them all, and in the darkness bind them. -- {-# LANGUAGE FlexibleInstances #-} module Foundation.Primitive @@ -34,12 +32,18 @@ -- * Block of memory , Block , MutableBlock + + -- * Ascii + , Char7 + , AsciiString(..) ) where -import Foundation.Primitive.Types -import Foundation.Primitive.Monad -import Foundation.Primitive.Endianness -import Foundation.Primitive.IntegralConv -import Foundation.Primitive.NormalForm -import Foundation.Primitive.These -import Foundation.Primitive.Block +import Basement.PrimType +import Basement.Types.Char7 +import Basement.Types.AsciiString +import Basement.Monad +import Basement.Endianness +import Basement.IntegralConv +import Basement.NormalForm +import Basement.These +import Basement.Block diff --git a/Foundation/Primitive/Base16.hs b/Foundation/Primitive/Base16.hs deleted file mode 100644 --- a/Foundation/Primitive/Base16.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE BangPatterns #-} -module Foundation.Primitive.Base16 - ( unsafeConvertByte - , hexWord16 - , hexWord32 - ) where - -import GHC.Prim -import GHC.Types -import GHC.Word - --- | Convert a byte value in Word# to two Word#s containing --- the hexadecimal representation of the Word# --- --- The output words# are guaranteed to be included in the 0 to 2^7-1 range --- --- Note that calling convertByte with a value greater than 256 --- will cause segfault or other horrible effect. -unsafeConvertByte :: Word# -> (# Word#, Word# #) -unsafeConvertByte b = (# r tableHi b, r tableLo b #) - where - r :: Table -> Word# -> Word# - r (Table !table) index = indexWord8OffAddr# table (word2Int# index) -{-# INLINE unsafeConvertByte #-} - --- | hex word16 -hexWord16 :: Word16 -> (Char, Char, Char, Char) -hexWord16 (W16# w) = (toChar w1,toChar w2,toChar w3,toChar w4) - where - toChar :: Word# -> Char - toChar c = C# (chr# (word2Int# c)) - (# w1, w2 #) = unsafeConvertByte (uncheckedShiftRL# w 8#) - (# w3, w4 #) = unsafeConvertByte (and# w 0xff##) - --- | hex word32 -hexWord32 :: Word32 -> (Char, Char, Char, Char, Char, Char, Char, Char) -hexWord32 (W32# w) = (toChar w1,toChar w2,toChar w3,toChar w4 - ,toChar w5,toChar w6,toChar w7,toChar w8) - where - toChar :: Word# -> Char - toChar c = C# (chr# (word2Int# c)) - (# w1, w2 #) = unsafeConvertByte (uncheckedShiftRL# w 24#) - (# w3, w4 #) = unsafeConvertByte (and# (uncheckedShiftRL# w 16#) 0xff##) - (# w5, w6 #) = unsafeConvertByte (and# (uncheckedShiftRL# w 8#) 0xff##) - (# w7, w8 #) = unsafeConvertByte (and# w 0xff##) - -data Table = Table Addr# - -tableLo:: Table -tableLo = Table - "0123456789abcdef0123456789abcdef\ - \0123456789abcdef0123456789abcdef\ - \0123456789abcdef0123456789abcdef\ - \0123456789abcdef0123456789abcdef\ - \0123456789abcdef0123456789abcdef\ - \0123456789abcdef0123456789abcdef\ - \0123456789abcdef0123456789abcdef\ - \0123456789abcdef0123456789abcdef"# - -tableHi :: Table -tableHi = Table - "00000000000000001111111111111111\ - \22222222222222223333333333333333\ - \44444444444444445555555555555555\ - \66666666666666667777777777777777\ - \88888888888888889999999999999999\ - \aaaaaaaaaaaaaaaabbbbbbbbbbbbbbbb\ - \ccccccccccccccccdddddddddddddddd\ - \eeeeeeeeeeeeeeeeffffffffffffffff"# - diff --git a/Foundation/Primitive/Block.hs b/Foundation/Primitive/Block.hs deleted file mode 100644 --- a/Foundation/Primitive/Block.hs +++ /dev/null @@ -1,401 +0,0 @@ --- | --- Module : Foundation.Primitive.Block --- License : BSD-style --- Maintainer : Haskell Foundation --- --- A block of memory that contains elements of a type, --- very similar to an unboxed array but with the key difference: --- --- * It doesn't have slicing capability (no cheap take or drop) --- * It consume less memory: 1 Offset, 1 CountOf --- * It's unpackable in any constructor --- * It uses unpinned memory by default --- -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UnboxedTuples #-} -module Foundation.Primitive.Block - ( Block(..) - , MutableBlock(..) - -- * Properties - , length - -- * Lowlevel functions - , unsafeThaw - , unsafeFreeze - , unsafeIndex - , thaw - , freeze - , copy - -- * safer api - , create - , isPinned - , isMutablePinned - , singleton - , replicate - , index - , map - , foldl' - , foldr - , foldl1' - , foldr1 - , cons - , snoc - , uncons - , unsnoc - , sub - , splitAt - , revSplitAt - , splitOn - , break - , span - , elem - , all - , any - , find - , filter - , reverse - , sortBy - , intersperse - -- * Foreign interfaces - , unsafeCopyToPtr - ) where - -import GHC.Prim -import GHC.Types -import GHC.ST -import qualified Data.List -import Foundation.Internal.Base -import Foundation.Internal.Proxy -import Foundation.Internal.Primitive -import Foundation.Collection.NonEmpty -import Foundation.Primitive.Types.OffsetSize -import Foundation.Primitive.Monad -import Foundation.Primitive.Exception -import Foundation.Primitive.Types -import qualified Foundation.Primitive.Block.Mutable as M -import Foundation.Primitive.Block.Mutable (Block(..), MutableBlock(..), new, unsafeThaw, unsafeFreeze) -import Foundation.Primitive.Block.Base -import Foundation.Numerical - --- | 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 - | nbElems == 0 = Nothing - | otherwise = Just (sub vec 0 lastElem, unsafeIndex vec lastElem) - where - !lastElem = 0 `offsetPlusE` (nbElems - 1) - !nbElems = length vec - -splitAt :: PrimType ty => CountOf ty -> Block ty -> (Block ty, Block ty) -splitAt nbElems blk - | nbElems <= 0 = (mempty, blk) - | n == vlen = (blk, mempty) - | otherwise = runST $ do - left <- new nbElems - right <- new (vlen - nbElems) - M.unsafeCopyElementsRO left 0 blk 0 nbElems - M.unsafeCopyElementsRO right 0 blk (sizeAsOffset nbElems) (vlen - nbElems) - - (,) <$> unsafeFreeze left <*> unsafeFreeze right - where - n = min nbElems vlen - vlen = length blk -{-# 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) - | otherwise = let (x,y) = splitAt (length blk - n) blk in (y,x) - -break :: PrimType ty => (ty -> Bool) -> Block ty -> (Block ty, Block ty) -break predicate blk = findBreak 0 - where - !len = length blk - findBreak !i - | i .==# len = (blk, mempty) - | predicate (unsafeIndex blk i) = splitAt (offsetAsSize i) blk - | otherwise = findBreak (i + 1) - {-# INLINE findBreak #-} -{-# SPECIALIZE [2] break :: (Word8 -> Bool) -> Block Word8 -> (Block Word8, Block Word8) #-} - -span :: PrimType ty => (ty -> Bool) -> Block ty -> (Block ty, Block ty) -span p = break (not . p) - -elem :: PrimType ty => ty -> Block ty -> Bool -elem v blk = loop 0 - where - !len = length blk - loop !i - | i .==# len = False - | unsafeIndex blk i == v = True - | otherwise = loop (i+1) -{-# SPECIALIZE [2] elem :: Word8 -> Block Word8 -> Bool #-} - -all :: PrimType ty => (ty -> Bool) -> Block ty -> Bool -all p blk = loop 0 - where - !len = length blk - loop !i - | i .==# len = True - | p (unsafeIndex blk i) = loop (i+1) - | otherwise = False -{-# SPECIALIZE [2] all :: (Word8 -> Bool) -> Block Word8 -> Bool #-} - -any :: PrimType ty => (ty -> Bool) -> Block ty -> Bool -any p blk = loop 0 - where - !len = length blk - loop !i - | i .==# len = False - | p (unsafeIndex blk i) = True - | otherwise = loop (i+1) -{-# SPECIALIZE [2] any :: (Word8 -> Bool) -> Block Word8 -> Bool #-} - -splitOn :: PrimType ty => (ty -> Bool) -> Block ty -> [Block ty] -splitOn predicate blk - | len == 0 = [mempty] - | otherwise = go 0 0 - where - !len = length blk - go !prevIdx !idx - | idx .==# len = [sub blk prevIdx idx] - | otherwise = - let e = unsafeIndex blk idx - idx' = idx + 1 - in if predicate e - then sub blk prevIdx idx : go idx' idx' - else go prevIdx idx' - -find :: PrimType ty => (ty -> Bool) -> Block ty -> Maybe ty -find predicate vec = loop 0 - where - !len = length vec - loop i - | i .==# len = Nothing - | otherwise = - let e = unsafeIndex vec i - in if predicate e then Just e else loop (i+1) - -filter :: PrimType ty => (ty -> Bool) -> Block ty -> Block ty -filter predicate vec = fromList $ Data.List.filter predicate $ toList vec - -reverse :: forall ty . PrimType ty => Block ty -> Block ty -reverse blk - | len == 0 = mempty - | otherwise = runST $ do - mb <- new len - go mb - unsafeFreeze mb - where - !len = length blk - !endOfs = 0 `offsetPlusE` len - - go :: MutableBlock ty s -> ST s () - go mb = loop endOfs 0 - where - loop o i - | i .==# len = pure () - | otherwise = unsafeWrite mb o' (unsafeIndex blk i) >> loop o' (i+1) - where o' = pred o - -sortBy :: forall ty . PrimType ty => (ty -> ty -> Ordering) -> Block ty -> Block ty -sortBy xford vec - | len == 0 = mempty - | otherwise = runST (thaw vec >>= doSort xford) - where - len = length vec - doSort :: (PrimType ty, PrimMonad prim) => (ty -> ty -> Ordering) -> MutableBlock ty (PrimState prim) -> prim (Block ty) - doSort ford ma = qsort 0 (sizeLastOffset len) >> unsafeFreeze ma - where - qsort lo hi - | lo >= hi = pure () - | otherwise = do - p <- partition lo hi - qsort lo (pred p) - qsort (p+1) hi - partition lo hi = do - pivot <- unsafeRead ma hi - let loop i j - | j == hi = pure i - | otherwise = do - aj <- unsafeRead ma j - i' <- if ford aj pivot == GT - then pure i - else do - ai <- unsafeRead ma i - unsafeWrite ma j ai - unsafeWrite ma i aj - pure $ i + 1 - loop i' (j+1) - - i <- loop lo lo - ai <- unsafeRead ma i - ahi <- unsafeRead ma hi - unsafeWrite ma hi ai - unsafeWrite ma i ahi - pure i - -intersperse :: forall ty . PrimType ty => ty -> Block ty -> Block ty -intersperse sep blk - | len <= 1 = blk - | otherwise = runST $ do - mb <- new newSize - go mb - unsafeFreeze mb - where - !len = length blk - newSize = len + len - 1 - - go :: MutableBlock ty s -> ST s () - go mb = loop 0 0 - where - loop !o !i - | i .==# (len - 1) = unsafeWrite mb o (unsafeIndex blk i) - | otherwise = do - unsafeWrite mb o (unsafeIndex blk i) - unsafeWrite mb (o+1) sep - loop (o+2) (i+1) diff --git a/Foundation/Primitive/Block/Base.hs b/Foundation/Primitive/Block/Base.hs deleted file mode 100644 --- a/Foundation/Primitive/Block/Base.hs +++ /dev/null @@ -1,342 +0,0 @@ -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UnboxedTuples #-} -module Foundation.Primitive.Block.Base - ( Block(..) - , MutableBlock(..) - -- * Basic accessor - , unsafeNew - , unsafeThaw - , unsafeFreeze - , unsafeCopyElements - , unsafeCopyElementsRO - , unsafeCopyBytes - , unsafeCopyBytesRO - , unsafeRead - , unsafeWrite - , unsafeIndex - -- * Properties - , length - , lengthBytes - -- * Other methods - , mutableEmpty - , new - , newPinned - , touch - , mutableTouch - ) where - -import GHC.Prim -import GHC.Types -import GHC.ST -import GHC.IO -import qualified Data.List -import Foundation.Internal.Base -import Foundation.Internal.Proxy -import Foundation.Internal.Primitive -import Foundation.System.Bindings.Hs (sysHsMemcmpBaBa) -import Foundation.Primitive.Types.OffsetSize -import Foundation.Primitive.Monad -import Foundation.Primitive.NormalForm -import Foundation.Numerical -import Foundation.Primitive.Types - --- | A block of memory containing unpacked bytes representing values of type 'ty' -data Block ty = Block ByteArray# - deriving (Typeable) - -instance Data ty => Data (Block ty) where - dataTypeOf _ = blockType - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - -blockType :: DataType -blockType = mkNoRepType "Foundation.Block" - -instance NormalForm (Block ty) where - toNormalForm (Block !_) = () -instance (PrimType ty, Show ty) => Show (Block ty) where - show v = show (toList v) -instance (PrimType ty, Eq ty) => Eq (Block ty) where - {-# SPECIALIZE instance Eq (Block Word8) #-} - (==) = equal -instance (PrimType ty, Ord ty) => Ord (Block ty) where - compare = internalCompare - -instance PrimType ty => Monoid (Block ty) where - mempty = empty - mappend = append - mconcat = concat - -instance PrimType ty => IsList (Block ty) where - type Item (Block ty) = ty - fromList = internalFromList - toList = internalToList - -length :: forall ty . PrimType ty => Block ty -> CountOf ty -length (Block ba) = - case primShiftToBytes (Proxy :: Proxy ty) of - 0 -> CountOf (I# (sizeofByteArray# ba)) - (I# szBits) -> CountOf (I# (uncheckedIShiftRL# (sizeofByteArray# ba) szBits)) -{-# INLINE[1] length #-} -{-# SPECIALIZE [2] length :: Block Word8 -> CountOf Word8 #-} - -lengthBytes :: Block ty -> CountOf Word8 -lengthBytes (Block ba) = CountOf (I# (sizeofByteArray# ba)) -{-# INLINE[1] lengthBytes #-} - --- | Create an empty block of memory -empty :: Block ty -empty = Block ba where !(Block ba) = empty_ - -empty_ :: Block () -empty_ = runST $ primitive $ \s1 -> - case newByteArray# 0# s1 of { (# s2, mba #) -> - case unsafeFreezeByteArray# mba s2 of { (# s3, ba #) -> - (# s3, Block ba #) }} - -mutableEmpty :: PrimMonad prim => prim (MutableBlock ty (PrimState prim)) -mutableEmpty = primitive $ \s1 -> - case newByteArray# 0# s1 of { (# s2, mba #) -> - (# s2, MutableBlock mba #) } - --- | Return the element at a specific index from an array without bounds checking. --- --- Reading from invalid memory can return unpredictable and invalid values. --- use 'index' if unsure. -unsafeIndex :: forall ty . PrimType ty => Block ty -> Offset ty -> ty -unsafeIndex (Block ba) n = primBaIndex ba n -{-# SPECIALIZE unsafeIndex :: Block Word8 -> Offset Word8 -> Word8 #-} -{-# INLINE unsafeIndex #-} - --- | make a block from a list of elements. -internalFromList :: PrimType ty => [ty] -> Block ty -internalFromList l = runST $ do - ma <- new (CountOf len) - iter azero l $ \i x -> unsafeWrite ma i x - unsafeFreeze ma - where len = Data.List.length l - iter _ [] _ = return () - iter !i (x:xs) z = z i x >> iter (i+1) xs z - --- | transform a block to a list. -internalToList :: forall ty . PrimType ty => Block ty -> [ty] -internalToList blk@(Block ba) - | len == azero = [] - | otherwise = loop azero - where - !len = length blk - loop !i | i .==# len = [] - | otherwise = primBaIndex ba i : loop (i+1) - --- | Check if two blocks are identical -equal :: (PrimType ty, Eq ty) => Block ty -> Block ty -> Bool -equal a b - | la /= lb = False - | otherwise = loop azero - where - !la = lengthBytes a - !lb = lengthBytes b - lat = length a - - loop !n | n .==# lat = True - | otherwise = (unsafeIndex a n == unsafeIndex b n) && loop (n+o1) - o1 = Offset (I# 1#) -{-# RULES "Block/Eq/Word8" [3] - forall (a :: Block Word8) b . equal a b = equalMemcmp a b #-} -{-# INLINEABLE [2] equal #-} --- {-# SPECIALIZE equal :: Block Word8 -> Block Word8 -> Bool #-} - -equalMemcmp :: PrimMemoryComparable ty => Block ty -> Block ty -> Bool -equalMemcmp b1@(Block a) b2@(Block b) - | la /= lb = False - | otherwise = unsafeDupablePerformIO (sysHsMemcmpBaBa a 0 b 0 la) == 0 - where - la = lengthBytes b1 - lb = lengthBytes b2 -{-# SPECIALIZE equalMemcmp :: Block Word8 -> Block Word8 -> Bool #-} - --- | Compare 2 blocks -internalCompare :: (Ord ty, PrimType ty) => Block ty -> Block ty -> Ordering -internalCompare a b = loop azero - where - !la = length a - !lb = length b - !end = sizeAsOffset (min la lb) - loop !n - | n == end = la `compare` lb - | v1 == v2 = loop (n + Offset (I# 1#)) - | otherwise = v1 `compare` v2 - where - v1 = unsafeIndex a n - v2 = unsafeIndex b n -{-# RULES "Block/Ord/Word8" [3] forall (a :: Block Word8) b . internalCompare a b = compareMemcmp a b #-} -{-# NOINLINE internalCompare #-} - -compareMemcmp :: PrimMemoryComparable ty => Block ty -> Block ty -> Ordering -compareMemcmp b1@(Block a) b2@(Block b) = - case unsafeDupablePerformIO (sysHsMemcmpBaBa a 0 b 0 sz) of - 0 -> la `compare` lb - n | n > 0 -> GT - | otherwise -> LT - where - la = lengthBytes b1 - lb = lengthBytes b2 - sz = min la lb -{-# SPECIALIZE [3] compareMemcmp :: Block Word8 -> Block Word8 -> Ordering #-} - --- | Append 2 blocks together by creating a new bigger block -append :: Block ty -> Block ty -> Block ty -append a b - | la == azero = b - | lb == azero = a - | otherwise = runST $ do - r <- unsafeNew Unpinned (la+lb) - unsafeCopyBytesRO r 0 a 0 la - unsafeCopyBytesRO r (sizeAsOffset la) b 0 lb - unsafeFreeze r - where - !la = lengthBytes a - !lb = lengthBytes b - -concat :: [Block ty] -> Block ty -concat [] = empty -concat l = - case filterAndSum 0 [] l of - (_,[]) -> empty - (_,[x]) -> x - (totalLen,chunks) -> runST $ do - r <- unsafeNew Unpinned totalLen - doCopy r 0 chunks - unsafeFreeze r - where - -- TODO would go faster not to reverse but pack from the end instead - filterAndSum !totalLen acc [] = (totalLen, Data.List.reverse acc) - filterAndSum !totalLen acc (x:xs) - | len == 0 = filterAndSum totalLen acc xs - | otherwise = filterAndSum (len+totalLen) (x:acc) xs - where len = lengthBytes x - - doCopy _ _ [] = return () - doCopy r i (x:xs) = do - unsafeCopyBytesRO r i x 0 lx - doCopy r (i `offsetPlusE` lx) xs - where !lx = lengthBytes x - --- | A Mutable block of memory containing unpacked bytes representing values of type 'ty' -data MutableBlock ty st = MutableBlock (MutableByteArray# st) - --- | Freeze a mutable block into a block. --- --- If the mutable block is still use after freeze, --- then the modification will be reflected in an unexpected --- way in the Block. -unsafeFreeze :: PrimMonad prim => MutableBlock ty (PrimState prim) -> prim (Block ty) -unsafeFreeze (MutableBlock mba) = primitive $ \s1 -> - case unsafeFreezeByteArray# mba s1 of - (# s2, ba #) -> (# s2, Block ba #) -{-# INLINE unsafeFreeze #-} - --- | Thaw an immutable block. --- --- If the immutable block is modified, then the original immutable block will --- be modified too, but lead to unexpected results when querying -unsafeThaw :: (PrimType ty, PrimMonad prim) => Block ty -> prim (MutableBlock ty (PrimState prim)) -unsafeThaw (Block ba) = primitive $ \st -> (# st, MutableBlock (unsafeCoerce# ba) #) - --- | Create a new mutable block of a specific size in bytes. --- --- Note that no checks are made to see if the size in bytes is compatible with the size --- of the underlaying element 'ty' in the block. --- --- use 'new' if unsure -unsafeNew :: PrimMonad prim - => PinnedStatus - -> CountOf Word8 - -> prim (MutableBlock ty (PrimState prim)) -unsafeNew pinSt (CountOf (I# bytes)) = case pinSt of - Unpinned -> primitive $ \s1 -> case newByteArray# bytes s1 of { (# s2, mba #) -> (# s2, MutableBlock mba #) } - _ -> primitive $ \s1 -> case newAlignedPinnedByteArray# bytes 8# s1 of { (# s2, mba #) -> (# s2, MutableBlock mba #) } - --- | Create a new mutable block of a specific N size of 'ty' elements -new :: forall prim ty . (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MutableBlock ty (PrimState prim)) -new n = unsafeNew Unpinned (sizeOfE (primSizeInBytes (Proxy :: Proxy ty)) n) - -newPinned :: forall prim ty . (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MutableBlock ty (PrimState prim)) -newPinned n = unsafeNew Pinned (sizeOfE (primSizeInBytes (Proxy :: Proxy ty)) n) - --- | Copy a number of elements from an array to another array with offsets -unsafeCopyElements :: forall prim ty . (PrimMonad prim, PrimType ty) - => MutableBlock ty (PrimState prim) -- ^ destination mutable block - -> Offset ty -- ^ offset at destination - -> MutableBlock ty (PrimState prim) -- ^ source mutable block - -> Offset ty -- ^ offset at source - -> CountOf ty -- ^ number of elements to copy - -> prim () -unsafeCopyElements dstMb destOffset srcMb srcOffset n = -- (MutableBlock dstMba) ed (MutableBlock srcBa) es n = - unsafeCopyBytes dstMb (offsetOfE sz destOffset) - srcMb (offsetOfE sz srcOffset) - (sizeOfE sz n) - where - !sz = primSizeInBytes (Proxy :: Proxy ty) - -unsafeCopyElementsRO :: forall prim ty . (PrimMonad prim, PrimType ty) - => MutableBlock ty (PrimState prim) -- ^ destination mutable block - -> Offset ty -- ^ offset at destination - -> Block ty -- ^ source block - -> Offset ty -- ^ offset at source - -> CountOf ty -- ^ number of elements to copy - -> prim () -unsafeCopyElementsRO dstMb destOffset srcMb srcOffset n = - unsafeCopyBytesRO dstMb (offsetOfE sz destOffset) - srcMb (offsetOfE sz srcOffset) - (sizeOfE sz n) - where - !sz = primSizeInBytes (Proxy :: Proxy ty) - --- | Copy a number of bytes from a MutableBlock to another MutableBlock with specific byte offsets -unsafeCopyBytes :: forall prim ty . PrimMonad prim - => MutableBlock ty (PrimState prim) -- ^ destination mutable block - -> Offset Word8 -- ^ offset at destination - -> MutableBlock ty (PrimState prim) -- ^ source mutable block - -> Offset Word8 -- ^ offset at source - -> CountOf Word8 -- ^ number of elements to copy - -> prim () -unsafeCopyBytes (MutableBlock dstMba) (Offset (I# d)) (MutableBlock srcBa) (Offset (I# s)) (CountOf (I# n)) = - primitive $ \st -> (# copyMutableByteArray# srcBa s dstMba d n st, () #) -{-# INLINE unsafeCopyBytes #-} - --- | Copy a number of bytes from a Block to a MutableBlock with specific byte offsets -unsafeCopyBytesRO :: forall prim ty . PrimMonad prim - => MutableBlock ty (PrimState prim) -- ^ destination mutable block - -> Offset Word8 -- ^ offset at destination - -> Block ty -- ^ source block - -> Offset Word8 -- ^ offset at source - -> CountOf Word8 -- ^ number of elements to copy - -> prim () -unsafeCopyBytesRO (MutableBlock dstMba) (Offset (I# d)) (Block srcBa) (Offset (I# s)) (CountOf (I# n)) = - primitive $ \st -> (# copyByteArray# srcBa s dstMba d n st, () #) -{-# INLINE unsafeCopyBytesRO #-} - --- | read from a cell in a mutable block without bounds checking. --- --- Reading from invalid memory can return unpredictable and invalid values. --- use 'read' if unsure. -unsafeRead :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> Offset ty -> prim ty -unsafeRead (MutableBlock mba) i = primMbaRead mba i -{-# INLINE unsafeRead #-} - --- | write to a cell in a mutable block without bounds checking. --- --- Writing with invalid bounds will corrupt memory and your program will --- become unreliable. use 'write' if unsure. -unsafeWrite :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> Offset ty -> ty -> prim () -unsafeWrite (MutableBlock mba) i v = primMbaWrite mba i v -{-# INLINE unsafeWrite #-} - -touch :: PrimMonad prim => Block ty -> prim () -touch (Block ba) = unsafePrimFromIO $ primitive $ \s -> case touch# ba s of { s2 -> (# s2, () #) } - -mutableTouch :: PrimMonad prim => MutableBlock ty (PrimState prim) -> prim () -mutableTouch (MutableBlock mba) = unsafePrimFromIO $ primitive $ \s -> case touch# mba s of { s2 -> (# s2, () #) } - diff --git a/Foundation/Primitive/Block/Mutable.hs b/Foundation/Primitive/Block/Mutable.hs deleted file mode 100644 --- a/Foundation/Primitive/Block/Mutable.hs +++ /dev/null @@ -1,124 +0,0 @@ --- | --- Module : Foundation.Primitive.Block.Mutable --- License : BSD-style --- Maintainer : Haskell Foundation --- --- A block of memory that contains elements of a type, --- very similar to an unboxed array but with the key difference: --- --- * It doesn't have slicing capability (no cheap take or drop) --- * It consume less memory: 1 Offset, 1 CountOf, 1 Pinning status trimmed --- * It's unpackable in any constructor --- * It uses unpinned memory by default --- --- It should be rarely needed in high level API, but --- in lowlevel API or some data structure containing lots --- of unboxed array that will benefit from optimisation. --- --- Because it's unpinned, the blocks are compactable / movable, --- at the expense of making them less friendly to C layer / address. --- --- Note that sadly the bytearray primitive type automatically create --- a pinned bytearray if the size is bigger than a certain threshold --- --- GHC Documentation associated: --- --- includes/rts/storage/Block.h --- * LARGE_OBJECT_THRESHOLD ((uint32_t)(BLOCK_SIZE * 8 / 10)) --- * BLOCK_SIZE (1< MutableBlock ty st -> CountOf ty -mutableLengthSize (MutableBlock mba) = - let !(CountOf (I# szBits)) = primSizeInBytes (Proxy :: Proxy ty) - !elems = quotInt# (sizeofMutableByteArray# mba) szBits - in CountOf (I# elems) -{-# INLINE[1] mutableLengthSize #-} - -mutableLengthBytes :: MutableBlock ty st -> CountOf Word8 -mutableLengthBytes (MutableBlock mba) = CountOf (I# (sizeofMutableByteArray# mba)) -{-# INLINE[1] mutableLengthBytes #-} - --- | Get the address of the context of the mutable block. --- --- if the block is not pinned, this is a _dangerous_ operation -mutableGetAddr :: PrimMonad prim => MutableBlock ty (PrimState prim) -> prim (Ptr ty) -mutableGetAddr (MutableBlock mba) = primitive $ \s1 -> - case unsafeFreezeByteArray# mba s1 of - (# s2, ba #) -> (# s2, Ptr (byteArrayContents# ba) #) - --- | Set all mutable block element to a value -iterSet :: (PrimType ty, PrimMonad prim) - => (Offset ty -> ty) - -> MutableBlock ty (PrimState prim) - -> prim () -iterSet f ma = loop 0 - where - !sz = mutableLengthSize ma - loop i - | i .==# sz = pure () - | otherwise = unsafeWrite ma i (f i) >> loop (i+1) - {-# INLINE loop #-} - --- | read a cell in a mutable array. --- --- If the index is out of bounds, an error is raised. -read :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> Offset ty -> prim ty -read array n - | isOutOfBound n len = primOutOfBound OOB_Read n len - | otherwise = unsafeRead array n - where len = mutableLengthSize array -{-# INLINE read #-} - --- | Write to a cell in a mutable array. --- --- If the index is out of bounds, an error is raised. -write :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> Offset ty -> ty -> prim () -write array n val - | isOutOfBound n len = primOutOfBound OOB_Write n len - | otherwise = unsafeWrite array n val - where - len = mutableLengthSize array -{-# INLINE write #-} diff --git a/Foundation/Primitive/BlockN.hs b/Foundation/Primitive/BlockN.hs deleted file mode 100644 --- a/Foundation/Primitive/BlockN.hs +++ /dev/null @@ -1,136 +0,0 @@ --- | --- Module : Foundation.Primitive.Block --- License : BSD-style --- Maintainer : Haskell Foundation --- --- A Nat-sized version of Block -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Foundation.Primitive.BlockN - ( BlockN - , MutableBlockN - , toBlockN - , toBlock - , singleton - , replicate - , thaw - , freeze - , index - , map - , foldl' - , foldr - , cons - , snoc - , elem - , sub - , uncons - , unsnoc - , splitAt - , all - , any - , find - , reverse - , sortBy - , intersperse - ) -where - -import Data.Proxy (Proxy(..)) -import Foundation.Internal.Base -import Foundation.Primitive.Block (Block, MutableBlock(..), unsafeIndex) -import qualified Foundation.Primitive.Block as B -import Foundation.Primitive.Monad (PrimMonad, PrimState) -import Foundation.Primitive.Nat -import Foundation.Primitive.NormalForm -import Foundation.Primitive.Types (PrimType) -import Foundation.Primitive.Types.OffsetSize (CountOf(..), Offset(..)) - -newtype BlockN (n :: Nat) a = BlockN { unBlock :: Block a } deriving (NormalForm, Eq, Show) - -newtype MutableBlockN (n :: Nat) ty st = MutableBlockN { unMBlock :: MutableBlock ty st } - -toBlockN :: forall n ty . (PrimType ty, KnownNat n, NatWithinBound Int n) => Block ty -> Maybe (BlockN n ty) -toBlockN b - | expected == B.length b = Just (BlockN b) - | otherwise = Nothing - where - expected = toCount @n - -toBlock :: BlockN n ty -> Block ty -toBlock = unBlock - -singleton :: PrimType ty => ty -> BlockN 1 ty -singleton a = BlockN (B.singleton a) - -replicate :: forall n ty . (KnownNat n, NatWithinBound Int n, PrimType ty) => ty -> BlockN n ty -replicate a = BlockN (B.replicate (toCount @n) a) - -thaw :: (KnownNat n, PrimMonad prim, PrimType ty) => BlockN n ty -> prim (MutableBlockN n ty (PrimState prim)) -thaw b = MutableBlockN <$> B.thaw (unBlock b) - -freeze :: (PrimMonad prim, PrimType ty, NatWithinBound Int n) => MutableBlockN n ty (PrimState prim) -> prim (BlockN n ty) -freeze b = BlockN <$> B.freeze (unMBlock b) - -index :: forall i n ty . (KnownNat i, CmpNat i n ~ 'LT, PrimType ty, NatWithinBound Int i) => BlockN n ty -> ty -index b = unsafeIndex (unBlock b) (toOffset @i) - -map :: (PrimType a, PrimType b) => (a -> b) -> BlockN n a -> BlockN n b -map f b = BlockN (B.map f (unBlock b)) - -foldl' :: PrimType ty => (a -> ty -> a) -> a -> BlockN n ty -> a -foldl' f acc b = B.foldl' f acc (unBlock b) - -foldr :: PrimType ty => (ty -> a -> a) -> a -> BlockN n ty -> a -foldr f acc b = B.foldr f acc (unBlock b) - -cons :: PrimType ty => ty -> BlockN n ty -> BlockN (n+1) ty -cons e = BlockN . B.cons e . unBlock - -snoc :: PrimType ty => BlockN n ty -> ty -> BlockN (n+1) ty -snoc b = BlockN . B.snoc (unBlock b) - -sub :: forall i j n ty . ((i <=? n) ~ 'True, (j <=? n) ~ 'True, (i <=? j) ~ 'True, PrimType ty, KnownNat i, NatWithinBound Int i, KnownNat j, NatWithinBound Int j) => BlockN n ty -> BlockN (j-i) ty -sub block = BlockN (B.sub (unBlock block) (toOffset @i) (toOffset @j)) - -uncons :: forall n ty . (CmpNat 0 n ~ 'LT, PrimType ty, KnownNat n, NatWithinBound Int n) => BlockN n ty -> (ty, BlockN (n-1) ty) -uncons b = (index @0 b, BlockN (B.sub (unBlock b) 1 (toOffset @n))) - -unsnoc :: forall n ty . (CmpNat 0 n ~ 'LT, KnownNat n, PrimType ty, NatWithinBound Int n) => BlockN n ty -> (BlockN (n-1) ty, ty) -unsnoc b = (BlockN (B.sub (unBlock b) 0 (toOffset @n)), undefined) - -splitAt :: forall i n ty . (CmpNat i n ~ 'LT, PrimType ty, KnownNat i, NatWithinBound Int i) => BlockN n ty -> (BlockN i ty, BlockN (n-i) ty) -splitAt b = - let (left, right) = B.splitAt (toCount @i) (unBlock b) - in (BlockN left, BlockN right) - -elem :: PrimType ty => ty -> BlockN n ty -> Bool -elem e b = B.elem e (unBlock b) - -all :: PrimType ty => (ty -> Bool) -> BlockN n ty -> Bool -all p b = B.all p (unBlock b) - -any :: PrimType ty => (ty -> Bool) -> BlockN n ty -> Bool -any p b = B.any p (unBlock b) - -find :: PrimType ty => (ty -> Bool) -> BlockN n ty -> Maybe ty -find p b = B.find p (unBlock b) - -reverse :: PrimType ty => BlockN n ty -> BlockN n ty -reverse = BlockN . B.reverse . unBlock - -sortBy :: PrimType ty => (ty -> ty -> Ordering) -> BlockN n ty -> BlockN n ty -sortBy f b = BlockN (B.sortBy f (unBlock b)) - -intersperse :: (CmpNat n 1 ~ 'GT, PrimType ty) => ty -> BlockN n ty -> BlockN (n+n-1) ty -intersperse sep b = BlockN (B.intersperse sep (unBlock b)) - -toCount :: forall n ty . (KnownNat n, NatWithinBound Int n) => CountOf ty -toCount = CountOf (natValInt (Proxy @n)) - -toOffset :: forall n ty . (KnownNat n, NatWithinBound Int n) => Offset ty -toOffset = Offset (natValInt (Proxy @n)) diff --git a/Foundation/Primitive/Endianness.hs b/Foundation/Primitive/Endianness.hs deleted file mode 100644 --- a/Foundation/Primitive/Endianness.hs +++ /dev/null @@ -1,129 +0,0 @@ --- | --- Module : Foundation.Primitive.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 Foundation.Primitive.Endianness - ( - ByteSwap - -- * Big Endian - , BE(..), toBE, fromBE - -- * Little Endian - , LE(..), toLE, fromLE - -- * System Endianness - , Endianness(..) - , endianness - ) where - -import Foundation.Internal.Base -import Foundation.Internal.ByteSwap - -#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 diff --git a/Foundation/Primitive/Error.hs b/Foundation/Primitive/Error.hs deleted file mode 100644 --- a/Foundation/Primitive/Error.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE CPP #-} -module Foundation.Primitive.Error - ( error - ) where - -import GHC.Prim -import Foundation.Primitive.UTF8.Base -import Foundation.Internal.CallStack - -#if MIN_VERSION_base(4,9,0) - -import GHC.Types (RuntimeRep) -import GHC.Exception (errorCallWithCallStackException) - --- | stop execution and displays an error message -error :: forall (r :: RuntimeRep) . forall (a :: TYPE r) . HasCallStack => String -> a -error s = raise# (errorCallWithCallStackException (sToList s) ?callstack) - -#elif MIN_VERSION_base(4,7,0) - -import GHC.Exception (errorCallException) - -error :: String -> a -error s = raise# (errorCallException (sToList s)) - -#else - -import GHC.Types -import GHC.Exception - -error :: String -> a -error s = throw (ErrorCall (sToList s)) - -#endif diff --git a/Foundation/Primitive/Exception.hs b/Foundation/Primitive/Exception.hs deleted file mode 100644 --- a/Foundation/Primitive/Exception.hs +++ /dev/null @@ -1,62 +0,0 @@ --- | --- Module : Foundation.Primitive.Exception --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : portable --- --- Common part for vectors --- -{-# LANGUAGE DeriveDataTypeable #-} -module Foundation.Primitive.Exception - ( OutOfBound(..) - , OutOfBoundOperation(..) - , isOutOfBound - , outOfBound - , primOutOfBound - , InvalidRecast(..) - , RecastSourceSize(..) - , RecastDestinationSize(..) - ) where - -import Foundation.Internal.Base -import Foundation.Primitive.Types.OffsetSize -import Foundation.Primitive.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 diff --git a/Foundation/Primitive/FinalPtr.hs b/Foundation/Primitive/FinalPtr.hs deleted file mode 100644 --- a/Foundation/Primitive/FinalPtr.hs +++ /dev/null @@ -1,112 +0,0 @@ --- | --- Module : Foundation.Primitive.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 Foundation.Primitive.FinalPtr - ( FinalPtr(..) - , finalPtrSameMemory - , castFinalPtr - , toFinalPtr - , toFinalPtrForeign - , touchFinalPtr - , withFinalPtr - , withUnsafeFinalPtr - , withFinalPtrNoTouch - ) where - -import GHC.Ptr -import GHC.ForeignPtr -import GHC.IO -import Foundation.Primitive.Monad -import Foundation.Internal.Primitive -import Foundation.Internal.Base - -import Control.Monad.ST (runST) - --- | Create a pointer with an associated finalizer -data FinalPtr a = FinalPtr (Ptr a) - | FinalForeign (ForeignPtr a) -instance Show (FinalPtr a) where - show f = runST $ withFinalPtr f (pure . show) -instance Eq (FinalPtr a) where - (==) f1 f2 = runST (equal f1 f2) -instance Ord (FinalPtr a) where - compare f1 f2 = runST (compare_ f1 f2) - --- | Check if 2 final ptr points on the same memory bits --- --- it stand to reason that provided a final ptr that is still being referenced --- and thus have the memory still valid, if 2 final ptrs have the --- same address, they should be the same final ptr -finalPtrSameMemory :: FinalPtr a -> FinalPtr b -> Bool -finalPtrSameMemory (FinalPtr p1) (FinalPtr p2) = p1 == castPtr p2 -finalPtrSameMemory (FinalForeign p1) (FinalForeign p2) = p1 == castForeignPtr p2 -finalPtrSameMemory (FinalForeign _) (FinalPtr _) = False -finalPtrSameMemory (FinalPtr _) (FinalForeign _) = False - --- | create a new FinalPtr from a Pointer -toFinalPtr :: PrimMonad prim => Ptr a -> (Ptr a -> IO ()) -> prim (FinalPtr a) -toFinalPtr ptr finalizer = unsafePrimFromIO (primitive makeWithFinalizer) - where - makeWithFinalizer s = - case compatMkWeak# ptr () (finalizer ptr) s of { (# s2, _ #) -> (# s2, FinalPtr ptr #) } - --- | Create a new FinalPtr from a ForeignPtr -toFinalPtrForeign :: ForeignPtr a -> FinalPtr a -toFinalPtrForeign fptr = FinalForeign fptr - --- | Cast a finalized pointer from type a to type b -castFinalPtr :: FinalPtr a -> FinalPtr b -castFinalPtr (FinalPtr a) = FinalPtr (castPtr a) -castFinalPtr (FinalForeign a) = FinalForeign (castForeignPtr a) - -withFinalPtrNoTouch :: FinalPtr p -> (Ptr p -> a) -> a -withFinalPtrNoTouch (FinalPtr ptr) f = f ptr -withFinalPtrNoTouch (FinalForeign fptr) f = f (unsafeForeignPtrToPtr fptr) -{-# INLINE withFinalPtrNoTouch #-} - --- | Looks at the raw pointer inside a FinalPtr, making sure the --- data pointed by the pointer is not finalized during the call to 'f' -withFinalPtr :: PrimMonad prim => FinalPtr p -> (Ptr p -> prim a) -> prim a -withFinalPtr (FinalPtr ptr) f = do - r <- f ptr - primTouch ptr - pure r -withFinalPtr (FinalForeign fptr) f = do - r <- f (unsafeForeignPtrToPtr fptr) - unsafePrimFromIO (touchForeignPtr fptr) - pure r -{-# INLINE withFinalPtr #-} - -touchFinalPtr :: PrimMonad prim => FinalPtr p -> prim () -touchFinalPtr (FinalPtr ptr) = primTouch ptr -touchFinalPtr (FinalForeign fptr) = unsafePrimFromIO (touchForeignPtr fptr) - --- | Unsafe version of 'withFinalPtr' -withUnsafeFinalPtr :: PrimMonad prim => FinalPtr p -> (Ptr p -> prim a) -> a -withUnsafeFinalPtr fptr f = unsafePerformIO (unsafePrimToIO (withFinalPtr fptr f)) -{-# NOINLINE withUnsafeFinalPtr #-} - -equal :: PrimMonad prim => FinalPtr a -> FinalPtr a -> prim Bool -equal f1 f2 = - withFinalPtr f1 $ \ptr1 -> - withFinalPtr f2 $ \ptr2 -> - pure $ ptr1 == ptr2 -{-# INLINE equal #-} - -compare_ :: PrimMonad prim => FinalPtr a -> FinalPtr a -> prim Ordering -compare_ f1 f2 = - withFinalPtr f1 $ \ptr1 -> - withFinalPtr f2 $ \ptr2 -> - pure $ ptr1 `compare` ptr2 -{-# INLINE compare_ #-} diff --git a/Foundation/Primitive/Floating.hs b/Foundation/Primitive/Floating.hs deleted file mode 100644 --- a/Foundation/Primitive/Floating.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Foundation.Primitive.Floating - ( integerToDouble - , naturalToDouble - , doubleExponant - , integerToFloat - , naturalToFloat - ) where - -import GHC.Types -import Foundation.Internal.Base -import Foundation.Internal.Natural -import qualified Prelude (fromInteger, toInteger, (^^)) - -integerToDouble :: Integer -> Double -integerToDouble = Prelude.fromInteger --- this depends on integer-gmp ---integerToDouble i = D# (doubleFromInteger i) - -naturalToDouble :: Natural -> Double -naturalToDouble = integerToDouble . Prelude.toInteger - -doubleExponant :: Double -> Int -> Double -doubleExponant = (Prelude.^^) - -integerToFloat :: Integer -> Float -integerToFloat = Prelude.fromInteger - -naturalToFloat :: Natural -> Float -naturalToFloat = integerToFloat . Prelude.toInteger diff --git a/Foundation/Primitive/Imports.hs b/Foundation/Primitive/Imports.hs deleted file mode 100644 --- a/Foundation/Primitive/Imports.hs +++ /dev/null @@ -1,105 +0,0 @@ --- | --- Module : Foundation.Primitive.Imports --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : portable --- --- re-export of all the base prelude and basic primitive stuffs -module Foundation.Primitive.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 - , Foundation.Primitive.Error.error - , Prelude.and - , Prelude.undefined - , Prelude.seq - , Prelude.Show - , Foundation.Primitive.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 - , Foundation.Internal.Natural.Natural - , Foundation.Primitive.Types.OffsetSize.Offset - , Foundation.Primitive.Types.OffsetSize.CountOf - , Prelude.Char - , Foundation.Primitive.UTF8.Base.String - , Foundation.Array.Unboxed.UArray - , Foundation.Array.Boxed.Array - , Foundation.Internal.NumLiteral.Integral (..) - , Foundation.Internal.NumLiteral.Fractional (..) - , Foundation.Internal.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 - , Foundation.Internal.IsList.IsList (..) - , GHC.Exts.IsString (..) - , GHC.Generics.Generic (..) - , Prelude.Either (..) - , Data.Data.Data (..) - , Data.Data.mkNoRepType - , Data.Data.DataType - , Data.Typeable.Typeable - , Data.Monoid.Monoid (..) - , (Data.Monoid.<>) - , Control.Exception.Exception - , Control.Exception.throw - , Control.Exception.throwIO - , GHC.Ptr.Ptr(..) - , ifThenElse - ) where - -import qualified Prelude -import qualified Control.Category -import qualified Control.Applicative -import qualified Control.Exception -import qualified Data.Monoid -import qualified Data.Data -import qualified Data.Typeable -import qualified Data.Word -import qualified Data.Int -import qualified Foundation.Internal.IsList -import qualified Foundation.Internal.Natural -import qualified Foundation.Internal.NumLiteral -import qualified Foundation.Array.Unboxed -import qualified Foundation.Array.Boxed -import qualified Foundation.Primitive.UTF8.Base -import qualified Foundation.Primitive.Error -import qualified Foundation.Primitive.Show -import qualified Foundation.Primitive.Types.OffsetSize -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 - -type FP32 = Prelude.Float -type FP64 = Prelude.Double diff --git a/Foundation/Primitive/IntegralConv.hs b/Foundation/Primitive/IntegralConv.hs deleted file mode 100644 --- a/Foundation/Primitive/IntegralConv.hs +++ /dev/null @@ -1,326 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UnboxedTuples #-} -module Foundation.Primitive.IntegralConv - ( IntegralDownsize(..) - , IntegralUpsize(..) - , IntegralCast(..) - , intToInt64 - , int64ToInt - , wordToWord64 - , word64ToWord32s - , word64ToWord - , wordToChar - , wordToInt - , charToInt - ) where - -#include "MachDeps.h" - -import GHC.Types -import GHC.Prim -import GHC.Int -import GHC.Word -import Prelude (Integer, fromIntegral) -import Foundation.Internal.Base -import Foundation.Internal.Natural - -#if WORD_SIZE_IN_BITS < 64 -import GHC.IntWord64 -#endif - --- | Downsize an integral value -class IntegralDownsize a b where - integralDownsize :: a -> b - default integralDownsize :: a ~ b => a -> b - integralDownsize = id - - integralDownsizeCheck :: a -> Maybe b - --- | Upsize an integral value --- --- The destination type 'b' size need to be greater or equal --- than the size type of 'a' -class IntegralUpsize a b where - integralUpsize :: a -> b - --- | Cast an integral value to another value --- that have the same representional size -class IntegralCast a b where - integralCast :: a -> b - default integralCast :: a ~ b => a -> b - integralCast = id - -integralDownsizeBounded :: forall a b . (Ord a, Bounded b, IntegralDownsize a b, IntegralUpsize b a) - => (a -> b) - -> a - -> Maybe b -integralDownsizeBounded aToB x - | x < integralUpsize (minBound :: b) && x > integralUpsize (maxBound :: b) = Nothing - | otherwise = Just (aToB x) - -instance IntegralUpsize Int8 Int16 where - integralUpsize (I8# i) = I16# i -instance IntegralUpsize Int8 Int32 where - integralUpsize (I8# i) = I32# i -instance IntegralUpsize Int8 Int64 where - integralUpsize (I8# i) = intToInt64 (I# i) -instance IntegralUpsize Int8 Int where - integralUpsize (I8# i) = I# i -instance IntegralUpsize Int8 Integer where - integralUpsize = fromIntegral - -instance IntegralUpsize Int16 Int32 where - integralUpsize (I16# i) = I32# i -instance IntegralUpsize Int16 Int64 where - integralUpsize (I16# i) = intToInt64 (I# i) -instance IntegralUpsize Int16 Int where - integralUpsize (I16# i) = I# i -instance IntegralUpsize Int16 Integer where - integralUpsize = fromIntegral - -instance IntegralUpsize Int32 Int64 where - integralUpsize (I32# i) = intToInt64 (I# i) -instance IntegralUpsize Int32 Int where - integralUpsize (I32# i) = I# i -instance IntegralUpsize Int32 Integer where - integralUpsize = fromIntegral - -instance IntegralUpsize Int Integer where - integralUpsize = fromIntegral -instance IntegralUpsize Int Int64 where - integralUpsize = intToInt64 - -instance IntegralUpsize Int64 Integer where - integralUpsize = fromIntegral - -instance IntegralUpsize Word8 Word16 where - integralUpsize (W8# i) = W16# i -instance IntegralUpsize Word8 Word32 where - integralUpsize (W8# i) = W32# i -instance IntegralUpsize Word8 Word64 where - integralUpsize (W8# i) = wordToWord64 (W# i) -instance IntegralUpsize Word8 Word where - integralUpsize (W8# i) = W# i -instance IntegralUpsize Word8 Int16 where - integralUpsize (W8# w) = I16# (word2Int# w) -instance IntegralUpsize Word8 Int32 where - integralUpsize (W8# w) = I32# (word2Int# w) -instance IntegralUpsize Word8 Int64 where - integralUpsize (W8# w) = intToInt64 (I# (word2Int# w)) -instance IntegralUpsize Word8 Int where - integralUpsize (W8# w) = I# (word2Int# w) -instance IntegralUpsize Word8 Integer where - integralUpsize = fromIntegral -instance IntegralUpsize Word8 Natural where - integralUpsize = fromIntegral - -instance IntegralUpsize Word16 Word32 where - integralUpsize (W16# i) = W32# i -instance IntegralUpsize Word16 Word64 where - integralUpsize (W16# i) = wordToWord64 (W# i) -instance IntegralUpsize Word16 Word where - integralUpsize (W16# i) = W# i -instance IntegralUpsize Word16 Integer where - integralUpsize = fromIntegral -instance IntegralUpsize Word16 Natural where - integralUpsize = fromIntegral - -instance IntegralUpsize Word32 Word64 where - integralUpsize (W32# i) = wordToWord64 (W# i) -instance IntegralUpsize Word32 Word where - integralUpsize (W32# i) = W# i -instance IntegralUpsize Word32 Integer where - integralUpsize = fromIntegral -instance IntegralUpsize Word32 Natural where - integralUpsize = fromIntegral - -instance IntegralUpsize Word Integer where - integralUpsize = fromIntegral -instance IntegralUpsize Word Natural where - integralUpsize = fromIntegral -instance IntegralUpsize Word Word64 where - integralUpsize = wordToWord64 - -instance IntegralUpsize Word64 Integer where - integralUpsize = fromIntegral -instance IntegralUpsize Word64 Natural where - integralUpsize = fromIntegral - -instance IntegralUpsize Natural Integer where - integralUpsize = fromIntegral - -instance IntegralDownsize Int Int8 where - integralDownsize (I# i) = I8# (narrow8Int# i) - integralDownsizeCheck = integralDownsizeBounded integralDownsize -instance IntegralDownsize Int Int16 where - integralDownsize (I# i) = I16# (narrow16Int# i) - integralDownsizeCheck = integralDownsizeBounded integralDownsize -instance IntegralDownsize Int Int32 where - integralDownsize (I# i) = I32# (narrow32Int# i) - integralDownsizeCheck = integralDownsizeBounded integralDownsize - -instance IntegralDownsize Int64 Int8 where - integralDownsize i = integralDownsize (int64ToInt i) - integralDownsizeCheck = integralDownsizeBounded integralDownsize -instance IntegralDownsize Int64 Int16 where - integralDownsize i = integralDownsize (int64ToInt i) - integralDownsizeCheck = integralDownsizeBounded integralDownsize -instance IntegralDownsize Int64 Int32 where - integralDownsize i = integralDownsize (int64ToInt i) - integralDownsizeCheck = integralDownsizeBounded integralDownsize -instance IntegralDownsize Int64 Int where - integralDownsize i = int64ToInt i - integralDownsizeCheck = integralDownsizeBounded integralDownsize - -instance IntegralDownsize Word64 Word8 where - integralDownsize (W64# i) = W8# (narrow8Word# (word64ToWord# i)) - integralDownsizeCheck = integralDownsizeBounded integralDownsize -instance IntegralDownsize Word64 Word16 where - integralDownsize (W64# i) = W16# (narrow16Word# (word64ToWord# i)) - integralDownsizeCheck = integralDownsizeBounded integralDownsize -instance IntegralDownsize Word64 Word32 where - integralDownsize (W64# i) = W32# (narrow32Word# (word64ToWord# i)) - integralDownsizeCheck = integralDownsizeBounded integralDownsize - -instance IntegralDownsize Word Word8 where - integralDownsize (W# w) = W8# (narrow8Word# w) - integralDownsizeCheck = integralDownsizeBounded integralDownsize -instance IntegralDownsize Word Word16 where - integralDownsize (W# w) = W16# (narrow16Word# w) - integralDownsizeCheck = integralDownsizeBounded integralDownsize -instance IntegralDownsize Word Word32 where - integralDownsize (W# w) = W32# (narrow32Word# w) - integralDownsizeCheck = integralDownsizeBounded integralDownsize - -instance IntegralDownsize Word32 Word8 where - integralDownsize (W32# i) = W8# (narrow8Word# i) - integralDownsizeCheck = integralDownsizeBounded integralDownsize -instance IntegralDownsize Word32 Word16 where - integralDownsize (W32# i) = W16# (narrow16Word# i) - integralDownsizeCheck = integralDownsizeBounded integralDownsize - -instance IntegralDownsize Word16 Word8 where - integralDownsize (W16# i) = W8# (narrow8Word# i) - integralDownsizeCheck = integralDownsizeBounded integralDownsize - -instance IntegralDownsize Integer Int8 where - integralDownsize = fromIntegral - integralDownsizeCheck = integralDownsizeBounded integralDownsize -instance IntegralDownsize Integer Int16 where - integralDownsize = fromIntegral - integralDownsizeCheck = integralDownsizeBounded integralDownsize -instance IntegralDownsize Integer Int32 where - integralDownsize = fromIntegral - integralDownsizeCheck = integralDownsizeBounded integralDownsize -instance IntegralDownsize Integer Int64 where - integralDownsize = fromIntegral - integralDownsizeCheck = integralDownsizeBounded integralDownsize - -instance IntegralDownsize Integer Word8 where - integralDownsize = fromIntegral - integralDownsizeCheck = integralDownsizeBounded integralDownsize -instance IntegralDownsize Integer Word16 where - integralDownsize = fromIntegral - integralDownsizeCheck = integralDownsizeBounded integralDownsize -instance IntegralDownsize Integer Word32 where - integralDownsize = fromIntegral - integralDownsizeCheck = integralDownsizeBounded integralDownsize -instance IntegralDownsize Integer Word64 where - integralDownsize = fromIntegral - integralDownsizeCheck = integralDownsizeBounded integralDownsize -instance IntegralDownsize Integer Natural where - integralDownsize i - | i >= 0 = fromIntegral i - | otherwise = 0 - integralDownsizeCheck i - | i >= 0 = Just (fromIntegral i) - | otherwise = Nothing - -instance IntegralDownsize Natural Word8 where - integralDownsize = fromIntegral - integralDownsizeCheck = integralDownsizeBounded integralDownsize -instance IntegralDownsize Natural Word16 where - integralDownsize = fromIntegral - integralDownsizeCheck = integralDownsizeBounded integralDownsize -instance IntegralDownsize Natural Word32 where - integralDownsize = fromIntegral - integralDownsizeCheck = integralDownsizeBounded integralDownsize -instance IntegralDownsize Natural Word64 where - integralDownsize = fromIntegral - integralDownsizeCheck = integralDownsizeBounded integralDownsize - -instance IntegralCast Word Int where - integralCast (W# w) = I# (word2Int# w) -instance IntegralCast Int Word where - integralCast (I# i) = W# (int2Word# i) -instance IntegralCast Word64 Int64 where -#if WORD_SIZE_IN_BITS == 64 - integralCast (W64# i) = I64# (word2Int# i) -#else - integralCast (W64# i) = I64# (word64ToInt64# i) -#endif -instance IntegralCast Int64 Word64 where -#if WORD_SIZE_IN_BITS == 64 - integralCast (I64# i) = W64# (int2Word# i) -#else - integralCast (I64# i) = W64# (int64ToWord64# i) -#endif - --- missing word8, word16, word32, word64 --- instance IntegralCast Word8 Int8 where --- instance IntegralCast Int8 Word8 where - -intToInt64 :: Int -> Int64 -#if WORD_SIZE_IN_BITS == 64 -intToInt64 (I# i) = I64# i -#else -intToInt64 (I# i) = I64# (intToInt64# i) -#endif - -int64ToInt :: Int64 -> Int -#if WORD_SIZE_IN_BITS == 64 -int64ToInt (I64# i) = I# i -#else -int64ToInt (I64# i) = I# (int64ToInt# i) -#endif - -wordToWord64 :: Word -> Word64 -#if WORD_SIZE_IN_BITS == 64 -wordToWord64 (W# i) = W64# i -#else -wordToWord64 (W# i) = W64# (wordToWord64# i) -#endif - -word64ToWord :: Word64 -> Word -#if WORD_SIZE_IN_BITS == 64 -word64ToWord (W64# i) = W# i -#else -word64ToWord (W64# i) = W# (word64ToWord# i) -#endif - -#if WORD_SIZE_IN_BITS == 64 -word64ToWord# :: Word# -> Word# -word64ToWord# i = i -{-# INLINE word64ToWord# #-} -#endif - -#if WORD_SIZE_IN_BITS == 64 -word64ToWord32s :: Word64 -> (# Word32, Word32 #) -word64ToWord32s (W64# w64) = (# W32# (uncheckedShiftRL# w64 32#), W32# (narrow32Word# w64) #) -#else -word64ToWord32s :: Word64 -> (# Word32, Word32 #) -word64ToWord32s (W64# w64) = (# W32# (word64ToWord# (uncheckedShiftRL64# w64 32#)), W32# (word64ToWord# w64) #) -#endif - -wordToChar :: Word -> Char -wordToChar (W# word) = C# (chr# (word2Int# word)) - -wordToInt :: Word -> Int -wordToInt (W# word) = I# (word2Int# word) - -charToInt :: Char -> Int -charToInt (C# x) = I# (ord# x) diff --git a/Foundation/Primitive/Monad.hs b/Foundation/Primitive/Monad.hs deleted file mode 100644 --- a/Foundation/Primitive/Monad.hs +++ /dev/null @@ -1,117 +0,0 @@ --- | --- Module : Foundation.Primitive.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 Foundation.Primitive.Monad - ( PrimMonad(..) - , 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 Foundation.Internal.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 #-} diff --git a/Foundation/Primitive/Nat.hs b/Foundation/Primitive/Nat.hs deleted file mode 100644 --- a/Foundation/Primitive/Nat.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} -#if __GLASGOW_HASKELL__ < 710 -# error "IMPORT ERROR: cannot include this file with GHC version below 7.10 -#else -#if __GLASGOW_HASKELL__ < 800 -{-# LANGUAGE ConstraintKinds #-} -#endif -module Foundation.Primitive.Nat - ( Nat - , KnownNat - , natVal - , type (<=), type (<=?), type (+), type (*), type (^), type (-) - , CmpNat - -- * Nat convertion - , natValInt - , natValInt8 - , natValInt16 - , natValInt32 - , natValInt64 - , natValWord - , natValWord8 - , natValWord16 - , natValWord32 - , natValWord64 - -- * Maximum bounds - , NatNumMaxBound - -- * Constraint - , NatInBoundOf - , NatWithinBound - ) where - -#include "MachDeps.h" - -import GHC.TypeLits -import Foundation.Internal.Base -import Foundation.Internal.Natural -import Data.Int (Int8, Int16, Int32, Int64) -import Data.Word (Word8, Word16, Word32, Word64) -import qualified Prelude (fromIntegral) - -#if __GLASGOW_HASKELL__ >= 800 -import Data.Type.Bool -#endif - -natValInt :: forall n proxy . (KnownNat n, NatWithinBound Int n) => proxy n -> Int -natValInt n = Prelude.fromIntegral (natVal n) - -natValInt64 :: forall n proxy . (KnownNat n, NatWithinBound Int64 n) => proxy n -> Int64 -natValInt64 n = Prelude.fromIntegral (natVal n) - -natValInt32 :: forall n proxy . (KnownNat n, NatWithinBound Int32 n) => proxy n -> Int32 -natValInt32 n = Prelude.fromIntegral (natVal n) - -natValInt16 :: forall n proxy . (KnownNat n, NatWithinBound Int16 n) => proxy n -> Int16 -natValInt16 n = Prelude.fromIntegral (natVal n) - -natValInt8 :: forall n proxy . (KnownNat n, NatWithinBound Int8 n) => proxy n -> Int8 -natValInt8 n = Prelude.fromIntegral (natVal n) - -natValWord :: forall n proxy . (KnownNat n, NatWithinBound Word n) => proxy n -> Word -natValWord n = Prelude.fromIntegral (natVal n) - -natValWord64 :: forall n proxy . (KnownNat n, NatWithinBound Word64 n) => proxy n -> Word64 -natValWord64 n = Prelude.fromIntegral (natVal n) - -natValWord32 :: forall n proxy . (KnownNat n, NatWithinBound Word32 n) => proxy n -> Word32 -natValWord32 n = Prelude.fromIntegral (natVal n) - -natValWord16 :: forall n proxy . (KnownNat n, NatWithinBound Word16 n) => proxy n -> Word16 -natValWord16 n = Prelude.fromIntegral (natVal n) - -natValWord8 :: forall n proxy . (KnownNat n, NatWithinBound Word8 n) => proxy n -> Word8 -natValWord8 n = Prelude.fromIntegral (natVal n) - --- | Get Maximum bounds of different Integral / Natural types related to Nat -type family NatNumMaxBound ty where - NatNumMaxBound Int64 = 0x7fffffffffffffff - NatNumMaxBound Int32 = 0x7fffffff - NatNumMaxBound Int16 = 0x7fff - NatNumMaxBound Int8 = 0x7f - NatNumMaxBound Word64 = 0xffffffffffffffff - NatNumMaxBound Word32 = 0xffffffff - NatNumMaxBound Word16 = 0xffff - NatNumMaxBound Word8 = 0xff -#if WORD_SIZE_IN_BITS == 64 - NatNumMaxBound Int = NatNumMaxBound Int64 - NatNumMaxBound Word = NatNumMaxBound Word64 -#else - NatNumMaxBound Int = NatNumMaxBound Int32 - NatNumMaxBound Word = NatNumMaxBound Word32 -#endif - --- | Check if a Nat is in bounds of another integral / natural types -type family NatInBoundOf ty n where - NatInBoundOf Integer n = 'True - NatInBoundOf Natural n = 'True - NatInBoundOf ty n = n <=? NatNumMaxBound ty - --- | Constraint to check if a natural is within a specific bounds of a type. --- --- i.e. given a Nat `n`, is it possible to convert it to `ty` without losing information -#if __GLASGOW_HASKELL__ >= 800 -type family NatWithinBound ty (n :: Nat) where - NatWithinBound ty n = If (NatInBoundOf ty n) - (() ~ ()) - (TypeError ('Text "Natural " ':<>: 'ShowType n ':<>: 'Text " is out of bounds for " ':<>: 'ShowType ty)) -#else -type NatWithinBound ty n = NatInBoundOf ty n ~ 'True -#endif - -#endif diff --git a/Foundation/Primitive/NormalForm.hs b/Foundation/Primitive/NormalForm.hs deleted file mode 100644 --- a/Foundation/Primitive/NormalForm.hs +++ /dev/null @@ -1,121 +0,0 @@ -module Foundation.Primitive.NormalForm - ( NormalForm(..) - , deepseq - , force - ) where - -import Foundation.Internal.Base -import Foundation.Internal.Natural -import Foundation.Primitive.Types.OffsetSize -import Foundation.Primitive.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 !_ = () - ------ --- composed type - -instance NormalForm a => NormalForm (Maybe a) where - toNormalForm Nothing = () - toNormalForm (Just a) = toNormalForm a `seq` () -instance (NormalForm l, NormalForm r) => NormalForm (Either l r) where - toNormalForm (Left l) = toNormalForm l `seq` () - toNormalForm (Right r) = toNormalForm r `seq` () -instance NormalForm a => NormalForm (LE a) where - toNormalForm (LE a) = toNormalForm a `seq` () -instance NormalForm a => NormalForm (BE a) where - toNormalForm (BE a) = toNormalForm a `seq` () - -instance NormalForm a => NormalForm [a] where - toNormalForm [] = () - toNormalForm (x:xs) = toNormalForm x `seq` toNormalForm xs - -instance (NormalForm a, NormalForm b) => NormalForm (a,b) where - toNormalForm (a,b) = toNormalForm a `seq` toNormalForm b - -instance (NormalForm a, NormalForm b, NormalForm c) => NormalForm (a,b,c) where - toNormalForm (a,b,c) = toNormalForm a `seq` toNormalForm b `seq` toNormalForm c - -instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d) => NormalForm (a,b,c,d) where - toNormalForm (a,b,c,d) = toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d - -instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d, NormalForm e) - => NormalForm (a,b,c,d,e) where - toNormalForm (a,b,c,d,e) = - toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d `seq` - toNormalForm e - -instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d, NormalForm e, NormalForm f) - => NormalForm (a,b,c,d,e,f) where - toNormalForm (a,b,c,d,e,f) = - toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d `seq` - toNormalForm e `seq` toNormalForm f - -instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d, NormalForm e, NormalForm f, NormalForm g) - => NormalForm (a,b,c,d,e,f,g) where - toNormalForm (a,b,c,d,e,f,g) = - toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d `seq` - toNormalForm e `seq` toNormalForm f `seq` toNormalForm g -instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d, NormalForm e, NormalForm f, NormalForm g, NormalForm h) - => NormalForm (a,b,c,d,e,f,g,h) where - toNormalForm (a,b,c,d,e,f,g,h) = - toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d `seq` - toNormalForm e `seq` toNormalForm f `seq` toNormalForm g `seq` toNormalForm h diff --git a/Foundation/Primitive/Runtime.hs b/Foundation/Primitive/Runtime.hs deleted file mode 100644 --- a/Foundation/Primitive/Runtime.hs +++ /dev/null @@ -1,30 +0,0 @@ --- | --- Module : Foundation.Primitive.Runtime --- License : BSD-style --- Maintainer : foundation --- --- Global configuration environment -module Foundation.Primitive.Runtime - where - -import Foundation.Internal.Base -import Foundation.Internal.Environment -import Foundation.Primitive.Types.OffsetSize -import System.IO.Unsafe (unsafePerformIO) - --- | 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 :: Size8 -unsafeUArrayUnpinnedMaxSize = unsafePerformIO $ do - maxSize <- (>>= readMaybe) <$> lookupEnv "HS_FOUNDATION_UARRAY_UNPINNED_MAX" - pure $ maybe (CountOf 1024) CountOf maxSize -{-# NOINLINE unsafeUArrayUnpinnedMaxSize #-} diff --git a/Foundation/Primitive/Show.hs b/Foundation/Primitive/Show.hs deleted file mode 100644 --- a/Foundation/Primitive/Show.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Foundation.Primitive.Show - where - -import qualified Prelude -import Foundation.Internal.Base -import Foundation.Primitive.UTF8.Base (String) - --- | Use the Show class to create a String. --- --- Note that this is not efficient, since --- an intermediate [Char] is going to be --- created before turning into a real String. -show :: Prelude.Show a => a -> String -show = fromList . Prelude.show diff --git a/Foundation/Primitive/These.hs b/Foundation/Primitive/These.hs deleted file mode 100644 --- a/Foundation/Primitive/These.hs +++ /dev/null @@ -1,36 +0,0 @@ --- | --- Module : Foundation.Primitive.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 Foundation.Primitive.These - ( These(..) - ) where - -import Foundation.Internal.Base -import Foundation.Primitive.NormalForm -import Foundation.Class.Bifunctor - --- | Either a or b or both. -data These a b - = This a - | That b - | These a b - deriving (Eq, Ord, Show, Typeable) - -instance (NormalForm a, NormalForm b) => NormalForm (These a b) where - toNormalForm (This a) = toNormalForm a - toNormalForm (That b) = toNormalForm b - toNormalForm (These a b) = toNormalForm a `seq` toNormalForm b - -instance Bifunctor These where - bimap fa _ (This a) = This (fa a) - bimap _ fb (That b) = That (fb b) - bimap fa fb (These a b) = These (fa a) (fb b) - -instance Functor (These a) where - fmap = second diff --git a/Foundation/Primitive/Types.hs b/Foundation/Primitive/Types.hs deleted file mode 100644 --- a/Foundation/Primitive/Types.hs +++ /dev/null @@ -1,625 +0,0 @@ --- Module : Foundation.Primitive.Types --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : portable --- -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} -module Foundation.Primitive.Types - ( 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 Foundation.Internal.Proxy -import Foundation.Internal.Base -import Foundation.Numerical.Subtractive -import Foundation.Primitive.Types.OffsetSize -import Foundation.Primitive.Endianness -import Foundation.Primitive.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 -> Size8 - - -- | get the shift size - primShiftToBytes :: Proxy ty -> Int - - ----- - -- ByteArray section - ----- - - -- | return the element stored at a specific index - primBaUIndex :: ByteArray# -> Offset ty -> ty - - ----- - -- MutableByteArray section - ----- - - -- | Read an element at an index in a mutable array - primMbaURead :: PrimMonad prim - => MutableByteArray# (PrimState prim) -- ^ mutable array to read from - -> Offset ty -- ^ index of the element to retrieve - -> prim ty -- ^ the element returned - - -- | Write an element to a specific cell in a mutable array. - primMbaUWrite :: PrimMonad prim - => MutableByteArray# (PrimState prim) -- ^ mutable array to modify - -> Offset ty -- ^ index of the element to modify - -> ty -- ^ the new value to store - -> prim () - - ----- - -- Addr# section - ----- - - -- | Read from Address, without a state. the value read should be considered a constant for all - -- pratical purpose, otherwise bad thing will happens. - primAddrIndex :: Addr# -> Offset ty -> ty - - -- | Read a value from Addr in a specific primitive monad - primAddrRead :: PrimMonad prim - => Addr# - -> Offset ty - -> prim ty - -- | Write a value to Addr in a specific primitive monad - primAddrWrite :: PrimMonad prim - => Addr# - -> Offset ty - -> ty - -> prim () - -sizeInt, sizeWord :: CountOf Word8 -shiftInt, shiftWord :: Int -#if WORD_SIZE_IN_BITS == 64 -sizeInt = CountOf 8 -sizeWord = CountOf 8 -shiftInt = 3 -shiftWord = 3 -#else -sizeInt = CountOf 4 -sizeWord = CountOf 4 -shiftInt = 2 -shiftWord = 2 -#endif - -{-# SPECIALIZE [3] primBaUIndex :: ByteArray# -> Offset Word8 -> Word8 #-} - -instance PrimType Int where - primSizeInBytes _ = sizeInt - {-# INLINE primSizeInBytes #-} - primShiftToBytes _ = shiftInt - {-# INLINE primShiftToBytes #-} - primBaUIndex ba (Offset (I# n)) = I# (indexIntArray# ba n) - {-# INLINE primBaUIndex #-} - primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readIntArray# mba n s1 in (# s2, I# r #) - {-# INLINE primMbaURead #-} - primMbaUWrite mba (Offset (I# n)) (I# w) = primitive $ \s1 -> (# writeIntArray# mba n w s1, () #) - {-# INLINE primMbaUWrite #-} - primAddrIndex addr (Offset (I# n)) = I# (indexIntOffAddr# addr n) - {-# INLINE primAddrIndex #-} - primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readIntOffAddr# addr n s1 in (# s2, I# r #) - {-# INLINE primAddrRead #-} - primAddrWrite addr (Offset (I# n)) (I# w) = primitive $ \s1 -> (# writeIntOffAddr# addr n w s1, () #) - {-# INLINE primAddrWrite #-} - -instance PrimType Word where - primSizeInBytes _ = sizeWord - {-# INLINE primSizeInBytes #-} - primShiftToBytes _ = shiftWord - {-# INLINE primShiftToBytes #-} - primBaUIndex ba (Offset (I# n)) = W# (indexWordArray# ba n) - {-# INLINE primBaUIndex #-} - primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWordArray# mba n s1 in (# s2, W# r #) - {-# INLINE primMbaURead #-} - primMbaUWrite mba (Offset (I# n)) (W# w) = primitive $ \s1 -> (# writeWordArray# mba n w s1, () #) - {-# INLINE primMbaUWrite #-} - primAddrIndex addr (Offset (I# n)) = W# (indexWordOffAddr# addr n) - {-# INLINE primAddrIndex #-} - primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWordOffAddr# addr n s1 in (# s2, W# r #) - {-# INLINE primAddrRead #-} - primAddrWrite addr (Offset (I# n)) (W# w) = primitive $ \s1 -> (# writeWordOffAddr# addr n w s1, () #) - {-# INLINE primAddrWrite #-} - -instance PrimType Word8 where - primSizeInBytes _ = CountOf 1 - {-# INLINE primSizeInBytes #-} - primShiftToBytes _ = 0 - {-# INLINE primShiftToBytes #-} - primBaUIndex ba (Offset (I# n)) = W8# (indexWord8Array# ba n) - {-# INLINE primBaUIndex #-} - primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWord8Array# mba n s1 in (# s2, W8# r #) - {-# INLINE primMbaURead #-} - primMbaUWrite mba (Offset (I# n)) (W8# w) = primitive $ \s1 -> (# writeWord8Array# mba n w s1, () #) - {-# INLINE primMbaUWrite #-} - primAddrIndex addr (Offset (I# n)) = W8# (indexWord8OffAddr# addr n) - {-# INLINE primAddrIndex #-} - primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWord8OffAddr# addr n s1 in (# s2, W8# r #) - {-# INLINE primAddrRead #-} - primAddrWrite addr (Offset (I# n)) (W8# w) = primitive $ \s1 -> (# writeWord8OffAddr# addr n w s1, () #) - {-# INLINE primAddrWrite #-} - -instance PrimType Word16 where - primSizeInBytes _ = CountOf 2 - {-# INLINE primSizeInBytes #-} - primShiftToBytes _ = 1 - {-# INLINE primShiftToBytes #-} - primBaUIndex ba (Offset (I# n)) = W16# (indexWord16Array# ba n) - {-# INLINE primBaUIndex #-} - primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWord16Array# mba n s1 in (# s2, W16# r #) - {-# INLINE primMbaURead #-} - primMbaUWrite mba (Offset (I# n)) (W16# w) = primitive $ \s1 -> (# writeWord16Array# mba n w s1, () #) - {-# INLINE primMbaUWrite #-} - primAddrIndex addr (Offset (I# n)) = W16# (indexWord16OffAddr# addr n) - {-# INLINE primAddrIndex #-} - primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWord16OffAddr# addr n s1 in (# s2, W16# r #) - {-# INLINE primAddrRead #-} - primAddrWrite addr (Offset (I# n)) (W16# w) = primitive $ \s1 -> (# writeWord16OffAddr# addr n w s1, () #) - {-# INLINE primAddrWrite #-} -instance PrimType Word32 where - primSizeInBytes _ = CountOf 4 - {-# INLINE primSizeInBytes #-} - primShiftToBytes _ = 2 - {-# INLINE primShiftToBytes #-} - primBaUIndex ba (Offset (I# n)) = W32# (indexWord32Array# ba n) - {-# INLINE primBaUIndex #-} - primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWord32Array# mba n s1 in (# s2, W32# r #) - {-# INLINE primMbaURead #-} - primMbaUWrite mba (Offset (I# n)) (W32# w) = primitive $ \s1 -> (# writeWord32Array# mba n w s1, () #) - {-# INLINE primMbaUWrite #-} - primAddrIndex addr (Offset (I# n)) = W32# (indexWord32OffAddr# addr n) - {-# INLINE primAddrIndex #-} - primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWord32OffAddr# addr n s1 in (# s2, W32# r #) - {-# INLINE primAddrRead #-} - primAddrWrite addr (Offset (I# n)) (W32# w) = primitive $ \s1 -> (# writeWord32OffAddr# addr n w s1, () #) - {-# INLINE primAddrWrite #-} -instance PrimType Word64 where - primSizeInBytes _ = CountOf 8 - {-# INLINE primSizeInBytes #-} - primShiftToBytes _ = 3 - {-# INLINE primShiftToBytes #-} - primBaUIndex ba (Offset (I# n)) = W64# (indexWord64Array# ba n) - {-# INLINE primBaUIndex #-} - primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWord64Array# mba n s1 in (# s2, W64# r #) - {-# INLINE primMbaURead #-} - primMbaUWrite mba (Offset (I# n)) (W64# w) = primitive $ \s1 -> (# writeWord64Array# mba n w s1, () #) - {-# INLINE primMbaUWrite #-} - primAddrIndex addr (Offset (I# n)) = W64# (indexWord64OffAddr# addr n) - {-# INLINE primAddrIndex #-} - primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWord64OffAddr# addr n s1 in (# s2, W64# r #) - {-# INLINE primAddrRead #-} - primAddrWrite addr (Offset (I# n)) (W64# w) = primitive $ \s1 -> (# writeWord64OffAddr# addr n w s1, () #) - {-# INLINE primAddrWrite #-} -instance PrimType Int8 where - primSizeInBytes _ = CountOf 1 - {-# INLINE primSizeInBytes #-} - primShiftToBytes _ = 0 - {-# INLINE primShiftToBytes #-} - primBaUIndex ba (Offset (I# n)) = I8# (indexInt8Array# ba n) - {-# INLINE primBaUIndex #-} - primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readInt8Array# mba n s1 in (# s2, I8# r #) - {-# INLINE primMbaURead #-} - primMbaUWrite mba (Offset (I# n)) (I8# w) = primitive $ \s1 -> (# writeInt8Array# mba n w s1, () #) - {-# INLINE primMbaUWrite #-} - primAddrIndex addr (Offset (I# n)) = I8# (indexInt8OffAddr# addr n) - {-# INLINE primAddrIndex #-} - primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readInt8OffAddr# addr n s1 in (# s2, I8# r #) - {-# INLINE primAddrRead #-} - primAddrWrite addr (Offset (I# n)) (I8# w) = primitive $ \s1 -> (# writeInt8OffAddr# addr n w s1, () #) - {-# INLINE primAddrWrite #-} -instance PrimType Int16 where - primSizeInBytes _ = CountOf 2 - {-# INLINE primSizeInBytes #-} - primShiftToBytes _ = 1 - {-# INLINE primShiftToBytes #-} - primBaUIndex ba (Offset (I# n)) = I16# (indexInt16Array# ba n) - {-# INLINE primBaUIndex #-} - primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readInt16Array# mba n s1 in (# s2, I16# r #) - {-# INLINE primMbaURead #-} - primMbaUWrite mba (Offset (I# n)) (I16# w) = primitive $ \s1 -> (# writeInt16Array# mba n w s1, () #) - {-# INLINE primMbaUWrite #-} - primAddrIndex addr (Offset (I# n)) = I16# (indexInt16OffAddr# addr n) - {-# INLINE primAddrIndex #-} - primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readInt16OffAddr# addr n s1 in (# s2, I16# r #) - {-# INLINE primAddrRead #-} - primAddrWrite addr (Offset (I# n)) (I16# w) = primitive $ \s1 -> (# writeInt16OffAddr# addr n w s1, () #) - {-# INLINE primAddrWrite #-} -instance PrimType Int32 where - primSizeInBytes _ = CountOf 4 - {-# INLINE primSizeInBytes #-} - primShiftToBytes _ = 2 - {-# INLINE primShiftToBytes #-} - primBaUIndex ba (Offset (I# n)) = I32# (indexInt32Array# ba n) - {-# INLINE primBaUIndex #-} - primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readInt32Array# mba n s1 in (# s2, I32# r #) - {-# INLINE primMbaURead #-} - primMbaUWrite mba (Offset (I# n)) (I32# w) = primitive $ \s1 -> (# writeInt32Array# mba n w s1, () #) - {-# INLINE primMbaUWrite #-} - primAddrIndex addr (Offset (I# n)) = I32# (indexInt32OffAddr# addr n) - {-# INLINE primAddrIndex #-} - primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readInt32OffAddr# addr n s1 in (# s2, I32# r #) - {-# INLINE primAddrRead #-} - primAddrWrite addr (Offset (I# n)) (I32# w) = primitive $ \s1 -> (# writeInt32OffAddr# addr n w s1, () #) - {-# INLINE primAddrWrite #-} -instance PrimType Int64 where - primSizeInBytes _ = CountOf 8 - {-# INLINE primSizeInBytes #-} - primShiftToBytes _ = 3 - {-# INLINE primShiftToBytes #-} - primBaUIndex ba (Offset (I# n)) = I64# (indexInt64Array# ba n) - {-# INLINE primBaUIndex #-} - primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readInt64Array# mba n s1 in (# s2, I64# r #) - {-# INLINE primMbaURead #-} - primMbaUWrite mba (Offset (I# n)) (I64# w) = primitive $ \s1 -> (# writeInt64Array# mba n w s1, () #) - {-# INLINE primMbaUWrite #-} - primAddrIndex addr (Offset (I# n)) = I64# (indexInt64OffAddr# addr n) - {-# INLINE primAddrIndex #-} - primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readInt64OffAddr# addr n s1 in (# s2, I64# r #) - {-# INLINE primAddrRead #-} - primAddrWrite addr (Offset (I# n)) (I64# w) = primitive $ \s1 -> (# writeInt64OffAddr# addr n w s1, () #) - {-# INLINE primAddrWrite #-} - -instance PrimType Float where - primSizeInBytes _ = CountOf 4 - {-# INLINE primSizeInBytes #-} - primShiftToBytes _ = 2 - {-# INLINE primShiftToBytes #-} - primBaUIndex ba (Offset (I# n)) = F# (indexFloatArray# ba n) - {-# INLINE primBaUIndex #-} - primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readFloatArray# mba n s1 in (# s2, F# r #) - {-# INLINE primMbaURead #-} - primMbaUWrite mba (Offset (I# n)) (F# w) = primitive $ \s1 -> (# writeFloatArray# mba n w s1, () #) - {-# INLINE primMbaUWrite #-} - primAddrIndex addr (Offset (I# n)) = F# (indexFloatOffAddr# addr n) - {-# INLINE primAddrIndex #-} - primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readFloatOffAddr# addr n s1 in (# s2, F# r #) - {-# INLINE primAddrRead #-} - primAddrWrite addr (Offset (I# n)) (F# w) = primitive $ \s1 -> (# writeFloatOffAddr# addr n w s1, () #) - {-# INLINE primAddrWrite #-} -instance PrimType Double where - primSizeInBytes _ = CountOf 8 - {-# INLINE primSizeInBytes #-} - primShiftToBytes _ = 3 - {-# INLINE primShiftToBytes #-} - primBaUIndex ba (Offset (I# n)) = D# (indexDoubleArray# ba n) - {-# INLINE primBaUIndex #-} - primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readDoubleArray# mba n s1 in (# s2, D# r #) - {-# INLINE primMbaURead #-} - primMbaUWrite mba (Offset (I# n)) (D# w) = primitive $ \s1 -> (# writeDoubleArray# mba n w s1, () #) - {-# INLINE primMbaUWrite #-} - primAddrIndex addr (Offset (I# n)) = D# (indexDoubleOffAddr# addr n) - {-# INLINE primAddrIndex #-} - primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readDoubleOffAddr# addr n s1 in (# s2, D# r #) - {-# INLINE primAddrRead #-} - primAddrWrite addr (Offset (I# n)) (D# w) = primitive $ \s1 -> (# writeDoubleOffAddr# addr n w s1, () #) - {-# INLINE primAddrWrite #-} - -instance PrimType Char where - primSizeInBytes _ = CountOf 4 - {-# INLINE primSizeInBytes #-} - primShiftToBytes _ = 2 - {-# INLINE primShiftToBytes #-} - primBaUIndex ba (Offset (I# n)) = C# (indexWideCharArray# ba n) - {-# INLINE primBaUIndex #-} - primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWideCharArray# mba n s1 in (# s2, C# r #) - {-# INLINE primMbaURead #-} - primMbaUWrite mba (Offset (I# n)) (C# w) = primitive $ \s1 -> (# writeWideCharArray# mba n w s1, () #) - {-# INLINE primMbaUWrite #-} - primAddrIndex addr (Offset (I# n)) = C# (indexWideCharOffAddr# addr n) - {-# INLINE primAddrIndex #-} - primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWideCharOffAddr# addr n s1 in (# s2, C# r #) - {-# INLINE primAddrRead #-} - primAddrWrite addr (Offset (I# n)) (C# w) = primitive $ \s1 -> (# writeWideCharOffAddr# addr n w s1, () #) - {-# INLINE primAddrWrite #-} - -instance PrimType CChar where - primSizeInBytes _ = CountOf 1 - {-# INLINE primSizeInBytes #-} - primShiftToBytes _ = 0 - {-# INLINE primShiftToBytes #-} - primBaUIndex ba (Offset n) = CChar (primBaUIndex ba (Offset n)) - {-# INLINE primBaUIndex #-} - primMbaURead mba (Offset n) = CChar <$> primMbaURead mba (Offset n) - {-# INLINE primMbaURead #-} - primMbaUWrite mba (Offset n) (CChar int8) = primMbaUWrite mba (Offset n) int8 - {-# INLINE primMbaUWrite #-} - primAddrIndex addr (Offset n) = CChar $ primAddrIndex addr (Offset n) - {-# INLINE primAddrIndex #-} - primAddrRead addr (Offset n) = CChar <$> primAddrRead addr (Offset n) - {-# INLINE primAddrRead #-} - primAddrWrite addr (Offset n) (CChar int8) = primAddrWrite addr (Offset n) int8 - {-# INLINE primAddrWrite #-} -instance PrimType CUChar where - primSizeInBytes _ = CountOf 1 - {-# INLINE primSizeInBytes #-} - primShiftToBytes _ = 0 - {-# INLINE primShiftToBytes #-} - primBaUIndex ba (Offset n) = CUChar (primBaUIndex ba (Offset n :: Offset Word8)) - {-# INLINE primBaUIndex #-} - primMbaURead mba (Offset n) = CUChar <$> primMbaURead mba (Offset n :: Offset Word8) - {-# INLINE primMbaURead #-} - primMbaUWrite mba (Offset n) (CUChar w8) = primMbaUWrite mba (Offset n) w8 - {-# INLINE primMbaUWrite #-} - primAddrIndex addr (Offset n) = CUChar $ primAddrIndex addr (Offset n :: Offset Word8) - {-# INLINE primAddrIndex #-} - primAddrRead addr (Offset n) = CUChar <$> primAddrRead addr (Offset n :: Offset Word8) - {-# INLINE primAddrRead #-} - primAddrWrite addr (Offset n) (CUChar w8) = primAddrWrite addr (Offset n) w8 - {-# INLINE primAddrWrite #-} - -instance PrimType a => PrimType (LE a) where - primSizeInBytes _ = primSizeInBytes (Proxy :: Proxy a) - {-# INLINE primSizeInBytes #-} - primShiftToBytes _ = primShiftToBytes (Proxy :: Proxy a) - {-# INLINE primShiftToBytes #-} - primBaUIndex ba (Offset a) = LE $ primBaUIndex ba (Offset a) - {-# INLINE primBaUIndex #-} - primMbaURead ba (Offset a) = LE <$> primMbaURead ba (Offset a) - {-# INLINE primMbaURead #-} - primMbaUWrite mba (Offset a) (LE w) = primMbaUWrite mba (Offset a) w - {-# INLINE primMbaUWrite #-} - primAddrIndex addr (Offset a) = LE $ primAddrIndex addr (Offset a) - {-# INLINE primAddrIndex #-} - primAddrRead addr (Offset a) = LE <$> primAddrRead addr (Offset a) - {-# INLINE primAddrRead #-} - primAddrWrite addr (Offset a) (LE w) = primAddrWrite addr (Offset a) w - {-# INLINE primAddrWrite #-} -instance PrimType a => PrimType (BE a) where - primSizeInBytes _ = primSizeInBytes (Proxy :: Proxy a) - {-# INLINE primSizeInBytes #-} - primShiftToBytes _ = primShiftToBytes (Proxy :: Proxy a) - {-# INLINE primShiftToBytes #-} - primBaUIndex ba (Offset a) = BE $ primBaUIndex ba (Offset a) - {-# INLINE primBaUIndex #-} - primMbaURead ba (Offset a) = BE <$> primMbaURead ba (Offset a) - {-# INLINE primMbaURead #-} - primMbaUWrite mba (Offset a) (BE w) = primMbaUWrite mba (Offset a) w - {-# INLINE primMbaUWrite #-} - primAddrIndex addr (Offset a) = BE $ primAddrIndex addr (Offset a) - {-# INLINE primAddrIndex #-} - primAddrRead addr (Offset a) = BE <$> primAddrRead addr (Offset a) - {-# INLINE primAddrRead #-} - primAddrWrite addr (Offset a) (BE w) = primAddrWrite addr (Offset a) w - {-# INLINE primAddrWrite #-} - --- | A constraint class for serializable type that have an unique --- memory compare representation --- --- e.g. Float and Double have -0.0 and 0.0 which are Eq individual, --- yet have a different memory representation which doesn't allow --- for memcmp operation -class PrimMemoryComparable ty where - -instance PrimMemoryComparable Int where -instance PrimMemoryComparable Word where -instance PrimMemoryComparable Word8 where -instance PrimMemoryComparable Word16 where -instance PrimMemoryComparable Word32 where -instance PrimMemoryComparable Word64 where -instance PrimMemoryComparable Int8 where -instance PrimMemoryComparable Int16 where -instance PrimMemoryComparable Int32 where -instance PrimMemoryComparable Int64 where -instance PrimMemoryComparable Char where -instance PrimMemoryComparable CChar where -instance PrimMemoryComparable CUChar where -instance PrimMemoryComparable a => PrimMemoryComparable (LE a) where -instance PrimMemoryComparable a => PrimMemoryComparable (BE a) where - --- | Cast a CountOf linked to type A (CountOf A) to a CountOf linked to type B (CountOf B) -sizeRecast :: forall a b . (PrimType a, PrimType b) => CountOf a -> CountOf b -sizeRecast sz = CountOf (bytes `Prelude.quot` szB) - where !szA = primSizeInBytes (Proxy :: Proxy a) - !(CountOf szB) = primSizeInBytes (Proxy :: Proxy b) - !(CountOf bytes) = sizeOfE szA sz -{-# INLINE [1] sizeRecast #-} -{-# RULES "sizeRecast from Word8" [2] forall a . sizeRecast a = sizeRecastBytes a #-} - -sizeRecastBytes :: forall b . PrimType b => CountOf Word8 -> CountOf b -sizeRecastBytes (CountOf w) = CountOf (w `Prelude.quot` szB) - where !(CountOf szB) = primSizeInBytes (Proxy :: Proxy b) -{-# INLINE [1] sizeRecastBytes #-} - -sizeInBytes :: forall a . PrimType a => CountOf a -> CountOf Word8 -sizeInBytes sz = sizeOfE (primSizeInBytes (Proxy :: Proxy a)) sz - -offsetInBytes :: forall a . PrimType a => Offset a -> Offset Word8 -offsetInBytes ofs = offsetShiftL (primShiftToBytes (Proxy :: Proxy a)) ofs -{-# INLINE [2] offsetInBytes #-} -{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word64 -> Offset Word8 #-} -{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word32 -> Offset Word8 #-} -{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word16 -> Offset Word8 #-} -{-# RULES "offsetInBytes Bytes" [3] forall x . offsetInBytes x = x #-} - -offsetInElements :: forall a . PrimType a => Offset Word8 -> Offset a -offsetInElements ofs = offsetShiftR (primShiftToBytes (Proxy :: Proxy a)) ofs -{-# INLINE [2] offsetInElements #-} -{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word64 -> Offset Word8 #-} -{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word32 -> Offset Word8 #-} -{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word16 -> Offset Word8 #-} -{-# RULES "offsetInElements Bytes" [3] forall x . offsetInElements x = x #-} - -primOffsetRecast :: forall a b . (PrimType a, PrimType b) => Offset a -> Offset b -primOffsetRecast !ofs = - let !(Offset bytes) = offsetOfE szA ofs - in Offset (bytes `Prelude.quot` szB) - where - !szA = primSizeInBytes (Proxy :: Proxy a) - !(CountOf szB) = primSizeInBytes (Proxy :: Proxy b) -{-# INLINE [1] primOffsetRecast #-} -{-# RULES "primOffsetRecast W8" [3] forall a . primOffsetRecast a = primOffsetRecastBytes a #-} - -offsetIsAligned :: forall a . PrimType a => Proxy a -> Offset Word8 -> Bool -offsetIsAligned _ (Offset ofs) = (ofs .&. mask) == 0 - where (CountOf sz) = primSizeInBytes (Proxy :: Proxy a) - mask = sz - 1 -{-# INLINE [1] offsetIsAligned #-} -{-# SPECIALIZE [3] offsetIsAligned :: Proxy Word64 -> Offset Word8 -> Bool #-} -{-# RULES "offsetInAligned Bytes" [3] forall (prx :: Proxy Word8) x . offsetIsAligned prx x = True #-} - -primOffsetRecastBytes :: forall b . PrimType b => Offset Word8 -> Offset b -primOffsetRecastBytes (Offset 0) = Offset 0 -primOffsetRecastBytes (Offset o) = Offset (szA `Prelude.quot` o) - where !(CountOf szA) = primSizeInBytes (Proxy :: Proxy b) -{-# INLINE [1] primOffsetRecastBytes #-} - -primOffsetOfE :: forall a . PrimType a => Offset a -> Offset Word8 -primOffsetOfE = offsetInBytes -{-# DEPRECATED primOffsetOfE "use offsetInBytes" #-} - -primWordGetByteAndShift :: Word# -> (# Word#, Word# #) -primWordGetByteAndShift w = (# and# w 0xff##, uncheckedShiftRL# w 8# #) -{-# INLINE primWordGetByteAndShift #-} - -#if WORD_SIZE_IN_BITS == 64 -primWord64GetByteAndShift :: Word# -> (# Word#, Word# #) -primWord64GetByteAndShift = primWord64GetByteAndShift - -primWord64GetHiLo :: Word# -> (# Word#, Word# #) -primWord64GetHiLo w = (# uncheckedShiftRL# w 32# , and# w 0xffffffff## #) -#else -primWord64GetByteAndShift :: Word64# -> (# Word#, Word64# #) -primWord64GetByteAndShift w = (# and# (word64ToWord# w) 0xff##, uncheckedShiftRL64# w 8# #) - -primWord64GetHiLo :: Word64# -> (# Word#, Word# #) -primWord64GetHiLo w = (# word64ToWord# (uncheckedShiftRL64# w 32#), word64ToWord# w #) -#endif -{-# INLINE primWord64GetByteAndShift #-} diff --git a/Foundation/Primitive/Types/OffsetSize.hs b/Foundation/Primitive/Types/OffsetSize.hs deleted file mode 100644 --- a/Foundation/Primitive/Types/OffsetSize.hs +++ /dev/null @@ -1,248 +0,0 @@ --- | --- Module : Foundation.Primitive.Types.OffsetSize --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : portable --- -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE CPP #-} -module Foundation.Primitive.Types.OffsetSize - ( FileSize(..) - , Offset(..) - , Offset8 - , offsetOfE - , offsetPlusE - , offsetMinusE - , offsetRecast - , offsetCast - , offsetSub - , offsetShiftL - , offsetShiftR - , sizeCast - , sizeLastOffset - , sizeAsOffset - , sizeSub - , offsetAsSize - , (+.) - , (.==#) - , CountOf(..) - , Size8 - , sizeOfE - , csizeOfOffset - , csizeOfSize - , sizeOfCSSize - , sizeOfCSize - ) where - -#include "MachDeps.h" - -import GHC.Types -import GHC.Word -import GHC.Int -import GHC.Prim -import Foreign.C.Types -import System.Posix.Types (CSsize (..)) -import Data.Bits -import Foundation.Internal.Base -import Foundation.Internal.Proxy -import Foundation.Numerical.Primitives -import Foundation.Numerical.Number -import Foundation.Numerical.Additive -import Foundation.Numerical.Subtractive -import Foundation.Numerical.Multiplicative -import Foundation.Primitive.IntegralConv -import Data.List (foldl') -import qualified Prelude - -#if WORD_SIZE_IN_BITS < 64 -import GHC.IntWord64 -#endif - --- $setup --- >>> import Foundation.Array.Unboxed - --- | 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 (intToWord i) -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 :: Size8 -> 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 :: Size8 -> Size8 -> 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) - | m > n = 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 in bytes. -type Size8 = CountOf Word8 - --- | 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 (intToWord i) - -instance Additive (CountOf ty) where - azero = CountOf 0 - (+) (CountOf a) (CountOf b) = CountOf (a+b) - -instance Subtractive (CountOf ty) where - type Difference (CountOf ty) = CountOf ty - (CountOf a) - (CountOf b) = CountOf (a-b) - -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 :: Size8 -> CountOf ty -> Size8 -sizeOfE (CountOf sz) (CountOf ty) = CountOf (ty * sz) - --- 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 :: Size8 -> 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 -> Size8 -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 -> Size8 -#if WORD_SIZE_IN_BITS < 64 -sizeOfCSize (CSize (W32# sz)) = CountOf (I# (word2Int# sz)) -#else -sizeOfCSize (CSize (W64# sz)) = CountOf (I# (word2Int# sz)) -#endif diff --git a/Foundation/Primitive/Types/Ptr.hs b/Foundation/Primitive/Types/Ptr.hs deleted file mode 100644 --- a/Foundation/Primitive/Types/Ptr.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE MagicHash #-} -module Foundation.Primitive.Types.Ptr - ( Addr(..) - , addrPlus - , addrPlusSz - , addrPlusCSz - , Ptr(..) - , ptrPlus - , ptrPlusSz - , ptrPlusCSz - , castPtr - ) where - -import Foundation.Internal.Base -import Foundation.Primitive.Types.OffsetSize -import GHC.Ptr -import GHC.Prim -import GHC.Types -import Foreign.C.Types - -data Addr = Addr Addr# - deriving (Eq,Ord) - -addrPlus :: Addr -> Offset Word8 -> Addr -addrPlus (Addr addr) (Offset (I# i)) = Addr (plusAddr# addr i) - -addrPlusSz :: Addr -> CountOf Word8 -> Addr -addrPlusSz (Addr addr) (CountOf (I# i)) = Addr (plusAddr# addr i) - -addrPlusCSz :: Addr -> CSize -> Addr -addrPlusCSz addr = addrPlusSz addr . sizeOfCSize - -ptrPlus :: Ptr a -> Offset Word8 -> Ptr a -ptrPlus (Ptr addr) (Offset (I# i)) = Ptr (plusAddr# addr i) - -ptrPlusSz :: Ptr a -> CountOf Word8 -> Ptr a -ptrPlusSz (Ptr addr) (CountOf (I# i)) = Ptr (plusAddr# addr i) - -ptrPlusCSz :: Ptr a -> CSize -> Ptr a -ptrPlusCSz ptr = ptrPlusSz ptr . sizeOfCSize diff --git a/Foundation/Primitive/UArray/Addr.hs b/Foundation/Primitive/UArray/Addr.hs deleted file mode 100644 --- a/Foundation/Primitive/UArray/Addr.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE CPP #-} -module Foundation.Primitive.UArray.Addr - ( findIndexElem - , findIndexPredicate - , foldl - , foldr - , foldl1 - , all - , any - , filter - , primIndex - ) where - -import GHC.Types -import GHC.Prim -import Foundation.Internal.Base -import Foundation.Numerical -import Foundation.Primitive.Types.OffsetSize -import Foundation.Primitive.Types -import Foundation.Primitive.Monad - -type Immutable = Addr# - -primIndex :: PrimType ty => Immutable -> Offset ty -> ty -primIndex = primAddrIndex - -findIndexElem :: PrimType ty => ty -> Immutable -> Offset ty -> Offset ty -> Offset ty -findIndexElem ty ba startIndex endIndex = loop startIndex - where - loop !i - | i < endIndex && t /= ty = loop (i+1) - | otherwise = i - where t = primIndex ba i -{-# INLINE findIndexElem #-} - -findIndexPredicate :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Offset ty -findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex - where - loop !i - | i < endIndex && not found = loop (i+1) - | otherwise = i - where found = predicate (primIndex ba i) -{-# INLINE findIndexPredicate #-} - -foldl :: PrimType ty => (a -> ty -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a -foldl f !initialAcc ba !startIndex !endIndex = loop startIndex initialAcc - where - loop !i !acc - | i == endIndex = acc - | otherwise = loop (i+1) (f acc (primIndex ba i)) -{-# INLINE foldl #-} - -foldr :: PrimType ty => (ty -> a -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a -foldr f !initialAcc ba startIndex endIndex = loop startIndex - where - loop !i - | i == endIndex = initialAcc - | otherwise = primIndex ba i `f` loop (i+1) -{-# INLINE foldr #-} - -foldl1 :: PrimType ty => (ty -> ty -> ty) -> Immutable -> Offset ty -> Offset ty -> ty -foldl1 f ba startIndex endIndex = loop (startIndex+1) (primIndex ba startIndex) - where - loop !i !acc - | i == endIndex = acc - | otherwise = loop (i+1) (f acc (primIndex ba i)) -{-# INLINE foldl1 #-} - -filter :: (PrimMonad prim, PrimType ty) - => (ty -> Bool) -> MutableByteArray# (PrimState prim) -> Immutable -> Offset ty -> Offset ty -> prim (CountOf ty) -filter predicate dst src start end = loop azero start - where - loop !d !s - | s == end = pure (offsetAsSize d) - | predicate v = primMbaWrite dst d v >> loop (d+Offset 1) (s+Offset 1) - | otherwise = loop d (s+Offset 1) - where - v = primIndex src s - -all :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool -all predicate ba start end = loop start - where - loop !i - | i == end = True - | predicate (primIndex ba i) = loop (i+1) - | otherwise = False -{-# INLINE all #-} - -any :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool -any predicate ba start end = loop start - where - loop !i - | i == end = False - | predicate (primIndex ba i) = True - | otherwise = loop (i+1) -{-# INLINE any #-} diff --git a/Foundation/Primitive/UArray/BA.hs b/Foundation/Primitive/UArray/BA.hs deleted file mode 100644 --- a/Foundation/Primitive/UArray/BA.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -module Foundation.Primitive.UArray.BA - ( findIndexElem - , findIndexPredicate - , foldl - , foldr - , foldl1 - , all - , any - , filter - , primIndex - ) where - -import GHC.Types -import GHC.Prim -import Foundation.Internal.Base -import Foundation.Numerical -import Foundation.Primitive.Types.OffsetSize -import Foundation.Primitive.Types -import Foundation.Primitive.Monad - -type Immutable = ByteArray# - -primIndex :: PrimType ty => Immutable -> Offset ty -> ty -primIndex = primBaIndex - -findIndexElem :: PrimType ty => ty -> Immutable -> Offset ty -> Offset ty -> Offset ty -findIndexElem ty ba startIndex endIndex = loop startIndex - where - loop !i - | i < endIndex && t /= ty = loop (i+1) - | otherwise = i - where t = primIndex ba i -{-# INLINE findIndexElem #-} - -findIndexPredicate :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Offset ty -findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex - where - loop !i - | i < endIndex && not found = loop (i+1) - | otherwise = i - where found = predicate (primIndex ba i) -{-# INLINE findIndexPredicate #-} - -foldl :: PrimType ty => (a -> ty -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a -foldl f !initialAcc ba !startIndex !endIndex = loop startIndex initialAcc - where - loop !i !acc - | i == endIndex = acc - | otherwise = loop (i+1) (f acc (primIndex ba i)) -{-# INLINE foldl #-} - -foldr :: PrimType ty => (ty -> a -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a -foldr f !initialAcc ba startIndex endIndex = loop startIndex - where - loop !i - | i == endIndex = initialAcc - | otherwise = primIndex ba i `f` loop (i+1) -{-# INLINE foldr #-} - -foldl1 :: PrimType ty => (ty -> ty -> ty) -> Immutable -> Offset ty -> Offset ty -> ty -foldl1 f ba startIndex endIndex = loop (startIndex+1) (primIndex ba startIndex) - where - loop !i !acc - | i == endIndex = acc - | otherwise = loop (i+1) (f acc (primIndex ba i)) -{-# INLINE foldl1 #-} - -filter :: (PrimMonad prim, PrimType ty) - => (ty -> Bool) -> MutableByteArray# (PrimState prim) -> Immutable -> Offset ty -> Offset ty -> prim (CountOf ty) -filter predicate dst src start end = loop azero start - where - loop !d !s - | s == end = pure (offsetAsSize d) - | predicate v = primMbaWrite dst d v >> loop (d+Offset 1) (s+Offset 1) - | otherwise = loop d (s+Offset 1) - where - v = primIndex src s - -all :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool -all predicate ba start end = loop start - where - loop !i - | i == end = True - | predicate (primIndex ba i) = loop (i+1) - | otherwise = False -{-# INLINE all #-} - -any :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool -any predicate ba start end = loop start - where - loop !i - | i == end = False - | predicate (primIndex ba i) = True - | otherwise = loop (i+1) -{-# INLINE any #-} diff --git a/Foundation/Primitive/UArray/Base.hs b/Foundation/Primitive/UArray/Base.hs deleted file mode 100644 --- a/Foundation/Primitive/UArray/Base.hs +++ /dev/null @@ -1,550 +0,0 @@ -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} -module Foundation.Primitive.UArray.Base - ( MUArray(..) - , UArray(..) - , MUArrayBackend(..) - , UArrayBackend(..) - -- * New mutable array creation - , newUnpinned - , newPinned - , newNative - , new - -- * Pinning status - , isPinned - , isMutablePinned - -- * Mutable array accessor - , unsafeRead - , unsafeWrite - -- * Freezing routines - , unsafeFreezeShrink - , unsafeFreeze - , unsafeThaw - -- * Array accessor - , unsafeIndex - , unsafeIndexer - , onBackend - , onBackendPrim - , onMutableBackend - , unsafeDewrap - , unsafeDewrap2 - -- * Basic lowlevel functions - , empty - , length - , offset - , ValidRange(..) - , offsetsValidRange - , equal - , equalMemcmp - , compare - , copyAt - , unsafeCopyAtRO - , touch - -- * temporary - , pureST - ) where - -import GHC.Prim -import GHC.Types -import GHC.Ptr -import GHC.ST -import Foundation.Internal.Primitive -import Foundation.Primitive.Monad -import Foundation.Primitive.Types -import Foundation.Internal.Base -import qualified Foundation.Primitive.Runtime as Runtime -import Foundation.Internal.Proxy -import qualified Foundation.Boot.List as List -import Foundation.Primitive.Types.OffsetSize -import Foundation.Primitive.FinalPtr -import Foundation.Primitive.NormalForm -import Foundation.Primitive.Block (MutableBlock(..), Block(..)) -import qualified Foundation.Primitive.Block as BLK -import qualified Foundation.Primitive.Block.Base as BLK (touch) -import qualified Foundation.Primitive.Block.Mutable as MBLK -import Foundation.Numerical -import Foundation.System.Bindings.Hs -import Foreign.C.Types -import System.IO.Unsafe (unsafeDupablePerformIO) - --- | A Mutable array of types built on top of GHC primitive. --- --- Element in this array can be modified in place. -data MUArray ty st = MUArray {-# UNPACK #-} !(Offset ty) - {-# UNPACK #-} !(CountOf ty) - !(MUArrayBackend ty st) - -data MUArrayBackend ty st = MUArrayMBA (MutableBlock ty st) | MUArrayAddr (FinalPtr ty) - - --- | An array of type built on top of GHC primitive. --- --- The elements need to have fixed sized and the representation is a --- packed contiguous array in memory that can easily be passed --- to foreign interface -data UArray ty = UArray {-# UNPACK #-} !(Offset ty) - {-# UNPACK #-} !(CountOf ty) - !(UArrayBackend ty) - deriving (Typeable) - -data UArrayBackend ty = UArrayBA !(Block ty) | UArrayAddr !(FinalPtr ty) - deriving (Typeable) - -instance Data ty => Data (UArray ty) where - dataTypeOf _ = arrayType - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - -arrayType :: DataType -arrayType = mkNoRepType "Foundation.UArray" - -instance NormalForm (UArray ty) where - toNormalForm (UArray _ _ !_) = () -instance (PrimType ty, Show ty) => Show (UArray ty) where - show v = show (toList v) -instance (PrimType ty, Eq ty) => Eq (UArray ty) where - (==) = equal -instance (PrimType ty, Ord ty) => Ord (UArray ty) where - {-# SPECIALIZE instance Ord (UArray Word8) #-} - compare = vCompare - -instance PrimType ty => Monoid (UArray ty) where - mempty = empty - mappend = append - mconcat = concat - -instance PrimType ty => IsList (UArray ty) where - type Item (UArray ty) = ty - fromList = vFromList - toList = vToList - -length :: UArray ty -> CountOf ty -length (UArray _ len _) = len -{-# INLINE[1] length #-} - -offset :: UArray ty -> Offset ty -offset (UArray ofs _ _) = ofs -{-# INLINE[1] offset #-} - -data ValidRange ty = ValidRange {-# UNPACK #-} !(Offset ty) {-# UNPACK #-} !(Offset ty) - -offsetsValidRange :: UArray ty -> ValidRange ty -offsetsValidRange (UArray ofs len _) = ValidRange ofs (ofs `offsetPlusE` len) - --- | Return if the array is pinned in memory --- --- note that Foreign array are considered pinned -isPinned :: UArray ty -> PinnedStatus -isPinned (UArray _ _ (UArrayAddr {})) = Pinned -isPinned (UArray _ _ (UArrayBA blk)) = BLK.isPinned blk - --- | Return if a mutable array is pinned in memory -isMutablePinned :: MUArray ty st -> PinnedStatus -isMutablePinned (MUArray _ _ (MUArrayAddr {})) = Pinned -isMutablePinned (MUArray _ _ (MUArrayMBA mb)) = BLK.isMutablePinned mb - --- | Create a new pinned mutable array of size @n. --- --- all the cells are uninitialized and could contains invalid values. --- --- All mutable arrays are allocated on a 64 bits aligned addresses -newPinned :: forall prim ty . (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MUArray ty (PrimState prim)) -newPinned n = MUArray 0 n . MUArrayMBA <$> MBLK.newPinned n - -newUnpinned :: forall prim ty . (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MUArray ty (PrimState prim)) -newUnpinned n = MUArray 0 n . MUArrayMBA <$> MBLK.new n - -newNative :: (PrimMonad prim, PrimType ty) - => CountOf ty - -> (MutableByteArray# (PrimState prim) -> prim a) -- ^ move to a MutableBlock - -> prim (a, MUArray ty (PrimState prim)) -newNative n f = do - mb@(MutableBlock mba) <- MBLK.new n - a <- f mba - pure (a, MUArray 0 n (MUArrayMBA mb)) - --- | Create a new mutable array of size @n. --- --- When memory for a new array is allocated, we decide if that memory region --- should be pinned (will not be copied around by GC) or unpinned (can be --- moved around by GC) depending on its size. --- --- You can change the threshold value used by setting the environment variable --- @HS_FOUNDATION_UARRAY_UNPINNED_MAX@. -new :: (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MUArray ty (PrimState prim)) -new sz - | sizeRecast sz <= maxSizeUnpinned = newUnpinned sz - | otherwise = newPinned sz - where - -- Safe to use here: If the value changes during runtime, this will only - -- have an impact on newly created arrays. - maxSizeUnpinned = Runtime.unsafeUArrayUnpinnedMaxSize -{-# INLINE new #-} - --- | read from a cell in a mutable array without bounds checking. --- --- Reading from invalid memory can return unpredictable and invalid values. --- use 'read' if unsure. -unsafeRead :: (PrimMonad prim, PrimType ty) => MUArray ty (PrimState prim) -> Offset ty -> prim ty -unsafeRead (MUArray start _ (MUArrayMBA (MutableBlock mba))) i = primMbaRead mba (start + i) -unsafeRead (MUArray start _ (MUArrayAddr fptr)) i = withFinalPtr fptr $ \(Ptr addr) -> primAddrRead addr (start + i) -{-# INLINE unsafeRead #-} - - --- | write to a cell in a mutable array without bounds checking. --- --- Writing with invalid bounds will corrupt memory and your program will --- become unreliable. use 'write' if unsure. -unsafeWrite :: (PrimMonad prim, PrimType ty) => MUArray ty (PrimState prim) -> Offset ty -> ty -> prim () -unsafeWrite (MUArray start _ (MUArrayMBA mb)) i v = MBLK.unsafeWrite mb (start+i) v -unsafeWrite (MUArray start _ (MUArrayAddr fptr)) i v = withFinalPtr fptr $ \(Ptr addr) -> primAddrWrite addr (start+i) v -{-# INLINE unsafeWrite #-} - --- | Return the element at a specific index from an array without bounds checking. --- --- Reading from invalid memory can return unpredictable and invalid values. --- use 'index' if unsure. -unsafeIndex :: forall ty . PrimType ty => UArray ty -> Offset ty -> ty -unsafeIndex (UArray start _ (UArrayBA ba)) n = BLK.unsafeIndex ba (start + n) -unsafeIndex (UArray start _ (UArrayAddr fptr)) n = withUnsafeFinalPtr fptr (\(Ptr addr) -> return (primAddrIndex addr (start+n)) :: IO ty) -{-# INLINE unsafeIndex #-} - -unsafeIndexer :: (PrimMonad prim, PrimType ty) => UArray ty -> ((Offset ty -> ty) -> prim a) -> prim a -unsafeIndexer (UArray start _ (UArrayBA ba)) f = f (\n -> BLK.unsafeIndex ba (start + n)) -unsafeIndexer (UArray start _ (UArrayAddr fptr)) f = withFinalPtr fptr $ \(Ptr addr) -> f (\n -> primAddrIndex addr (start + n)) -{-# INLINE unsafeIndexer #-} - --- | Freeze a mutable array into an array. --- --- the MUArray must not be changed after freezing. -unsafeFreeze :: PrimMonad prim => MUArray ty (PrimState prim) -> prim (UArray ty) -unsafeFreeze (MUArray start len (MUArrayMBA mba)) = - UArray start len . UArrayBA <$> MBLK.unsafeFreeze mba -unsafeFreeze (MUArray start len (MUArrayAddr fptr)) = - pure $ UArray start len (UArrayAddr fptr) -{-# INLINE unsafeFreeze #-} - -unsafeFreezeShrink :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> CountOf ty -> prim (UArray ty) -unsafeFreezeShrink (MUArray start _ backend) n = unsafeFreeze (MUArray start n backend) -{-# INLINE unsafeFreezeShrink #-} - --- | Thaw an immutable array. --- --- The UArray must not be used after thawing. -unsafeThaw :: (PrimType ty, PrimMonad prim) => UArray ty -> prim (MUArray ty (PrimState prim)) -unsafeThaw (UArray start len (UArrayBA blk)) = MUArray start len . MUArrayMBA <$> BLK.unsafeThaw blk -unsafeThaw (UArray start len (UArrayAddr fptr)) = pure $ MUArray start len (MUArrayAddr fptr) -{-# INLINE unsafeThaw #-} - -onBackend :: (ByteArray# -> a) - -> (FinalPtr ty -> Ptr ty -> ST s a) - -> UArray ty - -> a -onBackend onBa _ (UArray _ _ (UArrayBA (Block ba))) = onBa ba -onBackend _ onAddr (UArray _ _ (UArrayAddr fptr)) = withUnsafeFinalPtr fptr (onAddr fptr) -{-# INLINE onBackend #-} - -onBackendPrim :: PrimMonad prim - => (ByteArray# -> prim a) - -> (FinalPtr ty -> prim a) - -> UArray ty - -> prim a -onBackendPrim onBa _ (UArray _ _ (UArrayBA (Block ba))) = onBa ba -onBackendPrim _ onAddr (UArray _ _ (UArrayAddr fptr)) = onAddr fptr -{-# INLINE onBackendPrim #-} - -onMutableBackend :: PrimMonad prim - => (MutableByteArray# (PrimState prim) -> prim a) - -> (FinalPtr ty -> prim a) - -> MUArray ty (PrimState prim) - -> prim a -onMutableBackend onMba _ (MUArray _ _ (MUArrayMBA (MutableBlock mba))) = onMba mba -onMutableBackend _ onAddr (MUArray _ _ (MUArrayAddr fptr)) = onAddr fptr -{-# INLINE onMutableBackend #-} - - -unsafeDewrap :: (ByteArray# -> Offset ty -> a) - -> (Ptr ty -> Offset ty -> ST s a) - -> UArray ty - -> a -unsafeDewrap _ g (UArray start _ (UArrayAddr fptr)) = withUnsafeFinalPtr fptr $ \ptr -> g ptr start -unsafeDewrap f _ (UArray start _ (UArrayBA (Block ba))) = f ba start -{-# INLINE unsafeDewrap #-} - -unsafeDewrap2 :: (ByteArray# -> ByteArray# -> a) - -> (Ptr ty -> Ptr ty -> ST s a) - -> (ByteArray# -> Ptr ty -> ST s a) - -> (Ptr ty -> ByteArray# -> ST s a) - -> UArray ty - -> UArray ty - -> a -unsafeDewrap2 f g h i (UArray _ _ back1) (UArray _ _ back2) = - case (back1, back2) of - (UArrayBA (Block ba1), UArrayBA (Block ba2)) -> f ba1 ba2 - (UArrayAddr fptr1, UArrayAddr fptr2) -> withUnsafeFinalPtr fptr1 $ \ptr1 -> withFinalPtr fptr2 $ \ptr2 -> g ptr1 ptr2 - (UArrayBA (Block ba1), UArrayAddr fptr2) -> withUnsafeFinalPtr fptr2 $ \ptr2 -> h ba1 ptr2 - (UArrayAddr fptr1, UArrayBA (Block ba2)) -> withUnsafeFinalPtr fptr1 $ \ptr1 -> i ptr1 ba2 -{-# INLINE [2] unsafeDewrap2 #-} - -pureST :: a -> ST s a -pureST = pure - --- | make an array from a list of elements. -vFromList :: PrimType ty => [ty] -> UArray ty -vFromList l = runST $ do - ma <- new (CountOf len) - iter azero l $ \i x -> unsafeWrite ma i x - unsafeFreeze ma - where len = List.length l - iter _ [] _ = return () - iter !i (x:xs) z = z i x >> iter (i+1) xs z - --- | transform an array to a list. -vToList :: forall ty . PrimType ty => UArray ty -> [ty] -vToList a - | len == 0 = [] - | otherwise = unsafeDewrap goBa goPtr a - where - !len = length a - goBa ba start = loop start - where - !end = start `offsetPlusE` len - loop !i | i == end = [] - | otherwise = primBaIndex ba i : loop (i+1) - goPtr (Ptr addr) start = pureST (loop start) - where - !end = start `offsetPlusE` len - loop !i | i == end = [] - | otherwise = primAddrIndex addr i : loop (i+1) - --- | Check if two vectors are identical -equal :: (PrimType ty, Eq ty) => UArray ty -> UArray ty -> Bool -equal a b - | la /= lb = False - | otherwise = unsafeDewrap2 goBaBa goPtrPtr goBaPtr goPtrBa a b - where - !start1 = offset a - !start2 = offset b - !end = start1 `offsetPlusE` la - !la = length a - !lb = length b - goBaBa ba1 ba2 = loop start1 start2 - where - loop !i !o | i == end = True - | otherwise = primBaIndex ba1 i == primBaIndex ba2 o && loop (i+o1) (o+o1) - goPtrPtr (Ptr addr1) (Ptr addr2) = pureST (loop start1 start2) - where - loop !i !o | i == end = True - | otherwise = primAddrIndex addr1 i == primAddrIndex addr2 o && loop (i+o1) (o+o1) - goBaPtr ba1 (Ptr addr2) = pureST (loop start1 start2) - where - loop !i !o | i == end = True - | otherwise = primBaIndex ba1 i == primAddrIndex addr2 o && loop (i+o1) (o+o1) - goPtrBa (Ptr addr1) ba2 = pureST (loop start1 start2) - where - loop !i !o | i == end = True - | otherwise = primAddrIndex addr1 i == primBaIndex ba2 o && loop (i+o1) (o+o1) - - o1 = Offset (I# 1#) -{-# RULES "UArray/Eq/Word8" [3] equal = equalBytes #-} -{-# INLINEABLE [2] equal #-} - -equalBytes :: UArray Word8 -> UArray Word8 -> Bool -equalBytes a b - | la /= lb = False - | otherwise = memcmp a b (sizeInBytes la) == 0 - where - !la = length a - !lb = length b - -equalMemcmp :: PrimType ty => UArray ty -> UArray ty -> Bool -equalMemcmp a b - | la /= lb = False - | otherwise = memcmp a b (sizeInBytes la) == 0 - where - !la = length a - !lb = length b - --- | Compare 2 vectors -vCompare :: (Ord ty, PrimType ty) => UArray ty -> UArray ty -> Ordering -vCompare a@(UArray start1 la _) b@(UArray start2 lb _) = unsafeDewrap2 goBaBa goPtrPtr goBaPtr goPtrBa a b - where - !end = start1 `offsetPlusE` min la lb - o1 = Offset (I# 1#) - goBaBa ba1 ba2 = loop start1 start2 - where - loop !i !o | i == end = la `compare` lb - | v1 == v2 = loop (i + o1) (o + o1) - | otherwise = v1 `compare` v2 - where v1 = primBaIndex ba1 i - v2 = primBaIndex ba2 o - goPtrPtr (Ptr addr1) (Ptr addr2) = pureST (loop start1 start2) - where - loop !i !o | i == end = la `compare` lb - | v1 == v2 = loop (i + o1) (o + o1) - | otherwise = v1 `compare` v2 - where v1 = primAddrIndex addr1 i - v2 = primAddrIndex addr2 o - goBaPtr ba1 (Ptr addr2) = pureST (loop start1 start2) - where - loop !i !o | i == end = la `compare` lb - | v1 == v2 = loop (i + o1) (o + o1) - | otherwise = v1 `compare` v2 - where v1 = primBaIndex ba1 i - v2 = primAddrIndex addr2 o - goPtrBa (Ptr addr1) ba2 = pureST (loop start1 start2) - where - loop !i !o | i == end = la `compare` lb - | v1 == v2 = loop (i + o1) (o + o1) - | otherwise = v1 `compare` v2 - where v1 = primAddrIndex addr1 i - v2 = primBaIndex ba2 o --- {-# SPECIALIZE [3] vCompare :: UArray Word8 -> UArray Word8 -> Ordering = vCompareBytes #-} -{-# RULES "UArray/Ord/Word8" [3] vCompare = vCompareBytes #-} -{-# INLINEABLE [2] vCompare #-} - -vCompareBytes :: UArray Word8 -> UArray Word8 -> Ordering -vCompareBytes = vCompareMemcmp - -vCompareMemcmp :: (Ord ty, PrimType ty) => UArray ty -> UArray ty -> Ordering -vCompareMemcmp a b = cintToOrdering $ memcmp a b sz - where - la = length a - lb = length b - sz = sizeInBytes $ min la lb - cintToOrdering :: CInt -> Ordering - cintToOrdering 0 = la `compare` lb - cintToOrdering r | r < 0 = LT - | otherwise = GT -{-# SPECIALIZE [3] vCompareMemcmp :: UArray Word8 -> UArray Word8 -> Ordering #-} - -memcmp :: PrimType ty => UArray ty -> UArray ty -> CountOf Word8 -> CInt -memcmp a@(UArray (offsetInBytes -> o1) _ _) b@(UArray (offsetInBytes -> o2) _ _) sz = unsafeDewrap2 - (\s1 s2 -> unsafeDupablePerformIO $ sysHsMemcmpBaBa s1 o1 s2 o2 sz) - (\s1 s2 -> unsafePrimToST $ sysHsMemcmpPtrPtr s1 o1 s2 o2 sz) - (\s1 s2 -> unsafePrimToST $ sysHsMemcmpBaPtr s1 o1 s2 o2 sz) - (\s1 s2 -> unsafePrimToST $ sysHsMemcmpPtrBa s1 o1 s2 o2 sz) - a b -{-# SPECIALIZE [3] memcmp :: UArray Word8 -> UArray Word8 -> CountOf Word8 -> CInt #-} - --- | Copy a number of elements from an array to another array with offsets -copyAt :: forall prim ty . (PrimMonad prim, PrimType ty) - => MUArray ty (PrimState prim) -- ^ destination array - -> Offset ty -- ^ offset at destination - -> MUArray ty (PrimState prim) -- ^ source array - -> Offset ty -- ^ offset at source - -> CountOf ty -- ^ number of elements to copy - -> prim () -copyAt (MUArray dstStart _ (MUArrayMBA (MutableBlock dstMba))) ed (MUArray srcStart _ (MUArrayMBA (MutableBlock srcBa))) es n = - primitive $ \st -> (# copyMutableByteArray# srcBa os dstMba od nBytes st, () #) - where - !sz = primSizeInBytes (Proxy :: Proxy ty) - !(Offset (I# os)) = offsetOfE sz (srcStart + es) - !(Offset (I# od)) = offsetOfE sz (dstStart + ed) - !(CountOf (I# nBytes)) = sizeOfE sz n -copyAt (MUArray dstStart _ (MUArrayMBA (MutableBlock dstMba))) ed (MUArray srcStart _ (MUArrayAddr srcFptr)) es n = - withFinalPtr srcFptr $ \srcPtr -> - let !(Ptr srcAddr) = srcPtr `plusPtr` os - in primitive $ \s -> (# compatCopyAddrToByteArray# srcAddr dstMba od nBytes s, () #) - where - !sz = primSizeInBytes (Proxy :: Proxy ty) - !(Offset os) = offsetOfE sz (srcStart + es) - !(Offset (I# od)) = offsetOfE sz (dstStart + ed) - !(CountOf (I# nBytes)) = sizeOfE sz n -copyAt dst od src os n = loop od os - where - !endIndex = os `offsetPlusE` n - loop !d !i - | i == endIndex = return () - | otherwise = unsafeRead src i >>= unsafeWrite dst d >> loop (d+1) (i+1) - --- TODO Optimise with copyByteArray# --- | Copy @n@ sequential elements from the specified offset in a source array --- to the specified position in a destination array. --- --- This function does not check bounds. Accessing invalid memory can return --- unpredictable and invalid values. -unsafeCopyAtRO :: forall prim ty . (PrimMonad prim, PrimType ty) - => MUArray ty (PrimState prim) -- ^ destination array - -> Offset ty -- ^ offset at destination - -> UArray ty -- ^ source array - -> Offset ty -- ^ offset at source - -> CountOf ty -- ^ number of elements to copy - -> prim () -unsafeCopyAtRO (MUArray dstStart _ (MUArrayMBA (MutableBlock dstMba))) ed (UArray srcStart _ (UArrayBA (Block srcBa))) es n = - primitive $ \st -> (# copyByteArray# srcBa os dstMba od nBytes st, () #) - where - sz = primSizeInBytes (Proxy :: Proxy ty) - !(Offset (I# os)) = offsetOfE sz (srcStart+es) - !(Offset (I# od)) = offsetOfE sz (dstStart+ed) - !(CountOf (I# nBytes)) = sizeOfE sz n -unsafeCopyAtRO (MUArray dstStart _ (MUArrayMBA (MutableBlock dstMba))) ed (UArray srcStart _ (UArrayAddr srcFptr)) es n = - withFinalPtr srcFptr $ \srcPtr -> - let !(Ptr srcAddr) = srcPtr `plusPtr` os - in primitive $ \s -> (# compatCopyAddrToByteArray# srcAddr dstMba od nBytes s, () #) - where - sz = primSizeInBytes (Proxy :: Proxy ty) - !(Offset os) = offsetOfE sz (srcStart+es) - !(Offset (I# od)) = offsetOfE sz (dstStart+ed) - !(CountOf (I# nBytes)) = sizeOfE sz n -unsafeCopyAtRO dst od src os n = loop od os - where - !endIndex = os `offsetPlusE` n - loop d i - | i == endIndex = return () - | otherwise = unsafeWrite dst d (unsafeIndex src i) >> loop (d+1) (i+1) - -empty_ :: Block () -empty_ = runST $ primitive $ \s1 -> - case newByteArray# 0# s1 of { (# s2, mba #) -> - case unsafeFreezeByteArray# mba s2 of { (# s3, ba #) -> - (# s3, Block ba #) }} - -empty :: UArray ty -empty = UArray 0 0 (UArrayBA $ Block ba) where !(Block ba) = empty_ - --- | Append 2 arrays together by creating a new bigger array -append :: PrimType ty => UArray ty -> UArray ty -> UArray ty -append a b - | la == azero = b - | lb == azero = a - | otherwise = runST $ do - r <- new (la+lb) - ma <- unsafeThaw a - mb <- unsafeThaw b - copyAt r (Offset 0) ma (Offset 0) la - copyAt r (sizeAsOffset la) mb (Offset 0) lb - unsafeFreeze r - where - !la = length a - !lb = length b - -concat :: PrimType ty => [UArray ty] -> UArray ty -concat [] = empty -concat l = - case filterAndSum (CountOf 0) [] l of - (_,[]) -> empty - (_,[x]) -> x - (totalLen,chunks) -> runST $ do - r <- new totalLen - doCopy r (Offset 0) chunks - unsafeFreeze r - where - -- TODO would go faster not to reverse but pack from the end instead - filterAndSum !totalLen acc [] = (totalLen, List.reverse acc) - filterAndSum !totalLen acc (x:xs) - | len == CountOf 0 = filterAndSum totalLen acc xs - | otherwise = filterAndSum (len+totalLen) (x:acc) xs - where len = length x - - doCopy _ _ [] = return () - doCopy r i (x:xs) = do - unsafeCopyAtRO r i x (Offset 0) lx - doCopy r (i `offsetPlusE` lx) xs - where lx = length x - -touch :: PrimMonad prim => UArray ty -> prim () -touch (UArray _ _ (UArrayBA blk)) = BLK.touch blk -touch (UArray _ _ (UArrayAddr fptr)) = touchFinalPtr fptr diff --git a/Foundation/Primitive/UTF8/Addr.hs b/Foundation/Primitive/UTF8/Addr.hs deleted file mode 100644 --- a/Foundation/Primitive/UTF8/Addr.hs +++ /dev/null @@ -1,244 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -module Foundation.Primitive.UTF8.Addr - ( Immutable - , Mutable - -- * functions - , nextAscii - , nextAsciiDigit - , expectAscii - , next - , prev - , prevSkip - , write - , toList - , all - , any - , foldr - , length - -- temporary - , primIndex - , primIndex64 - , primRead - , primWrite - ) where - -import GHC.Int -import GHC.Types -import GHC.Word -import GHC.Prim -import Data.Bits -import Foundation.Internal.Base hiding (toList) -import Foundation.Internal.Primitive -import Foundation.Internal.Proxy -import Foundation.Numerical -import Foundation.Primitive.Types.OffsetSize -import Foundation.Primitive.Monad -import Foundation.Primitive.Types -import Foundation.Primitive.UTF8.Helper -import Foundation.Primitive.UTF8.Table -import Foundation.Primitive.UTF8.Types - -type Immutable = Addr# -type Mutable (prim :: * -> *) = Addr# - -primWrite :: PrimMonad prim => Mutable prim -> Offset Word8 -> Word8 -> prim () -primWrite = primAddrWrite - -primRead :: PrimMonad prim => Mutable prim -> Offset Word8 -> prim Word8 -primRead = primAddrRead - -primIndex :: Immutable -> Offset Word8 -> Word8 -primIndex = primAddrIndex - -primIndex64 :: Immutable -> Offset Word64 -> Word64 -primIndex64 = primAddrIndex - -nextAscii :: Immutable -> Offset Word8 -> StepASCII -nextAscii ba n = StepASCII w - where - !w = primIndex ba n -{-# INLINE nextAscii #-} - --- | nextAsciiBa specialized to get a digit between 0 and 9 (included) -nextAsciiDigit :: Immutable -> Offset Word8 -> StepDigit -nextAsciiDigit ba n = StepDigit (primIndex ba n - 0x30) -{-# INLINE nextAsciiDigit #-} - -expectAscii :: Immutable -> Offset Word8 -> Word8 -> Bool -expectAscii ba n v = primIndex ba n == v -{-# INLINE expectAscii #-} - -next :: Immutable -> Offset8 -> Step -next ba n = - case getNbBytes h of - 0 -> Step (toChar1 h) (n + Offset 1) - 1 -> Step (toChar2 h (primIndex ba (n + Offset 1))) (n + Offset 2) - 2 -> Step (toChar3 h (primIndex ba (n + Offset 1)) - (primIndex ba (n + Offset 2))) (n + Offset 3) - 3 -> Step (toChar4 h (primIndex ba (n + Offset 1)) - (primIndex ba (n + Offset 2)) - (primIndex ba (n + Offset 3))) (n + Offset 4) - r -> error ("next: internal error: invalid input: offset=" <> show n <> " table=" <> show r <> " h=" <> show h) - where - !h = primIndex ba n -{-# INLINE next #-} - --- Given a non null offset, give the previous character and the offset of this character --- will fail bad if apply at the beginning of string or an empty string. -prev :: Immutable -> Offset Word8 -> StepBack -prev ba offset = - case primIndex ba prevOfs1 of - (W8# v1) | isContinuation# v1 -> atLeast2 (maskContinuation# v1) - | otherwise -> StepBack (toChar# v1) prevOfs1 - where - sz1 = CountOf 1 - !prevOfs1 = offset `offsetMinusE` sz1 - prevOfs2 = prevOfs1 `offsetMinusE` sz1 - prevOfs3 = prevOfs2 `offsetMinusE` sz1 - prevOfs4 = prevOfs3 `offsetMinusE` sz1 - atLeast2 !v = - case primIndex ba prevOfs2 of - (W8# v2) | isContinuation# v2 -> atLeast3 (or# (uncheckedShiftL# (maskContinuation# v2) 6#) v) - | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader2# v2) 6#) v)) prevOfs2 - atLeast3 !v = - case primIndex ba prevOfs3 of - (W8# v3) | isContinuation# v3 -> atLeast4 (or# (uncheckedShiftL# (maskContinuation# v3) 12#) v) - | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader3# v3) 12#) v)) prevOfs3 - atLeast4 !v = - case primIndex ba prevOfs4 of - (W8# v4) -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader4# v4) 18#) v)) prevOfs4 - -prevSkip :: Immutable -> Offset Word8 -> Offset Word8 -prevSkip ba offset = loop (offset `offsetMinusE` sz1) - where - sz1 = CountOf 1 - loop o - | isContinuation (primIndex ba o) = loop (o `offsetMinusE` sz1) - | otherwise = o - -write :: PrimMonad prim => Mutable prim -> Offset8 -> Char -> prim Offset8 -write mba !i !c - | bool# (ltWord# x 0x80## ) = encode1 - | bool# (ltWord# x 0x800## ) = encode2 - | bool# (ltWord# x 0x10000##) = encode3 - | otherwise = encode4 - where - !(I# xi) = fromEnum c - !x = int2Word# xi - - encode1 = primWrite mba i (W8# x) >> pure (i + Offset 1) - encode2 = do - let x1 = or# (uncheckedShiftRL# x 6#) 0xc0## - x2 = toContinuation x - primWrite mba i (W8# x1) - primWrite mba (i+1) (W8# x2) - pure (i + Offset 2) - - encode3 = do - let x1 = or# (uncheckedShiftRL# x 12#) 0xe0## - x2 = toContinuation (uncheckedShiftRL# x 6#) - x3 = toContinuation x - primWrite mba i (W8# x1) - primWrite mba (i+Offset 1) (W8# x2) - primWrite mba (i+Offset 2) (W8# x3) - pure (i + Offset 3) - - encode4 = do - let x1 = or# (uncheckedShiftRL# x 18#) 0xf0## - x2 = toContinuation (uncheckedShiftRL# x 12#) - x3 = toContinuation (uncheckedShiftRL# x 6#) - x4 = toContinuation x - primWrite mba i (W8# x1) - primWrite mba (i+Offset 1) (W8# x2) - primWrite mba (i+Offset 2) (W8# x3) - primWrite mba (i+Offset 3) (W8# x4) - pure (i + Offset 4) - - toContinuation :: Word# -> Word# - toContinuation w = or# (and# w 0x3f##) 0x80## -{-# INLINE write #-} - -toList :: Immutable -> Offset Word8 -> Offset Word8 -> [Char] -toList ba !start !end = loop start - where - loop !idx - | idx == end = [] - | otherwise = c : loop idx' - where (Step c idx') = next ba idx - -all :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool -all predicate ba start end = loop start - where - loop !idx - | idx == end = True - | predicate c = loop idx' - | otherwise = False - where (Step c idx') = next ba idx -{-# INLINE all #-} - -any :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool -any predicate ba start end = loop start - where - loop !idx - | idx == end = False - | predicate c = True - | otherwise = loop idx' - where (Step c idx') = next ba idx -{-# INLINE any #-} - -foldr :: Immutable -> Offset Word8 -> Offset Word8 -> (Char -> a -> a) -> a -> a -foldr dat start end f acc = loop start - where - loop !i - | i == end = acc - | otherwise = - let (Step c i') = next dat i - in c `f` loop i' -{-# INLINE foldr #-} - -length :: Immutable -> Offset Word8 -> Offset Word8 -> CountOf Char -length dat start end - | start == end = 0 - | otherwise = processStart 0 start - where - end64 :: Offset Word64 - end64 = offsetInElements end - - prx64 :: Proxy Word64 - prx64 = Proxy - - mask64_80 :: Word64 - mask64_80 = 0x8080808080808080 - - processStart :: CountOf Char -> Offset Word8 -> CountOf Char - processStart !c !i - | i == end = c - | offsetIsAligned prx64 i = processAligned c (offsetInElements i) - | otherwise = - let h = primIndex dat i - cont = (h .&. 0xc0) == 0x80 - c' = if cont then c else c+1 - in processStart c' (i+1) - processAligned :: CountOf Char -> Offset Word64 -> CountOf Char - processAligned !c !i - | i >= end64 = processEnd c (offsetInBytes i) - | otherwise = - let !h = primIndex64 dat i - !h80 = h .&. mask64_80 - in if h80 == 0 - then processAligned (c+8) (i+1) - else let !nbAscii = if h80 == mask64_80 then 0 else CountOf (8 - popCount h80) - !nbHigh = CountOf $ popCount (h .&. (h80 `unsafeShiftR` 1)) - in processAligned (c + nbAscii + nbHigh) (i+1) - processEnd !c !i - | i == end = c - | otherwise = - let h = primIndex dat i - cont = (h .&. 0xc0) == 0x80 - c' = if cont then c else c+1 - in processStart c' (i+1) -{-# INLINE length #-} diff --git a/Foundation/Primitive/UTF8/BA.hs b/Foundation/Primitive/UTF8/BA.hs deleted file mode 100644 --- a/Foundation/Primitive/UTF8/BA.hs +++ /dev/null @@ -1,244 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -module Foundation.Primitive.UTF8.BA - ( Immutable - , Mutable - -- * functions - , nextAscii - , nextAsciiDigit - , expectAscii - , next - , prev - , prevSkip - , write - , toList - , all - , any - , foldr - , length - -- temporary - , primIndex - , primIndex64 - , primRead - , primWrite - ) where - -import GHC.Int -import GHC.Types -import GHC.Word -import GHC.Prim -import Data.Bits -import Foundation.Internal.Base hiding (toList) -import Foundation.Internal.Primitive -import Foundation.Internal.Proxy -import Foundation.Numerical -import Foundation.Primitive.Types.OffsetSize -import Foundation.Primitive.Monad -import Foundation.Primitive.Types -import Foundation.Primitive.UTF8.Helper -import Foundation.Primitive.UTF8.Table -import Foundation.Primitive.UTF8.Types - -type Immutable = ByteArray# -type Mutable prim = MutableByteArray# (PrimState prim) - -primWrite :: PrimMonad prim => Mutable prim -> Offset Word8 -> Word8 -> prim () -primWrite = primMbaWrite - -primRead :: PrimMonad prim => Mutable prim -> Offset Word8 -> prim Word8 -primRead = primMbaRead - -primIndex :: Immutable -> Offset Word8 -> Word8 -primIndex = primBaIndex - -primIndex64 :: Immutable -> Offset Word64 -> Word64 -primIndex64 = primBaIndex - -nextAscii :: Immutable -> Offset Word8 -> StepASCII -nextAscii ba n = StepASCII w - where - !w = primIndex ba n -{-# INLINE nextAscii #-} - --- | nextAsciiBa specialized to get a digit between 0 and 9 (included) -nextAsciiDigit :: Immutable -> Offset Word8 -> StepDigit -nextAsciiDigit ba n = StepDigit (primIndex ba n - 0x30) -{-# INLINE nextAsciiDigit #-} - -expectAscii :: Immutable -> Offset Word8 -> Word8 -> Bool -expectAscii ba n v = primIndex ba n == v -{-# INLINE expectAscii #-} - -next :: Immutable -> Offset8 -> Step -next ba n = - case getNbBytes h of - 0 -> Step (toChar1 h) (n + Offset 1) - 1 -> Step (toChar2 h (primIndex ba (n + Offset 1))) (n + Offset 2) - 2 -> Step (toChar3 h (primIndex ba (n + Offset 1)) - (primIndex ba (n + Offset 2))) (n + Offset 3) - 3 -> Step (toChar4 h (primIndex ba (n + Offset 1)) - (primIndex ba (n + Offset 2)) - (primIndex ba (n + Offset 3))) (n + Offset 4) - r -> error ("next: internal error: invalid input: offset=" <> show n <> " table=" <> show r <> " h=" <> show h) - where - !h = primIndex ba n -{-# INLINE next #-} - --- Given a non null offset, give the previous character and the offset of this character --- will fail bad if apply at the beginning of string or an empty string. -prev :: Immutable -> Offset Word8 -> StepBack -prev ba offset = - case primIndex ba prevOfs1 of - (W8# v1) | isContinuation# v1 -> atLeast2 (maskContinuation# v1) - | otherwise -> StepBack (toChar# v1) prevOfs1 - where - sz1 = CountOf 1 - !prevOfs1 = offset `offsetMinusE` sz1 - prevOfs2 = prevOfs1 `offsetMinusE` sz1 - prevOfs3 = prevOfs2 `offsetMinusE` sz1 - prevOfs4 = prevOfs3 `offsetMinusE` sz1 - atLeast2 !v = - case primIndex ba prevOfs2 of - (W8# v2) | isContinuation# v2 -> atLeast3 (or# (uncheckedShiftL# (maskContinuation# v2) 6#) v) - | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader2# v2) 6#) v)) prevOfs2 - atLeast3 !v = - case primIndex ba prevOfs3 of - (W8# v3) | isContinuation# v3 -> atLeast4 (or# (uncheckedShiftL# (maskContinuation# v3) 12#) v) - | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader3# v3) 12#) v)) prevOfs3 - atLeast4 !v = - case primIndex ba prevOfs4 of - (W8# v4) -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader4# v4) 18#) v)) prevOfs4 - -prevSkip :: Immutable -> Offset Word8 -> Offset Word8 -prevSkip ba offset = loop (offset `offsetMinusE` sz1) - where - sz1 = CountOf 1 - loop o - | isContinuation (primIndex ba o) = loop (o `offsetMinusE` sz1) - | otherwise = o - -write :: PrimMonad prim => Mutable prim -> Offset8 -> Char -> prim Offset8 -write mba !i !c - | bool# (ltWord# x 0x80## ) = encode1 - | bool# (ltWord# x 0x800## ) = encode2 - | bool# (ltWord# x 0x10000##) = encode3 - | otherwise = encode4 - where - !(I# xi) = fromEnum c - !x = int2Word# xi - - encode1 = primWrite mba i (W8# x) >> pure (i + Offset 1) - encode2 = do - let x1 = or# (uncheckedShiftRL# x 6#) 0xc0## - x2 = toContinuation x - primWrite mba i (W8# x1) - primWrite mba (i+1) (W8# x2) - pure (i + Offset 2) - - encode3 = do - let x1 = or# (uncheckedShiftRL# x 12#) 0xe0## - x2 = toContinuation (uncheckedShiftRL# x 6#) - x3 = toContinuation x - primWrite mba i (W8# x1) - primWrite mba (i+Offset 1) (W8# x2) - primWrite mba (i+Offset 2) (W8# x3) - pure (i + Offset 3) - - encode4 = do - let x1 = or# (uncheckedShiftRL# x 18#) 0xf0## - x2 = toContinuation (uncheckedShiftRL# x 12#) - x3 = toContinuation (uncheckedShiftRL# x 6#) - x4 = toContinuation x - primWrite mba i (W8# x1) - primWrite mba (i+Offset 1) (W8# x2) - primWrite mba (i+Offset 2) (W8# x3) - primWrite mba (i+Offset 3) (W8# x4) - pure (i + Offset 4) - - toContinuation :: Word# -> Word# - toContinuation w = or# (and# w 0x3f##) 0x80## -{-# INLINE write #-} - -toList :: Immutable -> Offset Word8 -> Offset Word8 -> [Char] -toList ba !start !end = loop start - where - loop !idx - | idx == end = [] - | otherwise = c : loop idx' - where (Step c idx') = next ba idx - -all :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool -all predicate ba start end = loop start - where - loop !idx - | idx == end = True - | predicate c = loop idx' - | otherwise = False - where (Step c idx') = next ba idx -{-# INLINE all #-} - -any :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool -any predicate ba start end = loop start - where - loop !idx - | idx == end = False - | predicate c = True - | otherwise = loop idx' - where (Step c idx') = next ba idx -{-# INLINE any #-} - -foldr :: Immutable -> Offset Word8 -> Offset Word8 -> (Char -> a -> a) -> a -> a -foldr dat start end f acc = loop start - where - loop !i - | i == end = acc - | otherwise = - let (Step c i') = next dat i - in c `f` loop i' -{-# INLINE foldr #-} - -length :: Immutable -> Offset Word8 -> Offset Word8 -> CountOf Char -length dat start end - | start == end = 0 - | otherwise = processStart 0 start - where - end64 :: Offset Word64 - end64 = offsetInElements end - - prx64 :: Proxy Word64 - prx64 = Proxy - - mask64_80 :: Word64 - mask64_80 = 0x8080808080808080 - - processStart :: CountOf Char -> Offset Word8 -> CountOf Char - processStart !c !i - | i == end = c - | offsetIsAligned prx64 i = processAligned c (offsetInElements i) - | otherwise = - let h = primIndex dat i - cont = (h .&. 0xc0) == 0x80 - c' = if cont then c else c+1 - in processStart c' (i+1) - processAligned :: CountOf Char -> Offset Word64 -> CountOf Char - processAligned !c !i - | i >= end64 = processEnd c (offsetInBytes i) - | otherwise = - let !h = primIndex64 dat i - !h80 = h .&. mask64_80 - in if h80 == 0 - then processAligned (c+8) (i+1) - else let !nbAscii = if h80 == mask64_80 then 0 else CountOf (8 - popCount h80) - !nbHigh = CountOf $ popCount (h .&. (h80 `unsafeShiftR` 1)) - in processAligned (c + nbAscii + nbHigh) (i+1) - processEnd !c !i - | i == end = c - | otherwise = - let h = primIndex dat i - cont = (h .&. 0xc0) == 0x80 - c' = if cont then c else c+1 - in processStart c' (i+1) -{-# INLINE length #-} diff --git a/Foundation/Primitive/UTF8/Base.hs b/Foundation/Primitive/UTF8/Base.hs deleted file mode 100644 --- a/Foundation/Primitive/UTF8/Base.hs +++ /dev/null @@ -1,176 +0,0 @@ --- | --- Module : Foundation.String.UTF8 --- 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 Foundation.Primitive.UTF8.Base - where - -import GHC.ST (ST, runST) -import GHC.Types -import GHC.Word -import GHC.Prim -import Foundation.Internal.Base -import Foundation.Numerical -import Foundation.Class.Bifunctor -import Foundation.Primitive.NormalForm -import Foundation.Primitive.Types.OffsetSize -import Foundation.Primitive.Monad -import Foundation.Primitive.FinalPtr -import Foundation.Primitive.UTF8.Helper -import Foundation.Primitive.UTF8.Types -import qualified Foundation.Primitive.UTF8.BA as PrimBA -import qualified Foundation.Primitive.UTF8.Addr as PrimAddr -import Foundation.Array.Unboxed (UArray) -import qualified Foundation.Array.Unboxed as Vec -import qualified Foundation.Array.Unboxed as C -import Foundation.Array.Unboxed.ByteArray (MutableByteArray) -import qualified Foundation.Array.Unboxed.Mutable as MVec -import Foundation.Primitive.UArray.Base as Vec (offset, pureST, onBackend) -import Foundation.String.ModifiedUTF8 (fromModified) -import GHC.CString (unpackCString#, unpackCStringUtf8#) - -import Data.Data -import Foundation.Boot.List as List - --- | Opaque packed array of characters in the UTF8 encoding -newtype String = String (UArray Word8) - deriving (Typeable, Monoid, Eq, Ord) - --- | Mutable String Buffer. --- --- Use as an *append* buffer, as UTF8 variable encoding --- doesn't really allow to change previously written --- character without potentially shifting bytes. -newtype MutableString st = MutableString (MutableByteArray st) - deriving (Typeable) - -instance Show String where - show = show . sToList -instance IsString String where - fromString = sFromList -instance IsList String where - type Item String = Char - fromList = sFromList - toList = sToList - -instance Data String where - toConstr s = mkConstr stringType (show s) [] Prefix - dataTypeOf _ = stringType - gunfold _ _ = error "gunfold" - -instance NormalForm String where - toNormalForm (String ba) = toNormalForm ba - -stringType :: DataType -stringType = mkNoRepType "Foundation.String" - --- | size in bytes. --- --- this size is available in o(1) -size :: String -> CountOf Word8 -size (String ba) = Vec.length ba - --- | Convert a String to a list of characters --- --- The list is lazily created as evaluation needed -sToList :: String -> [Char] -sToList s = loop 0 - where - !nbBytes = size s - loop idx - | idx .==# nbBytes = [] - | otherwise = - let !(Step c idx') = next s idx in c : loop idx' - -{-# RULES -"String sFromList" forall s . - sFromList (unpackCString# s) = String $ fromModified s - #-} -{-# RULES -"String sFromList" forall s . - sFromList (unpackCStringUtf8# s) = String $ fromModified s - #-} - --- | Create a new String from a list of characters --- --- The list is strictly and fully evaluated before --- creating the new String, as the size need to be --- computed before filling. -sFromList :: [Char] -> String -sFromList l = runST (new bytes >>= startCopy) - where - -- count how many bytes - !bytes = List.sum $ fmap (charToBytes . fromEnum) l - - startCopy :: MutableString (PrimState (ST st)) -> ST st String - startCopy ms = loop 0 l - where - loop _ [] = freeze ms - loop idx (c:xs) = write ms idx c >>= \idx' -> loop idx' xs -{-# INLINE [0] sFromList #-} - -next :: String -> Offset8 -> Step -next (String array) !n = Vec.onBackend nextNative nextAddr array - where - !start = Vec.offset array - reoffset (Step a ofs) = Step a (ofs `offsetSub` start) - nextNative ba = reoffset (PrimBA.next ba (start + n)) - nextAddr _ (Ptr ptr) = pureST $ reoffset (PrimAddr.next ptr (start + n)) - -prev :: String -> Offset8 -> StepBack -prev (String array) !n = Vec.onBackend prevNative prevAddr array - where - !start = Vec.offset array - reoffset (StepBack a ofs) = StepBack a (ofs `offsetSub` start) - prevNative ba = reoffset (PrimBA.prev ba (start + n)) - prevAddr _ (Ptr ptr) = pureST $ reoffset (PrimAddr.prev ptr (start + n)) - --- A variant of 'next' when you want the next character --- to be ASCII only. -nextAscii :: String -> Offset8 -> StepASCII -nextAscii (String ba) n = StepASCII w - where - !w = Vec.unsafeIndex ba n - -expectAscii :: String -> Offset8 -> Word8 -> Bool -expectAscii (String ba) n v = Vec.unsafeIndex ba n == v -{-# INLINE expectAscii #-} - -write :: PrimMonad prim => MutableString (PrimState prim) -> Offset8 -> Char -> prim Offset8 -write (MutableString marray) ofs c = - MVec.onMutableBackend (\mba -> PrimBA.write mba (start + ofs) c) - (\fptr -> withFinalPtr fptr $ \(Ptr ptr) -> PrimAddr.write ptr (start + ofs) c) - marray - where start = MVec.mutableOffset marray - --- | Allocate a MutableString of a specific size in bytes. -new :: PrimMonad prim - => Size8 -- ^ in number of bytes, not of elements. - -> prim (MutableString (PrimState prim)) -new n = MutableString `fmap` MVec.new n - -newNative :: PrimMonad prim - => CountOf Word8 -- ^ in number of bytes, not of elements. - -> (MutableByteArray# (PrimState prim) -> prim a) - -> prim (a, MutableString (PrimState prim)) -newNative n f = second MutableString `fmap` MVec.newNative n f - -freeze :: PrimMonad prim => MutableString (PrimState prim) -> prim String -freeze (MutableString mba) = String `fmap` C.unsafeFreeze mba -{-# INLINE freeze #-} - -freezeShrink :: PrimMonad prim - => CountOf Word8 - -> MutableString (PrimState prim) - -> prim String -freezeShrink n (MutableString mba) = String `fmap` C.unsafeFreezeShrink mba n diff --git a/Foundation/Primitive/UTF8/Helper.hs b/Foundation/Primitive/UTF8/Helper.hs deleted file mode 100644 --- a/Foundation/Primitive/UTF8/Helper.hs +++ /dev/null @@ -1,147 +0,0 @@ --- | --- Module : Foundation.Primitive.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 Foundation.Primitive.UTF8.Helper - where - -import Foundation.Internal.Base -import Foundation.Internal.Primitive -import Foundation.Primitive.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 -> Size8 -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 -> Size8 -charToBytes c - | c < 0x80 = CountOf 1 - | c < 0x800 = CountOf 2 - | c < 0x10000 = CountOf 3 - | c < 0x110000 = CountOf 4 - | otherwise = error ("invalid code point: " `mappend` show c) diff --git a/Foundation/Primitive/UTF8/Table.hs b/Foundation/Primitive/UTF8/Table.hs deleted file mode 100644 --- a/Foundation/Primitive/UTF8/Table.hs +++ /dev/null @@ -1,82 +0,0 @@ --- | --- Module : Foundation.Primitive.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 Foundation.Primitive.UTF8.Table - ( isContinuation - , getNbBytes - , isContinuation# - , getNbBytes# - ) where - -import GHC.Prim -import GHC.Types -import GHC.Word -import Foundation.Internal.Base - --- | Check if the byte is a continuation byte -isContinuation :: Word8 -> Bool -isContinuation (W8# w) = isContinuation# w -{-# INLINE isContinuation #-} - --- | Get the number of following bytes given the first byte of a UTF8 sequence. -getNbBytes :: Word8 -> Int -getNbBytes (W8# w) = I# (getNbBytes# w) -{-# INLINE getNbBytes #-} - --- | Check if the byte is a continuation byte -isContinuation# :: Word# -> Bool -isContinuation# w = W# (indexWord8OffAddr# (unTable contTable) (word2Int# w)) /= W# 0## -{-# INLINE isContinuation# #-} - --- | Get the number of following bytes given the first byte of a UTF8 sequence. -getNbBytes# :: Word# -> Int# -getNbBytes# w = word2Int# (indexWord8OffAddr# (unTable headTable) (word2Int# w)) -{-# INLINE getNbBytes# #-} - -data Table = Table { unTable :: !Addr# } - -contTable :: Table -contTable = Table - "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ - \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ - \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ - \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# -{-# NOINLINE contTable #-} - -headTable :: Table -headTable = Table - "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ - \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ - \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ - \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ - \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\ - \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\ - \\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\ - \\x03\x03\x03\x03\x03\x03\x03\x03\xff\xff\xff\xff\xff\xff\xff\xff"# -{-# NOINLINE headTable #-} diff --git a/Foundation/Primitive/UTF8/Types.hs b/Foundation/Primitive/UTF8/Types.hs deleted file mode 100644 --- a/Foundation/Primitive/UTF8/Types.hs +++ /dev/null @@ -1,50 +0,0 @@ -module Foundation.Primitive.UTF8.Types - ( - -- * Stepper - Step(..) - , StepBack(..) - , StepASCII(..) - , StepDigit(..) - , isValidStepASCII - , isValidStepDigit - -- * Unicode Errors - , ValidationFailure(..) - ) where - -import Foundation.Internal.Base -import Foundation.Primitive.Types.OffsetSize - --- | Step when walking a String --- --- this is a return value composed of : --- * the unicode code point read (Char) which need to be --- between 0 and 0x10ffff (inclusive) --- * The next offset to start reading the next unicode code point (or end) -data Step = Step {-# UNPACK #-} !Char {-# UNPACK #-} !(Offset Word8) - --- | Similar to Step but used when processing the string from the end. --- --- The stepper is thus the previous character, and the offset of --- the beginning of the previous character -data StepBack = StepBack {-# UNPACK #-} !Char {-# UNPACK #-} !(Offset Word8) - --- | Step when processing digits. the value is between 0 and 9 to be valid -newtype StepDigit = StepDigit Word8 - --- | Step when processing ASCII character -newtype StepASCII = StepASCII Word8 - -isValidStepASCII :: StepASCII -> Bool -isValidStepASCII (StepASCII w) = w < 0x80 - -isValidStepDigit :: StepDigit -> Bool -isValidStepDigit (StepDigit w) = w < 0xa - --- | Possible failure related to validating bytes of UTF8 sequences. -data ValidationFailure = InvalidHeader - | InvalidContinuation - | MissingByte - | BuildingFailure - deriving (Show,Eq,Typeable) - -instance Exception ValidationFailure diff --git a/Foundation/Primitive/Utils.hs b/Foundation/Primitive/Utils.hs deleted file mode 100644 --- a/Foundation/Primitive/Utils.hs +++ /dev/null @@ -1,72 +0,0 @@ --- | --- Module : Foundation.Primitive.Utils --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : portable --- -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -module Foundation.Primitive.Utils - ( primCopyFreezedBytes - , primCopyFreezedBytesOffset - , primCopyFreezedW32 - , primCopyFreezedW64 - , primMutableAddrSlideToStart - , primMutableByteArraySlideToStart - ) where - -import Foundation.Internal.Base -import Foundation.Primitive.Types.OffsetSize -import Foundation.Internal.Primitive -import Foundation.Primitive.Monad -import GHC.Prim -import GHC.Types - --- | Copy all bytes from a byteArray# to a mutableByteArray# -primCopyFreezedBytes :: PrimMonad m => MutableByteArray# (PrimState m) -> ByteArray# -> m () -primCopyFreezedBytes mba ba = primitive $ \st -> - (# copyByteArray# ba 0# mba 0# (sizeofByteArray# ba) st , () #) -{-# INLINE primCopyFreezedBytes #-} - --- | Copy @nbBytes bytes from a byteArray# to a mutableByteArray# starting at an offset -primCopyFreezedBytesOffset :: PrimMonad m => MutableByteArray# (PrimState m) -> Int# -> ByteArray# -> Int# -> m () -primCopyFreezedBytesOffset mba ofs ba nbBytes = primitive $ \st -> - (# copyByteArray# ba 0# mba ofs nbBytes st , () #) -{-# INLINE primCopyFreezedBytesOffset #-} - --- | same as 'primCopyFreezedBytes' except copy using 32 bits word -primCopyFreezedW32 :: PrimMonad m => MutableByteArray# (PrimState m) -> ByteArray# -> m () -primCopyFreezedW32 mba ba = primitive $ \st -> (# loop st 0#, () #) - where - !len = quotInt# (sizeofByteArray# ba) 8# - loop !st !n - | bool# (n ==# len) = st - | otherwise = loop (writeWord32Array# mba n (indexWord32Array# ba n) st) (n +# 1#) - {-# INLINE loop #-} -{-# INLINE primCopyFreezedW32 #-} - --- | same as 'primCopyFreezedBytes' except copy using 64 bits word -primCopyFreezedW64 :: PrimMonad m => MutableByteArray# (PrimState m) -> ByteArray# -> m () -primCopyFreezedW64 mba ba = primitive $ \st -> (# loop st 0#, () #) - where - !len = quotInt# (sizeofByteArray# ba) 8# - loop !st !n - | bool# (n ==# len) = st - | otherwise = loop (writeWord64Array# mba n (indexWord64Array# ba n) st) (n +# 1#) - {-# INLINE loop #-} -{-# INLINE primCopyFreezedW64 #-} - -primMutableByteArraySlideToStart :: PrimMonad m => MutableByteArray# (PrimState m) -> Offset8 -> Offset8 -> m () -primMutableByteArraySlideToStart mba (Offset (I# ofs)) (Offset (I# end)) = primitive $ \st -> - (# copyMutableByteArray# mba 0# mba ofs (end -# ofs) st, () #) - -primMutableAddrSlideToStart :: PrimMonad m => Addr# -> Offset8 -> Offset8 -> m () -primMutableAddrSlideToStart addr (Offset (I# ofsIni)) (Offset (I# end)) = primitive $ \st -> (# loop st 0# ofsIni, () #) - where - loop !st !dst !ofs - | bool# (ofs ==# end) = st - | otherwise = - case readWord8OffAddr# addr ofs st of { (# st', v #) -> - case writeWord8OffAddr# addr dst v st' of { st'' -> - loop st'' (dst +# 1#) (ofs +# 1#) }} diff --git a/Foundation/Random.hs b/Foundation/Random.hs --- a/Foundation/Random.hs +++ b/Foundation/Random.hs @@ -19,98 +19,16 @@ {-# LANGUAGE ScopedTypeVariables #-} module Foundation.Random ( MonadRandom(..) - , MonadRandomState(..) , RandomGen(..) - -- , getRandomPrimType + , MonadRandomState(..) , withRandomGenerator , RNG , RNGv1 ) where -import Foundation.Class.Storable (peek) -import Foundation.Internal.Base -import Foundation.Primitive.Types.OffsetSize -import Foundation.Internal.Proxy -import Foundation.Primitive.Monad -import Foundation.System.Entropy -import Foundation.Array -import qualified Foundation.Array.Unboxed as A -import qualified Foundation.Array.Unboxed.Mutable as A -import GHC.ST -import qualified Prelude -import qualified Foreign.Marshal.Alloc (alloca) - --- | A monad constraint that allows to generate random bytes -class (Functor m, Applicative m, Monad m) => MonadRandom m where - getRandomBytes :: CountOf Word8 -> m (UArray Word8) - getRandomWord64 :: m Word64 - getRandomF32 :: m Float - getRandomF64 :: m Double - -instance MonadRandom IO where - getRandomBytes = getEntropy - getRandomWord64 = flip A.index 0 . A.unsafeRecast - <$> getRandomBytes (A.primSizeInBytes (Proxy :: Proxy Word64)) - getRandomF32 = flip A.index 0 . A.unsafeRecast - <$> getRandomBytes (A.primSizeInBytes (Proxy :: Proxy Word64)) - getRandomF64 = flip A.index 0 . A.unsafeRecast - <$> getRandomBytes (A.primSizeInBytes (Proxy :: Proxy Word64)) - --- | A Deterministic Random Generator (DRG) class -class RandomGen gen where - -- | Initialize a new random generator - randomNew :: MonadRandom m => m gen - - -- | Initialize a new random generator from a binary seed. - -- - -- If `Nothing` is returned, then the data is not acceptable - -- for creating a new random generator. - randomNewFrom :: UArray Word8 -> Maybe gen - - -- | Generate N bytes of randomness from a DRG - randomGenerate :: CountOf Word8 -> gen -> (UArray Word8, gen) - - -- | Generate a Word64 from a DRG - randomGenerateWord64 :: gen -> (Word64, gen) - - randomGenerateF32 :: gen -> (Float, gen) - - randomGenerateF64 :: gen -> (Double, gen) - --- | A simple Monad class very similar to a State Monad --- with the state being a RandomGenerator. -newtype MonadRandomState gen a = MonadRandomState { runRandomState :: gen -> (a, gen) } - -instance Functor (MonadRandomState gen) where - fmap f m = MonadRandomState $ \g1 -> - let (a, g2) = runRandomState m g1 in (f a, g2) - -instance Applicative (MonadRandomState gen) where - pure a = MonadRandomState $ \g -> (a, g) - (<*>) fm m = MonadRandomState $ \g1 -> - let (f, g2) = runRandomState fm g1 - (a, g3) = runRandomState m g2 - in (f a, g3) - -instance Monad (MonadRandomState gen) where - return a = MonadRandomState $ \g -> (a, g) - (>>=) m1 m2 = MonadRandomState $ \g1 -> - let (a, g2) = runRandomState m1 g1 - in runRandomState (m2 a) g2 - -instance RandomGen gen => MonadRandom (MonadRandomState gen) where - getRandomBytes n = MonadRandomState (randomGenerate n) - getRandomWord64 = MonadRandomState randomGenerateWord64 - getRandomF32 = MonadRandomState randomGenerateF32 - getRandomF64 = MonadRandomState randomGenerateF64 - - --- | Run a pure computation with a Random Generator in the 'MonadRandomState' -withRandomGenerator :: RandomGen gen - => gen - -> MonadRandomState gen a - -> (a, gen) -withRandomGenerator gen m = runRandomState m gen +import Foundation.Random.Class +import Foundation.Random.DRG +import qualified Foundation.Random.ChaChaDRG as ChaChaDRG -- | An alias to the default choice of deterministic random number generator -- @@ -119,87 +37,4 @@ -- keep up to date with possible bugfixes, or change of algorithms. type RNG = RNGv1 --- | RNG based on ChaCha core. --- --- The algorithm is identical to the arc4random found in recent BSDs, --- namely a ChaCha core provide 64 bytes of random from 32 bytes of --- key. -newtype RNGv1 = RNGv1 (UArray Word8) - -instance RandomGen RNGv1 where - randomNew = RNGv1 <$> getRandomBytes 32 - randomNewFrom bs - | A.length bs == 32 = Just $ RNGv1 bs - | otherwise = Nothing - randomGenerate = rngv1Generate - randomGenerateWord64 = rngv1GenerateWord64 - randomGenerateF32 = rngv1GenerateF32 - randomGenerateF64 = rngv1GenerateF64 - -rngv1KeySize :: CountOf Word8 -rngv1KeySize = 32 - -rngv1Generate :: CountOf Word8 -> RNGv1 -> (UArray Word8, RNGv1) -rngv1Generate n@(CountOf x) (RNGv1 key) = runST $ do - dst <- A.newPinned n - newKey <- A.newPinned rngv1KeySize - A.withMutablePtr dst $ \dstP -> - A.withMutablePtr newKey $ \newKeyP -> - A.withPtr key $ \keyP -> do - _ <- unsafePrimFromIO $ c_rngv1_generate newKeyP dstP keyP (Prelude.fromIntegral x) - return () - (,) <$> A.unsafeFreeze dst - <*> (RNGv1 <$> A.unsafeFreeze newKey) - -rngv1GenerateWord64 :: RNGv1 -> (Word64, RNGv1) -rngv1GenerateWord64 (RNGv1 key) = runST $ unsafePrimFromIO $ - Foreign.Marshal.Alloc.alloca $ \dst -> do - newKey <- A.newPinned rngv1KeySize - A.withMutablePtr newKey $ \newKeyP -> - A.withPtr key $ \keyP -> - c_rngv1_generate_word64 newKeyP dst keyP *> return () - (,) <$> peek dst <*> (RNGv1 <$> A.unsafeFreeze newKey) - -rngv1GenerateF32 :: RNGv1 -> (Float, RNGv1) -rngv1GenerateF32 (RNGv1 key) = runST $ unsafePrimFromIO $ - Foreign.Marshal.Alloc.alloca $ \dst -> do - newKey <- A.newPinned rngv1KeySize - A.withMutablePtr newKey $ \newKeyP -> - A.withPtr key $ \keyP -> - c_rngv1_generate_f32 newKeyP dst keyP *> return () - (,) <$> peek dst <*> (RNGv1 <$> A.unsafeFreeze newKey) - -rngv1GenerateF64 :: RNGv1 -> (Double, RNGv1) -rngv1GenerateF64 (RNGv1 key) = runST $ unsafePrimFromIO $ - Foreign.Marshal.Alloc.alloca $ \dst -> do - newKey <- A.newPinned rngv1KeySize - A.withMutablePtr newKey $ \newKeyP -> - A.withPtr key $ \keyP -> - c_rngv1_generate_f64 newKeyP dst keyP *> return () - (,) <$> peek dst <*> (RNGv1 <$> A.unsafeFreeze newKey) - --- return 0 on success, !0 for failure -foreign import ccall unsafe "foundation_rngV1_generate" - c_rngv1_generate :: Ptr Word8 -- new key - -> Ptr Word8 -- destination - -> Ptr Word8 -- current key - -> Word32 -- number of bytes to generate - -> IO Word32 - -foreign import ccall unsafe "foundation_rngV1_generate_word64" - c_rngv1_generate_word64 :: Ptr Word8 -- new key - -> Ptr Word64 -- destination - -> Ptr Word8 -- current key - -> IO Word32 - -foreign import ccall unsafe "foundation_rngV1_generate_f32" - c_rngv1_generate_f32 :: Ptr Word8 -- new key - -> Ptr Float -- destination - -> Ptr Word8 -- current key - -> IO Word32 - -foreign import ccall unsafe "foundation_rngV1_generate_f64" - c_rngv1_generate_f64 :: Ptr Word8 -- new key - -> Ptr Double -- destination - -> Ptr Word8 -- current key - -> IO Word32 +type RNGv1 = ChaChaDRG.State diff --git a/Foundation/Random/ChaChaDRG.hs b/Foundation/Random/ChaChaDRG.hs new file mode 100644 --- /dev/null +++ b/Foundation/Random/ChaChaDRG.hs @@ -0,0 +1,100 @@ +module Foundation.Random.ChaChaDRG + ( State(..) + , keySize + ) where + +import Foundation.Class.Storable (peek) +import Basement.Imports +import Basement.Types.OffsetSize +import Basement.Monad +import Foundation.Random.Class +import Foundation.Random.DRG +import qualified Basement.UArray as A +import qualified Basement.UArray.Mutable as A +import GHC.ST +import qualified Foreign.Marshal.Alloc (alloca) + +-- | RNG based on ChaCha core. +-- +-- The algorithm is identical to the arc4random found in recent BSDs, +-- namely a ChaCha core provide 64 bytes of random from 32 bytes of +-- key. +newtype State = State (UArray Word8) + +instance RandomGen State where + randomNew = State <$> getRandomBytes keySize + randomNewFrom bs + | A.length bs == keySize = Just $ State bs + | otherwise = Nothing + randomGenerate = generate + randomGenerateWord64 = generateWord64 + randomGenerateF32 = generateF32 + randomGenerateF64 = generateF64 + +keySize :: CountOf Word8 +keySize = 32 + +generate :: CountOf Word8 -> State -> (UArray Word8, State) +generate n (State key) = runST $ do + dst <- A.newPinned n + newKey <- A.newPinned keySize + A.withMutablePtr dst $ \dstP -> + A.withMutablePtr newKey $ \newKeyP -> + A.withPtr key $ \keyP -> do + _ <- unsafePrimFromIO $ c_rngv1_generate newKeyP dstP keyP n + return () + (,) <$> A.unsafeFreeze dst + <*> (State <$> A.unsafeFreeze newKey) + +generateWord64 :: State -> (Word64, State) +generateWord64 (State key) = runST $ unsafePrimFromIO $ + Foreign.Marshal.Alloc.alloca $ \dst -> do + newKey <- A.newPinned keySize + A.withMutablePtr newKey $ \newKeyP -> + A.withPtr key $ \keyP -> + c_rngv1_generate_word64 newKeyP dst keyP *> return () + (,) <$> peek dst <*> (State <$> A.unsafeFreeze newKey) + +generateF32 :: State -> (Float, State) +generateF32 (State key) = runST $ unsafePrimFromIO $ + Foreign.Marshal.Alloc.alloca $ \dst -> do + newKey <- A.newPinned keySize + A.withMutablePtr newKey $ \newKeyP -> + A.withPtr key $ \keyP -> + c_rngv1_generate_f32 newKeyP dst keyP *> return () + (,) <$> peek dst <*> (State <$> A.unsafeFreeze newKey) + +generateF64 :: State -> (Double, State) +generateF64 (State key) = runST $ unsafePrimFromIO $ + Foreign.Marshal.Alloc.alloca $ \dst -> do + newKey <- A.newPinned keySize + A.withMutablePtr newKey $ \newKeyP -> + A.withPtr key $ \keyP -> + c_rngv1_generate_f64 newKeyP dst keyP *> return () + (,) <$> peek dst <*> (State <$> A.unsafeFreeze newKey) + +-- return 0 on success, !0 for failure +foreign import ccall unsafe "foundation_rngV1_generate" + c_rngv1_generate :: Ptr Word8 -- new key + -> Ptr Word8 -- destination + -> Ptr Word8 -- current key + -> CountOf Word8 -- number of bytes to generate + -> IO Word32 + +foreign import ccall unsafe "foundation_rngV1_generate_word64" + c_rngv1_generate_word64 :: Ptr Word8 -- new key + -> Ptr Word64 -- destination + -> Ptr Word8 -- current key + -> IO Word32 + +foreign import ccall unsafe "foundation_rngV1_generate_f32" + c_rngv1_generate_f32 :: Ptr Word8 -- new key + -> Ptr Float -- destination + -> Ptr Word8 -- current key + -> IO Word32 + +foreign import ccall unsafe "foundation_rngV1_generate_f64" + c_rngv1_generate_f64 :: Ptr Word8 -- new key + -> Ptr Double -- destination + -> Ptr Word8 -- current key + -> IO Word32 diff --git a/Foundation/Random/Class.hs b/Foundation/Random/Class.hs new file mode 100644 --- /dev/null +++ b/Foundation/Random/Class.hs @@ -0,0 +1,24 @@ +module Foundation.Random.Class + ( MonadRandom(..) + ) where + +import Data.Proxy +import Basement.Imports +import Foundation.System.Entropy +import qualified Basement.UArray as A + +-- | A monad constraint that allows to generate random bytes +class (Functor m, Applicative m, Monad m) => MonadRandom m where + getRandomBytes :: CountOf Word8 -> m (UArray Word8) + getRandomWord64 :: m Word64 + getRandomF32 :: m Float + getRandomF64 :: m Double + +instance MonadRandom IO where + getRandomBytes = getEntropy + getRandomWord64 = flip A.index 0 . A.unsafeRecast + <$> getRandomBytes (A.primSizeInBytes (Proxy :: Proxy Word64)) + getRandomF32 = flip A.index 0 . A.unsafeRecast + <$> getRandomBytes (A.primSizeInBytes (Proxy :: Proxy Word64)) + getRandomF64 = flip A.index 0 . A.unsafeRecast + <$> getRandomBytes (A.primSizeInBytes (Proxy :: Proxy Word64)) diff --git a/Foundation/Random/DRG.hs b/Foundation/Random/DRG.hs new file mode 100644 --- /dev/null +++ b/Foundation/Random/DRG.hs @@ -0,0 +1,64 @@ +module Foundation.Random.DRG + ( RandomGen(..) + , MonadRandomState(..) + , withRandomGenerator + ) where + +import Basement.Imports +import Foundation.Random.Class + +-- | A Deterministic Random Generator (DRG) class +class RandomGen gen where + -- | Initialize a new random generator + randomNew :: MonadRandom m => m gen + + -- | Initialize a new random generator from a binary seed. + -- + -- If `Nothing` is returned, then the data is not acceptable + -- for creating a new random generator. + randomNewFrom :: UArray Word8 -> Maybe gen + + -- | Generate N bytes of randomness from a DRG + randomGenerate :: CountOf Word8 -> gen -> (UArray Word8, gen) + + -- | Generate a Word64 from a DRG + randomGenerateWord64 :: gen -> (Word64, gen) + + randomGenerateF32 :: gen -> (Float, gen) + + randomGenerateF64 :: gen -> (Double, gen) + +-- | A simple Monad class very similar to a State Monad +-- with the state being a RandomGenerator. +newtype MonadRandomState gen a = MonadRandomState { runRandomState :: gen -> (a, gen) } + +instance Functor (MonadRandomState gen) where + fmap f m = MonadRandomState $ \g1 -> + let (a, g2) = runRandomState m g1 in (f a, g2) + +instance Applicative (MonadRandomState gen) where + pure a = MonadRandomState $ \g -> (a, g) + (<*>) fm m = MonadRandomState $ \g1 -> + let (f, g2) = runRandomState fm g1 + (a, g3) = runRandomState m g2 + in (f a, g3) + +instance Monad (MonadRandomState gen) where + return a = MonadRandomState $ \g -> (a, g) + (>>=) m1 m2 = MonadRandomState $ \g1 -> + let (a, g2) = runRandomState m1 g1 + in runRandomState (m2 a) g2 + +instance RandomGen gen => MonadRandom (MonadRandomState gen) where + getRandomBytes n = MonadRandomState (randomGenerate n) + getRandomWord64 = MonadRandomState randomGenerateWord64 + getRandomF32 = MonadRandomState randomGenerateF32 + getRandomF64 = MonadRandomState randomGenerateF64 + + +-- | Run a pure computation with a Random Generator in the 'MonadRandomState' +withRandomGenerator :: RandomGen gen + => gen + -> MonadRandomState gen a + -> (a, gen) +withRandomGenerator gen m = runRandomState m gen diff --git a/Foundation/Random/XorShift.hs b/Foundation/Random/XorShift.hs new file mode 100644 --- /dev/null +++ b/Foundation/Random/XorShift.hs @@ -0,0 +1,88 @@ +-- | +-- Module : Foundation.Random.XorShift +-- License : BSD-style +-- +-- XorShift variant: Xoroshiro128+ +-- +-- +-- C implementation at: +-- +-- +{-# LANGUAGE MagicHash #-} +module Foundation.Random.XorShift + ( State + , initialize + , next + , nextList + , nextDouble + ) where + +import Basement.Imports +import Basement.PrimType +import Basement.Types.OffsetSize +import Foundation.Numerical +import Foundation.Bits +import Foundation.Random.Class +import Foundation.Random.DRG +import Basement.Compat.Bifunctor +import Basement.Compat.ExtList (reverse) +import qualified Basement.UArray as A +import qualified Prelude +import GHC.Prim +import GHC.Float + + +-- | State of Xoroshiro128 plus +data State = State {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 + +instance RandomGen State where + randomNew = initialize <$> getRandomWord64 <*> getRandomWord64 + randomNewFrom bs + | A.length bs == 16 = + let bs64 = A.recast bs + in Just $ State (A.index bs64 0) (A.index bs64 1) + | otherwise = Nothing + randomGenerate = generate + randomGenerateWord64 = next + randomGenerateF32 = nextFloat + randomGenerateF64 = nextDouble + +initialize :: Word64 -> Word64 -> State +initialize s0 s1 = State s0 s1 + +generate :: CountOf Word8 -> State -> (UArray Word8, State) +generate c st = + first (A.take c . A.unsafeRecast . fromList) $ nextList c64 st + where + c64 = sizeRecast c' + c' = countOfRoundUp 8 c + +next :: State -> (Word64, State) +next (State s0 s1prev) = (s0 + s1prev, State s0' s1') + where + !s1 = s0 `xor` s1prev + s0' = (s0 `rotateL` 55) `xor` s1 `xor` (s1 .<<. 14) + s1' = (s1 `rotateL` 36) + +nextList :: CountOf Word64 -> State -> ([Word64], State) +nextList c state = loop [] state 0 + where + loop acc st o + | o .==# c = (reverse acc, st) + | otherwise = + let (w, st') = next st + in loop (w:acc) st' (o+1) + +nextFloat :: State -> (Float, State) +nextFloat = first dToF . nextDouble + where dToF (D# d) = F# (double2Float# d) + +nextDouble :: State -> (Double, State) +nextDouble !st = (d' - 1.0 , st') + where + !(w, st') = next st + upperMask = 0x3FF0000000000000 + lowerMask = 0x000FFFFFFFFFFFFF + d' :: Double + d' = Prelude.fromIntegral d + d = upperMask .|. (w .&. lowerMask) diff --git a/Foundation/String.hs b/Foundation/String.hs --- a/Foundation/String.hs +++ b/Foundation/String.hs @@ -40,4 +40,4 @@ , breakLine ) where -import Foundation.String.UTF8 +import Basement.String diff --git a/Foundation/String/ASCII.hs b/Foundation/String/ASCII.hs deleted file mode 100644 --- a/Foundation/String/ASCII.hs +++ /dev/null @@ -1,265 +0,0 @@ --- | --- Module : Foundation.String.ASCII --- 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. --- --- The recommended type is `AsciiString` from `Foundation.AsciiString.UTF8` --- -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE FlexibleContexts #-} -module Foundation.String.ASCII - ( AsciiString - --, Buffer - , create - , replicate - -- * Binary conversion - , fromBytesUnsafe - , toBytes - , copy - - -- * Legacy utility - , lines - , words - ) where - -import Foundation.Array.Unboxed (UArray) -import qualified Foundation.Array.Unboxed as Vec -import qualified Foundation.Array.Unboxed.Mutable as MVec -import qualified Foundation.Collection as C -import Foundation.Internal.Base -import Foundation.Primitive.Types.OffsetSize -import Foundation.Numerical -import Foundation.Primitive.Monad -import Foundation.Foreign - -import GHC.Word -import GHC.Types -import GHC.Prim - - -- temporary -import qualified Data.List -import qualified Prelude -import Foundation.Class.Bifunctor - -cucharToChar :: CUChar -> Char -cucharToChar (CUChar (W8# i)) = C# (chr# (word2Int# i)) -charToCUChar :: Char -> CUChar -charToCUChar (C# i) = CUChar (W8# (int2Word# (ord# i))) - --- | Opaque packed array of characters in the ASCII encoding -newtype AsciiString = AsciiString { toBytes :: UArray CUChar } - deriving (Typeable, Monoid, Eq, Ord) - -newtype MutableAsciiString st = MutableAsciiString (MVec.MUArray CUChar st) - deriving (Typeable) - -instance Show AsciiString where - show = fmap cucharToChar . toList -instance IsString AsciiString where - fromString = fromList . fmap charToCUChar -instance IsList AsciiString where - type Item AsciiString = CUChar - fromList = sFromList - toList = sToList - -type instance C.Element AsciiString = CUChar - -instance C.InnerFunctor AsciiString where - imap = cucharMap -instance C.Collection AsciiString where - null = null - length = length - minimum = Data.List.minimum . toList . C.getNonEmpty -- TODO faster implementation - maximum = Data.List.maximum . toList . C.getNonEmpty -- TODO faster implementation - elem x = Data.List.elem x . toList - notElem x = Data.List.notElem x . toList - all p = Data.List.all p . toList - any p = Data.List.any p . toList -instance C.Sequential AsciiString where - take = take - drop = drop - splitAt = splitAt - revTake = revTake - revDrop = revDrop - revSplitAt = revSplitAt - splitOn = splitOn - break = break - breakElem = breakElem - intersperse = intersperse - span = span - filter = filter - reverse = reverse - unsnoc = unsnoc - uncons = uncons - snoc = snoc - cons = cons - find = find - sortBy = sortBy - singleton = fromList . (:[]) - replicate n = fromList . C.replicate n - -instance C.Zippable AsciiString where - -- TODO Use a string builder once available - zipWith f a b = sFromList (C.zipWith f a b) - -next :: AsciiString -> Offset CUChar -> (# CUChar, Offset CUChar #) -next (AsciiString ba) n = (# h, n + 1 #) - where - !h = Vec.unsafeIndex ba n - -freeze :: PrimMonad prim => MutableAsciiString (PrimState prim) -> prim AsciiString -freeze (MutableAsciiString mba) = AsciiString `fmap` C.unsafeFreeze mba -{-# INLINE freeze #-} - ------------------------------------------------------------------------- --- real functions - -sToList :: AsciiString -> [CUChar] -sToList s = loop azero - where - !len = length s - loop idx - | idx .==# len = [] - | otherwise = let (# c , idx' #) = next s idx in c : loop idx' - -sFromList :: [CUChar] -> AsciiString -sFromList = AsciiString . fromList -{-# INLINE [0] sFromList #-} - -null :: AsciiString -> Bool -null = Vec.null . toBytes -{-# INLINE null #-} - --- | Create a string composed of a number @n of Chars (Unicode code points). --- --- if the input @s contains less characters than required, then -take :: CountOf CUChar -> AsciiString -> AsciiString -take n s = fst $ splitAt n s -- TODO specialize -{-# INLINE take #-} - --- | Create a string with the remaining Chars after dropping @n Chars from the beginning -drop :: CountOf CUChar -> AsciiString -> AsciiString -drop n = AsciiString . Vec.drop n . toBytes -{-# INLINE drop #-} - -splitAt :: CountOf CUChar -> AsciiString -> (AsciiString, AsciiString) -splitAt n = bimap AsciiString AsciiString . Vec.splitAt n . toBytes -{-# INLINE splitAt #-} - --- rev{Take,Drop,SplitAt} TODO optimise: --- we can process the string from the end using a skipPrev instead of getting the length - -revTake :: CountOf CUChar -> AsciiString -> AsciiString -revTake nbElems v = drop (length v - nbElems) v - -revDrop :: CountOf CUChar -> AsciiString -> AsciiString -revDrop nbElems v = take (length v - nbElems) v - -revSplitAt :: CountOf CUChar -> AsciiString -> (AsciiString, AsciiString) -revSplitAt n v = (drop idx v, take idx v) - where idx = length 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 :: (CUChar -> Bool) -> AsciiString -> [AsciiString] -splitOn predicate = fmap AsciiString . Vec.splitOn predicate . toBytes - -break :: (CUChar -> Bool) -> AsciiString -> (AsciiString, AsciiString) -break predicate = bimap AsciiString AsciiString . Vec.break predicate . toBytes -{-# INLINE[0] break #-} - -{-# RULES "break (== 'c')" [3] forall c . break (== c) = breakElem c #-} - -breakElem :: CUChar -> AsciiString -> (AsciiString, AsciiString) -breakElem !el (AsciiString ba) = - bimap AsciiString AsciiString $ Vec.breakElem el ba -{-# INLINE breakElem #-} - -intersperse :: CUChar -> AsciiString -> AsciiString -intersperse sep = AsciiString . Vec.intersperse sep . toBytes - -span :: (CUChar -> Bool) -> AsciiString -> (AsciiString, AsciiString) -span predicate = break (not . predicate) - -length :: AsciiString -> CountOf CUChar -length (AsciiString ba) = C.length ba - -replicate :: CountOf CUChar -> CUChar -> AsciiString -replicate n c = AsciiString $ Vec.create n (const c) - --- | Copy the AsciiString -copy :: AsciiString -> AsciiString -copy (AsciiString s) = AsciiString (Vec.copy s) - --- | Allocate a MutableAsciiString of a specific size in bytes. -new :: PrimMonad prim - => CountOf CUChar -- ^ in number of bytes, not of elements. - -> prim (MutableAsciiString (PrimState prim)) -new n = MutableAsciiString `fmap` MVec.new n - -create :: PrimMonad prim => CountOf CUChar -> (MutableAsciiString (PrimState prim) -> prim (Offset CUChar)) -> prim AsciiString -create sz f = do - ms <- new sz - filled <- f ms - if filled .==# sz - then freeze ms - else C.take (offsetAsSize filled) `fmap` freeze ms - -cucharMap :: (CUChar -> CUChar) -> AsciiString -> AsciiString -cucharMap f = AsciiString . Vec.map f . toBytes - -snoc :: AsciiString -> CUChar -> AsciiString -snoc (AsciiString ba) = AsciiString . Vec.snoc ba - -cons :: CUChar -> AsciiString -> AsciiString -cons c = AsciiString . Vec.cons c . toBytes - -unsnoc :: AsciiString -> Maybe (AsciiString, CUChar) -unsnoc str = first AsciiString <$> Vec.unsnoc (toBytes str) - -uncons :: AsciiString -> Maybe (CUChar, AsciiString) -uncons str = second AsciiString <$> Vec.uncons (toBytes str) - -find :: (CUChar -> Bool) -> AsciiString -> Maybe CUChar -find predicate = Vec.find predicate . toBytes - -sortBy :: (CUChar -> CUChar -> Ordering) -> AsciiString -> AsciiString -sortBy sortF = AsciiString . Vec.sortBy sortF . toBytes - -filter :: (CUChar -> Bool) -> AsciiString -> AsciiString -filter p s = fromList $ Data.List.filter p $ toList s - -reverse :: AsciiString -> AsciiString -reverse (AsciiString ba) = AsciiString $ Vec.reverse ba - --- | 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 CUChar -> AsciiString -fromBytesUnsafe = AsciiString - -lines :: AsciiString -> [AsciiString] -lines = fmap fromString . Prelude.lines . show - -words :: AsciiString -> [AsciiString] -words = fmap fromString . Prelude.words . show diff --git a/Foundation/String/Builder.hs b/Foundation/String/Builder.hs --- a/Foundation/String/Builder.hs +++ b/Foundation/String/Builder.hs @@ -16,10 +16,10 @@ , toString ) where -import Foundation.Internal.Base ---import Foundation.Internal.Semigroup -import Foundation.String.UTF8 (String) -import qualified Foundation.String.UTF8 as S +import Basement.Compat.Base +--import Basement.Compat.Semigroup +import Basement.String (String) +import qualified Basement.String as S data Builder = E String | T [Builder] diff --git a/Foundation/String/Encoding/ASCII7.hs b/Foundation/String/Encoding/ASCII7.hs deleted file mode 100644 --- a/Foundation/String/Encoding/ASCII7.hs +++ /dev/null @@ -1,88 +0,0 @@ --- | --- Module : Foundation.String.Encoding.ASCII7 --- License : BSD-style --- Maintainer : Foundation --- Stability : experimental --- Portability : portable --- - -{-# LANGUAGE MagicHash #-} - -module Foundation.String.Encoding.ASCII7 - ( ASCII7(..) - , ASCII7_Invalid(..) - ) where - -import Foundation.Internal.Base -import Foundation.Primitive.Types.OffsetSize -import Foundation.Numerical -import Foundation.Primitive.Monad - -import GHC.Prim -import GHC.Word -import GHC.Types -import Foundation.Array.Unboxed -import Foundation.Array.Unboxed.Mutable (MUArray) -import Foundation.Boot.Builder - -import Foundation.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 #-} - --- offset of size one -aone :: Offset Word8 -aone = Offset 1 - -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 + aone) - | otherwise = Left $ ByteOutOfBound w8 - where - !w8@(W8# w) = getter off - toChar :: Word# -> Char - toChar a = C# (chr# (word2Int# a)) - --- Write ascii char --- --- > build 64 $ sequence_ write "this is a simple list of char..." --- -write :: (PrimMonad st, Monad st) - => Char - -- ^ expecting it to be a valid Ascii character. - -- otherwise this function will throw an exception - -> Builder (UArray Word8) (MUArray Word8) Word8 st err () -write c - | c < toEnum 0x80 = builderAppend $ w8 c - | otherwise = throw $ CharNotAscii c - where - w8 :: Char -> Word8 - w8 (C# ch) = W8# (int2Word# (ord# ch)) diff --git a/Foundation/String/Encoding/Encoding.hs b/Foundation/String/Encoding/Encoding.hs deleted file mode 100644 --- a/Foundation/String/Encoding/Encoding.hs +++ /dev/null @@ -1,103 +0,0 @@ --- | --- Module : Foundation.String.Encoding.Encoding --- License : BSD-style --- Maintainer : Foundation --- Stability : experimental --- Portability : portable --- - -{-# LANGUAGE FlexibleContexts #-} - -module Foundation.String.Encoding.Encoding - ( Encoding(..) - , convertFromTo - ) where - -import Foundation.Internal.Base -import Foundation.Primitive.Types.OffsetSize -import Foundation.Primitive.Monad -import Foundation.Primitive.Types -import Foundation.Boot.Builder -import Foundation.Numerical -import Foundation.Array.Unboxed (UArray) -import Foundation.Array.Unboxed.Mutable (MUArray) -import qualified Foundation.Array.Unboxed as Vec -import Foundation.Monad.Exception - -class Encoding encoding where - -- | the unit element use for the encoding. - -- i.e. Word8 for ASCII7 or UTF8, Word16 for UTF16... - -- - type Unit encoding - - -- | define the type of error handling you want to use for the - -- next function. - -- - -- > type Error UTF8 = Either UTF8_Invalid - -- - type Error encoding - - -- | consume an `Unit encoding` and return the Unicode point and the position - -- of the next possible `Unit encoding` - -- - encodingNext :: encoding - -- ^ only used for type deduction - -> (Offset (Unit encoding) -> Unit encoding) - -- ^ method to access a given `Unit encoding` - -- (see `unsafeIndexer`) - -> Offset (Unit encoding) - -- ^ offset of the `Unit encoding` where starts the - -- encoding of a given unicode - -> Either (Error encoding) (Char, Offset (Unit encoding)) -- ^ either successfully validated the `Unit encoding` - -- and returned the next offset or fail with an - -- `Error encoding` - - -- Write a unicode point encoded into one or multiple `Unit encoding` - -- - -- > build 64 $ sequence_ (write UTF8) "this is a simple list of char..." - -- - encodingWrite :: (PrimMonad st, Monad st) - => encoding - -- ^ only used for type deduction - -> Char - -- ^ the unicode character to encode - -> Builder (UArray (Unit encoding)) - (MUArray (Unit encoding)) - (Unit encoding) st err () - --- | helper to convert a given Array in a given encoding into an array --- with another encoding. --- --- This is a helper to convert from one String encoding to another. --- This function is (quite) slow and needs some work. --- --- ``` --- let s16 = ... -- string in UTF16 --- -- create s8, a UTF8 String --- let s8 = runST $ convertWith UTF16 UTF8 (toBytes s16) --- --- print s8 --- ``` --- -convertFromTo :: ( PrimMonad st, Monad st - , Encoding input, PrimType (Unit input) - , Encoding output, PrimType (Unit output) - ) - => input - -- ^ Input's encoding type - -> output - -- ^ Output's encoding type - -> UArray (Unit input) - -- ^ the input raw array - -> st (Either (Offset (Unit input), Error input) (UArray (Unit output))) -convertFromTo inputEncodingTy outputEncodingTy bytes - | Vec.null bytes = return . return $ mempty - | otherwise = Vec.unsafeIndexer bytes $ \t -> Vec.builderBuild 64 (loop azero t) - where - lastUnit = Vec.length bytes - - loop off getter - | off .==# lastUnit = return () - | otherwise = case encodingNext inputEncodingTy getter off of - Left err -> mFail (off, err) - Right (c, noff) -> encodingWrite outputEncodingTy c >> loop noff getter diff --git a/Foundation/String/Encoding/ISO_8859_1.hs b/Foundation/String/Encoding/ISO_8859_1.hs deleted file mode 100644 --- a/Foundation/String/Encoding/ISO_8859_1.hs +++ /dev/null @@ -1,64 +0,0 @@ --- | --- Module : Foundation.String.Encoding.ISO_8859_1 --- License : BSD-style --- Maintainer : Foundation --- Stability : experimental --- Portability : portable --- - -{-# LANGUAGE MagicHash #-} - -module Foundation.String.Encoding.ISO_8859_1 - ( ISO_8859_1(..) - , ISO_8859_1_Invalid(..) - ) where - -import Foundation.Internal.Base -import Foundation.Primitive.Types.OffsetSize -import Foundation.Numerical -import Foundation.Primitive.Monad - -import GHC.Prim -import GHC.Word -import GHC.Types -import Foundation.Array.Unboxed -import Foundation.Array.Unboxed.Mutable (MUArray) -import Foundation.Boot.Builder - -import Foundation.String.Encoding.Encoding - --- offset of size one -aone :: Offset Word8 -aone = Offset 1 - -data ISO_8859_1_Invalid - = NotISO_8859_1 Char - deriving (Typeable, Show, Eq) -instance Exception ISO_8859_1_Invalid - -data ISO_8859_1 = ISO_8859_1 - -instance Encoding ISO_8859_1 where - type Unit ISO_8859_1 = Word8 - type Error ISO_8859_1 = ISO_8859_1_Invalid - encodingNext _ = next - encodingWrite _ = write - -next :: (Offset Word8 -> Word8) - -> Offset Word8 - -> Either ISO_8859_1_Invalid (Char, Offset Word8) -next getter off = Right (toChar w, off + aone) - where - !(W8# w) = getter off - toChar :: Word# -> Char - toChar a = C# (chr# (word2Int# a)) - -write :: (PrimMonad st, Monad st) - => Char - -> Builder (UArray Word8) (MUArray Word8) Word8 st err () -write c@(C# ch) - | c <= toEnum 0xFF = builderAppend (W8# x) - | otherwise = throw $ NotISO_8859_1 c - where - x :: Word# - !x = int2Word# (ord# ch) diff --git a/Foundation/String/Encoding/UTF16.hs b/Foundation/String/Encoding/UTF16.hs deleted file mode 100644 --- a/Foundation/String/Encoding/UTF16.hs +++ /dev/null @@ -1,97 +0,0 @@ --- | --- Module : Foundation.String.Encoding.UTF16 --- License : BSD-style --- Maintainer : Foundation --- Stability : experimental --- Portability : portable --- -{-# LANGUAGE MagicHash #-} -module Foundation.String.Encoding.UTF16 - ( UTF16(..) - , UTF16_Invalid(..) - ) where - -import Foundation.Internal.Base -import Foundation.Primitive.Types.OffsetSize -import Foundation.Primitive.Monad -import GHC.Prim -import GHC.Word -import GHC.Types -import Foundation.Numerical -import Data.Bits -import qualified Prelude -import Foundation.Array.Unboxed -import Foundation.Array.Unboxed.Mutable (MUArray) -import Foundation.Boot.Builder - -import Foundation.String.Encoding.Encoding - -data UTF16_Invalid - = InvalidContinuation - | InvalidUnicode Char - deriving (Show, Eq, Typeable) -instance Exception UTF16_Invalid - -data UTF16 = UTF16 - -instance Encoding UTF16 where - type Unit UTF16 = Word16 - type Error UTF16 = UTF16_Invalid - encodingNext _ = next - encodingWrite _ = write - - --- --- U+0000 to U+D7FF and U+E000 to U+FFFF : 1 bytes --- U+10000 to U+10FFFF : --- * 0x010000 is subtracted from the code point, leaving a 20-bit number in the range 0..0x0FFFFF. --- * The top ten bits (a number in the range 0..0x03FF) are added to 0xD800 to give the first 16-bit code unit --- or high surrogate, which will be in the range 0xD800..0xDBFF. --- * The low ten bits (also in the range 0..0x03FF) are added to 0xDC00 to give the second 16-bit code unit --- or low surrogate, which will be in the range 0xDC00..0xDFFF. - -next :: (Offset Word16 -> Word16) - -> Offset Word16 - -> Either UTF16_Invalid (Char, Offset Word16) -next getter off - | h < 0xd800 = Right (toChar hh, off + Offset 1) - | h >= 0xe000 = Right (toChar hh, off + Offset 1) - | otherwise = nextContinuation - where - h :: Word16 - !h@(W16# hh) = getter off - toChar :: Word# -> Char - toChar w = C# (chr# (word2Int# w)) - to32 :: Word16 -> Word32 - to32 (W16# w) = W32# w - - nextContinuation - | cont >= 0xdc00 && cont < 0xe00 = - let !(W32# w) = ((to32 h .&. 0x3ff) `shiftL` 10) - .|. (to32 cont .&. 0x3ff) - in Right (toChar w, off + Offset 2) - | otherwise = Left InvalidContinuation - where - cont :: Word16 - !cont = getter $ off + Offset 1 - -write :: (PrimMonad st, Monad st) - => Char - -> Builder (UArray Word16) (MUArray Word16) Word16 st err () -write c - | c < toEnum 0xd800 = builderAppend $ w16 c - | c > toEnum 0x10000 = let (w1, w2) = wHigh c in builderAppend w1 >> builderAppend w2 - | c > toEnum 0x10ffff = throw $ InvalidUnicode c - | c >= toEnum 0xe000 = builderAppend $ w16 c - | otherwise = throw $ InvalidUnicode c - where - w16 :: Char -> Word16 - w16 (C# ch) = W16# (int2Word# (ord# ch)) - - to16 :: Word32 -> Word16 - to16 = Prelude.fromIntegral - - wHigh :: Char -> (Word16, Word16) - wHigh (C# ch) = - let v = W32# (minusWord# (int2Word# (ord# ch)) 0x10000##) - in (0xdc00 .|. to16 (v `shiftR` 10), 0xd800 .|. to16 (v .&. 0x3ff)) diff --git a/Foundation/String/Encoding/UTF32.hs b/Foundation/String/Encoding/UTF32.hs deleted file mode 100644 --- a/Foundation/String/Encoding/UTF32.hs +++ /dev/null @@ -1,55 +0,0 @@ --- | --- Module : Foundation.String.Encoding.UTF32 --- License : BSD-style --- Maintainer : Foundation --- Stability : experimental --- Portability : portable --- -{-# LANGUAGE MagicHash #-} -module Foundation.String.Encoding.UTF32 - ( UTF32(..) - , UTF32_Invalid - ) where - -import Foundation.Internal.Base -import Foundation.Primitive.Types.OffsetSize -import Foundation.Primitive.Monad -import GHC.Prim -import GHC.Word -import GHC.Types -import Foundation.Numerical -import Foundation.Array.Unboxed -import Foundation.Array.Unboxed.Mutable (MUArray) -import Foundation.Boot.Builder - -import Foundation.String.Encoding.Encoding - -data UTF32 = UTF32 - -data UTF32_Invalid = UTF32_Invalid - deriving (Typeable, Show, Eq, Ord, Enum, Bounded) -instance Exception UTF32_Invalid - -instance Encoding UTF32 where - type Unit UTF32 = Word32 - type Error UTF32 = UTF32_Invalid - encodingNext _ = next - encodingWrite _ = write - -next :: (Offset Word32 -> Word32) - -> Offset Word32 - -> Either UTF32_Invalid (Char, Offset Word32) -next getter off = Right (char, off + Offset 1) - where - !(W32# hh) = getter off - char :: Char - char = C# (chr# (word2Int# hh)) - -write :: (PrimMonad st, Monad st) - => Char - -> Builder (UArray Word32) (MUArray Word32) Word32 st err () -write c = builderAppend w32 - where - !(C# ch) = c - w32 :: Word32 - w32 = W32# (int2Word# (ord# ch)) diff --git a/Foundation/String/Internal.hs b/Foundation/String/Internal.hs deleted file mode 100644 --- a/Foundation/String/Internal.hs +++ /dev/null @@ -1,10 +0,0 @@ --- | --- Module : Foundation.String.Internal --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : portable --- -module Foundation.String.Internal - ( - ) where diff --git a/Foundation/String/ModifiedUTF8.hs b/Foundation/String/ModifiedUTF8.hs deleted file mode 100644 --- a/Foundation/String/ModifiedUTF8.hs +++ /dev/null @@ -1,78 +0,0 @@ --- | --- Module : Foundation.String.ModifiedUTF8 --- License : BSD-style --- Maintainer : foundation --- Stability : experimental --- Portability : portable --- --- A String type backed by a Modified 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 FlexibleContexts #-} -{-# LANGUAGE MagicHash #-} -module Foundation.String.ModifiedUTF8 - ( fromModified - ) where - -import GHC.ST (runST, ST) -import GHC.Prim (Addr#) -import Control.Monad (mapM_) - -import Foundation.Internal.Base -import Foundation.Primitive.Types.OffsetSize -import qualified Foundation.Array.Unboxed as Vec -import qualified Foundation.Primitive.UArray.Base as Vec -import Foundation.Array.Unboxed (UArray) -import Foundation.Numerical -import Foundation.Primitive.FinalPtr -import Foundation.Primitive.UTF8.Table - --- helper function to read some bytes from the given byte reader -accessBytes :: Offset Word8 -> (Offset Word8 -> Word8) -> ([Word8], Offset Word8) -accessBytes offset getAtIdx = (loop offset, pastEnd) - where - nbytes :: CountOf Word8 - nbytes = CountOf $ getNbBytes $ getAtIdx offset - pastEnd :: Offset Word8 - pastEnd = 1 + (offset `offsetPlusE` nbytes) - loop :: Offset Word8 -> [Word8] - loop off - | off == pastEnd = [] - | otherwise = getAtIdx off : loop (off + 1) - -buildByteArray :: Addr# -> ST st (UArray Word8) -buildByteArray addr = Vec.UArray (Offset 0) (CountOf 100000) . Vec.UArrayAddr <$> - toFinalPtr (Ptr addr) (\_ -> return ()) - --- | assuming the given ByteArray 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# -> UArray Word8 -fromModified addr = runST $ do - ba <- buildByteArray addr - Vec.unsafeIndexer ba buildWithBytes - where - buildWithBytes getAt = Vec.builderBuild_ 64 (loopBuilder getAt (Offset 0)) - loopBuilder getAt offset = - case bs of - [] -> internalError "ModifiedUTF8.fromModified" - [0x00] -> return () - [b1,b2] | b1 == 0xC0 && b2 == 0x80 -> Vec.builderAppend 0x00 >> loopBuilder getAt noffset - _ -> mapM_ Vec.builderAppend bs >> loopBuilder getAt noffset - where - (bs, noffset) = accessBytes offset getAt - -{- -toModified :: ByteArray -> ByteArray -toModified = undefined --} diff --git a/Foundation/String/Read.hs b/Foundation/String/Read.hs --- a/Foundation/String/Read.hs +++ b/Foundation/String/Read.hs @@ -7,4 +7,4 @@ , readFloatingExact ) where -import Foundation.String.UTF8 +import Basement.String diff --git a/Foundation/String/UTF8.hs b/Foundation/String/UTF8.hs deleted file mode 100644 --- a/Foundation/String/UTF8.hs +++ /dev/null @@ -1,1409 +0,0 @@ --- | --- Module : Foundation.String.UTF8 --- 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 Foundation.String.UTF8 - ( String(..) - , MutableString(..) - , create - , replicate - , length - -- * Binary conversion - , Encoding(..) - , fromBytes - , fromChunkBytes - , fromBytesUnsafe - , fromBytesLenient - , toBytes - , mutableValidate - , copy - , ValidationFailure(..) - , index - , null - , drop - , take - , splitAt - , revDrop - , revTake - , revSplitAt - , splitOn - , sub - , elem - , indices - , intersperse - , span - , break - , breakElem - , breakLine - , dropWhile - , singleton - , charMap - , snoc - , cons - , unsnoc - , uncons - , find - , findIndex - , sortBy - , filter - , reverse - , replace - , builderAppend - , builderBuild - , builderBuild_ - , readInteger - , readIntegral - , readNatural - , readDouble - , readRational - , readFloatingExact - , upper - , lower - , isPrefixOf - , isSuffixOf - , isInfixOf - , stripPrefix - , stripSuffix - , all - , any - -- * Legacy utility - , lines - , words - , toBase64 - , toBase64URL - , toBase64OpenBSD - ) where - -import Foundation.Array.Unboxed (UArray) -import qualified Foundation.Array.Unboxed as Vec -import qualified Foundation.Array.Unboxed as C -import Foundation.Array.Unboxed.ByteArray (MutableByteArray) -import qualified Foundation.Array.Unboxed.Mutable as MVec -import Foundation.Class.Bifunctor -import Foundation.Internal.Base -import Foundation.Internal.Natural -import Foundation.Internal.MonadTrans -import Foundation.Internal.Primitive -import Foundation.Primitive.Types.OffsetSize -import Foundation.Numerical -import Foundation.Primitive.Monad -import Foundation.Primitive.Types -import Foundation.Primitive.FinalPtr -import Foundation.Primitive.IntegralConv -import Foundation.Primitive.Floating -import Foundation.Boot.Builder -import Foundation.Primitive.UTF8.Table -import Foundation.Primitive.UTF8.Helper -import Foundation.Primitive.UTF8.Base -import Foundation.Primitive.UTF8.Types -import Foundation.Primitive.UArray.Base as C (onBackendPrim, onBackend, offset, ValidRange(..), offsetsValidRange) -import qualified Foundation.Primitive.UTF8.BA as PrimBA -import qualified Foundation.Primitive.UTF8.Addr as PrimAddr -import qualified Foundation.String.UTF8.BA as BackendBA -import qualified Foundation.String.UTF8.Addr as BackendAddr -import GHC.Prim -import GHC.ST -import GHC.Types -import GHC.Word -#if MIN_VERSION_base(4,9,0) -import GHC.Char -#endif - - -- temporary -import qualified Data.List -import Data.Ratio -import Data.Char (toUpper, toLower) -import qualified Prelude - -import qualified Foundation.String.Encoding.Encoding as Encoder -import qualified Foundation.String.Encoding.ASCII7 as Encoder -import qualified Foundation.String.Encoding.UTF16 as Encoder -import qualified Foundation.String.Encoding.UTF32 as Encoder -import qualified Foundation.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 - => MutableByteArray (PrimState prim) - -> Offset Word8 - -> CountOf Word8 - -> prim (Offset Word8, Maybe ValidationFailure) -mutableValidate mba ofsStart sz = do - loop ofsStart - where - end = ofsStart `offsetPlusE` sz - - loop ofs - | ofs > end = error "mutableValidate: internal error: went pass offset" - | ofs == end = return (end, Nothing) - | otherwise = do - r <- one ofs - case r of - (nextOfs, Nothing) -> loop nextOfs - (pos, Just failure) -> return (pos, Just failure) - - one pos = do - h <- Vec.unsafeRead mba pos - let nbConts = getNbBytes h - if nbConts == 0xff - then return (pos, Just InvalidHeader) - else if pos + 1 + Offset nbConts > end - then return (pos, Just MissingByte) - else do - case nbConts of - 0 -> return (pos + 1, Nothing) - 1 -> do - c1 <- Vec.unsafeRead mba (pos + 1) - if isContinuation c1 - then return (pos + 2, Nothing) - else return (pos, Just InvalidContinuation) - 2 -> do - c1 <- Vec.unsafeRead mba (pos + 1) - c2 <- Vec.unsafeRead mba (pos + 2) - if isContinuation c1 && isContinuation c2 - then return (pos + 3, Nothing) - else return (pos, Just InvalidContinuation) - 3 -> do - c1 <- Vec.unsafeRead mba (pos + 1) - c2 <- Vec.unsafeRead mba (pos + 2) - c3 <- Vec.unsafeRead mba (pos + 3) - if isContinuation c1 && isContinuation c2 && isContinuation c3 - then return (pos + 4, Nothing) - else return (pos, Just InvalidContinuation) - _ -> error "internal error" - -nextWithIndexer :: (Offset Word8 -> Word8) - -> Offset Word8 - -> (Char, Offset Word8) -nextWithIndexer getter off = - case getNbBytes# h of - 0# -> (toChar h, off + 1) - 1# -> (toChar (decode2 (getter $ off + 1)), off + 2) - 2# -> (toChar (decode3 (getter $ off + 1) (getter $ off + 2)), off + 3) - 3# -> (toChar (decode4 (getter $ off + 1) (getter $ off + 2) (getter $ off + 3)) - , off + 4) - r -> error ("next: internal error: invalid input: " <> show (I# r) <> " " <> show (W# h)) - where - !(W8# h) = getter off - - toChar :: Word# -> Char - toChar w = C# (chr# (word2Int# w)) - - decode2 :: Word8 -> Word# - decode2 (W8# c1) = - or# (uncheckedShiftL# (and# h 0x1f##) 6#) - (and# c1 0x3f##) - - decode3 :: Word8 -> Word8 -> Word# - decode3 (W8# c1) (W8# c2) = - or# (uncheckedShiftL# (and# h 0xf##) 12#) - (or# (uncheckedShiftL# (and# c1 0x3f##) 6#) - (and# c2 0x3f##)) - - decode4 :: Word8 -> Word8 -> Word8 -> Word# - decode4 (W8# c1) (W8# c2) (W8# c3) = - or# (uncheckedShiftL# (and# h 0x7##) 18#) - (or# (uncheckedShiftL# (and# c1 0x3f##) 12#) - (or# (uncheckedShiftL# (and# c2 0x3f##) 6#) - (and# c3 0x3f##)) - ) - -writeWithBuilder :: (PrimMonad st, Monad st) - => Char - -> Builder (UArray Word8) (MVec.MUArray Word8) Word8 st err () -writeWithBuilder c - | bool# (ltWord# x 0x80## ) = encode1 - | bool# (ltWord# x 0x800## ) = encode2 - | bool# (ltWord# x 0x10000##) = encode3 - | otherwise = encode4 - where - !(I# xi) = fromEnum c - !x = int2Word# xi - - encode1 = Vec.builderAppend (W8# x) - - encode2 = do - let x1 = or# (uncheckedShiftRL# x 6#) 0xc0## - x2 = toContinuation x - Vec.builderAppend (W8# x1) >> Vec.builderAppend (W8# x2) - - encode3 = do - let x1 = or# (uncheckedShiftRL# x 12#) 0xe0## - x2 = toContinuation (uncheckedShiftRL# x 6#) - x3 = toContinuation x - Vec.builderAppend (W8# x1) >> Vec.builderAppend (W8# x2) >> Vec.builderAppend (W8# x3) - - encode4 = do - let x1 = or# (uncheckedShiftRL# x 18#) 0xf0## - x2 = toContinuation (uncheckedShiftRL# x 12#) - x3 = toContinuation (uncheckedShiftRL# x 6#) - x4 = toContinuation x - Vec.builderAppend (W8# x1) >> Vec.builderAppend (W8# x2) >> Vec.builderAppend (W8# x3) >> Vec.builderAppend (W8# x4) - - toContinuation :: Word# -> Word# - toContinuation w = or# (and# w 0x3f##) 0x80## - -writeUTF8Char :: PrimMonad prim => MutableString (PrimState prim) -> Offset8 -> UTF8Char -> prim () -writeUTF8Char (MutableString mba) i (UTF8_1 x1) = - Vec.unsafeWrite mba i x1 -writeUTF8Char (MutableString mba) i (UTF8_2 x1 x2) = do - Vec.unsafeWrite mba i x1 - Vec.unsafeWrite mba (i+1) x2 -writeUTF8Char (MutableString mba) i (UTF8_3 x1 x2 x3) = do - Vec.unsafeWrite mba i x1 - Vec.unsafeWrite mba (i+1) x2 - Vec.unsafeWrite mba (i+2) x3 -writeUTF8Char (MutableString mba) i (UTF8_4 x1 x2 x3 x4) = do - Vec.unsafeWrite mba i x1 - Vec.unsafeWrite mba (i+1) x2 - Vec.unsafeWrite mba (i+2) x3 - Vec.unsafeWrite mba (i+3) x4 -{-# INLINE writeUTF8Char #-} - -unsafeFreezeShrink :: PrimMonad prim => MutableString (PrimState prim) -> CountOf Word8 -> prim String -unsafeFreezeShrink (MutableString mba) s = String <$> Vec.unsafeFreezeShrink mba s -{-# INLINE unsafeFreezeShrink #-} - ------------------------------------------------------------------------- --- real functions - --- | Check if a String is null -null :: String -> Bool -null (String ba) = C.length ba == 0 - --- we don't know in constant time the count of character in string, --- however if we estimate bounds of what N characters would --- take in space (between N and N*4). If the count is thus bigger than --- the number of bytes, then we know for sure that it's going to --- be out of bounds -countCharMoreThanBytes :: CountOf Char -> UArray Word8 -> Bool -countCharMoreThanBytes (CountOf chars) ba = chars >= bytes - where (CountOf bytes) = C.length ba - --- | Create a string composed of a number @n of Chars (Unicode code points). --- --- if the input @s contains less characters than required, then the input string is returned. -take :: CountOf Char -> String -> String -take n s@(String ba) - | n <= 0 = mempty - | countCharMoreThanBytes n ba = s - | otherwise = String $ Vec.unsafeTake (offsetAsSize $ indexN n s) ba - --- | Create a string with the remaining Chars after dropping @n Chars from the beginning -drop :: CountOf Char -> String -> String -drop n s@(String ba) - | n <= 0 = s - | countCharMoreThanBytes n ba = mempty - | otherwise = String $ Vec.drop (offsetAsSize $ indexN n s) ba - --- | Split a string at the Offset specified (in Char) returning both --- the leading part and the remaining part. -splitAt :: CountOf Char -> String -> (String, String) -splitAt n s@(String ba) - | n <= 0 = (mempty, s) - | countCharMoreThanBytes n ba = (s, mempty) - | otherwise = - let (v1,v2) = C.splitAt (offsetAsSize $ indexN n s) ba - in (String v1, String v2) - --- | Return the offset (in bytes) of the N'th sequence in an UTF8 String -indexN :: CountOf Char -> String -> Offset Word8 -indexN !n (String ba) = Vec.unsafeDewrap goVec goAddr ba - where - goVec :: ByteArray# -> Offset Word8 -> Offset Word8 - goVec !ma !start = loop start 0 - where - !len = start `offsetPlusE` Vec.length ba - loop :: Offset Word8 -> Offset Char -> Offset Word8 - loop !idx !i - | idx >= len || i .==# n = sizeAsOffset (idx - start) - | otherwise = loop (idx `offsetPlusE` d) (i + Offset 1) - where d = skipNextHeaderValue (primBaIndex ma idx) - {-# INLINE goVec #-} - - goAddr :: Ptr Word8 -> Offset Word8 -> ST s (Offset Word8) - goAddr (Ptr ptr) !start = return $ loop start (Offset 0) - where - !len = start `offsetPlusE` Vec.length ba - loop :: Offset Word8 -> Offset Char -> Offset Word8 - loop !idx !i - | idx >= len || i .==# n = sizeAsOffset (idx - start) - | otherwise = loop (idx `offsetPlusE` d) (i + Offset 1) - where d = skipNextHeaderValue (primAddrIndex ptr idx) - {-# INLINE goAddr #-} -{-# INLINE indexN #-} - --- inverse a CountOf that is specified from the end (e.g. take n Chars from the end) --- --- rev{Take,Drop,SplitAt} TODO optimise: --- we can process the string from the end using a skipPrev instead of getting the length -countFromStart :: String -> CountOf Char -> CountOf Char -countFromStart s sz@(CountOf sz') - | sz >= len = CountOf 0 - | otherwise = CountOf (len' - sz') - where len@(CountOf len') = length s - --- | Similar to 'take' but from the end -revTake :: CountOf Char -> String -> String -revTake n v = drop (countFromStart v n) v - --- | Similar to 'drop' but from the end -revDrop :: CountOf Char -> String -> String -revDrop n v = take (countFromStart v n) v - --- | Similar to 'splitAt' but from the end -revSplitAt :: CountOf Char -> String -> (String, String) -revSplitAt n v = (drop idx v, take idx v) where idx = countFromStart v n - --- | Split on the input string using the predicate as separator --- --- e.g. --- --- > splitOn (== ',') "," == ["",""] --- > splitOn (== ',') ",abc," == ["","abc",""] --- > splitOn (== ':') "abc" == ["abc"] --- > splitOn (== ':') "abc::def" == ["abc","","def"] --- > splitOn (== ':') "::abc::def" == ["","","abc","","def"] --- -splitOn :: (Char -> Bool) -> String -> [String] -splitOn predicate s - | sz == CountOf 0 = [mempty] - | otherwise = loop azero azero - where - !sz = size s - end = azero `offsetPlusE` sz - loop prevIdx idx - | idx == end = [sub s prevIdx idx] - | otherwise = - let !(Step c idx') = next s idx - in if predicate c - then sub s prevIdx idx : loop idx' idx' - else loop prevIdx idx' - --- | Internal call to make a substring given offset in bytes. --- --- This is unsafe considering that one can create a substring --- starting and/or ending on the middle of a UTF8 sequence. -sub :: String -> Offset8 -> Offset8 -> String -sub (String ba) start end = String $ Vec.sub ba start end - --- | Internal call to split at a given index in offset of bytes. --- --- This is unsafe considering that one can split in the middle of a --- UTF8 sequence, so use with care. -splitIndex :: Offset8 -> String -> (String, String) -splitIndex idx (String ba) = (String v1, String v2) - where (v1,v2) = C.splitAt (offsetAsSize idx) ba - --- | Break a string into 2 strings at the location where the predicate return True -break :: (Char -> Bool) -> String -> (String, String) -break predicate s@(String ba) = runST $ Vec.unsafeIndexer ba go - where - !sz = size s - end = azero `offsetPlusE` sz - - go :: (Offset Word8 -> Word8) -> ST st (String, String) - go getIdx = loop (Offset 0) - where - !nextI = nextWithIndexer getIdx - loop idx - | idx == end = return (s, mempty) - | otherwise = do - let (c, idx') = nextI idx - case predicate c of - True -> return $ splitIndex idx s - False -> loop idx' - {-# INLINE loop #-} -{-# INLINE [2] break #-} - -#if MIN_VERSION_base(4,9,0) -{-# RULES "break (== 'c')" [3] forall c . break (eqChar c) = breakElem c #-} -#else -{-# RULES "break (== 'c')" [3] forall c . break (== c) = breakElem c #-} -#endif - --- | Break a string into 2 strings at the first occurence of the character -breakElem :: Char -> String -> (String, String) -breakElem !el s@(String ba) - | sz == 0 = (mempty, mempty) - | otherwise = - case asUTF8Char el of - UTF8_1 w -> let !(v1,v2) = Vec.breakElem w ba in (String v1, String v2) - _ -> runST $ Vec.unsafeIndexer ba go - where - sz = size s - end = azero `offsetPlusE` sz - - go :: (Offset Word8 -> Word8) -> ST st (String, String) - go getIdx = loop (Offset 0) - where - !nextI = nextWithIndexer getIdx - loop idx - | idx == end = return (s, mempty) - | otherwise = do - let (c, idx') = nextI idx - case el == c of - True -> return $ splitIndex idx s - False -> loop idx' - --- | Same as break but cut on a line feed with an optional carriage return. --- --- This is the same operation as 'breakElem LF' dropping the last character of the --- string if it's a CR. --- --- Also for efficiency reason (streaming), it returns if the last character was a CR character. -breakLine :: String -> Either Bool (String, String) -breakLine (String arr) = bimap String String <$> Vec.breakLine arr - --- | Apply a @predicate@ to the string to return the longest prefix that satisfy the predicate and --- the remaining -span :: (Char -> Bool) -> String -> (String, String) -span predicate s = break (not . predicate) s - --- | Drop character from the beginning while the predicate is true -dropWhile :: (Char -> Bool) -> String -> String -dropWhile predicate = snd . break (not . predicate) - --- | Return whereas the string contains a specific character or not -elem :: Char -> String -> Bool -elem !el s@(String ba) = - case asUTF8Char el of - UTF8_1 w -> Vec.elem w ba - _ -> runST $ Vec.unsafeIndexer ba go - where - sz = size s - end = azero `offsetPlusE` sz - - go :: (Offset Word8 -> Word8) -> ST st Bool - go getIdx = loop (Offset 0) - where - !nextI = nextWithIndexer getIdx - loop !idx - | idx == end = return False - | otherwise = do - let (c, idx') = nextI idx - case el == c of - True -> return True - False -> loop idx' - --- | Intersperse the character @sep@ between each character in the string --- --- > intersperse ' ' "Hello Foundation" --- "H e l l o F o u n d a t i o n" -intersperse :: Char -> String -> String -intersperse sep src - | srcLen <= 1 = src - | otherwise = runST $ unsafeCopyFrom src dstBytes (go sep) - where - !srcBytes = size src - !srcLen = length src - dstBytes = (srcBytes :: Size8) - + ((srcLen - 1) `scale` charToBytes (fromEnum sep)) - - lastSrcI :: Offset Char - lastSrcI = 0 `offsetPlusE` (srcLen - 1) - - go :: Char -> String -> Offset Char -> Offset8 -> MutableString s -> Offset8 -> ST s (Offset8, Offset8) - go sep' 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 - -> Size8 -- ^ Length of the destination string in bytes - -> (String -> Offset Char -> Offset8 -> MutableString s -> Offset8 -> ST s (Offset8, Offset8)) - -- ^ Function called for each character in the source String - -> ST s String -- ^ Returns the filled new string -unsafeCopyFrom src dstBytes f = new dstBytes >>= fill (Offset 0) (Offset 0) (Offset 0) f >>= freeze - where - srcLen = length src - end = Offset 0 `offsetPlusE` srcLen - fill srcI srcIdx dstIdx f' dst' - | srcI == end = return dst' - | otherwise = do (nextSrcIdx, nextDstIdx) <- f' src srcI srcIdx dst' dstIdx - fill (srcI + Offset 1) nextSrcIdx nextDstIdx f' dst' - --- | Length of a String using CountOf --- --- this size is available in o(n) -length :: String -> CountOf Char -length (String arr) - | start == end = 0 - | otherwise = C.onBackend goVec (\_ -> pure . goAddr) arr - where - (C.ValidRange !start !end) = offsetsValidRange arr - goVec ma = PrimBA.length ma start end - goAddr (Ptr ptr) = PrimAddr.length ptr start end - --- | Replicate a character @c@ @n@ times to create a string of length @n@ -replicate :: CountOf Char -> Char -> String -replicate (CountOf n) c = runST (new nbBytes >>= fill) - where - nbBytes = scale (integralCast n :: Word) sz - sz = charToBytes (fromEnum c) - fill :: PrimMonad prim => MutableString (PrimState prim) -> prim String - fill ms = loop (Offset 0) - where - loop idx - | idx .==# nbBytes = freeze ms - | otherwise = write ms idx c >>= loop - --- | Copy the String --- --- The slice of memory is copied to a new slice, making the new string --- independent from the original string.. -copy :: String -> String -copy (String s) = String (Vec.copy s) - --- | Create a single element String -singleton :: Char -> String -singleton c = runST $ do - ms <- new nbBytes - _ <- write ms (Offset 0) c - freeze ms - where - !nbBytes = charToBytes (fromEnum c) - --- | Unsafely create a string of up to @sz@ bytes. --- --- The callback @f@ needs to return the number of bytes filled in the underlaying --- bytes buffer. No check is made on the callback return values, and if it's not --- contained without the bounds, bad things will happen. -create :: PrimMonad prim => CountOf Word8 -> (MutableString (PrimState prim) -> prim (Offset Word8)) -> prim String -create sz f = do - ms <- new sz - filled <- f ms - if filled .==# sz - then freeze ms - else do - (String ba) <- freeze ms - pure $ String $ C.take (offsetAsSize filled) ba - --- | Monomorphically map the character in a string and return the transformed one -charMap :: (Char -> Char) -> String -> String -charMap f src - | srcSz == 0 = mempty - | otherwise = - let !(elems, nbBytes) = allocateAndFill [] (Offset 0) (CountOf 0) - in runST $ do - dest <- new nbBytes - copyLoop dest elems (Offset 0 `offsetPlusE` nbBytes) - freeze dest - where - !srcSz = size src - srcEnd = azero `offsetPlusE` srcSz - - allocateAndFill :: [(String, Size8)] - -> Offset8 - -> Size8 - -> ([(String,Size8)], Size8) - 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) - -> Size8 - -> Offset8 - -> prim (Size8, Offset8) - fill mba dsz srcIdxOrig = - loop (Offset 0) srcIdxOrig - where - endDst = (Offset 0) `offsetPlusE` dsz - loop dstIdx srcIdx - | srcIdx == srcEnd = return (offsetAsSize dstIdx, srcIdx) - | dstIdx == endDst = return (offsetAsSize dstIdx, srcIdx) - | otherwise = - let !(Step c srcIdx') = next src srcIdx - c' = f c -- the mapped char - !nbBytes = charToBytes (fromEnum c') - in -- check if we have room in the destination buffer - if dstIdx `offsetPlusE` nbBytes <= sizeAsOffset dsz - then do dstIdx' <- write mba dstIdx c' - loop dstIdx' srcIdx' - else return (offsetAsSize dstIdx, srcIdx) - - copyLoop _ [] (Offset 0) = return () - copyLoop _ [] n = error ("charMap invalid: " <> show n) - copyLoop ms@(MutableString mba) ((String ba, sz):xs) end = do - let start = end `offsetMinusE` sz - Vec.unsafeCopyAtRO mba start ba (Offset 0) sz - copyLoop ms xs start - --- | Append a Char to the end of the String and return this new String -snoc :: String -> Char -> String -snoc s@(String ba) c - | len == CountOf 0 = singleton c - | otherwise = runST $ do - ms@(MutableString mba) <- new (len + nbBytes) - Vec.unsafeCopyAtRO mba (Offset 0) ba (Offset 0) len - _ <- write ms (azero `offsetPlusE` len) c - freeze ms - where - !len = size s - !nbBytes = charToBytes (fromEnum c) - --- | Prepend a Char to the beginning of the String and return this new String -cons :: Char -> String -> String -cons c s@(String ba) - | len == CountOf 0 = singleton c - | otherwise = runST $ do - ms@(MutableString mba) <- new (len + nbBytes) - idx <- write ms (Offset 0) c - Vec.unsafeCopyAtRO mba idx ba (Offset 0) len - freeze ms - where - !len = size s - !nbBytes = charToBytes (fromEnum c) - --- | Extract the String stripped of the last character and the last character if not empty --- --- If empty, Nothing is returned -unsnoc :: String -> Maybe (String, Char) -unsnoc s@(String arr) - | sz == 0 = Nothing - | otherwise = - let !(StepBack c idx) = prev s (sizeAsOffset sz) - in Just (String $ Vec.take (offsetAsSize idx) arr, c) - where - sz = size s - --- | Extract the First character of a string, and the String stripped of the first character. --- --- If empty, Nothing is returned -uncons :: String -> Maybe (Char, String) -uncons s@(String ba) - | null s = Nothing - | otherwise = - let !(Step c idx) = next s azero - in Just (c, String $ Vec.drop (offsetAsSize idx) ba) - --- | Look for a predicate in the String and return the matched character, if any. -find :: (Char -> Bool) -> String -> Maybe Char -find predicate s = loop (Offset 0) - where - !sz = size s - end = Offset 0 `offsetPlusE` sz - loop idx - | idx == end = Nothing - | otherwise = - let !(Step c idx') = next s idx - in case predicate c of - True -> Just c - False -> loop idx' - --- | Sort the character in a String using a specific sort function --- --- TODO: optimise not going through a list -sortBy :: (Char -> Char -> Ordering) -> String -> String -sortBy sortF s = fromList $ Data.List.sortBy sortF $ toList s -- FIXME for tests - --- | Filter characters of a string using the predicate -filter :: (Char -> Bool) -> String -> String -filter predicate (String arr) = runST $ do - (finalSize, dst) <- newNative sz $ \mba -> - C.onBackendPrim (\ba -> BackendBA.copyFilter predicate sz mba ba start) - (\fptr -> withFinalPtr fptr $ \(Ptr addr) -> BackendAddr.copyFilter predicate sz mba addr start) - arr - freezeShrink finalSize dst - where - !sz = C.length arr - !start = C.offset arr - --- | Reverse a string -reverse :: String -> String -reverse s@(String ba) = runST $ do - ms <- new len - loop ms (Offset 0) (Offset 0 `offsetPlusE` len) - where - !len = size s - -- write those bytes - loop :: PrimMonad prim => MutableString (PrimState prim) -> Offset8 -> Offset8 -> prim String - loop ms@(MutableString mba) si didx - | didx == Offset 0 = freeze ms - | otherwise = do - let !h = Vec.unsafeIndex ba si - !nb = CountOf (getNbBytes h + 1) - d = didx `offsetMinusE` nb - case nb of - CountOf 1 -> Vec.unsafeWrite mba d h - CountOf 2 -> do - Vec.unsafeWrite mba d h - Vec.unsafeWrite mba (d + 1) (Vec.unsafeIndex ba (si + 1)) - CountOf 3 -> do - Vec.unsafeWrite mba d h - Vec.unsafeWrite mba (d + 1) (Vec.unsafeIndex ba (si + 1)) - Vec.unsafeWrite mba (d + 2) (Vec.unsafeIndex ba (si + 2)) - CountOf 4 -> do - Vec.unsafeWrite mba d h - Vec.unsafeWrite mba (d + 1) (Vec.unsafeIndex ba (si + 1)) - Vec.unsafeWrite mba (d + 2) (Vec.unsafeIndex ba (si + 2)) - Vec.unsafeWrite mba (d + 3) (Vec.unsafeIndex ba (si + 3)) - _ -> return () -- impossible - loop ms (si `offsetPlusE` nb) d - --- Finds where are the insertion points when we search for a `needle` --- within an `haystack`. -indices :: String -> String -> [Offset8] -indices (String ned) (String hy) = Vec.indices ned hy - --- | Replace all the occurrencies of `needle` with `replacement` in --- the `haystack` string. -replace :: String -> String -> String -> String -replace (String needle) (String replacement) (String haystack) = - String $ Vec.replace needle replacement haystack - --- | Return the nth character in a String --- --- Compared to an array, the string need to be scanned from the beginning --- since the UTF8 encoding is variable. -index :: String -> Offset Char -> Maybe Char -index s n - | ofs >= end = Nothing - | otherwise = - let (Step !c _) = next s ofs - in Just c - where - !nbBytes = size s - end = 0 `offsetPlusE` nbBytes - ofs = indexN (offsetAsSize n) s - --- | Return the index in unit of Char of the first occurence of the predicate returning True --- --- If not found, Nothing is returned -findIndex :: (Char -> Bool) -> String -> Maybe (Offset Char) -findIndex predicate s = loop 0 0 - where - !sz = size s - loop ofs idx - | idx .==# sz = Nothing - | otherwise = - let !(Step c idx') = next s idx - in case predicate c of - True -> Just ofs - False -> loop (ofs+1) idx' - --- | Various String Encoding that can be use to convert to and from bytes -data Encoding - = ASCII7 - | UTF8 - | UTF16 - | UTF32 - | ISO_8859_1 - deriving (Typeable, Data, Eq, Ord, Show, Enum, Bounded) - -fromEncoderBytes :: ( Encoder.Encoding encoding - , PrimType (Encoder.Unit encoding) - ) - => encoding - -> UArray Word8 - -> (String, Maybe ValidationFailure, UArray Word8) -fromEncoderBytes enc bytes = - case runST $ Encoder.convertFromTo enc EncoderUTF8 (Vec.recast bytes) of - -- TODO: Don't swallow up specific error (second element of pair) - -- TODO: Confused why all this recasting is necessary. I "typed hole"-ed my way to get this function to compile. Feels like there should be a cleaner method. - Left (off, _) -> - let (b1, b2) = Vec.splitAt (offsetAsSize off) (Vec.recast bytes) - in (String $ Vec.recast b1, Just BuildingFailure, Vec.recast b2) - Right converted -> (String converted, Nothing, mempty) - --- | Convert a ByteArray to a string assuming a specific encoding. --- --- It returns a 3-tuple of: --- --- * The string that has been succesfully converted without any error --- * An optional validation error --- * The remaining buffer that hasn't been processed (either as a result of an error, or because the encoded sequence is not fully available) --- --- Considering a stream of data that is fetched chunk by chunk, it's valid to assume --- that some sequence might fall in a chunk boundary. When converting chunks, --- if the error is Nothing and the remaining buffer is not empty, then this buffer --- need to be prepended to the next chunk -fromBytes :: Encoding -> UArray Word8 -> (String, Maybe ValidationFailure, UArray Word8) -fromBytes ASCII7 bytes = fromEncoderBytes Encoder.ASCII7 bytes -fromBytes ISO_8859_1 bytes = fromEncoderBytes Encoder.ISO_8859_1 bytes -fromBytes UTF16 bytes = fromEncoderBytes Encoder.UTF16 bytes -fromBytes UTF32 bytes = fromEncoderBytes Encoder.UTF32 bytes -fromBytes UTF8 bytes - | C.null bytes = (mempty, Nothing, mempty) - | otherwise = - case validate bytes (Offset 0) (C.length bytes) of - (_, Nothing) -> (fromBytesUnsafe bytes, Nothing, mempty) - (pos, Just vf) -> - let (b1, b2) = C.splitAt (offsetAsSize pos) bytes - in (fromBytesUnsafe b1, toErr vf, b2) - where - toErr MissingByte = Nothing - toErr InvalidHeader = Just InvalidHeader - toErr InvalidContinuation = Just InvalidContinuation - toErr BuildingFailure = Just BuildingFailure - --- | Convert a UTF8 array of bytes to a String. --- --- If there's any error in the stream, it will automatically --- insert replacement bytes to replace invalid sequences. --- --- In the case of sequence that fall in the middle of 2 chunks, --- the remaining buffer is supposed to be preprended to the --- next chunk, and resume the parsing. -fromBytesLenient :: UArray Word8 -> (String, UArray Word8) -fromBytesLenient bytes - | C.null bytes = (mempty, mempty) - | otherwise = - case validate bytes (Offset 0) (C.length bytes) of - (_, Nothing) -> (fromBytesUnsafe bytes, mempty) - -- TODO: Should anything be done in the 'BuildingFailure' case? - (_, Just BuildingFailure) -> error "fromBytesLenient: FIXME!" - (pos, Just MissingByte) -> - let (b1,b2) = C.splitAt (offsetAsSize pos) bytes - in (fromBytesUnsafe b1, b2) - (pos, Just InvalidHeader) -> - let (b1,b2) = C.splitAt (offsetAsSize pos) bytes - (_,b3) = C.splitAt 1 b2 - (s3, r) = fromBytesLenient b3 - in (mconcat [fromBytesUnsafe b1,replacement, s3], r) - (pos, Just InvalidContinuation) -> - let (b1,b2) = C.splitAt (offsetAsSize pos) bytes - (_,b3) = C.splitAt 1 b2 - (s3, r) = fromBytesLenient b3 - in (mconcat [fromBytesUnsafe b1,replacement, s3], r) - where - -- This is the replacement character U+FFFD used for any invalid header or continuation - replacement :: String - !replacement = fromBytesUnsafe $ fromList [0xef,0xbf,0xbd] - --- | Decode a stream of binary chunks containing UTF8 encoding in a list of valid String --- --- Chunk not necessarily contains a valid string, as --- a UTF8 sequence could be split over 2 chunks. -fromChunkBytes :: [UArray Word8] -> [String] -fromChunkBytes l = loop l - where - loop [] = [] - loop [bytes] = - case validate bytes (Offset 0) (C.length bytes) of - (_, Nothing) -> [fromBytesUnsafe bytes] - (_, Just err) -> doErr err - loop (bytes:cs@(c1:c2)) = - case validate bytes (Offset 0) (C.length bytes) of - (_, Nothing) -> fromBytesUnsafe bytes : loop cs - (pos, Just MissingByte) -> - let (b1,b2) = C.splitAt (offsetAsSize pos) bytes - in fromBytesUnsafe b1 : loop ((b2 `mappend` c1) : c2) - (_, Just err) -> doErr err - doErr err = error ("fromChunkBytes: " <> show err) - --- | Convert a Byte Array representing UTF8 data directly to a string without checking for UTF8 validity --- --- If the input contains invalid sequences, it will trigger runtime async errors when processing data. --- --- In doubt, use 'fromBytes' -fromBytesUnsafe :: UArray Word8 -> String -fromBytesUnsafe = String - -toEncoderBytes :: ( Encoder.Encoding encoding - , PrimType (Encoder.Unit encoding) - , Exception (Encoder.Error encoding) - ) - => encoding - -> UArray Word8 - -> UArray Word8 -toEncoderBytes enc bytes = Vec.recast $ - case runST $ Encoder.convertFromTo EncoderUTF8 enc bytes of - Left _ -> error "toEncoderBytes: FIXME!" - Right converted -> converted - --- | Convert a String to a bytearray in a specific encoding --- --- if the encoding is UTF8, the underlying buffer is returned without extra allocation or any processing --- --- In any other encoding, some allocation and processing are done to convert. -toBytes :: Encoding -> String -> UArray Word8 -toBytes UTF8 (String bytes) = bytes -toBytes ASCII7 (String bytes) = toEncoderBytes Encoder.ASCII7 bytes -toBytes ISO_8859_1 (String bytes) = toEncoderBytes Encoder.ISO_8859_1 bytes -toBytes UTF16 (String bytes) = toEncoderBytes Encoder.UTF16 bytes -toBytes UTF32 (String bytes) = toEncoderBytes Encoder.UTF32 bytes - --- | Split lines in a string using newline as separation. --- --- Note that carriage return preceding a newline are also strip for --- maximum compatibility between Windows and Unix system. -lines :: String -> [String] -lines s = - case breakLine s of - Left _ -> [s] - Right (line,r) -> line : lines r - --- | Split words in a string using spaces as separation --- --- > words "Hello Foundation" --- [ "Hello", "Foundation" ] -words :: String -> [String] -words = fmap fromList . Prelude.words . toList - --- | Append a character to a String builder -builderAppend :: PrimMonad state => Char -> Builder String MutableString Word8 state err () -builderAppend c = Builder $ State $ \(i, st, e) -> - if offsetAsSize i + nbBytes >= chunkSize st - then do - cur <- unsafeFreezeShrink (curChunk st) (offsetAsSize i) - newChunk <- new (chunkSize st) - writeUTF8Char newChunk (Offset 0) utf8Char - return ((), (sizeAsOffset nbBytes, st { prevChunks = cur : prevChunks st - , prevChunksSize = offsetAsSize i + prevChunksSize st - , curChunk = newChunk - }, e)) - else do - writeUTF8Char (curChunk st) i utf8Char - return ((), (i + sizeAsOffset nbBytes, st, e)) - where - utf8Char = asUTF8Char c - nbBytes = numBytes utf8Char - --- | Create a new String builder using chunks of @sizeChunksI@ -builderBuild :: PrimMonad m => Int -> Builder String MutableString Word8 m err () -> m (Either err String) -builderBuild sizeChunksI sb - | sizeChunksI <= 3 = builderBuild 64 sb - | otherwise = do - firstChunk <- new sizeChunks - ((), (i, st, e)) <- runState (runBuilder sb) (Offset 0, BuildingState [] (CountOf 0) firstChunk sizeChunks, Nothing) - case e of - Just err -> return (Left err) - Nothing -> do - cur <- unsafeFreezeShrink (curChunk st) (offsetAsSize i) - -- Build final array - let totalSize = prevChunksSize st + offsetAsSize i - final <- Vec.new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= Vec.unsafeFreeze - return . Right . String $ final - where - sizeChunks = CountOf sizeChunksI - - fillFromEnd _ [] mba = return mba - fillFromEnd !end (String x:xs) mba = do - let sz = Vec.length x - Vec.unsafeCopyAtRO mba (sizeAsOffset (end - sz)) x (Offset 0) sz - fillFromEnd (end - sz) 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) - | needleLen > hayLen = False - | otherwise = loop 0 - where - endOfs = hayLen - needleLen - needleLen = C.length needle - hayLen = C.length haystack - - loop i - | i == endOfs = needle == haystackSub - | needle == haystackSub = True - | otherwise = loop (i+1) - where haystackSub = C.take needleLen $ C.drop i haystack - --- | Try to strip a prefix from the start of a String. --- --- If the prefix is not starting the string, then Nothing is returned, --- otherwise the striped string is returned -stripPrefix :: String -> String -> Maybe String -stripPrefix (String suffix) (String arr) - | C.isPrefixOf suffix arr = Just $ String $ C.drop (C.length suffix) arr - | otherwise = Nothing - --- | Try to strip a suffix from the end of a String. --- --- If the suffix is not ending the string, then Nothing is returned, --- otherwise the striped string is returned -stripSuffix :: String -> String -> Maybe String -stripSuffix (String prefix) (String arr) - | C.isSuffixOf prefix arr = Just $ String $ C.revDrop (C.length prefix) arr - | otherwise = Nothing - -all :: (Char -> Bool) -> String -> Bool -all predicate (String arr) = C.onBackend goNative (\_ -> pure . goAddr) arr - where - !(C.ValidRange start end) = C.offsetsValidRange arr - goNative ba = PrimBA.all predicate ba start end - goAddr (Ptr addr) = PrimAddr.all predicate addr start end - -any :: (Char -> Bool) -> String -> Bool -any predicate (String arr) = C.onBackend goNative (\_ -> pure . goAddr) arr - where - !(C.ValidRange start end) = C.offsetsValidRange arr - goNative ba = PrimBA.any predicate ba start end - goAddr (Ptr addr) = PrimAddr.any predicate addr start end - --- | Transform string @src@ to base64 binary representation. -toBase64 :: String -> String -toBase64 (String src) = fromBytesUnsafe . Vec.toBase64Internal set src $ True - where - !set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"# - --- | Transform string @src@ to URL-safe base64 binary representation. --- The result will be either padded or unpadded, depending on the boolean --- @padded@ argument. -toBase64URL :: Bool -> String -> String -toBase64URL padded (String src) = fromBytesUnsafe . Vec.toBase64Internal set src $ padded - where - !set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_"# - --- | Transform string @src@ to OpenBSD base64 binary representation. -toBase64OpenBSD :: String -> String -toBase64OpenBSD (String src) = fromBytesUnsafe . Vec.toBase64Internal set src $ False - where - !set = "./ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"# diff --git a/Foundation/String/UTF8/Addr.hs b/Foundation/String/UTF8/Addr.hs deleted file mode 100644 --- a/Foundation/String/UTF8/Addr.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -module Foundation.String.UTF8.Addr - ( copyFilter - , validate - ) where - -import GHC.Prim -import GHC.ST -import Foundation.Internal.Base -import Foundation.Numerical -import Foundation.Primitive.Types.OffsetSize - -import qualified Foundation.Primitive.UTF8.BA as PrimBA -import qualified Foundation.Primitive.UTF8.Addr as PrimBackend -import Foundation.Primitive.UTF8.Helper -import Foundation.Primitive.UTF8.Table -import Foundation.Primitive.UTF8.Types - -copyFilter :: (Char -> Bool) - -> CountOf Word8 - -> MutableByteArray# s - -> PrimBackend.Immutable - -> Offset Word8 - -> ST s (CountOf Word8) -copyFilter predicate !sz dst src start = loop (Offset 0) start - where - !end = start `offsetPlusE` sz - loop !d !s - | s == end = pure (offsetAsSize d) - | otherwise = - let !h = PrimBackend.primIndex src s - in case headerIsAscii h of - True | predicate (toChar1 h) -> PrimBA.primWrite dst d h >> loop (d + Offset 1) (s + Offset 1) - | otherwise -> loop d (s + Offset 1) - False -> - case PrimBackend.next src s of - Step c s' | predicate c -> PrimBA.write dst d c >>= \d' -> loop d' s' - | otherwise -> loop d s' - -validate :: Offset Word8 - -> PrimBackend.Immutable - -> Offset Word8 - -> (Offset Word8, Maybe ValidationFailure) -validate end ba ofsStart = loop ofsStart - where - loop !ofs - | ofs > end = error ("validate: internal error: went pass offset : ofs=" <> show ofs <> " end=" <> show end) - | ofs == end = (end, Nothing) - | otherwise = - let !h = PrimBackend.primIndex ba ofs in - case headerIsAscii h of - True -> loop (ofs + Offset 1) - False -> - case one (CountOf $ getNbBytes h) ofs of - (nextOfs, Nothing) -> loop nextOfs - (pos, Just failure) -> (pos, Just failure) - - one (CountOf 0xff) pos = (pos, Just InvalidHeader) - one nbConts pos - | ((pos+Offset 1) `offsetPlusE` nbConts) > end = (pos, Just MissingByte) - | otherwise = - case nbConts of - CountOf 1 -> - let c1 = PrimBackend.primIndex ba (pos + Offset 1) - in if isContinuation c1 - then (pos + Offset 2, Nothing) - else (pos, Just InvalidContinuation) - CountOf 2 -> - let c1 = PrimBackend.primIndex ba (pos + Offset 1) - c2 = PrimBackend.primIndex ba (pos + Offset 2) - in if isContinuation c1 && isContinuation c2 - then (pos + Offset 3, Nothing) - else (pos, Just InvalidContinuation) - CountOf 3 -> - let c1 = PrimBackend.primIndex ba (pos + Offset 1) - c2 = PrimBackend.primIndex ba (pos + Offset 2) - c3 = PrimBackend.primIndex ba (pos + Offset 3) - in if isContinuation c1 && isContinuation c2 && isContinuation c3 - then (pos + Offset 4, Nothing) - else (pos, Just InvalidContinuation) - CountOf _ -> error "internal error" diff --git a/Foundation/String/UTF8/BA.hs b/Foundation/String/UTF8/BA.hs deleted file mode 100644 --- a/Foundation/String/UTF8/BA.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -module Foundation.String.UTF8.BA - ( copyFilter - , validate - ) where - -import GHC.Prim -import GHC.ST -import Foundation.Internal.Base -import Foundation.Numerical -import Foundation.Primitive.Types.OffsetSize - -import qualified Foundation.Primitive.UTF8.BA as PrimBA -import qualified Foundation.Primitive.UTF8.BA as PrimBackend -import Foundation.Primitive.UTF8.Helper -import Foundation.Primitive.UTF8.Table -import Foundation.Primitive.UTF8.Types - -copyFilter :: (Char -> Bool) - -> CountOf Word8 - -> MutableByteArray# s - -> PrimBackend.Immutable - -> Offset Word8 - -> ST s (CountOf Word8) -copyFilter predicate !sz dst src start = loop (Offset 0) start - where - !end = start `offsetPlusE` sz - loop !d !s - | s == end = pure (offsetAsSize d) - | otherwise = - let !h = PrimBackend.primIndex src s - in case headerIsAscii h of - True | predicate (toChar1 h) -> PrimBA.primWrite dst d h >> loop (d + Offset 1) (s + Offset 1) - | otherwise -> loop d (s + Offset 1) - False -> - case PrimBackend.next src s of - Step c s' | predicate c -> PrimBA.write dst d c >>= \d' -> loop d' s' - | otherwise -> loop d s' - -validate :: Offset Word8 - -> PrimBackend.Immutable - -> Offset Word8 - -> (Offset Word8, Maybe ValidationFailure) -validate end ba ofsStart = loop ofsStart - where - loop !ofs - | ofs > end = error ("validate: internal error: went pass offset : ofs=" <> show ofs <> " end=" <> show end) - | ofs == end = (end, Nothing) - | otherwise = - let !h = PrimBackend.primIndex ba ofs in - case headerIsAscii h of - True -> loop (ofs + Offset 1) - False -> - case one (CountOf $ getNbBytes h) ofs of - (nextOfs, Nothing) -> loop nextOfs - (pos, Just failure) -> (pos, Just failure) - - one (CountOf 0xff) pos = (pos, Just InvalidHeader) - one nbConts pos - | ((pos+Offset 1) `offsetPlusE` nbConts) > end = (pos, Just MissingByte) - | otherwise = - case nbConts of - CountOf 1 -> - let c1 = PrimBackend.primIndex ba (pos + Offset 1) - in if isContinuation c1 - then (pos + Offset 2, Nothing) - else (pos, Just InvalidContinuation) - CountOf 2 -> - let c1 = PrimBackend.primIndex ba (pos + Offset 1) - c2 = PrimBackend.primIndex ba (pos + Offset 2) - in if isContinuation c1 && isContinuation c2 - then (pos + Offset 3, Nothing) - else (pos, Just InvalidContinuation) - CountOf 3 -> - let c1 = PrimBackend.primIndex ba (pos + Offset 1) - c2 = PrimBackend.primIndex ba (pos + Offset 2) - c3 = PrimBackend.primIndex ba (pos + Offset 3) - in if isContinuation c1 && isContinuation c2 && isContinuation c3 - then (pos + Offset 4, Nothing) - else (pos, Just InvalidContinuation) - CountOf _ -> error "internal error" diff --git a/Foundation/System/Bindings/Hs.hs b/Foundation/System/Bindings/Hs.hs --- a/Foundation/System/Bindings/Hs.hs +++ b/Foundation/System/Bindings/Hs.hs @@ -5,34 +5,6 @@ where import GHC.IO -import GHC.Prim -import GHC.Word import Foreign.C.Types -import Foreign.Ptr -import Foundation.Primitive.Types.OffsetSize foreign import ccall unsafe "HsBase.h __hscore_get_errno" sysHsCoreGetErrno :: IO CInt - -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 - ---foreign import ccall unsafe "foundation_utf8_length" sysHsUTF8LengthBa :: --- ByteArray# -> Offset Word8 -> Offset Word8 -> CountOf Char - ---foreign import ccall unsafe "foundation_utf8_length" sysHsUTF8LengthAddr :: --- Addr# -> Offset Word8 -> Offset Word8 -> CountOf Char diff --git a/Foundation/System/Bindings/Linux.hsc b/Foundation/System/Bindings/Linux.hsc --- a/Foundation/System/Bindings/Linux.hsc +++ b/Foundation/System/Bindings/Linux.hsc @@ -15,7 +15,7 @@ module Foundation.System.Bindings.Linux where -import Foundation.Internal.Base +import Basement.Compat.Base import Foreign.C.Types import Foundation.System.Bindings.PosixDef diff --git a/Foundation/System/Bindings/Macos.hsc b/Foundation/System/Bindings/Macos.hsc --- a/Foundation/System/Bindings/Macos.hsc +++ b/Foundation/System/Bindings/Macos.hsc @@ -2,10 +2,10 @@ module Foundation.System.Bindings.Macos where -import Foundation.Internal.Base +import Basement.Compat.Base import Foreign.C.Types import Foundation.System.Bindings.PosixDef -import Foundation.Primitive.Types.OffsetSize +import Basement.Types.OffsetSize #include #include diff --git a/Foundation/System/Bindings/Network.hsc b/Foundation/System/Bindings/Network.hsc --- a/Foundation/System/Bindings/Network.hsc +++ b/Foundation/System/Bindings/Network.hsc @@ -15,7 +15,7 @@ , herr_TryAgain ) where -import Foundation.Internal.Base +import Basement.Compat.Base import Foreign.C.Types #ifdef mingw32_HOST_OS diff --git a/Foundation/System/Bindings/Posix.hsc b/Foundation/System/Bindings/Posix.hsc --- a/Foundation/System/Bindings/Posix.hsc +++ b/Foundation/System/Bindings/Posix.hsc @@ -15,7 +15,7 @@ module Foundation.System.Bindings.Posix where -import Foundation.Internal.Base +import Basement.Compat.Base import Foreign.C.Types import Data.Bits import Foundation.System.Bindings.PosixDef diff --git a/Foundation/System/Bindings/Time.hsc b/Foundation/System/Bindings/Time.hsc --- a/Foundation/System/Bindings/Time.hsc +++ b/Foundation/System/Bindings/Time.hsc @@ -5,8 +5,8 @@ module Foundation.System.Bindings.Time where -import Foundation.Internal.Base -import Foundation.Primitive.Types.OffsetSize +import Basement.Compat.Base +import Basement.Types.OffsetSize import Foreign.C.Types #include diff --git a/Foundation/System/Entropy.hs b/Foundation/System/Entropy.hs --- a/Foundation/System/Entropy.hs +++ b/Foundation/System/Entropy.hs @@ -11,10 +11,10 @@ ) where -import Foundation.Internal.Base -import Foundation.Primitive.Types.OffsetSize -import qualified Foundation.Array.Unboxed.Mutable as A -import qualified Foundation.Array.Unboxed as A +import Basement.Compat.Base +import Basement.Types.OffsetSize +import qualified Basement.UArray.Mutable as A +import qualified Basement.UArray as A import Control.Exception import Foreign.Ptr import Foundation.Numerical diff --git a/Foundation/System/Entropy/Common.hs b/Foundation/System/Entropy/Common.hs --- a/Foundation/System/Entropy/Common.hs +++ b/Foundation/System/Entropy/Common.hs @@ -12,7 +12,7 @@ ( EntropySystemMissing(..) ) where -import Foundation.Internal.Base +import Basement.Compat.Base data EntropySystemMissing = EntropySystemMissing deriving (Show,Eq,Typeable) diff --git a/Foundation/System/Entropy/Unix.hs b/Foundation/System/Entropy/Unix.hs --- a/Foundation/System/Entropy/Unix.hs +++ b/Foundation/System/Entropy/Unix.hs @@ -21,7 +21,7 @@ import Control.Monad import System.IO import System.IO.Unsafe (unsafePerformIO) -import Foundation.Internal.Base +import Basement.Compat.Base import Prelude (fromIntegral) import Foundation.System.Entropy.Common import Foundation.Numerical diff --git a/Foundation/System/Entropy/Windows.hs b/Foundation/System/Entropy/Windows.hs --- a/Foundation/System/Entropy/Windows.hs +++ b/Foundation/System/Entropy/Windows.hs @@ -28,7 +28,7 @@ import System.Win32.Types (getLastError) import Control.Exception import Foundation.System.Entropy.Common -import Foundation.Internal.Base +import Basement.Compat.Base import qualified Prelude newtype EntropyCtx = EntropyCtx CryptCtx diff --git a/Foundation/System/Info.hs b/Foundation/System/Info.hs --- a/Foundation/System/Info.hs +++ b/Foundation/System/Info.hs @@ -29,8 +29,8 @@ import qualified Data.Version import Data.Data import qualified GHC.Conc -import Foundation.Internal.Base -import Foundation.Primitive.Endianness (Endianness(..), endianness) +import Basement.Compat.Base +import Basement.Endianness (Endianness(..), endianness) import Foundation.String data OS diff --git a/Foundation/Time/Bindings.hs b/Foundation/Time/Bindings.hs --- a/Foundation/Time/Bindings.hs +++ b/Foundation/Time/Bindings.hs @@ -4,9 +4,9 @@ , getMonotonicTime ) where -import Foundation.Primitive.Imports -import Foundation.Primitive.Types.OffsetSize -import Foundation.Primitive.Types.Ptr +import Basement.Imports +import Basement.Types.OffsetSize +import Basement.Types.Ptr import Foundation.System.Bindings.Time import Foundation.Time.Types import Foundation.Foreign.Alloc diff --git a/Foundation/Time/StopWatch.hs b/Foundation/Time/StopWatch.hs --- a/Foundation/Time/StopWatch.hs +++ b/Foundation/Time/StopWatch.hs @@ -6,27 +6,27 @@ , stopPrecise ) where -import Foundation.Primitive.Imports -import Foundation.Primitive.Types.Ptr +import Basement.Imports +import Basement.Types.Ptr import Foundation.Time.Types -import Foundation.Primitive.Block.Mutable +import Basement.Block.Mutable import Foundation.Numerical import Foreign.Storable #if defined(mingw32_HOST_OS) import System.Win32.Time -import Foundation.Primitive.Monad -import Foundation.Primitive.IntegralConv +import Basement.Monad +import Basement.IntegralConv import System.IO.Unsafe #elif defined(darwin_HOST_OS) import Foundation.System.Bindings.Macos -import Foundation.Primitive.IntegralConv +import Basement.IntegralConv import System.IO.Unsafe -import Foundation.Primitive.Types.OffsetSize +import Basement.Types.OffsetSize #else import Foundation.System.Bindings.Time -import Foundation.Primitive.Monad -import Foundation.Primitive.Types.OffsetSize +import Basement.Monad +import Basement.Types.OffsetSize #endif -- | A precise stop watch @@ -58,7 +58,7 @@ let p32 = castPtr p :: Ptr Word32 !n <- peek (p32 `ptrPlus` ofs_MachTimebaseInfo_numer) !d <- peek (p32 `ptrPlus` ofs_MachTimebaseInfo_denom) - -- touch mti .. + mutableTouch mti pure (integralUpsize n, integralUpsize d) {-# NOINLINE initPrecise #-} #endif @@ -91,6 +91,7 @@ let p64 = castPtr p :: Ptr Word64 end <- peek p64 start <- peek (p64 `ptrPlus` 8) + mutableTouch blk pure $ NanoSeconds ((end - start) * secondInNano `div` initPrecise) #elif defined(darwin_HOST_OS) end <- sysMacos_absolute_time @@ -105,6 +106,7 @@ startSec <- peek (p64 `ptrPlusCSz` size_CTimeSpec) endNSec <- peek (p64 `ptrPlus` ofs_CTimeSpec_NanoSeconds) startNSec <- peek (p64 `ptrPlus` (sizeAsOffset (sizeOfCSize size_CTimeSpec) + ofs_CTimeSpec_NanoSeconds)) + mutableTouch blk pure $ NanoSeconds $ (endSec * secondInNano + endNSec) - (startSec * secondInNano + startNSec) #endif diff --git a/Foundation/Time/Types.hs b/Foundation/Time/Types.hs --- a/Foundation/Time/Types.hs +++ b/Foundation/Time/Types.hs @@ -11,9 +11,9 @@ , Seconds(..) ) where -import Foundation.Internal.Proxy -import Foundation.Primitive.Imports -import Foundation.Primitive.Types +import Data.Proxy +import Basement.Imports +import Basement.PrimType import Foundation.Numerical import Data.Coerce diff --git a/Foundation/Timing.hs b/Foundation/Timing.hs --- a/Foundation/Timing.hs +++ b/Foundation/Timing.hs @@ -5,6 +5,7 @@ -- -- An implementation of a timing framework -- +{-# LANGUAGE CPP #-} module Foundation.Timing ( Timing(..) , Measure(..) @@ -12,11 +13,11 @@ , measure ) where -import Foundation.Primitive.Imports -import Foundation.Primitive.IntegralConv -import Foundation.Primitive.Monad --- import Foundation.Array.Unboxed hiding (unsafeFreeze) -import Foundation.Array.Unboxed.Mutable (MUArray) +import Basement.Imports +import Basement.IntegralConv +import Basement.Monad +-- import Basement.UArray hiding (unsafeFreeze) +import Basement.UArray.Mutable (MUArray) import Foundation.Collection import Foundation.Time.Types import Foundation.Numerical @@ -29,7 +30,7 @@ data Timing = Timing { timeDiff :: !NanoSeconds - , timeBytesAllocated :: !(Maybe Int64) + , timeBytesAllocated :: !(Maybe Word64) } data Measure = Measure @@ -37,11 +38,28 @@ , iters :: Word } -getGCStats :: IO (Maybe GHC.GCStats) +#if __GLASGOW_HASKELL__ >= 802 +type GCStats = GHC.RTSStats + +getGCStats :: IO (Maybe GCStats) getGCStats = do + r <- GHC.getRTSStatsEnabled + if r then pure Nothing else Just <$> GHC.getRTSStats + +diffGC :: Maybe GHC.RTSStats -> Maybe GHC.RTSStats -> Maybe Word64 +diffGC gc2 gc1 = ((-) `on` GHC.allocated_bytes) <$> gc2 <*> gc1 +#else +type GCStats = GHC.GCStats + +getGCStats :: IO (Maybe GCStats) +getGCStats = do r <- GHC.getGCStatsEnabled if r then pure Nothing else Just <$> GHC.getGCStats +diffGC :: Maybe GHC.GCStats -> Maybe GHC.GCStats -> Maybe Word64 +diffGC gc2 gc1 = integralCast <$> (((-) `on` GHC.bytesAllocated) <$> gc2 <*> gc1) +#endif + -- | Simple one-time measurement of time & other metrics spent in a function stopWatch :: (a -> b) -> a -> IO Timing stopWatch f !a = do @@ -49,7 +67,7 @@ gc1 <- getGCStats (_, ns) <- measuringNanoSeconds (evaluate $ f a) gc2 <- getGCStats - return $ Timing ns (((-) `on` GHC.bytesAllocated) <$> gc2 <*> gc1) + return $ Timing ns (diffGC gc2 gc1) -- | In depth timing & other metrics analysis of a function measure :: Word -> (a -> b) -> a -> IO Measure diff --git a/Foundation/Timing/Main.hs b/Foundation/Timing/Main.hs --- a/Foundation/Timing/Main.hs +++ b/Foundation/Timing/Main.hs @@ -11,7 +11,7 @@ ( defaultMain ) where -import Foundation.Primitive.Imports +import Basement.Imports import Foundation.IO.Terminal import Foundation.Collection import Control.Monad (when) diff --git a/Foundation/Tuple.hs b/Foundation/Tuple.hs --- a/Foundation/Tuple.hs +++ b/Foundation/Tuple.hs @@ -16,8 +16,8 @@ , Thdable(..) ) where -import Foundation.Internal.Base -import Foundation.Class.Bifunctor +import Basement.Compat.Base +import Basement.Compat.Bifunctor import Foundation.Primitive -- | Strict tuple (a,b) diff --git a/Foundation/UUID.hs b/Foundation/UUID.hs --- a/Foundation/UUID.hs +++ b/Foundation/UUID.hs @@ -13,7 +13,7 @@ import Control.Monad (unless) import Data.Maybe (fromMaybe) -import Foundation.Internal.Base +import Basement.Compat.Base import Foundation.Collection (Element, Sequential, foldl') import Foundation.Class.Storable import Foundation.Hashing.Hashable @@ -21,10 +21,10 @@ import Foundation.Parser import Foundation.Numerical import Foundation.Primitive -import Foundation.Primitive.Base16 -import Foundation.Primitive.IntegralConv -import Foundation.Primitive.Types.OffsetSize -import qualified Foundation.Array.Unboxed as UA +import Basement.Base16 +import Basement.IntegralConv +import Basement.Types.OffsetSize +import qualified Basement.UArray as UA import Foundation.Random (MonadRandom, getRandomBytes) data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 @@ -67,7 +67,7 @@ hexWord_4 w l = case hexWord32 w of (c1,c2,c3,c4,c5,c6,c7,c8) -> c1:c2:c3:c4:c5:c6:c7:c8:l hexWord64_6 w l = case word64ToWord32s w of - (# wHigh, wLow #) -> hexWord_2 (integralDownsize wHigh) $ hexWord_4 wLow l + Word32x2 wHigh wLow -> hexWord_2 (integralDownsize wHigh) $ hexWord_4 wLow l nil :: UUID nil = UUID 0 0 diff --git a/Foundation/VFS/FilePath.hs b/Foundation/VFS/FilePath.hs --- a/Foundation/VFS/FilePath.hs +++ b/Foundation/VFS/FilePath.hs @@ -34,7 +34,7 @@ , extension ) where -import Foundation.Internal.Base +import Basement.Compat.Base import Foundation.Collection import Foundation.Array import Foundation.String (Encoding(..), ValidationFailure, toBytes, fromBytes, String) diff --git a/Foundation/VFS/Path.hs b/Foundation/VFS/Path.hs --- a/Foundation/VFS/Path.hs +++ b/Foundation/VFS/Path.hs @@ -19,10 +19,10 @@ , suffix ) where -import Foundation.Internal.Base +import Basement.Compat.Base -- $setup --- >>> import Foundation.Internal.Base +-- >>> import Basement.Compat.Base -- >>> import Foundation.VFS.FilePath -- >>> import Foundation.VFS.Path diff --git a/Foundation/VFS/URI.hs b/Foundation/VFS/URI.hs --- a/Foundation/VFS/URI.hs +++ b/Foundation/VFS/URI.hs @@ -15,7 +15,7 @@ , URIPath(..) ) where -import Foundation.Internal.Base +import Basement.Compat.Base import Foundation.VFS.Path(Path(..)) -- ------------------------------------------------------------------------- -- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -143,7 +143,7 @@ Every foundation modules start by `Foundation`. * `Foundation` is the prelude replacement module. -* `Foundation.Internal` contains only compatibilty and re-export from ghc/ghc-prim/base. +* `Basement.Compat` contains only compatibilty and re-export from ghc/ghc-prim/base. * `Foundation.Primitive` is where all the lowlevel magic happens: * Important types that underpins many others part * Pervasive features diff --git a/benchs/Main.hs b/benchs/Main.hs --- a/benchs/Main.hs +++ b/benchs/Main.hs @@ -8,7 +8,7 @@ import Foundation import Foundation.Collection -import Foundation.Primitive.Block (Block) +import Basement.Block (Block) import Foundation.String.Read import Foundation.String import BenchUtil.Common @@ -45,17 +45,19 @@ ] where diffTextString :: (String -> a) + -> Maybe (UArray Char -> c) -> (Text.Text -> b) -> [Char] -> [Benchmark] - diffTextString foundationBench textBench dat = - [ bench "String" $ whnf foundationBench s + diffTextString foundationBench utf32Bench textBench dat = + [ bench "String" $ whnf foundationBench s ] + <> maybe [] (\f -> [bench "String-UTF32" $ whnf f ws]) utf32Bench #ifdef BENCH_ALL - , bench "Text" $ whnf textBench t + <> [ bench "Text" $ whnf textBench t ] #endif - ] where s = fromList dat + ws = fromList dat t = Text.pack dat diffToTextString :: (UArray Word8 -> String) @@ -74,19 +76,21 @@ diffBsTextString :: (String -> a) + -> Maybe (UArray Char -> d) -> (Text.Text -> b) -> (ByteString.ByteString -> c) -> [Char] -> [Benchmark] - diffBsTextString foundationBench textBench bytestringBench dat = - [ bench "String" $ whnf foundationBench s + diffBsTextString foundationBench utf32Bench textBench bytestringBench dat = + [ bench "String" $ whnf foundationBench s ] + <> maybe [] (\f -> [bench "String-UTF32" $ whnf f ws]) utf32Bench #ifdef BENCH_ALL - , bench "Text" $ whnf textBench t - , bench "ByteString" $ whnf bytestringBench b + <> [ bench "Text" $ whnf textBench t + , bench "ByteString" $ whnf bytestringBench b ] #endif - ] where s = fromList dat + ws = fromList dat t = Text.pack dat b = ByteString.pack $ Prelude.map (fromIntegral . fromEnum) dat @@ -99,20 +103,20 @@ allDatSuffix s = fmap (first (\x -> x <> "-" <> s)) allDat benchLength = bgroup "Length" $ - fmap (\(n, dat) -> bgroup n $ diffTextString length Text.length dat) + fmap (\(n, dat) -> bgroup n $ diffTextString length (Just length) Text.length dat) allDat benchUnpack = bgroup "Unpack" $ - fmap (\(n, dat) -> bgroup n $ diffTextString (length . toList) (length . Text.unpack) dat) + fmap (\(n, dat) -> bgroup n $ diffTextString (length . toList) (Just (length . toList)) (length . Text.unpack) dat) allDat benchElem = bgroup "Elem" $ - fmap (\(n, dat) -> bgroup n $ diffTextString (elem '.') (Text.any (== '.')) dat) + fmap (\(n, dat) -> bgroup n $ diffTextString (elem '.') (Just (elem '.')) (Text.any (== '.')) dat) allDat benchTake = bgroup "Take" $ mconcat $ fmap (\p -> - fmap (\(n, dat) -> bgroup n $ diffTextString (take (CountOf p)) (Text.take p) dat) + fmap (\(n, dat) -> bgroup n $ diffTextString (take (CountOf p)) (Just (take (CountOf p))) (Text.take p) dat) $ allDatSuffix (show p) ) [ 10, 100, 800 ] benchSplitAt = bgroup "SplitAt" $ mconcat $ fmap (\p -> - fmap (\(n, dat) -> bgroup n $ diffTextString (fst . splitAt (CountOf p)) (fst . Text.splitAt p) dat) + fmap (\(n, dat) -> bgroup n $ diffTextString (fst . splitAt (CountOf p)) (Just ((fst . splitAt (CountOf p)))) (fst . Text.splitAt p) dat) $ allDatSuffix (show p) ) [ 10, 100, 800 ] @@ -121,24 +125,24 @@ allDat benchReverse = bgroup "Reverse" $ - fmap (\(n, dat) -> bgroup n $ diffTextString reverse Text.reverse dat) + fmap (\(n, dat) -> bgroup n $ diffTextString reverse (Just reverse) Text.reverse dat) allDat benchFilter = bgroup "Filter" $ - fmap (\(n, dat) -> bgroup n $ diffTextString (filter (> 'b')) (Text.filter (> 'b')) dat) + fmap (\(n, dat) -> bgroup n $ diffTextString (filter (> 'b')) (Just $ filter (> 'b')) (Text.filter (> 'b')) dat) allDat benchRead = bgroup "Read" [ bgroup "Integer" - [ bgroup "10000" (diffTextString stringReadInteger textReadInteger (toList $ show 10000)) - , bgroup "1234567891234567890" (diffTextString stringReadInteger textReadInteger (toList $ show 1234567891234567890)) + [ bgroup "10000" (diffTextString stringReadInteger Nothing textReadInteger (toList $ show 10000)) + , bgroup "1234567891234567890" (diffTextString stringReadInteger Nothing textReadInteger (toList $ show 1234567891234567890)) ] , bgroup "Int" - [ bgroup "12345" (diffBsTextString stringReadInt textReadInt bsReadInt (toList $ show 12345)) + [ bgroup "12345" (diffBsTextString stringReadInt Nothing textReadInt bsReadInt (toList $ show 12345)) ] , bgroup "Double" - [ bgroup "100.56e23" (diffTextString (maybe undefined id . readDouble) (either undefined fst . Text.double) (toList $ show 100.56e23)) - , bgroup "-123.1247" (diffTextString (maybe undefined id . readDouble) (either undefined fst . Text.double) (toList $ show (-123.1247))) + [ bgroup "100.56e23" (diffTextString (maybe undefined id . readDouble) Nothing (either undefined fst . Text.double) (toList $ show 100.56e23)) + , bgroup "-123.1247" (diffTextString (maybe undefined id . readDouble) Nothing (either undefined fst . Text.double) (toList $ show (-123.1247))) ] ] where @@ -176,6 +180,7 @@ , benchReverse , benchFilter , benchAll + , benchSort ] where diffByteArray :: (UArray Word8 -> a) @@ -263,6 +268,17 @@ fmap (\(n, dat) -> bgroup n $ diffByteArray (filter (> 100)) (filter (> 100)) (ByteString.filter (> 100)) (Vector.filter (> 100)) dat) allDat + + benchSort = bgroup "Sort" $ fmap (\(n, dat) -> + bgroup n $ + [ bench "UArray_W8" $ whnf uarrayBench (fromList dat) + , bench "Block_W8" $ whnf blockBench (fromList dat) + ]) allDat + where + blockBench :: Block Word8 -> Block Word8 + blockBench dat = sortBy compare dat + uarrayBench :: UArray Word8 -> UArray Word8 + uarrayBench dat = sortBy compare dat -------------------------------------------------------------------------- diff --git a/cbits/foundation_mem.c b/cbits/foundation_mem.c deleted file mode 100644 --- a/cbits/foundation_mem.c +++ /dev/null @@ -1,14 +0,0 @@ -#include -#include -#include "foundation_prim.h" - -int _foundation_memcmp(const void *s1, FsOffset off1, const void *s2, FsOffset off2, FsCountOf n) -{ - return memcmp(s1 + off1, s2 + off2, n); -} - -FsOffset _foundation_mem_findbyte(uint8_t * const arr, FsOffset startofs, FsOffset endofs, uint8_t ty) -{ - uint8_t *r = memchr(arr + startofs, ty, endofs - startofs); - return ((r == NULL) ? endofs : r - arr); -} diff --git a/cbits/foundation_random.c b/cbits/foundation_random.c --- a/cbits/foundation_random.c +++ b/cbits/foundation_random.c @@ -4,16 +4,18 @@ #include #include #include +#include "foundation_prim.h" #include "foundation_system.h" #include "foundation_bits.h" #if defined(FOUNDATION_SYSTEM_LINUX) #include -#include -#include +#include #include +#ifndef _GNU_SOURCE #define _GNU_SOURCE #endif +#endif #include @@ -111,7 +113,7 @@ out[15] = cpu_to_le32(x15); } -int foundation_rngV1_generate(uint8_t newkey[CHACHA_KEY_SIZE], uint8_t *dst, uint8_t key[CHACHA_KEY_SIZE], uint32_t bytes) +int foundation_rngV1_generate(uint8_t newkey[CHACHA_KEY_SIZE], uint8_t *dst, uint8_t key[CHACHA_KEY_SIZE], FsCountOf bytes) { const int rounds = 20; uint8_t nonce[CHACHA_NONCE_SIZE] = { 0 }; diff --git a/cbits/foundation_rts.c b/cbits/foundation_rts.c deleted file mode 100644 --- a/cbits/foundation_rts.c +++ /dev/null @@ -1,8 +0,0 @@ -#include "Rts.h" - -#if __GLASGOW_HASKELL__ < 802 -int foundation_is_bytearray_pinned(void *p) -{ - return Bdescr((StgPtr) p)->flags & BF_PINNED; -} -#endif diff --git a/foundation.cabal b/foundation.cabal --- a/foundation.cabal +++ b/foundation.cabal @@ -1,5 +1,5 @@ name: foundation -version: 0.0.13 +version: 0.0.14 synopsis: Alternative prelude with batteries and no dependencies description: A custom prelude with no dependencies apart from base. @@ -29,8 +29,8 @@ 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.0.2, GHC==7.10.3, GHC==7.8.4 +cabal-version: >=1.18 +tested-with: GHC==8.2.1, GHC==8.0.2, GHC==7.10.3 extra-source-files: cbits/*.h extra-doc-files: README.md CHANGELOG.md @@ -74,9 +74,7 @@ Foundation.Class.Storable Foundation.Conduit Foundation.Conduit.Textual - Foundation.Convertible Foundation.String - Foundation.String.ASCII Foundation.String.Read Foundation.String.Builder Foundation.IO @@ -91,7 +89,6 @@ Foundation.Foreign Foundation.Collection Foundation.Primitive - Foundation.Primitive.Block Foundation.List.DList Foundation.Monad Foundation.Monad.Reader @@ -112,18 +109,7 @@ Foundation.UUID Foundation.System.Entropy Foundation.System.Bindings - other-modules: Foundation.Boot.Builder - Foundation.Boot.List - Foundation.String.Internal - Foundation.String.UTF8 - Foundation.String.UTF8.BA - Foundation.String.UTF8.Addr - Foundation.String.Encoding.Encoding - Foundation.String.Encoding.UTF16 - Foundation.String.Encoding.UTF32 - Foundation.String.Encoding.ASCII7 - Foundation.String.Encoding.ISO_8859_1 - Foundation.String.ModifiedUTF8 + other-modules: Foundation.Tuple Foundation.Hashing.FNV Foundation.Hashing.SipHash @@ -141,7 +127,6 @@ Foundation.Collection.InnerFunctor Foundation.Collection.Collection Foundation.Collection.Copy - Foundation.Collection.NonEmpty Foundation.Collection.Sequential Foundation.Collection.Keyed Foundation.Collection.Indexed @@ -150,64 +135,18 @@ Foundation.Collection.Zippable Foundation.Collection.Mappable Foundation.Conduit.Internal - Foundation.Internal.Base - Foundation.Internal.ByteSwap - Foundation.Internal.CallStack - Foundation.Internal.Environment - Foundation.Primitive.Error - Foundation.Internal.Primitive - Foundation.Internal.IsList - Foundation.Internal.Identity - Foundation.Internal.Proxy - Foundation.Internal.PrimTypes - Foundation.Internal.MonadTrans - Foundation.Internal.Natural - Foundation.Internal.NumLiteral - Foundation.Internal.Typeable - Foundation.Numerical.Primitives - Foundation.Numerical.Number - Foundation.Numerical.Additive - Foundation.Numerical.Subtractive - Foundation.Numerical.Multiplicative Foundation.Numerical.Floating Foundation.IO.File - Foundation.Primitive.Base16 - Foundation.Primitive.Block.Base - Foundation.Primitive.Block.Mutable - Foundation.Primitive.Endianness - Foundation.Primitive.Exception - Foundation.Primitive.Types - Foundation.Primitive.Types.OffsetSize - Foundation.Primitive.Types.Ptr - Foundation.Primitive.Monad - Foundation.Primitive.NormalForm - Foundation.Primitive.Utils - Foundation.Primitive.IntegralConv - Foundation.Primitive.Floating - Foundation.Primitive.FinalPtr - Foundation.Primitive.These - Foundation.Primitive.Show - Foundation.Primitive.UTF8.Table - Foundation.Primitive.UTF8.Helper - Foundation.Primitive.UTF8.Base - Foundation.Primitive.UTF8.BA - Foundation.Primitive.UTF8.Addr - Foundation.Primitive.UTF8.Types - Foundation.Primitive.UArray.Base - Foundation.Primitive.UArray.BA - Foundation.Primitive.UArray.Addr - Foundation.Primitive.Runtime - Foundation.Primitive.Imports Foundation.Monad.MonadIO Foundation.Monad.Exception Foundation.Monad.Transformer Foundation.Monad.Identity Foundation.Monad.Base + Foundation.Random.Class + Foundation.Random.DRG + Foundation.Random.ChaChaDRG + Foundation.Random.XorShift Foundation.Array.Chunked.Unboxed - Foundation.Array.Unboxed - Foundation.Array.Unboxed.Mutable - Foundation.Array.Unboxed.ByteArray - Foundation.Array.Boxed Foundation.Array.Bitmap Foundation.Foreign.Alloc Foundation.Foreign.MemoryMap @@ -222,10 +161,8 @@ include-dirs: cbits c-sources: cbits/foundation_random.c cbits/foundation_network.c - cbits/foundation_mem.c cbits/foundation_time.c cbits/foundation_utf8.c - cbits/foundation_rts.c if flag(experimental) exposed-modules: Foundation.Network.HostName @@ -246,9 +183,6 @@ if impl(ghc >= 7.10) exposed-modules: Foundation.Tuple.Nth Foundation.List.ListN - Foundation.Primitive.Nat - if impl(ghc >= 8.0) - exposed-modules: Foundation.Primitive.BlockN default-extensions: NoImplicitPrelude RebindableSyntax @@ -256,6 +190,7 @@ BangPatterns DeriveDataTypeable build-depends: base >= 4.7 && < 5 + , basement == 0.0.1 , ghc-prim -- FIXME add suport for armel mipsel -- CPP-options: -DARCH_IS_LITTLE_ENDIAN @@ -274,60 +209,29 @@ if flag(bounds-check) cpp-options: -DFOUNDATION_BOUNDS_CHECK -test-suite test-foundation - type: exitcode-stdio-1.0 - hs-source-dirs: tests - main-is: Tests.hs - other-modules: Test.Utils.Foreign - Test.Data.List - Test.Data.Network - Test.Data.Unicode - Test.Data.ASCII - Test.Foundation.Collection - Test.Foundation.Conduit - Test.Foundation.Bits - Test.Foundation.ChunkedUArray - Test.Foundation.Network.IPv4 - Test.Foundation.Network.IPv6 - Test.Foundation.Number - Test.Foundation.Encoding - Test.Foundation.Parser - Test.Foundation.Array - Test.Foundation.String - Test.Foundation.String.Base64 - Test.Foundation.Storable - Test.Foundation.Misc - Imports - if impl(ghc >= 8.0) - other-modules: Test.Foundation.Primitive.BlockN - - default-extensions: NoImplicitPrelude - RebindableSyntax - if flag(minimal-deps) - buildable: False - else - build-depends: base >= 3 && < 5 - , mtl - , QuickCheck - , tasty - , tasty-quickcheck - , tasty-hunit - , foundation - ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures - default-language: Haskell2010 - if impl(ghc >= 8.0) - ghc-options: -Wno-redundant-constraints - test-suite check-foundation type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Checks.hs other-modules: Test.Checks.Property.Collection Test.Foundation.Random + Test.Foundation.Misc + Test.Foundation.Conduit + Test.Foundation.Primitive.BlockN + Test.Foundation.Storable + Test.Foundation.Number + Test.Foundation.String.Base64 + Test.Foundation.String + Test.Foundation.Bits + Test.Data.Network + Test.Data.List + Test.Foundation.Network.IPv4 + Test.Foundation.Network.IPv6 default-extensions: NoImplicitPrelude RebindableSyntax OverloadedStrings build-depends: base >= 3 && < 5 + , basement , foundation ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures default-language: Haskell2010 @@ -368,7 +272,7 @@ if flag(minimal-deps) || impl(ghc < 7.10) buildable: False else - build-depends: base >= 4, criterion, foundation + build-depends: base >= 4, criterion, basement, foundation if flag(bench-all) cpp-options: -DBENCH_ALL build-depends: text, attoparsec, vector, bytestring diff --git a/tests/Checks.hs b/tests/Checks.hs --- a/tests/Checks.hs +++ b/tests/Checks.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE CPP #-} module Main where @@ -18,8 +19,21 @@ import Data.Ratio import Test.Foundation.Random +import Test.Foundation.Misc +import Test.Foundation.Storable +import Test.Foundation.Number +import Test.Foundation.Conduit +import Test.Foundation.String +import Test.Foundation.Network.IPv4 +import Test.Foundation.Network.IPv6 +import Test.Foundation.String.Base64 import Test.Checks.Property.Collection +import qualified Test.Foundation.Bits as Bits +#if MIN_VERSION_base(4,9,0) +import Test.Foundation.Primitive.BlockN +#endif + applyFstToSnd :: (String, String -> b) -> b applyFstToSnd (a, fab) = fab a @@ -36,6 +50,8 @@ , ("W16", f (Proxy :: Proxy Word16) arbitrary) , ("W32", f (Proxy :: Proxy Word32) arbitrary) , ("W64", f (Proxy :: Proxy Word64) arbitrary) + , ("W128", f (Proxy :: Proxy Word128) arbitrary) + , ("W256", f (Proxy :: Proxy Word256) arbitrary) , ("Word", f (Proxy :: Proxy Word) arbitrary) ]) , ("Ints", @@ -91,7 +107,9 @@ , Group "Word64" [ testAdditive (Proxy :: Proxy Word64) ] + , Group "Number" testNumberRefs ] + , Bits.tests , Group "String" [ Group "reading" [ Group "integer" @@ -139,6 +157,7 @@ ] ] , collectionProperties "DList a" (Proxy :: Proxy (DList Word8)) arbitrary + , collectionProperties "Bitmap" (Proxy :: Proxy Bitmap) arbitrary , Group "Array" [ matrixToGroup "Block" $ primTypesMatrixArbitrary $ \prx arb s -> collectionProperties ("Block " <> s) (functorProxy (Proxy :: Proxy Block) prx) arb @@ -172,5 +191,17 @@ [ matrixToGroup "Unboxed" $ primTypesMatrixArbitrary $ \prx arb s -> collectionProperties ("Unboxed " <> s) (functorProxy (Proxy :: Proxy ChunkedUArray) prx) arb ] + , testStringRefs + , testForeignStorableRefs + , testNetworkIPv4 + , testNetworkIPv6 + , testBase64Refs + , testHexadecimal + , testTime + , testUUID , testRandom + , testConduit +#if MIN_VERSION_base(4,9,0) + , testBlockN +#endif ] diff --git a/tests/DocTest.hs b/tests/DocTest.hs --- a/tests/DocTest.hs +++ b/tests/DocTest.hs @@ -19,7 +19,7 @@ flags :: [String] flags = ["-fobject-code"] --- Would be nice to just use "src" here, but both Foundation.String.UTF8 and +-- Would be nice to just use "src" here, but both Basement.String and -- Foundation.String.UTF8LL share the same module name, and doctest breaks. files :: [String] files = diff --git a/tests/Imports.hs b/tests/Imports.hs deleted file mode 100644 --- a/tests/Imports.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -module Imports - ( module X - , testCase - , testGroup - , testProperty - , assertFailure - , Positive(..) - , NonZero(..) - , (===?) - , diffList - , assertEq - , assertEq' - ) where - -import Foundation -import Test.Tasty as X hiding (testGroup) -import Test.Tasty.QuickCheck as X (Arbitrary(..), Gen, suchThat, Property, (===), (==>) - , Small(..), QuickCheckTests(..) - , forAll, vectorOf, frequency, choose, elements) -#if MIN_VERSION_tasty_quickcheck(0,8,4) -import Test.Tasty.QuickCheck as X (QuickCheckVerbose(..)) -#endif -import Test.Tasty.HUnit as X hiding (testCase, assert, assertFailure) -import Test.QuickCheck.Monadic as X - - -import qualified Test.Tasty as Y -import qualified Test.Tasty.QuickCheck as Y -import qualified Test.Tasty.HUnit as Y - -assertEq :: (Eq a, Show a) => a -> a -> Bool -assertEq got expected - | got == expected = True - | otherwise = error ("got: " <> show got <> " expected: " <> show expected) -assertEq' :: (Eq a, Show a) => a -> a -> X.Assertion -assertEq' got expected - | got == expected = return () - | otherwise = error ("got: " <> show got <> " expected: " <> show expected) - -testCase :: String -> X.Assertion -> X.TestTree -testCase x f = Y.testCase (toList x) f - -assertFailure :: String -> X.Assertion -assertFailure x = Y.assertFailure (toList x) - -testGroup :: String -> [TestTree] -> TestTree -testGroup x l = Y.testGroup (toList x) l - -testProperty :: Y.Testable a => String -> a -> TestTree -testProperty x l = Y.testProperty (toList x) l - -newtype Positive a = Positive { getPositive :: a } - deriving ( Eq, Ord, Show, Enum) -instance (Ord a, Integral a, Arbitrary a) => Arbitrary (Positive a) where - arbitrary = Positive <$> (arbitrary `suchThat` \i -> i > 0) - shrink (Positive x) = [ Positive x' | x' <- shrink x , x' > 0 ] -newtype NonZero a = NonZero { getNonZero :: a } - deriving (Eq, Ord, Show, Enum) -instance (Ord a, Integral a, Arbitrary a) => Arbitrary (NonZero a) where - arbitrary = NonZero <$> (arbitrary `suchThat` \i -> i /= 0) - shrink (NonZero x) = [ NonZero x' | x' <- shrink x , x' /= 0 ] - -infix 4 ===? - -(===?) :: (Eq a, Show a) => [a] -> [a] -> Property -x ===? y = - Y.counterexample (toList msg) (x == y) - where - msg = diffList x y - -diffList :: (Eq a, Show a) => [a] -> [a] -> String -diffList a b = "left : " <> show a <> "\nright: " <> show b <> "\ndiff : " <> show d - where - d = loop 0 a b - loop :: (Eq a, Show a) => Int -> [a] -> [a] -> String - loop _ [] [] = "internal error : list is equal" - loop n l1@(_:_) [] = "offset=" <> show n <> " extra left=" <> show l1 - loop n [] l2@(_:_) = "offset=" <> show n <> " extra right=" <> show l2 - loop n l1@(x:xs) l2@(y:ys) - | x == y = loop (n+1) xs ys - | otherwise = "offset=" <> show n <> " left=" <> show l1 <> " right= " <> show l2 - diff --git a/tests/Test/Checks/Property/Collection.hs b/tests/Test/Checks/Property/Collection.hs --- a/tests/Test/Checks/Property/Collection.hs +++ b/tests/Test/Checks/Property/Collection.hs @@ -26,6 +26,8 @@ , testMonoidProperties , testCollectionProperties , testSequentialProperties + , fromListP + , toListP ) where import Foundation @@ -222,8 +224,10 @@ , Property "revDrop" $ withElements2 $ \(l, n) -> toList (revDrop n $ fromListP proxy l) === (revDrop n) l , Property "revSplitAt" $ withElements2 $ \(l, n) -> toList2 (revSplitAt n $ fromListP proxy l) === (revSplitAt n) l , Property "break" $ withElements2E $ \(l, c) -> toList2 (break (== c) $ fromListP proxy l) === (break (== c)) l + , Property "breakEnd" $ withElements2E $ \(l, c) -> toList2 (breakEnd (== c) $ fromListP proxy l) === (breakEnd (== c)) l , Property "breakElem" $ withElements2E $ \(l, c) -> toList2 (breakElem c $ fromListP proxy l) === (breakElem c) l , Property "span" $ withElements2E $ \(l, c) -> toList2 (span (== c) $ fromListP proxy l) === (span (== c)) l + , Property "spanEnd" $ withElements2E $ \(l, c) -> toList2 (spanEnd (== c) $ fromListP proxy l) === (spanEnd (== c)) l , Property "filter" $ withElements2E $ \(l, c) -> toList (filter (== c) $ fromListP proxy l) === (filter (== c)) l , Property "partition" $ withElements2E $ \(l, c) -> toList2 (partition (== c) $ fromListP proxy l) === (partition (== c)) l , Property "snoc" $ withElements2E $ \(l, c) -> toList (snoc (fromListP proxy l) c) === (l <> [c]) @@ -278,6 +282,12 @@ , Property "collection + empty" $ withElements $ \l1 -> isPrefixOf (fromListP proxy []) (fromListP proxy l1) === isPrefixOf [] l1 ] + , Group "isInfixOf" + [ Property "b isInfixOf 'a b c'" $ with3Elements $ \(a, b, c) -> + isInfixOf (toCol b) (toCol a <> toCol b <> toCol c) + , Property "the reverse is typically not an infix" $ withElements $ \a' -> + let a = toCol a'; rev = reverse a in isInfixOf rev a === (a == rev) + ] ] {- , testProperty "imap" $ \(CharMap (LUString u) i) -> @@ -285,11 +295,13 @@ ] -} where + toCol = fromListP proxy toList2 (x,y) = (toList x, toList y) toListFirst (x,y) = (toList x, y) toListSecond (x,y) = (x, toList y) withElements f = forAll (generateListOfElement genElement) f with2Elements f = forAll ((,) <$> generateListOfElement genElement <*> generateListOfElement genElement) f + with3Elements f = forAll ((,,) <$> generateListOfElement genElement <*> generateListOfElement genElement <*> generateListOfElement genElement) f withElements2 f = forAll ((,) <$> generateListOfElement genElement <*> arbitrary) f withElements3 f = forAll ((,,) <$> generateListOfElement genElement <*> arbitrary <*> arbitrary) f withElements2E f = forAll ((,) <$> generateListOfElement genElement <*> genElement) f diff --git a/tests/Test/Data/ASCII.hs b/tests/Test/Data/ASCII.hs deleted file mode 100644 --- a/tests/Test/Data/ASCII.hs +++ /dev/null @@ -1,17 +0,0 @@ --- | --- Module: Test.Data.ASCII --- - -{-# LANGUAGE NoImplicitPrelude #-} - -module Test.Data.ASCII - ( genAsciiChar - ) where - -import Foundation -import Foundation.Foreign -import Test.Tasty.QuickCheck - --- | a better generator for unicode Character -genAsciiChar :: Gen CUChar -genAsciiChar = toEnum <$> choose (1, 127) diff --git a/tests/Test/Data/List.hs b/tests/Test/Data/List.hs --- a/tests/Test/Data/List.hs +++ b/tests/Test/Data/List.hs @@ -8,9 +8,10 @@ ) where import Foundation +import Foundation.Primitive import Foundation.Collection (nonEmpty_, NonEmpty) -import Test.Tasty.QuickCheck -import Control.Monad +import Foundation.Check +import Foundation.Monad -- | convenient function to replicate thegiven Generator of `e` a randomly -- choosen amount of time. @@ -19,14 +20,20 @@ -- | convenient function to generate up to a certain amount of time the given -- generator. -generateListOfElementMaxN :: Int -> Gen e -> Gen [e] -generateListOfElementMaxN n e = choose (0,n) >>= flip replicateM e +generateListOfElementMaxN :: CountOf e -> Gen e -> Gen [e] +generateListOfElementMaxN (CountOf n) e = replicateBetween 0 (integralCast n) e -generateNonEmptyListOfElement :: Int -> Gen e -> Gen (NonEmpty [e]) -generateNonEmptyListOfElement n e = nonEmpty_ <$> (choose (1,n) >>= flip replicateM e) +generateNonEmptyListOfElement :: CountOf e -> Gen e -> Gen (NonEmpty [e]) +generateNonEmptyListOfElement (CountOf n) e = nonEmpty_ <$> replicateBetween 1 (integralCast n) e data RandomList = RandomList [Int] deriving (Show,Eq) instance Arbitrary RandomList where - arbitrary = RandomList <$> (choose (100,400) >>= flip replicateM (choose (0,8))) + arbitrary = RandomList <$> replicateBetween 100 400 (integralCast <$> between (0,8)) + +replicateBetween n1 n2 f = + between (n1, n2) >>= \n -> replicateM (CountOf (toInt n)) f + where + toInt :: Word -> Int + toInt = integralCast diff --git a/tests/Test/Data/Network.hs b/tests/Test/Data/Network.hs --- a/tests/Test/Data/Network.hs +++ b/tests/Test/Data/Network.hs @@ -19,10 +19,10 @@ ) where import Foundation +import Foundation.Check import Foundation.Network.IPv4 as IPv4 import Foundation.Network.IPv6 as IPv6 import Foundation.Class.Storable as F -import Test.Tasty.QuickCheck import qualified Foreign.Storable as Foreign instance Arbitrary IPv4 where @@ -42,10 +42,10 @@ genIPv4Tuple :: Gen (Word8, Word8, Word8, Word8) genIPv4Tuple = - (,,,) <$> choose (0, 255) - <*> choose (0, 255) - <*> choose (0, 255) - <*> choose (0, 255) + (,,,) <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary genIPv6Tuple :: Gen (Word16, Word16, Word16, Word16, Word16, Word16, Word16, Word16) genIPv6Tuple = diff --git a/tests/Test/Data/Unicode.hs b/tests/Test/Data/Unicode.hs deleted file mode 100644 --- a/tests/Test/Data/Unicode.hs +++ /dev/null @@ -1,45 +0,0 @@ --- | --- Module: Test.Data.Unicode --- - -{-# LANGUAGE TypeFamilies #-} - -module Test.Data.Unicode - ( LUString(..) - , genUnicodeChar - ) where - -import Test.Tasty.QuickCheck -import Control.Monad (replicateM) -import Foundation - --- | a better generator for unicode Character -genUnicodeChar :: Gen Char -genUnicodeChar = - toEnum <$> oneof - [ choose (1, 0xff) - , choose (0x100, 0x1000) - , choose (0x100, 0x10000) - , choose (0x1, 0x1000) - ] - --- | data type instance to generate a Lazy String (list of Char `[Char]`) but --- with higher probability of generating unicode characters -data LUString = LUString { toLString :: LString } - deriving (Show, Eq, Ord) - -instance IsString LUString where - fromString = LUString -instance IsList LUString where - type Item LUString = Char - fromList = LUString - toList (LUString l) = l -instance Arbitrary LUString where - arbitrary = do - n <- choose (0,200) - oneof - [ LUString <$> replicateM n (toEnum <$> choose (1, 0xff)) - , LUString <$> replicateM n (toEnum <$> choose (0x100, 0x1000)) - , LUString <$> replicateM n (toEnum <$> choose (0x100, 0x10000)) - , LUString <$> replicateM n (toEnum <$> choose (0x1, 0x1000)) - ] diff --git a/tests/Test/Foundation/Array.hs b/tests/Test/Foundation/Array.hs deleted file mode 100644 --- a/tests/Test/Foundation/Array.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -module Test.Foundation.Array - ( testArrayRefs - ) where - -import Control.Monad -import Foundation -import Foundation.Collection -import Foundation.Foreign -import Foundation.Primitive -import Foundation.Class.Storable - -import Test.Tasty -import Test.Tasty.QuickCheck -import Test.QuickCheck.Monadic - -import Test.Foundation.Collection -import Test.Data.List -import Test.Utils.Foreign - -testArrayRefs :: TestTree -testArrayRefs = testGroup "Array" - [ testGroup "Unboxed-Foreign" - [ testGroup "UArray(W8)" (testUnboxedForeign (Proxy :: Proxy (UArray Word8)) arbitrary) - , testGroup "UArray(W16)" (testUnboxedForeign (Proxy :: Proxy (UArray Word16)) arbitrary) - , testGroup "UArray(W32)" (testUnboxedForeign (Proxy :: Proxy (UArray Word32)) arbitrary) - , testGroup "UArray(W64)" (testUnboxedForeign (Proxy :: Proxy (UArray Word64)) arbitrary) - , testGroup "UArray(I8)" (testUnboxedForeign (Proxy :: Proxy (UArray Int8)) arbitrary) - , testGroup "UArray(I16)" (testUnboxedForeign (Proxy :: Proxy (UArray Int16)) arbitrary) - , testGroup "UArray(I32)" (testUnboxedForeign (Proxy :: Proxy (UArray Int32)) arbitrary) - , testGroup "UArray(I64)" (testUnboxedForeign (Proxy :: Proxy (UArray Int64)) arbitrary) - , testGroup "UArray(F32)" (testUnboxedForeign (Proxy :: Proxy (UArray Float)) arbitrary) - , testGroup "UArray(F64)" (testUnboxedForeign (Proxy :: Proxy (UArray Double)) arbitrary) - , testGroup "UArray(CChar)" (testUnboxedForeign (Proxy :: Proxy (UArray CChar)) (CChar <$> arbitrary)) - , testGroup "UArray(CUChar)" (testUnboxedForeign (Proxy :: Proxy (UArray CUChar)) (CUChar <$> arbitrary)) - , testGroup "UArray(BE W16)" (testUnboxedForeign (Proxy :: Proxy (UArray (BE Word16))) (toBE <$> arbitrary)) - , testGroup "UArray(BE W32)" (testUnboxedForeign (Proxy :: Proxy (UArray (BE Word32))) (toBE <$> arbitrary)) - , testGroup "UArray(BE W64)" (testUnboxedForeign (Proxy :: Proxy (UArray (BE Word64))) (toBE <$> arbitrary)) - , testGroup "UArray(LE W16)" (testUnboxedForeign (Proxy :: Proxy (UArray (LE Word16))) (toLE <$> arbitrary)) - , testGroup "UArray(LE W32)" (testUnboxedForeign (Proxy :: Proxy (UArray (LE Word32))) (toLE <$> arbitrary)) - , testGroup "UArray(LE W64)" (testUnboxedForeign (Proxy :: Proxy (UArray (LE Word64))) (toLE <$> arbitrary)) - ] - ] - -testUnboxedForeign :: (PrimType e, Show e, Element a ~ e, StorableFixed e) - => Proxy a -> Gen e -> [TestTree] -testUnboxedForeign proxy genElement = - [ testProperty "equal" $ withElementsM $ \fptr l -> - return $ toArrayP proxy l == foreignMem fptr (length l) - , testProperty "take" $ withElementsM $ \fptr l -> do - n <- CountOf <$> pick arbitrary - return $ take n (toArrayP proxy l) == take n (foreignMem fptr (length l)) - , testProperty "take" $ withElementsM $ \fptr l -> do - n <- CountOf <$> pick arbitrary - return $ drop n (toArrayP proxy l) == drop n (foreignMem fptr (length l)) - ] - where - withElementsM f = monadicIO $ forAllM (generateListOfElement genElement) $ \l -> run (createPtr l) >>= \fptr -> f fptr l - toArrayP :: PrimType (Element c) => Proxy c -> [Element c] -> UArray (Element c) - toArrayP _ l = fromList l diff --git a/tests/Test/Foundation/Bits.hs b/tests/Test/Foundation/Bits.hs --- a/tests/Test/Foundation/Bits.hs +++ b/tests/Test/Foundation/Bits.hs @@ -1,16 +1,46 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} module Test.Foundation.Bits ( tests ) where import Foundation.Bits -import Imports +import Foundation.Check import Foundation -tests = testGroup "Bits" - [ testProperty "round-up" $ \(Positive m) n' -> n' >= 1 ==> +newtype Shifter = Shifter Int + deriving (Show,Eq) + +instance Arbitrary Shifter where + arbitrary = Shifter . applyMod <$> arbitrary + where applyMod i = abs i `mod` 256 + +testBits :: forall a . (Integral a, IsIntegral a, Bits a, Show a, Eq a, Arbitrary a, Typeable a) + => String + -> Proxy a + -> Gen a + -> Test +testBits n _ _ = Group n + [ Property "shiftR" $ \(a :: a) (Shifter i) -> + (a `shiftR` i) === convertBack (toInteger a `shiftR` i) + , Property "shiftL" $ \(a :: a) (Shifter i) -> + (a `shiftL` i) === convertBack (toInteger a `shiftL` i) + ] + where + convertBack x + | x <= 0 = 0 + | otherwise = fromInteger x + +tests = Group "Bits" +{- + [ Property "round-up" $ \(Positive m) n' -> n' >= 1 ==> let n = 2 ^ ((n' `mod` 30) :: Word) md = alignRoundUp m n in (md `mod` n) == 0 && md >= m + -} + [ testBits "W32" (Proxy :: Proxy Word32) arbitrary + , testBits "W64" (Proxy :: Proxy Word64) arbitrary + , testBits "W128" (Proxy :: Proxy Word128) arbitrary + , testBits "W256" (Proxy :: Proxy Word256) arbitrary ] - diff --git a/tests/Test/Foundation/ChunkedUArray.hs b/tests/Test/Foundation/ChunkedUArray.hs deleted file mode 100644 --- a/tests/Test/Foundation/ChunkedUArray.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -module Test.Foundation.ChunkedUArray - ( testChunkedUArrayRefs - ) where - -import Control.Monad -import Foundation -import Foundation.Collection -import Foundation.Array -import Foundation.Foreign -import Foundation.Class.Storable -import Foundation.Primitive - -import Test.Tasty -import Test.Tasty.QuickCheck -import Test.QuickCheck.Monadic - -import Test.Foundation.Collection -import Test.Data.List -import Test.Utils.Foreign - -testChunkedUArrayRefs :: TestTree -testChunkedUArrayRefs = testGroup "ChunkedArray" - [ testGroup "Unboxed-Foreign" - [ testGroup "UArray(W8)" (testUnboxedForeign (Proxy :: Proxy (ChunkedUArray Word8)) arbitrary) - , testGroup "UArray(W16)" (testUnboxedForeign (Proxy :: Proxy (ChunkedUArray Word16)) arbitrary) - , testGroup "UArray(W32)" (testUnboxedForeign (Proxy :: Proxy (ChunkedUArray Word32)) arbitrary) - , testGroup "UArray(W64)" (testUnboxedForeign (Proxy :: Proxy (ChunkedUArray Word64)) arbitrary) - , testGroup "UArray(I8)" (testUnboxedForeign (Proxy :: Proxy (ChunkedUArray Int8)) arbitrary) - , testGroup "UArray(I16)" (testUnboxedForeign (Proxy :: Proxy (ChunkedUArray Int16)) arbitrary) - , testGroup "UArray(I32)" (testUnboxedForeign (Proxy :: Proxy (ChunkedUArray Int32)) arbitrary) - , testGroup "UArray(I64)" (testUnboxedForeign (Proxy :: Proxy (ChunkedUArray Int64)) arbitrary) - , testGroup "UArray(F32)" (testUnboxedForeign (Proxy :: Proxy (ChunkedUArray Float)) arbitrary) - , testGroup "UArray(F64)" (testUnboxedForeign (Proxy :: Proxy (ChunkedUArray Double)) arbitrary) - , testGroup "UArray(BE W16)" (testUnboxedForeign (Proxy :: Proxy (ChunkedUArray (BE Word16))) (toBE <$> arbitrary)) - , testGroup "UArray(BE W32)" (testUnboxedForeign (Proxy :: Proxy (ChunkedUArray (BE Word32))) (toBE <$> arbitrary)) - , testGroup "UArray(BE W64)" (testUnboxedForeign (Proxy :: Proxy (ChunkedUArray (BE Word64))) (toBE <$> arbitrary)) - , testGroup "UArray(LE W16)" (testUnboxedForeign (Proxy :: Proxy (ChunkedUArray (LE Word16))) (toLE <$> arbitrary)) - , testGroup "UArray(LE W32)" (testUnboxedForeign (Proxy :: Proxy (ChunkedUArray (LE Word32))) (toLE <$> arbitrary)) - , testGroup "UArray(LE W64)" (testUnboxedForeign (Proxy :: Proxy (ChunkedUArray (LE Word64))) (toLE <$> arbitrary)) - ] - ] - -testUnboxedForeign :: (PrimType e, Show e, Element a ~ e, StorableFixed e) - => Proxy a -> Gen e -> [TestTree] -testUnboxedForeign proxy genElement = - [ testProperty "equal" $ withElementsM $ \fptr l -> - return $ toArrayP proxy l == foreignMem fptr (length l) - , testProperty "take" $ withElementsM $ \fptr l -> do - n <- CountOf <$> pick arbitrary - return $ take n (toArrayP proxy l) == take n (foreignMem fptr (length l)) - , testProperty "take" $ withElementsM $ \fptr l -> do - n <- CountOf <$> pick arbitrary - return $ drop n (toArrayP proxy l) == drop n (foreignMem fptr (length l)) - ] - where - withElementsM f = monadicIO $ forAllM (generateListOfElement genElement) $ \l -> run (createPtr l) >>= \fptr -> f fptr l - toArrayP :: PrimType (Element c) => Proxy c -> [Element c] -> UArray (Element c) - toArrayP _ l = fromList l diff --git a/tests/Test/Foundation/Collection.hs b/tests/Test/Foundation/Collection.hs deleted file mode 100644 --- a/tests/Test/Foundation/Collection.hs +++ /dev/null @@ -1,260 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -module Test.Foundation.Collection - ( testCollection - , fromListP - , toListP - ) where - -import qualified Prelude - -import Imports - -import Foundation -import Foundation.Collection -import Test.Data.List - --- | internal helper to convert a list of element into a collection --- -fromListP :: (IsList c, Item c ~ Element c) => Proxy c -> [Element c] -> c -fromListP p = \x -> asProxyTypeOf (fromList x) p - --- | internal helper to convert a given Collection into a list of its element --- -toListP :: (IsList c, Item c ~ Element c) => Proxy c -> c -> [Element c] -toListP p x = toList (asProxyTypeOf x p) - --- | test property equality for the given Collection --- --- This does to enforce -testEquality :: ( Show e - , Eq e, Eq a - , Element a ~ e - , IsList a, Item a ~ Element a - ) - => Proxy a - -> Gen e - -> TestTree -testEquality proxy genElement = testGroup "equality" - [ testProperty "x == x" $ withElements $ \l -> let col = fromListP proxy l in col == col - , testProperty "x == y" $ with2Elements $ \(l1, l2) -> - (fromListP proxy l1 == fromListP proxy l2) == (l1 == l2) - ] - where - withElements f = forAll (generateListOfElement genElement) f - with2Elements f = forAll ((,) <$> generateListOfElement genElement <*> generateListOfElement genElement) f - - -testOrdering :: ( Show e - , Ord a, Ord e - , Element a ~ e - , IsList a, Item a ~ Element a - ) - => Proxy a - -> Gen e - -> TestTree -testOrdering proxy genElement = testGroup "ordering" - [ testProperty "x `compare` y" $ with2Elements $ \(l1, l2) -> - (fromListP proxy l1 `compare` fromListP proxy l2) == (l1 `compare` l2) - ] - where - with2Elements f = forAll ((,) <$> generateListOfElement genElement <*> generateListOfElement genElement) f - -testIsList :: ( Show e - , Eq e, Eq a - , Element a ~ e - , IsList a, Item a ~ Element a - ) - => Proxy a - -> Gen e - -> TestTree -testIsList proxy genElement = testGroup "IsList" - [ testProperty "fromList . toList == id" $ withElements $ \l -> (toList $ fromListP proxy l) === l - ] - where - withElements f = forAll (generateListOfElement genElement) f - --- | group of all the property a given collection should have --- --- > splitAt == (take, drop) --- --- > revSplitAt == (revTake, revDrop) --- --- > c == [Element c] --- -testSequentialProperties :: (Show a, Sequential a, Eq a, e ~ Item a) => Proxy a -> Gen e -> TestTree -testSequentialProperties proxy genElement = testGroup "Properties" - [ testProperty "splitAt == (take, drop)" $ withCollection2 $ \(col, n) -> - splitAt n col == (take n col, drop n col) - , testProperty "revSplitAt == (revTake, revDrop)" $ withCollection2 $ \(col, n) -> - revSplitAt n col == (revTake n col, revDrop n col) - ] - where - withCollection2 f = forAll ((,) <$> (fromListP proxy <$> generateListOfElement genElement) <*> (CountOf <$> arbitrary)) f - -testMonoid :: ( Show a, Show e - , Eq a, Eq e - , Monoid a - , Element a ~ e, IsList a, Item a ~ Element a - ) - => Proxy a - -> Gen e - -> TestTree -testMonoid proxy genElement = testGroup "Monoid" - [ testProperty "mempty <> x == x" $ withElements $ \l -> let col = fromListP proxy l in (col <> mempty) === col - , testProperty "x <> mempty == x" $ withElements $ \l -> let col = fromListP proxy l in (mempty <> col) === col - , testProperty "x1 <> x2 == x1|x2" $ with2Elements $ \(l1,l2) -> - (fromListP proxy l1 <> fromListP proxy l2) === fromListP proxy (l1 <> l2) - , testProperty "mconcat [map fromList [e]] = fromList (concat [e])" $ withNElements $ \l -> - mconcat (fmap (fromListP proxy) l) === fromListP proxy (mconcat l) - ] - where - withElements f = forAll (generateListOfElement genElement) f - with2Elements f = forAll ((,) <$> generateListOfElement genElement <*> generateListOfElement genElement) f - withNElements f = forAll (generateListOfElementMaxN 5 (generateListOfElement genElement)) f - -testCollection :: ( Sequential a - , Show a, Show (Element a) - , Eq (Element a) - , Ord a, Ord (Item a) - ) - => String - -> Proxy a - -> Gen (Element a) - -> TestTree -testCollection name proxy genElement = testGroup name - [ testEquality proxy genElement - , testOrdering proxy genElement - , testIsList proxy genElement - , testMonoid proxy genElement - , testCollectionOps proxy genElement - , testSequentialOps proxy genElement - ] - -fromListNonEmptyP :: Collection a => Proxy a -> NonEmpty [Element a] -> NonEmpty a -fromListNonEmptyP proxy = nonEmpty_ . fromListP proxy . getNonEmpty - -testCollectionOps :: ( Collection a - , Show a, Show (Element a) - , Eq (Element a) - , Ord a, Ord (Item a) - ) - => Proxy a - -> Gen (Element a) - -> TestTree -testCollectionOps proxy genElement = testGroup "Collection" - [ testProperty "length" $ withElements $ \l -> (length $ fromListP proxy l) === length l - , testProperty "elem" $ withListAndElement $ \(l,e) -> elem e (fromListP proxy l) == elem e l - , testProperty "notElem" $ withListAndElement $ \(l,e) -> notElem e (fromListP proxy l) == notElem e l - , testProperty "minimum" $ withNonEmptyElements $ \els -> minimum (fromListNonEmptyP proxy els) === minimum els - , testProperty "maximum" $ withNonEmptyElements $ \els -> maximum (fromListNonEmptyP proxy els) === maximum els - , testProperty "all" $ withListAndElement $ \(l, e) -> - all (/= e) (fromListP proxy l) == all (/= e) l && - all (== e) (fromListP proxy l) == all (== e) l - , testProperty "any" $ withListAndElement $ \(l, e) -> - any (/= e) (fromListP proxy l) == any (/= e) l && - any (== e) (fromListP proxy l) == any (== e) l - ] - where - withElements f = forAll (generateListOfElement genElement) f - withListAndElement = forAll ((,) <$> generateListOfElement genElement <*> genElement) - withNonEmptyElements f = forAll (generateNonEmptyListOfElement 80 genElement) f - -testSplitOn :: ( Sequential a - , Show a, Show (Element a) - , Eq (Element a) - , Eq a, Ord a, Ord (Item a), Show a - ) - => Proxy a -> (Element a -> Bool) -> a - -> TestTree -testSplitOn _ predicate col = testCase "splitOn (const True) mempty == [mempty]" $ - assertEq' (splitOn predicate col) [col] - -testSequentialOps :: ( Sequential a - , Show a, Show (Element a) - , Eq (Element a) - , Eq a, Ord a, Ord (Item a), Show a - ) - => Proxy a - -> Gen (Element a) - -> TestTree -testSequentialOps proxy genElement = testGroup "Sequential" - [ testProperty "take" $ withElements2 $ \(l, n) -> toList (take n $ fromListP proxy l) === (take n) l - , testProperty "drop" $ withElements2 $ \(l, n) -> toList (drop n $ fromListP proxy l) === (drop n) l - , testProperty "splitAt" $ withElements2 $ \(l, n) -> toList2 (splitAt n $ fromListP proxy l) === (splitAt n) l - , testProperty "revTake" $ withElements2 $ \(l, n) -> toList (revTake n $ fromListP proxy l) === (revTake n) l - , testProperty "revDrop" $ withElements2 $ \(l, n) -> toList (revDrop n $ fromListP proxy l) === (revDrop n) l - , testProperty "revSplitAt" $ withElements2 $ \(l, n) -> toList2 (revSplitAt n $ fromListP proxy l) === (revSplitAt n) l - , testProperty "break" $ withElements2E $ \(l, c) -> toList2 (break (== c) $ fromListP proxy l) === (break (== c)) l - , testProperty "breakElem" $ withElements2E $ \(l, c) -> toList2 (breakElem c $ fromListP proxy l) === (breakElem c) l - , testProperty "span" $ withElements2E $ \(l, c) -> toList2 (span (== c) $ fromListP proxy l) === (span (== c)) l - , testProperty "filter" $ withElements2E $ \(l, c) -> toList (filter (== c) $ fromListP proxy l) === (filter (== c)) l - , testProperty "partition" $ withElements2E $ \(l, c) -> toList2 (partition (== c) $ fromListP proxy l) === (partition (== c)) l - , testProperty "snoc" $ withElements2E $ \(l, c) -> toList (snoc (fromListP proxy l) c) === (l <> [c]) - , testProperty "cons" $ withElements2E $ \(l, c) -> toList (cons c (fromListP proxy l)) === (c : l) - , testProperty "unsnoc" $ withElements $ \l -> fmap toListFirst (unsnoc (fromListP proxy l)) === unsnoc l - , testProperty "uncons" $ withElements $ \l -> fmap toListSecond (uncons (fromListP proxy l)) === uncons l - , testProperty "head" $ withNonEmptyElements $ \els -> head (fromListNonEmptyP proxy els) === head els - , testProperty "last" $ withNonEmptyElements $ \els -> last (fromListNonEmptyP proxy els) === last els - , testProperty "tail" $ withNonEmptyElements $ \els -> toList (tail $ fromListNonEmptyP proxy els) === tail els - , testProperty "init" $ withNonEmptyElements $ \els -> toList (init $ fromListNonEmptyP proxy els) === init els - , testProperty "splitOn" $ withElements2E $ \(l, ch) -> - fmap toList (splitOn (== ch) (fromListP proxy l)) === splitOn (== ch) l - , testSplitOn proxy (const True) mempty - , testProperty "intercalate c (splitOn (c ==) col) == col" $ withElements2E $ \(c, ch) -> - intercalate [ch] (splitOn (== ch) c) === c - , testProperty "intercalate c (splitOn (c ==) (col ++ [c]) == (col ++ [c])" $ withElements2E $ \(c, ch) -> - intercalate [ch] (splitOn (== ch) $ snoc c ch) === (snoc c ch) - , testProperty "intercalate c (splitOn (c ==) (col ++ [c,c]) == (col ++ [c,c])" $ withElements2E $ \(c, ch) -> - intercalate [ch] (splitOn (== ch) $ snoc (snoc c ch) ch) === (snoc (snoc c ch) ch) - , testProperty "intersperse" $ withElements2E $ \(l, c) -> - toList (intersperse c (fromListP proxy l)) === intersperse c l - , testProperty "intercalate" $ withElements2E $ \(l, c) -> - let ls = Prelude.replicate 5 l - cs = Prelude.replicate 5 c - in toList (intercalate (fromListP proxy cs) (fromListP proxy <$> ls)) === intercalate cs ls - , testProperty "sortBy" $ withElements $ \l -> - (sortBy compare $ fromListP proxy l) === fromListP proxy (sortBy compare l) - , testProperty "reverse" $ withElements $ \l -> - (reverse $ fromListP proxy l) === fromListP proxy (reverse l) - -- stress slicing - , testProperty "take . take" $ withElements3 $ \(l, n1, n2) -> toList (take n2 $ take n1 $ fromListP proxy l) === (take n2 $ take n1 l) - , testProperty "drop . take" $ withElements3 $ \(l, n1, n2) -> toList (drop n2 $ take n1 $ fromListP proxy l) === (drop n2 $ take n1 l) - , testProperty "drop . drop" $ withElements3 $ \(l, n1, n2) -> toList (drop n2 $ drop n1 $ fromListP proxy l) === (drop n2 $ drop n1 l) - , testProperty "drop . take" $ withElements3 $ \(l, n1, n2) -> toList (drop n2 $ take n1 $ fromListP proxy l) === (drop n2 $ take n1 l) - , testProperty "second take . splitAt" $ withElements3 $ \(l, n1, n2) -> - (toList2 $ (second (take n1) . splitAt n2) $ fromListP proxy l) === (second (take n1) . splitAt n2) l - , testSequentialProperties proxy genElement - , testGroup "isSuffixOf" - [ testProperty "collection + sub" $ withElements2 $ \(l1, n) -> - let c1 = fromListP proxy l1 in isSuffixOf (revTake n c1) c1 === isSuffixOf (revTake n l1) l1 - , testProperty "2 collections" $ with2Elements $ \(l1, l2) -> isSuffixOf (fromListP proxy l1) (fromListP proxy l2) === isSuffixOf l1 l2 - , testProperty "collection + empty" $ withElements $ \l1 -> - isSuffixOf (fromListP proxy []) (fromListP proxy l1) === isSuffixOf [] l1 - ] - , testGroup "isPrefixOf" - [ testProperty "collection + sub" $ withElements2 $ \(l1, n) -> - let c1 = fromListP proxy l1 in isPrefixOf (take n c1) c1 === isPrefixOf (take n l1) l1 - , testProperty "2 collections" $ with2Elements $ \(l1, l2) -> isPrefixOf (fromListP proxy l1) (fromListP proxy l2) === isPrefixOf l1 l2 - , testProperty "collection + empty" $ withElements $ \l1 -> - isPrefixOf (fromListP proxy []) (fromListP proxy l1) === isPrefixOf [] l1 - ] - ] -{- - , testProperty "imap" $ \(CharMap (LUString u) i) -> - (imap (addChar i) (fromList u) :: String) `assertEq` fromList (Prelude.map (addChar i) u) - ] --} - where - toList2 (x,y) = (toList x, toList y) - toListFirst (x,y) = (toList x, y) - toListSecond (x,y) = (x, toList y) - withElements f = forAll (generateListOfElement genElement) f - with2Elements f = forAll ((,) <$> generateListOfElement genElement <*> generateListOfElement genElement) f - withElements2 f = forAll ((,) <$> generateListOfElement genElement <*> (CountOf <$> arbitrary)) f - withElements3 f = forAll ((,,) <$> generateListOfElement genElement <*> (CountOf <$> arbitrary) <*> (CountOf <$> arbitrary)) f - withElements2E f = forAll ((,) <$> generateListOfElement genElement <*> genElement) f - withNonEmptyElements f = forAll (generateNonEmptyListOfElement 80 genElement) f diff --git a/tests/Test/Foundation/Conduit.hs b/tests/Test/Foundation/Conduit.hs --- a/tests/Test/Foundation/Conduit.hs +++ b/tests/Test/Foundation/Conduit.hs @@ -6,41 +6,41 @@ ) where import Foundation +import Foundation.Check import Foundation.Conduit import Foundation.IO -import Imports - -testConduit :: TestTree -testConduit = testGroup "Conduit" - [ testCase "sourceHandle gives same data as readFile" testSourceFile - , testCase "sourceHandle/sinkHandle copies data" testCopyFile - , testCase "sourceFile/sinkFile copies data" testCopyFileRes +testConduit :: Test +testConduit = Group "Conduit" + [ CheckPlan "sourceHandle gives same data as readFile" testSourceFile + , CheckPlan "sourceHandle/sinkHandle copies data" testCopyFile + , CheckPlan "sourceFile/sinkFile copies data" testCopyFileRes ] where - testSourceFile :: Assertion + --testSourceFile :: Assertion testSourceFile = do let fp = "foundation.cabal" - arrs <- withFile fp ReadMode - $ \h -> runConduit $ sourceHandle h .| sinkList - arr <- readFile fp - assertEqual "foundation.cabal contents" arr (mconcat arrs) + arrs <- pick "conduit-read" $ withFile fp ReadMode $ \h -> + runConduit $ sourceHandle h .| sinkList + arr <- pick "read-source" $ readFile fp + validate "foundation.cabal contents" $ arr == (mconcat arrs) - testCopyFile :: Assertion + --testCopyFile :: Assertion testCopyFile = do let src = "foundation.cabal" dst = "temp-file" -- FIXME some temp file API? - withFile src ReadMode $ \hin -> withFile dst WriteMode $ \hout -> - runConduit $ sourceHandle hin .| sinkHandle hout - orig <- readFile src - new <- readFile dst - assertEqual "copied foundation.cabal contents" orig new + pick "conduit-duplicate" $ withFile src ReadMode $ \hin -> + withFile dst WriteMode $ \hout -> + runConduit $ sourceHandle hin .| sinkHandle hout + orig <- pick "read-source" $ readFile src + new <- pick "read-destination" $ readFile dst + validate "copied foundation.cabal contents" $ orig == new - testCopyFileRes :: Assertion + --testCopyFileRes :: Assertion testCopyFileRes = do let src = "foundation.cabal" dst = "temp-file" -- FIXME some temp file API? - runConduitRes $ sourceFile src .| sinkFile dst - orig <- readFile src - new <- readFile dst - assertEqual "copied foundation.cabal contents" orig new + pick "conduit-res" $ runConduitRes $ sourceFile src .| sinkFile dst + orig <- pick "read-soure" $ readFile src + new <- pick "read-destination" $ readFile dst + validate "copied foundation.cabal contents" $ orig == new diff --git a/tests/Test/Foundation/Encoding.hs b/tests/Test/Foundation/Encoding.hs deleted file mode 100644 --- a/tests/Test/Foundation/Encoding.hs +++ /dev/null @@ -1,955 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Test.Foundation.Encoding - ( EncodedString(..) - , sample0 - , sample1 - , sample2 - - , testEncodings - ) where - -import Foundation -import Foundation.String (Encoding(..), fromBytes, toBytes) -import Foundation.Array.Internal (recast) - -import Imports - -data EncodedString = EncodedString Encoding (UArray Word8) - -testEncodings :: ([EncodedString], String) -> [TestTree] -testEncodings ([] , _ ) = [] -testEncodings (x:xs, expected) = testEncoding x expected <> testEncodings (xs, expected) - -testEncoding :: EncodedString -> String -> [TestTree] -testEncoding (EncodedString encoding ba) expected = - [ testCase (show encoding <> " -> UTF8") testFromBytes - , testCase ("UTF8 -> " <> show encoding) testToBytes - ] - where - testFromBytes :: Assertion - testFromBytes = case fromBytes encoding ba of - (str, _, _) -> assertEqual "testFromBytes: " expected str - testToBytes :: Assertion - testToBytes = - let bytes = toBytes encoding expected - in assertEqual "testToBytes: " ba bytes - --- -------------------------- Sample 0 ------------------------------------- -- - -sample0 :: ([EncodedString], String) -sample0 = ( [sample0_ASCII7, sample0_UTF8, sample0_UTF16, sample0_ISO_8859_1] - , sample0_String - ) - -sample0_String :: String -sample0_String = - "Called forth to stand trial on Trantor for allegations of treason (for\n\ - \foreshadowing the decline of the Galactic Empire), Seldon explains that his\n\ - \science of psychohistory foresees many alternatives, all of which result in the\n\ - \Galactic Empire eventually falling. If humanity follows its current path, the\n\ - \Empire will fall and 30,000 years of turmoil will overcome humanity before a\n\ - \second Empire arises. However, an alternative path allows for the intervening\n\ - \years to be only one thousand, if Seldon is allowed to collect the most\n\ - \intelligent minds and create a compendium of all human knowledge, entitled\n\ - \Encyclopedia Galactica. The board is still wary but allows Seldon to assemble\n\ - \whomever he needs, provided he and the \"Encyclopedists\" be exiled to a remote\n\ - \planet, Terminus. Seldon agrees to set up his own collection of Encyclopedists,\n\ - \and also secretly implements a contingency plan-a second Foundation-at the\n\ - \\"opposite end\" of the galaxy.\n" - -sample0_ASCII7 :: EncodedString -sample0_ASCII7 = EncodedString ASCII7 $ fromList - [ 0x43, 0x61, 0x6c, 0x6c, 0x65, 0x64, 0x20, 0x66, 0x6f, 0x72, 0x74, 0x68, 0x20, 0x74, 0x6f, 0x20 - , 0x73, 0x74, 0x61, 0x6e, 0x64, 0x20, 0x74, 0x72, 0x69, 0x61, 0x6c, 0x20, 0x6f, 0x6e, 0x20, 0x54 - , 0x72, 0x61, 0x6e, 0x74, 0x6f, 0x72, 0x20, 0x66, 0x6f, 0x72, 0x20, 0x61, 0x6c, 0x6c, 0x65, 0x67 - , 0x61, 0x74, 0x69, 0x6f, 0x6e, 0x73, 0x20, 0x6f, 0x66, 0x20, 0x74, 0x72, 0x65, 0x61, 0x73, 0x6f - , 0x6e, 0x20, 0x28, 0x66, 0x6f, 0x72, 0x0a, 0x66, 0x6f, 0x72, 0x65, 0x73, 0x68, 0x61, 0x64, 0x6f - , 0x77, 0x69, 0x6e, 0x67, 0x20, 0x74, 0x68, 0x65, 0x20, 0x64, 0x65, 0x63, 0x6c, 0x69, 0x6e, 0x65 - , 0x20, 0x6f, 0x66, 0x20, 0x74, 0x68, 0x65, 0x20, 0x47, 0x61, 0x6c, 0x61, 0x63, 0x74, 0x69, 0x63 - , 0x20, 0x45, 0x6d, 0x70, 0x69, 0x72, 0x65, 0x29, 0x2c, 0x20, 0x53, 0x65, 0x6c, 0x64, 0x6f, 0x6e - , 0x20, 0x65, 0x78, 0x70, 0x6c, 0x61, 0x69, 0x6e, 0x73, 0x20, 0x74, 0x68, 0x61, 0x74, 0x20, 0x68 - , 0x69, 0x73, 0x0a, 0x73, 0x63, 0x69, 0x65, 0x6e, 0x63, 0x65, 0x20, 0x6f, 0x66, 0x20, 0x70, 0x73 - , 0x79, 0x63, 0x68, 0x6f, 0x68, 0x69, 0x73, 0x74, 0x6f, 0x72, 0x79, 0x20, 0x66, 0x6f, 0x72, 0x65 - , 0x73, 0x65, 0x65, 0x73, 0x20, 0x6d, 0x61, 0x6e, 0x79, 0x20, 0x61, 0x6c, 0x74, 0x65, 0x72, 0x6e - , 0x61, 0x74, 0x69, 0x76, 0x65, 0x73, 0x2c, 0x20, 0x61, 0x6c, 0x6c, 0x20, 0x6f, 0x66, 0x20, 0x77 - , 0x68, 0x69, 0x63, 0x68, 0x20, 0x72, 0x65, 0x73, 0x75, 0x6c, 0x74, 0x20, 0x69, 0x6e, 0x20, 0x74 - , 0x68, 0x65, 0x0a, 0x47, 0x61, 0x6c, 0x61, 0x63, 0x74, 0x69, 0x63, 0x20, 0x45, 0x6d, 0x70, 0x69 - , 0x72, 0x65, 0x20, 0x65, 0x76, 0x65, 0x6e, 0x74, 0x75, 0x61, 0x6c, 0x6c, 0x79, 0x20, 0x66, 0x61 - , 0x6c, 0x6c, 0x69, 0x6e, 0x67, 0x2e, 0x20, 0x49, 0x66, 0x20, 0x68, 0x75, 0x6d, 0x61, 0x6e, 0x69 - , 0x74, 0x79, 0x20, 0x66, 0x6f, 0x6c, 0x6c, 0x6f, 0x77, 0x73, 0x20, 0x69, 0x74, 0x73, 0x20, 0x63 - , 0x75, 0x72, 0x72, 0x65, 0x6e, 0x74, 0x20, 0x70, 0x61, 0x74, 0x68, 0x2c, 0x20, 0x74, 0x68, 0x65 - , 0x0a, 0x45, 0x6d, 0x70, 0x69, 0x72, 0x65, 0x20, 0x77, 0x69, 0x6c, 0x6c, 0x20, 0x66, 0x61, 0x6c - , 0x6c, 0x20, 0x61, 0x6e, 0x64, 0x20, 0x33, 0x30, 0x2c, 0x30, 0x30, 0x30, 0x20, 0x79, 0x65, 0x61 - , 0x72, 0x73, 0x20, 0x6f, 0x66, 0x20, 0x74, 0x75, 0x72, 0x6d, 0x6f, 0x69, 0x6c, 0x20, 0x77, 0x69 - , 0x6c, 0x6c, 0x20, 0x6f, 0x76, 0x65, 0x72, 0x63, 0x6f, 0x6d, 0x65, 0x20, 0x68, 0x75, 0x6d, 0x61 - , 0x6e, 0x69, 0x74, 0x79, 0x20, 0x62, 0x65, 0x66, 0x6f, 0x72, 0x65, 0x20, 0x61, 0x0a, 0x73, 0x65 - , 0x63, 0x6f, 0x6e, 0x64, 0x20, 0x45, 0x6d, 0x70, 0x69, 0x72, 0x65, 0x20, 0x61, 0x72, 0x69, 0x73 - , 0x65, 0x73, 0x2e, 0x20, 0x48, 0x6f, 0x77, 0x65, 0x76, 0x65, 0x72, 0x2c, 0x20, 0x61, 0x6e, 0x20 - , 0x61, 0x6c, 0x74, 0x65, 0x72, 0x6e, 0x61, 0x74, 0x69, 0x76, 0x65, 0x20, 0x70, 0x61, 0x74, 0x68 - , 0x20, 0x61, 0x6c, 0x6c, 0x6f, 0x77, 0x73, 0x20, 0x66, 0x6f, 0x72, 0x20, 0x74, 0x68, 0x65, 0x20 - , 0x69, 0x6e, 0x74, 0x65, 0x72, 0x76, 0x65, 0x6e, 0x69, 0x6e, 0x67, 0x0a, 0x79, 0x65, 0x61, 0x72 - , 0x73, 0x20, 0x74, 0x6f, 0x20, 0x62, 0x65, 0x20, 0x6f, 0x6e, 0x6c, 0x79, 0x20, 0x6f, 0x6e, 0x65 - , 0x20, 0x74, 0x68, 0x6f, 0x75, 0x73, 0x61, 0x6e, 0x64, 0x2c, 0x20, 0x69, 0x66, 0x20, 0x53, 0x65 - , 0x6c, 0x64, 0x6f, 0x6e, 0x20, 0x69, 0x73, 0x20, 0x61, 0x6c, 0x6c, 0x6f, 0x77, 0x65, 0x64, 0x20 - , 0x74, 0x6f, 0x20, 0x63, 0x6f, 0x6c, 0x6c, 0x65, 0x63, 0x74, 0x20, 0x74, 0x68, 0x65, 0x20, 0x6d - , 0x6f, 0x73, 0x74, 0x0a, 0x69, 0x6e, 0x74, 0x65, 0x6c, 0x6c, 0x69, 0x67, 0x65, 0x6e, 0x74, 0x20 - , 0x6d, 0x69, 0x6e, 0x64, 0x73, 0x20, 0x61, 0x6e, 0x64, 0x20, 0x63, 0x72, 0x65, 0x61, 0x74, 0x65 - , 0x20, 0x61, 0x20, 0x63, 0x6f, 0x6d, 0x70, 0x65, 0x6e, 0x64, 0x69, 0x75, 0x6d, 0x20, 0x6f, 0x66 - , 0x20, 0x61, 0x6c, 0x6c, 0x20, 0x68, 0x75, 0x6d, 0x61, 0x6e, 0x20, 0x6b, 0x6e, 0x6f, 0x77, 0x6c - , 0x65, 0x64, 0x67, 0x65, 0x2c, 0x20, 0x65, 0x6e, 0x74, 0x69, 0x74, 0x6c, 0x65, 0x64, 0x0a, 0x45 - , 0x6e, 0x63, 0x79, 0x63, 0x6c, 0x6f, 0x70, 0x65, 0x64, 0x69, 0x61, 0x20, 0x47, 0x61, 0x6c, 0x61 - , 0x63, 0x74, 0x69, 0x63, 0x61, 0x2e, 0x20, 0x54, 0x68, 0x65, 0x20, 0x62, 0x6f, 0x61, 0x72, 0x64 - , 0x20, 0x69, 0x73, 0x20, 0x73, 0x74, 0x69, 0x6c, 0x6c, 0x20, 0x77, 0x61, 0x72, 0x79, 0x20, 0x62 - , 0x75, 0x74, 0x20, 0x61, 0x6c, 0x6c, 0x6f, 0x77, 0x73, 0x20, 0x53, 0x65, 0x6c, 0x64, 0x6f, 0x6e - , 0x20, 0x74, 0x6f, 0x20, 0x61, 0x73, 0x73, 0x65, 0x6d, 0x62, 0x6c, 0x65, 0x0a, 0x77, 0x68, 0x6f - , 0x6d, 0x65, 0x76, 0x65, 0x72, 0x20, 0x68, 0x65, 0x20, 0x6e, 0x65, 0x65, 0x64, 0x73, 0x2c, 0x20 - , 0x70, 0x72, 0x6f, 0x76, 0x69, 0x64, 0x65, 0x64, 0x20, 0x68, 0x65, 0x20, 0x61, 0x6e, 0x64, 0x20 - , 0x74, 0x68, 0x65, 0x20, 0x22, 0x45, 0x6e, 0x63, 0x79, 0x63, 0x6c, 0x6f, 0x70, 0x65, 0x64, 0x69 - , 0x73, 0x74, 0x73, 0x22, 0x20, 0x62, 0x65, 0x20, 0x65, 0x78, 0x69, 0x6c, 0x65, 0x64, 0x20, 0x74 - , 0x6f, 0x20, 0x61, 0x20, 0x72, 0x65, 0x6d, 0x6f, 0x74, 0x65, 0x0a, 0x70, 0x6c, 0x61, 0x6e, 0x65 - , 0x74, 0x2c, 0x20, 0x54, 0x65, 0x72, 0x6d, 0x69, 0x6e, 0x75, 0x73, 0x2e, 0x20, 0x53, 0x65, 0x6c - , 0x64, 0x6f, 0x6e, 0x20, 0x61, 0x67, 0x72, 0x65, 0x65, 0x73, 0x20, 0x74, 0x6f, 0x20, 0x73, 0x65 - , 0x74, 0x20, 0x75, 0x70, 0x20, 0x68, 0x69, 0x73, 0x20, 0x6f, 0x77, 0x6e, 0x20, 0x63, 0x6f, 0x6c - , 0x6c, 0x65, 0x63, 0x74, 0x69, 0x6f, 0x6e, 0x20, 0x6f, 0x66, 0x20, 0x45, 0x6e, 0x63, 0x79, 0x63 - , 0x6c, 0x6f, 0x70, 0x65, 0x64, 0x69, 0x73, 0x74, 0x73, 0x2c, 0x0a, 0x61, 0x6e, 0x64, 0x20, 0x61 - , 0x6c, 0x73, 0x6f, 0x20, 0x73, 0x65, 0x63, 0x72, 0x65, 0x74, 0x6c, 0x79, 0x20, 0x69, 0x6d, 0x70 - , 0x6c, 0x65, 0x6d, 0x65, 0x6e, 0x74, 0x73, 0x20, 0x61, 0x20, 0x63, 0x6f, 0x6e, 0x74, 0x69, 0x6e - , 0x67, 0x65, 0x6e, 0x63, 0x79, 0x20, 0x70, 0x6c, 0x61, 0x6e, 0x2d, 0x61, 0x20, 0x73, 0x65, 0x63 - , 0x6f, 0x6e, 0x64, 0x20, 0x46, 0x6f, 0x75, 0x6e, 0x64, 0x61, 0x74, 0x69, 0x6f, 0x6e, 0x2d, 0x61 - , 0x74, 0x20, 0x74, 0x68, 0x65, 0x0a, 0x22, 0x6f, 0x70, 0x70, 0x6f, 0x73, 0x69, 0x74, 0x65, 0x20 - , 0x65, 0x6e, 0x64, 0x22, 0x20, 0x6f, 0x66, 0x20, 0x74, 0x68, 0x65, 0x20, 0x67, 0x61, 0x6c, 0x61 - , 0x78, 0x79, 0x2e, 0x0a - ] - - -sample0_UTF8 :: EncodedString -sample0_UTF8 = EncodedString UTF8 $ fromList - [ 0x43, 0x61, 0x6c, 0x6c, 0x65, 0x64, 0x20, 0x66, 0x6f, 0x72, 0x74, 0x68, 0x20, 0x74, 0x6f, 0x20 - , 0x73, 0x74, 0x61, 0x6e, 0x64, 0x20, 0x74, 0x72, 0x69, 0x61, 0x6c, 0x20, 0x6f, 0x6e, 0x20, 0x54 - , 0x72, 0x61, 0x6e, 0x74, 0x6f, 0x72, 0x20, 0x66, 0x6f, 0x72, 0x20, 0x61, 0x6c, 0x6c, 0x65, 0x67 - , 0x61, 0x74, 0x69, 0x6f, 0x6e, 0x73, 0x20, 0x6f, 0x66, 0x20, 0x74, 0x72, 0x65, 0x61, 0x73, 0x6f - , 0x6e, 0x20, 0x28, 0x66, 0x6f, 0x72, 0x0a, 0x66, 0x6f, 0x72, 0x65, 0x73, 0x68, 0x61, 0x64, 0x6f - , 0x77, 0x69, 0x6e, 0x67, 0x20, 0x74, 0x68, 0x65, 0x20, 0x64, 0x65, 0x63, 0x6c, 0x69, 0x6e, 0x65 - , 0x20, 0x6f, 0x66, 0x20, 0x74, 0x68, 0x65, 0x20, 0x47, 0x61, 0x6c, 0x61, 0x63, 0x74, 0x69, 0x63 - , 0x20, 0x45, 0x6d, 0x70, 0x69, 0x72, 0x65, 0x29, 0x2c, 0x20, 0x53, 0x65, 0x6c, 0x64, 0x6f, 0x6e - , 0x20, 0x65, 0x78, 0x70, 0x6c, 0x61, 0x69, 0x6e, 0x73, 0x20, 0x74, 0x68, 0x61, 0x74, 0x20, 0x68 - , 0x69, 0x73, 0x0a, 0x73, 0x63, 0x69, 0x65, 0x6e, 0x63, 0x65, 0x20, 0x6f, 0x66, 0x20, 0x70, 0x73 - , 0x79, 0x63, 0x68, 0x6f, 0x68, 0x69, 0x73, 0x74, 0x6f, 0x72, 0x79, 0x20, 0x66, 0x6f, 0x72, 0x65 - , 0x73, 0x65, 0x65, 0x73, 0x20, 0x6d, 0x61, 0x6e, 0x79, 0x20, 0x61, 0x6c, 0x74, 0x65, 0x72, 0x6e - , 0x61, 0x74, 0x69, 0x76, 0x65, 0x73, 0x2c, 0x20, 0x61, 0x6c, 0x6c, 0x20, 0x6f, 0x66, 0x20, 0x77 - , 0x68, 0x69, 0x63, 0x68, 0x20, 0x72, 0x65, 0x73, 0x75, 0x6c, 0x74, 0x20, 0x69, 0x6e, 0x20, 0x74 - , 0x68, 0x65, 0x0a, 0x47, 0x61, 0x6c, 0x61, 0x63, 0x74, 0x69, 0x63, 0x20, 0x45, 0x6d, 0x70, 0x69 - , 0x72, 0x65, 0x20, 0x65, 0x76, 0x65, 0x6e, 0x74, 0x75, 0x61, 0x6c, 0x6c, 0x79, 0x20, 0x66, 0x61 - , 0x6c, 0x6c, 0x69, 0x6e, 0x67, 0x2e, 0x20, 0x49, 0x66, 0x20, 0x68, 0x75, 0x6d, 0x61, 0x6e, 0x69 - , 0x74, 0x79, 0x20, 0x66, 0x6f, 0x6c, 0x6c, 0x6f, 0x77, 0x73, 0x20, 0x69, 0x74, 0x73, 0x20, 0x63 - , 0x75, 0x72, 0x72, 0x65, 0x6e, 0x74, 0x20, 0x70, 0x61, 0x74, 0x68, 0x2c, 0x20, 0x74, 0x68, 0x65 - , 0x0a, 0x45, 0x6d, 0x70, 0x69, 0x72, 0x65, 0x20, 0x77, 0x69, 0x6c, 0x6c, 0x20, 0x66, 0x61, 0x6c - , 0x6c, 0x20, 0x61, 0x6e, 0x64, 0x20, 0x33, 0x30, 0x2c, 0x30, 0x30, 0x30, 0x20, 0x79, 0x65, 0x61 - , 0x72, 0x73, 0x20, 0x6f, 0x66, 0x20, 0x74, 0x75, 0x72, 0x6d, 0x6f, 0x69, 0x6c, 0x20, 0x77, 0x69 - , 0x6c, 0x6c, 0x20, 0x6f, 0x76, 0x65, 0x72, 0x63, 0x6f, 0x6d, 0x65, 0x20, 0x68, 0x75, 0x6d, 0x61 - , 0x6e, 0x69, 0x74, 0x79, 0x20, 0x62, 0x65, 0x66, 0x6f, 0x72, 0x65, 0x20, 0x61, 0x0a, 0x73, 0x65 - , 0x63, 0x6f, 0x6e, 0x64, 0x20, 0x45, 0x6d, 0x70, 0x69, 0x72, 0x65, 0x20, 0x61, 0x72, 0x69, 0x73 - , 0x65, 0x73, 0x2e, 0x20, 0x48, 0x6f, 0x77, 0x65, 0x76, 0x65, 0x72, 0x2c, 0x20, 0x61, 0x6e, 0x20 - , 0x61, 0x6c, 0x74, 0x65, 0x72, 0x6e, 0x61, 0x74, 0x69, 0x76, 0x65, 0x20, 0x70, 0x61, 0x74, 0x68 - , 0x20, 0x61, 0x6c, 0x6c, 0x6f, 0x77, 0x73, 0x20, 0x66, 0x6f, 0x72, 0x20, 0x74, 0x68, 0x65, 0x20 - , 0x69, 0x6e, 0x74, 0x65, 0x72, 0x76, 0x65, 0x6e, 0x69, 0x6e, 0x67, 0x0a, 0x79, 0x65, 0x61, 0x72 - , 0x73, 0x20, 0x74, 0x6f, 0x20, 0x62, 0x65, 0x20, 0x6f, 0x6e, 0x6c, 0x79, 0x20, 0x6f, 0x6e, 0x65 - , 0x20, 0x74, 0x68, 0x6f, 0x75, 0x73, 0x61, 0x6e, 0x64, 0x2c, 0x20, 0x69, 0x66, 0x20, 0x53, 0x65 - , 0x6c, 0x64, 0x6f, 0x6e, 0x20, 0x69, 0x73, 0x20, 0x61, 0x6c, 0x6c, 0x6f, 0x77, 0x65, 0x64, 0x20 - , 0x74, 0x6f, 0x20, 0x63, 0x6f, 0x6c, 0x6c, 0x65, 0x63, 0x74, 0x20, 0x74, 0x68, 0x65, 0x20, 0x6d - , 0x6f, 0x73, 0x74, 0x0a, 0x69, 0x6e, 0x74, 0x65, 0x6c, 0x6c, 0x69, 0x67, 0x65, 0x6e, 0x74, 0x20 - , 0x6d, 0x69, 0x6e, 0x64, 0x73, 0x20, 0x61, 0x6e, 0x64, 0x20, 0x63, 0x72, 0x65, 0x61, 0x74, 0x65 - , 0x20, 0x61, 0x20, 0x63, 0x6f, 0x6d, 0x70, 0x65, 0x6e, 0x64, 0x69, 0x75, 0x6d, 0x20, 0x6f, 0x66 - , 0x20, 0x61, 0x6c, 0x6c, 0x20, 0x68, 0x75, 0x6d, 0x61, 0x6e, 0x20, 0x6b, 0x6e, 0x6f, 0x77, 0x6c - , 0x65, 0x64, 0x67, 0x65, 0x2c, 0x20, 0x65, 0x6e, 0x74, 0x69, 0x74, 0x6c, 0x65, 0x64, 0x0a, 0x45 - , 0x6e, 0x63, 0x79, 0x63, 0x6c, 0x6f, 0x70, 0x65, 0x64, 0x69, 0x61, 0x20, 0x47, 0x61, 0x6c, 0x61 - , 0x63, 0x74, 0x69, 0x63, 0x61, 0x2e, 0x20, 0x54, 0x68, 0x65, 0x20, 0x62, 0x6f, 0x61, 0x72, 0x64 - , 0x20, 0x69, 0x73, 0x20, 0x73, 0x74, 0x69, 0x6c, 0x6c, 0x20, 0x77, 0x61, 0x72, 0x79, 0x20, 0x62 - , 0x75, 0x74, 0x20, 0x61, 0x6c, 0x6c, 0x6f, 0x77, 0x73, 0x20, 0x53, 0x65, 0x6c, 0x64, 0x6f, 0x6e - , 0x20, 0x74, 0x6f, 0x20, 0x61, 0x73, 0x73, 0x65, 0x6d, 0x62, 0x6c, 0x65, 0x0a, 0x77, 0x68, 0x6f - , 0x6d, 0x65, 0x76, 0x65, 0x72, 0x20, 0x68, 0x65, 0x20, 0x6e, 0x65, 0x65, 0x64, 0x73, 0x2c, 0x20 - , 0x70, 0x72, 0x6f, 0x76, 0x69, 0x64, 0x65, 0x64, 0x20, 0x68, 0x65, 0x20, 0x61, 0x6e, 0x64, 0x20 - , 0x74, 0x68, 0x65, 0x20, 0x22, 0x45, 0x6e, 0x63, 0x79, 0x63, 0x6c, 0x6f, 0x70, 0x65, 0x64, 0x69 - , 0x73, 0x74, 0x73, 0x22, 0x20, 0x62, 0x65, 0x20, 0x65, 0x78, 0x69, 0x6c, 0x65, 0x64, 0x20, 0x74 - , 0x6f, 0x20, 0x61, 0x20, 0x72, 0x65, 0x6d, 0x6f, 0x74, 0x65, 0x0a, 0x70, 0x6c, 0x61, 0x6e, 0x65 - , 0x74, 0x2c, 0x20, 0x54, 0x65, 0x72, 0x6d, 0x69, 0x6e, 0x75, 0x73, 0x2e, 0x20, 0x53, 0x65, 0x6c - , 0x64, 0x6f, 0x6e, 0x20, 0x61, 0x67, 0x72, 0x65, 0x65, 0x73, 0x20, 0x74, 0x6f, 0x20, 0x73, 0x65 - , 0x74, 0x20, 0x75, 0x70, 0x20, 0x68, 0x69, 0x73, 0x20, 0x6f, 0x77, 0x6e, 0x20, 0x63, 0x6f, 0x6c - , 0x6c, 0x65, 0x63, 0x74, 0x69, 0x6f, 0x6e, 0x20, 0x6f, 0x66, 0x20, 0x45, 0x6e, 0x63, 0x79, 0x63 - , 0x6c, 0x6f, 0x70, 0x65, 0x64, 0x69, 0x73, 0x74, 0x73, 0x2c, 0x0a, 0x61, 0x6e, 0x64, 0x20, 0x61 - , 0x6c, 0x73, 0x6f, 0x20, 0x73, 0x65, 0x63, 0x72, 0x65, 0x74, 0x6c, 0x79, 0x20, 0x69, 0x6d, 0x70 - , 0x6c, 0x65, 0x6d, 0x65, 0x6e, 0x74, 0x73, 0x20, 0x61, 0x20, 0x63, 0x6f, 0x6e, 0x74, 0x69, 0x6e - , 0x67, 0x65, 0x6e, 0x63, 0x79, 0x20, 0x70, 0x6c, 0x61, 0x6e, 0x2d, 0x61, 0x20, 0x73, 0x65, 0x63 - , 0x6f, 0x6e, 0x64, 0x20, 0x46, 0x6f, 0x75, 0x6e, 0x64, 0x61, 0x74, 0x69, 0x6f, 0x6e, 0x2d, 0x61 - , 0x74, 0x20, 0x74, 0x68, 0x65, 0x0a, 0x22, 0x6f, 0x70, 0x70, 0x6f, 0x73, 0x69, 0x74, 0x65, 0x20 - , 0x65, 0x6e, 0x64, 0x22, 0x20, 0x6f, 0x66, 0x20, 0x74, 0x68, 0x65, 0x20, 0x67, 0x61, 0x6c, 0x61 - , 0x78, 0x79, 0x2e, 0x0a - ] - -sample0_UTF16 :: EncodedString -sample0_UTF16 = EncodedString UTF16 $ recast array - where - array :: UArray Word16 - array = fromList - [ 0x0043, 0x0061, 0x006c, 0x006c, 0x0065, 0x0064, 0x0020, 0x0066 - , 0x006f, 0x0072, 0x0074, 0x0068, 0x0020, 0x0074, 0x006f, 0x0020 - , 0x0073, 0x0074, 0x0061, 0x006e, 0x0064, 0x0020, 0x0074, 0x0072 - , 0x0069, 0x0061, 0x006c, 0x0020, 0x006f, 0x006e, 0x0020, 0x0054 - , 0x0072, 0x0061, 0x006e, 0x0074, 0x006f, 0x0072, 0x0020, 0x0066 - , 0x006f, 0x0072, 0x0020, 0x0061, 0x006c, 0x006c, 0x0065, 0x0067 - , 0x0061, 0x0074, 0x0069, 0x006f, 0x006e, 0x0073, 0x0020, 0x006f - , 0x0066, 0x0020, 0x0074, 0x0072, 0x0065, 0x0061, 0x0073, 0x006f - , 0x006e, 0x0020, 0x0028, 0x0066, 0x006f, 0x0072, 0x000a, 0x0066 - , 0x006f, 0x0072, 0x0065, 0x0073, 0x0068, 0x0061, 0x0064, 0x006f - , 0x0077, 0x0069, 0x006e, 0x0067, 0x0020, 0x0074, 0x0068, 0x0065 - , 0x0020, 0x0064, 0x0065, 0x0063, 0x006c, 0x0069, 0x006e, 0x0065 - , 0x0020, 0x006f, 0x0066, 0x0020, 0x0074, 0x0068, 0x0065, 0x0020 - , 0x0047, 0x0061, 0x006c, 0x0061, 0x0063, 0x0074, 0x0069, 0x0063 - , 0x0020, 0x0045, 0x006d, 0x0070, 0x0069, 0x0072, 0x0065, 0x0029 - , 0x002c, 0x0020, 0x0053, 0x0065, 0x006c, 0x0064, 0x006f, 0x006e - , 0x0020, 0x0065, 0x0078, 0x0070, 0x006c, 0x0061, 0x0069, 0x006e - , 0x0073, 0x0020, 0x0074, 0x0068, 0x0061, 0x0074, 0x0020, 0x0068 - , 0x0069, 0x0073, 0x000a, 0x0073, 0x0063, 0x0069, 0x0065, 0x006e - , 0x0063, 0x0065, 0x0020, 0x006f, 0x0066, 0x0020, 0x0070, 0x0073 - , 0x0079, 0x0063, 0x0068, 0x006f, 0x0068, 0x0069, 0x0073, 0x0074 - , 0x006f, 0x0072, 0x0079, 0x0020, 0x0066, 0x006f, 0x0072, 0x0065 - , 0x0073, 0x0065, 0x0065, 0x0073, 0x0020, 0x006d, 0x0061, 0x006e - , 0x0079, 0x0020, 0x0061, 0x006c, 0x0074, 0x0065, 0x0072, 0x006e - , 0x0061, 0x0074, 0x0069, 0x0076, 0x0065, 0x0073, 0x002c, 0x0020 - , 0x0061, 0x006c, 0x006c, 0x0020, 0x006f, 0x0066, 0x0020, 0x0077 - , 0x0068, 0x0069, 0x0063, 0x0068, 0x0020, 0x0072, 0x0065, 0x0073 - , 0x0075, 0x006c, 0x0074, 0x0020, 0x0069, 0x006e, 0x0020, 0x0074 - , 0x0068, 0x0065, 0x000a, 0x0047, 0x0061, 0x006c, 0x0061, 0x0063 - , 0x0074, 0x0069, 0x0063, 0x0020, 0x0045, 0x006d, 0x0070, 0x0069 - , 0x0072, 0x0065, 0x0020, 0x0065, 0x0076, 0x0065, 0x006e, 0x0074 - , 0x0075, 0x0061, 0x006c, 0x006c, 0x0079, 0x0020, 0x0066, 0x0061 - , 0x006c, 0x006c, 0x0069, 0x006e, 0x0067, 0x002e, 0x0020, 0x0049 - , 0x0066, 0x0020, 0x0068, 0x0075, 0x006d, 0x0061, 0x006e, 0x0069 - , 0x0074, 0x0079, 0x0020, 0x0066, 0x006f, 0x006c, 0x006c, 0x006f - , 0x0077, 0x0073, 0x0020, 0x0069, 0x0074, 0x0073, 0x0020, 0x0063 - , 0x0075, 0x0072, 0x0072, 0x0065, 0x006e, 0x0074, 0x0020, 0x0070 - , 0x0061, 0x0074, 0x0068, 0x002c, 0x0020, 0x0074, 0x0068, 0x0065 - , 0x000a, 0x0045, 0x006d, 0x0070, 0x0069, 0x0072, 0x0065, 0x0020 - , 0x0077, 0x0069, 0x006c, 0x006c, 0x0020, 0x0066, 0x0061, 0x006c - , 0x006c, 0x0020, 0x0061, 0x006e, 0x0064, 0x0020, 0x0033, 0x0030 - , 0x002c, 0x0030, 0x0030, 0x0030, 0x0020, 0x0079, 0x0065, 0x0061 - , 0x0072, 0x0073, 0x0020, 0x006f, 0x0066, 0x0020, 0x0074, 0x0075 - , 0x0072, 0x006d, 0x006f, 0x0069, 0x006c, 0x0020, 0x0077, 0x0069 - , 0x006c, 0x006c, 0x0020, 0x006f, 0x0076, 0x0065, 0x0072, 0x0063 - , 0x006f, 0x006d, 0x0065, 0x0020, 0x0068, 0x0075, 0x006d, 0x0061 - , 0x006e, 0x0069, 0x0074, 0x0079, 0x0020, 0x0062, 0x0065, 0x0066 - , 0x006f, 0x0072, 0x0065, 0x0020, 0x0061, 0x000a, 0x0073, 0x0065 - , 0x0063, 0x006f, 0x006e, 0x0064, 0x0020, 0x0045, 0x006d, 0x0070 - , 0x0069, 0x0072, 0x0065, 0x0020, 0x0061, 0x0072, 0x0069, 0x0073 - , 0x0065, 0x0073, 0x002e, 0x0020, 0x0048, 0x006f, 0x0077, 0x0065 - , 0x0076, 0x0065, 0x0072, 0x002c, 0x0020, 0x0061, 0x006e, 0x0020 - , 0x0061, 0x006c, 0x0074, 0x0065, 0x0072, 0x006e, 0x0061, 0x0074 - , 0x0069, 0x0076, 0x0065, 0x0020, 0x0070, 0x0061, 0x0074, 0x0068 - , 0x0020, 0x0061, 0x006c, 0x006c, 0x006f, 0x0077, 0x0073, 0x0020 - , 0x0066, 0x006f, 0x0072, 0x0020, 0x0074, 0x0068, 0x0065, 0x0020 - , 0x0069, 0x006e, 0x0074, 0x0065, 0x0072, 0x0076, 0x0065, 0x006e - , 0x0069, 0x006e, 0x0067, 0x000a, 0x0079, 0x0065, 0x0061, 0x0072 - , 0x0073, 0x0020, 0x0074, 0x006f, 0x0020, 0x0062, 0x0065, 0x0020 - , 0x006f, 0x006e, 0x006c, 0x0079, 0x0020, 0x006f, 0x006e, 0x0065 - , 0x0020, 0x0074, 0x0068, 0x006f, 0x0075, 0x0073, 0x0061, 0x006e - , 0x0064, 0x002c, 0x0020, 0x0069, 0x0066, 0x0020, 0x0053, 0x0065 - , 0x006c, 0x0064, 0x006f, 0x006e, 0x0020, 0x0069, 0x0073, 0x0020 - , 0x0061, 0x006c, 0x006c, 0x006f, 0x0077, 0x0065, 0x0064, 0x0020 - , 0x0074, 0x006f, 0x0020, 0x0063, 0x006f, 0x006c, 0x006c, 0x0065 - , 0x0063, 0x0074, 0x0020, 0x0074, 0x0068, 0x0065, 0x0020, 0x006d - , 0x006f, 0x0073, 0x0074, 0x000a, 0x0069, 0x006e, 0x0074, 0x0065 - , 0x006c, 0x006c, 0x0069, 0x0067, 0x0065, 0x006e, 0x0074, 0x0020 - , 0x006d, 0x0069, 0x006e, 0x0064, 0x0073, 0x0020, 0x0061, 0x006e - , 0x0064, 0x0020, 0x0063, 0x0072, 0x0065, 0x0061, 0x0074, 0x0065 - , 0x0020, 0x0061, 0x0020, 0x0063, 0x006f, 0x006d, 0x0070, 0x0065 - , 0x006e, 0x0064, 0x0069, 0x0075, 0x006d, 0x0020, 0x006f, 0x0066 - , 0x0020, 0x0061, 0x006c, 0x006c, 0x0020, 0x0068, 0x0075, 0x006d - , 0x0061, 0x006e, 0x0020, 0x006b, 0x006e, 0x006f, 0x0077, 0x006c - , 0x0065, 0x0064, 0x0067, 0x0065, 0x002c, 0x0020, 0x0065, 0x006e - , 0x0074, 0x0069, 0x0074, 0x006c, 0x0065, 0x0064, 0x000a, 0x0045 - , 0x006e, 0x0063, 0x0079, 0x0063, 0x006c, 0x006f, 0x0070, 0x0065 - , 0x0064, 0x0069, 0x0061, 0x0020, 0x0047, 0x0061, 0x006c, 0x0061 - , 0x0063, 0x0074, 0x0069, 0x0063, 0x0061, 0x002e, 0x0020, 0x0054 - , 0x0068, 0x0065, 0x0020, 0x0062, 0x006f, 0x0061, 0x0072, 0x0064 - , 0x0020, 0x0069, 0x0073, 0x0020, 0x0073, 0x0074, 0x0069, 0x006c - , 0x006c, 0x0020, 0x0077, 0x0061, 0x0072, 0x0079, 0x0020, 0x0062 - , 0x0075, 0x0074, 0x0020, 0x0061, 0x006c, 0x006c, 0x006f, 0x0077 - , 0x0073, 0x0020, 0x0053, 0x0065, 0x006c, 0x0064, 0x006f, 0x006e - , 0x0020, 0x0074, 0x006f, 0x0020, 0x0061, 0x0073, 0x0073, 0x0065 - , 0x006d, 0x0062, 0x006c, 0x0065, 0x000a, 0x0077, 0x0068, 0x006f - , 0x006d, 0x0065, 0x0076, 0x0065, 0x0072, 0x0020, 0x0068, 0x0065 - , 0x0020, 0x006e, 0x0065, 0x0065, 0x0064, 0x0073, 0x002c, 0x0020 - , 0x0070, 0x0072, 0x006f, 0x0076, 0x0069, 0x0064, 0x0065, 0x0064 - , 0x0020, 0x0068, 0x0065, 0x0020, 0x0061, 0x006e, 0x0064, 0x0020 - , 0x0074, 0x0068, 0x0065, 0x0020, 0x0022, 0x0045, 0x006e, 0x0063 - , 0x0079, 0x0063, 0x006c, 0x006f, 0x0070, 0x0065, 0x0064, 0x0069 - , 0x0073, 0x0074, 0x0073, 0x0022, 0x0020, 0x0062, 0x0065, 0x0020 - , 0x0065, 0x0078, 0x0069, 0x006c, 0x0065, 0x0064, 0x0020, 0x0074 - , 0x006f, 0x0020, 0x0061, 0x0020, 0x0072, 0x0065, 0x006d, 0x006f - , 0x0074, 0x0065, 0x000a, 0x0070, 0x006c, 0x0061, 0x006e, 0x0065 - , 0x0074, 0x002c, 0x0020, 0x0054, 0x0065, 0x0072, 0x006d, 0x0069 - , 0x006e, 0x0075, 0x0073, 0x002e, 0x0020, 0x0053, 0x0065, 0x006c - , 0x0064, 0x006f, 0x006e, 0x0020, 0x0061, 0x0067, 0x0072, 0x0065 - , 0x0065, 0x0073, 0x0020, 0x0074, 0x006f, 0x0020, 0x0073, 0x0065 - , 0x0074, 0x0020, 0x0075, 0x0070, 0x0020, 0x0068, 0x0069, 0x0073 - , 0x0020, 0x006f, 0x0077, 0x006e, 0x0020, 0x0063, 0x006f, 0x006c - , 0x006c, 0x0065, 0x0063, 0x0074, 0x0069, 0x006f, 0x006e, 0x0020 - , 0x006f, 0x0066, 0x0020, 0x0045, 0x006e, 0x0063, 0x0079, 0x0063 - , 0x006c, 0x006f, 0x0070, 0x0065, 0x0064, 0x0069, 0x0073, 0x0074 - , 0x0073, 0x002c, 0x000a, 0x0061, 0x006e, 0x0064, 0x0020, 0x0061 - , 0x006c, 0x0073, 0x006f, 0x0020, 0x0073, 0x0065, 0x0063, 0x0072 - , 0x0065, 0x0074, 0x006c, 0x0079, 0x0020, 0x0069, 0x006d, 0x0070 - , 0x006c, 0x0065, 0x006d, 0x0065, 0x006e, 0x0074, 0x0073, 0x0020 - , 0x0061, 0x0020, 0x0063, 0x006f, 0x006e, 0x0074, 0x0069, 0x006e - , 0x0067, 0x0065, 0x006e, 0x0063, 0x0079, 0x0020, 0x0070, 0x006c - , 0x0061, 0x006e, 0x002d, 0x0061, 0x0020, 0x0073, 0x0065, 0x0063 - , 0x006f, 0x006e, 0x0064, 0x0020, 0x0046, 0x006f, 0x0075, 0x006e - , 0x0064, 0x0061, 0x0074, 0x0069, 0x006f, 0x006e, 0x002d, 0x0061 - , 0x0074, 0x0020, 0x0074, 0x0068, 0x0065, 0x000a, 0x0022, 0x006f - , 0x0070, 0x0070, 0x006f, 0x0073, 0x0069, 0x0074, 0x0065, 0x0020 - , 0x0065, 0x006e, 0x0064, 0x0022, 0x0020, 0x006f, 0x0066, 0x0020 - , 0x0074, 0x0068, 0x0065, 0x0020, 0x0067, 0x0061, 0x006c, 0x0061 - , 0x0078, 0x0079, 0x002e, 0x000a - ] - -sample0_ISO_8859_1 :: EncodedString -sample0_ISO_8859_1 = EncodedString ISO_8859_1 $ fromList - [ 0x43, 0x61, 0x6c, 0x6c, 0x65, 0x64, 0x20, 0x66, 0x6f, 0x72, 0x74, 0x68, 0x20, 0x74, 0x6f, 0x20 - , 0x73, 0x74, 0x61, 0x6e, 0x64, 0x20, 0x74, 0x72, 0x69, 0x61, 0x6c, 0x20, 0x6f, 0x6e, 0x20, 0x54 - , 0x72, 0x61, 0x6e, 0x74, 0x6f, 0x72, 0x20, 0x66, 0x6f, 0x72, 0x20, 0x61, 0x6c, 0x6c, 0x65, 0x67 - , 0x61, 0x74, 0x69, 0x6f, 0x6e, 0x73, 0x20, 0x6f, 0x66, 0x20, 0x74, 0x72, 0x65, 0x61, 0x73, 0x6f - , 0x6e, 0x20, 0x28, 0x66, 0x6f, 0x72, 0x0a, 0x66, 0x6f, 0x72, 0x65, 0x73, 0x68, 0x61, 0x64, 0x6f - , 0x77, 0x69, 0x6e, 0x67, 0x20, 0x74, 0x68, 0x65, 0x20, 0x64, 0x65, 0x63, 0x6c, 0x69, 0x6e, 0x65 - , 0x20, 0x6f, 0x66, 0x20, 0x74, 0x68, 0x65, 0x20, 0x47, 0x61, 0x6c, 0x61, 0x63, 0x74, 0x69, 0x63 - , 0x20, 0x45, 0x6d, 0x70, 0x69, 0x72, 0x65, 0x29, 0x2c, 0x20, 0x53, 0x65, 0x6c, 0x64, 0x6f, 0x6e - , 0x20, 0x65, 0x78, 0x70, 0x6c, 0x61, 0x69, 0x6e, 0x73, 0x20, 0x74, 0x68, 0x61, 0x74, 0x20, 0x68 - , 0x69, 0x73, 0x0a, 0x73, 0x63, 0x69, 0x65, 0x6e, 0x63, 0x65, 0x20, 0x6f, 0x66, 0x20, 0x70, 0x73 - , 0x79, 0x63, 0x68, 0x6f, 0x68, 0x69, 0x73, 0x74, 0x6f, 0x72, 0x79, 0x20, 0x66, 0x6f, 0x72, 0x65 - , 0x73, 0x65, 0x65, 0x73, 0x20, 0x6d, 0x61, 0x6e, 0x79, 0x20, 0x61, 0x6c, 0x74, 0x65, 0x72, 0x6e - , 0x61, 0x74, 0x69, 0x76, 0x65, 0x73, 0x2c, 0x20, 0x61, 0x6c, 0x6c, 0x20, 0x6f, 0x66, 0x20, 0x77 - , 0x68, 0x69, 0x63, 0x68, 0x20, 0x72, 0x65, 0x73, 0x75, 0x6c, 0x74, 0x20, 0x69, 0x6e, 0x20, 0x74 - , 0x68, 0x65, 0x0a, 0x47, 0x61, 0x6c, 0x61, 0x63, 0x74, 0x69, 0x63, 0x20, 0x45, 0x6d, 0x70, 0x69 - , 0x72, 0x65, 0x20, 0x65, 0x76, 0x65, 0x6e, 0x74, 0x75, 0x61, 0x6c, 0x6c, 0x79, 0x20, 0x66, 0x61 - , 0x6c, 0x6c, 0x69, 0x6e, 0x67, 0x2e, 0x20, 0x49, 0x66, 0x20, 0x68, 0x75, 0x6d, 0x61, 0x6e, 0x69 - , 0x74, 0x79, 0x20, 0x66, 0x6f, 0x6c, 0x6c, 0x6f, 0x77, 0x73, 0x20, 0x69, 0x74, 0x73, 0x20, 0x63 - , 0x75, 0x72, 0x72, 0x65, 0x6e, 0x74, 0x20, 0x70, 0x61, 0x74, 0x68, 0x2c, 0x20, 0x74, 0x68, 0x65 - , 0x0a, 0x45, 0x6d, 0x70, 0x69, 0x72, 0x65, 0x20, 0x77, 0x69, 0x6c, 0x6c, 0x20, 0x66, 0x61, 0x6c - , 0x6c, 0x20, 0x61, 0x6e, 0x64, 0x20, 0x33, 0x30, 0x2c, 0x30, 0x30, 0x30, 0x20, 0x79, 0x65, 0x61 - , 0x72, 0x73, 0x20, 0x6f, 0x66, 0x20, 0x74, 0x75, 0x72, 0x6d, 0x6f, 0x69, 0x6c, 0x20, 0x77, 0x69 - , 0x6c, 0x6c, 0x20, 0x6f, 0x76, 0x65, 0x72, 0x63, 0x6f, 0x6d, 0x65, 0x20, 0x68, 0x75, 0x6d, 0x61 - , 0x6e, 0x69, 0x74, 0x79, 0x20, 0x62, 0x65, 0x66, 0x6f, 0x72, 0x65, 0x20, 0x61, 0x0a, 0x73, 0x65 - , 0x63, 0x6f, 0x6e, 0x64, 0x20, 0x45, 0x6d, 0x70, 0x69, 0x72, 0x65, 0x20, 0x61, 0x72, 0x69, 0x73 - , 0x65, 0x73, 0x2e, 0x20, 0x48, 0x6f, 0x77, 0x65, 0x76, 0x65, 0x72, 0x2c, 0x20, 0x61, 0x6e, 0x20 - , 0x61, 0x6c, 0x74, 0x65, 0x72, 0x6e, 0x61, 0x74, 0x69, 0x76, 0x65, 0x20, 0x70, 0x61, 0x74, 0x68 - , 0x20, 0x61, 0x6c, 0x6c, 0x6f, 0x77, 0x73, 0x20, 0x66, 0x6f, 0x72, 0x20, 0x74, 0x68, 0x65, 0x20 - , 0x69, 0x6e, 0x74, 0x65, 0x72, 0x76, 0x65, 0x6e, 0x69, 0x6e, 0x67, 0x0a, 0x79, 0x65, 0x61, 0x72 - , 0x73, 0x20, 0x74, 0x6f, 0x20, 0x62, 0x65, 0x20, 0x6f, 0x6e, 0x6c, 0x79, 0x20, 0x6f, 0x6e, 0x65 - , 0x20, 0x74, 0x68, 0x6f, 0x75, 0x73, 0x61, 0x6e, 0x64, 0x2c, 0x20, 0x69, 0x66, 0x20, 0x53, 0x65 - , 0x6c, 0x64, 0x6f, 0x6e, 0x20, 0x69, 0x73, 0x20, 0x61, 0x6c, 0x6c, 0x6f, 0x77, 0x65, 0x64, 0x20 - , 0x74, 0x6f, 0x20, 0x63, 0x6f, 0x6c, 0x6c, 0x65, 0x63, 0x74, 0x20, 0x74, 0x68, 0x65, 0x20, 0x6d - , 0x6f, 0x73, 0x74, 0x0a, 0x69, 0x6e, 0x74, 0x65, 0x6c, 0x6c, 0x69, 0x67, 0x65, 0x6e, 0x74, 0x20 - , 0x6d, 0x69, 0x6e, 0x64, 0x73, 0x20, 0x61, 0x6e, 0x64, 0x20, 0x63, 0x72, 0x65, 0x61, 0x74, 0x65 - , 0x20, 0x61, 0x20, 0x63, 0x6f, 0x6d, 0x70, 0x65, 0x6e, 0x64, 0x69, 0x75, 0x6d, 0x20, 0x6f, 0x66 - , 0x20, 0x61, 0x6c, 0x6c, 0x20, 0x68, 0x75, 0x6d, 0x61, 0x6e, 0x20, 0x6b, 0x6e, 0x6f, 0x77, 0x6c - , 0x65, 0x64, 0x67, 0x65, 0x2c, 0x20, 0x65, 0x6e, 0x74, 0x69, 0x74, 0x6c, 0x65, 0x64, 0x0a, 0x45 - , 0x6e, 0x63, 0x79, 0x63, 0x6c, 0x6f, 0x70, 0x65, 0x64, 0x69, 0x61, 0x20, 0x47, 0x61, 0x6c, 0x61 - , 0x63, 0x74, 0x69, 0x63, 0x61, 0x2e, 0x20, 0x54, 0x68, 0x65, 0x20, 0x62, 0x6f, 0x61, 0x72, 0x64 - , 0x20, 0x69, 0x73, 0x20, 0x73, 0x74, 0x69, 0x6c, 0x6c, 0x20, 0x77, 0x61, 0x72, 0x79, 0x20, 0x62 - , 0x75, 0x74, 0x20, 0x61, 0x6c, 0x6c, 0x6f, 0x77, 0x73, 0x20, 0x53, 0x65, 0x6c, 0x64, 0x6f, 0x6e - , 0x20, 0x74, 0x6f, 0x20, 0x61, 0x73, 0x73, 0x65, 0x6d, 0x62, 0x6c, 0x65, 0x0a, 0x77, 0x68, 0x6f - , 0x6d, 0x65, 0x76, 0x65, 0x72, 0x20, 0x68, 0x65, 0x20, 0x6e, 0x65, 0x65, 0x64, 0x73, 0x2c, 0x20 - , 0x70, 0x72, 0x6f, 0x76, 0x69, 0x64, 0x65, 0x64, 0x20, 0x68, 0x65, 0x20, 0x61, 0x6e, 0x64, 0x20 - , 0x74, 0x68, 0x65, 0x20, 0x22, 0x45, 0x6e, 0x63, 0x79, 0x63, 0x6c, 0x6f, 0x70, 0x65, 0x64, 0x69 - , 0x73, 0x74, 0x73, 0x22, 0x20, 0x62, 0x65, 0x20, 0x65, 0x78, 0x69, 0x6c, 0x65, 0x64, 0x20, 0x74 - , 0x6f, 0x20, 0x61, 0x20, 0x72, 0x65, 0x6d, 0x6f, 0x74, 0x65, 0x0a, 0x70, 0x6c, 0x61, 0x6e, 0x65 - , 0x74, 0x2c, 0x20, 0x54, 0x65, 0x72, 0x6d, 0x69, 0x6e, 0x75, 0x73, 0x2e, 0x20, 0x53, 0x65, 0x6c - , 0x64, 0x6f, 0x6e, 0x20, 0x61, 0x67, 0x72, 0x65, 0x65, 0x73, 0x20, 0x74, 0x6f, 0x20, 0x73, 0x65 - , 0x74, 0x20, 0x75, 0x70, 0x20, 0x68, 0x69, 0x73, 0x20, 0x6f, 0x77, 0x6e, 0x20, 0x63, 0x6f, 0x6c - , 0x6c, 0x65, 0x63, 0x74, 0x69, 0x6f, 0x6e, 0x20, 0x6f, 0x66, 0x20, 0x45, 0x6e, 0x63, 0x79, 0x63 - , 0x6c, 0x6f, 0x70, 0x65, 0x64, 0x69, 0x73, 0x74, 0x73, 0x2c, 0x0a, 0x61, 0x6e, 0x64, 0x20, 0x61 - , 0x6c, 0x73, 0x6f, 0x20, 0x73, 0x65, 0x63, 0x72, 0x65, 0x74, 0x6c, 0x79, 0x20, 0x69, 0x6d, 0x70 - , 0x6c, 0x65, 0x6d, 0x65, 0x6e, 0x74, 0x73, 0x20, 0x61, 0x20, 0x63, 0x6f, 0x6e, 0x74, 0x69, 0x6e - , 0x67, 0x65, 0x6e, 0x63, 0x79, 0x20, 0x70, 0x6c, 0x61, 0x6e, 0x2d, 0x61, 0x20, 0x73, 0x65, 0x63 - , 0x6f, 0x6e, 0x64, 0x20, 0x46, 0x6f, 0x75, 0x6e, 0x64, 0x61, 0x74, 0x69, 0x6f, 0x6e, 0x2d, 0x61 - , 0x74, 0x20, 0x74, 0x68, 0x65, 0x0a, 0x22, 0x6f, 0x70, 0x70, 0x6f, 0x73, 0x69, 0x74, 0x65, 0x20 - , 0x65, 0x6e, 0x64, 0x22, 0x20, 0x6f, 0x66, 0x20, 0x74, 0x68, 0x65, 0x20, 0x67, 0x61, 0x6c, 0x61 - , 0x78, 0x79, 0x2e, 0x0a - ] - --- -------------------------- Sample 1 ------------------------------------- -- - -sample1 :: ([EncodedString], String) -sample1 = ( [sample1_UTF8, sample1_UTF16, sample1_ISO_8859_1] - , sample1_String - ) - -sample1_String :: String -sample1_String = - "In French:\n\ - \\n\ - \1. un robot ne peut porter atteinte à un être humain, ni, en restant passif, permettre qu'un être humain soit exposé au danger ;\n\ - \2. un robot doit obéir aux ordres qui lui sont donnés par un être humain, sauf si de tels ordres entrent en conflit avec la première loi ;\n\ - \3. un robot doit protéger son existence tant que cette protection n'entre pas en conflit avec la première ou la deuxième loi.\n\ - \\n\ - \In Danish:\n\ - \\n\ - \1. En robot må ikke gøre et menneske fortræd, eller, ved ikke at gøre noget, lade et menneske komme til skade\n\ - \2. En robot skal adlyde ordrer givet af mennesker, så længe disse ikke er i konflikt med første lov\n\ - \3. En robot skal beskytte sin egen eksistens, så længe dette ikke er i konflikt med første eller anden lov\n" - -sample1_UTF8 :: EncodedString -sample1_UTF8 = EncodedString UTF8 $ fromList - [ 0x49, 0x6e, 0x20, 0x46, 0x72, 0x65, 0x6e, 0x63, 0x68, 0x3a, 0x0a, 0x0a, 0x31, 0x2e, 0x20, 0x75 - , 0x6e, 0x20, 0x72, 0x6f, 0x62, 0x6f, 0x74, 0x20, 0x6e, 0x65, 0x20, 0x70, 0x65, 0x75, 0x74, 0x20 - , 0x70, 0x6f, 0x72, 0x74, 0x65, 0x72, 0x20, 0x61, 0x74, 0x74, 0x65, 0x69, 0x6e, 0x74, 0x65, 0x20 - , 0xc3, 0xa0, 0x20, 0x75, 0x6e, 0x20, 0xc3, 0xaa, 0x74, 0x72, 0x65, 0x20, 0x68, 0x75, 0x6d, 0x61 - , 0x69, 0x6e, 0x2c, 0x20, 0x6e, 0x69, 0x2c, 0x20, 0x65, 0x6e, 0x20, 0x72, 0x65, 0x73, 0x74, 0x61 - , 0x6e, 0x74, 0x20, 0x70, 0x61, 0x73, 0x73, 0x69, 0x66, 0x2c, 0x20, 0x70, 0x65, 0x72, 0x6d, 0x65 - , 0x74, 0x74, 0x72, 0x65, 0x20, 0x71, 0x75, 0x27, 0x75, 0x6e, 0x20, 0xc3, 0xaa, 0x74, 0x72, 0x65 - , 0x20, 0x68, 0x75, 0x6d, 0x61, 0x69, 0x6e, 0x20, 0x73, 0x6f, 0x69, 0x74, 0x20, 0x65, 0x78, 0x70 - , 0x6f, 0x73, 0xc3, 0xa9, 0x20, 0x61, 0x75, 0x20, 0x64, 0x61, 0x6e, 0x67, 0x65, 0x72, 0x20, 0x3b - , 0x0a, 0x32, 0x2e, 0x20, 0x75, 0x6e, 0x20, 0x72, 0x6f, 0x62, 0x6f, 0x74, 0x20, 0x64, 0x6f, 0x69 - , 0x74, 0x20, 0x6f, 0x62, 0xc3, 0xa9, 0x69, 0x72, 0x20, 0x61, 0x75, 0x78, 0x20, 0x6f, 0x72, 0x64 - , 0x72, 0x65, 0x73, 0x20, 0x71, 0x75, 0x69, 0x20, 0x6c, 0x75, 0x69, 0x20, 0x73, 0x6f, 0x6e, 0x74 - , 0x20, 0x64, 0x6f, 0x6e, 0x6e, 0xc3, 0xa9, 0x73, 0x20, 0x70, 0x61, 0x72, 0x20, 0x75, 0x6e, 0x20 - , 0xc3, 0xaa, 0x74, 0x72, 0x65, 0x20, 0x68, 0x75, 0x6d, 0x61, 0x69, 0x6e, 0x2c, 0x20, 0x73, 0x61 - , 0x75, 0x66, 0x20, 0x73, 0x69, 0x20, 0x64, 0x65, 0x20, 0x74, 0x65, 0x6c, 0x73, 0x20, 0x6f, 0x72 - , 0x64, 0x72, 0x65, 0x73, 0x20, 0x65, 0x6e, 0x74, 0x72, 0x65, 0x6e, 0x74, 0x20, 0x65, 0x6e, 0x20 - , 0x63, 0x6f, 0x6e, 0x66, 0x6c, 0x69, 0x74, 0x20, 0x61, 0x76, 0x65, 0x63, 0x20, 0x6c, 0x61, 0x20 - , 0x70, 0x72, 0x65, 0x6d, 0x69, 0xc3, 0xa8, 0x72, 0x65, 0x20, 0x6c, 0x6f, 0x69, 0x20, 0x3b, 0x0a - , 0x33, 0x2e, 0x20, 0x75, 0x6e, 0x20, 0x72, 0x6f, 0x62, 0x6f, 0x74, 0x20, 0x64, 0x6f, 0x69, 0x74 - , 0x20, 0x70, 0x72, 0x6f, 0x74, 0xc3, 0xa9, 0x67, 0x65, 0x72, 0x20, 0x73, 0x6f, 0x6e, 0x20, 0x65 - , 0x78, 0x69, 0x73, 0x74, 0x65, 0x6e, 0x63, 0x65, 0x20, 0x74, 0x61, 0x6e, 0x74, 0x20, 0x71, 0x75 - , 0x65, 0x20, 0x63, 0x65, 0x74, 0x74, 0x65, 0x20, 0x70, 0x72, 0x6f, 0x74, 0x65, 0x63, 0x74, 0x69 - , 0x6f, 0x6e, 0x20, 0x6e, 0x27, 0x65, 0x6e, 0x74, 0x72, 0x65, 0x20, 0x70, 0x61, 0x73, 0x20, 0x65 - , 0x6e, 0x20, 0x63, 0x6f, 0x6e, 0x66, 0x6c, 0x69, 0x74, 0x20, 0x61, 0x76, 0x65, 0x63, 0x20, 0x6c - , 0x61, 0x20, 0x70, 0x72, 0x65, 0x6d, 0x69, 0xc3, 0xa8, 0x72, 0x65, 0x20, 0x6f, 0x75, 0x20, 0x6c - , 0x61, 0x20, 0x64, 0x65, 0x75, 0x78, 0x69, 0xc3, 0xa8, 0x6d, 0x65, 0x20, 0x6c, 0x6f, 0x69, 0x2e - , 0x0a, 0x0a, 0x49, 0x6e, 0x20, 0x44, 0x61, 0x6e, 0x69, 0x73, 0x68, 0x3a, 0x0a, 0x0a, 0x31, 0x2e - , 0x20, 0x45, 0x6e, 0x20, 0x72, 0x6f, 0x62, 0x6f, 0x74, 0x20, 0x6d, 0xc3, 0xa5, 0x20, 0x69, 0x6b - , 0x6b, 0x65, 0x20, 0x67, 0xc3, 0xb8, 0x72, 0x65, 0x20, 0x65, 0x74, 0x20, 0x6d, 0x65, 0x6e, 0x6e - , 0x65, 0x73, 0x6b, 0x65, 0x20, 0x66, 0x6f, 0x72, 0x74, 0x72, 0xc3, 0xa6, 0x64, 0x2c, 0x20, 0x65 - , 0x6c, 0x6c, 0x65, 0x72, 0x2c, 0x20, 0x76, 0x65, 0x64, 0x20, 0x69, 0x6b, 0x6b, 0x65, 0x20, 0x61 - , 0x74, 0x20, 0x67, 0xc3, 0xb8, 0x72, 0x65, 0x20, 0x6e, 0x6f, 0x67, 0x65, 0x74, 0x2c, 0x20, 0x6c - , 0x61, 0x64, 0x65, 0x20, 0x65, 0x74, 0x20, 0x6d, 0x65, 0x6e, 0x6e, 0x65, 0x73, 0x6b, 0x65, 0x20 - , 0x6b, 0x6f, 0x6d, 0x6d, 0x65, 0x20, 0x74, 0x69, 0x6c, 0x20, 0x73, 0x6b, 0x61, 0x64, 0x65, 0x0a - , 0x32, 0x2e, 0x20, 0x45, 0x6e, 0x20, 0x72, 0x6f, 0x62, 0x6f, 0x74, 0x20, 0x73, 0x6b, 0x61, 0x6c - , 0x20, 0x61, 0x64, 0x6c, 0x79, 0x64, 0x65, 0x20, 0x6f, 0x72, 0x64, 0x72, 0x65, 0x72, 0x20, 0x67 - , 0x69, 0x76, 0x65, 0x74, 0x20, 0x61, 0x66, 0x20, 0x6d, 0x65, 0x6e, 0x6e, 0x65, 0x73, 0x6b, 0x65 - , 0x72, 0x2c, 0x20, 0x73, 0xc3, 0xa5, 0x20, 0x6c, 0xc3, 0xa6, 0x6e, 0x67, 0x65, 0x20, 0x64, 0x69 - , 0x73, 0x73, 0x65, 0x20, 0x69, 0x6b, 0x6b, 0x65, 0x20, 0x65, 0x72, 0x20, 0x69, 0x20, 0x6b, 0x6f - , 0x6e, 0x66, 0x6c, 0x69, 0x6b, 0x74, 0x20, 0x6d, 0x65, 0x64, 0x20, 0x66, 0xc3, 0xb8, 0x72, 0x73 - , 0x74, 0x65, 0x20, 0x6c, 0x6f, 0x76, 0x0a, 0x33, 0x2e, 0x20, 0x45, 0x6e, 0x20, 0x72, 0x6f, 0x62 - , 0x6f, 0x74, 0x20, 0x73, 0x6b, 0x61, 0x6c, 0x20, 0x62, 0x65, 0x73, 0x6b, 0x79, 0x74, 0x74, 0x65 - , 0x20, 0x73, 0x69, 0x6e, 0x20, 0x65, 0x67, 0x65, 0x6e, 0x20, 0x65, 0x6b, 0x73, 0x69, 0x73, 0x74 - , 0x65, 0x6e, 0x73, 0x2c, 0x20, 0x73, 0xc3, 0xa5, 0x20, 0x6c, 0xc3, 0xa6, 0x6e, 0x67, 0x65, 0x20 - , 0x64, 0x65, 0x74, 0x74, 0x65, 0x20, 0x69, 0x6b, 0x6b, 0x65, 0x20, 0x65, 0x72, 0x20, 0x69, 0x20 - , 0x6b, 0x6f, 0x6e, 0x66, 0x6c, 0x69, 0x6b, 0x74, 0x20, 0x6d, 0x65, 0x64, 0x20, 0x66, 0xc3, 0xb8 - , 0x72, 0x73, 0x74, 0x65, 0x20, 0x65, 0x6c, 0x6c, 0x65, 0x72, 0x20, 0x61, 0x6e, 0x64, 0x65, 0x6e - , 0x20, 0x6c, 0x6f, 0x76, 0x0a - ] - -sample1_UTF16 :: EncodedString -sample1_UTF16 = EncodedString UTF16 $ recast array - where - array :: UArray Word16 - array = fromList - [ 0x0049, 0x006e, 0x0020, 0x0046, 0x0072, 0x0065, 0x006e, 0x0063 - , 0x0068, 0x003a, 0x000a, 0x000a, 0x0031, 0x002e, 0x0020, 0x0075 - , 0x006e, 0x0020, 0x0072, 0x006f, 0x0062, 0x006f, 0x0074, 0x0020 - , 0x006e, 0x0065, 0x0020, 0x0070, 0x0065, 0x0075, 0x0074, 0x0020 - , 0x0070, 0x006f, 0x0072, 0x0074, 0x0065, 0x0072, 0x0020, 0x0061 - , 0x0074, 0x0074, 0x0065, 0x0069, 0x006e, 0x0074, 0x0065, 0x0020 - , 0x00e0, 0x0020, 0x0075, 0x006e, 0x0020, 0x00ea, 0x0074, 0x0072 - , 0x0065, 0x0020, 0x0068, 0x0075, 0x006d, 0x0061, 0x0069, 0x006e - , 0x002c, 0x0020, 0x006e, 0x0069, 0x002c, 0x0020, 0x0065, 0x006e - , 0x0020, 0x0072, 0x0065, 0x0073, 0x0074, 0x0061, 0x006e, 0x0074 - , 0x0020, 0x0070, 0x0061, 0x0073, 0x0073, 0x0069, 0x0066, 0x002c - , 0x0020, 0x0070, 0x0065, 0x0072, 0x006d, 0x0065, 0x0074, 0x0074 - , 0x0072, 0x0065, 0x0020, 0x0071, 0x0075, 0x0027, 0x0075, 0x006e - , 0x0020, 0x00ea, 0x0074, 0x0072, 0x0065, 0x0020, 0x0068, 0x0075 - , 0x006d, 0x0061, 0x0069, 0x006e, 0x0020, 0x0073, 0x006f, 0x0069 - , 0x0074, 0x0020, 0x0065, 0x0078, 0x0070, 0x006f, 0x0073, 0x00e9 - , 0x0020, 0x0061, 0x0075, 0x0020, 0x0064, 0x0061, 0x006e, 0x0067 - , 0x0065, 0x0072, 0x0020, 0x003b, 0x000a, 0x0032, 0x002e, 0x0020 - , 0x0075, 0x006e, 0x0020, 0x0072, 0x006f, 0x0062, 0x006f, 0x0074 - , 0x0020, 0x0064, 0x006f, 0x0069, 0x0074, 0x0020, 0x006f, 0x0062 - , 0x00e9, 0x0069, 0x0072, 0x0020, 0x0061, 0x0075, 0x0078, 0x0020 - , 0x006f, 0x0072, 0x0064, 0x0072, 0x0065, 0x0073, 0x0020, 0x0071 - , 0x0075, 0x0069, 0x0020, 0x006c, 0x0075, 0x0069, 0x0020, 0x0073 - , 0x006f, 0x006e, 0x0074, 0x0020, 0x0064, 0x006f, 0x006e, 0x006e - , 0x00e9, 0x0073, 0x0020, 0x0070, 0x0061, 0x0072, 0x0020, 0x0075 - , 0x006e, 0x0020, 0x00ea, 0x0074, 0x0072, 0x0065, 0x0020, 0x0068 - , 0x0075, 0x006d, 0x0061, 0x0069, 0x006e, 0x002c, 0x0020, 0x0073 - , 0x0061, 0x0075, 0x0066, 0x0020, 0x0073, 0x0069, 0x0020, 0x0064 - , 0x0065, 0x0020, 0x0074, 0x0065, 0x006c, 0x0073, 0x0020, 0x006f - , 0x0072, 0x0064, 0x0072, 0x0065, 0x0073, 0x0020, 0x0065, 0x006e - , 0x0074, 0x0072, 0x0065, 0x006e, 0x0074, 0x0020, 0x0065, 0x006e - , 0x0020, 0x0063, 0x006f, 0x006e, 0x0066, 0x006c, 0x0069, 0x0074 - , 0x0020, 0x0061, 0x0076, 0x0065, 0x0063, 0x0020, 0x006c, 0x0061 - , 0x0020, 0x0070, 0x0072, 0x0065, 0x006d, 0x0069, 0x00e8, 0x0072 - , 0x0065, 0x0020, 0x006c, 0x006f, 0x0069, 0x0020, 0x003b, 0x000a - , 0x0033, 0x002e, 0x0020, 0x0075, 0x006e, 0x0020, 0x0072, 0x006f - , 0x0062, 0x006f, 0x0074, 0x0020, 0x0064, 0x006f, 0x0069, 0x0074 - , 0x0020, 0x0070, 0x0072, 0x006f, 0x0074, 0x00e9, 0x0067, 0x0065 - , 0x0072, 0x0020, 0x0073, 0x006f, 0x006e, 0x0020, 0x0065, 0x0078 - , 0x0069, 0x0073, 0x0074, 0x0065, 0x006e, 0x0063, 0x0065, 0x0020 - , 0x0074, 0x0061, 0x006e, 0x0074, 0x0020, 0x0071, 0x0075, 0x0065 - , 0x0020, 0x0063, 0x0065, 0x0074, 0x0074, 0x0065, 0x0020, 0x0070 - , 0x0072, 0x006f, 0x0074, 0x0065, 0x0063, 0x0074, 0x0069, 0x006f - , 0x006e, 0x0020, 0x006e, 0x0027, 0x0065, 0x006e, 0x0074, 0x0072 - , 0x0065, 0x0020, 0x0070, 0x0061, 0x0073, 0x0020, 0x0065, 0x006e - , 0x0020, 0x0063, 0x006f, 0x006e, 0x0066, 0x006c, 0x0069, 0x0074 - , 0x0020, 0x0061, 0x0076, 0x0065, 0x0063, 0x0020, 0x006c, 0x0061 - , 0x0020, 0x0070, 0x0072, 0x0065, 0x006d, 0x0069, 0x00e8, 0x0072 - , 0x0065, 0x0020, 0x006f, 0x0075, 0x0020, 0x006c, 0x0061, 0x0020 - , 0x0064, 0x0065, 0x0075, 0x0078, 0x0069, 0x00e8, 0x006d, 0x0065 - , 0x0020, 0x006c, 0x006f, 0x0069, 0x002e, 0x000a, 0x000a, 0x0049 - , 0x006e, 0x0020, 0x0044, 0x0061, 0x006e, 0x0069, 0x0073, 0x0068 - , 0x003a, 0x000a, 0x000a, 0x0031, 0x002e, 0x0020, 0x0045, 0x006e - , 0x0020, 0x0072, 0x006f, 0x0062, 0x006f, 0x0074, 0x0020, 0x006d - , 0x00e5, 0x0020, 0x0069, 0x006b, 0x006b, 0x0065, 0x0020, 0x0067 - , 0x00f8, 0x0072, 0x0065, 0x0020, 0x0065, 0x0074, 0x0020, 0x006d - , 0x0065, 0x006e, 0x006e, 0x0065, 0x0073, 0x006b, 0x0065, 0x0020 - , 0x0066, 0x006f, 0x0072, 0x0074, 0x0072, 0x00e6, 0x0064, 0x002c - , 0x0020, 0x0065, 0x006c, 0x006c, 0x0065, 0x0072, 0x002c, 0x0020 - , 0x0076, 0x0065, 0x0064, 0x0020, 0x0069, 0x006b, 0x006b, 0x0065 - , 0x0020, 0x0061, 0x0074, 0x0020, 0x0067, 0x00f8, 0x0072, 0x0065 - , 0x0020, 0x006e, 0x006f, 0x0067, 0x0065, 0x0074, 0x002c, 0x0020 - , 0x006c, 0x0061, 0x0064, 0x0065, 0x0020, 0x0065, 0x0074, 0x0020 - , 0x006d, 0x0065, 0x006e, 0x006e, 0x0065, 0x0073, 0x006b, 0x0065 - , 0x0020, 0x006b, 0x006f, 0x006d, 0x006d, 0x0065, 0x0020, 0x0074 - , 0x0069, 0x006c, 0x0020, 0x0073, 0x006b, 0x0061, 0x0064, 0x0065 - , 0x000a, 0x0032, 0x002e, 0x0020, 0x0045, 0x006e, 0x0020, 0x0072 - , 0x006f, 0x0062, 0x006f, 0x0074, 0x0020, 0x0073, 0x006b, 0x0061 - , 0x006c, 0x0020, 0x0061, 0x0064, 0x006c, 0x0079, 0x0064, 0x0065 - , 0x0020, 0x006f, 0x0072, 0x0064, 0x0072, 0x0065, 0x0072, 0x0020 - , 0x0067, 0x0069, 0x0076, 0x0065, 0x0074, 0x0020, 0x0061, 0x0066 - , 0x0020, 0x006d, 0x0065, 0x006e, 0x006e, 0x0065, 0x0073, 0x006b - , 0x0065, 0x0072, 0x002c, 0x0020, 0x0073, 0x00e5, 0x0020, 0x006c - , 0x00e6, 0x006e, 0x0067, 0x0065, 0x0020, 0x0064, 0x0069, 0x0073 - , 0x0073, 0x0065, 0x0020, 0x0069, 0x006b, 0x006b, 0x0065, 0x0020 - , 0x0065, 0x0072, 0x0020, 0x0069, 0x0020, 0x006b, 0x006f, 0x006e - , 0x0066, 0x006c, 0x0069, 0x006b, 0x0074, 0x0020, 0x006d, 0x0065 - , 0x0064, 0x0020, 0x0066, 0x00f8, 0x0072, 0x0073, 0x0074, 0x0065 - , 0x0020, 0x006c, 0x006f, 0x0076, 0x000a, 0x0033, 0x002e, 0x0020 - , 0x0045, 0x006e, 0x0020, 0x0072, 0x006f, 0x0062, 0x006f, 0x0074 - , 0x0020, 0x0073, 0x006b, 0x0061, 0x006c, 0x0020, 0x0062, 0x0065 - , 0x0073, 0x006b, 0x0079, 0x0074, 0x0074, 0x0065, 0x0020, 0x0073 - , 0x0069, 0x006e, 0x0020, 0x0065, 0x0067, 0x0065, 0x006e, 0x0020 - , 0x0065, 0x006b, 0x0073, 0x0069, 0x0073, 0x0074, 0x0065, 0x006e - , 0x0073, 0x002c, 0x0020, 0x0073, 0x00e5, 0x0020, 0x006c, 0x00e6 - , 0x006e, 0x0067, 0x0065, 0x0020, 0x0064, 0x0065, 0x0074, 0x0074 - , 0x0065, 0x0020, 0x0069, 0x006b, 0x006b, 0x0065, 0x0020, 0x0065 - , 0x0072, 0x0020, 0x0069, 0x0020, 0x006b, 0x006f, 0x006e, 0x0066 - , 0x006c, 0x0069, 0x006b, 0x0074, 0x0020, 0x006d, 0x0065, 0x0064 - , 0x0020, 0x0066, 0x00f8, 0x0072, 0x0073, 0x0074, 0x0065, 0x0020 - , 0x0065, 0x006c, 0x006c, 0x0065, 0x0072, 0x0020, 0x0061, 0x006e - , 0x0064, 0x0065, 0x006e, 0x0020, 0x006c, 0x006f, 0x0076, 0x000a - ] - -sample1_ISO_8859_1 :: EncodedString -sample1_ISO_8859_1 = EncodedString ISO_8859_1 $ fromList - [ 0x49, 0x6e, 0x20, 0x46, 0x72, 0x65, 0x6e, 0x63, 0x68, 0x3a, 0x0a, 0x0a, 0x31, 0x2e, 0x20, 0x75 - , 0x6e, 0x20, 0x72, 0x6f, 0x62, 0x6f, 0x74, 0x20, 0x6e, 0x65, 0x20, 0x70, 0x65, 0x75, 0x74, 0x20 - , 0x70, 0x6f, 0x72, 0x74, 0x65, 0x72, 0x20, 0x61, 0x74, 0x74, 0x65, 0x69, 0x6e, 0x74, 0x65, 0x20 - , 0xe0, 0x20, 0x75, 0x6e, 0x20, 0xea, 0x74, 0x72, 0x65, 0x20, 0x68, 0x75, 0x6d, 0x61, 0x69, 0x6e - , 0x2c, 0x20, 0x6e, 0x69, 0x2c, 0x20, 0x65, 0x6e, 0x20, 0x72, 0x65, 0x73, 0x74, 0x61, 0x6e, 0x74 - , 0x20, 0x70, 0x61, 0x73, 0x73, 0x69, 0x66, 0x2c, 0x20, 0x70, 0x65, 0x72, 0x6d, 0x65, 0x74, 0x74 - , 0x72, 0x65, 0x20, 0x71, 0x75, 0x27, 0x75, 0x6e, 0x20, 0xea, 0x74, 0x72, 0x65, 0x20, 0x68, 0x75 - , 0x6d, 0x61, 0x69, 0x6e, 0x20, 0x73, 0x6f, 0x69, 0x74, 0x20, 0x65, 0x78, 0x70, 0x6f, 0x73, 0xe9 - , 0x20, 0x61, 0x75, 0x20, 0x64, 0x61, 0x6e, 0x67, 0x65, 0x72, 0x20, 0x3b, 0x0a, 0x32, 0x2e, 0x20 - , 0x75, 0x6e, 0x20, 0x72, 0x6f, 0x62, 0x6f, 0x74, 0x20, 0x64, 0x6f, 0x69, 0x74, 0x20, 0x6f, 0x62 - , 0xe9, 0x69, 0x72, 0x20, 0x61, 0x75, 0x78, 0x20, 0x6f, 0x72, 0x64, 0x72, 0x65, 0x73, 0x20, 0x71 - , 0x75, 0x69, 0x20, 0x6c, 0x75, 0x69, 0x20, 0x73, 0x6f, 0x6e, 0x74, 0x20, 0x64, 0x6f, 0x6e, 0x6e - , 0xe9, 0x73, 0x20, 0x70, 0x61, 0x72, 0x20, 0x75, 0x6e, 0x20, 0xea, 0x74, 0x72, 0x65, 0x20, 0x68 - , 0x75, 0x6d, 0x61, 0x69, 0x6e, 0x2c, 0x20, 0x73, 0x61, 0x75, 0x66, 0x20, 0x73, 0x69, 0x20, 0x64 - , 0x65, 0x20, 0x74, 0x65, 0x6c, 0x73, 0x20, 0x6f, 0x72, 0x64, 0x72, 0x65, 0x73, 0x20, 0x65, 0x6e - , 0x74, 0x72, 0x65, 0x6e, 0x74, 0x20, 0x65, 0x6e, 0x20, 0x63, 0x6f, 0x6e, 0x66, 0x6c, 0x69, 0x74 - , 0x20, 0x61, 0x76, 0x65, 0x63, 0x20, 0x6c, 0x61, 0x20, 0x70, 0x72, 0x65, 0x6d, 0x69, 0xe8, 0x72 - , 0x65, 0x20, 0x6c, 0x6f, 0x69, 0x20, 0x3b, 0x0a, 0x33, 0x2e, 0x20, 0x75, 0x6e, 0x20, 0x72, 0x6f - , 0x62, 0x6f, 0x74, 0x20, 0x64, 0x6f, 0x69, 0x74, 0x20, 0x70, 0x72, 0x6f, 0x74, 0xe9, 0x67, 0x65 - , 0x72, 0x20, 0x73, 0x6f, 0x6e, 0x20, 0x65, 0x78, 0x69, 0x73, 0x74, 0x65, 0x6e, 0x63, 0x65, 0x20 - , 0x74, 0x61, 0x6e, 0x74, 0x20, 0x71, 0x75, 0x65, 0x20, 0x63, 0x65, 0x74, 0x74, 0x65, 0x20, 0x70 - , 0x72, 0x6f, 0x74, 0x65, 0x63, 0x74, 0x69, 0x6f, 0x6e, 0x20, 0x6e, 0x27, 0x65, 0x6e, 0x74, 0x72 - , 0x65, 0x20, 0x70, 0x61, 0x73, 0x20, 0x65, 0x6e, 0x20, 0x63, 0x6f, 0x6e, 0x66, 0x6c, 0x69, 0x74 - , 0x20, 0x61, 0x76, 0x65, 0x63, 0x20, 0x6c, 0x61, 0x20, 0x70, 0x72, 0x65, 0x6d, 0x69, 0xe8, 0x72 - , 0x65, 0x20, 0x6f, 0x75, 0x20, 0x6c, 0x61, 0x20, 0x64, 0x65, 0x75, 0x78, 0x69, 0xe8, 0x6d, 0x65 - , 0x20, 0x6c, 0x6f, 0x69, 0x2e, 0x0a, 0x0a, 0x49, 0x6e, 0x20, 0x44, 0x61, 0x6e, 0x69, 0x73, 0x68 - , 0x3a, 0x0a, 0x0a, 0x31, 0x2e, 0x20, 0x45, 0x6e, 0x20, 0x72, 0x6f, 0x62, 0x6f, 0x74, 0x20, 0x6d - , 0xe5, 0x20, 0x69, 0x6b, 0x6b, 0x65, 0x20, 0x67, 0xf8, 0x72, 0x65, 0x20, 0x65, 0x74, 0x20, 0x6d - , 0x65, 0x6e, 0x6e, 0x65, 0x73, 0x6b, 0x65, 0x20, 0x66, 0x6f, 0x72, 0x74, 0x72, 0xe6, 0x64, 0x2c - , 0x20, 0x65, 0x6c, 0x6c, 0x65, 0x72, 0x2c, 0x20, 0x76, 0x65, 0x64, 0x20, 0x69, 0x6b, 0x6b, 0x65 - , 0x20, 0x61, 0x74, 0x20, 0x67, 0xf8, 0x72, 0x65, 0x20, 0x6e, 0x6f, 0x67, 0x65, 0x74, 0x2c, 0x20 - , 0x6c, 0x61, 0x64, 0x65, 0x20, 0x65, 0x74, 0x20, 0x6d, 0x65, 0x6e, 0x6e, 0x65, 0x73, 0x6b, 0x65 - , 0x20, 0x6b, 0x6f, 0x6d, 0x6d, 0x65, 0x20, 0x74, 0x69, 0x6c, 0x20, 0x73, 0x6b, 0x61, 0x64, 0x65 - , 0x0a, 0x32, 0x2e, 0x20, 0x45, 0x6e, 0x20, 0x72, 0x6f, 0x62, 0x6f, 0x74, 0x20, 0x73, 0x6b, 0x61 - , 0x6c, 0x20, 0x61, 0x64, 0x6c, 0x79, 0x64, 0x65, 0x20, 0x6f, 0x72, 0x64, 0x72, 0x65, 0x72, 0x20 - , 0x67, 0x69, 0x76, 0x65, 0x74, 0x20, 0x61, 0x66, 0x20, 0x6d, 0x65, 0x6e, 0x6e, 0x65, 0x73, 0x6b - , 0x65, 0x72, 0x2c, 0x20, 0x73, 0xe5, 0x20, 0x6c, 0xe6, 0x6e, 0x67, 0x65, 0x20, 0x64, 0x69, 0x73 - , 0x73, 0x65, 0x20, 0x69, 0x6b, 0x6b, 0x65, 0x20, 0x65, 0x72, 0x20, 0x69, 0x20, 0x6b, 0x6f, 0x6e - , 0x66, 0x6c, 0x69, 0x6b, 0x74, 0x20, 0x6d, 0x65, 0x64, 0x20, 0x66, 0xf8, 0x72, 0x73, 0x74, 0x65 - , 0x20, 0x6c, 0x6f, 0x76, 0x0a, 0x33, 0x2e, 0x20, 0x45, 0x6e, 0x20, 0x72, 0x6f, 0x62, 0x6f, 0x74 - , 0x20, 0x73, 0x6b, 0x61, 0x6c, 0x20, 0x62, 0x65, 0x73, 0x6b, 0x79, 0x74, 0x74, 0x65, 0x20, 0x73 - , 0x69, 0x6e, 0x20, 0x65, 0x67, 0x65, 0x6e, 0x20, 0x65, 0x6b, 0x73, 0x69, 0x73, 0x74, 0x65, 0x6e - , 0x73, 0x2c, 0x20, 0x73, 0xe5, 0x20, 0x6c, 0xe6, 0x6e, 0x67, 0x65, 0x20, 0x64, 0x65, 0x74, 0x74 - , 0x65, 0x20, 0x69, 0x6b, 0x6b, 0x65, 0x20, 0x65, 0x72, 0x20, 0x69, 0x20, 0x6b, 0x6f, 0x6e, 0x66 - , 0x6c, 0x69, 0x6b, 0x74, 0x20, 0x6d, 0x65, 0x64, 0x20, 0x66, 0xf8, 0x72, 0x73, 0x74, 0x65, 0x20 - , 0x65, 0x6c, 0x6c, 0x65, 0x72, 0x20, 0x61, 0x6e, 0x64, 0x65, 0x6e, 0x20, 0x6c, 0x6f, 0x76, 0x0a - ] - --- -------------------------- Sample 2 ------------------------------------- -- - -sample2 :: ([EncodedString], String) -sample2 = ( [sample2_UTF8, sample2_UTF16] - , sample2_String - ) - -sample2_String :: String -sample2_String = - "The sample text below has been taken from Wikipedia:\n\ - \https://zh.wikipedia.org/wiki/%E5%9F%BA%E5%9C%B0%E7%B3%BB%E5%88%97\n\ - \\n\ - \基地系列（The Foundation Series）是一部經典科幻小說系列，創作時間橫跨美國作家以撒·艾西莫夫49個寫作年頭，一共10冊（包括別人續寫3冊），彼此間劇情獨立，卻又緊密關聯。「基地系列」通常也將處在同一架空宇宙的「機器人系列」和「銀河帝國系列」包括進來，總計起來整個「大基地系列」作品共有14冊長篇，和數不清的短篇小說，另外6冊由其他作家在他死後續寫。「基地系列」備受讚譽，1965年得過雨果獎「史上最佳科幻小說系列」。\n\ - \\n\ - \《基地》原本是一系列8篇的短篇小說，在1942年5月到1950年1月期間發表於《驚奇雜誌》（Astounding Magazine）。艾西莫夫在自傳中表示，《基地》是在他拜訪編輯約翰·坎貝爾（John W. Campbell）的路上，天馬行空聯想自愛德華·吉本的《羅馬帝國衰亡史》，之後與坎貝爾兩相討論下，整體概念遂而成形[1]。\n\ - \\n\ - \「基地系列」第一部《基地》包含4篇短篇小說，劇情各自獨立，單行本發行於1951年。其它4篇中篇小說兩兩相對，分別收錄在《基地與帝國》和《第二基地》，成為名聞遐邇的「基地三部曲」。1981年，「基地三部曲」早已是世所公認最重要的現代科幻作品，艾西莫夫終於被出版商說服續寫「基地系列」第四部《基地邊緣》[2]。接下來他又寫了一部續集《基地與地球》，5年後發表兩部前傳《基地前奏》和《基地締造者》，在這幾年中，艾西莫夫將「基地系列」與其它系列相結合，將所有系列作品同置於一個「基地宇宙」架構下。\n\ - \\n\ - \艾西莫夫和坎貝爾聯手為「基地系列」打造出一門全新的統計科學，稱之為“心理史學”，這門學問由書中数學家哈里·謝頓窮盡畢生之力創建，根據大規模的人類活動數據，預測未來走向，規模一旦小於一顆星球或是一座帝國，結果就會失準。謝頓運用此一科學，預見銀河帝國的殞落，整片銀河將因此進入長達三萬年的黑暗時期，直到第二帝國建立。\n\ - \\n\ - \於是謝頓建立兩座基地，藉以縮減蠻荒時期，一座遠在邊陲，是藝術與科學的避風港，相對的另一座則在“群星的盡頭”。「基地三部曲」的主要焦點就在端點星上的基地。端點星上的學者為了搶在衰退期之前，保存人類物理科學的知識，努力編輯著一部全方位的《银河百科全书》，對謝頓真正的意圖毫不知情（如果他們知道，就會產生無法控制的變數）。基地的位置也是刻意選定的，千年後就是第二帝國的首都（並非三萬年後的那個帝國）\n" - -sample2_UTF8 :: EncodedString -sample2_UTF8 = EncodedString UTF8 $ fromList - [ 0x54, 0x68, 0x65, 0x20, 0x73, 0x61, 0x6d, 0x70, 0x6c, 0x65, 0x20, 0x74, 0x65, 0x78, 0x74, 0x20 - , 0x62, 0x65, 0x6c, 0x6f, 0x77, 0x20, 0x68, 0x61, 0x73, 0x20, 0x62, 0x65, 0x65, 0x6e, 0x20, 0x74 - , 0x61, 0x6b, 0x65, 0x6e, 0x20, 0x66, 0x72, 0x6f, 0x6d, 0x20, 0x57, 0x69, 0x6b, 0x69, 0x70, 0x65 - , 0x64, 0x69, 0x61, 0x3a, 0x0a, 0x68, 0x74, 0x74, 0x70, 0x73, 0x3a, 0x2f, 0x2f, 0x7a, 0x68, 0x2e - , 0x77, 0x69, 0x6b, 0x69, 0x70, 0x65, 0x64, 0x69, 0x61, 0x2e, 0x6f, 0x72, 0x67, 0x2f, 0x77, 0x69 - , 0x6b, 0x69, 0x2f, 0x25, 0x45, 0x35, 0x25, 0x39, 0x46, 0x25, 0x42, 0x41, 0x25, 0x45, 0x35, 0x25 - , 0x39, 0x43, 0x25, 0x42, 0x30, 0x25, 0x45, 0x37, 0x25, 0x42, 0x33, 0x25, 0x42, 0x42, 0x25, 0x45 - , 0x35, 0x25, 0x38, 0x38, 0x25, 0x39, 0x37, 0x0a, 0x0a, 0xe5, 0x9f, 0xba, 0xe5, 0x9c, 0xb0, 0xe7 - , 0xb3, 0xbb, 0xe5, 0x88, 0x97, 0xef, 0xbc, 0x88, 0x54, 0x68, 0x65, 0x20, 0x46, 0x6f, 0x75, 0x6e - , 0x64, 0x61, 0x74, 0x69, 0x6f, 0x6e, 0x20, 0x53, 0x65, 0x72, 0x69, 0x65, 0x73, 0xef, 0xbc, 0x89 - , 0xe6, 0x98, 0xaf, 0xe4, 0xb8, 0x80, 0xe9, 0x83, 0xa8, 0xe7, 0xb6, 0x93, 0xe5, 0x85, 0xb8, 0xe7 - , 0xa7, 0x91, 0xe5, 0xb9, 0xbb, 0xe5, 0xb0, 0x8f, 0xe8, 0xaa, 0xaa, 0xe7, 0xb3, 0xbb, 0xe5, 0x88 - , 0x97, 0xef, 0xbc, 0x8c, 0xe5, 0x89, 0xb5, 0xe4, 0xbd, 0x9c, 0xe6, 0x99, 0x82, 0xe9, 0x96, 0x93 - , 0xe6, 0xa9, 0xab, 0xe8, 0xb7, 0xa8, 0xe7, 0xbe, 0x8e, 0xe5, 0x9c, 0x8b, 0xe4, 0xbd, 0x9c, 0xe5 - , 0xae, 0xb6, 0xe4, 0xbb, 0xa5, 0xe6, 0x92, 0x92, 0xc2, 0xb7, 0xe8, 0x89, 0xbe, 0xe8, 0xa5, 0xbf - , 0xe8, 0x8e, 0xab, 0xe5, 0xa4, 0xab, 0x34, 0x39, 0xe5, 0x80, 0x8b, 0xe5, 0xaf, 0xab, 0xe4, 0xbd - , 0x9c, 0xe5, 0xb9, 0xb4, 0xe9, 0xa0, 0xad, 0xef, 0xbc, 0x8c, 0xe4, 0xb8, 0x80, 0xe5, 0x85, 0xb1 - , 0x31, 0x30, 0xe5, 0x86, 0x8a, 0xef, 0xbc, 0x88, 0xe5, 0x8c, 0x85, 0xe6, 0x8b, 0xac, 0xe5, 0x88 - , 0xa5, 0xe4, 0xba, 0xba, 0xe7, 0xba, 0x8c, 0xe5, 0xaf, 0xab, 0x33, 0xe5, 0x86, 0x8a, 0xef, 0xbc - , 0x89, 0xef, 0xbc, 0x8c, 0xe5, 0xbd, 0xbc, 0xe6, 0xad, 0xa4, 0xe9, 0x96, 0x93, 0xe5, 0x8a, 0x87 - , 0xe6, 0x83, 0x85, 0xe7, 0x8d, 0xa8, 0xe7, 0xab, 0x8b, 0xef, 0xbc, 0x8c, 0xe5, 0x8d, 0xbb, 0xe5 - , 0x8f, 0x88, 0xe7, 0xb7, 0x8a, 0xe5, 0xaf, 0x86, 0xe9, 0x97, 0x9c, 0xe8, 0x81, 0xaf, 0xe3, 0x80 - , 0x82, 0xe3, 0x80, 0x8c, 0xe5, 0x9f, 0xba, 0xe5, 0x9c, 0xb0, 0xe7, 0xb3, 0xbb, 0xe5, 0x88, 0x97 - , 0xe3, 0x80, 0x8d, 0xe9, 0x80, 0x9a, 0xe5, 0xb8, 0xb8, 0xe4, 0xb9, 0x9f, 0xe5, 0xb0, 0x87, 0xe8 - , 0x99, 0x95, 0xe5, 0x9c, 0xa8, 0xe5, 0x90, 0x8c, 0xe4, 0xb8, 0x80, 0xe6, 0x9e, 0xb6, 0xe7, 0xa9 - , 0xba, 0xe5, 0xae, 0x87, 0xe5, 0xae, 0x99, 0xe7, 0x9a, 0x84, 0xe3, 0x80, 0x8c, 0xe6, 0xa9, 0x9f - , 0xe5, 0x99, 0xa8, 0xe4, 0xba, 0xba, 0xe7, 0xb3, 0xbb, 0xe5, 0x88, 0x97, 0xe3, 0x80, 0x8d, 0xe5 - , 0x92, 0x8c, 0xe3, 0x80, 0x8c, 0xe9, 0x8a, 0x80, 0xe6, 0xb2, 0xb3, 0xe5, 0xb8, 0x9d, 0xe5, 0x9c - , 0x8b, 0xe7, 0xb3, 0xbb, 0xe5, 0x88, 0x97, 0xe3, 0x80, 0x8d, 0xe5, 0x8c, 0x85, 0xe6, 0x8b, 0xac - , 0xe9, 0x80, 0xb2, 0xe4, 0xbe, 0x86, 0xef, 0xbc, 0x8c, 0xe7, 0xb8, 0xbd, 0xe8, 0xa8, 0x88, 0xe8 - , 0xb5, 0xb7, 0xe4, 0xbe, 0x86, 0xe6, 0x95, 0xb4, 0xe5, 0x80, 0x8b, 0xe3, 0x80, 0x8c, 0xe5, 0xa4 - , 0xa7, 0xe5, 0x9f, 0xba, 0xe5, 0x9c, 0xb0, 0xe7, 0xb3, 0xbb, 0xe5, 0x88, 0x97, 0xe3, 0x80, 0x8d - , 0xe4, 0xbd, 0x9c, 0xe5, 0x93, 0x81, 0xe5, 0x85, 0xb1, 0xe6, 0x9c, 0x89, 0x31, 0x34, 0xe5, 0x86 - , 0x8a, 0xe9, 0x95, 0xb7, 0xe7, 0xaf, 0x87, 0xef, 0xbc, 0x8c, 0xe5, 0x92, 0x8c, 0xe6, 0x95, 0xb8 - , 0xe4, 0xb8, 0x8d, 0xe6, 0xb8, 0x85, 0xe7, 0x9a, 0x84, 0xe7, 0x9f, 0xad, 0xe7, 0xaf, 0x87, 0xe5 - , 0xb0, 0x8f, 0xe8, 0xaa, 0xaa, 0xef, 0xbc, 0x8c, 0xe5, 0x8f, 0xa6, 0xe5, 0xa4, 0x96, 0x36, 0xe5 - , 0x86, 0x8a, 0xe7, 0x94, 0xb1, 0xe5, 0x85, 0xb6, 0xe4, 0xbb, 0x96, 0xe4, 0xbd, 0x9c, 0xe5, 0xae - , 0xb6, 0xe5, 0x9c, 0xa8, 0xe4, 0xbb, 0x96, 0xe6, 0xad, 0xbb, 0xe5, 0xbe, 0x8c, 0xe7, 0xba, 0x8c - , 0xe5, 0xaf, 0xab, 0xe3, 0x80, 0x82, 0xe3, 0x80, 0x8c, 0xe5, 0x9f, 0xba, 0xe5, 0x9c, 0xb0, 0xe7 - , 0xb3, 0xbb, 0xe5, 0x88, 0x97, 0xe3, 0x80, 0x8d, 0xe5, 0x82, 0x99, 0xe5, 0x8f, 0x97, 0xe8, 0xae - , 0x9a, 0xe8, 0xad, 0xbd, 0xef, 0xbc, 0x8c, 0x31, 0x39, 0x36, 0x35, 0xe5, 0xb9, 0xb4, 0xe5, 0xbe - , 0x97, 0xe9, 0x81, 0x8e, 0xe9, 0x9b, 0xa8, 0xe6, 0x9e, 0x9c, 0xe7, 0x8d, 0x8e, 0xe3, 0x80, 0x8c - , 0xe5, 0x8f, 0xb2, 0xe4, 0xb8, 0x8a, 0xe6, 0x9c, 0x80, 0xe4, 0xbd, 0xb3, 0xe7, 0xa7, 0x91, 0xe5 - , 0xb9, 0xbb, 0xe5, 0xb0, 0x8f, 0xe8, 0xaa, 0xaa, 0xe7, 0xb3, 0xbb, 0xe5, 0x88, 0x97, 0xe3, 0x80 - , 0x8d, 0xe3, 0x80, 0x82, 0x0a, 0x0a, 0xe3, 0x80, 0x8a, 0xe5, 0x9f, 0xba, 0xe5, 0x9c, 0xb0, 0xe3 - , 0x80, 0x8b, 0xe5, 0x8e, 0x9f, 0xe6, 0x9c, 0xac, 0xe6, 0x98, 0xaf, 0xe4, 0xb8, 0x80, 0xe7, 0xb3 - , 0xbb, 0xe5, 0x88, 0x97, 0x38, 0xe7, 0xaf, 0x87, 0xe7, 0x9a, 0x84, 0xe7, 0x9f, 0xad, 0xe7, 0xaf - , 0x87, 0xe5, 0xb0, 0x8f, 0xe8, 0xaa, 0xaa, 0xef, 0xbc, 0x8c, 0xe5, 0x9c, 0xa8, 0x31, 0x39, 0x34 - , 0x32, 0xe5, 0xb9, 0xb4, 0x35, 0xe6, 0x9c, 0x88, 0xe5, 0x88, 0xb0, 0x31, 0x39, 0x35, 0x30, 0xe5 - , 0xb9, 0xb4, 0x31, 0xe6, 0x9c, 0x88, 0xe6, 0x9c, 0x9f, 0xe9, 0x96, 0x93, 0xe7, 0x99, 0xbc, 0xe8 - , 0xa1, 0xa8, 0xe6, 0x96, 0xbc, 0xe3, 0x80, 0x8a, 0xe9, 0xa9, 0x9a, 0xe5, 0xa5, 0x87, 0xe9, 0x9b - , 0x9c, 0xe8, 0xaa, 0x8c, 0xe3, 0x80, 0x8b, 0xef, 0xbc, 0x88, 0x41, 0x73, 0x74, 0x6f, 0x75, 0x6e - , 0x64, 0x69, 0x6e, 0x67, 0x20, 0x4d, 0x61, 0x67, 0x61, 0x7a, 0x69, 0x6e, 0x65, 0xef, 0xbc, 0x89 - , 0xe3, 0x80, 0x82, 0xe8, 0x89, 0xbe, 0xe8, 0xa5, 0xbf, 0xe8, 0x8e, 0xab, 0xe5, 0xa4, 0xab, 0xe5 - , 0x9c, 0xa8, 0xe8, 0x87, 0xaa, 0xe5, 0x82, 0xb3, 0xe4, 0xb8, 0xad, 0xe8, 0xa1, 0xa8, 0xe7, 0xa4 - , 0xba, 0xef, 0xbc, 0x8c, 0xe3, 0x80, 0x8a, 0xe5, 0x9f, 0xba, 0xe5, 0x9c, 0xb0, 0xe3, 0x80, 0x8b - , 0xe6, 0x98, 0xaf, 0xe5, 0x9c, 0xa8, 0xe4, 0xbb, 0x96, 0xe6, 0x8b, 0x9c, 0xe8, 0xa8, 0xaa, 0xe7 - , 0xb7, 0xa8, 0xe8, 0xbc, 0xaf, 0xe7, 0xb4, 0x84, 0xe7, 0xbf, 0xb0, 0xc2, 0xb7, 0xe5, 0x9d, 0x8e - , 0xe8, 0xb2, 0x9d, 0xe7, 0x88, 0xbe, 0xef, 0xbc, 0x88, 0x4a, 0x6f, 0x68, 0x6e, 0x20, 0x57, 0x2e - , 0x20, 0x43, 0x61, 0x6d, 0x70, 0x62, 0x65, 0x6c, 0x6c, 0xef, 0xbc, 0x89, 0xe7, 0x9a, 0x84, 0xe8 - , 0xb7, 0xaf, 0xe4, 0xb8, 0x8a, 0xef, 0xbc, 0x8c, 0xe5, 0xa4, 0xa9, 0xe9, 0xa6, 0xac, 0xe8, 0xa1 - , 0x8c, 0xe7, 0xa9, 0xba, 0xe8, 0x81, 0xaf, 0xe6, 0x83, 0xb3, 0xe8, 0x87, 0xaa, 0xe6, 0x84, 0x9b - , 0xe5, 0xbe, 0xb7, 0xe8, 0x8f, 0xaf, 0xc2, 0xb7, 0xe5, 0x90, 0x89, 0xe6, 0x9c, 0xac, 0xe7, 0x9a - , 0x84, 0xe3, 0x80, 0x8a, 0xe7, 0xbe, 0x85, 0xe9, 0xa6, 0xac, 0xe5, 0xb8, 0x9d, 0xe5, 0x9c, 0x8b - , 0xe8, 0xa1, 0xb0, 0xe4, 0xba, 0xa1, 0xe5, 0x8f, 0xb2, 0xe3, 0x80, 0x8b, 0xef, 0xbc, 0x8c, 0xe4 - , 0xb9, 0x8b, 0xe5, 0xbe, 0x8c, 0xe8, 0x88, 0x87, 0xe5, 0x9d, 0x8e, 0xe8, 0xb2, 0x9d, 0xe7, 0x88 - , 0xbe, 0xe5, 0x85, 0xa9, 0xe7, 0x9b, 0xb8, 0xe8, 0xa8, 0x8e, 0xe8, 0xab, 0x96, 0xe4, 0xb8, 0x8b - , 0xef, 0xbc, 0x8c, 0xe6, 0x95, 0xb4, 0xe9, 0xab, 0x94, 0xe6, 0xa6, 0x82, 0xe5, 0xbf, 0xb5, 0xe9 - , 0x81, 0x82, 0xe8, 0x80, 0x8c, 0xe6, 0x88, 0x90, 0xe5, 0xbd, 0xa2, 0x5b, 0x31, 0x5d, 0xe3, 0x80 - , 0x82, 0x0a, 0x0a, 0xe3, 0x80, 0x8c, 0xe5, 0x9f, 0xba, 0xe5, 0x9c, 0xb0, 0xe7, 0xb3, 0xbb, 0xe5 - , 0x88, 0x97, 0xe3, 0x80, 0x8d, 0xe7, 0xac, 0xac, 0xe4, 0xb8, 0x80, 0xe9, 0x83, 0xa8, 0xe3, 0x80 - , 0x8a, 0xe5, 0x9f, 0xba, 0xe5, 0x9c, 0xb0, 0xe3, 0x80, 0x8b, 0xe5, 0x8c, 0x85, 0xe5, 0x90, 0xab - , 0x34, 0xe7, 0xaf, 0x87, 0xe7, 0x9f, 0xad, 0xe7, 0xaf, 0x87, 0xe5, 0xb0, 0x8f, 0xe8, 0xaa, 0xaa - , 0xef, 0xbc, 0x8c, 0xe5, 0x8a, 0x87, 0xe6, 0x83, 0x85, 0xe5, 0x90, 0x84, 0xe8, 0x87, 0xaa, 0xe7 - , 0x8d, 0xa8, 0xe7, 0xab, 0x8b, 0xef, 0xbc, 0x8c, 0xe5, 0x96, 0xae, 0xe8, 0xa1, 0x8c, 0xe6, 0x9c - , 0xac, 0xe7, 0x99, 0xbc, 0xe8, 0xa1, 0x8c, 0xe6, 0x96, 0xbc, 0x31, 0x39, 0x35, 0x31, 0xe5, 0xb9 - , 0xb4, 0xe3, 0x80, 0x82, 0xe5, 0x85, 0xb6, 0xe5, 0xae, 0x83, 0x34, 0xe7, 0xaf, 0x87, 0xe4, 0xb8 - , 0xad, 0xe7, 0xaf, 0x87, 0xe5, 0xb0, 0x8f, 0xe8, 0xaa, 0xaa, 0xe5, 0x85, 0xa9, 0xe5, 0x85, 0xa9 - , 0xe7, 0x9b, 0xb8, 0xe5, 0xb0, 0x8d, 0xef, 0xbc, 0x8c, 0xe5, 0x88, 0x86, 0xe5, 0x88, 0xa5, 0xe6 - , 0x94, 0xb6, 0xe9, 0x8c, 0x84, 0xe5, 0x9c, 0xa8, 0xe3, 0x80, 0x8a, 0xe5, 0x9f, 0xba, 0xe5, 0x9c - , 0xb0, 0xe8, 0x88, 0x87, 0xe5, 0xb8, 0x9d, 0xe5, 0x9c, 0x8b, 0xe3, 0x80, 0x8b, 0xe5, 0x92, 0x8c - , 0xe3, 0x80, 0x8a, 0xe7, 0xac, 0xac, 0xe4, 0xba, 0x8c, 0xe5, 0x9f, 0xba, 0xe5, 0x9c, 0xb0, 0xe3 - , 0x80, 0x8b, 0xef, 0xbc, 0x8c, 0xe6, 0x88, 0x90, 0xe7, 0x82, 0xba, 0xe5, 0x90, 0x8d, 0xe8, 0x81 - , 0x9e, 0xe9, 0x81, 0x90, 0xe9, 0x82, 0x87, 0xe7, 0x9a, 0x84, 0xe3, 0x80, 0x8c, 0xe5, 0x9f, 0xba - , 0xe5, 0x9c, 0xb0, 0xe4, 0xb8, 0x89, 0xe9, 0x83, 0xa8, 0xe6, 0x9b, 0xb2, 0xe3, 0x80, 0x8d, 0xe3 - , 0x80, 0x82, 0x31, 0x39, 0x38, 0x31, 0xe5, 0xb9, 0xb4, 0xef, 0xbc, 0x8c, 0xe3, 0x80, 0x8c, 0xe5 - , 0x9f, 0xba, 0xe5, 0x9c, 0xb0, 0xe4, 0xb8, 0x89, 0xe9, 0x83, 0xa8, 0xe6, 0x9b, 0xb2, 0xe3, 0x80 - , 0x8d, 0xe6, 0x97, 0xa9, 0xe5, 0xb7, 0xb2, 0xe6, 0x98, 0xaf, 0xe4, 0xb8, 0x96, 0xe6, 0x89, 0x80 - , 0xe5, 0x85, 0xac, 0xe8, 0xaa, 0x8d, 0xe6, 0x9c, 0x80, 0xe9, 0x87, 0x8d, 0xe8, 0xa6, 0x81, 0xe7 - , 0x9a, 0x84, 0xe7, 0x8f, 0xbe, 0xe4, 0xbb, 0xa3, 0xe7, 0xa7, 0x91, 0xe5, 0xb9, 0xbb, 0xe4, 0xbd - , 0x9c, 0xe5, 0x93, 0x81, 0xef, 0xbc, 0x8c, 0xe8, 0x89, 0xbe, 0xe8, 0xa5, 0xbf, 0xe8, 0x8e, 0xab - , 0xe5, 0xa4, 0xab, 0xe7, 0xb5, 0x82, 0xe6, 0x96, 0xbc, 0xe8, 0xa2, 0xab, 0xe5, 0x87, 0xba, 0xe7 - , 0x89, 0x88, 0xe5, 0x95, 0x86, 0xe8, 0xaa, 0xaa, 0xe6, 0x9c, 0x8d, 0xe7, 0xba, 0x8c, 0xe5, 0xaf - , 0xab, 0xe3, 0x80, 0x8c, 0xe5, 0x9f, 0xba, 0xe5, 0x9c, 0xb0, 0xe7, 0xb3, 0xbb, 0xe5, 0x88, 0x97 - , 0xe3, 0x80, 0x8d, 0xe7, 0xac, 0xac, 0xe5, 0x9b, 0x9b, 0xe9, 0x83, 0xa8, 0xe3, 0x80, 0x8a, 0xe5 - , 0x9f, 0xba, 0xe5, 0x9c, 0xb0, 0xe9, 0x82, 0x8a, 0xe7, 0xb7, 0xa3, 0xe3, 0x80, 0x8b, 0x5b, 0x32 - , 0x5d, 0xe3, 0x80, 0x82, 0xe6, 0x8e, 0xa5, 0xe4, 0xb8, 0x8b, 0xe4, 0xbe, 0x86, 0xe4, 0xbb, 0x96 - , 0xe5, 0x8f, 0x88, 0xe5, 0xaf, 0xab, 0xe4, 0xba, 0x86, 0xe4, 0xb8, 0x80, 0xe9, 0x83, 0xa8, 0xe7 - , 0xba, 0x8c, 0xe9, 0x9b, 0x86, 0xe3, 0x80, 0x8a, 0xe5, 0x9f, 0xba, 0xe5, 0x9c, 0xb0, 0xe8, 0x88 - , 0x87, 0xe5, 0x9c, 0xb0, 0xe7, 0x90, 0x83, 0xe3, 0x80, 0x8b, 0xef, 0xbc, 0x8c, 0x35, 0xe5, 0xb9 - , 0xb4, 0xe5, 0xbe, 0x8c, 0xe7, 0x99, 0xbc, 0xe8, 0xa1, 0xa8, 0xe5, 0x85, 0xa9, 0xe9, 0x83, 0xa8 - , 0xe5, 0x89, 0x8d, 0xe5, 0x82, 0xb3, 0xe3, 0x80, 0x8a, 0xe5, 0x9f, 0xba, 0xe5, 0x9c, 0xb0, 0xe5 - , 0x89, 0x8d, 0xe5, 0xa5, 0x8f, 0xe3, 0x80, 0x8b, 0xe5, 0x92, 0x8c, 0xe3, 0x80, 0x8a, 0xe5, 0x9f - , 0xba, 0xe5, 0x9c, 0xb0, 0xe7, 0xb7, 0xa0, 0xe9, 0x80, 0xa0, 0xe8, 0x80, 0x85, 0xe3, 0x80, 0x8b - , 0xef, 0xbc, 0x8c, 0xe5, 0x9c, 0xa8, 0xe9, 0x80, 0x99, 0xe5, 0xb9, 0xbe, 0xe5, 0xb9, 0xb4, 0xe4 - , 0xb8, 0xad, 0xef, 0xbc, 0x8c, 0xe8, 0x89, 0xbe, 0xe8, 0xa5, 0xbf, 0xe8, 0x8e, 0xab, 0xe5, 0xa4 - , 0xab, 0xe5, 0xb0, 0x87, 0xe3, 0x80, 0x8c, 0xe5, 0x9f, 0xba, 0xe5, 0x9c, 0xb0, 0xe7, 0xb3, 0xbb - , 0xe5, 0x88, 0x97, 0xe3, 0x80, 0x8d, 0xe8, 0x88, 0x87, 0xe5, 0x85, 0xb6, 0xe5, 0xae, 0x83, 0xe7 - , 0xb3, 0xbb, 0xe5, 0x88, 0x97, 0xe7, 0x9b, 0xb8, 0xe7, 0xb5, 0x90, 0xe5, 0x90, 0x88, 0xef, 0xbc - , 0x8c, 0xe5, 0xb0, 0x87, 0xe6, 0x89, 0x80, 0xe6, 0x9c, 0x89, 0xe7, 0xb3, 0xbb, 0xe5, 0x88, 0x97 - , 0xe4, 0xbd, 0x9c, 0xe5, 0x93, 0x81, 0xe5, 0x90, 0x8c, 0xe7, 0xbd, 0xae, 0xe6, 0x96, 0xbc, 0xe4 - , 0xb8, 0x80, 0xe5, 0x80, 0x8b, 0xe3, 0x80, 0x8c, 0xe5, 0x9f, 0xba, 0xe5, 0x9c, 0xb0, 0xe5, 0xae - , 0x87, 0xe5, 0xae, 0x99, 0xe3, 0x80, 0x8d, 0xe6, 0x9e, 0xb6, 0xe6, 0xa7, 0x8b, 0xe4, 0xb8, 0x8b - , 0xe3, 0x80, 0x82, 0x0a, 0x0a, 0xe8, 0x89, 0xbe, 0xe8, 0xa5, 0xbf, 0xe8, 0x8e, 0xab, 0xe5, 0xa4 - , 0xab, 0xe5, 0x92, 0x8c, 0xe5, 0x9d, 0x8e, 0xe8, 0xb2, 0x9d, 0xe7, 0x88, 0xbe, 0xe8, 0x81, 0xaf - , 0xe6, 0x89, 0x8b, 0xe7, 0x82, 0xba, 0xe3, 0x80, 0x8c, 0xe5, 0x9f, 0xba, 0xe5, 0x9c, 0xb0, 0xe7 - , 0xb3, 0xbb, 0xe5, 0x88, 0x97, 0xe3, 0x80, 0x8d, 0xe6, 0x89, 0x93, 0xe9, 0x80, 0xa0, 0xe5, 0x87 - , 0xba, 0xe4, 0xb8, 0x80, 0xe9, 0x96, 0x80, 0xe5, 0x85, 0xa8, 0xe6, 0x96, 0xb0, 0xe7, 0x9a, 0x84 - , 0xe7, 0xb5, 0xb1, 0xe8, 0xa8, 0x88, 0xe7, 0xa7, 0x91, 0xe5, 0xad, 0xb8, 0xef, 0xbc, 0x8c, 0xe7 - , 0xa8, 0xb1, 0xe4, 0xb9, 0x8b, 0xe7, 0x82, 0xba, 0xe2, 0x80, 0x9c, 0xe5, 0xbf, 0x83, 0xe7, 0x90 - , 0x86, 0xe5, 0x8f, 0xb2, 0xe5, 0xad, 0xb8, 0xe2, 0x80, 0x9d, 0xef, 0xbc, 0x8c, 0xe9, 0x80, 0x99 - , 0xe9, 0x96, 0x80, 0xe5, 0xad, 0xb8, 0xe5, 0x95, 0x8f, 0xe7, 0x94, 0xb1, 0xe6, 0x9b, 0xb8, 0xe4 - , 0xb8, 0xad, 0xe6, 0x95, 0xb0, 0xe5, 0xad, 0xb8, 0xe5, 0xae, 0xb6, 0xe5, 0x93, 0x88, 0xe9, 0x87 - , 0x8c, 0xc2, 0xb7, 0xe8, 0xac, 0x9d, 0xe9, 0xa0, 0x93, 0xe7, 0xaa, 0xae, 0xe7, 0x9b, 0xa1, 0xe7 - , 0x95, 0xa2, 0xe7, 0x94, 0x9f, 0xe4, 0xb9, 0x8b, 0xe5, 0x8a, 0x9b, 0xe5, 0x89, 0xb5, 0xe5, 0xbb - , 0xba, 0xef, 0xbc, 0x8c, 0xe6, 0xa0, 0xb9, 0xe6, 0x93, 0x9a, 0xe5, 0xa4, 0xa7, 0xe8, 0xa6, 0x8f - , 0xe6, 0xa8, 0xa1, 0xe7, 0x9a, 0x84, 0xe4, 0xba, 0xba, 0xe9, 0xa1, 0x9e, 0xe6, 0xb4, 0xbb, 0xe5 - , 0x8b, 0x95, 0xe6, 0x95, 0xb8, 0xe6, 0x93, 0x9a, 0xef, 0xbc, 0x8c, 0xe9, 0xa0, 0x90, 0xe6, 0xb8 - , 0xac, 0xe6, 0x9c, 0xaa, 0xe4, 0xbe, 0x86, 0xe8, 0xb5, 0xb0, 0xe5, 0x90, 0x91, 0xef, 0xbc, 0x8c - , 0xe8, 0xa6, 0x8f, 0xe6, 0xa8, 0xa1, 0xe4, 0xb8, 0x80, 0xe6, 0x97, 0xa6, 0xe5, 0xb0, 0x8f, 0xe6 - , 0x96, 0xbc, 0xe4, 0xb8, 0x80, 0xe9, 0xa1, 0x86, 0xe6, 0x98, 0x9f, 0xe7, 0x90, 0x83, 0xe6, 0x88 - , 0x96, 0xe6, 0x98, 0xaf, 0xe4, 0xb8, 0x80, 0xe5, 0xba, 0xa7, 0xe5, 0xb8, 0x9d, 0xe5, 0x9c, 0x8b - , 0xef, 0xbc, 0x8c, 0xe7, 0xb5, 0x90, 0xe6, 0x9e, 0x9c, 0xe5, 0xb0, 0xb1, 0xe6, 0x9c, 0x83, 0xe5 - , 0xa4, 0xb1, 0xe6, 0xba, 0x96, 0xe3, 0x80, 0x82, 0xe8, 0xac, 0x9d, 0xe9, 0xa0, 0x93, 0xe9, 0x81 - , 0x8b, 0xe7, 0x94, 0xa8, 0xe6, 0xad, 0xa4, 0xe4, 0xb8, 0x80, 0xe7, 0xa7, 0x91, 0xe5, 0xad, 0xb8 - , 0xef, 0xbc, 0x8c, 0xe9, 0xa0, 0x90, 0xe8, 0xa6, 0x8b, 0xe9, 0x8a, 0x80, 0xe6, 0xb2, 0xb3, 0xe5 - , 0xb8, 0x9d, 0xe5, 0x9c, 0x8b, 0xe7, 0x9a, 0x84, 0xe6, 0xae, 0x9e, 0xe8, 0x90, 0xbd, 0xef, 0xbc - , 0x8c, 0xe6, 0x95, 0xb4, 0xe7, 0x89, 0x87, 0xe9, 0x8a, 0x80, 0xe6, 0xb2, 0xb3, 0xe5, 0xb0, 0x87 - , 0xe5, 0x9b, 0xa0, 0xe6, 0xad, 0xa4, 0xe9, 0x80, 0xb2, 0xe5, 0x85, 0xa5, 0xe9, 0x95, 0xb7, 0xe9 - , 0x81, 0x94, 0xe4, 0xb8, 0x89, 0xe8, 0x90, 0xac, 0xe5, 0xb9, 0xb4, 0xe7, 0x9a, 0x84, 0xe9, 0xbb - , 0x91, 0xe6, 0x9a, 0x97, 0xe6, 0x99, 0x82, 0xe6, 0x9c, 0x9f, 0xef, 0xbc, 0x8c, 0xe7, 0x9b, 0xb4 - , 0xe5, 0x88, 0xb0, 0xe7, 0xac, 0xac, 0xe4, 0xba, 0x8c, 0xe5, 0xb8, 0x9d, 0xe5, 0x9c, 0x8b, 0xe5 - , 0xbb, 0xba, 0xe7, 0xab, 0x8b, 0xe3, 0x80, 0x82, 0x0a, 0x0a, 0xe6, 0x96, 0xbc, 0xe6, 0x98, 0xaf - , 0xe8, 0xac, 0x9d, 0xe9, 0xa0, 0x93, 0xe5, 0xbb, 0xba, 0xe7, 0xab, 0x8b, 0xe5, 0x85, 0xa9, 0xe5 - , 0xba, 0xa7, 0xe5, 0x9f, 0xba, 0xe5, 0x9c, 0xb0, 0xef, 0xbc, 0x8c, 0xe8, 0x97, 0x89, 0xe4, 0xbb - , 0xa5, 0xe7, 0xb8, 0xae, 0xe6, 0xb8, 0x9b, 0xe8, 0xa0, 0xbb, 0xe8, 0x8d, 0x92, 0xe6, 0x99, 0x82 - , 0xe6, 0x9c, 0x9f, 0xef, 0xbc, 0x8c, 0xe4, 0xb8, 0x80, 0xe5, 0xba, 0xa7, 0xe9, 0x81, 0xa0, 0xe5 - , 0x9c, 0xa8, 0xe9, 0x82, 0x8a, 0xe9, 0x99, 0xb2, 0xef, 0xbc, 0x8c, 0xe6, 0x98, 0xaf, 0xe8, 0x97 - , 0x9d, 0xe8, 0xa1, 0x93, 0xe8, 0x88, 0x87, 0xe7, 0xa7, 0x91, 0xe5, 0xad, 0xb8, 0xe7, 0x9a, 0x84 - , 0xe9, 0x81, 0xbf, 0xe9, 0xa2, 0xa8, 0xe6, 0xb8, 0xaf, 0xef, 0xbc, 0x8c, 0xe7, 0x9b, 0xb8, 0xe5 - , 0xb0, 0x8d, 0xe7, 0x9a, 0x84, 0xe5, 0x8f, 0xa6, 0xe4, 0xb8, 0x80, 0xe5, 0xba, 0xa7, 0xe5, 0x89 - , 0x87, 0xe5, 0x9c, 0xa8, 0xe2, 0x80, 0x9c, 0xe7, 0xbe, 0xa4, 0xe6, 0x98, 0x9f, 0xe7, 0x9a, 0x84 - , 0xe7, 0x9b, 0xa1, 0xe9, 0xa0, 0xad, 0xe2, 0x80, 0x9d, 0xe3, 0x80, 0x82, 0xe3, 0x80, 0x8c, 0xe5 - , 0x9f, 0xba, 0xe5, 0x9c, 0xb0, 0xe4, 0xb8, 0x89, 0xe9, 0x83, 0xa8, 0xe6, 0x9b, 0xb2, 0xe3, 0x80 - , 0x8d, 0xe7, 0x9a, 0x84, 0xe4, 0xb8, 0xbb, 0xe8, 0xa6, 0x81, 0xe7, 0x84, 0xa6, 0xe9, 0xbb, 0x9e - , 0xe5, 0xb0, 0xb1, 0xe5, 0x9c, 0xa8, 0xe7, 0xab, 0xaf, 0xe9, 0xbb, 0x9e, 0xe6, 0x98, 0x9f, 0xe4 - , 0xb8, 0x8a, 0xe7, 0x9a, 0x84, 0xe5, 0x9f, 0xba, 0xe5, 0x9c, 0xb0, 0xe3, 0x80, 0x82, 0xe7, 0xab - , 0xaf, 0xe9, 0xbb, 0x9e, 0xe6, 0x98, 0x9f, 0xe4, 0xb8, 0x8a, 0xe7, 0x9a, 0x84, 0xe5, 0xad, 0xb8 - , 0xe8, 0x80, 0x85, 0xe7, 0x82, 0xba, 0xe4, 0xba, 0x86, 0xe6, 0x90, 0xb6, 0xe5, 0x9c, 0xa8, 0xe8 - , 0xa1, 0xb0, 0xe9, 0x80, 0x80, 0xe6, 0x9c, 0x9f, 0xe4, 0xb9, 0x8b, 0xe5, 0x89, 0x8d, 0xef, 0xbc - , 0x8c, 0xe4, 0xbf, 0x9d, 0xe5, 0xad, 0x98, 0xe4, 0xba, 0xba, 0xe9, 0xa1, 0x9e, 0xe7, 0x89, 0xa9 - , 0xe7, 0x90, 0x86, 0xe7, 0xa7, 0x91, 0xe5, 0xad, 0xb8, 0xe7, 0x9a, 0x84, 0xe7, 0x9f, 0xa5, 0xe8 - , 0xad, 0x98, 0xef, 0xbc, 0x8c, 0xe5, 0x8a, 0xaa, 0xe5, 0x8a, 0x9b, 0xe7, 0xb7, 0xa8, 0xe8, 0xbc - , 0xaf, 0xe8, 0x91, 0x97, 0xe4, 0xb8, 0x80, 0xe9, 0x83, 0xa8, 0xe5, 0x85, 0xa8, 0xe6, 0x96, 0xb9 - , 0xe4, 0xbd, 0x8d, 0xe7, 0x9a, 0x84, 0xe3, 0x80, 0x8a, 0xe9, 0x93, 0xb6, 0xe6, 0xb2, 0xb3, 0xe7 - , 0x99, 0xbe, 0xe7, 0xa7, 0x91, 0xe5, 0x85, 0xa8, 0xe4, 0xb9, 0xa6, 0xe3, 0x80, 0x8b, 0xef, 0xbc - , 0x8c, 0xe5, 0xb0, 0x8d, 0xe8, 0xac, 0x9d, 0xe9, 0xa0, 0x93, 0xe7, 0x9c, 0x9f, 0xe6, 0xad, 0xa3 - , 0xe7, 0x9a, 0x84, 0xe6, 0x84, 0x8f, 0xe5, 0x9c, 0x96, 0xe6, 0xaf, 0xab, 0xe4, 0xb8, 0x8d, 0xe7 - , 0x9f, 0xa5, 0xe6, 0x83, 0x85, 0xef, 0xbc, 0x88, 0xe5, 0xa6, 0x82, 0xe6, 0x9e, 0x9c, 0xe4, 0xbb - , 0x96, 0xe5, 0x80, 0x91, 0xe7, 0x9f, 0xa5, 0xe9, 0x81, 0x93, 0xef, 0xbc, 0x8c, 0xe5, 0xb0, 0xb1 - , 0xe6, 0x9c, 0x83, 0xe7, 0x94, 0xa2, 0xe7, 0x94, 0x9f, 0xe7, 0x84, 0xa1, 0xe6, 0xb3, 0x95, 0xe6 - , 0x8e, 0xa7, 0xe5, 0x88, 0xb6, 0xe7, 0x9a, 0x84, 0xe8, 0xae, 0x8a, 0xe6, 0x95, 0xb8, 0xef, 0xbc - , 0x89, 0xe3, 0x80, 0x82, 0xe5, 0x9f, 0xba, 0xe5, 0x9c, 0xb0, 0xe7, 0x9a, 0x84, 0xe4, 0xbd, 0x8d - , 0xe7, 0xbd, 0xae, 0xe4, 0xb9, 0x9f, 0xe6, 0x98, 0xaf, 0xe5, 0x88, 0xbb, 0xe6, 0x84, 0x8f, 0xe9 - , 0x81, 0xb8, 0xe5, 0xae, 0x9a, 0xe7, 0x9a, 0x84, 0xef, 0xbc, 0x8c, 0xe5, 0x8d, 0x83, 0xe5, 0xb9 - , 0xb4, 0xe5, 0xbe, 0x8c, 0xe5, 0xb0, 0xb1, 0xe6, 0x98, 0xaf, 0xe7, 0xac, 0xac, 0xe4, 0xba, 0x8c - , 0xe5, 0xb8, 0x9d, 0xe5, 0x9c, 0x8b, 0xe7, 0x9a, 0x84, 0xe9, 0xa6, 0x96, 0xe9, 0x83, 0xbd, 0xef - , 0xbc, 0x88, 0xe4, 0xb8, 0xa6, 0xe9, 0x9d, 0x9e, 0xe4, 0xb8, 0x89, 0xe8, 0x90, 0xac, 0xe5, 0xb9 - , 0xb4, 0xe5, 0xbe, 0x8c, 0xe7, 0x9a, 0x84, 0xe9, 0x82, 0xa3, 0xe5, 0x80, 0x8b, 0xe5, 0xb8, 0x9d - , 0xe5, 0x9c, 0x8b, 0xef, 0xbc, 0x89, 0x0a - ] - - - -sample2_UTF16 :: EncodedString -sample2_UTF16 = EncodedString UTF16 $ recast array - where - array :: UArray Word16 - array = fromList - [ 0x0054, 0x0068, 0x0065, 0x0020, 0x0073, 0x0061, 0x006d, 0x0070 - , 0x006c, 0x0065, 0x0020, 0x0074, 0x0065, 0x0078, 0x0074, 0x0020 - , 0x0062, 0x0065, 0x006c, 0x006f, 0x0077, 0x0020, 0x0068, 0x0061 - , 0x0073, 0x0020, 0x0062, 0x0065, 0x0065, 0x006e, 0x0020, 0x0074 - , 0x0061, 0x006b, 0x0065, 0x006e, 0x0020, 0x0066, 0x0072, 0x006f - , 0x006d, 0x0020, 0x0057, 0x0069, 0x006b, 0x0069, 0x0070, 0x0065 - , 0x0064, 0x0069, 0x0061, 0x003a, 0x000a, 0x0068, 0x0074, 0x0074 - , 0x0070, 0x0073, 0x003a, 0x002f, 0x002f, 0x007a, 0x0068, 0x002e - , 0x0077, 0x0069, 0x006b, 0x0069, 0x0070, 0x0065, 0x0064, 0x0069 - , 0x0061, 0x002e, 0x006f, 0x0072, 0x0067, 0x002f, 0x0077, 0x0069 - , 0x006b, 0x0069, 0x002f, 0x0025, 0x0045, 0x0035, 0x0025, 0x0039 - , 0x0046, 0x0025, 0x0042, 0x0041, 0x0025, 0x0045, 0x0035, 0x0025 - , 0x0039, 0x0043, 0x0025, 0x0042, 0x0030, 0x0025, 0x0045, 0x0037 - , 0x0025, 0x0042, 0x0033, 0x0025, 0x0042, 0x0042, 0x0025, 0x0045 - , 0x0035, 0x0025, 0x0038, 0x0038, 0x0025, 0x0039, 0x0037, 0x000a - , 0x000a, 0x57fa, 0x5730, 0x7cfb, 0x5217, 0xff08, 0x0054, 0x0068 - , 0x0065, 0x0020, 0x0046, 0x006f, 0x0075, 0x006e, 0x0064, 0x0061 - , 0x0074, 0x0069, 0x006f, 0x006e, 0x0020, 0x0053, 0x0065, 0x0072 - , 0x0069, 0x0065, 0x0073, 0xff09, 0x662f, 0x4e00, 0x90e8, 0x7d93 - , 0x5178, 0x79d1, 0x5e7b, 0x5c0f, 0x8aaa, 0x7cfb, 0x5217, 0xff0c - , 0x5275, 0x4f5c, 0x6642, 0x9593, 0x6a6b, 0x8de8, 0x7f8e, 0x570b - , 0x4f5c, 0x5bb6, 0x4ee5, 0x6492, 0x00b7, 0x827e, 0x897f, 0x83ab - , 0x592b, 0x0034, 0x0039, 0x500b, 0x5beb, 0x4f5c, 0x5e74, 0x982d - , 0xff0c, 0x4e00, 0x5171, 0x0031, 0x0030, 0x518a, 0xff08, 0x5305 - , 0x62ec, 0x5225, 0x4eba, 0x7e8c, 0x5beb, 0x0033, 0x518a, 0xff09 - , 0xff0c, 0x5f7c, 0x6b64, 0x9593, 0x5287, 0x60c5, 0x7368, 0x7acb - , 0xff0c, 0x537b, 0x53c8, 0x7dca, 0x5bc6, 0x95dc, 0x806f, 0x3002 - , 0x300c, 0x57fa, 0x5730, 0x7cfb, 0x5217, 0x300d, 0x901a, 0x5e38 - , 0x4e5f, 0x5c07, 0x8655, 0x5728, 0x540c, 0x4e00, 0x67b6, 0x7a7a - , 0x5b87, 0x5b99, 0x7684, 0x300c, 0x6a5f, 0x5668, 0x4eba, 0x7cfb - , 0x5217, 0x300d, 0x548c, 0x300c, 0x9280, 0x6cb3, 0x5e1d, 0x570b - , 0x7cfb, 0x5217, 0x300d, 0x5305, 0x62ec, 0x9032, 0x4f86, 0xff0c - , 0x7e3d, 0x8a08, 0x8d77, 0x4f86, 0x6574, 0x500b, 0x300c, 0x5927 - , 0x57fa, 0x5730, 0x7cfb, 0x5217, 0x300d, 0x4f5c, 0x54c1, 0x5171 - , 0x6709, 0x0031, 0x0034, 0x518a, 0x9577, 0x7bc7, 0xff0c, 0x548c - , 0x6578, 0x4e0d, 0x6e05, 0x7684, 0x77ed, 0x7bc7, 0x5c0f, 0x8aaa - , 0xff0c, 0x53e6, 0x5916, 0x0036, 0x518a, 0x7531, 0x5176, 0x4ed6 - , 0x4f5c, 0x5bb6, 0x5728, 0x4ed6, 0x6b7b, 0x5f8c, 0x7e8c, 0x5beb - , 0x3002, 0x300c, 0x57fa, 0x5730, 0x7cfb, 0x5217, 0x300d, 0x5099 - , 0x53d7, 0x8b9a, 0x8b7d, 0xff0c, 0x0031, 0x0039, 0x0036, 0x0035 - , 0x5e74, 0x5f97, 0x904e, 0x96e8, 0x679c, 0x734e, 0x300c, 0x53f2 - , 0x4e0a, 0x6700, 0x4f73, 0x79d1, 0x5e7b, 0x5c0f, 0x8aaa, 0x7cfb - , 0x5217, 0x300d, 0x3002, 0x000a, 0x000a, 0x300a, 0x57fa, 0x5730 - , 0x300b, 0x539f, 0x672c, 0x662f, 0x4e00, 0x7cfb, 0x5217, 0x0038 - , 0x7bc7, 0x7684, 0x77ed, 0x7bc7, 0x5c0f, 0x8aaa, 0xff0c, 0x5728 - , 0x0031, 0x0039, 0x0034, 0x0032, 0x5e74, 0x0035, 0x6708, 0x5230 - , 0x0031, 0x0039, 0x0035, 0x0030, 0x5e74, 0x0031, 0x6708, 0x671f - , 0x9593, 0x767c, 0x8868, 0x65bc, 0x300a, 0x9a5a, 0x5947, 0x96dc - , 0x8a8c, 0x300b, 0xff08, 0x0041, 0x0073, 0x0074, 0x006f, 0x0075 - , 0x006e, 0x0064, 0x0069, 0x006e, 0x0067, 0x0020, 0x004d, 0x0061 - , 0x0067, 0x0061, 0x007a, 0x0069, 0x006e, 0x0065, 0xff09, 0x3002 - , 0x827e, 0x897f, 0x83ab, 0x592b, 0x5728, 0x81ea, 0x50b3, 0x4e2d - , 0x8868, 0x793a, 0xff0c, 0x300a, 0x57fa, 0x5730, 0x300b, 0x662f - , 0x5728, 0x4ed6, 0x62dc, 0x8a2a, 0x7de8, 0x8f2f, 0x7d04, 0x7ff0 - , 0x00b7, 0x574e, 0x8c9d, 0x723e, 0xff08, 0x004a, 0x006f, 0x0068 - , 0x006e, 0x0020, 0x0057, 0x002e, 0x0020, 0x0043, 0x0061, 0x006d - , 0x0070, 0x0062, 0x0065, 0x006c, 0x006c, 0xff09, 0x7684, 0x8def - , 0x4e0a, 0xff0c, 0x5929, 0x99ac, 0x884c, 0x7a7a, 0x806f, 0x60f3 - , 0x81ea, 0x611b, 0x5fb7, 0x83ef, 0x00b7, 0x5409, 0x672c, 0x7684 - , 0x300a, 0x7f85, 0x99ac, 0x5e1d, 0x570b, 0x8870, 0x4ea1, 0x53f2 - , 0x300b, 0xff0c, 0x4e4b, 0x5f8c, 0x8207, 0x574e, 0x8c9d, 0x723e - , 0x5169, 0x76f8, 0x8a0e, 0x8ad6, 0x4e0b, 0xff0c, 0x6574, 0x9ad4 - , 0x6982, 0x5ff5, 0x9042, 0x800c, 0x6210, 0x5f62, 0x005b, 0x0031 - , 0x005d, 0x3002, 0x000a, 0x000a, 0x300c, 0x57fa, 0x5730, 0x7cfb - , 0x5217, 0x300d, 0x7b2c, 0x4e00, 0x90e8, 0x300a, 0x57fa, 0x5730 - , 0x300b, 0x5305, 0x542b, 0x0034, 0x7bc7, 0x77ed, 0x7bc7, 0x5c0f - , 0x8aaa, 0xff0c, 0x5287, 0x60c5, 0x5404, 0x81ea, 0x7368, 0x7acb - , 0xff0c, 0x55ae, 0x884c, 0x672c, 0x767c, 0x884c, 0x65bc, 0x0031 - , 0x0039, 0x0035, 0x0031, 0x5e74, 0x3002, 0x5176, 0x5b83, 0x0034 - , 0x7bc7, 0x4e2d, 0x7bc7, 0x5c0f, 0x8aaa, 0x5169, 0x5169, 0x76f8 - , 0x5c0d, 0xff0c, 0x5206, 0x5225, 0x6536, 0x9304, 0x5728, 0x300a - , 0x57fa, 0x5730, 0x8207, 0x5e1d, 0x570b, 0x300b, 0x548c, 0x300a - , 0x7b2c, 0x4e8c, 0x57fa, 0x5730, 0x300b, 0xff0c, 0x6210, 0x70ba - , 0x540d, 0x805e, 0x9050, 0x9087, 0x7684, 0x300c, 0x57fa, 0x5730 - , 0x4e09, 0x90e8, 0x66f2, 0x300d, 0x3002, 0x0031, 0x0039, 0x0038 - , 0x0031, 0x5e74, 0xff0c, 0x300c, 0x57fa, 0x5730, 0x4e09, 0x90e8 - , 0x66f2, 0x300d, 0x65e9, 0x5df2, 0x662f, 0x4e16, 0x6240, 0x516c - , 0x8a8d, 0x6700, 0x91cd, 0x8981, 0x7684, 0x73fe, 0x4ee3, 0x79d1 - , 0x5e7b, 0x4f5c, 0x54c1, 0xff0c, 0x827e, 0x897f, 0x83ab, 0x592b - , 0x7d42, 0x65bc, 0x88ab, 0x51fa, 0x7248, 0x5546, 0x8aaa, 0x670d - , 0x7e8c, 0x5beb, 0x300c, 0x57fa, 0x5730, 0x7cfb, 0x5217, 0x300d - , 0x7b2c, 0x56db, 0x90e8, 0x300a, 0x57fa, 0x5730, 0x908a, 0x7de3 - , 0x300b, 0x005b, 0x0032, 0x005d, 0x3002, 0x63a5, 0x4e0b, 0x4f86 - , 0x4ed6, 0x53c8, 0x5beb, 0x4e86, 0x4e00, 0x90e8, 0x7e8c, 0x96c6 - , 0x300a, 0x57fa, 0x5730, 0x8207, 0x5730, 0x7403, 0x300b, 0xff0c - , 0x0035, 0x5e74, 0x5f8c, 0x767c, 0x8868, 0x5169, 0x90e8, 0x524d - , 0x50b3, 0x300a, 0x57fa, 0x5730, 0x524d, 0x594f, 0x300b, 0x548c - , 0x300a, 0x57fa, 0x5730, 0x7de0, 0x9020, 0x8005, 0x300b, 0xff0c - , 0x5728, 0x9019, 0x5e7e, 0x5e74, 0x4e2d, 0xff0c, 0x827e, 0x897f - , 0x83ab, 0x592b, 0x5c07, 0x300c, 0x57fa, 0x5730, 0x7cfb, 0x5217 - , 0x300d, 0x8207, 0x5176, 0x5b83, 0x7cfb, 0x5217, 0x76f8, 0x7d50 - , 0x5408, 0xff0c, 0x5c07, 0x6240, 0x6709, 0x7cfb, 0x5217, 0x4f5c - , 0x54c1, 0x540c, 0x7f6e, 0x65bc, 0x4e00, 0x500b, 0x300c, 0x57fa - , 0x5730, 0x5b87, 0x5b99, 0x300d, 0x67b6, 0x69cb, 0x4e0b, 0x3002 - , 0x000a, 0x000a, 0x827e, 0x897f, 0x83ab, 0x592b, 0x548c, 0x574e - , 0x8c9d, 0x723e, 0x806f, 0x624b, 0x70ba, 0x300c, 0x57fa, 0x5730 - , 0x7cfb, 0x5217, 0x300d, 0x6253, 0x9020, 0x51fa, 0x4e00, 0x9580 - , 0x5168, 0x65b0, 0x7684, 0x7d71, 0x8a08, 0x79d1, 0x5b78, 0xff0c - , 0x7a31, 0x4e4b, 0x70ba, 0x201c, 0x5fc3, 0x7406, 0x53f2, 0x5b78 - , 0x201d, 0xff0c, 0x9019, 0x9580, 0x5b78, 0x554f, 0x7531, 0x66f8 - , 0x4e2d, 0x6570, 0x5b78, 0x5bb6, 0x54c8, 0x91cc, 0x00b7, 0x8b1d - , 0x9813, 0x7aae, 0x76e1, 0x7562, 0x751f, 0x4e4b, 0x529b, 0x5275 - , 0x5efa, 0xff0c, 0x6839, 0x64da, 0x5927, 0x898f, 0x6a21, 0x7684 - , 0x4eba, 0x985e, 0x6d3b, 0x52d5, 0x6578, 0x64da, 0xff0c, 0x9810 - , 0x6e2c, 0x672a, 0x4f86, 0x8d70, 0x5411, 0xff0c, 0x898f, 0x6a21 - , 0x4e00, 0x65e6, 0x5c0f, 0x65bc, 0x4e00, 0x9846, 0x661f, 0x7403 - , 0x6216, 0x662f, 0x4e00, 0x5ea7, 0x5e1d, 0x570b, 0xff0c, 0x7d50 - , 0x679c, 0x5c31, 0x6703, 0x5931, 0x6e96, 0x3002, 0x8b1d, 0x9813 - , 0x904b, 0x7528, 0x6b64, 0x4e00, 0x79d1, 0x5b78, 0xff0c, 0x9810 - , 0x898b, 0x9280, 0x6cb3, 0x5e1d, 0x570b, 0x7684, 0x6b9e, 0x843d - , 0xff0c, 0x6574, 0x7247, 0x9280, 0x6cb3, 0x5c07, 0x56e0, 0x6b64 - , 0x9032, 0x5165, 0x9577, 0x9054, 0x4e09, 0x842c, 0x5e74, 0x7684 - , 0x9ed1, 0x6697, 0x6642, 0x671f, 0xff0c, 0x76f4, 0x5230, 0x7b2c - , 0x4e8c, 0x5e1d, 0x570b, 0x5efa, 0x7acb, 0x3002, 0x000a, 0x000a - , 0x65bc, 0x662f, 0x8b1d, 0x9813, 0x5efa, 0x7acb, 0x5169, 0x5ea7 - , 0x57fa, 0x5730, 0xff0c, 0x85c9, 0x4ee5, 0x7e2e, 0x6e1b, 0x883b - , 0x8352, 0x6642, 0x671f, 0xff0c, 0x4e00, 0x5ea7, 0x9060, 0x5728 - , 0x908a, 0x9672, 0xff0c, 0x662f, 0x85dd, 0x8853, 0x8207, 0x79d1 - , 0x5b78, 0x7684, 0x907f, 0x98a8, 0x6e2f, 0xff0c, 0x76f8, 0x5c0d - , 0x7684, 0x53e6, 0x4e00, 0x5ea7, 0x5247, 0x5728, 0x201c, 0x7fa4 - , 0x661f, 0x7684, 0x76e1, 0x982d, 0x201d, 0x3002, 0x300c, 0x57fa - , 0x5730, 0x4e09, 0x90e8, 0x66f2, 0x300d, 0x7684, 0x4e3b, 0x8981 - , 0x7126, 0x9ede, 0x5c31, 0x5728, 0x7aef, 0x9ede, 0x661f, 0x4e0a - , 0x7684, 0x57fa, 0x5730, 0x3002, 0x7aef, 0x9ede, 0x661f, 0x4e0a - , 0x7684, 0x5b78, 0x8005, 0x70ba, 0x4e86, 0x6436, 0x5728, 0x8870 - , 0x9000, 0x671f, 0x4e4b, 0x524d, 0xff0c, 0x4fdd, 0x5b58, 0x4eba - , 0x985e, 0x7269, 0x7406, 0x79d1, 0x5b78, 0x7684, 0x77e5, 0x8b58 - , 0xff0c, 0x52aa, 0x529b, 0x7de8, 0x8f2f, 0x8457, 0x4e00, 0x90e8 - , 0x5168, 0x65b9, 0x4f4d, 0x7684, 0x300a, 0x94f6, 0x6cb3, 0x767e - , 0x79d1, 0x5168, 0x4e66, 0x300b, 0xff0c, 0x5c0d, 0x8b1d, 0x9813 - , 0x771f, 0x6b63, 0x7684, 0x610f, 0x5716, 0x6beb, 0x4e0d, 0x77e5 - , 0x60c5, 0xff08, 0x5982, 0x679c, 0x4ed6, 0x5011, 0x77e5, 0x9053 - , 0xff0c, 0x5c31, 0x6703, 0x7522, 0x751f, 0x7121, 0x6cd5, 0x63a7 - , 0x5236, 0x7684, 0x8b8a, 0x6578, 0xff09, 0x3002, 0x57fa, 0x5730 - , 0x7684, 0x4f4d, 0x7f6e, 0x4e5f, 0x662f, 0x523b, 0x610f, 0x9078 - , 0x5b9a, 0x7684, 0xff0c, 0x5343, 0x5e74, 0x5f8c, 0x5c31, 0x662f - , 0x7b2c, 0x4e8c, 0x5e1d, 0x570b, 0x7684, 0x9996, 0x90fd, 0xff08 - , 0x4e26, 0x975e, 0x4e09, 0x842c, 0x5e74, 0x5f8c, 0x7684, 0x90a3 - , 0x500b, 0x5e1d, 0x570b, 0xff09, 0x000a - ] diff --git a/tests/Test/Foundation/Misc.hs b/tests/Test/Foundation/Misc.hs --- a/tests/Test/Foundation/Misc.hs +++ b/tests/Test/Foundation/Misc.hs @@ -7,11 +7,10 @@ ) where import Foundation -import Test.Tasty -import Test.Tasty.QuickCheck +import Foundation.Check import Foundation.Array.Internal (toHexadecimal) -import Test.Foundation.Collection (fromListP, toListP) +import Test.Checks.Property.Collection (fromListP) import qualified Foundation.UUID as UUID import Foundation.Parser @@ -31,13 +30,13 @@ where (q,r) = x `divMod` 16 -testHexadecimal = testGroup "hexadecimal" - [ testProperty "UArray(W8)" $ \l -> +testHexadecimal = Group "hexadecimal" + [ Property "UArray(W8)" $ \l -> toList (toHexadecimal (fromListP (Proxy :: Proxy (UArray Word8)) l)) == hex l ] -testTime = testGroup "Time" - [ testProperty "foundation_time_clock_gettime links properly" $ +testTime = Group "Time" + [ Property "foundation_time_clock_gettime links properly" $ $(let s :: String s = fromString "Hello" @@ -46,9 +45,9 @@ in [| b |]) ] -testUUID = testGroup "UUID" - [ testProperty "show" $ show UUID.nil === "00000000-0000-0000-0000-000000000000" - , testProperty "show-bin" $ fmap show (UUID.fromBinary (fromList [1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16])) === Just "100f0e0d-0c0b-0a09-0807-060504030201" - , testProperty "parser . show = id" $ \uuid -> +testUUID = Group "UUID" + [ Property "show" $ show UUID.nil === "00000000-0000-0000-0000-000000000000" + , Property "show-bin" $ fmap show (UUID.fromBinary (fromList [1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16])) === Just "100f0e0d-0c0b-0a09-0807-060504030201" + , Property "parser . show = id" $ \uuid -> (either (error . show) id $ parseOnly UUID.uuidParser (show uuid)) === uuid ] diff --git a/tests/Test/Foundation/Network/IPv4.hs b/tests/Test/Foundation/Network/IPv4.hs --- a/tests/Test/Foundation/Network/IPv4.hs +++ b/tests/Test/Foundation/Network/IPv4.hs @@ -6,32 +6,30 @@ import Foundation import Foundation.Network.IPv4 - -import Test.Tasty -import Test.Tasty.QuickCheck +import Foundation.Check import Test.Data.Network import Test.Foundation.Storable -- | test property equality for the given Collection -testEquality :: Gen IPv4 -> TestTree -testEquality genElement = testGroup "equality" - [ testProperty "x == x" $ forAll genElement (\x -> x === x) - , testProperty "x == y" $ forAll ((,) <$> genElement <*> genElement) $ +testEquality :: Gen IPv4 -> Test +testEquality genElement = Group "equality" + [ Property "x == x" $ forAll genElement (\x -> x === x) + , Property "x == y" $ forAll ((,) <$> genElement <*> genElement) $ \(x,y) -> (toTuple x == toTuple y) === (x == y) ] -- | test ordering -testOrdering :: Gen IPv4 -> TestTree -testOrdering genElement = testProperty "ordering" $ +testOrdering :: Gen IPv4 -> Test +testOrdering genElement = Property "ordering" $ forAll ((,) <$> genElement <*> genElement) $ \(x, y) -> (toTuple x `compare` toTuple y) === x `compare` y -testNetworkIPv4 :: TestTree -testNetworkIPv4 = testGroup "IPv4" - [ testProperty "toTuple . fromTuple == id" $ +testNetworkIPv4 :: Test +testNetworkIPv4 = Group "IPv4" + [ Property "toTuple . fromTuple == id" $ forAll genIPv4Tuple $ \x -> x === toTuple (fromTuple x) - , testProperty "toString . fromString == id" $ + , Property "toString . fromString == id" $ forAll genIPv4String $ \x -> x === toString (fromString $ toList x) , testEquality genIPv4 , testOrdering genIPv4 diff --git a/tests/Test/Foundation/Network/IPv6.hs b/tests/Test/Foundation/Network/IPv6.hs --- a/tests/Test/Foundation/Network/IPv6.hs +++ b/tests/Test/Foundation/Network/IPv6.hs @@ -5,51 +5,44 @@ ) where import Foundation +import Foundation.Check import Foundation.Network.IPv6 -import Test.Tasty -import Test.Tasty.QuickCheck -import Test.Tasty.HUnit - import Test.Data.Network import Test.Foundation.Storable -- | test property equality for the given Collection -testEquality :: Gen IPv6 -> TestTree -testEquality genElement = testGroup "equality" - [ testProperty "x == x" $ forAll genElement (\x -> x === x) - , testProperty "x == y" $ forAll ((,) <$> genElement <*> genElement) $ +testEquality :: Gen IPv6 -> Test +testEquality genElement = Group "equality" + [ Property "x == x" $ forAll genElement (\x -> x === x) + , Property "x == y" $ forAll ((,) <$> genElement <*> genElement) $ \(x,y) -> (toTuple x == toTuple y) === (x == y) ] -- | test ordering -testOrdering :: Gen IPv6 -> TestTree -testOrdering genElement = testProperty "ordering" $ +testOrdering :: Gen IPv6 -> Test +testOrdering genElement = Property "ordering" $ forAll ((,) <$> genElement <*> genElement) $ \(x, y) -> (toTuple x `compare` toTuple y) === x `compare` y -testNetworkIPv6 :: TestTree -testNetworkIPv6 = testGroup "IPv6" - [ testProperty "toTuple . fromTuple == id" $ +testNetworkIPv6 :: Test +testNetworkIPv6 = Group "IPv6" + [ Property "toTuple . fromTuple == id" $ forAll genIPv6Tuple $ \x -> x === toTuple (fromTuple x) - , testProperty "toString . fromString == id" $ + , Property "toString . fromString == id" $ forAll genIPv6String $ \x -> x === toString (fromString $ toList x) , testEquality genIPv6 , testOrdering genIPv6 , testPropertyStorable "Storable" (Proxy :: Proxy IPv6) , testPropertyStorableFixed "StorableFixed" (Proxy :: Proxy IPv6) - , testGroup "parse" - [ testCase "::" $ assert $ fromTuple (0,0,0,0,0,0,0,0) == fromString "::" - , testCase "::1" $ assert $ fromTuple (0,0,0,0,0,0,0,1) == fromString "::1" - , testCase "2001:DB8::8:800:200C:417A" $ assert $ fromTuple (0x2001,0xDB8,0,0,0x8,0x800,0x200c,0x417a) == fromString "2001:DB8::8:800:200C:417A" - , testCase "FF01::101" $ assert $ fromTuple (0xff01,0,0,0,0,0,0,0x101) == fromString "FF01::101" - , testCase "::13.1.68.3" $ assertEq (fromTuple (0,0,0,0,0,0,0x0d01,0x4403)) (fromString "::13.1.68.3") - , testCase "::FFFF:129.144.52.38" $ assertEq (fromTuple (0,0,0,0,0,0xffff,0x8190,0x3426)) (fromString "::FFFF:129.144.52.38") - , testCase "0::FFFF:129.144.52.38" $ assertEq (fromTuple (0,0,0,0,0,0xffff,0x8190,0x3426)) (fromString "0::FFFF:129.144.52.38") - , testCase "0:0::FFFF:129.144.52.38" $ assertEq (fromTuple (0,0,0,0,0,0xffff,0x8190,0x3426)) (fromString "0:0::FFFF:129.144.52.38") + , Group "parse" + [ Property "::" $ fromTuple (0,0,0,0,0,0,0,0) === fromString "::" + , Property "::1" $ fromTuple (0,0,0,0,0,0,0,1) === fromString "::1" + , Property "2001:DB8::8:800:200C:417A" $ fromTuple (0x2001,0xDB8,0,0,0x8,0x800,0x200c,0x417a) === fromString "2001:DB8::8:800:200C:417A" + , Property "FF01::101" $ fromTuple (0xff01,0,0,0,0,0,0,0x101) === fromString "FF01::101" + , Property "::13.1.68.3" $ (fromTuple (0,0,0,0,0,0,0x0d01,0x4403)) === (fromString "::13.1.68.3") + , Property "::FFFF:129.144.52.38" $ (fromTuple (0,0,0,0,0,0xffff,0x8190,0x3426)) === (fromString "::FFFF:129.144.52.38") + , Property "0::FFFF:129.144.52.38" $ (fromTuple (0,0,0,0,0,0xffff,0x8190,0x3426)) === (fromString "0::FFFF:129.144.52.38") + , Property "0:0::FFFF:129.144.52.38" $ (fromTuple (0,0,0,0,0,0xffff,0x8190,0x3426)) === (fromString "0:0::FFFF:129.144.52.38") ] ] - -assertEq a b - | a /= b = error $ show a <> " /= " <> show b - | otherwise = return () diff --git a/tests/Test/Foundation/Number.hs b/tests/Test/Foundation/Number.hs --- a/tests/Test/Foundation/Number.hs +++ b/tests/Test/Foundation/Number.hs @@ -9,90 +9,81 @@ , testNumberRefs ) where -import Imports import Foundation -import Foundation.Numerical -- hiding (Positive) +import Foundation.Check import qualified Prelude -#if !(MIN_VERSION_base(4,8,0)) -instance Arbitrary Natural where - arbitrary = fromInteger <$> (arbitrary `suchThat` \i -> i >= 0) -#endif - -testAddNullElementRight :: (Show a, Eq a, Additive a, Arbitrary a) - => Proxy a -> a -> Property -testAddNullElementRight _ a = a + azero === a -testAddNullElementLeft :: (Show a, Eq a, Additive a, Arbitrary a) - => Proxy a -> a -> Property -testAddNullElementLeft _ a = azero + a === a -testAddCommutatif :: (Show a, Eq a, Additive a, Arbitrary a) - => Proxy a -> a -> a -> Property -testAddCommutatif _ a b = a + b === b + a - -testMultiplyByIdentityRight :: (Show a, Eq a, Multiplicative a, Arbitrary a) - => Proxy a -> a -> Property -testMultiplyByIdentityRight _ a = a * midentity === a -testMultiplyByIdentityLeft :: (Show a, Eq a, Multiplicative a, Arbitrary a) - => Proxy a -> a -> Property -testMultiplyByIdentityLeft _ a = midentity * a === a - -testDivMulPlusRest :: (Show a, Eq a, Integral a, IDivisible a, Arbitrary a) - => Proxy a -> a -> (NonZero a) -> Property -testDivMulPlusRest _ a (NonZero b) = - a === (a `div` b) * b + (a `mod` b) - -testAdditive :: (Show a, Eq a, Additive a, Arbitrary a) - => Proxy a -> TestTree -testAdditive proxy = testGroup "Additive" - [ testProperty "a + azero == a" (testAddNullElementRight proxy) - , testProperty "azero + a == a" (testAddNullElementLeft proxy) - , testProperty "a + b == b + a" (testAddCommutatif proxy) +testIntegral :: forall a . (Arbitrary a, Show a, IsIntegral a, Integral a, Typeable a) + => Proxy a -> Test +testIntegral _ = Group "Integral" + [ Property "FromIntegral(Integer(a)) == a" $ \(a :: a) -> fromInteger (toInteger a) === a ] -testMultiplicative :: (Show a, Eq a, Multiplicative a, Arbitrary a) - => Proxy a -> TestTree -testMultiplicative proxy = testGroup "Multiplicative" - [ testProperty "a * midentity == a" (testMultiplyByIdentityRight proxy) - , testProperty "midentity * a == a" (testMultiplyByIdentityLeft proxy) +testEqOrd :: forall a . (Arbitrary a, Show a, Eq a, Ord a, IsIntegral a, Typeable a) + => Proxy a -> Test +testEqOrd _ = Group "Property" + [ Property "Eq" $ \(a :: a) -> a === a + -- , Property "Ne" $ \(a :: a) (b :: a) -> if a === w + , Property "Show" $ \(a :: a) -> show a === show (toInteger a) + , Property "Ord" $ \(a :: a) (b :: a) -> compare a b === (compare `on` toInteger) a b + , Property "<" $ \(a :: a) (b :: a) -> case compare a b of + LT -> propertyCompare "<" (<) a b + GT -> propertyCompare "<" (<) b a + EQ -> propertyCompare "not <" ((not .) . (<)) a b `propertyAnd` + propertyCompare "not <" ((not .) . (<)) b a ] -testDividible :: (Show a, Eq a, IsIntegral a, IDivisible a, Arbitrary a) - => Proxy a -> TestTree -testDividible proxy = testGroup "Divisible" - [ testProperty "(x `div` y) * y + (x `mod` y) == x" (testDivMulPlusRest proxy) +testAdditive :: forall a . (Show a, Eq a, Additive a, Arbitrary a, Typeable a) + => Proxy a -> Test +testAdditive _ = Group "Additive" + [ Property "a + azero == a" $ \(a :: a) -> a + azero === a + , Property "azero + a == a" $ \(a :: a) -> azero + a === a + , Property "a + b == b + a" $ \(a :: a) (b :: a) -> a + b === b + a ] -withP3 :: (Show a, Eq a, IsIntegral a, Additive a, Multiplicative a, Subtractive a, Difference a ~ a, Arbitrary a) - => Proxy a -> (a -> a -> a -> Property) -> (a -> a -> a -> Property) -withP3 _ f = f +testMultiplicative :: forall a . (Show a, Eq a, IsIntegral a, Integral a, Multiplicative a, Arbitrary a, Typeable a) + => Proxy a -> Test +testMultiplicative _ = Group "Multiplicative" + [ Property "a * 1 == a" $ \(a :: a) -> a * midentity === a + , Property "1 * a == a" $ \(a :: a) -> midentity * a === a + , Property "multiplication commutative" $ \(a :: a) (b :: a) -> a * b == b * a + , Property "a * b == Integer(a) * Integer(b)" $ \(a :: a) (b :: a) -> a * b == fromInteger (toInteger a * toInteger b) + ] -withP3Pos2 :: (Show a, Eq a, IsIntegral a, Difference a ~ a, Arbitrary a) - => Proxy a -> (a -> Natural -> a -> Property) -> (a -> Natural -> a -> Property) -withP3Pos2 _ f = f +testDividible :: forall a . (Show a, Eq a, IsIntegral a, IDivisible a, Arbitrary a, Typeable a) + => Proxy a -> Test +testDividible _ = Group "Divisible" + [ Property "(x `div` y) * y + (x `mod` y) == x" $ \(a :: a) b -> + if b == 0 then True === True + else a === (a `div` b) * b + (a `mod` b) + ] -testOperatorPrecedence :: (Show a, Eq a, Prelude.Num a, IsIntegral a, Additive a, Subtractive a, Multiplicative a, Difference a ~ a, Arbitrary a) => Proxy a -> TestTree -testOperatorPrecedence proxy = testGroup "Precedence" - [ testProperty "+ and - (1)" $ withP3 proxy $ \a b c -> (a + b - c) === ((a + b) - c) - , testProperty "+ and - (2)" $ withP3 proxy $ \a b c -> (a - b + c) === ((a - b) + c) - , testProperty "+ and * (1)" $ withP3 proxy $ \a b c -> (a + b * c) === (a + (b * c)) - , testProperty "+ and * (2)" $ withP3 proxy $ \a b c -> (a * b + c) === ((a * b) + c) - , testProperty "- and * (1)" $ withP3 proxy $ \a b c -> (a - b * c) === (a - (b * c)) - , testProperty "- and * (2)" $ withP3 proxy $ \a b c -> (a * b - c) === ((a * b) - c) - , testProperty "* and ^ (1)" $ withP3Pos2 proxy $ \a b c -> (a ^ b * c) === ((a ^ b) * c) - , testProperty "* and ^ (2)" $ withP3Pos2 proxy $ \a c b -> (a * b ^ c) === (a * (b ^ c)) +testOperatorPrecedence :: forall a . (Show a, Eq a, Prelude.Num a, IsIntegral a, Additive a, Subtractive a, Multiplicative a, Difference a ~ a, Arbitrary a, Typeable a) + => Proxy a -> Test +testOperatorPrecedence _ = Group "Precedence" + [ Property "+ and - (1)" $ \(a :: a) (b :: a) (c :: a) -> (a + b - c) === ((a + b) - c) + , Property "+ and - (2)" $ \(a :: a) (b :: a) (c :: a) -> (a - b + c) === ((a - b) + c) + , Property "+ and * (1)" $ \(a :: a) (b :: a) (c :: a) -> (a + b * c) === (a + (b * c)) + , Property "+ and * (2)" $ \(a :: a) (b :: a) (c :: a) -> (a * b + c) === ((a * b) + c) + , Property "- and * (1)" $ \(a :: a) (b :: a) (c :: a) -> (a - b * c) === (a - (b * c)) + , Property "- and * (2)" $ \(a :: a) (b :: a) (c :: a) -> (a * b - c) === ((a * b) - c) + , Property "* and ^ (1)" $ \(a :: a) (b :: Natural) (c :: a) -> (a ^ b * c) === ((a ^ b) * c) + , Property "* and ^ (2)" $ \(a :: a) (c :: Natural) (b :: a) -> (a * b ^ c) === (a * (b ^ c)) ] -testNumber :: (Show a, Eq a, Prelude.Num a, IsIntegral a, Additive a, Multiplicative a, Subtractive a, Difference a ~ a, IDivisible a, Arbitrary a) - => String -> Proxy a -> TestTree -testNumber name proxy = testGroup name - [ testAdditive proxy +testNumber :: (Show a, Eq a, Prelude.Num a, IsIntegral a, Additive a, Multiplicative a, Subtractive a, Difference a ~ a, IDivisible a, Arbitrary a, Typeable a) + => String -> Proxy a -> Test +testNumber name proxy = Group name + [ testIntegral proxy + , testEqOrd proxy + , testAdditive proxy , testMultiplicative proxy , testDividible proxy , testOperatorPrecedence proxy ] -testNumberRefs :: [TestTree] +testNumberRefs :: [Test] testNumberRefs = [ testNumber "Int" (Proxy :: Proxy Int) , testNumber "Int8" (Proxy :: Proxy Int8) @@ -105,4 +96,6 @@ , testNumber "Word16" (Proxy :: Proxy Word16) , testNumber "Word32" (Proxy :: Proxy Word32) , testNumber "Word64" (Proxy :: Proxy Word64) + , testNumber "Word128" (Proxy :: Proxy Word128) + , testNumber "Word256" (Proxy :: Proxy Word256) ] diff --git a/tests/Test/Foundation/Parser.hs b/tests/Test/Foundation/Parser.hs deleted file mode 100644 --- a/tests/Test/Foundation/Parser.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Test.Foundation.Parser - ( testParsers - ) where - -import Foundation -import Foundation.Parser -import qualified Foundation.Parser as P - -import Test.Tasty -import Test.Tasty.HUnit - -data TestCaseRes a - = TestCaseOk String a - | TestCaseMore String (TestCaseRes a) - | TestCaseFail - deriving (Show) - -parseTestCase :: (Show a, Eq a) - => String - -> Parser String a - -> TestCaseRes a - -> Assertion -parseTestCase buff parser = check (parse parser buff) -check :: (Show a, Eq a) => Result String a -> TestCaseRes a -> Assertion -check r e = case (r, e) of - (ParseOk remain a, TestCaseOk eRemain ea) -> do - assertEqual "remaining buffer" eRemain remain - assertEqual "returned value" ea a - (ParseMore fr, TestCaseMore mb res') -> check (fr mb) res' - (ParseFailed _, TestCaseFail) -> return () - _ -> assertFailure $ toList $ - "parseTestCase failed: " - <> "expected: " <> show e <> " " - <> "buf received: " <> show r - --- Some custom test cases -parseTestCases :: TestTree -parseTestCases = testGroup "units" - [ testGroup "element" - [ testCase "Ok" $ parseTestCase "a" (element 'a') (TestCaseOk "" ()) - , testCase "Fail" $ parseTestCase "b" (element 'a') TestCaseFail - , testCase "MoreOk" $ parseTestCase "a" (element 'a' >> element 'a') (TestCaseMore "a" (TestCaseOk "" ())) - , testCase "MoreFail" $ parseTestCase "a" (element 'a' >> element 'a') (TestCaseMore mempty TestCaseFail) - ] - , testGroup "elements" - [ testCase "Ok" $ parseTestCase "abc" (elements "ab") (TestCaseOk "c" ()) - , testCase "Fail" $ parseTestCase "ac" (elements "ab") TestCaseFail - , testCase "MoreOk" $ parseTestCase "a" (elements "abc") (TestCaseMore "bc" (TestCaseOk "" ())) - , testCase "MoreMoreOk" $ parseTestCase "a" (elements "abc") (TestCaseMore "b" $ TestCaseMore "c" (TestCaseOk "" ())) - , testCase "MoreMoreFail" $ parseTestCase "a" (elements "abc") (TestCaseMore "b" $ TestCaseMore mempty TestCaseFail) - ] - , testGroup "anyElement" - [ testCase "OK" $ parseTestCase "a" anyElement (TestCaseOk "" 'a') - , testCase "OkRemains" $ parseTestCase "abc" anyElement (TestCaseOk "bc" 'a') - , testCase "MoreOk" $ parseTestCase "a" (anyElement *> anyElement) $ TestCaseMore "abc" (TestCaseOk "bc" 'a') - , testCase "MoreFail" $ parseTestCase "a" (anyElement <* anyElement) $ TestCaseMore mempty TestCaseFail - ] - , testGroup "take" - [ testCase "OK" $ parseTestCase "a" (P.take 1) (TestCaseOk "" "a") - , testCase "OkRemains" $ parseTestCase "abc" (P.take 2) (TestCaseOk "c" "ab") - , testCase "MoreOk" $ parseTestCase "a" (P.take 2) $ TestCaseMore "bc" (TestCaseOk "c" "ab") - , testCase "MoreFail" $ parseTestCase "a" (P.take 2) $ TestCaseMore mempty TestCaseFail - ] - , testGroup "takeWhile" - [ testCase "OK" $ parseTestCase "a " (P.takeWhile (' ' /=)) (TestCaseOk " " "a") - , testCase "OkRemains" $ parseTestCase "ab bc" (P.takeWhile (' ' /=)) (TestCaseOk " bc" "ab") - , testCase "MoreOk" $ parseTestCase "ab" (P.takeWhile (' ' /=)) $ TestCaseMore "cd " (TestCaseOk " " "abcd") - , testCase "MoreEmptyOK" $ parseTestCase "aa" (P.takeWhile (' ' /=)) $ TestCaseMore mempty (TestCaseOk "" "aa") - ] - , testGroup "takeAll" - [ testCase "OK" $ parseTestCase "abc" takeAll (TestCaseMore mempty $ TestCaseOk "" "abc") - ] - , testGroup "skip" - [ testCase "OK" $ parseTestCase "a" (skip 1) (TestCaseOk "" ()) - , testCase "OkRemains" $ parseTestCase "abc" (skip 2) (TestCaseOk "c" ()) - , testCase "MoreOk" $ parseTestCase "a" (skip 2) $ TestCaseMore "bc" (TestCaseOk "c" ()) - , testCase "MoreFail" $ parseTestCase "a" (skip 2) $ TestCaseMore mempty TestCaseFail - ] - , testGroup "skipWhile" - [ testCase "OK" $ parseTestCase "a " (skipWhile (' ' /=)) (TestCaseOk " " ()) - , testCase "OkRemains" $ parseTestCase "ab bc" (skipWhile (' ' /=)) (TestCaseOk " bc" ()) - , testCase "MoreOk" $ parseTestCase "ab" (skipWhile (' ' /=)) $ TestCaseMore "cd " (TestCaseOk " " ()) - , testCase "MoreEmptyOk" $ parseTestCase "aa" (skipWhile (' ' /=)) $ TestCaseMore mempty (TestCaseOk "" ()) - ] - , testGroup "skipAll" - [ testCase "OK" $ parseTestCase "abc" skipAll (TestCaseMore mempty $ TestCaseOk "" ()) - ] - , testGroup "optional" - [ testCase "Nothing" $ parseTestCase "aaa" (optional $ elements "bbb") (TestCaseOk "aaa" Nothing) - , testCase "Just" $ parseTestCase "aaa" (optional $ elements "a") (TestCaseOk "aa" (Just ())) - ] - , testGroup "many" - [ testCase "many elements" $ parseTestCase "101010\0" - (many ((element '1' >> pure True) <|> (element '0' >> pure False) ) ) - (TestCaseOk "\0" [True, False, True, False, True, False]) - ] - , testGroup "parseOnly" - [ testCase "takeWhile" $ case parseOnly (P.takeWhile (' ' /=)) ("abc" :: [Char]) of - Right "abc" -> return () - _ -> error "failed" - ] - ] - -testParsers :: TestTree -testParsers = testGroup "Parsers" - [ parseTestCases - ] diff --git a/tests/Test/Foundation/Primitive/BlockN.hs b/tests/Test/Foundation/Primitive/BlockN.hs --- a/tests/Test/Foundation/Primitive/BlockN.hs +++ b/tests/Test/Foundation/Primitive/BlockN.hs @@ -8,46 +8,44 @@ ( testBlockN ) where -import Imports import Data.Proxy (Proxy(..)) import Foundation hiding (singleton, replicate, cons, uncons, elem) -import Foundation.Primitive.Nat -import qualified Foundation.Primitive.Block as B -import Foundation.Primitive.BlockN +import Basement.Nat +import qualified Basement.Block as B +import Basement.BlockN +import Basement.From +import Foundation.Check -testBlockN = testGroup "BlockN" +testBlockN = Group "BlockN" [ testWithDifferentN - , testCase "singleton" $ assertEq' (B.singleton (1 :: Int)) (toBlock (singleton 1)) + , Property "singleton" $ B.singleton (1 :: Int) === toBlock (singleton 1) ] - testWithDifferentN = - testGroup "Multiple n" $ do + Group "Multiple n" $ do Foo n <- ns [testBlock n] -testBlock :: forall n . (KnownNat n, NatWithinBound Int n) => Proxy n -> TestTree +testBlock :: forall n . (KnownNat n, NatWithinBound (CountOf Int) n) => Proxy n -> Test testBlock nProxy = - testGroup ("n = " <> show size) - [ testCase "to/from block" $ assertEq' block (toBlock blockN) - , testCase "replicate" $ assertEq' (B.replicate (CountOf size) (7 :: Int)) (toBlock (rep 7)) - , testCase "length . cons" $ assertEq' (B.length (toBlock (cons 42 blockN))) (CountOf (size+1)) - , testCase "elem" $ assertEq' (size == 0 || size `elem` blockN) True + Group ("n = " <> show size) + [ Property "to/from block" $ block === (toBlock blockN) + , Property "replicate" $ B.replicate size (7 :: Int) === toBlock (rep 7) + , Property "length . cons" $ B.length (toBlock (cons 42 blockN)) === (size+1) + , Property "elem" $ size == 0 || from size `elem` blockN ] where rep :: Int -> BlockN n Int rep = replicate - size = natValInt nProxy + size = natValCountOf nProxy block = createBlockSized size Just blockN = toBlockN block :: Maybe (BlockN n Int) -createBlockSized :: Int -> B.Block Int -createBlockSized n = - B.create (CountOf n) (const n) - +createBlockSized :: CountOf Int -> B.Block Int +createBlockSized n@(CountOf n') = B.create n (const n') -data Foo = forall a . (KnownNat a, NatWithinBound Int a) => Foo (Proxy a) +data Foo = forall a . (KnownNat a, NatWithinBound (CountOf Int) a) => Foo (Proxy a) ns = [ Foo (Proxy :: Proxy 0) diff --git a/tests/Test/Foundation/Storable.hs b/tests/Test/Foundation/Storable.hs --- a/tests/Test/Foundation/Storable.hs +++ b/tests/Test/Foundation/Storable.hs @@ -11,18 +11,15 @@ import Foundation import Foundation.Class.Storable import Foundation.Primitive +import Foundation.Check import qualified Foreign.Storable import qualified Foreign.Marshal.Alloc import qualified Foreign.Marshal.Array -import Test.Tasty -import Test.Tasty.QuickCheck -import Test.QuickCheck.Monadic - -testForeignStorableRefs :: TestTree -testForeignStorableRefs = testGroup "Storable" - [ testGroup "Storable" +testForeignStorableRefs :: Test +testForeignStorableRefs = Group "Storable" + [ Group "Storable" [ testPropertyStorable "Word8" (Proxy :: Proxy Word8) , testPropertyStorable "Word16" (Proxy :: Proxy Word16) , testPropertyStorable "Word32" (Proxy :: Proxy Word32) @@ -35,7 +32,7 @@ , testPropertyStorable "Double" (Proxy :: Proxy Double) , testPropertyStorable "Float" (Proxy :: Proxy Float) ] - , testGroup "StorableFixed" + , Group "StorableFixed" [ testPropertyStorableFixed "Word8" (Proxy :: Proxy Word8) , testPropertyStorableFixed "Word16" (Proxy :: Proxy Word16) , testPropertyStorableFixed "Word32" (Proxy :: Proxy Word32) @@ -48,108 +45,102 @@ , testPropertyStorableFixed "Double" (Proxy :: Proxy Double) , testPropertyStorableFixed "Float" (Proxy :: Proxy Float) ] - , testGroup "Endianness" + , Group "Endianness" [ testPropertyBE "Word16" (Proxy :: Proxy Word16) , testPropertyBE "Word32" (Proxy :: Proxy Word32) , testPropertyBE "Word64" (Proxy :: Proxy Word64) ] ] -testPropertyBE :: (ByteSwap a, StorableFixed a, Arbitrary a, Eq a, Show a) - => LString +testPropertyBE :: forall a . (ByteSwap a, StorableFixed a, Arbitrary a, Eq a, Show a, Typeable a) + => String -> Proxy a - -> TestTree -testPropertyBE name p = testGroup name - [ testProperty "fromBE . toBE == id" $ withProxy p $ \a -> - fromBE (toBE a) === a - , testProperty "fromLE . toLE == id" $ withProxy p $ \a -> - fromLE (toLE a) === a + -> Test +testPropertyBE name p = Group name + [ Property "fromBE . toBE == id" $ \(a :: a) -> fromBE (toBE a) === a + , Property "fromLE . toLE == id" $ \(a :: a) -> fromLE (toLE a) === a ] - where - withProxy :: (ByteSwap a, StorableFixed a, Arbitrary a, Show a, Eq a) - => Proxy a -> (a -> Property) -> (a -> Property) - withProxy _ f = f testPropertyStorable :: (Storable a, Foreign.Storable.Storable a, Arbitrary a, Eq a, Show a) - => LString + => String -> Proxy a - -> TestTree -testPropertyStorable name p = testGroup name - [ testProperty "peek" $ testPropertyStorablePeek p - , testProperty "poke" $ testPropertyStorablePoke p + -> Test +testPropertyStorable name p = Group name + [ -- testPropertyStorablePeek p + -- , testPropertyStorablePoke p ] -testPropertyStorableFixed :: (StorableFixed a, Foreign.Storable.Storable a, Arbitrary a, Eq a, Show a) - => LString +testPropertyStorableFixed :: forall a . (StorableFixed a, Foreign.Storable.Storable a, Arbitrary a, Eq a, Show a) + => String -> Proxy a - -> TestTree -testPropertyStorableFixed name p = testGroup name - [ testProperty "size" $ withProxy p $ \a -> size p === (CountOf $ Foreign.Storable.sizeOf a) - , testProperty "alignment" $ withProxy p $ \a -> alignment p === (CountOf $ Foreign.Storable.alignment a) - , testProperty "peekOff" $ testPropertyStorableFixedPeekOff p - , testProperty "pokeOff" $ testPropertyStorableFixedPokeOff p + -> Test +testPropertyStorableFixed name p = Group name + [ Property "size" $ \(a :: a) -> size p === (CountOf $ Foreign.Storable.sizeOf a) + , Property "alignment" $ \(a :: a) -> alignment p === (CountOf $ Foreign.Storable.alignment a) + --, testPropertyStorableFixedPeekOff p + --, testPropertyStorableFixedPokeOff p ] - where - withProxy :: (Arbitrary a, Storable a, Show a, Eq a, Foreign.Storable.Storable a) - => Proxy a -> (a -> Property) -> (a -> Property) - withProxy _ f = f testPropertyStorablePeek :: (Storable a, Foreign.Storable.Storable a, Arbitrary a, Eq a, Show a) => Proxy a -> a - -> Property -testPropertyStorablePeek _ v = monadicIO $ do - v' <- run $ Foreign.Marshal.Alloc.alloca $ \ptr -> do + -> Test +testPropertyStorablePeek _ v = CheckPlan "storable-peek" $ do + v' <- pick "alloca" $ Foreign.Marshal.Alloc.alloca $ \ptr -> do Foreign.Storable.poke ptr v peek ptr - assertEq v v' + validate "equal" $ v == v' testPropertyStorablePoke :: (Storable a, Foreign.Storable.Storable a, Arbitrary a, Eq a, Show a) => Proxy a -> a - -> Property -testPropertyStorablePoke _ v = monadicIO $ do - v' <- run $ Foreign.Marshal.Alloc.alloca $ \ptr -> do + -> Test +testPropertyStorablePoke _ v = CheckPlan "storable-poke" $ do + v' <- pick "alloca" $ Foreign.Marshal.Alloc.alloca $ \ptr -> do poke ptr v Foreign.Storable.peek ptr - assertEq v v' + validate "equal" $ v == v' +{- assertEq a b | a == b = assert True | otherwise = do run $ putStrLn $ show a <> " /= " <> show b assert False + -} data SomeWhereInArray a = SomeWhereInArray a Int Int deriving (Show, Eq) instance (StorableFixed a, Arbitrary a) => Arbitrary (SomeWhereInArray a) where arbitrary = do a <- arbitrary - let p = toProxy a - (CountOf minsz) = size p + (alignment p - size p) - sz <- choose (minsz, 512) - o <- choose (0, sz - minsz) + let p = Proxy :: Proxy a + Just (CountOf minsz) = (size p + alignment p - size p) + let sz = minsz + 1 + let o = sz - minsz + --sz <- choose (minsz, 512) + --o <- choose (0, sz - minsz) return $ SomeWhereInArray a sz o - where - toProxy :: a -> Proxy a - toProxy _ = Proxy +{- testPropertyStorableFixedPeekOff :: (StorableFixed a, Foreign.Storable.Storable a, Arbitrary a, Eq a, Show a) => Proxy a -> SomeWhereInArray a - -> Property -testPropertyStorableFixedPeekOff _ (SomeWhereInArray v sz off) = monadicIO $ do - v' <- run $ Foreign.Marshal.Array.allocaArray sz $ \ptr -> do + -> Test +testPropertyStorableFixedPeekOff = CheckPlan "storable-fixed-peek-off" $ do + (SomeWhereInArray v sz off) <- pick "x" arbitrary + v' <- pick "alloca" $ Foreign.Marshal.Array.allocaArray sz $ \ptr -> do Foreign.Storable.pokeElemOff ptr off v peekOff ptr (Offset off) - assert $ v == v' + validate "equal" $ v == v' testPropertyStorableFixedPokeOff :: (StorableFixed a, Foreign.Storable.Storable a, Arbitrary a, Eq a, Show a) => Proxy a -> SomeWhereInArray a - -> Property -testPropertyStorableFixedPokeOff _ (SomeWhereInArray v sz off) = monadicIO $ do - v' <- run $ Foreign.Marshal.Array.allocaArray sz $ \ptr -> do + -> Test +testPropertyStorableFixedPokeOff _ (SomeWhereInArray v sz off) = CheckPlan "storable-fixed-poke-off" $ do + v' <- pick "alloca" $ Foreign.Marshal.Array.allocaArray sz $ \ptr -> do pokeOff ptr (Offset off) v Foreign.Storable.peekElemOff ptr off - assert $ v == v' + validate "equal" $ v == v' + -} diff --git a/tests/Test/Foundation/String.hs b/tests/Test/Foundation/String.hs --- a/tests/Test/Foundation/String.hs +++ b/tests/Test/Foundation/String.hs @@ -7,45 +7,40 @@ ( testStringRefs ) where -import Control.Monad (replicateM) +-- import Control.Monad (replicateM) import Foundation +import Foundation.Check import Foundation.String -import Foundation.String.ASCII (AsciiString) -import Control.Exception -import Data.Either - -import Test.Tasty -import Test.Tasty.QuickCheck -import Test.Tasty.HUnit +import Foundation.Primitive (AsciiString) -import Test.Data.Unicode -import Test.Data.ASCII import Test.Data.List -import Test.Foundation.Collection -import Test.Foundation.Encoding +import Test.Checks.Property.Collection +--import Test.Foundation.Encoding -testStringRefs :: TestTree -testStringRefs = testGroup "String" - [ testGroup "UTF8" $ - [ testCollection "Sequential" (Proxy :: Proxy String) genUnicodeChar ] +testStringRefs :: Test +testStringRefs = Group "String" + [ Group "UTF8" $ + [ collectionProperties "String" (Proxy :: Proxy String) arbitrary ] <> testStringCases + {- <> [ testGroup "Encoding Sample0" (testEncodings sample0) , testGroup "Encoding Sample1" (testEncodings sample1) , testGroup "Encoding Sample2" (testEncodings sample2) ] - , testGroup "ASCII" $ - [ testCollection "Sequential" (Proxy :: Proxy AsciiString) genAsciiChar ] - <> testAsciiStringCases + -} + , Group "ASCII" $ + [ collectionProperties "AsciiString" (Proxy :: Proxy AsciiString) arbitrary ] + -- <> testAsciiStringCases ] -testStringCases :: [TestTree] +testStringCases :: [Test] testStringCases = - [ testGroup "Validation" - [ testProperty "fromBytes . toBytes == valid" $ \(LUString l) -> + [ Group "Validation" + [ Property "fromBytes . toBytes == valid" $ \l -> let s = fromList l in (fromBytes UTF8 $ toBytes UTF8 s) === (s, Nothing, mempty) - , testProperty "Streaming" $ \(LUString l, randomInts) -> + , Property "Streaming" $ \(l, randomInts) -> let wholeS = fromList l wholeBA = toBytes UTF8 wholeS reconstruct (prevBa, errs, acc) ba = @@ -54,8 +49,17 @@ in (nextBa, merr : errs, s : acc) (remainingBa, allErrs, chunkS) = foldl' reconstruct (mempty, [], []) $ chunks randomInts wholeBA - in (catMaybes allErrs === []) .&&. (remainingBa === mempty) .&&. (mconcat (reverse chunkS) === wholeS) + in (catMaybes allErrs === []) `propertyAnd` (remainingBa === mempty) `propertyAnd` (mconcat (reverse chunkS) === wholeS) ] + , Group "ModifiedUTF8" + [ propertyModifiedUTF8 "The foundation Serie" "基地系列" "基地系列" + , propertyModifiedUTF8 "has null bytes" "let's\0 do \0 it" "let's\0 do \0 it" + , propertyModifiedUTF8 "Vincent's special" "abc\0안, 蠀\0, ☃" "abc\0안, 蠀\0, ☃" + , propertyModifiedUTF8 "Long string" + "this is only a simple string but quite longer than the 64 bytes used in the modified UTF8 parser" + "this is only a simple string but quite longer than the 64 bytes used in the modified UTF8 parser" + ] + {- , testGroup "replace" [ testCase "indices '' 'bb' should raise an error" $ do res <- try (evaluate $ indices "" "bb") @@ -112,15 +116,17 @@ , testCase "empty" $ (breakLine "" @?= Left False) ] + -} ] -testAsciiStringCases :: [TestTree] +{- +testAsciiStringCases :: [Test] testAsciiStringCases = - [ testGroup "Validation-ASCII7" - [ testProperty "fromBytes . toBytes == valid" $ \l -> + [ Group "Validation-ASCII7" + [ Property "fromBytes . toBytes == valid" $ \l -> let s = fromList . fromLStringASCII $ l in (fromBytes ASCII7 $ toBytes ASCII7 s) === (s, Nothing, mempty) - , testProperty "Streaming" $ \(l, randomInts) -> + , Property "Streaming" $ \(l, randomInts) -> let wholeS = fromList . fromLStringASCII $ l wholeBA = toBytes ASCII7 wholeS reconstruct (prevBa, errs, acc) ba = @@ -131,8 +137,8 @@ (remainingBa, allErrs, chunkS) = foldl' reconstruct (mempty, [], []) $ chunks randomInts wholeBA in (catMaybes allErrs === []) .&&. (remainingBa === mempty) .&&. (mconcat (reverse chunkS) === wholeS) ] - , testGroup "Cases" - [ testGroup "Invalid-ASCII7" + , Group "Cases" + [ Group "Invalid-ASCII7" [ testCase "ff" $ expectFromBytesErr ASCII7 ("", Just BuildingFailure, 0) (fromList [0xff]) ] ] @@ -145,7 +151,11 @@ assertEqual "error" expectedErr merr assertEqual "remaining" (drop positionErr ba) ba' assertEqual "string" expectedString (toList s') +-} +propertyModifiedUTF8 :: String -> [Char] -> String -> Test +propertyModifiedUTF8 name chars str = Property name $ chars === toList str + chunks :: Sequential c => RandomList -> c -> [c] chunks (RandomList randomInts) = loop (randomInts <> [1..]) where @@ -158,11 +168,3 @@ in c1 : loop rs c2 [] -> loop randomInts c - -newtype LStringASCII = LStringASCII { fromLStringASCII :: LString } - deriving (Show, Eq, Ord) - -instance Arbitrary LStringASCII where - arbitrary = do - n <- choose (0,200) - LStringASCII <$> replicateM n (toEnum <$> choose (1, 127)) diff --git a/tests/Test/Foundation/String/Base64.hs b/tests/Test/Foundation/String/Base64.hs --- a/tests/Test/Foundation/String/Base64.hs +++ b/tests/Test/Foundation/String/Base64.hs @@ -7,102 +7,96 @@ ( testBase64Refs ) where -import Imports ((@?=), testCase) - import Control.Monad import Foundation import Foundation.Numerical import Foundation.String - -import Test.Tasty -import Test.Tasty.QuickCheck - -import Test.Data.Unicode +import Foundation.Check -testBase64Refs :: TestTree -testBase64Refs = testGroup "String" - [ testGroup "Base64" testBase64Cases +testBase64Refs :: Test +testBase64Refs = Group "String" + [ Group "Base64" testBase64Cases ] -testBase64Cases :: [TestTree] +testBase64Cases :: [Test] testBase64Cases = - [ testGroup "toBase64" - [ testProperty "length with padding" $ \(LUString l) -> + [ Group "toBase64" + [ Property "length with padding" $ \l -> let s = fromList l b = toBytes UTF8 s blen = length b in (length . toBytes UTF8 . toBase64 $ s) === outputLengthBase64 True blen - , testProperty "valid chars" $ \(LUString l) -> + , Property "valid chars" $ \l -> let s = fromList l s64 = toBase64 s b64 = toBytes UTF8 s64 in all ((||) <$> isPlainBase64Char <*> isPadding) b64 === True - , testCase "test string: 'pleasure.'" $ do + , Property "test string: 'pleasure.'" $ do let s = fromList "pleasure." - toBase64 s @?= fromList "cGxlYXN1cmUu" - , testCase "test string: 'leasure.'" $ do + toBase64 s === fromList "cGxlYXN1cmUu" + , Property "test string: 'leasure.'" $ do let s = fromList "leasure." - toBase64 s @?= fromList "bGVhc3VyZS4=" - , testCase "test string: 'easure.'" $ do + toBase64 s === fromList "bGVhc3VyZS4=" + , Property "test string: 'easure.'" $ do let s = fromList "easure." - toBase64 s @?= fromList "ZWFzdXJlLg==" - , testCase "test string: 'asure.'" $ do + toBase64 s === fromList "ZWFzdXJlLg==" + , Property "test string: 'asure.'" $ do let s = fromList "asure." - toBase64 s @?= fromList "YXN1cmUu" - , testCase "test string: 'sure.'" $ do + toBase64 s === fromList "YXN1cmUu" + , Property "test string: 'sure.'" $ do let s = fromList "sure." - toBase64 s @?= fromList "c3VyZS4=" + toBase64 s === fromList "c3VyZS4=" ] - , testGroup "toBase64OpenBSD" - [ testProperty "length without padding" $ \(LUString l) -> + , Group "toBase64OpenBSD" + [ Property "length without padding" $ \l -> let s = fromList l b = toBytes UTF8 s blen = length b in (length . toBytes UTF8 . toBase64OpenBSD $ s) === outputLengthBase64 False blen - , testProperty "valid chars" $ \(LUString l) -> + , Property "valid chars" $ \l -> let s = fromList l s64 = toBase64OpenBSD s b64 = toBytes UTF8 s64 in all isBase64OpenBSDChar b64 === True ] - , testGroup "toBase64URL" - [ testProperty "length with padding" $ \(LUString l) -> + , Group "toBase64URL" + [ Property "length with padding" $ \l -> let s = fromList l b = toBytes UTF8 s blen = length b in (length . toBytes UTF8 . toBase64URL True $ s) === outputLengthBase64 True blen, - testProperty "length without padding" $ \(LUString l) -> + Property "length without padding" $ \l -> let s = fromList l b = toBytes UTF8 s blen = length b in (length . toBytes UTF8 . toBase64URL False $ s) === outputLengthBase64 False blen - , testProperty "valid chars (with padding)" $ \(LUString l) -> + , Property "valid chars (with padding)" $ \l -> let s = fromList l s64 = toBase64URL True s b64 = toBytes UTF8 s64 in all ((||) <$> isBase64URLChar <*> isPadding) b64 === True - , testProperty "valid chars (without padding)" $ \(LUString l) -> + , Property "valid chars (without padding)" $ \l -> let s = fromList l s64 = toBase64URL False s b64 = toBytes UTF8 s64 in all isBase64URLChar b64 === True - , testCase "test string: 'pleasure.'" $ do + , Property "test string: 'pleasure.'" $ do let s = fromList "pleasure." - toBase64URL False s @?= fromList "cGxlYXN1cmUu" - , testCase "test string: 'leasure.'" $ do + toBase64URL False s === fromList "cGxlYXN1cmUu" + , Property "test string: 'leasure.'" $ do let s = fromList "leasure." - toBase64URL False s @?= fromList "bGVhc3VyZS4" - , testCase "test string: ''" $ do + toBase64URL False s === fromList "bGVhc3VyZS4" + , Property "test string: ''" $ do let s = fromList "" - toBase64URL False s @?= fromList "" - , testCase "test string: '\\DC4\\251\\156\\ETX\\217~'" $ do + toBase64URL False s === fromList "" + , Property "test string: '\\DC4\\251\\156\\ETX\\217~'" $ do -- the byte list represents "\DC4\251\156\ETX\217~" let s = fromBytesUnsafe . fromList $ [0x14, 0xfb, 0x9c, 0x03, 0xd9, 0x7e] - toBase64URL False s @?= fromList "FPucA9l-" - , testCase "test string: '\\DC4\\251\\156\\ETX\\217\\DEL'" $ do + toBase64URL False s === fromList "FPucA9l-" + , Property "test string: '\\DC4\\251\\156\\ETX\\217\\DEL'" $ do -- the byte list represents "\DC4\251\156\ETX\217\DEL" let s = fromBytesUnsafe . fromList $ [0x14, 0xfb, 0x9c, 0x03, 0xd9, 0x7f] - toBase64URL False s @?= fromList "FPucA9l_" + toBase64URL False s === fromList "FPucA9l_" ] ] diff --git a/tests/Test/Utils/Foreign.hs b/tests/Test/Utils/Foreign.hs deleted file mode 100644 --- a/tests/Test/Utils/Foreign.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Test.Utils.Foreign - ( Ptr - , Storable - , createPtr - , free - ) where - -import Foreign.Marshal.Alloc - -import Foreign.Ptr -import Foundation -import Prelude (zip) -import Control.Monad (forM_) - -import Foundation.Foreign -import Foundation.Class.Storable - -createPtr :: forall e . StorableFixed e => [e] -> IO (FinalPtr e) -createPtr l - | null l = toFinalPtr nullPtr (\_ -> return ()) - | otherwise = do - let (CountOf szElem) = size (Proxy :: Proxy e) - nbBytes = szElem * (let (CountOf c) = length l in c) - ptr <- mallocBytes nbBytes - forM_ (zip [0..] l) $ uncurry (pokeOff ptr) - toFinalPtr ptr free diff --git a/tests/Tests.hs b/tests/Tests.hs deleted file mode 100644 --- a/tests/Tests.hs +++ /dev/null @@ -1,363 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} -module Main where - -import Control.Monad -import Imports - -import Foundation hiding (second) -import Foundation.Array -import Foundation.Collection -import Foundation.VFS (Path (..), filename, parent) -import Foundation.VFS.FilePath -import qualified Prelude -import GHC.ST - -import Test.Data.Unicode -import Test.Data.List - -import Test.Foundation.Collection -import Test.Foundation.Conduit -import Test.Foundation.Number -import Test.Foundation.Array -import Test.Foundation.String.Base64 -import Test.Foundation.ChunkedUArray -#if MIN_VERSION_base(4,9,0) -import Test.Foundation.Primitive.BlockN -#endif -import Test.Foundation.String -import Test.Foundation.Parser -import Test.Foundation.Storable -import Test.Foundation.Network.IPv4 -import Test.Foundation.Network.IPv6 -import Test.Foundation.Misc -import qualified Test.Foundation.Bits as Bits - -data CharMap = CharMap LUString Prelude.Int - deriving (Show) - -addChar :: Prelude.Int -> Char -> Char -addChar n c = toEnum ((fromEnum c + n) `Prelude.mod` 0x10ffff) - - -instance Arbitrary CharMap where - arbitrary = - CharMap <$> arbitrary <*> choose (1,12) - -instance Arbitrary FileName where - arbitrary = do - s <- choose (1, 30) - unsafeFileName . fromList <$> vectorOf s genChar - where - genChar :: Gen Word8 - genChar = frequency - [ (10, pure 0x2e) -- '.' - , (10, choose (0x41, 0x5A)) -- [A-Z] - , (10, choose (0x61, 0x7A)) -- [a-z] - , (5, choose (0x30, 0x39)) -- [a-z] - , (5, elements [0x2d, 0x5f]) -- [-_] - ] - -instance Arbitrary Relativity where - arbitrary = elements [ Absolute, Relative ] - -instance Arbitrary FilePath where - arbitrary = do - s <- choose (0, 10) - unsafeFilePath <$> arbitrary - <*> vectorOf s arbitrary - -transEq :: Eq a => (t -> t1) -> (t1 -> a) -> (t1 -> a) -> t -> Bool -transEq unWrap f g s = - let s' = unWrap s in f s' == g s' - ---stringEq :: Eq a => (b -> a) -> (String -> b) -> (LString -> a) -> LUString -> Bool ---stringEq back f g s = - -#if MIN_VERSION_tasty_quickcheck(0,8,4) --- | Set in front of tests to make them verbose -qcv :: TestTree -> TestTree -qcv = adjustOption (\(QuickCheckVerbose _) -> QuickCheckVerbose True) - --- | Set the number of tests -qcnSet :: Int -> TestTree -> TestTree -qcnSet n = adjustOption (\(QuickCheckTests _) -> QuickCheckTests n) - --- | Scale the number of tests -qcnScale :: Int -> TestTree -> TestTree -qcnScale n = adjustOption (\(QuickCheckTests actual) -> QuickCheckTests (actual * n)) -#endif - -testCaseFilePath :: [TestTree] -testCaseFilePath = Prelude.map (makeTestCases . (\x -> (show x, x))) - [ "/" - , "." - , ".." - , "C:" "Users" "haskell-lang" - , "/home" - , "/home" "haskell-lang" "new hope" "foundation" - , "~" "new hope" "foundation" - , "new hope" "foundation" - , "new hope" "foundation" ".." - , "." "new hope" ".." ".." "haskell-lang" "new hope" - ] - where - makeTestCases :: (String, FilePath) -> TestTree - makeTestCases (title, p) = testGroup title - [ testCase "buildPath . splitPath == id)" $ assertBuildSplitIdemPotent p - , testCase "p == (parent p filename p)" $ assertParentFilenameIdemPotent p - ] - - assertParentFilenameIdemPotent :: FilePath -> Assertion - assertParentFilenameIdemPotent p = - unless (assertEq (parent p filename p) p) $ - error "assertion failed" - assertBuildSplitIdemPotent :: FilePath -> Assertion - assertBuildSplitIdemPotent p = - unless (assertEq (buildPath $ splitPath p) p) $ - error "assertion failed" - -testPath :: (Path path, Show path, Eq path) - => Gen path - -> [TestTree] -testPath genElement = - [ testProperty "buildPath . splitPath == id" $ withElements $ \l -> (buildPath $ splitPath l) === l - ] - where - withElements f = forAll genElement f - -testBuildable :: (Eq a, IsList a, Show (Element a), Element a ~ Item a, Buildable a) - => Proxy a -> Gen (Element a) -> Gen (Small Int) -> [TestTree] -testBuildable proxy genElement genChunkSize = - [ testProperty "build s . mapM_ append == id" $ withElementsAndChunkSize $ \(l, Small s) -> - runST (build_ s (Prelude.mapM_ append l)) `asProxyTypeOf` proxy == fromListP proxy l - ] - where - withElementsAndChunkSize = forAll ((,) <$> generateListOfElement genElement <*> genChunkSize) - -testBoxedZippable :: ( Eq (Element col) , Show (Item a), Show (Item b) - , BoxedZippable col, Zippable a, Zippable b - , Element col ~ (Item a, Item b) ) - => Proxy a -> Proxy b -> Proxy col -> Gen (Element a) -> Gen (Element b) -> [TestTree] -testBoxedZippable proxyA proxyB proxyCol genElementA genElementB = - [ testProperty "zip" $ withList2 $ \(as, bs) -> - toListP proxyCol (zip (fromListP proxyA as) (fromListP proxyB bs)) === zip as bs - , testProperty "zip . unzip == id" $ withListOfTuples $ \xs -> - let (as, bs) = unzip (fromListP proxyCol xs) - in toListP proxyCol (zip (as `asProxyTypeOf` proxyA) (bs `asProxyTypeOf` proxyB)) === xs - ] - where - withList2 = forAll ((,) <$> generateListOfElement genElementA <*> generateListOfElement genElementB) - withListOfTuples = forAll (generateListOfElement ((,) <$> genElementA <*> genElementB)) - -testZippable :: ( Eq (Element col), Show (Item col), Show (Item a), Show (Item b) - , Zippable col, Zippable a, Zippable b ) - => Proxy a -> Proxy b -> Proxy col -> Gen (Element a) -> Gen (Element b) -> Gen (Element col) -> [TestTree] -testZippable proxyA proxyB proxyCol genElementA genElementB genElementCol = - [ testProperty "zipWith" $ withList2AndE $ \(as, bs, c) -> - toListP proxyCol (zipWith (\_ _ -> c) (fromListP proxyA as) (fromListP proxyB bs) - ) === replicate (CountOf (Prelude.min (unCountOf $ length as) (unCountOf $ length bs))) c - ] - where - unCountOf (CountOf c) = c - withList2AndE = forAll ( (,,) <$> generateListOfElement genElementA <*> generateListOfElement genElementB - <*> genElementCol ) - -testZippableProps :: (Eq (Item a), Eq (Item b), Show (Item a), Show (Item b), Zippable a, Zippable b) - => Proxy a -> Proxy b -> Gen (Element a) -> Gen (Element b) -> [TestTree] -testZippableProps proxyA proxyB genElementA genElementB = - [ testProperty "zipWith _|_ [] xs == []" $ withList $ \as -> - toListP proxyA (zipWith undefined [] (fromListP proxyA as)) === [] - , testProperty "zipWith f a b == zipWith (flip f) b a" $ withList2 $ \(as, bs) -> - let f = ignore1 - as' = fromListP proxyA as - bs' = fromListP proxyB bs - in toListP proxyB (zipWith f as' bs') - === toListP proxyB (zipWith (flip f) bs' as') - , testProperty "zipWith3 f [...] xs == zipWith id (zipWith f [...]) xs)" $ withList2 $ \(as, bs) -> - let f = ignore2 - as' = fromListP proxyA as - bs' = fromListP proxyB bs - in toListP proxyB (zipWith3 f as' as' bs') - === Prelude.zipWith id (zipWith f as as) bs - , testProperty "zipWith4 f [...] xs == zipWith id (zipWith3 f [...]) xs)" $ withList2 $ \(as, bs) -> - let f = ignore3 - as' = fromListP proxyA as - bs' = fromListP proxyB bs - in toListP proxyB (zipWith4 f as' as' as' bs') - === Prelude.zipWith id (zipWith3 f as as as) bs - , testProperty "zipWith5 f [...] xs == zipWith id (zipWith4 f [...]) xs)" $ withList2 $ \(as, bs) -> - let f = ignore4 - as' = fromListP proxyA as - bs' = fromListP proxyB bs - in toListP proxyB (zipWith5 f as' as' as' as' bs') - === Prelude.zipWith id (zipWith4 f as as as as) bs - , testProperty "zipWith6 f [...] xs == zipWith id (zipWith5 f [...]) xs)" $ withList2 $ \(as, bs) -> - let f = ignore5 - as' = fromListP proxyA as - bs' = fromListP proxyB bs - in toListP proxyB (zipWith6 f as' as' as' as' as' bs') - === Prelude.zipWith id (zipWith5 f as as as as as) bs - , testProperty "zipWith7 f [...] xs == zipWith id (zipWith6 f [...]) xs)" $ withList2 $ \(as, bs) -> - let f = ignore6 - as' = fromListP proxyA as - bs' = fromListP proxyB bs - in toListP proxyB (zipWith7 f as' as' as' as' as' as' bs') - === Prelude.zipWith id (zipWith6 f as as as as as as) bs - ] - where - -- ignore the first n arguments - ignore1 = flip const - ignore2 = const . ignore1 - ignore3 = const . ignore2 - ignore4 = const . ignore3 - ignore5 = const . ignore4 - ignore6 = const . ignore5 - withList = forAll (generateListOfElement genElementA) - withList2 = forAll ((,) <$> generateListOfElement genElementA <*> generateListOfElement genElementB) - - -tests :: [TestTree] -tests = - [ testArrayRefs - , testBase64Refs - , testChunkedUArrayRefs - , Bits.tests - , testCollection "Bitmap" (Proxy :: Proxy Bitmap) arbitrary - , testStringRefs - , testGroup "VFS" - [ testGroup "FilePath" $ testCaseFilePath <> (testPath (arbitrary :: Gen FilePath)) - ] - , testGroup "Number" testNumberRefs - , testGroup "ModifiedUTF8" - [ testCase "The foundation Serie" $ testCaseModifiedUTF8 "基地系列" "基地系列" - , testCase "has null bytes" $ testCaseModifiedUTF8 "let's\0 do \0 it" "let's\0 do \0 it" - , testCase "Vincent's special" $ testCaseModifiedUTF8 "abc\0안, 蠀\0, ☃" "abc\0안, 蠀\0, ☃" - , testCase "Long string" $ testCaseModifiedUTF8 - "this is only a simple string but quite longer than the 64 bytes used in the modified UTF8 parser" - "this is only a simple string but quite longer than the 64 bytes used in the modified UTF8 parser" - ] - , testGroup "BoxedZippable" - [ testGroup "Array" - [ testGroup "from Array Int" - ( testBoxedZippable - (Proxy :: Proxy (Array Int)) (Proxy :: Proxy (Array Int)) - (Proxy :: Proxy (Array (Int, Int))) arbitrary arbitrary ) - , testGroup "from String" - ( testBoxedZippable - (Proxy :: Proxy String) (Proxy :: Proxy String) - (Proxy :: Proxy (Array (Char, Char))) arbitrary arbitrary ) - , testGroup "from String and Array Char" - ( testBoxedZippable - (Proxy :: Proxy String) (Proxy :: Proxy (Array Char)) - (Proxy :: Proxy (Array (Char, Char))) arbitrary arbitrary ) - , testGroup "from Array Int and Array Char" - ( testBoxedZippable - (Proxy :: Proxy (Array Int)) (Proxy :: Proxy (Array Char)) - (Proxy :: Proxy (Array (Int, Char))) arbitrary arbitrary ) - ] - ] - , testGroup "Buildable" - [ testGroup "String" - (testBuildable (Proxy :: Proxy String) arbitrary arbitrary) - , testGroup "Array Int" - (testBuildable (Proxy :: Proxy (Array Int)) arbitrary arbitrary) - , testGroup "Array Char" - (testBuildable (Proxy :: Proxy (Array Char)) arbitrary arbitrary) - , testGroup "UArray Word8" - (testBuildable (Proxy :: Proxy (UArray Word8)) arbitrary arbitrary) - , testGroup "UArray Char" - (testBuildable (Proxy :: Proxy (UArray Char)) arbitrary arbitrary) - ] - , testGroup "Zippable" - [ testGroup "String" - [ testGroup "from String" - ( testZippable - (Proxy :: Proxy String) (Proxy :: Proxy String) - (Proxy :: Proxy String) arbitrary arbitrary arbitrary ) - , testGroup "from Array Char" - ( testZippable - (Proxy :: Proxy (Array Char)) (Proxy :: Proxy (Array Char)) - (Proxy :: Proxy String) arbitrary arbitrary arbitrary ) - , testGroup "from UArray Word8 and Array Int" - ( testZippable - (Proxy :: Proxy (UArray Word8)) (Proxy :: Proxy (Array Int)) - (Proxy :: Proxy String) arbitrary arbitrary arbitrary ) - ] - , testGroup "Array" - [ testGroup "from String" - ( testZippable - (Proxy :: Proxy String) (Proxy :: Proxy String) - (Proxy :: Proxy (Array Int)) arbitrary arbitrary arbitrary ) - , testGroup "from Array Char" - ( testZippable - (Proxy :: Proxy (Array Char)) (Proxy :: Proxy (Array Char)) - (Proxy :: Proxy (Array Char)) arbitrary arbitrary arbitrary ) - , testGroup "from UArray Word8 and Array Int" - ( testZippable - (Proxy :: Proxy (UArray Word8)) (Proxy :: Proxy (Array Int)) - (Proxy :: Proxy (Array Int)) arbitrary arbitrary arbitrary ) - ] - , testGroup "UArray" - [ testGroup "from String" - ( testZippable - (Proxy :: Proxy String) (Proxy :: Proxy String) - (Proxy :: Proxy (UArray Word8)) arbitrary arbitrary arbitrary ) - , testGroup "from Array Char" - ( testZippable - (Proxy :: Proxy (Array Char)) (Proxy :: Proxy (Array Char)) - (Proxy :: Proxy (UArray Word16)) arbitrary arbitrary arbitrary ) - , testGroup "from UArray Word8 and Array Int" - ( testZippable - (Proxy :: Proxy (UArray Word8)) (Proxy :: Proxy (Array Int)) - (Proxy :: Proxy (UArray Word32)) arbitrary arbitrary arbitrary ) - ] - , testGroup "Properties" - ( testZippableProps (Proxy :: Proxy (Array Int)) (Proxy :: Proxy (Array Char)) - arbitrary arbitrary ) - ] -#if MIN_VERSION_base(4,9,0) - , testBlockN -#endif - , testParsers - , testForeignStorableRefs - , testConduit - , testNetworkIPv4 - , testNetworkIPv6 - , testHexadecimal - , testTime - , testUUID - , testGroup "Issues" - [ testGroup "218" - [ testCase "Foundation Strings" $ - let str1 = "aa9a9\154" :: String - str2 = "a9\154" :: String - Just x = uncons $ snd $ breakElem '9' str1 - x1 = breakElem '9' $ snd x - x2 = breakElem '9' str2 - in if assertEq x1 x2 then return () else error "failed..." - , testCase "Lazy Strings" $ - let str1 = "aa9a9\154" :: [Char] - str2 = "a9\154" :: [Char] - Just x = uncons $ snd $ breakElem '9' str1 - x1 = breakElem '9' $ snd x - x2 = breakElem '9' str2 - in if assertEq x1 x2 then return () else error "failed..." - ] - ] - ] - -testCaseModifiedUTF8 :: [Char] -> String -> Assertion -testCaseModifiedUTF8 ghcStr str - | ghcStr == fStr = return () - | otherwise = assertFailure $ diffList ghcStr fStr - where - fStr :: [Char] - fStr = toList str - -main :: IO () -main = defaultMain $ testGroup "foundation" tests