diff --git a/Foundation.hs b/Foundation.hs new file mode 100644 --- /dev/null +++ b/Foundation.hs @@ -0,0 +1,178 @@ +-- | +-- Module : Foundation +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- I tried to picture clusters of information +-- As they moved through the computer +-- What do they look like? +-- +-- Alternative Prelude +{-# LANGUAGE CPP #-} +module Foundation + ( -- * Standard + -- ** Operators + (Prelude.$) + , (Prelude.$!) + , (Prelude.&&) + , (Prelude.||) + , (Control.Category..) + -- ** Functions + , Prelude.not + , Prelude.otherwise + , module Foundation.Tuple + , Control.Category.id + , Prelude.maybe + , Prelude.either + , Prelude.flip + , Prelude.const + , Prelude.error + , Foundation.IO.Terminal.putStr + , Foundation.IO.Terminal.putStrLn + --, print + , getArgs + , Prelude.uncurry + , Prelude.curry + , Data.Tuple.swap + , Prelude.until + , Prelude.asTypeOf + , Prelude.undefined + , Prelude.seq + -- ** Type classes + , Prelude.Show (..) + , Prelude.Ord (..) + , Prelude.Eq (..) + , Prelude.Bounded (..) + , Prelude.Enum (..) + , Prelude.Functor (..) + , Control.Applicative.Applicative (..) + , Prelude.Monad (..) + , (Control.Monad.=<<) + --, Foundation.String.IsString (..) + , IsString(..) + , IsList(..) + -- ** Numeric type classes + , Foundation.Number.Number (..) + , Foundation.Number.Signed (..) + , Foundation.Number.Additive (..) + , Foundation.Number.Subtractive (..) + , Foundation.Number.Multiplicative (..) + -- ** Data types + , Prelude.Maybe (..) + , Prelude.Ordering (..) + , Prelude.Bool (..) + , Prelude.Char + , 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 + , Prelude.Int + , Prelude.Integer + , Prelude.Rational + , Prelude.Float + , Prelude.Double + -- ** Collection types + , UArray + , PrimType + , Array + , String + -- ** Numeric functions + -- , (Prelude.^) + , (Prelude.^^) + , Prelude.fromIntegral + , Prelude.realToFrac + -- ** Monoids + , Monoid (..) + , (<>) + -- ** Folds and traversals + , Data.Foldable.Foldable + , Data.Foldable.asum + , Data.Traversable.Traversable + -- ** Maybe + , Data.Maybe.mapMaybe + , Data.Maybe.catMaybes + , Data.Maybe.fromMaybe + , Data.Maybe.isJust + , Data.Maybe.isNothing + , Data.Maybe.listToMaybe + , Data.Maybe.maybeToList + -- ** Either + , Data.Either.partitionEithers + , Data.Either.lefts + , Data.Either.rights + -- ** Function + , Data.Function.on + -- ** Applicative + , (Control.Applicative.<$>) + , (Control.Applicative.<|>) + -- ** Monad + , (Control.Monad.>=>) + -- ** Exceptions + , Control.Exception.Exception (..) + , Data.Typeable.Typeable + , Control.Exception.SomeException + , Control.Exception.IOException + -- ** Proxy + , Foundation.Internal.Proxy.Proxy(..) + , Foundation.Internal.Proxy.asProxyTypeOf + -- ** Partial + , Foundation.Partial.Partial + , Foundation.Partial.partial + , Foundation.Partial.PartialError + , Foundation.Partial.fromPartial + -- ** Old Prelude Strings as [Char] with bridge back and forth + , LString + ) where + +import qualified Prelude +--import Prelude (Char, (.), Eq, Bool, IO) + +import Data.Monoid (Monoid (..)) +import Control.Applicative +import qualified Control.Category +import qualified Control.Monad +import qualified Control.Exception +import qualified Data.Typeable + +import qualified Data.Foldable +import qualified Data.Traversable + +import Data.Word (Word8, Word16, Word32, Word64, Word) +import Data.Int (Int8, Int16, Int32, Int64) +import Foundation.String (String) +import Foundation.Array (UArray, Array, PrimType) +--import Foundation.Collection +import qualified Foundation.IO.Terminal + +import GHC.Exts (IsString(..)) +import Foundation.Internal.IsList +import qualified Foundation.Internal.Proxy + +import qualified Foundation.Number +import qualified Foundation.Partial +import Foundation.Tuple + +import qualified Data.Maybe +import qualified Data.Either +import qualified Data.Function +import qualified Data.Tuple + +import qualified System.Environment +import qualified Data.List +#if MIN_VERSION_base(4,6,0) +import System.IO.Error +#else +import System.IO.Error hiding (catch, try) +#endif + +import Data.Monoid ((<>)) + +-- | 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) diff --git a/Foundation/Array.hs b/Foundation/Array.hs new file mode 100644 --- /dev/null +++ b/Foundation/Array.hs @@ -0,0 +1,30 @@ +-- | +-- Module : Foundation.Array +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- Simple Array and Almost-Array-like data structure +-- +-- Generally accessible in o(1) +-- +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +module Foundation.Array + ( Array + , MArray + , UArray + , MUArray + , Bitmap + , MutableBitmap + , PrimType + -- exceptions + , OutOfBound + ) where + +import Foundation.Array.Common +import Foundation.Array.Boxed +import Foundation.Array.Unboxed +import Foundation.Array.Unboxed.Mutable +import Foundation.Array.Bitmap diff --git a/Foundation/Array/Bitmap.hs b/Foundation/Array/Bitmap.hs new file mode 100644 --- /dev/null +++ b/Foundation/Array/Bitmap.hs @@ -0,0 +1,435 @@ +-- | +-- Module : Foundation.Array.Bitmap +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- A simple abstraction to a set of Bits (Bitmap) +-- +-- Largely a placeholder for a more performant implementation, +-- most operation goes through the List representation (e.g. [Bool]) +-- to conduct even the most trivial operation, leading to a lots of +-- unnecessary churn. +-- +{-# LANGUAGE BangPatterns #-} +module Foundation.Array.Bitmap + ( Bitmap + , MutableBitmap + , empty + , append + , concat + , unsafeIndex + , index + , read + , unsafeRead + , write + , unsafeWrite + , snoc + , cons + ) where + +import Foundation.Array.Unboxed (UArray) +import qualified Foundation.Array.Unboxed as A +import Foundation.Array.Unboxed.Mutable (MUArray) +import Foundation.Array.Common +import Foundation.Internal.Base +import Foundation.Internal.Types +import Foundation.Primitive.Monad +import qualified Foundation.Collection as C +import Foundation.Number +import Data.Bits +import GHC.ST +import qualified Data.List + +data Bitmap = Bitmap Int (UArray Word32) + +data MutableBitmap st = MutableBitmap Int (MUArray Word32 st) + +bitsPerTy :: Int +bitsPerTy = 32 + +instance Show Bitmap where + show v = show (toList v) +instance Eq Bitmap where + (==) = equal +instance Ord Bitmap where + compare = vCompare +instance Monoid Bitmap where + mempty = empty + mappend = append + mconcat = concat + +type instance C.Element Bitmap = Bool + +instance IsList Bitmap where + type Item Bitmap = Bool + fromList = vFromList + toList = vToList + +instance C.InnerFunctor Bitmap where + imap = map + +instance C.Foldable Bitmap where + foldl = foldl + foldr = foldr + foldl' = foldl' + foldr' = foldr' + +instance C.Sequential Bitmap where + null = null + take = take + drop = drop + splitAt = splitAt + revTake n = unoptimised (C.revTake n) + revDrop n = unoptimised (C.revDrop n) + splitOn = splitOn + break = break + span = span + filter = filter + reverse = reverse + snoc = snoc + cons = cons + unsnoc = unsnoc + uncons = uncons + intersperse = intersperse + find = find + sortBy = sortBy + length = length + singleton = fromList . (:[]) + +instance C.IndexedCollection Bitmap where + (!) l n + | n < 0 || n >= length l = Nothing + | otherwise = Just $ index l n + findIndex predicate c = loop 0 + where + !len = length c + loop i + | i == len = Nothing + | predicate (unsafeIndex c i) = Just i + | otherwise = Nothing + +instance C.MutableCollection MutableBitmap where + type Collection MutableBitmap = Bitmap + type MutableKey MutableBitmap = Int + type MutableValue MutableBitmap = Bool + + thaw = thaw + freeze = freeze + unsafeThaw = unsafeThaw + unsafeFreeze = unsafeFreeze + + mutUnsafeWrite = unsafeWrite + mutUnsafeRead = unsafeRead + mutWrite = write + mutRead = read + +bitmapIndex :: Int -> (Int, Int) +bitmapIndex !i = i `divMod` bitsPerTy +{-# INLINE bitmapIndex #-} + +-- return the index in word32 quantity and mask to a bit in a bitmap +{- +bitmapAddr :: Int -> (# Int , Word #) +bitmapAddr !i = (# idx, mask #) + where (!idx, !bitIdx) = bitmapIndex i + !mask = case bitIdx of + 0 -> 0x1 + 1 -> 0x2 + 2 -> 0x4 + 3 -> 0x8 + 4 -> 0x10 + 5 -> 0x20 + 6 -> 0x40 + 7 -> 0x80 + 8 -> 0x100 + 9 -> 0x200 + 10 -> 0x400 + 11 -> 0x800 + 12 -> 0x1000 + 13 -> 0x2000 + 14 -> 0x4000 + 15 -> 0x8000 + 16 -> 0x10000 + 17 -> 0x20000 + 18 -> 0x40000 + 19 -> 0x80000 + 20 -> 0x100000 + 21 -> 0x200000 + 22 -> 0x400000 + 23 -> 0x800000 + 24 -> 0x1000000 + 25 -> 0x2000000 + 26 -> 0x4000000 + 27 -> 0x8000000 + 28 -> 0x10000000 + 29 -> 0x20000000 + 30 -> 0x40000000 + _ -> 0x80000000 +-} + +thaw :: PrimMonad prim => Bitmap -> prim (MutableBitmap (PrimState prim)) +thaw (Bitmap len ba) = MutableBitmap len `fmap` C.thaw ba + +freeze :: PrimMonad prim => MutableBitmap (PrimState prim) -> prim Bitmap +freeze (MutableBitmap len mba) = Bitmap len `fmap` C.freeze mba + +unsafeThaw :: PrimMonad prim => Bitmap -> prim (MutableBitmap (PrimState prim)) +unsafeThaw (Bitmap len ba) = MutableBitmap len `fmap` C.unsafeThaw ba + +unsafeFreeze :: PrimMonad prim => MutableBitmap (PrimState prim) -> prim Bitmap +unsafeFreeze (MutableBitmap len mba) = Bitmap len `fmap` C.unsafeFreeze mba + +unsafeWrite :: PrimMonad prim => MutableBitmap (PrimState prim) -> Int -> Bool -> prim () +unsafeWrite (MutableBitmap _ ma) i v = do + let (idx, bitIdx) = bitmapIndex i + w <- A.unsafeRead ma idx + let w' = if v then setBit w bitIdx else clearBit w bitIdx + A.unsafeWrite ma idx w' +{-# INLINE unsafeWrite #-} + +unsafeRead :: PrimMonad prim => MutableBitmap (PrimState prim) -> Int -> prim Bool +unsafeRead (MutableBitmap _ ma) i = do + let (idx, bitIdx) = bitmapIndex i + flip testBit bitIdx `fmap` A.unsafeRead ma idx +{-# INLINE unsafeRead #-} + +write :: PrimMonad prim => MutableBitmap (PrimState prim) -> Int -> Bool -> prim () +write mb n val + | n < 0 || n >= len = primThrow (OutOfBound OOB_Write n len) + | otherwise = unsafeWrite mb n val + where + len = mutableLength mb +{-# INLINE write #-} + +read :: PrimMonad prim => MutableBitmap (PrimState prim) -> Int -> prim Bool +read mb n + | n < 0 || n >= len = primThrow (OutOfBound OOB_Read n len) + | otherwise = unsafeRead mb n + where len = mutableLength mb +{-# INLINE read #-} + +-- | Return the element at a specific index from a Bitmap. +-- +-- If the index @n is out of bounds, an error is raised. +index :: Bitmap -> Int -> Bool +index bits n + | n < 0 || n >= len = throw (OutOfBound OOB_Index n len) + | otherwise = unsafeIndex bits n + where len = length bits +{-# 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 :: Bitmap -> Int -> Bool +unsafeIndex (Bitmap _ ba) n = + let (idx, bitIdx) = bitmapIndex n + in testBit (A.unsafeIndex ba idx) bitIdx + +{-# INLINE unsafeIndex #-} + +----------------------------------------------------------------------- +-- higher level collection implementation +----------------------------------------------------------------------- +length :: Bitmap -> Int +length (Bitmap len _) = len + +mutableLength :: MutableBitmap st -> Int +mutableLength (MutableBitmap len _) = len + +empty :: Bitmap +empty = Bitmap 0 A.empty + +-- | make an array from a list of elements. +vFromList :: [Bool] -> Bitmap +vFromList allBools = runST $ do + mba <- A.new nbElements + let mbitmap = MutableBitmap len mba + loop mbitmap 0 allBools + where + loop mb _ [] = unsafeFreeze mb + loop mb i (x:xs) = unsafeWrite mb i x >> loop mb (i+1) xs + +{- + runST $ do + mba <- A.new nbElements + ba <- loop mba (0 :: Int) allBools + return (Bitmap len ba) + where + loop mba _ [] = A.unsafeFreeze mba + loop mba i l = do + let (l1, l2) = C.splitAt bitsPerTy l + w = toPacked l1 + A.unsafeWrite mba i w + loop mba (i+1) l2 + + toPacked :: [Bool] -> Word32 + toPacked l = + C.foldl (.|.) 0 $ Prelude.zipWith (\b w -> if b then (1 `shiftL` w) else 0) l (C.reverse [0..31]) +-} + + nbElements :: Size Word32 + nbElements = Size (len `divUp` bitsPerTy) + + divUp a b + | d == 0 = c + | otherwise = c+1 + where + (c,d) = a `divMod` b + + len = C.length allBools + +-- | transform an array to a list. +vToList :: Bitmap -> [Bool] +vToList a = loop 0 + where len = length a + loop i | i == len = [] + | otherwise = unsafeIndex a i : loop (i+1) + +-- | Check if two vectors are identical +equal :: Bitmap -> Bitmap -> Bool +equal a b + | la /= lb = False + | otherwise = loop 0 + where + !la = length a + !lb = length b + loop n | n == la = True + | otherwise = (unsafeIndex a n == unsafeIndex b n) && loop (n+1) + +-- | Compare 2 vectors +vCompare :: Bitmap -> Bitmap -> 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 + +-- | Append 2 arrays together by creating a new bigger array +-- +-- TODO completely non optimized +append :: Bitmap -> Bitmap -> Bitmap +append a b = fromList $ toList a `mappend` toList b + +-- TODO completely non optimized +concat :: [Bitmap] -> Bitmap +concat l = fromList $ mconcat $ fmap toList l + +null :: Bitmap -> Bool +null (Bitmap nbBits _) = nbBits == 0 + +take :: Int -> Bitmap -> Bitmap +take nbElems bits@(Bitmap nbBits ba) + | nbElems <= 0 = empty + | nbElems >= nbBits = bits + | otherwise = Bitmap nbElems ba -- TODO : although it work right now, take on the underlaying ba too + +drop :: Int -> Bitmap -> Bitmap +drop nbElems bits@(Bitmap nbBits _) + | nbElems <= 0 = bits + | nbElems >= nbBits = empty + | otherwise = unoptimised (C.drop nbElems) bits + -- TODO: decide if we have drop easy by having a bit offset in the data structure + -- or if we need to shift stuff around making all the indexing slighlty more complicated + +splitAt :: Int -> Bitmap -> (Bitmap, Bitmap) +splitAt n v = (take n v, drop n v) + +-- unoptimised +splitOn :: (Bool -> Bool) -> Bitmap -> [Bitmap] +splitOn f bits = fmap fromList $ C.splitOn f $ toList bits + +-- unoptimised +break :: (Bool -> Bool) -> Bitmap -> (Bitmap, Bitmap) +break predicate v = findBreak 0 + where + findBreak i + | i == length v = (v, empty) + | otherwise = + if predicate (unsafeIndex v i) + then splitAt i v + else findBreak (i+1) + +span :: (Bool -> Bool) -> Bitmap -> (Bitmap, Bitmap) +span p = break (not . p) + +map :: (Bool -> Bool) -> Bitmap -> Bitmap +map f bits = unoptimised (fmap f) bits + +--mapIndex :: (Int -> Bool -> Bool) -> Bitmap -> Bitmap +--mapIndex f Bitmap = + +cons :: Bool -> Bitmap -> Bitmap +cons v l = unoptimised (C.cons v) l + +snoc :: Bitmap -> Bool -> Bitmap +snoc l v = unoptimised (flip C.snoc v) l + +-- unoptimised +uncons :: Bitmap -> Maybe (Bool, Bitmap) +uncons b = fmap (\(v, l) -> (v, fromList l)) $ C.uncons $ toList b + +-- unoptimised +unsnoc :: Bitmap -> Maybe (Bitmap, Bool) +unsnoc b = fmap (\(l, v) -> (fromList l, v)) $ C.unsnoc $ toList b + +intersperse :: Bool -> Bitmap -> Bitmap +intersperse b = unoptimised (C.intersperse b) + +find :: (Bool -> Bool) -> Bitmap -> Maybe Bool +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 :: (Bool -> Bool -> Ordering) -> Bitmap -> Bitmap +sortBy by bits = unoptimised (C.sortBy by) bits + +filter :: (Bool -> Bool) -> Bitmap -> Bitmap +filter predicate vec = unoptimised (Data.List.filter predicate) vec + +reverse :: Bitmap -> Bitmap +reverse bits = unoptimised C.reverse bits + +foldl :: (a -> Bool -> a) -> a -> Bitmap -> 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)) + +foldr :: (Bool -> a -> a) -> a -> Bitmap -> a +foldr f initialAcc vec = loop 0 + where + len = length vec + loop i + | i == len = initialAcc + | otherwise = unsafeIndex vec i `f` loop (i+1) + +foldr' :: (Bool -> a -> a) -> a -> Bitmap -> a +foldr' = foldr + +foldl' :: (a -> Bool -> a) -> a -> Bitmap -> 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)) + +unoptimised :: ([Bool] -> [Bool]) -> Bitmap -> Bitmap +unoptimised f = vFromList . f . vToList diff --git a/Foundation/Array/Boxed.hs b/Foundation/Array/Boxed.hs new file mode 100644 --- /dev/null +++ b/Foundation/Array/Boxed.hs @@ -0,0 +1,607 @@ +-- | +-- Module : Foundation.Array.Boxed +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- Simple boxed array abstraction +-- +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE UnboxedTuples #-} +module Foundation.Array.Boxed + ( Array + , MArray + ) where + +import GHC.Prim +import GHC.Types +import GHC.ST +import Foundation.Number +import Foundation.Internal.Base +import Foundation.Internal.Types +import Foundation.Primitive.Types +import Foundation.Primitive.Monad +import Foundation.Array.Common +import qualified Foundation.Collection as C +import qualified Prelude + +-- | Array of a +data Array a = Array (Array# a) + deriving (Typeable) + +-- | Mutable Array of a +data MArray a st = MArray (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 + +type instance C.Element (Array ty) = ty + +instance IsList (Array ty) where + type Item (Array ty) = ty + fromList = vFromList + toList = vToList + +instance C.InnerFunctor (Array ty) + +instance C.Sequential (Array ty) where + null = null + take = take + drop = drop + splitAt = splitAt + revTake = revTake + revDrop = revDrop + revSplitAt = revSplitAt + splitOn = splitOn + break = break + intersperse = intersperse + span = span + reverse = reverse + filter = filter + unsnoc = unsnoc + uncons = uncons + snoc = snoc + cons = cons + find = find + sortBy = sortBy + length = length + singleton = fromList . (:[]) + +instance C.MutableCollection (MArray ty) where + type Collection (MArray ty) = Array ty + type MutableKey (MArray ty) = Int + type MutableValue (MArray ty) = ty + + thaw = thaw + freeze = freeze + unsafeThaw = unsafeThaw + unsafeFreeze = unsafeFreeze + + mutUnsafeWrite = unsafeWrite + mutUnsafeRead = unsafeRead + mutWrite = write + mutRead = read + +instance C.IndexedCollection (Array ty) where + (!) l n + | n < 0 || n >= length l = Nothing + | otherwise = Just $ index l n + findIndex predicate c = loop 0 + where + !len = length c + loop i + | i == len = Nothing + | otherwise = + if predicate (unsafeIndex c i) then Just i else Nothing + +instance C.Zippable (Array ty) where + -- TODO Use an array builder once available + zipWith f a b = runST $ do + mv <- new len + go mv 0 f (toList a) (toList b) + unsafeFreeze mv + where + !len = Size $ min (C.length a) (C.length b) + go _ _ _ [] _ = return () + go _ _ _ _ [] = return () + go mv i f' (a':as') (b':bs') = do + write mv i (f' a' b') + go mv (i + 1) f' as' bs' + +instance C.BoxedZippable (Array ty) + +-- | return the numbers of elements in a mutable array +mutableLength :: MArray ty st -> Int +mutableLength (MArray ma) = I# (sizeofMutableArray# ma) +{-# INLINE mutableLength #-} + +-- | 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 -> Int -> ty +index array n + | n < 0 || n >= len = throw (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 -> Int -> ty +unsafeIndex (Array a) (I# n) = let (# v #) = indexArray# a n in v +{-# 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) -> Int -> prim ty +read array n + | n < 0 || n >= len = primThrow (OutOfBound OOB_Read n len) + | otherwise = unsafeRead array n + where len = mutableLength 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) -> Int -> prim ty +unsafeRead (MArray ma) (I# i) = primitive $ \s1 -> readArray# ma i s1 +--readArray# :: MutableArray# s a -> Int# -> State# s -> (#State# s, a#) +{-# 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) -> Int -> ty -> prim () +write array n val + | n < 0 || n >= len = primThrow (OutOfBound OOB_Write n len) + | otherwise = unsafeWrite array n val + where len = mutableLength 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) -> Int -> ty -> prim () +unsafeWrite (MArray ma) (I# i) v = primitive $ \s1 -> let !s2 = writeArray# ma i v s1 in (# s2, () #) +{-# 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 ma) = primitive $ \s1 -> + case unsafeFreezeArray# ma s1 of + (# s2, a #) -> (# s2, Array 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 a) = primitive $ \st -> (# st, MArray (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 (lengthSize array) + unsafeCopyAtRO m (Offset 0) array (Offset 0) (lengthSize array) + return 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 = Size $ mutableLength marray + +-- | 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 + -> Size ty -- ^ number of elements to copy + -> prim () +copyAt dst od src os n = loop od os + where !endIndex = os `offsetPlusE` n + loop (Offset d) s@(Offset i) + | s == endIndex = return () + | otherwise = unsafeRead src i >>= unsafeWrite dst d >> loop (Offset $ d+1) (Offset $ i+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 + -> Size ty -- ^ number of elements to copy + -> prim () +unsafeCopyAtRO dst od src os n = loop od os + where !endIndex = os `offsetPlusE` n + loop (Offset d) s@(Offset i) + | s == endIndex = return () + | otherwise = unsafeWrite dst d (unsafeIndex src i) >> loop (Offset $ d+1) (Offset $ i+1) + +-- | Allocate a new array with a fill function that has access to the elements of +-- the source array. +unsafeCopyFrom :: Array ty -- ^ Source array + -> Size 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 = lengthSize v' + endIdx = Offset 0 `offsetPlusE` len + fill i f' r' + | i == endIdx = return 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 => Size ty -> prim (MArray ty (PrimState prim)) +new (Size (I# n)) = primitive $ \s1 -> + case newArray# n (error "vector: internal error uninitialized vector") s1 of + (# s2, ma #) -> (# s2, MArray ma #) + +-- | Create a new array of size @n by settings each cells through the +-- function @f. +create :: Int -- ^ the size of the array + -> (Int -> ty) -- ^ the function that set the value at the index + -> Array ty -- ^ the array created +create n initializer = runST (new (Size n) >>= iter initializer) + where + iter :: PrimMonad prim => (Int -> ty) -> MArray ty (PrimState prim) -> prim (Array ty) + iter f ma = loop (Offset 0) + where + !end = Offset 0 `offsetPlusE` Size n + loop s@(Offset i) + | s == end = unsafeFreeze ma + | otherwise = unsafeWrite ma i (f i) >> loop (Offset $ i+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 -> Int +length (Array a) = I# (sizeofArray# a) + +lengthSize :: Array a -> Size a +lengthSize (Array a) = Size $ I# (sizeofArray# a) + +vFromList :: [a] -> Array a +vFromList l = runST (new len >>= loop 0 l) + where + len = Size $ C.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 = fmap (unsafeIndex v) [0..(length v - 1)] + +-- | 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) + 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 = lengthSize a + lb = lengthSize b + +concat :: [Array ty] -> Array ty +concat l = runST $ do + r <- new (Size $ Prelude.sum $ fmap length l) + loop r (Offset 0) l + unsafeFreeze r + where loop _ _ [] = return () + loop r i (x:xs) = do + mx <- unsafeThaw x + copyAt r i mx (Offset 0) lx + loop r (i `offsetPlusE` lx) xs + where lx = lengthSize 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 (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 a #) }}} + +----------------------------------------------------------------------- + + +null :: Array ty -> Bool +null = (==) 0 . length + +take :: Int -> Array ty -> Array ty +take nbElems v + | nbElems <= 0 = empty + | otherwise = runST $ do + muv <- new n + unsafeCopyAtRO muv (Offset 0) v (Offset 0) n + unsafeFreeze muv + where + n = Size $ min nbElems (length v) + +drop :: Int -> Array ty -> Array ty +drop nbElems v + | nbElems <= 0 = v + | otherwise = runST $ do + muv <- new n + unsafeCopyAtRO muv (Offset 0) v (Offset offset) n + unsafeFreeze muv + where + offset = min nbElems (length v) + n = Size (length v - offset) + +splitAt :: Int -> Array ty -> (Array ty, Array ty) +splitAt n v = (take n v, drop n v) + +revTake :: Int -> Array ty -> Array ty +revTake nbElems v = drop (length v - nbElems) v + +revDrop :: Int -> Array ty -> Array ty +revDrop nbElems v = take (length v - nbElems) v + +revSplitAt :: Int -> Array ty -> (Array ty, Array ty) +revSplitAt n v = (drop idx v, take idx v) + where idx = length v - n + +splitOn :: (ty -> Bool) -> Array ty -> [Array ty] +splitOn predicate vec + | len == Size 0 = [] + | otherwise = loop (Offset 0) (Offset 0) + where + !len = lengthSize vec + !endIdx = Offset 0 `offsetPlusE` len + loop prevIdx idx@(Offset i) + | idx == endIdx = [runST $ sub vec prevIdx idx] + | otherwise = + let e = unsafeIndex vec i + idx' = idx + Offset 1 + in if predicate e + then runST (sub vec prevIdx idx) : loop idx' idx' + else loop prevIdx idx' + +sub :: PrimMonad prim => Array ty -> Offset ty -> Offset ty -> prim (Array ty) +sub vec startIdx expectedEndIdx + | startIdx == endIdx = return empty + | startIdx >= sizeAsOffset len = return empty + | otherwise = new sz >>= loop startIdx (Offset 0) + where + !len = lengthSize vec + loop os@(Offset s) od@(Offset d) mv + | os == endIdx = unsafeFreeze mv + | otherwise = unsafeWrite mv d (unsafeIndex vec s) >> loop (os+Offset 1) (od+Offset 1) mv + !sz = endIdx - startIdx + !endIdx = min expectedEndIdx (sizeAsOffset $ lengthSize vec) + +break :: (ty -> Bool) -> Array ty -> (Array ty, Array ty) +break predicate v = findBreak 0 + where + findBreak i + | i == length v = (v, empty) + | otherwise = + if predicate (unsafeIndex v i) + then splitAt i v + else findBreak (i+1) + +intersperse :: ty -> Array ty -> Array ty +intersperse sep v + | len <= Size 1 = v + | otherwise = runST $ unsafeCopyFrom v ((len + len) - Size 1) (go (Offset 0 `offsetPlusE` (len - Size 1)) sep) + where len = lengthSize v + -- terminate 1 before the end + + go :: Offset ty -> ty -> Array ty -> Offset ty -> MArray ty s -> ST s () + go endI sep' oldV oldI@(Offset oi) newV + | oldI == endI = unsafeWrite newV dst e + | otherwise = do + unsafeWrite newV dst e + unsafeWrite newV (dst + 1) sep' + where + e = unsafeIndex oldV oi + (Offset 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 (length a) (\i -> f $ unsafeIndex a i) + +{- +mapIndex :: (Int -> a -> b) -> Array a -> Array b +mapIndex f a = create (length a) (\i -> f i $ unsafeIndex a i) +-} + +cons :: ty -> Array ty -> Array ty +cons e vec + | len == Size 0 = C.singleton e + | otherwise = runST $ do + mv <- new (len + Size 1) + unsafeWrite mv 0 e + unsafeCopyAtRO mv (Offset 1) vec (Offset 0) len + unsafeFreeze mv + where + !len = lengthSize vec + +snoc :: Array ty -> ty -> Array ty +snoc vec e + | len == Size 0 = C.singleton e + | otherwise = runST $ do + mv <- new (len + Size 1) + unsafeCopyAtRO mv (Offset 0) vec (Offset 0) len + unsafeWrite mv lastI e + unsafeFreeze mv + where + !len@(Size lastI) = lengthSize 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 (len-1)) + where + !len = length vec + +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 :: (ty -> ty -> Ordering) -> Array ty -> Array ty +sortBy xford vec = 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 (len - 1) >> unsafeFreeze ma + where + qsort lo hi + | lo >= hi = return () + | otherwise = do + p <- partition lo hi + qsort lo (p-1) + qsort (p+1) hi + partition lo hi = do + pivot <- unsafeRead ma hi + let loop i j + | j == hi = return i + | otherwise = do + aj <- unsafeRead ma j + i' <- if ford aj pivot == GT + then return i + else do + ai <- unsafeRead ma i + unsafeWrite ma j ai + unsafeWrite ma i aj + return $ 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 + return i + +filter :: (ty -> Bool) -> Array ty -> Array ty +filter predicate vec = runST (new len >>= copyFilterFreeze predicate (unsafeIndex vec)) + where + !len = lengthSize vec + !end = Offset 0 `offsetPlusE` len + copyFilterFreeze :: PrimMonad prim => (ty -> Bool) -> (Int -> ty) -> MArray ty (PrimState prim) -> prim (Array ty) + copyFilterFreeze predi getVec mvec = loop (Offset 0) (Offset 0) >>= freezeUntilIndex mvec + where + loop d@(Offset di) s@(Offset si) + | s == end = return d + | predi v = unsafeWrite mvec di v >> loop (d+Offset 1) (s+Offset 1) + | otherwise = loop d (s+Offset 1) + where + v = getVec si + +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 + +reverse :: Array ty -> Array ty +reverse a = create len toEnd + where + len = length a + toEnd i = unsafeIndex a (len - i - 1) diff --git a/Foundation/Array/Common.hs b/Foundation/Array/Common.hs new file mode 100644 --- /dev/null +++ b/Foundation/Array/Common.hs @@ -0,0 +1,46 @@ +-- | +-- Module : Foundation.Array.Common +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- Common part for vectors +-- +{-# LANGUAGE DeriveDataTypeable #-} +module Foundation.Array.Common + ( OutOfBound(..) + , OutOfBoundOperation(..) + + , InvalidRecast(..) + , RecastSourceSize(..) + , RecastDestinationSize(..) + ) where + +import Foundation.Internal.Base + +-- | 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_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 + +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/Array/Internal.hs b/Foundation/Array/Internal.hs new file mode 100644 --- /dev/null +++ b/Foundation/Array/Internal.hs @@ -0,0 +1,20 @@ +-- | +-- Module : Foundation.Array.Internal +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- Give access to Array non public functions which +-- can be used to make certains optimisations. +-- +-- Most of what is available here has no guarantees of stability. +-- Anything can be removed and changed. +-- +module Foundation.Array.Internal + ( UArray(..) + , fromForeignPtr + , recast + ) where + +import Foundation.Array.Unboxed diff --git a/Foundation/Array/Unboxed.hs b/Foundation/Array/Unboxed.hs new file mode 100644 --- /dev/null +++ b/Foundation/Array/Unboxed.hs @@ -0,0 +1,807 @@ +-- | +-- Module : Foundation.Array.Unboxed +-- 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 ViewPatterns #-} +module Foundation.Array.Unboxed + ( UArray(..) + , PrimType(..) + -- * methods + , copy + , unsafeCopyAtRO + -- * internal methods + -- , copyAddr + , recast + , unsafeRecast + , length + , lengthSize + , freeze + , unsafeFreeze + , thaw + , unsafeThaw + -- * Creation + , new + , empty + , create + , createFromIO + , sub + , withPtr + , withMutablePtr + , unsafeFreezeShrink + , freezeShrink + , unsafeSlide + -- * accessors + , update + , unsafeUpdate + , unsafeIndex + , unsafeIndexer + , unsafeRead + , unsafeWrite + -- * Functions + , map + , mapIndex + , findIndex + , index + , null + , take + , drop + , splitAt + , revDrop + , revTake + , revSplitAt + , splitOn + , splitElem + , break + , breakElem + , intersperse + , span + , cons + , snoc + , uncons + , unsnoc + , find + , sortBy + , filter + , reverse + , foldl + , foldr + , foldl' + , foreignMem + , fromForeignPtr + ) where + +import GHC.Prim +import GHC.Types +import GHC.Word +import GHC.ST +import GHC.Ptr +import GHC.ForeignPtr (ForeignPtr) +import qualified Prelude +import Foundation.Internal.Base +import Foundation.Internal.Primitive +import Foundation.Internal.Proxy +import Foundation.Internal.Types +import Foundation.Primitive.Monad +import Foundation.Primitive.Types +import Foundation.Primitive.FinalPtr +import Foundation.Primitive.Utils +import Foundation.Array.Common +import Foundation.Array.Unboxed.Mutable +import Foundation.Number +import qualified Data.List + +-- | 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 = + UVecBA {-# UNPACK #-} !(Offset ty) + {-# UNPACK #-} !(Size ty) + {-# UNPACK #-} !PinnedStatus {- unpinned / pinned flag -} + ByteArray# + | UVecAddr {-# UNPACK #-} !(Offset ty) + {-# UNPACK #-} !(Size ty) + !(FinalPtr ty) + +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 + 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 + +vectorProxyTy :: UArray ty -> Proxy ty +vectorProxyTy _ = Proxy + +-- | 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 (lengthSize array) + unsafeCopyAtRO ma azero array (Offset 0) (lengthSize array) + return 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 -> Int -> ty +index array n + | n < 0 || n >= len = throw (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 :: PrimType ty => UArray ty -> Int -> ty +unsafeIndex (UVecBA start _ _ ba) n = primBaIndex ba (start + Offset n) +unsafeIndex v@(UVecAddr start _ fptr) n = withUnsafeFinalPtr fptr (primAddrIndex' v start) + where + primAddrIndex' :: PrimType ty => UArray ty -> Offset ty -> Ptr a -> IO ty + primAddrIndex' _ start' (Ptr addr) = return (primAddrIndex addr (start' + Offset n)) +{-# INLINE unsafeIndex #-} + +unsafeIndexer :: (PrimMonad prim, PrimType ty) => UArray ty -> ((Offset ty -> ty) -> prim a) -> prim a +unsafeIndexer (UVecBA start _ _ ba) f = f (\n -> primBaIndex ba (start + n)) +unsafeIndexer (UVecAddr start _ fptr) f = withFinalPtr fptr (\ptr -> f (primAddrIndex' start ptr)) + where + primAddrIndex' :: PrimType ty => Offset ty -> Ptr a -> (Offset ty -> ty) + primAddrIndex' start' (Ptr addr) = \n -> primAddrIndex addr (start' + n) + {-# INLINE primAddrIndex' #-} +{-# NOINLINE unsafeIndexer #-} + +{-# SPECIALIZE [3] unsafeIndexer :: UArray Word8 -> ((Offset Word8 -> Word8) -> ST s a) -> ST s a #-} + +foreignMem :: PrimType ty + => FinalPtr ty -- ^ the start pointer with a finalizer + -> Int -- ^ the number of elements (in elements, not bytes) + -> UArray ty +foreignMem fptr nb = UVecAddr (Offset 0) (Size nb) 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) = UVecAddr (Offset ofs) (Size len) (toFinalPtrForeign fptr) + +-- | return the number of elements of the array. +length :: PrimType ty => UArray ty -> Int +length a = let (Size len) = lengthSize a in len +{-# INLINE[1] length #-} + +lengthSize :: PrimType ty => UArray ty -> Size ty +lengthSize (UVecAddr _ len _) = len +lengthSize (UVecBA _ len _ _) = len +{-# INLINE[1] lengthSize #-} + +-- 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 :: (PrimMonad prim, PrimType ty) + => MUArray ty (PrimState prim) -- ^ destination array + -> Offset ty -- ^ offset at destination + -> UArray ty -- ^ source array + -> Offset ty -- ^ offset at source + -> Size ty -- ^ number of elements to copy + -> prim () +unsafeCopyAtRO (MUVecMA dstStart _ _ dstMba) ed uvec@(UVecBA srcStart _ _ srcBa) es n = + primitive $ \st -> (# copyByteArray# srcBa os dstMba od nBytes st, () #) + where + sz = primSizeInBytes (vectorProxyTy uvec) + !(Offset (I# os)) = offsetOfE sz (srcStart+es) + !(Offset (I# od)) = offsetOfE sz (dstStart+ed) + !(Size (I# nBytes)) = sizeOfE sz n +unsafeCopyAtRO (MUVecMA dstStart _ _ dstMba) ed uvec@(UVecAddr srcStart _ srcFptr) es n = + withFinalPtr srcFptr $ \srcPtr -> + let !(Ptr srcAddr) = srcPtr `plusPtr` os + in primitive $ \s -> (# compatCopyAddrToByteArray# srcAddr dstMba od nBytes s, () #) + where + sz = primSizeInBytes (vectorProxyTy uvec) + !(Offset os) = offsetOfE sz (srcStart+es) + !(Offset (I# od)) = offsetOfE sz (dstStart+ed) + !(Size (I# nBytes)) = sizeOfE sz n +unsafeCopyAtRO dst od src os n = loop od os + where + !(Offset endIndex) = os `offsetPlusE` n + loop (Offset d) (Offset i) + | i == endIndex = return () + | otherwise = unsafeWrite dst d (unsafeIndex src i) >> loop (Offset $ d+1) (Offset $ i+1) + +-- | Allocate a new array with a fill function that has access to the elements of +-- the source array. +unsafeCopyFrom :: PrimType ty + => UArray ty -- ^ Source array + -> Int -- ^ Length of the destination array + -> (UArray ty -> Int -> MUArray ty s -> ST s ()) + -- ^ Function called for each element in the source array + -> ST s (UArray ty) -- ^ Returns the filled new array +unsafeCopyFrom v' newLen f = new (Size newLen) >>= fill 0 f >>= unsafeFreeze + where len = length v' + fill i f' r' + | i == len = return r' + | otherwise = do f' v' i r' + fill (i + 1) f' r' + +-- | 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 (MUVecMA start len pinnedState mba) = primitive $ \s1 -> + case unsafeFreezeByteArray# mba s1 of + (# s2, ba #) -> (# s2, UVecBA start len pinnedState ba #) +unsafeFreeze (MUVecAddr start len fptr) = return $ UVecAddr start len fptr +{-# INLINE unsafeFreeze #-} + +unsafeFreezeShrink :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> Size ty -> prim (UArray ty) +unsafeFreezeShrink (MUVecMA start _ pinnedState mba) n = unsafeFreeze (MUVecMA start n pinnedState mba) +unsafeFreezeShrink (MUVecAddr start _ fptr) n = unsafeFreeze (MUVecAddr start n fptr) + +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 = Size $ mutableLength ma + +freezeShrink :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> Int -> prim (UArray ty) +freezeShrink ma n = do + ma' <- new (Size n) + copyAt ma' (Offset 0) ma (Offset 0) (Size n) + unsafeFreeze ma' + +unsafeSlide :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> Int -> Int -> prim () +unsafeSlide mua s e = doSlide mua (Offset s) (Offset e) + where + doSlide :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> Offset ty -> Offset ty -> prim () + doSlide (MUVecMA mbStart _ _ mba) start end = + primMutableByteArraySlideToStart mba (primOffsetOfE $ mbStart+start) (primOffsetOfE end) + doSlide (MUVecAddr mbStart _ fptr) start end = withFinalPtr fptr $ \(Ptr addr) -> + primMutableAddrSlideToStart addr (primOffsetOfE $ mbStart+start) (primOffsetOfE end) + +-- | 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 (UVecBA start len pinnedState ba) = primitive $ \st -> (# st, MUVecMA start len pinnedState (unsafeCoerce# ba) #) +unsafeThaw (UVecAddr start len fptr) = return $ MUVecAddr start len fptr +{-# INLINE unsafeThaw #-} + +-- | Create a new array of size @n by settings each cells through the +-- function @f. +create :: PrimType ty + => Int -- ^ the size of the array + -> (Int -> ty) -- ^ the function that set the value at the index + -> UArray ty -- ^ the array created +create n initializer + | n == 0 = empty + | otherwise = runST (new (Size n) >>= iter initializer) + where + iter :: (PrimType ty, PrimMonad prim) => (Int -> 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 + => Int -- ^ the size of the array + -> (Ptr ty -> IO Int) -- ^ filling function that + -> IO (UArray ty) +createFromIO size filler + | size == 0 = return empty + | otherwise = do + mba <- newPinned (Size size) + r <- withMutablePtr mba $ \p -> filler p + case r of + 0 -> return empty -- make sure we don't keep our array referenced by using empty + _ | r < 0 -> error "filler returned negative number" + | otherwise -> unsafeFreezeShrink mba (Size r) + +----------------------------------------------------------------------- +-- higher level collection implementation +----------------------------------------------------------------------- + +empty :: PrimType ty => UArray ty +empty = UVecAddr (Offset 0) (Size 0) (FinalPtr $ error "empty de-referenced") + +singleton :: PrimType ty => ty -> UArray ty +singleton ty = create 1 (\_ -> ty) + +-- | make an array from a list of elements. +vFromList :: PrimType ty => [ty] -> UArray ty +vFromList l = runST $ do + ma <- new (Size len) + iter 0 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 an array to a list. +vToList :: PrimType ty => UArray ty -> [ty] +vToList a + | null a = [] + | otherwise = runST (unsafeIndexer a go) + where + !len = length a + go :: (Offset ty -> ty) -> ST s [ty] + go getIdx = return $ loop azero + where + loop i | i == Offset len = [] + | otherwise = getIdx i : loop (i+Offset 1) + {-# INLINE go #-} + +-- | Check if two vectors are identical +equal :: (PrimType ty, Eq ty) => UArray ty -> UArray ty -> Bool +equal a b + | la /= lb = False + | otherwise = loop 0 + where + !la = length a + !lb = length b + loop n | n == la = True + | otherwise = (unsafeIndex a n == unsafeIndex b n) && loop (n+1) + +{- +sizeEqual :: PrimType ty => UArray ty -> UArray ty -> Bool +sizeEqual a b = length a == length b -- TODO optimise with direct comparaison of bytes or elements when possible +-} + +-- | Compare 2 vectors +vCompare :: (Ord ty, PrimType ty) => UArray ty -> UArray ty -> 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 + +-- | 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 = lengthSize a + !lb = lengthSize b + +concat :: PrimType ty => [UArray ty] -> UArray ty +concat [] = empty +concat l = + case filterAndSum (Size 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, Prelude.reverse acc) + filterAndSum !totalLen acc (x:xs) + | len == Size 0 = filterAndSum totalLen acc xs + | otherwise = filterAndSum (len+totalLen) (x:acc) xs + where len = lengthSize x + + doCopy _ _ [] = return () + doCopy r i (x:xs) = do + unsafeCopyAtRO r i x (Offset 0) lx + doCopy r (i `offsetPlusE` lx) xs + where lx = lengthSize x + +-- | 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 + -> [(Int, 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 + -> [(Int, 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 #-} + +withPtr :: PrimType ty + => UArray ty + -> (Ptr ty -> IO a) + -> IO a +withPtr vec@(UVecAddr start _ fptr) f = + withFinalPtr fptr (\ptr -> f (ptr `plusPtr` os)) + where + sz = primSizeInBytes (vectorProxyTy vec) + !(Offset os) = offsetOfE sz start +withPtr vec@(UVecBA start _ pstatus a) f + | isPinned pstatus = f (Ptr (byteArrayContents# a) `plusPtr` os) + | otherwise = do + -- TODO don't copy the whole vector, and just allocate+copy the slice. + let !sz# = sizeofByteArray# a + a' <- primitive $ \s -> do + case newAlignedPinnedByteArray# sz# 8# s of { (# s2, mba #) -> + case copyByteArray# a 0# mba 0# sz# s2 of { s3 -> + case unsafeFreezeByteArray# mba s3 of { (# s4, ba #) -> + (# s4, Ptr (byteArrayContents# ba) `plusPtr` os #) }}} + f a' + where + sz = primSizeInBytes (vectorProxyTy vec) + !(Offset os) = offsetOfE sz start + +withMutablePtr :: PrimType ty + => MUArray ty RealWorld + -> (Ptr ty -> IO a) + -> IO a +withMutablePtr muvec f = do + v <- unsafeFreeze muvec + withPtr v f + +recast :: (PrimType a, PrimType b) => UArray a -> UArray b +recast = recast_ Proxy Proxy + where + recast_ :: (PrimType a, PrimType b) + => Proxy a -> Proxy b -> UArray a -> UArray b + recast_ pa pb array + | aTypeSize == bTypeSize = unsafeRecast array + | missing == 0 = unsafeRecast array + | otherwise = throw $ InvalidRecast + (RecastSourceSize alen) + (RecastDestinationSize $ alen + missing) + where + aTypeSize@(Size as) = primSizeInBytes pa + bTypeSize@(Size bs) = primSizeInBytes pb + alen = length array * as + missing = alen `mod` bs + +unsafeRecast :: (PrimType a, PrimType b) => UArray a -> UArray b +unsafeRecast (UVecBA start len pinStatus b) = UVecBA (primOffsetRecast start) (sizeRecast len) pinStatus b +unsafeRecast (UVecAddr start len a) = UVecAddr (primOffsetRecast start) (sizeRecast len) (castFinalPtr a) + +null :: UArray ty -> Bool +null (UVecBA _ sz _ _) = sz == Size 0 +null (UVecAddr _ l _) = l == Size 0 + +take :: PrimType ty => Int -> UArray ty -> UArray ty +take nbElems v + | nbElems <= 0 = empty + | n == vlen = v + | otherwise = + case v of + UVecBA start _ pinst ba -> UVecBA start n pinst ba + UVecAddr start _ fptr -> UVecAddr start n fptr + where + n = min (Size nbElems) vlen + vlen = lengthSize v + +drop :: PrimType ty => Int -> UArray ty -> UArray ty +drop nbElems v + | nbElems <= 0 = v + | n == vlen = empty + | otherwise = + case v of + UVecBA start len pinst ba -> UVecBA (start `offsetPlusE` n) (len - n) pinst ba + UVecAddr start len fptr -> UVecAddr (start `offsetPlusE` n) (len - n) fptr + where + n = min (Size nbElems) vlen + vlen = lengthSize v + +splitAt :: PrimType ty => Int -> UArray ty -> (UArray ty, UArray ty) +splitAt nbElems v + | nbElems <= 0 = (empty, v) + | n == Size vlen = (v, empty) + | otherwise = + case v of + UVecBA start len pinst ba -> ( UVecBA start n pinst ba + , UVecBA (start `offsetPlusE` n) (len - n) pinst ba) + UVecAddr start len fptr -> ( UVecAddr start n fptr + , UVecAddr (start `offsetPlusE` n) (len - n) fptr) + where + n = Size $ min nbElems vlen + vlen = length v + +splitElem :: PrimType ty => ty -> UArray ty -> (# UArray ty, UArray ty #) +splitElem !ty r@(UVecBA start len pinst ba) + | k == end = (# r, empty #) + | k == start = (# empty, r #) + | otherwise = + (# UVecBA start (offsetAsSize k) pinst ba + , UVecBA (start `offsetPlusE` (offsetAsSize k)) (len - offsetAsSize k) pinst ba + #) + where + !end = start `offsetPlusE` len + !k = loop start + loop !i | i < end && t /= ty = loop (i+Offset 1) + | otherwise = i + where !t = primBaIndex ba i +splitElem ty r@(UVecAddr start len fptr) + | k == end = (# r, empty #) + | otherwise = + (# UVecAddr start (offsetAsSize k) fptr + , UVecAddr (start `offsetPlusE` offsetAsSize k) (len - offsetAsSize k) fptr #) + where + !(Ptr addr) = withFinalPtrNoTouch fptr id + !end = start `offsetPlusE` len + !k = loop start + loop !i | i < end && t /= ty = loop (i+Offset 1) + | otherwise = i + where t = primAddrIndex addr i +{-# SPECIALIZE [3] splitElem :: Word8 -> UArray Word8 -> (# UArray Word8, UArray Word8 #) #-} +{-# SPECIALIZE [3] splitElem :: Word32 -> UArray Word32 -> (# UArray Word32, UArray Word32 #) #-} + +revTake :: PrimType ty => Int -> UArray ty -> UArray ty +revTake nbElems v = drop (length v - nbElems) v + +revDrop :: PrimType ty => Int -> UArray ty -> UArray ty +revDrop nbElems v = take (length v - nbElems) v + +revSplitAt :: PrimType ty => Int -> UArray ty -> (UArray ty, UArray ty) +revSplitAt n v = (drop idx v, take idx v) + where idx = length v - n + +splitOn :: PrimType ty => (ty -> Bool) -> UArray ty -> [UArray ty] +splitOn xpredicate ivec + | len == 0 = [] + | otherwise = runST $ unsafeIndexer ivec (go ivec xpredicate) + where + !len = length ivec + go :: PrimType ty => UArray ty -> (ty -> Bool) -> (Offset ty -> ty) -> ST s [UArray ty] + go v predicate getIdx = return (loop azero azero) + where + loop !prevIdx@(Offset prevIdxo) !idx@(Offset idxo) + | idx == Offset len = [sub v prevIdxo idxo] + | otherwise = + let e = getIdx idx + idx' = idx + Offset 1 + in if predicate e + then sub v prevIdxo idxo : loop idx' idx' + else loop prevIdx idx' + {-# INLINE go #-} + +sub :: PrimType ty => UArray ty -> Int -> Int -> UArray ty +sub vec startIdx expectedEndIdx + | startIdx >= endIdx = empty + | otherwise = + case vec of + UVecBA start _ pinst ba -> UVecBA (start + Offset startIdx) newLen pinst ba + UVecAddr start _ fptr -> UVecAddr (start + Offset startIdx) newLen fptr + where + newLen = Offset endIdx - Offset startIdx + endIdx = min expectedEndIdx len + len = length vec + +findIndex :: PrimType ty => ty -> UArray ty -> Maybe Int +findIndex tyOuter ba = runST $ unsafeIndexer ba (go tyOuter) + where + !len = length ba + + go :: PrimType ty => ty -> (Offset ty -> ty) -> ST s (Maybe Int) + go ty getIdx = loop (Offset 0) + where + loop ofs@(Offset i) + | ofs == Offset len = return Nothing + | getIdx ofs == ty = return $ Just i + | otherwise = loop (ofs + Offset 1) +{-# SPECIALIZE [3] findIndex :: Word8 -> UArray Word8 -> Maybe Int #-} + +break :: PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty) +break xpredicate xv + | len == 0 = (empty, empty) + | 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 = return (findBreak $ Offset 0) + where + findBreak !i@(Offset io) + | i == Offset len = (v, empty) + | predicate (getIdx i) = splitAt io 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 #-} + +breakElem :: PrimType ty => ty -> UArray ty -> (UArray ty, UArray ty) +breakElem xelem xv = let (# v1, v2 #) = splitElem xelem xv in (v1, v2) +{-# SPECIALIZE [2] breakElem :: Word8 -> UArray Word8 -> (UArray Word8, UArray Word8) #-} +{-# SPECIALIZE [2] breakElem :: Word32 -> UArray Word32 -> (UArray Word32, UArray Word32) #-} + +intersperse :: PrimType ty => ty -> UArray ty -> UArray ty +intersperse sep v + | len <= 1 = v + | otherwise = runST $ unsafeCopyFrom v (len * 2 - 1) (go sep) + where len = length v + go :: PrimType ty => ty -> UArray ty -> Int -> 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 = oldI * 2 + +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 (length a) (\i -> f $ unsafeIndex a i) + +mapIndex :: (PrimType a, PrimType b) => (Int -> a -> b) -> UArray a -> UArray b +mapIndex f a = create (length a) (\i -> f i $ unsafeIndex a i) + +cons :: PrimType ty => ty -> UArray ty -> UArray ty +cons e vec + | len == Size 0 = singleton e + | otherwise = runST $ do + muv <- new (len + Size 1) + unsafeCopyAtRO muv (Offset 1) vec (Offset 0) len + unsafeWrite muv 0 e + unsafeFreeze muv + where + !len = lengthSize vec + +snoc :: PrimType ty => UArray ty -> ty -> UArray ty +snoc vec e + | len == Size 0 = singleton e + | otherwise = runST $ do + muv <- new (len + Size 1) + unsafeCopyAtRO muv (Offset 0) vec (Offset 0) len + unsafeWrite muv (length vec) e + unsafeFreeze muv + where + !len = lengthSize vec + +uncons :: PrimType ty => UArray ty -> Maybe (ty, UArray ty) +uncons vec + | nbElems == 0 = Nothing + | otherwise = Just (unsafeIndex vec 0, sub vec 1 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 = 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 :: PrimType ty => (ty -> ty -> Ordering) -> UArray ty -> UArray ty +sortBy xford vec = 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 (len - 1) >> unsafeFreeze ma + where + qsort lo hi + | lo >= hi = return () + | otherwise = do + p <- partition lo hi + qsort lo (p-1) + qsort (p+1) hi + partition lo hi = do + pivot <- unsafeRead ma hi + let loop i j + | j == hi = return i + | otherwise = do + aj <- unsafeRead ma j + i' <- if ford aj pivot == GT + then return i + else do + ai <- unsafeRead ma i + unsafeWrite ma j ai + unsafeWrite ma i aj + return $ 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 + return i + +filter :: PrimType ty => (ty -> Bool) -> UArray ty -> UArray ty +filter predicate vec = vFromList $ Data.List.filter predicate $ vToList vec + +reverse :: PrimType ty => UArray ty -> UArray ty +reverse a = create len toEnd + where + len = length a + toEnd i = unsafeIndex a (len - i - 1) + +foldl :: PrimType ty => (a -> ty -> a) -> a -> UArray 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)) + +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 vec = loop 0 initialAcc + where + len = length vec + loop i !acc + | i == len = acc + | otherwise = loop (i+1) (f acc (unsafeIndex vec i)) diff --git a/Foundation/Array/Unboxed/Builder.hs b/Foundation/Array/Unboxed/Builder.hs new file mode 100644 --- /dev/null +++ b/Foundation/Array/Unboxed/Builder.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Foundation.Array.Unboxed.Builder + ( ArrayBuilder + , appendTy + , build + ) where + +import Foundation.Array.Unboxed +import Foundation.Array.Unboxed.Mutable +import Foundation.Internal.Base +import Foundation.Internal.MonadTrans +import Foundation.Internal.Types +import Foundation.Number +import Foundation.Primitive.Monad +import Foundation.Primitive.Types +import qualified Data.List + +-- | A Array being built chunks by chunks +-- +-- The previous buffers are in reverse order, and +-- this contains the current buffer and the state of +-- progress packing ty inside. +data ArrayBuildingState ty st = ArrayBuildingState + { prevBuffers :: [UArray ty] + , currentBuffer :: MUArray ty st + , currentOffset :: !(Offset ty) + , chunkSize :: !(Size ty) + } + +newtype ArrayBuilder ty st a = ArrayBuilder { runArrayBuilder :: State (ArrayBuildingState ty (PrimState st)) st a } + deriving (Functor,Applicative,Monad) + +appendTy :: (PrimMonad st, PrimType ty, Monad st) => ty -> ArrayBuilder ty st () +appendTy v = ArrayBuilder $ State $ \st -> + if offsetAsSize (currentOffset st) == chunkSize st + then do + newChunk <- new (chunkSize st) + cur <- unsafeFreeze (currentBuffer st) + write newChunk 0 v + return ((), st { prevBuffers = cur : prevBuffers st + , currentOffset = Offset 1 + , currentBuffer = newChunk + }) + else do + let (Offset ofs) = currentOffset st + write (currentBuffer st) ofs v + return ((), st { currentOffset = currentOffset st + Offset 1 }) + +build :: (PrimMonad prim, PrimType ty) + => Int -- ^ size of chunks (elements) + -> ArrayBuilder ty prim () -- ^ .. + -> prim (UArray ty) +build sizeChunksI origab = call origab (Size sizeChunksI) + where + call :: (PrimType ty, PrimMonad prim) + => ArrayBuilder ty prim () -> Size ty -> prim (UArray ty) + call ab sizeChunks = do + m <- new sizeChunks + ((), st) <- runState (runArrayBuilder ab) (ArrayBuildingState [] m (Offset 0) sizeChunks) + current <- unsafeFreezeShrink (currentBuffer st) (offsetAsSize $ currentOffset st) + return $ mconcat $ Data.List.reverse (current:prevBuffers st) diff --git a/Foundation/Array/Unboxed/ByteArray.hs b/Foundation/Array/Unboxed/ByteArray.hs new file mode 100644 --- /dev/null +++ b/Foundation/Array/Unboxed/ByteArray.hs @@ -0,0 +1,37 @@ +module Foundation.Array.Unboxed.ByteArray + ( MutableByteArray + , mutableByteArraySet + , mutableByteArraySetBetween + , mutableByteArrayMove + ) where + +import Foundation.Internal.Base +import Foundation.Primitive.Monad +import Foundation.Array.Common +import Foundation.Array.Unboxed.Mutable +import Foundation.Number +import Control.Monad (forM_) +import qualified Foundation.Collection as C + +-- | 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..(len-1)] $ \i -> C.mutUnsafeWrite mba i val + where + len = mutableLength mba + +mutableByteArraySetBetween :: PrimMonad prim => MUArray Word8 (PrimState prim) -> Word8 -> Int -> Int -> prim () +mutableByteArraySetBetween mba val offset size + | offset < 0 = throw (OutOfBound OOB_MemSet offset len) + | offset > len || offset+size > len = throw (OutOfBound OOB_MemSet (offset+size) len) + | otherwise = + -- TODO same as mutableByteArraySet + forM_ [offset..(offset+size-1)] $ \i -> C.mutUnsafeWrite mba i val + where + len = mutableLength 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 new file mode 100644 --- /dev/null +++ b/Foundation/Array/Unboxed/Mutable.hs @@ -0,0 +1,212 @@ +-- | +-- 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 #-} +module Foundation.Array.Unboxed.Mutable + ( MUArray(..) + -- * Property queries + , sizeInMutableBytesOfContent + , mutableLength + , mutableSame + -- * Allocation & Copy + , new + , newPinned + , newNative + , mutableForeignMem + , copyAt + -- , copyAddr + -- * Reading and Writing cells + , unsafeWrite + , unsafeRead + , write + , read + ) where + +import GHC.Prim +import GHC.Types +import GHC.Ptr +import Foundation.Internal.Base +import Foundation.Internal.Types +import Foundation.Internal.Primitive +import Foundation.Internal.Proxy +import Foundation.Primitive.Monad +import Foundation.Primitive.Types +import Foundation.Primitive.FinalPtr +import Foundation.Array.Common +import Foundation.Number +-- import Foreign.Marshal.Utils (copyBytes) + +-- | A Mutable array of types built on top of GHC primitive. +-- +-- Element in this array can be modified in place. +data MUArray ty st = + MUVecMA {-# UNPACK #-} !(Offset ty) + {-# UNPACK #-} !(Size ty) + {-# UNPACK #-} !PinnedStatus + (MutableByteArray# st) + | MUVecAddr {-# UNPACK #-} !(Offset ty) + {-# UNPACK #-} !(Size ty) + !(FinalPtr ty) + +mutableArrayProxyTy :: MUArray ty st -> Proxy ty +mutableArrayProxyTy _ = Proxy + +sizeInMutableBytesOfContent :: PrimType ty => MUArray ty s -> Size8 +sizeInMutableBytesOfContent = primSizeInBytes . mutableArrayProxyTy +{-# 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) -> Int -> prim ty +read array n + | n < 0 || n >= len = primThrow (OutOfBound OOB_Read n len) + | otherwise = unsafeRead array n + where len = mutableLength 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, PrimType ty) => MUArray ty (PrimState prim) -> Int -> prim ty +unsafeRead (MUVecMA start _ _ mba) i = primMbaRead mba (start+.i) +unsafeRead (MUVecAddr start _ fptr) i = withFinalPtr fptr $ \(Ptr addr) -> primAddrRead addr (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, PrimType ty) => MUArray ty (PrimState prim) -> Int -> ty -> prim () +write array n val + | n < 0 || n >= len = primThrow (OutOfBound OOB_Write n len) + | otherwise = unsafeWrite array n val + where + len = mutableLength 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, PrimType ty) => MUArray ty (PrimState prim) -> Int -> ty -> prim () +unsafeWrite (MUVecMA start _ _ mba) i v = primMbaWrite mba (start+.i) v +unsafeWrite (MUVecAddr start _ fptr) i v = withFinalPtr fptr $ \(Ptr addr) -> primAddrWrite addr (start+.i) v +{-# INLINE unsafeWrite #-} + +-- | 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 :: (PrimMonad prim, PrimType ty) => Size ty -> prim (MUArray ty (PrimState prim)) +newPinned n = newFake n Proxy + where newFake :: (PrimMonad prim, PrimType ty) => Size ty -> Proxy ty -> prim (MUArray ty (PrimState prim)) + newFake sz ty = primitive $ \s1 -> + case newAlignedPinnedByteArray# bytes 8# s1 of + (# s2, mba #) -> (# s2, MUVecMA (Offset 0) sz pinned mba #) + where + !(Size (I# bytes)) = sizeOfE (primSizeInBytes ty) sz + {-# INLINE newFake #-} +{-# INLINE new #-} + +newUnpinned :: (PrimMonad prim, PrimType ty) => Size ty -> prim (MUArray ty (PrimState prim)) +newUnpinned n = newFake n Proxy + where newFake :: (PrimMonad prim, PrimType ty) => Size ty -> Proxy ty -> prim (MUArray ty (PrimState prim)) + newFake sz ty = primitive $ \s1 -> + case newByteArray# bytes s1 of + (# s2, mba #) -> (# s2, MUVecMA (Offset 0) sz unpinned mba #) + where + !(Size (I# bytes)) = sizeOfE (primSizeInBytes ty) sz + {-# INLINE newFake #-} + +-- | Create a new mutable array of size @n. +-- +-- TODO: heuristic to allocated unpinned (< 1K for example) +new :: (PrimMonad prim, PrimType ty) => Size ty -> prim (MUArray ty (PrimState prim)) +new sz@(Size n) + | n > 0 = newPinned sz + | otherwise = newUnpinned sz + + +mutableSame :: MUArray ty st -> MUArray ty st -> Bool +mutableSame (MUVecMA sa ea _ ma) (MUVecMA sb eb _ mb) = and [ sa == sb, ea == eb, bool# (sameMutableByteArray# ma mb)] +mutableSame (MUVecAddr s1 e1 f1) (MUVecAddr s2 e2 f2) = and [ s1 == s2, e1 == e2, finalPtrSameMemory f1 f2 ] +mutableSame (MUVecMA {}) (MUVecAddr {}) = False +mutableSame (MUVecAddr {}) (MUVecMA {}) = False + + +newNative :: (PrimMonad prim, PrimType ty) => Size ty -> (MutableByteArray# (PrimState prim) -> prim ()) -> prim (MUArray ty (PrimState prim)) +newNative n f = do + muvec <- new n + case muvec of + (MUVecMA _ _ _ mba) -> f mba >> return muvec + (MUVecAddr {}) -> error "internal error: unboxed new only supposed to allocate natively" + +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 = return $ MUVecAddr (Offset 0) (Size nb) fptr + +-- | Copy a number of elements from an array to another array with offsets +copyAt :: (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 + -> Size ty -- ^ number of elements to copy + -> prim () +copyAt (MUVecMA dstStart _ _ dstMba) ed uvec@(MUVecMA srcStart _ _ srcBa) es n = + primitive $ \st -> (# copyMutableByteArray# srcBa os dstMba od nBytes st, () #) + where + !sz = primSizeInBytes (mutableArrayProxyTy uvec) + !(Offset (I# os)) = offsetOfE sz (srcStart + es) + !(Offset (I# od)) = offsetOfE sz (dstStart + ed) + !(Size (I# nBytes)) = sizeOfE sz n +copyAt (MUVecMA dstStart _ _ dstMba) ed muvec@(MUVecAddr srcStart _ srcFptr) es n = + withFinalPtr srcFptr $ \srcPtr -> + let !(Ptr srcAddr) = srcPtr `plusPtr` os + in primitive $ \s -> (# compatCopyAddrToByteArray# srcAddr dstMba od nBytes s, () #) + where + !sz = primSizeInBytes (mutableArrayProxyTy muvec) + !(Offset os) = offsetOfE sz (srcStart + es) + !(Offset (I# od)) = offsetOfE sz (dstStart + ed) + !(Size (I# nBytes)) = sizeOfE sz n +copyAt dst od src os n = loop od os + where + !(Offset endIndex) = os `offsetPlusE` n + loop !(Offset d) !(Offset i) + | i == endIndex = return () + | otherwise = unsafeRead src i >>= unsafeWrite dst d >> loop (Offset $ d+1) (Offset $ i+1) + +{- +copyAddr :: (PrimMonad prim, PrimType ty) + => MUArray ty (PrimState prim) -- ^ destination array + -> Offset ty -- ^ offset at destination + -> Ptr Word8 -- ^ source ptr + -> Offset ty -- ^ offset at source + -> Size ty -- ^ number of elements to copy + -> prim () +copyAddr (MUVecMA dstStart _ _ dst) dstOfs (Ptr src) srcOfs sz = primitive $ \s -> + (# compatCopyAddrToByteArray# (plusAddr# src os) dst od sz s, () #) +copyAddr (MUVecAddr start _ fptr) od src os sz = + withFinalPtr fptr $ \dst -> + unsafePrimFromIO $ copyBytes (dst `plusPtr` od) (src `plusPtr` os) sz + --memcpy addr to addr + -} + +-- | return the numbers of elements in a mutable array +mutableLength :: PrimType ty => MUArray ty st -> Int +mutableLength (MUVecMA _ (Size end) _ _) = end +mutableLength (MUVecAddr _ (Size end) _) = end diff --git a/Foundation/Collection.hs b/Foundation/Collection.hs new file mode 100644 --- /dev/null +++ b/Foundation/Collection.hs @@ -0,0 +1,32 @@ +-- | +-- Module : Foundation.Collection +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +module Foundation.Collection + ( BoxedZippable(..) + , Element + , InnerFunctor(..) + , Foldable(..) + , Sequential(..) + , MutableCollection(..) + , IndexedCollection(..) + , KeyedCollection(..) + , Zippable(..) + ) where + +import Foundation.Collection.Element +import Foundation.Collection.Foldable +import Foundation.Collection.Indexed +import Foundation.Collection.InnerFunctor +import Foundation.Collection.Keyed +import Foundation.Collection.Mutable +import Foundation.Collection.Sequential +import Foundation.Collection.Zippable diff --git a/Foundation/Collection/Element.hs b/Foundation/Collection/Element.hs new file mode 100644 --- /dev/null +++ b/Foundation/Collection/Element.hs @@ -0,0 +1,17 @@ +-- | +-- Module : Foundation.Array.Element +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +module Foundation.Collection.Element + ( Element + ) where + +import Foundation.Array.Unboxed (UArray) + +-- | Element type of a collection +type family Element container +type instance Element [a] = a +type instance Element (UArray ty) = ty diff --git a/Foundation/Collection/Foldable.hs b/Foundation/Collection/Foldable.hs new file mode 100644 --- /dev/null +++ b/Foundation/Collection/Foldable.hs @@ -0,0 +1,56 @@ +-- | +-- Module : Foundation.Primitive.Foldable +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- A mono-morphic re-thinking of the Foldable class +-- +module Foundation.Collection.Foldable + ( Foldable(..) + ) where + +import Foundation.Internal.Base +import Foundation.Collection.Element +import qualified Data.List +import qualified Foundation.Array.Unboxed as UV + +-- | Give the ability to fold a collection on itself +class Foldable collection where + -- | Left-associative fold of a structure. + -- + -- In the case of lists, foldl, when applied to a binary operator, a starting value (typically the left-identity of the operator), and a list, reduces the list using the binary operator, from left to right: + -- + -- > foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn + -- Note that to produce the outermost application of the operator the entire input list must be traversed. This means that foldl' will diverge if given an infinite list. + -- + -- Also note that if you want an efficient left-fold, you probably want to use foldl' instead of foldl. The reason for this is that latter does not force the "inner" results (e.g. z f x1 in the above example) before applying them to the operator (e.g. to (f x2)). This results in a thunk chain O(n) elements long, which then must be evaluated from the outside-in. + foldl :: (a -> Element collection -> a) -> a -> collection -> a + + + -- | Left-associative fold of a structure but with strict application of the operator. + foldl' :: (a -> Element collection -> a) -> a -> collection -> a + + -- | Right-associative fold of a structure. + -- + -- > foldr f z [x1, x2, ..., xn] == x1 `f` (x2 `f` ... (xn `f` z)...) + foldr :: (Element collection -> a -> a) -> a -> collection -> a + + -- | Right-associative fold of a structure, but with strict application of the operator. + foldr' :: (Element collection -> a -> a) -> a -> collection -> a + foldr' f z0 xs = foldl f' id xs z0 where f' k x z = k $! f x z + +---------------------------- +-- Foldable instances +---------------------------- + +instance Foldable [a] where + foldl = Data.List.foldl + foldr = Data.List.foldr + foldl' = Data.List.foldl' + +instance UV.PrimType ty => Foldable (UV.UArray ty) where + foldl = UV.foldl + foldr = UV.foldr + foldl' = UV.foldl' diff --git a/Foundation/Collection/Indexed.hs b/Foundation/Collection/Indexed.hs new file mode 100644 --- /dev/null +++ b/Foundation/Collection/Indexed.hs @@ -0,0 +1,42 @@ +-- | +-- Module : Foundation.Array.Indexed +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +module Foundation.Collection.Indexed + ( IndexedCollection(..) + ) where + +import Foundation.Internal.Base +import Foundation.Collection.Element +import qualified Data.List +import qualified Foundation.Array.Unboxed as UV + +-- | Collection of elements that can indexed by int +class IndexedCollection c where + (!) :: c -> Int -> Maybe (Element c) + findIndex :: (Element c -> Bool) -> c -> Maybe Int + +instance IndexedCollection [a] where + (!) l n + | n < 0 = Nothing + | otherwise = case Data.List.drop n l of + [] -> Nothing + x:_ -> Just x + findIndex = Data.List.findIndex + +instance UV.PrimType ty => IndexedCollection (UV.UArray ty) where + (!) l n + | n < 0 || n >= UV.length l = Nothing + | otherwise = Just $ UV.index l n + findIndex predicate c = loop 0 + where + !len = UV.length c + loop i + | i == len = Nothing + | predicate (UV.unsafeIndex c i) = Just i + | otherwise = Nothing diff --git a/Foundation/Collection/InnerFunctor.hs b/Foundation/Collection/InnerFunctor.hs new file mode 100644 --- /dev/null +++ b/Foundation/Collection/InnerFunctor.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DefaultSignatures #-} +module Foundation.Collection.InnerFunctor + ( InnerFunctor(..) + ) where + +import Foundation.Internal.Base +import Foundation.Collection.Element +import qualified Foundation.Array.Unboxed as UV + +-- | A monomorphic functor that maps the inner values to values of the same type +class InnerFunctor c where + imap :: (Element c -> Element c) -> c -> c + default imap :: (Functor f, Element (f a) ~ a, f a ~ c) => (a -> a) -> f a -> f a + imap = fmap + +instance InnerFunctor [a] + +instance UV.PrimType ty => InnerFunctor (UV.UArray ty) where + imap = UV.map diff --git a/Foundation/Collection/Keyed.hs b/Foundation/Collection/Keyed.hs new file mode 100644 --- /dev/null +++ b/Foundation/Collection/Keyed.hs @@ -0,0 +1,26 @@ +-- | +-- Module : Foundation.Array.Keyed +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +module Foundation.Collection.Keyed + ( KeyedCollection(..) + ) where + +import Foundation.Internal.Base +import qualified Data.List + +-- | Collection of things that can be looked up by Key +class KeyedCollection c where + type Key c + type Value c + lookup :: Key c -> c -> Maybe (Value c) + +instance Eq k => KeyedCollection [(k, v)] where + type Key [(k,v)] = k + type Value [(k,v)] = v + lookup = Data.List.lookup diff --git a/Foundation/Collection/List.hs b/Foundation/Collection/List.hs new file mode 100644 --- /dev/null +++ b/Foundation/Collection/List.hs @@ -0,0 +1,60 @@ +-- | +-- Module : Foundation.Array.List +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +module Foundation.Collection.List + ( wordsWhen + , revTake + , revDrop + , revSplitAt + , uncons + , unsnoc + ) where + +import qualified Data.List +import Data.Tuple (swap) +import Foundation.Internal.Base +import Foundation.Number + +-- | Simple helper to split a list repeatly when the predicate match +wordsWhen :: (x -> Bool) -> [x] -> [[x]] +wordsWhen _ [] = [] +wordsWhen p is = loop is + where + loop s = + let (w, s') = Data.List.break p s + in case s' of + [] -> [w] + _:xs -> w : loop xs + +revTake :: Int -> [a] -> [a] +revTake n l = Data.List.drop (len - n) l + where + len = Data.List.length l + +revDrop :: Int -> [a] -> [a] +revDrop n l = Data.List.take (len - n) l + where + len = Data.List.length l + +revSplitAt :: Int -> [a] -> ([a],[a]) +revSplitAt n l = swap $ Data.List.splitAt (len - n) l + where + len = Data.List.length l + +uncons :: [a] -> Maybe (a, [a]) +uncons [] = Nothing +uncons (x:xs) = Just (x,xs) + +unsnoc :: [a] -> Maybe ([a], a) +unsnoc [] = Nothing +unsnoc [x] = Just ([], x) +unsnoc [x,y] = Just ([x], y) +unsnoc (x:xs@(_:_)) = Just $ loop [x] xs + where + loop acc [y] = (Data.List.reverse acc, y) + loop acc (y:ys) = loop (y:acc) ys + loop _ _ = error "impossible" diff --git a/Foundation/Collection/Mutable.hs b/Foundation/Collection/Mutable.hs new file mode 100644 --- /dev/null +++ b/Foundation/Collection/Mutable.hs @@ -0,0 +1,52 @@ +-- | +-- Module : Foundation.Array.Mutable +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +module Foundation.Collection.Mutable + ( MutableCollection(..) + ) where + +import Foundation.Primitive.Monad +import Foundation.Internal.Base + +import qualified Foundation.Array.Unboxed.Mutable as MUV +import qualified Foundation.Array.Unboxed as UV + +-- | Collection of things that can be made mutable, modified and then freezed into an immutable collection +class MutableCollection c where + -- unfortunately: cannot set mutUnsafeWrite to default to mutWrite .. same for read.. + {-# MINIMAL thaw, freeze, mutWrite, mutRead, mutUnsafeWrite, mutUnsafeRead #-} + type Collection c + type MutableKey c + type MutableValue c + + unsafeThaw :: PrimMonad prim => Collection c -> prim (c (PrimState prim)) + unsafeThaw = thaw + unsafeFreeze :: PrimMonad prim => c (PrimState prim) -> prim (Collection c) + unsafeFreeze = freeze + + thaw :: PrimMonad prim => Collection c -> prim (c (PrimState prim)) + freeze :: PrimMonad prim => c (PrimState prim) -> prim (Collection c) + + mutUnsafeWrite :: PrimMonad prim => c (PrimState prim) -> MutableKey c -> MutableValue c -> prim () + mutWrite :: PrimMonad prim => c (PrimState prim) -> MutableKey c -> MutableValue c -> prim () + mutUnsafeRead :: PrimMonad prim => c (PrimState prim) -> MutableKey c -> prim (MutableValue c) + mutRead :: PrimMonad prim => c (PrimState prim) -> MutableKey c -> prim (MutableValue c) + +instance UV.PrimType ty => MutableCollection (MUV.MUArray ty) where + type Collection (MUV.MUArray ty) = UV.UArray ty + type MutableKey (MUV.MUArray ty) = Int + type MutableValue (MUV.MUArray ty) = ty + + thaw = UV.thaw + freeze = UV.freeze + unsafeThaw = UV.unsafeThaw + unsafeFreeze = UV.unsafeFreeze + + mutUnsafeWrite = MUV.unsafeWrite + mutUnsafeRead = MUV.unsafeRead + mutWrite = MUV.write + mutRead = MUV.read diff --git a/Foundation/Collection/Sequential.hs b/Foundation/Collection/Sequential.hs new file mode 100644 --- /dev/null +++ b/Foundation/Collection/Sequential.hs @@ -0,0 +1,171 @@ +-- | +-- Module : Foundation.Collection.Sequential +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstrainedClassMethods #-} +module Foundation.Collection.Sequential + ( Sequential(..) + ) where + +import Foundation.Internal.Base +import Foundation.Collection.Element +import qualified Foundation.Collection.List as ListExtra +import qualified Data.List +import qualified Foundation.Array.Unboxed as UV + +-- | A set of methods for ordered colection +class (IsList c, Item c ~ Element c, Monoid c) => Sequential c where + {-# MINIMAL null, ((take, drop) | splitAt) + , ((revTake, revDrop) | revSplitAt) + , splitOn + , (break | span) + , intersperse + , filter, reverse + , uncons, unsnoc, snoc, cons + , find, sortBy, length, singleton #-} + + -- | Check if a collection is empty + null :: c -> Bool + + -- | Take the first @n elements of a collection + take :: Int -> c -> c + take n = fst . splitAt n + + -- | Take the last @n elements of a collection + revTake :: Int -> c -> c + revTake n = fst . revSplitAt n + + -- | Drop the first @n elements of a collection + drop :: Int -> c -> c + drop n = snd . splitAt n + + -- | Drop the last @n elements of a collection + revDrop :: Int -> c -> c + revDrop n = snd . revSplitAt n + + -- | Split the collection at the @n'th elements + splitAt :: Int -> c -> (c,c) + splitAt n c = (take n c, drop n c) + + -- | Split the collection at the @n'th elements from the end + revSplitAt :: Int -> c -> (c,c) + revSplitAt n c = (revTake n c, revDrop n c) + + -- | Split on a specific elements returning a list of colletion + splitOn :: (Element c -> Bool) -> c -> [c] + + -- | Split a collection when the predicate return true + break :: (Element c -> Bool) -> c -> (c,c) + break predicate = span (not . predicate) + + -- | Split a collection when the predicate return true + breakElem :: Eq (Element c) => Element c -> c -> (c,c) + breakElem c = break (== c) + + -- | The 'intersperse' function takes an element and a list and + -- \`intersperses\' that element between the elements of the list. + -- For example, + -- + -- > intersperse ',' "abcde" == "a,b,c,d,e" + intersperse :: Element c -> c -> c + + -- | 'intercalate' @xs xss@ is equivalent to @('mconcat' ('intersperse' xs xss))@. + -- It inserts the list @xs@ in between the lists in @xss@ and concatenates the + -- result. + intercalate :: Monoid (Item c) => Element c -> c -> Element c + intercalate xs xss = mconcatCollection (intersperse xs xss) + + -- | Split a collection while the predicate return true + span :: (Element c -> Bool) -> c -> (c,c) + span predicate = break (not . predicate) + + -- | Filter all the elements that satisfy the predicate + filter :: (Element c -> Bool) -> c -> c + + -- | Reverse a collection + reverse :: c -> c + + -- | Decompose a collection into its first element and the remaining collection. + -- If the collection is empty, returns Nothing. + uncons :: c -> Maybe (Element c, c) + + -- | Decompose a collection into a collection without its last element, and the last element + -- If the collection is empty, returns Nothing. + unsnoc :: c -> Maybe (c, Element c) + + -- | Prepend an element to an ordered collection + snoc :: c -> Element c -> c + + -- | Append an element to an ordered collection + cons :: Element c -> c -> c + + -- | Find an element in an ordered collection + find :: (Element c -> Bool) -> c -> Maybe (Element c) + + -- | Sort an ordered collection using the specified order function + sortBy :: (Element c -> Element c -> Ordering) -> c -> c + + -- | Length of a collection (number of Element c) + length :: c -> Int + + -- | Create a collection with a single element + singleton :: Element c -> c + +-- Temporary utility functions +mconcatCollection :: (Monoid (Item c), Sequential c) => c -> Element c +mconcatCollection c = mconcat (toList c) + +instance Sequential [a] where + null = Data.List.null + take = Data.List.take + drop = Data.List.drop + revTake = ListExtra.revTake + revDrop = ListExtra.revDrop + splitAt = Data.List.splitAt + revSplitAt = ListExtra.revSplitAt + splitOn = ListExtra.wordsWhen + break = Data.List.break + intersperse = Data.List.intersperse + span = Data.List.span + filter = Data.List.filter + reverse = Data.List.reverse + uncons = ListExtra.uncons + unsnoc = ListExtra.unsnoc + snoc c e = c `mappend` [e] + cons e c = e : c + find = Data.List.find + sortBy = Data.List.sortBy + length = Data.List.length + singleton = (:[]) + +instance UV.PrimType ty => Sequential (UV.UArray ty) where + null = UV.null + take = UV.take + revTake = UV.revTake + drop = UV.drop + revDrop = UV.revDrop + splitAt = UV.splitAt + revSplitAt = UV.revSplitAt + splitOn = UV.splitOn + break = UV.break + breakElem = UV.breakElem + intersperse = UV.intersperse + span = UV.span + filter = UV.filter + reverse = UV.reverse + uncons = UV.uncons + unsnoc = UV.unsnoc + snoc = UV.snoc + cons = UV.cons + find = UV.find + sortBy = UV.sortBy + length = UV.length + singleton = fromList . (:[]) diff --git a/Foundation/Collection/Zippable.hs b/Foundation/Collection/Zippable.hs new file mode 100644 --- /dev/null +++ b/Foundation/Collection/Zippable.hs @@ -0,0 +1,278 @@ +-- | +-- Module : Foundation.Collection.Zippable +-- License : BSD-style +-- Maintainer : foundation +-- Stability : experimental +-- Portability : portable +-- +-- Common functions (e. g. 'zip', 'zipWith') that are useful for combining +-- multiple collections. +-- +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Foundation.Collection.Zippable + ( BoxedZippable(..) + , Zippable(..) + ) where + +import qualified Foundation.Array.Unboxed as UV +import qualified Foundation.Array.Unboxed.Builder as UVB +import Foundation.Collection.Element +import Foundation.Collection.Sequential +import Foundation.Internal.Base +import Foundation.Number +import qualified Prelude +import GHC.ST + +class Sequential col => Zippable col where + + -- | 'zipWith' generalises 'zip' by zipping with the function given as the + -- first argument, instead of a tupling function. For example, @'zipWith' (+)@ + -- is applied to two collections to produce the collection of corresponding + -- sums. + zipWith :: (Sequential a, Sequential b) + => (Element a -> Element b -> Element col) + -> a -> b -> col + zipWith f a b = go f (toList a, toList b) + where go f' = maybe mempty (\(x, xs) -> uncurry2 f' x `cons` go f' xs) . uncons2 + + -- | Like 'zipWith', but works with 3 collections. + zipWith3 :: (Sequential a, Sequential b, Sequential c) + => (Element a -> Element b -> Element c -> Element col) + -> a -> b -> c -> col + zipWith3 f a b c = go f (toList a, toList b, toList c) + where go f' = maybe mempty (\(x, xs) -> uncurry3 f' x `cons` go f' xs) . uncons3 + + -- | Like 'zipWith', but works with 4 collections. + zipWith4 :: (Sequential a, Sequential b, Sequential c, Sequential d) + => (Element a -> Element b -> Element c -> Element d -> Element col) + -> a -> b -> c -> d -> col + zipWith4 fn a b c d = go fn (toList a, toList b, toList c, toList d) + where go f' = maybe mempty (\(x, xs) -> uncurry4 f' x `cons` go f' xs) . uncons4 + + -- | Like 'zipWith', but works with 5 collections. + zipWith5 :: (Sequential a, Sequential b, Sequential c, Sequential d, Sequential e) + => (Element a -> Element b -> Element c -> Element d -> Element e -> Element col) + -> a -> b -> c -> d -> e -> col + zipWith5 fn a b c d e = go fn (toList a, toList b, toList c, toList d, toList e) + where go f' = maybe mempty (\(x, xs) -> uncurry5 f' x `cons` go f' xs) . uncons5 + + -- | Like 'zipWith', but works with 6 collections. + zipWith6 :: ( Sequential a, Sequential b, Sequential c, Sequential d, Sequential e + , Sequential f) + => (Element a -> Element b -> Element c -> Element d -> Element e -> Element f -> Element col) + -> a -> b -> c -> d -> e -> f -> col + zipWith6 fn a b c d e f = go fn (toList a, toList b, toList c, toList d, toList e, toList f) + where go f' = maybe mempty (\(x, xs) -> uncurry6 f' x `cons` go f' xs) . uncons6 + + -- | Like 'zipWith', but works with 7 collections. + zipWith7 :: ( Sequential a, Sequential b, Sequential c, Sequential d, Sequential e + , Sequential f, Sequential g ) + => (Element a -> Element b -> Element c -> Element d -> Element e -> Element f -> Element g -> Element col) + -> a -> b -> c -> d -> e -> f -> g -> col + zipWith7 fn a b c d e f g = go fn (toList a, toList b, toList c, toList d, toList e, toList f, toList g) + where go f' = maybe mempty (\(x, xs) -> uncurry7 f' x `cons` go f' xs) . uncons7 + +instance Zippable [c] + +instance UV.PrimType ty => Zippable (UV.UArray ty) where + zipWith f as bs = runST $ + Prelude.uncurry UVB.build $ go f (toList as) (toList bs) + where + go _ [] _ = (0, return ()) + go _ _ [] = (0, return ()) + go f' (a':as') (b':bs') = + let (i, builder) = go f' as' bs' + in (i + 1, UVB.appendTy (f' a' b') >> builder) + +class Zippable col => BoxedZippable col where + + -- | 'zip' takes two collections and returns a collections of corresponding + -- pairs. If one input collection is short, excess elements of the longer + -- collection are discarded. + zip :: ( Sequential a, Sequential b + , Element col ~ (Element a, Element b) ) + => a -> b -> col + zip = zipWith (,) + + -- | Like 'zip', but works with 3 collections. + zip3 :: ( Sequential a, Sequential b, Sequential c + , Element col ~ (Element a, Element b, Element c) ) + => a -> b -> c -> col + zip3 = zipWith3 (,,) + + -- | Like 'zip', but works with 4 collections. + zip4 :: ( Sequential a, Sequential b, Sequential c, Sequential d + , Element col ~ (Element a, Element b, Element c, Element d) ) + => a -> b -> c -> d -> col + zip4 = zipWith4 (,,,) + + -- | Like 'zip', but works with 5 collections. + zip5 :: ( Sequential a, Sequential b, Sequential c, Sequential d, Sequential e + , Element col ~ (Element a, Element b, Element c, Element d, Element e) ) + => a -> b -> c -> d -> e -> col + zip5 = zipWith5 (,,,,) + + -- | Like 'zip', but works with 6 collections. + zip6 :: ( Sequential a, Sequential b, Sequential c, Sequential d, Sequential e, Sequential f + , Element col ~ (Element a, Element b, Element c, Element d, Element e, Element f) ) + => a -> b -> c -> d -> e -> f -> col + zip6 = zipWith6 (,,,,,) + + -- | Like 'zip', but works with 7 collections. + zip7 :: ( Sequential a, Sequential b, Sequential c, Sequential d, Sequential e, Sequential f, Sequential g + , Element col ~ (Element a, Element b, Element c, Element d, Element e, Element f, Element g) ) + => a -> b -> c -> d -> e -> f -> g -> col + zip7 = zipWith7 (,,,,,,) + + -- | 'unzip' transforms a collection of pairs into a collection of first + -- components and a collection of second components. + unzip :: (Sequential a, Sequential b, Element col ~ (Element a, Element b)) + => col -> (a, b) + unzip = go . toList + where go [] = (mempty, mempty) + go ((a, b):xs) = + let (as, bs) = go xs + in (a `cons` as, b `cons` bs) + + -- | Like 'unzip', but works on a collection of 3-element tuples. + unzip3 :: ( Sequential a, Sequential b, Sequential c + , Element col ~ (Element a, Element b, Element c) ) + => col -> (a, b, c) + unzip3 = go . toList + where go [] = (mempty, mempty, mempty) + go ((a, b, c):xs) = + let (as, bs, cs) = go xs + in (a `cons` as, b `cons` bs, c `cons` cs) + + -- | Like 'unzip', but works on a collection of 4-element tuples. + unzip4 :: ( Sequential a, Sequential b, Sequential c, Sequential d + , Element col ~ (Element a, Element b, Element c, Element d) ) + => col -> (a, b, c, d) + unzip4 = go . toList + where go [] = (mempty, mempty, mempty, mempty) + go ((a, b, c, d):xs) = + let (as, bs, cs, ds) = go xs + in (a `cons` as, b `cons` bs, c `cons` cs, d `cons` ds) + + -- | Like 'unzip', but works on a collection of 5-element tuples. + unzip5 :: ( Sequential a, Sequential b, Sequential c, Sequential d, Sequential e + , Element col ~ (Element a, Element b, Element c, Element d, Element e) ) + => col -> (a, b, c, d, e) + unzip5 = go . toList + where go [] = (mempty, mempty, mempty, mempty, mempty) + go ((a, b, c, d, e):xs) = + let (as, bs, cs, ds, es) = go xs + in (a `cons` as, b `cons` bs, c `cons` cs, d `cons` ds, e `cons` es) + + -- | Like 'unzip', but works on a collection of 6-element tuples. + unzip6 :: ( Sequential a, Sequential b, Sequential c, Sequential d, Sequential e, Sequential f + , Element col ~ (Element a, Element b, Element c, Element d, Element e, Element f) ) + => col -> (a, b, c, d, e, f) + unzip6 = go . toList + where go [] = (mempty, mempty, mempty, mempty, mempty, mempty) + go ((a, b, c, d, e, f):xs) = + let (as, bs, cs, ds, es, fs) = go xs + in (a `cons` as, b `cons` bs, c `cons` cs, d `cons` ds, e `cons` es, f `cons` fs) + + -- | Like 'unzip', but works on a collection of 7-element tuples. + unzip7 :: ( Sequential a, Sequential b, Sequential c, Sequential d, Sequential e, Sequential f, Sequential g + , Element col ~ (Element a, Element b, Element c, Element d, Element e, Element f, Element g) ) + => col -> (a, b, c, d, e, f, g) + unzip7 = go . toList + where go [] = (mempty, mempty, mempty, mempty, mempty, mempty, mempty) + go ((a, b, c, d, e, f, g):xs) = + let (as, bs, cs, ds, es, fs, gs) = go xs + in (a `cons` as, b `cons` bs, c `cons` cs, d `cons` ds, e `cons` es, f `cons` fs, g `cons` gs) + +instance BoxedZippable [a] + +-- * Tuple helper functions + +uncons2 :: (Sequential a, Sequential b) => (a, b) -> Maybe ((Element a, Element b), (a, b)) +uncons2 xs = let (as, bs) = xs + in do (a', as') <- uncons as + (b', bs') <- uncons bs + return ((a', b'), (as', bs')) + +uncons3 :: (Sequential a, Sequential b, Sequential c) + => (a, b, c) + -> Maybe ((Element a, Element b, Element c), (a, b, c)) +uncons3 xs = let (as, bs, cs) = xs + in do (a', as') <- uncons as + (b', bs') <- uncons bs + (c', cs') <- uncons cs + return ((a', b', c'), (as', bs', cs')) + +uncons4 :: (Sequential a, Sequential b, Sequential c, Sequential d) + => (a, b, c, d) + -> Maybe ( (Element a, Element b, Element c, Element d) + , (a, b, c, d) ) +uncons4 xs = let (as, bs, cs, ds) = xs + in do (a', as') <- uncons as + (b', bs') <- uncons bs + (c', cs') <- uncons cs + (d', ds') <- uncons ds + return ((a', b', c', d'), (as', bs', cs', ds')) + +uncons5 :: (Sequential a, Sequential b, Sequential c, Sequential d, Sequential e) + => (a, b, c, d, e) + -> Maybe ( (Element a, Element b, Element c, Element d, Element e) + , (a, b, c, d, e) ) +uncons5 xs = let (as, bs, cs, ds, es) = xs + in do (a', as') <- uncons as + (b', bs') <- uncons bs + (c', cs') <- uncons cs + (d', ds') <- uncons ds + (e', es') <- uncons es + return ((a', b', c', d', e'), (as', bs', cs', ds', es')) + +uncons6 :: ( Sequential a, Sequential b, Sequential c, Sequential d, Sequential e + , Sequential f ) + => (a, b, c, d, e, f) + -> Maybe ( (Element a, Element b, Element c, Element d, Element e, Element f) + , (a, b, c, d, e, f) ) +uncons6 xs = let (as, bs, cs, ds, es, fs) = xs + in do (a', as') <- uncons as + (b', bs') <- uncons bs + (c', cs') <- uncons cs + (d', ds') <- uncons ds + (e', es') <- uncons es + (f', fs') <- uncons fs + return ((a', b', c', d', e', f'), (as', bs', cs', ds', es', fs')) + +uncons7 :: ( Sequential a, Sequential b, Sequential c, Sequential d, Sequential e + , Sequential f, Sequential g ) + => (a, b, c, d, e, f, g) + -> Maybe ( (Element a, Element b, Element c, Element d, Element e, Element f + , Element g) + , (a, b, c, d, e, f, g) ) +uncons7 xs = let (as, bs, cs, ds, es, fs, gs) = xs + in do (a', as') <- uncons as + (b', bs') <- uncons bs + (c', cs') <- uncons cs + (d', ds') <- uncons ds + (e', es') <- uncons es + (f', fs') <- uncons fs + (g', gs') <- uncons gs + return ( (a', b', c', d', e', f', g') + , (as', bs', cs', ds', es', fs', gs') ) + +uncurry2 :: (a -> b -> c) -> (a, b) -> c +uncurry2 = Prelude.uncurry + +uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d +uncurry3 fn (a, b, c) = fn a b c + +uncurry4 :: (a -> b -> c -> d -> g) -> (a, b, c, d) -> g +uncurry4 fn (a, b, c, d) = fn a b c d + +uncurry5 :: (a -> b -> c -> d -> e -> f) -> (a, b, c, d, e) -> f +uncurry5 fn (a, b, c, d, e) = fn a b c d e + +uncurry6 :: (a -> b -> c -> d -> e -> f -> g) -> (a, b, c, d, e, f) -> g +uncurry6 fn (a, b, c, d, e, f) = fn a b c d e f + +uncurry7 :: (a -> b -> c -> d -> e -> f -> g -> h) -> (a, b, c, d, e, f, g) -> h +uncurry7 fn (a, b, c, d, e, f, g) = fn a b c d e f g diff --git a/Foundation/Convertible.hs b/Foundation/Convertible.hs new file mode 100644 --- /dev/null +++ b/Foundation/Convertible.hs @@ -0,0 +1,24 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/Foundation/Foreign.hs @@ -0,0 +1,16 @@ +-- | +-- Module : Foundation.Foreign +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +module Foundation.Foreign + ( module Foundation.Primitive.FinalPtr + , V.foreignMem + , V.mutableForeignMem + ) where + +import Foundation.Primitive.FinalPtr +import qualified Foundation.Array.Unboxed as V +import qualified Foundation.Array.Unboxed.Mutable as V diff --git a/Foundation/Foreign/MemoryMap.hs b/Foundation/Foreign/MemoryMap.hs new file mode 100644 --- /dev/null +++ b/Foundation/Foreign/MemoryMap.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE CPP #-} +module Foundation.Foreign.MemoryMap + ( fileMapRead + , FileMapping(..) + , fileMappingToFinalPtr + ) where + +import Foundation.Foreign.MemoryMap.Types +#ifdef mingw32_HOST_OS +import Foundation.Foreign.MemoryMap.Windows +#else +import Foundation.Foreign.MemoryMap.Posix +#endif + +{- +fileMap :: Fd -> Int -> IO FileMap +fileMap = undefined +-} diff --git a/Foundation/Foreign/MemoryMap/Posix.hsc b/Foundation/Foreign/MemoryMap/Posix.hsc new file mode 100644 --- /dev/null +++ b/Foundation/Foreign/MemoryMap/Posix.hsc @@ -0,0 +1,251 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Foundation.Foreign.MemoryMap.Posix +-- Copyright : (c) Vincent Hanquez 2014 +-- License : BSD-style +-- +-- Maintainer : Vincent Hanquez +-- Stability : provisional +-- Portability : non-portable (requires POSIX) +-- +-- Functions defined by the POSIX standards for manipulating memory maps +-- +-- When a function that calls an underlying POSIX function fails, the errno +-- code is converted to an 'IOError' using 'Foreign.C.Error.errnoToIOError'. +-- For a list of which errno codes may be generated, consult the POSIX +-- documentation for the underlying function. +-- +----------------------------------------------------------------------------- + +#include +#include + +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE CPP #-} +module Foundation.Foreign.MemoryMap.Posix + ( memoryMap + , memoryUnmap + , memoryAdvise + , memoryLock + , memoryUnlock + , memoryProtect + , memorySync + -- * Flags types + , MemoryMapFlag(..) + , MemoryProtection(..) + , MemoryAdvice(..) + , MemorySyncFlag(..) + -- * system page size + , sysconfPageSize + -- * High level + , fileMapRead + ) where + +import Foundation.Internal.Base +import Foundation.Internal.Types +import System.Posix.Types +import Foreign.Ptr +import Foreign.C.Types +import Foreign.C.Error +import Data.Bits + +import Foundation.Collection.Foldable +import Foundation.VFS +import qualified Prelude (fromIntegral) +import Foundation.Foreign.MemoryMap.Types +import Control.Exception + +import GHC.IO.FD +import GHC.IO.IOMode +import qualified GHC.IO.Device as IO + +foreign import ccall unsafe "mmap" + c_mmap :: Ptr a -> CSize -> CInt -> CInt -> CInt -> COff -> IO (Ptr a) + +foreign import ccall unsafe "munmap" + c_munmap :: Ptr a -> CSize -> IO CInt + +#if defined(POSIX_MADV_NORMAL) +foreign import ccall unsafe "posix_madvise" + c_madvise :: Ptr a -> CSize -> CInt -> IO CInt +#else +foreign import ccall unsafe "madvise" + c_madvise :: Ptr a -> CSize -> CInt -> IO CInt +#endif + +foreign import ccall unsafe "msync" + c_msync :: Ptr a -> CSize -> CInt -> IO CInt + +foreign import ccall unsafe "mprotect" + c_mprotect :: Ptr a -> CSize -> CInt -> IO CInt + +#ifndef __HAIKU__ +foreign import ccall unsafe "mlock" + c_mlock :: Ptr a -> CSize -> IO CInt +#else +c_mlock :: Ptr a -> CSize -> IO CInt +c_mlock _ _ = return (-1) +#endif + +#ifndef __HAIKU__ +foreign import ccall unsafe "munlock" + c_munlock :: Ptr a -> CSize -> IO CInt +#else +c_munlock :: Ptr a -> CSize -> IO CInt +c_munlock _ _ = return (-1) +#endif + +foreign import ccall unsafe "sysconf" + c_sysconf :: CInt -> CLong + +-- | Mapping flag +data MemoryMapFlag = + MemoryMapShared -- ^ memory changes are shared between process + | MemoryMapPrivate -- ^ memory changes are private to process + deriving (Show,Eq) + +-- | Memory protection +data MemoryProtection = + MemoryProtectionNone + | MemoryProtectionRead + | MemoryProtectionWrite + | MemoryProtectionExecute + deriving (Show,Eq) + +-- | Advice to put on memory. +-- +-- only define the posix one. +data MemoryAdvice = + MemoryAdviceNormal -- ^ no specific advice, the default. + | MemoryAdviceRandom -- ^ Expect page references in random order. No readahead should occur. + | MemoryAdviceSequential -- ^ Expect page references in sequential order. Page should be readahead aggressively. + | MemoryAdviceWillNeed -- ^ Expect access in the near future. Probably a good idea to readahead early + | MemoryAdviceDontNeed -- ^ Do not expect access in the near future. + deriving (Show,Eq) + +-- | Memory synchronization flags +data MemorySyncFlag = + MemorySyncAsync -- ^ perform asynchronous write. + | MemorySyncSync -- ^ perform synchronous write. + | MemorySyncInvalidate -- ^ invalidate cache data. + deriving (Show,Eq) + +cvalueOfMemoryProts :: [MemoryProtection] -> CInt +cvalueOfMemoryProts = foldl (.|.) 0 . fmap toProt + where toProt :: MemoryProtection -> CInt + toProt MemoryProtectionNone = (#const PROT_NONE) + toProt MemoryProtectionRead = (#const PROT_READ) + toProt MemoryProtectionWrite = (#const PROT_WRITE) + toProt MemoryProtectionExecute = (#const PROT_EXEC) + +cvalueOfMemorySync :: [MemorySyncFlag] -> CInt +cvalueOfMemorySync = foldl (.|.) 0 . fmap toSync + where toSync MemorySyncAsync = (#const MS_ASYNC) + toSync MemorySyncSync = (#const MS_SYNC) + toSync MemorySyncInvalidate = (#const MS_INVALIDATE) + +-- | Map pages of memory. +-- +-- If fd is present, this memory will represent the file associated. +-- Otherwise, the memory will be an anonymous mapping. +-- +-- use 'mmap' +memoryMap :: Maybe (Ptr a) -- ^ The address to map to if MapFixed is used. + -> CSize -- ^ The length of the mapping + -> [MemoryProtection] -- ^ the memory protection associated with the mapping + -> MemoryMapFlag -- ^ + -> Maybe Fd + -> COff + -> IO (Ptr a) +memoryMap initPtr sz prots flag mfd off = + throwErrnoIf (== m1ptr) "mmap" (c_mmap (maybe nullPtr id initPtr) sz cprot cflags fd off) + where m1ptr = nullPtr `plusPtr` (-1) + fd = maybe (-1) (\(Fd v) -> v) mfd + cprot = cvalueOfMemoryProts prots + cflags = maybe cMapAnon (const 0) mfd + .|. maybe 0 (const cMapFixed) initPtr + .|. toMapFlag flag + +#ifdef __APPLE__ + cMapAnon = (#const MAP_ANON) +#else + cMapAnon = (#const MAP_ANONYMOUS) +#endif + cMapFixed = (#const MAP_FIXED) + + toMapFlag MemoryMapShared = (#const MAP_SHARED) + toMapFlag MemoryMapPrivate = (#const MAP_PRIVATE) + +-- | Unmap pages of memory +-- +-- use 'munmap' +memoryUnmap :: Ptr a -> CSize -> IO () +memoryUnmap ptr sz = throwErrnoIfMinus1_ "munmap" (c_munmap ptr sz) + +-- | give advice to the operating system about use of memory +-- +-- call 'madvise' +memoryAdvise :: Ptr a -> CSize -> MemoryAdvice -> IO () +memoryAdvise ptr sz adv = throwErrnoIfMinus1_ "madvise" (c_madvise ptr sz cadv) + where cadv = toAdvice adv +#if defined(POSIX_MADV_NORMAL) + toAdvice MemoryAdviceNormal = (#const POSIX_MADV_NORMAL) + toAdvice MemoryAdviceRandom = (#const POSIX_MADV_RANDOM) + toAdvice MemoryAdviceSequential = (#const POSIX_MADV_SEQUENTIAL) + toAdvice MemoryAdviceWillNeed = (#const POSIX_MADV_WILLNEED) + toAdvice MemoryAdviceDontNeed = (#const POSIX_MADV_DONTNEED) +#else + toAdvice MemoryAdviceNormal = (#const MADV_NORMAL) + toAdvice MemoryAdviceRandom = (#const MADV_RANDOM) + toAdvice MemoryAdviceSequential = (#const MADV_SEQUENTIAL) + toAdvice MemoryAdviceWillNeed = (#const MADV_WILLNEED) + toAdvice MemoryAdviceDontNeed = (#const MADV_DONTNEED) +#endif + +-- | lock a range of process address space +-- +-- call 'mlock' +memoryLock :: Ptr a -> CSize -> IO () +memoryLock ptr sz = throwErrnoIfMinus1_ "mlock" (c_mlock ptr sz) + +-- | unlock a range of process address space +-- +-- call 'munlock' +memoryUnlock :: Ptr a -> CSize -> IO () +memoryUnlock ptr sz = throwErrnoIfMinus1_ "munlock" (c_munlock ptr sz) + +-- | set protection of memory mapping +-- +-- call 'mprotect' +memoryProtect :: Ptr a -> CSize -> [MemoryProtection] -> IO () +memoryProtect ptr sz prots = throwErrnoIfMinus1_ "mprotect" (c_mprotect ptr sz cprot) + where cprot = cvalueOfMemoryProts prots + +-- | memorySync synchronize memory with physical storage. +-- +-- On an anonymous mapping this function does not have any effect. +-- call 'msync' +memorySync :: Ptr a -> CSize -> [MemorySyncFlag] -> IO () +memorySync ptr sz flags = throwErrnoIfMinus1_ "msync" (c_msync ptr sz cflags) + where cflags = cvalueOfMemorySync flags + +-- | Return the operating system page size. +-- +-- call 'sysconf' +sysconfPageSize :: Int +sysconfPageSize = Prelude.fromIntegral $ c_sysconf (#const _SC_PAGESIZE) + +-------------------------------------------------------------------------------- + +fileSizeToCSize :: FileSize -> CSize +fileSizeToCSize (FileSize sz) = Prelude.fromIntegral sz + +fileSizeFromInteger :: Integer -> FileSize +fileSizeFromInteger = FileSize . Prelude.fromIntegral + +fileMapRead :: FileMapReadF +fileMapRead fp = bracket (openFile (filePathToLString fp) ReadMode True) (IO.close . fst) $ \(fd,_) -> do + sz <- fileSizeFromInteger `fmap` IO.getSize fd + let csz = fileSizeToCSize sz + p <- memoryMap Nothing csz [MemoryProtectionRead] MemoryMapPrivate (Just $ Fd $ fdFD fd) 0 + return $ FileMapping p sz (memoryUnmap p csz) diff --git a/Foundation/Foreign/MemoryMap/Types.hs b/Foundation/Foreign/MemoryMap/Types.hs new file mode 100644 --- /dev/null +++ b/Foundation/Foreign/MemoryMap/Types.hs @@ -0,0 +1,34 @@ +-- | +-- Module : Foundation.Foreign.MemoryMap.Types +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +module Foundation.Foreign.MemoryMap.Types + ( FileMapping(..) + , fileMappingToFinalPtr + , FileMapReadF + ) where + +import GHC.Ptr +import Foundation.Primitive.FinalPtr +import Foundation.Internal.Base +import Foundation.Internal.Types +import Foundation.VFS (FilePath) + +-- | Contains all the information related to a file mapping, +-- including the size and the finalizer function. +data FileMapping = FileMapping + { fileMappingPtr :: Ptr Word8 + , fileMappingSize :: FileSize + , fileMappingUnmap :: IO () + } + +-- | From a file mapping, create a final ptr which will automatically +-- unmap memory when the pointer is garbage. +fileMappingToFinalPtr :: FileMapping -> IO (FinalPtr Word8) +fileMappingToFinalPtr (FileMapping ptr _ finalizer) = + toFinalPtr ptr (\_ -> finalizer) + +type FileMapReadF = FilePath -> IO FileMapping diff --git a/Foundation/Foreign/MemoryMap/Windows.hs b/Foundation/Foreign/MemoryMap/Windows.hs new file mode 100644 --- /dev/null +++ b/Foundation/Foreign/MemoryMap/Windows.hs @@ -0,0 +1,27 @@ +module Foundation.Foreign.MemoryMap.Windows + ( fileMapRead + ) where + +import System.Win32.Mem +import System.Win32.File +import System.Win32.FileMapping +import Control.Exception hiding (handle) + +import Foundation.Internal.Types +import Foundation.Internal.Base +import Foundation.Primitive.FinalPtr +import Foundation.VFS +import Foundation.Foreign.MemoryMap.Types + +fileMapRead :: FileMapReadF +fileMapRead path = bracket doOpen closeHandle doMapping + where + doOpen = createFile (filePathToLString path) gENERIC_READ fILE_SHARE_READ Nothing oPEN_EXISTING fILE_ATTRIBUTE_NORMAL Nothing + doMapping handle = bracket (createFileMapping (Just handle) pAGE_READONLY 0 Nothing) + closeHandle + (getSizeAndMap handle) + getSizeAndMap handle filemap = do + fileInfo <- getFileInformationByHandle handle + mask_ $ do + ptr <- mapViewOfFile filemap fILE_MAP_READ 0 0 + return $ FileMapping ptr (FileSize $ bhfiSize fileInfo) (unmapViewOfFile ptr) diff --git a/Foundation/IO.hs b/Foundation/IO.hs new file mode 100644 --- /dev/null +++ b/Foundation/IO.hs @@ -0,0 +1,25 @@ +-- | +-- Module : Foundation.IO +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- IO Routine +module Foundation.IO + ( + -- * Terminal + Foundation.IO.Terminal.putStrLn + , Foundation.IO.Terminal.putStr + -- * File + , Foundation.IO.File.IOMode(..) + , Foundation.IO.File.openFile + , Foundation.IO.File.closeFile + , Foundation.IO.File.withFile + , Foundation.IO.File.hGet + , Foundation.IO.File.readFile + , Foundation.IO.File.foldTextFile + ) where + +import qualified Foundation.IO.Terminal +import qualified Foundation.IO.File diff --git a/Foundation/IO/File.hs b/Foundation/IO/File.hs new file mode 100644 --- /dev/null +++ b/Foundation/IO/File.hs @@ -0,0 +1,147 @@ +-- | +-- Module : Foundation.IO.File +-- License : BSD-style +-- Maintainer : Foundation +-- Stability : experimental +-- Portability : portable +-- +module Foundation.IO.File + ( openFile + , closeFile + , IOMode(..) + , withFile + , hGet + , hGetNonBlocking + , hGetSome + , readFile + , foldTextFile + ) where + +import System.IO (Handle, IOMode) +import System.IO.Error +import qualified System.IO as S +import Foundation.Collection +import Foundation.VFS +import Foundation.Internal.Types +import Foundation.Internal.Base +import Foundation.String +import Foundation.Array +import Foundation.Number +import qualified Foundation.Array.Unboxed.Mutable as V +import qualified Foundation.Array.Unboxed as V +import qualified Foundation.String.UTF8 as S +import Control.Exception (bracket) +import Foreign.Ptr (plusPtr) + +-- | list the file name in the given FilePath directory +-- +-- TODO: error management and not implemented yet +--getDirectory :: FilePath -> IO [FileName] +--getDirectory = undefined + +-- | Open a new handle on the file +openFile :: FilePath -> IOMode -> IO Handle +openFile filepath mode = do + S.openBinaryFile (filePathToLString filepath) mode + +-- | Close a handle +closeFile :: Handle -> IO () +closeFile = S.hClose + +-- | Read binary data directly from the specified 'Handle'. +-- +-- First argument is the Handle to read from, and the second is the number of bytes to read. +-- It returns the bytes read, up to the specified size, or an empty array if EOF has been reached. +-- +-- 'hGet' is implemented in terms of 'hGetBuf'. +hGet :: Handle -> Int -> IO (UArray Word8) +hGet h size + | size < 0 = invalidBufferSize "hGet" h size + | otherwise = V.createFromIO size $ \p -> S.hGetBuf h p size + +-- | hGetNonBlocking is similar to 'hGet', except that it will never block +-- waiting for data to become available, instead it returns only whatever data +-- is available. If there is no data available to be read, 'hGetNonBlocking' +-- returns an empty array. +-- +-- Note: on Windows, this function behaves identically to 'hGet'. +hGetNonBlocking :: Handle -> Int -> IO (UArray Word8) +hGetNonBlocking h size + | size < 0 = invalidBufferSize "hGetNonBlocking" h size + | otherwise = V.createFromIO size $ \p -> S.hGetBufNonBlocking h p size + +-- | Like 'hGet', except that a shorter array may be returned +-- if there are not enough bytes immediately available to satisfy the +-- whole request. 'hGetSome' only blocks if there is no data +-- available, and EOF has not yet been reached. +-- +hGetSome :: Handle -> Int -> IO (UArray Word8) +hGetSome h size + | size < 0 = invalidBufferSize "hGetSome" h size + | otherwise = V.createFromIO size $ \p -> S.hGetBufSome h p size + +invalidBufferSize :: [Char] -> Handle -> Int -> IO a +invalidBufferSize functionName handle size = + ioError $ mkIOError illegalOperationErrorType + (functionName <> " invalid array size: " <> show size) + (Just handle) + Nothing + +-- | @'withFile' filepath mode act@ opens a file using the mode@ +-- and run act@. the by-product handle will be closed when act finish, +-- either normally or through an exception. +-- +-- The value returned is the result of act@ +withFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r +withFile fp mode act = bracket (openFile fp mode) closeFile act + +-- | Read a binary file and return the whole content in one contiguous buffer. +readFile :: FilePath -> IO (UArray Word8) +readFile fp = withFile fp S.ReadMode $ \h -> do + -- TODO filesize is an integer (whyyy ?!), and transforming to Int using + -- fromIntegral is probably the wrong thing to do here.. + sz <- S.hFileSize h + mv <- V.newPinned (Size $ fromInteger sz) + V.withMutablePtr mv $ loop h (fromInteger sz) + unsafeFreeze mv + where + loop h left dst + | left == 0 = return () + | otherwise = do + let toRead = min blockSize left + r <- S.hGetBuf h dst toRead + 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 (Size 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 r + s <- case validateRet of + Nothing -> S.fromBytesUnsafe `fmap` V.freezeShrink mv r + Just S.MissingByte -> do + sRet <- S.fromBytesUnsafe `fmap` V.freezeShrink mv pos + V.unsafeSlide mv pos r + return sRet + Just _ -> + error ("foldTextFile: invalid UTF8 sequence: byte position: " <> show (absPos + pos)) + chunkf s acc >>= loop (absPos + r) + else error ("foldTextFile: read failed") -- FIXME + +blockSize :: Int +blockSize = 4096 diff --git a/Foundation/IO/FileMap.hs b/Foundation/IO/FileMap.hs new file mode 100644 --- /dev/null +++ b/Foundation/IO/FileMap.hs @@ -0,0 +1,59 @@ +-- | +-- Module : Foundation.IO.FileMap +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- Note that the memory mapping is handled by the system, not at the haskell level. +-- The system can modify the content of the memory as any moment under your feet. +-- +-- It also have the limitation of your system, no emulation or nice handling of all +-- those corners cases is attempted here. +-- +-- for example mapping a large file (> 4G), on a 32 bits system is likely to just +-- fail or returns inconsistent result. +-- +-- In doubt, use 'readFile' or other simple routine that brings +-- the content of the file in IO. +-- +module Foundation.IO.FileMap + ( fileMapRead + , fileMapReadWith + ) where + +import Control.Exception +import Foundation.Internal.Types +import Foundation.Internal.Base +import Foundation.VFS (FilePath) +import Foundation.Primitive.FinalPtr +import qualified Foundation.Array.Unboxed as V +import qualified Foundation.Foreign.MemoryMap as I +import qualified Prelude + +getSize :: I.FileMapping -> Int +getSize fm + | Prelude.fromIntegral (maxBound :: Int) < sz = error ("cannot map file in entirety as size overflow " <> show sz) + | otherwise = Prelude.fromIntegral sz + where + (FileSize sz) = I.fileMappingSize fm + +-- | Map in memory the whole content of a file. +-- +-- Once the array goes out of scope, the memory get (eventually) unmap +fileMapRead :: FilePath -> IO (V.UArray Word8) +fileMapRead fp = do + fileMapping <- I.fileMapRead fp + fptr <- I.fileMappingToFinalPtr fileMapping + return $ V.foreignMem fptr (getSize fileMapping) + +-- | Map in memory the whole content of a file, + +-- the whole map is unmapped at the end of function after the function has been called +-- so any things that is still holding on to this memory will very likely trigger segfault +-- or other really bad behavior. +fileMapReadWith :: FilePath -> (V.UArray Word8 -> IO a) -> IO a +fileMapReadWith fp f = do + bracket (I.fileMapRead fp) I.fileMappingUnmap $ \fm -> do + fptr <- toFinalPtr (I.fileMappingPtr fm) (\_ -> return ()) + f (V.foreignMem fptr (getSize fm)) diff --git a/Foundation/IO/Terminal.hs b/Foundation/IO/Terminal.hs new file mode 100644 --- /dev/null +++ b/Foundation/IO/Terminal.hs @@ -0,0 +1,23 @@ +-- | +-- Module : Foundation.IO.Terminal +-- License : BSD-style +-- Maintainer : Foundation +-- Stability : experimental +-- Portability : portable +-- +module Foundation.IO.Terminal + ( putStrLn + , putStr + ) where + +import Foundation.Internal.Base +import Foundation.String +import qualified Prelude + +-- | Print a string to standard output +putStr :: String -> IO () +putStr = Prelude.putStr . toList + +-- | Print a string with a newline to standard output +putStrLn :: String -> IO () +putStrLn = Prelude.putStrLn . toList diff --git a/Foundation/Internal/Base.hs b/Foundation/Internal/Base.hs new file mode 100644 --- /dev/null +++ b/Foundation/Internal/Base.hs @@ -0,0 +1,74 @@ +-- | +-- 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 + , 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.IO + , Foundation.Internal.IsList.IsList (..) + , GHC.Exts.IsString (..) + , GHC.Generics.Generic (..) + , Prelude.Either (..) + , Data.Typeable.Typeable + , Data.Monoid.Monoid (..) + , (Data.Monoid.<>) + , Control.Exception.Exception + , Control.Exception.throw + , Control.Exception.throwIO + -- * Errors + , internalError + ) where + +import qualified Prelude +import qualified Control.Category +import qualified Control.Applicative +import qualified Control.Exception +import qualified Data.Monoid +import qualified Data.Typeable +import qualified Data.Word +import qualified Data.Int +import qualified Foundation.Internal.IsList +import qualified GHC.Exts +import qualified GHC.Generics + +-- | Only to use internally for internal error cases +internalError :: [Prelude.Char] -> a +internalError s = Prelude.error ("Internal Error: the impossible happened: " Prelude.++ s) diff --git a/Foundation/Internal/Identity.hs b/Foundation/Internal/Identity.hs new file mode 100644 --- /dev/null +++ b/Foundation/Internal/Identity.hs @@ -0,0 +1,37 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/Foundation/Internal/IsList.hs @@ -0,0 +1,36 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/Foundation/Internal/MonadTrans.hs @@ -0,0 +1,49 @@ +-- | +-- 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 + +-- | 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 $ \st -> runState fa st >>= \(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 + (a,s2) <- runState fa s1 + (ab,s3) <- runState fab 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 $ \r -> runReader fa r >>= \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/PrimTypes.hs b/Foundation/Internal/PrimTypes.hs new file mode 100644 --- /dev/null +++ b/Foundation/Internal/PrimTypes.hs @@ -0,0 +1,28 @@ +-- | +-- Module : Foundation.Internal.PrimTypes +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +{-# LANGUAGE MagicHash #-} +module Foundation.Internal.PrimTypes + ( FileSize# + , Offset# + , Size# + ) 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# + +-- | Size in bytes type alias +-- +-- for code documentation purpose only, just a simple type alias on Int# +type Size# = Int# diff --git a/Foundation/Internal/Primitive.hs b/Foundation/Internal/Primitive.hs new file mode 100644 --- /dev/null +++ b/Foundation/Internal/Primitive.hs @@ -0,0 +1,144 @@ +-- | +-- Module : Foundation.Internal.Primitive +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE CPP #-} +module Foundation.Internal.Primitive + ( bool# + , PinnedStatus, pinned, unpinned, isPinned + , compatAndI# + , compatQuotRemInt# + , compatCopyAddrToByteArray# + , compatMkWeak# + , compatGetSizeofMutableByteArray# + , compatShrinkMutableByteArray# + , compatResizeMutableByteArray# + , Word(..) + ) where + +import qualified Prelude +import GHC.Prim +import GHC.Word +#if __GLASGOW_HASKELL__ >= 800 +import GHC.IO +#endif + +-- 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 = PinnedStatus Int# + +isPinned :: PinnedStatus -> Prelude.Bool +isPinned (PinnedStatus 0#) = Prelude.False +isPinned _ = Prelude.True + +pinned :: PinnedStatus +pinned = PinnedStatus 1# + +unpinned :: PinnedStatus +unpinned = PinnedStatus 0# + +-- | 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 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# (if isGrow then len else i) s2 of { s3 -> (# s3, dst #) }} + where + isGrow = bool# (i ># len) + !len = sizeofMutableByteArray# src +#endif +{-# INLINE compatResizeMutableByteArray# #-} diff --git a/Foundation/Internal/Proxy.hs b/Foundation/Internal/Proxy.hs new file mode 100644 --- /dev/null +++ b/Foundation/Internal/Proxy.hs @@ -0,0 +1,32 @@ +-- | +-- 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/Types.hs b/Foundation/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/Foundation/Internal/Types.hs @@ -0,0 +1,87 @@ +-- | +-- Module : Foundation.Internal.Types +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +module Foundation.Internal.Types + ( FileSize(..) + , Offset(..) + , Offset8 + , offsetOfE + , offsetPlusE + , offsetMinusE + , offsetRecast + , (+.) + , Size(..) + , Size8 + , sizeOfE + ) where + +import GHC.Types +import GHC.Word +import Foundation.Internal.Base +import Foundation.Number + +-- | 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, ..) +-- +-- Int a terrible backing type which is hard to get away +-- considering that GHC/haskell are mostly using this for offset. +-- try to bring some sanity by a lightweight wrapping +--newtype Offset = Offset Int +-- deriving (Show,Eq,Ord) +type Offset8 = Offset Word8 + +-- | Offset in element of a certain type +newtype Offset ty = Offset Int + deriving (Show,Eq,Ord) + +instance Additive (Offset ty) where + azero = Offset 0 + (+) (Offset a) (Offset b) = Offset (a+b) + +instance Subtractive (Offset ty) where + type Difference (Offset ty) = Size ty + (Offset a) - (Offset b) = Size (a-b) + +(+.) :: Offset ty -> Int -> Offset ty +(+.) (Offset a) b = Offset (a + b) + +offsetOfE :: Size8 -> Offset ty -> Offset8 +offsetOfE (Size sz) (Offset ty) = Offset (ty * sz) + +offsetPlusE :: Offset ty -> Size ty -> Offset ty +offsetPlusE (Offset ofs) (Size sz) = Offset (ofs + sz) + +offsetMinusE :: Offset ty -> Size ty -> Offset ty +offsetMinusE (Offset ofs) (Size sz) = Offset (ofs - sz) + +offsetRecast :: Size8 -> Size8 -> Offset ty -> Offset ty2 +offsetRecast szTy (Size szTy2) ofs = + let (Offset bytes) = offsetOfE szTy ofs + in Offset (bytes `div` szTy2) + +-- | Size in bytes +-- +-- Same caveat as Offset apply here +type Size8 = Size Word8 + +instance Additive (Size ty) where + azero = Size 0 + (+) (Size a) (Size b) = Size (a+b) + +instance Subtractive (Size ty) where + type Difference (Size ty) = Size ty + (Size a) - (Size b) = Size (a-b) + +-- | Size in element +newtype Size ty = Size Int + deriving (Show,Eq,Ord) + +sizeOfE :: Size8 -> Size ty -> Size8 +sizeOfE (Size sz) (Size ty) = Size (ty * sz) diff --git a/Foundation/Number.hs b/Foundation/Number.hs new file mode 100644 --- /dev/null +++ b/Foundation/Number.hs @@ -0,0 +1,387 @@ +-- | +-- Module : Foundation.Number +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- Compared to the Haskell hierarchy of number classes +-- this provide a more flexible approach that is closer to the +-- mathematical foundation (group, field, etc) +-- +-- This try to only provide one feature per class, at the expense of +-- the number of classes. +-- +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DefaultSignatures #-} +module Foundation.Number + ( Number(..) + , fromInteger + , Signed(..) + , Additive(..) + , Multiplicative(..) + , Subtractive(..) + , Divisible(..) + , Sign(..) + ) where + +import Foundation.Internal.Base +import qualified Prelude + +infixl 7 * +infixl 6 +, - +infixr 8 ^ + +-- | Sign of a signed number +data Sign = Negative | Zero | Positive + deriving (Eq) + +orderingToSign :: Ordering -> Sign +orderingToSign EQ = Zero +orderingToSign GT = Negative +orderingToSign LT = Positive + +-- | Number literals, convertible through the generic Integer type. +-- +-- all number are Enum'erable, meaning that you can move to +-- next element +class (Eq a, Ord a, Prelude.Num a, Enum a, Additive a, Subtractive a, Difference a ~ a, Multiplicative a, Divisible a) => Number a where + {-# MINIMAL toInteger #-} + --fromInteger :: Integer -> a + toInteger :: a -> Integer + +-- | convert an Integer to a type having the Number constraint +fromInteger :: Number a => Integer -> a +fromInteger = Prelude.fromInteger + +-- | Number literals that can be negative +class Number a => Signed a where + {-# MINIMAL abs, signum #-} + abs :: a -> a + signum :: a -> Sign + +-- | 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 :: Number n => n -> a -> a -- scale: repeated addition + default scale :: Number n => n -> a -> a + scale 0 _ = azero + scale 1 a = a + scale 2 a = a + a + scale n a + | n < 0 = error "cannot scale by negative number" + | otherwise = a + scale (pred n) a -- TODO optimise. define by group of 2. + +-- | 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) .. + (^) :: Number n => a -> n -> a + (^) = power + +-- | 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: +-- e.g. (-) :: Int -> Int -> Int +-- (-) :: DateTime -> DateTime -> Seconds +-- (-) :: Ptr a -> Ptr a -> PtrDiff +class Subtractive a where + type Difference a + (-) :: a -> a -> Difference a + +-- | Represent class of things that can be divided +-- +-- (x ‘div‘ y) * y + (x ‘mod‘ y) == x +class Multiplicative a => Divisible 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) + +instance Number Integer where + toInteger i = i +instance Number Int where + toInteger i = Prelude.fromIntegral i +instance Number Int8 where + toInteger i = Prelude.fromIntegral i +instance Number Int16 where + toInteger i = Prelude.fromIntegral i +instance Number Int32 where + toInteger i = Prelude.fromIntegral i +instance Number Int64 where + toInteger i = Prelude.fromIntegral i + +instance Signed Integer where + abs = Prelude.abs + signum = orderingToSign . compare 0 +instance Signed Int where + abs = Prelude.abs + signum = orderingToSign . compare 0 +instance Signed Int8 where + abs = Prelude.abs + signum = orderingToSign . compare 0 +instance Signed Int16 where + abs = Prelude.abs + signum = orderingToSign . compare 0 +instance Signed Int32 where + abs = Prelude.abs + signum = orderingToSign . compare 0 +instance Signed Int64 where + abs = Prelude.abs + signum = orderingToSign . compare 0 + +instance Number Word where + toInteger i = Prelude.fromIntegral i +instance Number Word8 where + toInteger i = Prelude.fromIntegral i +instance Number Word16 where + toInteger i = Prelude.fromIntegral i +instance Number Word32 where + toInteger i = Prelude.fromIntegral i +instance Number Word64 where + toInteger i = Prelude.fromIntegral i + +instance Additive Integer where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive Int where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive Int8 where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive Int16 where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive Int32 where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive Int64 where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive Word where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive Word8 where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive Word16 where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive Word32 where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive Word64 where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum + +scaleNum :: (Prelude.Num a, Number n) => n -> a -> a +scaleNum n a = (Prelude.fromIntegral $ toInteger n) Prelude.* a + +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 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 Multiplicative Integer where + midentity = 1 + (*) = (Prelude.*) + (^) = power +instance Multiplicative Int where + midentity = 1 + (*) = (Prelude.*) + (^) = power +instance Multiplicative Int8 where + midentity = 1 + (*) = (Prelude.*) + (^) = power +instance Multiplicative Int16 where + midentity = 1 + (*) = (Prelude.*) + (^) = power +instance Multiplicative Int32 where + midentity = 1 + (*) = (Prelude.*) + (^) = power +instance Multiplicative Int64 where + midentity = 1 + (*) = (Prelude.*) + (^) = power +instance Multiplicative Word where + midentity = 1 + (*) = (Prelude.*) + (^) = power +instance Multiplicative Word8 where + midentity = 1 + (*) = (Prelude.*) + (^) = power +instance Multiplicative Word16 where + midentity = 1 + (*) = (Prelude.*) + (^) = power +instance Multiplicative Word32 where + midentity = 1 + (*) = (Prelude.*) + (^) = power +instance Multiplicative Word64 where + midentity = 1 + (*) = (Prelude.*) + (^) = power + +power :: (Number n, Multiplicative a) => a -> n -> a +power a n + | n < 0 = error "(^): cannot use negative exponent" + | 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) + +--odd n = (n `mod` 2) /= 0 +even :: Number n => n -> Bool +even n = (n `mod` 2) == 0 + +instance Divisible Integer where + div = Prelude.div + mod = Prelude.mod +instance Divisible Int where + div = Prelude.div + mod = Prelude.mod +instance Divisible Int8 where + div = Prelude.div + mod = Prelude.mod +instance Divisible Int16 where + div = Prelude.div + mod = Prelude.mod +instance Divisible Int32 where + div = Prelude.div + mod = Prelude.mod +instance Divisible Int64 where + div = Prelude.div + mod = Prelude.mod +instance Divisible Word where + div = Prelude.quot + mod = Prelude.rem +instance Divisible Word8 where + div = Prelude.quot + mod = Prelude.rem +instance Divisible Word16 where + div = Prelude.quot + mod = Prelude.rem +instance Divisible Word32 where + div = Prelude.quot + mod = Prelude.rem +instance Divisible Word64 where + div = Prelude.quot + mod = Prelude.rem + +-- {-# RULES scaleNum = * #-} + +--numUpSize :: a -> b +--numUpSize +----------------------------------- +{- haskell numerical classes: + - +Prelude> :i Fractional +class Num a => Fractional a where + (/) :: a -> a -> a + recip :: a -> a + fromRational :: Rational -> a + -- Defined in ‘GHC.Real’ +instance Fractional Float -- Defined in ‘GHC.Float’ +instance Fractional Double -- Defined in ‘GHC.Float’ + +Prelude> :i Integral +class (Real a, Enum a) => Integral a where + quot :: a -> a -> a + rem :: a -> a -> a + div :: a -> a -> a + mod :: a -> a -> a + quotRem :: a -> a -> (a, a) + divMod :: a -> a -> (a, a) + toInteger :: a -> Integer + -- Defined in ‘GHC.Real’ +instance Integral Word -- Defined in ‘GHC.Real’ +instance Integral Integer -- Defined in ‘GHC.Real’ +instance Integral Int -- Defined in ‘GHC.Real’ + +Prelude> :i Real +class (Num a, Ord a) => Real a where + toRational :: a -> Rational + -- Defined in ‘GHC.Real’ +instance Real Word -- Defined in ‘GHC.Real’ +instance Real Integer -- Defined in ‘GHC.Real’ +instance Real Int -- Defined in ‘GHC.Real’ +instance Real Float -- Defined in ‘GHC.Float’ +instance Real Double -- Defined in ‘GHC.Float’ +-} diff --git a/Foundation/Partial.hs b/Foundation/Partial.hs new file mode 100644 --- /dev/null +++ b/Foundation/Partial.hs @@ -0,0 +1,80 @@ +-- | +-- Module : Foundation.Partial +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- Partial give a way to annotate your partial function with +-- a simple wrapper, which can only evaluated using 'fromPartial' +-- +-- > fromPartial ( head [] ) +-- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Foundation.Partial + ( Partial + , PartialError + , partialError + , partial + , fromPartial + , head + , fromJust + , fromLeft + , fromRight + ) where + +import Foundation.Internal.Base +import Foundation.Internal.Identity + +-- | Partialiality wrapper. +newtype Partial a = Partial (Identity a) + deriving (Functor, Applicative, Monad) + +-- | An error related to the evaluation of a Partial value that failed. +-- +-- it contains the name of the function and the reason for failure +data PartialError = PartialError [Char] [Char] + deriving (Show,Eq,Typeable) + +instance Exception PartialError + +-- | Throw an asynchronous PartialError +partialError :: [Char] -> [Char] -> a +partialError lbl exp = throw (PartialError lbl exp) + +-- | Create a value that is partial. this can only be +-- unwrap using the 'fromPartial' function +partial :: a -> Partial a +partial = pure + +-- | Dewrap a possible partial value +fromPartial :: Partial a -> a +fromPartial (Partial ida) = runIdentity ida + +-- | Partial function to get the head of a list +head :: [a] -> Partial a +head l = partial $ + case l of + [] -> partialError "head" "empty list" + x:_ -> x + +-- | Partial function to grab the value inside a Maybe +fromJust :: Maybe a -> Partial a +fromJust x = partial $ + case x of + Nothing -> partialError "fromJust" "Nothing" + Just y -> y + +-- Grab the Right value of an Either +fromRight :: Either a b -> Partial b +fromRight x = partial $ + case x of + Left _ -> partialError "fromRight" "Left" + Right a -> a + +-- Grab the Left value of an Either +fromLeft :: Either a b -> Partial a +fromLeft x = partial $ + case x of + Right _ -> partialError "fromLeft" "Right" + Left a -> a diff --git a/Foundation/Primitive.hs b/Foundation/Primitive.hs new file mode 100644 --- /dev/null +++ b/Foundation/Primitive.hs @@ -0,0 +1,19 @@ +-- | +-- Module : Foundation.Primitive +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +module Foundation.Primitive + ( PrimType(..) + , PrimMonad(..) + ) where + +import Foundation.Primitive.Types +import Foundation.Primitive.Monad diff --git a/Foundation/Primitive/FinalPtr.hs b/Foundation/Primitive/FinalPtr.hs new file mode 100644 --- /dev/null +++ b/Foundation/Primitive/FinalPtr.hs @@ -0,0 +1,85 @@ +-- | +-- 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 + , 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 (return, Bool(..), (==)) + +-- | Create a pointer with an associated finalizer +data FinalPtr a = FinalPtr (Ptr a) + | FinalForeign (ForeignPtr a) + +-- | 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 + return r +withFinalPtr (FinalForeign fptr) f = do + r <- f (unsafeForeignPtrToPtr fptr) + unsafePrimFromIO (touchForeignPtr fptr) + return r +{-# INLINE withFinalPtr #-} + +-- | Unsafe version of 'withFinalPtr' +withUnsafeFinalPtr :: PrimMonad prim => FinalPtr p -> (Ptr p -> prim a) -> a +withUnsafeFinalPtr fptr f = unsafePerformIO (unsafePrimToIO (withFinalPtr fptr f)) +{-# NOINLINE withUnsafeFinalPtr #-} diff --git a/Foundation/Primitive/Monad.hs b/Foundation/Primitive/Monad.hs new file mode 100644 --- /dev/null +++ b/Foundation/Primitive/Monad.hs @@ -0,0 +1,117 @@ +-- | +-- 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, (.), ($)) + +-- | Primitive monad that can handle mutation. +-- +-- For example: IO and ST. +class (Prelude.Functor 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/Types.hs b/Foundation/Primitive/Types.hs new file mode 100644 --- /dev/null +++ b/Foundation/Primitive/Types.hs @@ -0,0 +1,281 @@ +-- | +-- Module : Foundation.Primitive.Types +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +module Foundation.Primitive.Types + ( PrimType(..) + , primOffsetOfE + , primOffsetRecast + , sizeRecast + , offsetAsSize + , sizeAsOffset + ) where + +import GHC.Prim +import GHC.Int +import GHC.Types +import GHC.Word +import Foundation.Internal.Proxy +import Foundation.Internal.Base +import Foundation.Internal.Types +import Foundation.Primitive.Monad +import qualified Prelude (quot) + +-- | 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 + + ----- + -- ByteArray section + ----- + + -- | return the element stored at a specific index + primBaIndex :: ByteArray# -> Offset ty -> ty + + ----- + -- MutableByteArray section + ----- + + -- | Read an element at an index in a mutable array + primMbaRead :: 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. + primMbaWrite :: 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 () + +{-# SPECIALIZE [3] primBaIndex :: ByteArray# -> Offset Word8 -> Word8 #-} + +instance PrimType Word8 where + primSizeInBytes _ = Size 1 + {-# INLINE primSizeInBytes #-} + primBaIndex ba (Offset (I# n)) = W8# (indexWord8Array# ba n) + {-# INLINE primBaIndex #-} + primMbaRead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWord8Array# mba n s1 in (# s2, W8# r #) + {-# INLINE primMbaRead #-} + primMbaWrite mba (Offset (I# n)) (W8# w) = primitive $ \s1 -> (# writeWord8Array# mba n w s1, () #) + {-# INLINE primMbaWrite #-} + 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 _ = Size 2 + {-# INLINE primSizeInBytes #-} + primBaIndex ba (Offset (I# n)) = W16# (indexWord16Array# ba n) + {-# INLINE primBaIndex #-} + primMbaRead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWord16Array# mba n s1 in (# s2, W16# r #) + {-# INLINE primMbaRead #-} + primMbaWrite mba (Offset (I# n)) (W16# w) = primitive $ \s1 -> (# writeWord16Array# mba n w s1, () #) + {-# INLINE primMbaWrite #-} + 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 _ = Size 4 + {-# INLINE primSizeInBytes #-} + primBaIndex ba (Offset (I# n)) = W32# (indexWord32Array# ba n) + {-# INLINE primBaIndex #-} + primMbaRead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWord32Array# mba n s1 in (# s2, W32# r #) + {-# INLINE primMbaRead #-} + primMbaWrite mba (Offset (I# n)) (W32# w) = primitive $ \s1 -> (# writeWord32Array# mba n w s1, () #) + {-# INLINE primMbaWrite #-} + 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 _ = Size 8 + {-# INLINE primSizeInBytes #-} + primBaIndex ba (Offset (I# n)) = W64# (indexWord64Array# ba n) + {-# INLINE primBaIndex #-} + primMbaRead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWord64Array# mba n s1 in (# s2, W64# r #) + {-# INLINE primMbaRead #-} + primMbaWrite mba (Offset (I# n)) (W64# w) = primitive $ \s1 -> (# writeWord64Array# mba n w s1, () #) + {-# INLINE primMbaWrite #-} + 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 _ = Size 1 + {-# INLINE primSizeInBytes #-} + primBaIndex ba (Offset (I# n)) = I8# (indexInt8Array# ba n) + {-# INLINE primBaIndex #-} + primMbaRead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readInt8Array# mba n s1 in (# s2, I8# r #) + {-# INLINE primMbaRead #-} + primMbaWrite mba (Offset (I# n)) (I8# w) = primitive $ \s1 -> (# writeInt8Array# mba n w s1, () #) + {-# INLINE primMbaWrite #-} + 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 _ = Size 2 + {-# INLINE primSizeInBytes #-} + primBaIndex ba (Offset (I# n)) = I16# (indexInt16Array# ba n) + {-# INLINE primBaIndex #-} + primMbaRead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readInt16Array# mba n s1 in (# s2, I16# r #) + {-# INLINE primMbaRead #-} + primMbaWrite mba (Offset (I# n)) (I16# w) = primitive $ \s1 -> (# writeInt16Array# mba n w s1, () #) + {-# INLINE primMbaWrite #-} + 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 _ = Size 4 + {-# INLINE primSizeInBytes #-} + primBaIndex ba (Offset (I# n)) = I32# (indexInt32Array# ba n) + {-# INLINE primBaIndex #-} + primMbaRead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readInt32Array# mba n s1 in (# s2, I32# r #) + {-# INLINE primMbaRead #-} + primMbaWrite mba (Offset (I# n)) (I32# w) = primitive $ \s1 -> (# writeInt32Array# mba n w s1, () #) + {-# INLINE primMbaWrite #-} + 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 _ = Size 8 + {-# INLINE primSizeInBytes #-} + primBaIndex ba (Offset (I# n)) = I64# (indexInt64Array# ba n) + {-# INLINE primBaIndex #-} + primMbaRead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readInt64Array# mba n s1 in (# s2, I64# r #) + {-# INLINE primMbaRead #-} + primMbaWrite mba (Offset (I# n)) (I64# w) = primitive $ \s1 -> (# writeInt64Array# mba n w s1, () #) + {-# INLINE primMbaWrite #-} + 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 _ = Size 4 + {-# INLINE primSizeInBytes #-} + primBaIndex ba (Offset (I# n)) = F# (indexFloatArray# ba n) + {-# INLINE primBaIndex #-} + primMbaRead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readFloatArray# mba n s1 in (# s2, F# r #) + {-# INLINE primMbaRead #-} + primMbaWrite mba (Offset (I# n)) (F# w) = primitive $ \s1 -> (# writeFloatArray# mba n w s1, () #) + {-# INLINE primMbaWrite #-} + 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 _ = Size 8 + {-# INLINE primSizeInBytes #-} + primBaIndex ba (Offset (I# n)) = D# (indexDoubleArray# ba n) + {-# INLINE primBaIndex #-} + primMbaRead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readDoubleArray# mba n s1 in (# s2, D# r #) + {-# INLINE primMbaRead #-} + primMbaWrite mba (Offset (I# n)) (D# w) = primitive $ \s1 -> (# writeDoubleArray# mba n w s1, () #) + {-# INLINE primMbaWrite #-} + 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 _ = Size 4 + {-# INLINE primSizeInBytes #-} + primBaIndex ba (Offset (I# n)) = C# (indexWideCharArray# ba n) + {-# INLINE primBaIndex #-} + primMbaRead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWideCharArray# mba n s1 in (# s2, C# r #) + {-# INLINE primMbaRead #-} + primMbaWrite mba (Offset (I# n)) (C# w) = primitive $ \s1 -> (# writeWideCharArray# mba n w s1, () #) + {-# INLINE primMbaWrite #-} + 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 #-} + +-- | Cast a Size linked to type A (Size A) to a Size linked to type B (Size B) +sizeRecast :: (PrimType a, PrimType b) => Size a -> Size b +sizeRecast = doRecast Proxy Proxy + where doRecast :: (PrimType a, PrimType b) => Proxy a -> Proxy b -> Size a -> Size b + doRecast pa pb sz = + let szA = primSizeInBytes pa + (Size szB) = primSizeInBytes pb + (Size bytes) = sizeOfE szA sz + in Size (bytes `Prelude.quot` szB) + +primOffsetRecast :: (PrimType a, PrimType b) => Offset a -> Offset b +primOffsetRecast = doRecast Proxy Proxy + where doRecast :: (PrimType a, PrimType b) => Proxy a -> Proxy b -> Offset a -> Offset b + doRecast pa pb ofs = + let szA = primSizeInBytes pa + (Size szB) = primSizeInBytes pb + (Offset bytes) = offsetOfE szA ofs + in Offset (bytes `Prelude.quot` szB) + +primOffsetOfE :: PrimType a => Offset a -> Offset8 +primOffsetOfE = getOffset Proxy + where getOffset :: PrimType a => Proxy a -> Offset a -> Offset8 + getOffset proxy = offsetOfE (primSizeInBytes proxy) + +sizeAsOffset :: Size a -> Offset a +sizeAsOffset (Size a) = Offset a +{-# INLINE sizeAsOffset #-} + +offsetAsSize :: Offset a -> Size a +offsetAsSize (Offset a) = Size a +{-# INLINE offsetAsSize #-} diff --git a/Foundation/Primitive/Utils.hs b/Foundation/Primitive/Utils.hs new file mode 100644 --- /dev/null +++ b/Foundation/Primitive/Utils.hs @@ -0,0 +1,72 @@ +-- | +-- 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.Internal.Types +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/Strict.hs b/Foundation/Strict.hs new file mode 100644 --- /dev/null +++ b/Foundation/Strict.hs @@ -0,0 +1,37 @@ +-- | +-- Module : Foundation.Strict +-- License : BSD-style +-- Maintainer : Foundation +-- Stability : stable +-- Portability : portable +-- +-- Enforce strictness when executing lambda +-- + +module Foundation.Strict + ( strict1 + , strict2 + , strict3 + , strict4 + , strict5 + , strict6 + ) where + +strict1 :: (a -> b) -> a -> b +strict1 f !a = f a + +strict2 :: (a -> b -> c) -> a -> b -> c +strict2 f !a !b = f a b + +strict3 :: (a -> b -> c -> d) -> a -> b -> c -> d +strict3 f !a !b !c = f a b c + +strict4 :: (a -> b -> c -> d -> e) -> a -> b -> c -> d -> e +strict4 f !a !b !c !d = f a b c d + +strict5 :: (a -> b -> c -> d -> e -> f) -> a -> b -> c -> d -> e -> f +strict5 f !a !b !c !d !e = f a b c d e + +strict6 :: (a -> b -> c -> d -> e -> f -> g) -> a -> b -> c -> d -> e -> f -> g +strict6 f !a !b !c !d !e !g = f a b c d e g + diff --git a/Foundation/String.hs b/Foundation/String.hs new file mode 100644 --- /dev/null +++ b/Foundation/String.hs @@ -0,0 +1,35 @@ +-- | +-- Module : Foundation.String +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- Opaque packed String encoded in UTF8. +-- +-- The type is an instance of IsString and IsList, which allow OverloadedStrings +-- for string literal, and 'fromList' to convert a [Char] (Prelude String) to a packed +-- representation +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > s = "Hello World :: String +-- +-- > s = fromList ("Hello World" :: Prelude.String) :: String +-- +-- Each unicode code point is represented by a variable encoding of 1 to 4 bytes, +-- +-- For more information about UTF8: +-- +module Foundation.String + ( String + , Encoding(..) + , fromBytes + , fromBytesLenient + , fromBytesUnsafe + , toBytes + , ValidationFailure(..) + , lines + , words + ) where + +import Foundation.String.UTF8 diff --git a/Foundation/String/Encoding/ASCII7.hs b/Foundation/String/Encoding/ASCII7.hs new file mode 100644 --- /dev/null +++ b/Foundation/String/Encoding/ASCII7.hs @@ -0,0 +1,86 @@ +-- | +-- 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.Internal.Types +import Foundation.Number +import Foundation.Primitive.Monad + +import GHC.Prim +import GHC.Word +import GHC.Types +import Foundation.Array.Unboxed.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 + -> ArrayBuilder Word8 st () +write c + | c < toEnum 0x80 = appendTy $ 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 new file mode 100644 --- /dev/null +++ b/Foundation/String/Encoding/Encoding.hs @@ -0,0 +1,102 @@ +-- | +-- 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.Internal.Types +import Foundation.Primitive.Monad +import Foundation.Primitive.Types +import Foundation.Array.Unboxed.Builder +import Foundation.Number +import qualified Foundation.Collection as C +import Foundation.Array.Unboxed (UArray) +import qualified Foundation.Array.Unboxed as Vec + +class Encoding encoding where + -- | the unit element use for the encoding. + -- i.e. Word8 for ASCII7 or UTF8, Word16 for UTF16... + -- + type Unit encoding + + -- | define the type of error handling you want to use for the + -- next function. + -- + -- > type Error UTF8 = Either UTF8_Invalid + -- + type Error encoding + + -- | consume an `Unit encoding` and return the Unicode point and the position + -- of the next possible `Unit encoding` + -- + encodingNext :: encoding + -- ^ only used for type deduction + -> (Offset (Unit encoding) -> Unit encoding) + -- ^ method to access a given `Unit encoding` + -- (see `unsafeIndexer`) + -> Offset (Unit encoding) + -- ^ offset of the `Unit encoding` where starts the + -- encoding of a given unicode + -> Either (Error encoding) (Char, Offset (Unit encoding)) + -- ^ either successfully validated the `Unit encoding` + -- and returned the next offset or fail with an + -- `Error encoding` + + -- Write a unicode point encoded into one or multiple `Unit encoding` + -- + -- > build 64 $ sequence_ (write UTF8) "this is a simple list of char..." + -- + encodingWrite :: (PrimMonad st, Monad st) + => encoding + -- ^ only used for type deduction + -> Char + -- ^ the unicode character to encode + -> ArrayBuilder (Unit encoding) st () + +-- | 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) + , Exception (Error input) + , Encoding output, PrimType (Unit output) + ) + => input + -- ^ Input's encoding type + -> output + -- ^ Output's encoding type + -> UArray (Unit input) + -- ^ the input raw array + -> st (UArray (Unit output)) +convertFromTo inputEncodingTy outputEncodingTy bytes + | C.null bytes = return mempty + | otherwise = Vec.unsafeIndexer bytes $ \t -> build 64 (loop azero t) + where + lastUnit = Offset $ C.length bytes + + loop off getter + | off >= lastUnit = return () + | otherwise = case encodingNext inputEncodingTy getter off of + Left err -> throw 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 new file mode 100644 --- /dev/null +++ b/Foundation/String/Encoding/ISO_8859_1.hs @@ -0,0 +1,62 @@ +-- | +-- 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.Internal.Types +import Foundation.Number +import Foundation.Primitive.Monad + +import GHC.Prim +import GHC.Word +import GHC.Types +import Foundation.Array.Unboxed.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 + -> ArrayBuilder Word8 st () +write c@(C# ch) + | c <= toEnum 0xFF = appendTy (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 new file mode 100644 --- /dev/null +++ b/Foundation/String/Encoding/UTF16.hs @@ -0,0 +1,95 @@ +-- | +-- 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.Internal.Types +import Foundation.Primitive.Monad +import GHC.Prim +import GHC.Word +import GHC.Types +import Foundation.Number +import Data.Bits +import qualified Prelude +import Foundation.Array.Unboxed.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 + -> ArrayBuilder Word16 st () +write c + | c < toEnum 0xd800 = appendTy $ w16 c + | c > toEnum 0x10000 = let (w1, w2) = wHigh c in appendTy w1 >> appendTy w2 + | c > toEnum 0x10ffff = throw $ InvalidUnicode c + | c >= toEnum 0xe000 = appendTy $ 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 new file mode 100644 --- /dev/null +++ b/Foundation/String/Encoding/UTF32.hs @@ -0,0 +1,53 @@ +-- | +-- 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.Internal.Types +import Foundation.Primitive.Monad +import GHC.Prim +import GHC.Word +import GHC.Types +import Foundation.Number +import Foundation.Array.Unboxed.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 + -> ArrayBuilder Word32 st () +write c = appendTy w32 + where + !(C# ch) = c + w32 :: Word32 + w32 = W32# (int2Word# (ord# ch)) diff --git a/Foundation/String/Internal.hs b/Foundation/String/Internal.hs new file mode 100644 --- /dev/null +++ b/Foundation/String/Internal.hs @@ -0,0 +1,10 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/Foundation/String/ModifiedUTF8.hs @@ -0,0 +1,81 @@ +-- | +-- 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 MagicHash #-} +module Foundation.String.ModifiedUTF8 + ( fromModified + ) where + +import GHC.ST (runST, ST) +import GHC.Prim (Addr#) +import GHC.Ptr (Ptr(..)) +import qualified Control.Monad (mapM) + +import Foundation.Internal.Base +import Foundation.Internal.Types +import qualified Foundation.Array.Unboxed as Vec +import Foundation.Array.Unboxed (UArray) +import Foundation.Number +import Foundation.Array.Unboxed.Builder +import Foundation.Primitive.FinalPtr +import Foundation.String.UTF8Table + +-- offset of size one +aone :: Offset Word8 +aone = Offset 1 + +-- 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 :: Size Word8 + nbytes = Size $ getNbBytes $ getAtIdx offset + pastEnd :: Offset Word8 + pastEnd = aone + (offset `offsetPlusE` nbytes) + loop :: Offset Word8 -> [Word8] + loop off + | off == pastEnd = [] + | otherwise = getAtIdx off : loop (off + aone) + +buildByteArray :: Addr# -> ST st (UArray Word8) +buildByteArray addr = Vec.UVecAddr (Offset 0) (Size 100000) `fmap` + 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 = build 64 $ loopBuilder getAt (Offset 0) + loopBuilder getAt offset = + let (bs, noffset) = accessBytes offset getAt + in case bs of + [] -> internalError "ModifiedUTF8.fromModified" + [0x00] -> return () + [b1,b2] | b1 == 0xC0 && b2 == 0x80 -> appendTy 0x00 >> loopBuilder getAt noffset + _ -> Control.Monad.mapM appendTy bs >> loopBuilder getAt noffset + +{- +toModified :: ByteArray -> ByteArray +toModified = undefined +-} diff --git a/Foundation/String/UTF8.hs b/Foundation/String/UTF8.hs new file mode 100644 --- /dev/null +++ b/Foundation/String/UTF8.hs @@ -0,0 +1,962 @@ +-- | +-- 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 GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE FlexibleContexts #-} +module Foundation.String.UTF8 + ( String(..) + --, Buffer + , create + , replicate + -- * Binary conversion + , Encoding(..) + , fromBytes + , fromChunkBytes + , fromBytesUnsafe + , fromBytesLenient + , toBytes + , mutableValidate + , ValidationFailure(..) + -- * Legacy utility + , lines + , words + ) where + +import Foundation.Array.Unboxed (UArray) +import qualified Foundation.Array.Unboxed as Vec +import Foundation.Array.Unboxed.ByteArray (MutableByteArray) +import qualified Foundation.Array.Unboxed.Mutable as MVec +import qualified Foundation.Collection as C +import Foundation.Internal.Base +import Foundation.Internal.Primitive +import Foundation.Internal.Types +import Foundation.Number +import Foundation.Primitive.Monad +import Foundation.Primitive.Types +import Foundation.String.UTF8Table +import GHC.Prim +import GHC.ST +import GHC.Types +import GHC.Word +import Foundation.Array.Unboxed.Builder (ArrayBuilder, appendTy) + + -- temporary +import qualified Data.List +import Data.Data +import qualified Prelude + +import Foundation.String.ModifiedUTF8 (fromModified) +import GHC.CString (unpackCString#, + unpackCStringUtf8#) + +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 + +-- | Opaque packed array of characters in the UTF8 encoding +newtype String = String (UArray Word8) + deriving (Typeable, Monoid, Eq, Ord) + +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 + +type instance C.Element String = Char + +instance C.InnerFunctor String where + imap = charMap +instance C.Sequential String where + null = null + 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 + length = length + singleton = fromList . (:[]) + +instance C.Zippable String where + -- TODO Use a string builder once available + zipWith f a b = sFromList (C.zipWith f a b) + +data ValidationFailure = InvalidHeader + | InvalidContinuation + | MissingByte + deriving (Show,Eq,Typeable) + +instance Exception ValidationFailure + +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 + -> Size Word8 + -> (Offset8, Maybe ValidationFailure) +validate ba ofsStart sz = runST (Vec.unsafeIndexer ba go) + where + end = ofsStart `offsetPlusE` sz + + go :: (Offset Word8 -> Word8) -> ST s (Offset Word8, Maybe ValidationFailure) + go getIdx = return $ loop ofsStart + where + loop ofs + | ofs > end = error "validate: internal error: went pass offset" + | ofs == end = (end, Nothing) + | otherwise = + case {-# SCC "validate.one" #-} one ofs of + (nextOfs, Nothing) -> loop nextOfs + (pos, Just failure) -> (pos, Just failure) + + one pos = + case nbConts of + 0 -> (pos + o1, Nothing) + 0xff -> (pos, Just InvalidHeader) + _ | (pos + o1) `offsetPlusE` nbContsE > end -> (pos, Just MissingByte) + 1 -> + let c1 = getIdx (pos + o1) + in if isContinuation c1 + then (pos + Offset 2, Nothing) + else (pos, Just InvalidContinuation) + 2 -> + let c1 = getIdx (pos + o1) + c2 = getIdx (pos + Offset 2) + in if isContinuation c1 && isContinuation c2 + then (pos + Offset 3, Nothing) + else (pos, Just InvalidContinuation) + 3 -> + let c1 = getIdx (pos + Offset 1) + c2 = getIdx (pos + Offset 2) + c3 = getIdx (pos + Offset 3) + in if isContinuation c1 && isContinuation c2 && isContinuation c3 + then (pos + Offset 4, Nothing) + else (pos, Just InvalidContinuation) + _ -> error "internal error" + where + !h = getIdx pos + !nbContsE@(Size nbConts) = Size $ getNbBytes h + {-# INLINE go #-} + + o1 = Offset 1 + +mutableValidate :: PrimMonad prim + => MutableByteArray (PrimState prim) + -> Int + -> Int + -> prim (Int, Maybe ValidationFailure) +mutableValidate mba ofsStart sz = do + loop ofsStart + where + end = ofsStart + 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 <- C.mutUnsafeRead mba pos + let nbConts = getNbBytes h + if nbConts == 0xff + then return (pos, Just InvalidHeader) + else if pos + 1 + nbConts > end + then return (pos, Just MissingByte) + else do + case nbConts of + 0 -> return (pos + 1, Nothing) + 1 -> do + c1 <- C.mutUnsafeRead mba (pos + 1) + if isContinuation c1 + then return (pos + 2, Nothing) + else return (pos, Just InvalidContinuation) + 2 -> do + c1 <- C.mutUnsafeRead mba (pos + 1) + c2 <- C.mutUnsafeRead mba (pos + 2) + if isContinuation c1 && isContinuation c2 + then return (pos + 3, Nothing) + else return (pos, Just InvalidContinuation) + 3 -> do + c1 <- C.mutUnsafeRead mba (pos + 1) + c2 <- C.mutUnsafeRead mba (pos + 2) + c3 <- C.mutUnsafeRead mba (pos + 3) + if isContinuation c1 && isContinuation c2 && isContinuation c3 + then return (pos + 4, Nothing) + else return (pos, Just InvalidContinuation) + _ -> error "internal error" + +skipNext :: String -> Int -> Int +skipNext (String ba) n = n + 1 + getNbBytes h + where + !h = Vec.unsafeIndex ba n + +nextWithIndexer :: (Offset Word8 -> Word8) + -> Offset Word8 + -> (Char, Offset Word8) +nextWithIndexer getter off = + case getNbBytes# h of + 0# -> (toChar h, off + aone) + 1# -> (toChar (decode2 (getter $ off + aone)), off + atwo) + 2# -> (toChar (decode3 (getter $ off + aone) (getter $ off + atwo)), off + athree) + 3# -> (toChar (decode4 (getter $ off + aone) (getter $ off + atwo) (getter $ off + athree)) + , off + afour) + r -> error ("next: internal error: invalid input: " <> show (I# r) <> " " <> show (W# h)) + where + aone = Offset 1 + atwo = Offset 2 + athree = Offset 3 + afour = Offset 4 + !(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 + -> ArrayBuilder Word8 st () +writeWithBuilder c = + if bool# (ltWord# x 0x80## ) then encode1 + else if bool# (ltWord# x 0x800## ) then encode2 + else if bool# (ltWord# x 0x10000##) then encode3 + else encode4 + where + !(I# xi) = fromEnum c + !x = int2Word# xi + + encode1 = appendTy (W8# x) + + encode2 = do + let x1 = or# (uncheckedShiftRL# x 6#) 0xc0## + x2 = toContinuation x + appendTy (W8# x1) >> appendTy (W8# x2) + + encode3 = do + let x1 = or# (uncheckedShiftRL# x 12#) 0xe0## + x2 = toContinuation (uncheckedShiftRL# x 6#) + x3 = toContinuation x + appendTy (W8# x1) >> appendTy (W8# x2) >> appendTy (W8# x3) + + encode4 = do + let x1 = or# (uncheckedShiftRL# x 18#) 0xf0## + x2 = toContinuation (uncheckedShiftRL# x 12#) + x3 = toContinuation (uncheckedShiftRL# x 6#) + x4 = toContinuation x + appendTy (W8# x1) >> appendTy (W8# x2) >> appendTy (W8# x3) >> appendTy (W8# x4) + + toContinuation :: Word# -> Word# + toContinuation w = or# (and# w 0x3f##) 0x80## + + +next :: String -> Offset8 -> (# Char, Offset8 #) +next (String ba) (Offset n) = + case getNbBytes# h of + 0# -> (# toChar h, Offset $ n + 1 #) + 1# -> (# toChar (decode2 (Vec.unsafeIndex ba (n + 1))) , Offset $ n + 2 #) + 2# -> (# toChar (decode3 (Vec.unsafeIndex ba (n + 1)) + (Vec.unsafeIndex ba (n + 2))) , Offset $ n + 3 #) + 3# -> (# toChar (decode4 (Vec.unsafeIndex ba (n + 1)) + (Vec.unsafeIndex ba (n + 2)) + (Vec.unsafeIndex ba (n + 3))) , Offset $ n + 4 #) + r -> error ("next: internal error: invalid input: " <> show (I# r) <> " " <> show (W# h)) + where + !(W8# h) = Vec.unsafeIndex ba n + + 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##)) + ) + +-- | 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 + +writeBytes :: Char -> UTF8Char +writeBytes c = + if bool# (ltWord# x 0x80## ) then encode1 + else if bool# (ltWord# x 0x800## ) then encode2 + else if bool# (ltWord# x 0x10000##) then encode3 + else 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 #-} + +write :: PrimMonad prim => MutableString (PrimState prim) -> Offset8 -> Char -> prim Offset8 +write (MutableString mba) (Offset i) c = + if bool# (ltWord# x 0x80## ) then encode1 + else if bool# (ltWord# x 0x800## ) then encode2 + else if bool# (ltWord# x 0x10000##) then encode3 + else encode4 + where + !(I# xi) = fromEnum c + !x = int2Word# xi + + encode1 = C.mutUnsafeWrite mba i (W8# x) >> return (Offset $ i + 1) + + encode2 = do + let x1 = or# (uncheckedShiftRL# x 6#) 0xc0## + x2 = toContinuation x + C.mutUnsafeWrite mba i (W8# x1) + C.mutUnsafeWrite mba (i+1) (W8# x2) + return $ Offset (i + 2) + + encode3 = do + let x1 = or# (uncheckedShiftRL# x 12#) 0xe0## + x2 = toContinuation (uncheckedShiftRL# x 6#) + x3 = toContinuation x + C.mutUnsafeWrite mba i (W8# x1) + C.mutUnsafeWrite mba (i+1) (W8# x2) + C.mutUnsafeWrite mba (i+2) (W8# x3) + return $ Offset (i + 3) + + encode4 = do + let x1 = or# (uncheckedShiftRL# x 18#) 0xf0## + x2 = toContinuation (uncheckedShiftRL# x 12#) + x3 = toContinuation (uncheckedShiftRL# x 6#) + x4 = toContinuation x + C.mutUnsafeWrite mba i (W8# x1) + C.mutUnsafeWrite mba (i+1) (W8# x2) + C.mutUnsafeWrite mba (i+2) (W8# x3) + C.mutUnsafeWrite mba (i+3) (W8# x4) + return $ Offset (i + 4) + + toContinuation :: Word# -> Word# + toContinuation w = or# (and# w 0x3f##) 0x80## + +freeze :: PrimMonad prim => MutableString (PrimState prim) -> prim String +freeze (MutableString mba) = String `fmap` C.unsafeFreeze mba +{-# INLINE freeze #-} + +------------------------------------------------------------------------ +-- real functions + +sToList :: String -> [Char] +sToList s = loop azero + where + !nbBytes = size s + end = azero `offsetPlusE` nbBytes + loop idx + | idx == end = [] + | otherwise = + let (# 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 + #-} + +sFromList :: [Char] -> String +sFromList l = runST (new bytes >>= copy) + where + -- count how many bytes + !bytes = C.foldl' (+) (Size 0) $ fmap (charToBytes . fromEnum) l + + copy :: MutableString (PrimState (ST st)) -> ST st String + copy ms = loop azero l + where + loop _ [] = freeze ms + loop idx (c:xs) = write ms idx c >>= \idx' -> loop idx' xs + -- write those bytes + --loop :: MutableByteArray# st -> Int# -> State# st -> [Char] -> (# State# st, String #) +{-# INLINE [0] sFromList #-} + +null :: String -> Bool +null (String ba) = C.length ba == 0 + +-- | Create a string composed of a number @n of Chars (Unicode code points). +-- +-- if the input @s contains less characters than required, then +take :: Int -> String -> String +take n s = fst $ splitAt n s -- TODO specialize + +-- | Create a string with the remaining Chars after dropping @n Chars from the beginning +drop :: Int -> String -> String +drop n s@(String ba) + | n <= 0 = s + | otherwise = loop 0 0 + where + !sz = C.length ba + loop idx i + | idx >= sz = mempty + | i == n = String $ C.drop idx ba + | otherwise = loop (skipNext s idx) (i + 1) + +splitAt :: Int -> String -> (String, String) +splitAt n s@(String ba) + | n <= 0 = (mempty, s) + | otherwise = loop 0 0 + where + !sz = C.length ba + loop idx i + | idx >= sz = (s, mempty) + | i == n = let (v1,v2) = C.splitAt idx ba in (String v1, String v2) + | otherwise = loop (skipNext s idx) (i + 1) + +-- rev{Take,Drop,SplitAt} TODO optimise: +-- we can process the string from the end using a skipPrev instead of getting the length + +revTake :: Int -> String -> String +revTake nbElems v = drop (length v - nbElems) v + +revDrop :: Int -> String -> String +revDrop nbElems v = take (length v - nbElems) v + +revSplitAt :: Int -> String -> (String, String) +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 :: (Char -> Bool) -> String -> [String] +splitOn predicate s + | sz == Size 0 = [] + | otherwise = loop azero azero + where + !sz = size s + end = azero `offsetPlusE` sz + loop prevIdx idx + | idx == end = [sub s prevIdx idx] + | otherwise = + let (# c, idx' #) = next s idx + in if predicate c + then sub s prevIdx idx : loop idx' idx' + else loop prevIdx idx' + +sub :: String -> Offset8 -> Offset8 -> String +sub (String ba) (Offset start) (Offset end) = String $ Vec.sub ba start end + +-- | Split at a given index. +splitIndex :: Offset8 -> String -> (String, String) +splitIndex (Offset idx) (String ba) = (String v1, String v2) + where (v1,v2) = C.splitAt idx ba + +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 #-} + +{-# RULES "break (== 'c')" [3] forall c . break (== c) = breakElem c #-} + +breakElem :: Char -> String -> (String, String) +breakElem !el s@(String ba) = + case writeBytes el of + UTF8_1 w -> let (# v1,v2 #) = Vec.splitElem 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' + +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 + ((srcLen - 1) `scale` charToBytes (fromEnum sep)) + + lastSrc :: Offset Char + lastSrc = Offset 0 `offsetPlusE` Size srcLen + + go :: Char -> String -> Offset Char -> Offset8 -> MutableString s -> Offset8 -> ST s (Offset8, Offset8) + go sep' src' srcI srcIdx dst dstIdx + | srcI == lastSrc = 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 + (# 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` Size 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' + +span :: (Char -> Bool) -> String -> (String, String) +span predicate s = break (not . predicate) s + +-- | size in bytes +size :: String -> Size8 +size (String ba) = Size $ C.length ba + +length :: String -> Int +length s@(String ba) = loop 0 0 + where + !sz = C.length ba + loop idx !i + | idx == sz = i + | otherwise = + let idx' = skipNext s idx + in loop idx' (i + 1) + +replicate :: Int -> Char -> String +replicate n c = runST (new nbBytes >>= fill) + where + end = azero `offsetPlusE` nbBytes + nbBytes = Size $ sz * n + (Size sz) = charToBytes (fromEnum c) + fill :: PrimMonad prim => MutableString (PrimState prim) -> prim String + fill ms = loop (Offset 0) + where + loop idx + | idx == end = freeze ms + | otherwise = write ms idx c >>= loop + +{- +sizeBytes :: String -> Int +sizeBytes (String ba) = I# (sizeofByteArray# ba) +-} + +-- | 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 + +create :: PrimMonad prim => Int -> (MutableString (PrimState prim) -> prim Int) -> prim String +create sz f = do + ms <- new (Size sz) + filled <- f ms + if filled == sz + then freeze ms + else C.take filled `fmap` freeze ms + +charToBytes :: Int -> Size8 +charToBytes c + | c < 0x80 = Size 1 + | c < 0x800 = Size 2 + | c < 0x10000 = Size 3 + | c < 0x110000 = Size 4 + | otherwise = error ("invalid code point: " `mappend` show c) + +charMap :: (Char -> Char) -> String -> String +charMap f src = + let !(elems, nbBytes) = allocateAndFill [] (Offset 0) (Size 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 <= Size 4 then Size 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 (# 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 + +snoc :: String -> Char -> String +snoc s@(String ba) c + | len == Size 0 = C.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) + +cons :: Char -> String -> String +cons c s@(String ba) + | len == Size 0 = C.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) + +unsnoc :: String -> Maybe (String, Char) +unsnoc s + | null s = Nothing + | otherwise = + let (s1,s2) = revSplitAt 1 s + in case toList s1 of -- TODO use index instead of toList + [c] -> Just (s2, c) + _ -> internalError "unsnoc" + +uncons :: String -> Maybe (Char, String) +uncons s + | null s = Nothing + | otherwise = + let (s1,s2) = splitAt 1 s + in case toList s1 of -- TODO use index instead of ToList + [c] -> Just (c, s2) + _ -> internalError "uncons" + +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 (# c, idx' #) = next s idx + in case predicate c of + True -> Just c + False -> loop idx' + +sortBy :: (Char -> Char -> Ordering) -> String -> String +sortBy sortF s = fromList $ Data.List.sortBy sortF $ toList s -- FIXME for tests + +filter :: (Char -> Bool) -> String -> String +filter p s = fromList $ Data.List.filter p $ toList s + +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) sidx@(Offset si) didx + | didx == Offset 0 = freeze ms + | otherwise = do + let !h = Vec.unsafeIndex ba si + !nb = Size (getNbBytes h + 1) + didx'@(Offset d) = didx `offsetMinusE` nb + case nb of + Size 1 -> C.mutUnsafeWrite mba d h + Size 2 -> do + C.mutUnsafeWrite mba d h + C.mutUnsafeWrite mba (d + 1) (Vec.unsafeIndex ba (si + 1)) + Size 3 -> do + C.mutUnsafeWrite mba d h + C.mutUnsafeWrite mba (d + 1) (Vec.unsafeIndex ba (si + 1)) + C.mutUnsafeWrite mba (d + 2) (Vec.unsafeIndex ba (si + 2)) + Size 4 -> do + C.mutUnsafeWrite mba d h + C.mutUnsafeWrite mba (d + 1) (Vec.unsafeIndex ba (si + 1)) + C.mutUnsafeWrite mba (d + 2) (Vec.unsafeIndex ba (si + 2)) + C.mutUnsafeWrite mba (d + 3) (Vec.unsafeIndex ba (si + 3)) + _ -> return () -- impossible + loop ms (sidx `offsetPlusE` nb) didx' + +{- +-- | Convert a Byte Array to a string and check UTF8 validity +fromBytes :: Encoding -> UArray Word8 -> Maybe String +fromBytes UTF8 bytes = + case validate bytes 0 (C.length bytes) of + (_, Nothing) -> Just $ fromBytesUnsafe bytes + (_, Just _) -> Nothing + -} + +data Encoding + = ASCII7 + | UTF8 + | UTF16 + | UTF32 + | ISO_8859_1 + deriving (Typeable, Data, Eq, Ord, Show, Enum, Bounded) + +fromEncoderBytes :: ( Encoder.Encoding encoding + , Exception (Encoder.Error encoding) + , PrimType (Encoder.Unit encoding) + ) + => encoding + -> UArray Word8 + -> (String, Maybe ValidationFailure, UArray Word8) +fromEncoderBytes enc bytes = + ( String $ runST $ Encoder.convertFromTo enc EncoderUTF8 (Vec.recast bytes) + , Nothing + , mempty + ) + + +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) (Size $ C.length bytes) of + (_, Nothing) -> (fromBytesUnsafe bytes, Nothing, mempty) + (Offset pos, Just vf) -> + let (b1, b2) = C.splitAt pos bytes + in (fromBytesUnsafe b1, toErr vf, b2) + where + toErr MissingByte = Nothing + toErr InvalidHeader = Just InvalidHeader + toErr InvalidContinuation = Just InvalidContinuation + +fromBytesLenient :: UArray Word8 -> (String, UArray Word8) +fromBytesLenient bytes + | C.null bytes = (mempty, mempty) + | otherwise = + case validate bytes (Offset 0) (Size $ C.length bytes) of + (_, Nothing) -> (fromBytesUnsafe bytes, mempty) + (Offset pos, Just MissingByte) -> + let (b1,b2) = C.splitAt pos bytes + in (fromBytesUnsafe b1, b2) + (Offset pos, Just InvalidHeader) -> + let (b1,b2) = C.splitAt pos bytes + (_,b3) = C.splitAt 1 b2 + (s3, r) = fromBytesLenient b3 + in (mconcat [fromBytesUnsafe b1,replacement, s3], r) + (Offset pos, Just InvalidContinuation) -> + let (b1,b2) = C.splitAt 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] + +fromChunkBytes :: [UArray Word8] -> [String] +fromChunkBytes l = loop l + where + loop [] = [] + loop (bytes:[]) = + case validate bytes (Offset 0) (Size $ C.length bytes) of + (_, Nothing) -> [fromBytesUnsafe bytes] + (_, Just err) -> doErr err + loop (bytes:cs@(c1:c2)) = + case validate bytes (Offset 0) (Size $ C.length bytes) of + (_, Nothing) -> fromBytesUnsafe bytes : loop cs + (Offset pos, Just MissingByte) -> + let (b1,b2) = C.splitAt pos bytes + in fromBytesUnsafe b1 : loop ((b2 `mappend` c1) : c2) + (_, Just err) -> doErr err + doErr err = error ("fromChunkBytes: " <> show err) + +-- | Convert a Byte Array directly to a string without checking for UTF8 validity +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 (runST $ Encoder.convertFromTo EncoderUTF8 enc bytes) + +-- | Convert a String to a bytearray +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 + +lines :: String -> [String] +lines = fmap fromList . Prelude.lines . toList + +words :: String -> [String] +words = fmap fromList . Prelude.words . toList diff --git a/Foundation/String/UTF8Table.hs b/Foundation/String/UTF8Table.hs new file mode 100644 --- /dev/null +++ b/Foundation/String/UTF8Table.hs @@ -0,0 +1,83 @@ +-- | +-- Module : Foundation.String.UTF8Table +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- UTF8 lookup tables for fast continuation & nb bytes per header queries +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +module Foundation.String.UTF8Table + ( 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/System/Info.hs b/Foundation/System/Info.hs new file mode 100644 --- /dev/null +++ b/Foundation/System/Info.hs @@ -0,0 +1,138 @@ +-- | +-- Module : Foundation.System.Info +-- License : BSD-style +-- Maintainer : foundation +-- Stability : experimental +-- Portability : portable +-- + +{-# LANGUAGE CPP #-} + +module Foundation.System.Info + ( + -- * Operation System info + OS(..) + , os + -- * CPU info + , arch + , cpus + , Endianness(..) + , endianness + -- * Compiler info + , compilerName + , System.Info.compilerVersion + , Data.Version.Version(..) + ) where + +import qualified System.Info +import qualified Data.Version +import Data.Data +import qualified GHC.Conc +import Foundation.String +import Foundation.Internal.Base + +#ifdef ARCH_IS_UNKNOWN_ENDIAN +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 + +data OS + = Windows + | OSX + | Linux + | Android + | BSD + deriving (Show, Eq, Ord, Enum, Bounded, Data, Typeable) + +-- | get the operating system on which the program is running. +-- +-- Either return the known `OS` or a strict `String` of the OS name. +-- +-- This function uses the `base`'s `System.Info.os` function. +-- +os :: Either String OS +os = case System.Info.os of + "darwin" -> Right OSX + "mingw32" -> Right Windows + "linux" -> Right Linux + "linux-android" -> Right Android + "openbsd" -> Right BSD + "netbsd" -> Right BSD + "freebsd" -> Right BSD + str -> Left $ fromList str + +-- | Enumeration of the known GHC supported architecture. +-- +data Arch + = I386 + | X86_64 + | PowerPC + | PowerPC64 + | Sparc + | Sparc64 + | ARM + | ARM64 + deriving (Show, Eq, Ord, Enum, Bounded, Data, Typeable) + +-- | get the machine architecture on which the program is running +-- +-- Either return the known architecture or a Strict `String` of the +-- architecture name. +-- +-- This function uses the `base`'s `System.Info.arch` function. +-- +arch :: Either String Arch +arch = case System.Info.arch of + "i386" -> Right I386 + "x86_64" -> Right X86_64 + "powerpc" -> Right PowerPC + "powerpc64" -> Right PowerPC64 + "powerpc64le" -> Right PowerPC64 + "sparc" -> Right Sparc + "sparc64" -> Right Sparc64 + "arm" -> Right ARM + "aarch64" -> Right ARM64 + str -> Left $ fromList str + +-- | get the compiler name +-- +-- get the compilerName from base package but convert +-- it into a strict String +compilerName :: String +compilerName = fromList System.Info.compilerName + +-- | returns the number of CPUs the machine has +cpus :: IO Int +cpus = GHC.Conc.getNumProcessors + +data Endianness + = LittleEndian + | BigEndian + deriving (Eq, Show) + +-- | 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/Tuple.hs b/Foundation/Tuple.hs new file mode 100644 --- /dev/null +++ b/Foundation/Tuple.hs @@ -0,0 +1,98 @@ +-- | +-- Module : Foundation.Tuple +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Foundation.Tuple + ( Tuple2(..) + , Tuple3(..) + , Tuple4(..) + , Fstable(..) + , Sndable(..) + , Thdable(..) + ) where + +import Foundation.Internal.Base +import Data.Data + +-- | Strict tuple (a,b) +data Tuple2 a b = Tuple2 !a !b + deriving (Show,Eq,Ord,Typeable,Data,Generic) + +-- | Strict tuple (a,b,c) +data Tuple3 a b c = Tuple3 !a !b !c + deriving (Show,Eq,Ord,Typeable,Data,Generic) + +-- | Strict tuple (a,b,c,d) +data Tuple4 a b c d = Tuple4 !a !b !c !d + deriving (Show,Eq,Ord,Typeable,Data,Generic) + +-- | Class of product types that have a first element +class Fstable a where + type FstTy a + fst :: a -> FstTy a + +-- | Class of product types that have a second element +class Sndable a where + type SndTy a + snd :: a -> SndTy a + +-- | Class of product types that have a third element +class Thdable a where + type ThdTy a + thd :: a -> ThdTy a + +instance Fstable (a,b) where + type FstTy (a,b) = a + fst (a,_) = a +instance Fstable (a,b,c) where + type FstTy (a,b,c) = a + fst (a,_,_) = a +instance Fstable (a,b,c,d) where + type FstTy (a,b,c,d) = a + fst (a,_,_,_) = a +instance Fstable (Tuple2 a b) where + type FstTy (Tuple2 a b) = a + fst (Tuple2 a _) = a +instance Fstable (Tuple3 a b c) where + type FstTy (Tuple3 a b c) = a + fst (Tuple3 a _ _) = a +instance Fstable (Tuple4 a b c d) where + type FstTy (Tuple4 a b c d) = a + fst (Tuple4 a _ _ _) = a + +instance Sndable (a,b) where + type SndTy (a,b) = b + snd (_,b) = b +instance Sndable (a,b,c) where + type SndTy (a,b,c) = b + snd (_,b,_) = b +instance Sndable (a,b,c,d) where + type SndTy (a,b,c,d) = b + snd (_,b,_,_) = b +instance Sndable (Tuple2 a b) where + type SndTy (Tuple2 a b) = b + snd (Tuple2 _ b) = b +instance Sndable (Tuple3 a b c) where + type SndTy (Tuple3 a b c) = b + snd (Tuple3 _ b _) = b +instance Sndable (Tuple4 a b c d) where + type SndTy (Tuple4 a b c d) = b + snd (Tuple4 _ b _ _) = b + +instance Thdable (a,b,c) where + type ThdTy (a,b,c) = c + thd (_,_,c) = c +instance Thdable (a,b,c,d) where + type ThdTy (a,b,c,d) = c + thd (_,_,c,_) = c +instance Thdable (Tuple3 a b c) where + type ThdTy (Tuple3 a b c) = c + thd (Tuple3 _ _ c) = c +instance Thdable (Tuple4 a b c d) where + type ThdTy (Tuple4 a b c d) = c + thd (Tuple4 _ _ c _) = c diff --git a/Foundation/VFS.hs b/Foundation/VFS.hs new file mode 100644 --- /dev/null +++ b/Foundation/VFS.hs @@ -0,0 +1,32 @@ +-- | +-- Module : Foundation.VFS +-- License : BSD-style +-- Maintainer : foundation +-- Stability : experimental +-- Portability : portable +-- +module Foundation.VFS + ( Path(..) + , filename + , parent + , prefix + , suffix + + -- * FilePath + , FilePath + , FileName + -- ** conversion + , filePathToString + , filePathToLString + ) where + + +import Foundation.VFS.Path + ( Path(..) + , filename, parent, suffix, prefix + ) +import Foundation.VFS.FilePath + ( FilePath, FileName + , filePathToString + , filePathToLString + ) diff --git a/Foundation/VFS/FilePath.hs b/Foundation/VFS/FilePath.hs new file mode 100644 --- /dev/null +++ b/Foundation/VFS/FilePath.hs @@ -0,0 +1,256 @@ +-- | +-- Module : Foundation.VFS.FilePath +-- License : BSD-style +-- Maintainer : foundation +-- Stability : experimental +-- Portability : portable +-- +-- # Opaque implementation for FilePath +-- +-- The underlying type of a FilePath is a `Foundation.ByteArray`. It is indeed like +-- this because for some systems (Unix systems) a `FilePath` is a null +-- terminated array of bytes. +-- +-- # FilePath and FileName for type checking validation +-- +-- In order to add some constraint at compile time, it is not possible to +-- append (``) a `FilePath` to another `FilePath`. +-- You can only append (``) a `FileName` to a given `FilePath`. +-- + +{-# LANGUAGE CPP #-} + +module Foundation.VFS.FilePath + ( FilePath + , Relativity(..) + , FileName + -- * conversion + , filePathToString + , filePathToLString + + -- ** unsafe + , unsafeFilePath + , unsafeFileName + , extension + ) where + +import Foundation.Internal.Base +import Foundation.Collection +import Foundation.Array +import Foundation.String (Encoding(..), ValidationFailure, toBytes, fromBytes, String) +import Foundation.VFS.Path(Path(..)) + +import qualified Data.List +import Foundation.Partial +-- ------------------------------------------------------------------------- -- +-- System related helpers -- +-- ------------------------------------------------------------------------- -- + +#ifdef mingw32_HOST_OS +pathSeparatorWINC :: Char +pathSeparatorWINC = '\\' + +-- | define the Path separator for Windows systems : '\\' +pathSeparatorWIN :: String +pathSeparatorWIN = fromString [pathSeparatorWINC] +#else +pathSeparatorPOSIXC :: Char +pathSeparatorPOSIXC = '/' + +-- | define the Path separator for POSIX systems : '/' +pathSeparatorPOSIX :: String +pathSeparatorPOSIX = fromString [pathSeparatorPOSIXC] +#endif + +pathSeparatorC :: Char +pathSeparator :: String +#ifdef mingw32_HOST_OS +pathSeparatorC = pathSeparatorWINC +pathSeparator = pathSeparatorWIN +#else +pathSeparatorC = pathSeparatorPOSIXC +pathSeparator = pathSeparatorPOSIX +#endif + +-- ------------------------------------------------------------------------- -- +-- FilePath -- +-- ------------------------------------------------------------------------- -- + +-- | information about type of FilePath +-- +-- A file path being only `Relative` or `Absolute`. +data Relativity = Absolute | Relative + deriving (Eq, Show) + +-- | FilePath is a collection of FileName +-- +-- TODO: Eq and Ord are implemented using Show +-- This is not very efficient and would need to be improved +-- Also, it is possible the ordering is not necessary what we want +-- in this case. +-- +-- A FilePath is one of the following: +-- +-- * An Absolute: +-- * starts with one of the follwing "/" +-- * A relative: +-- * don't start with a "/" +-- +-- * authorised: +-- * "/" +-- * "/file/path" +-- * "." +-- * ".." +-- * "work/haskell/hs-foundation" +-- +-- * unauthorised +-- * "path//" +data FilePath = FilePath Relativity [FileName] + +instance Show FilePath where + show = filePathToLString +instance Eq FilePath where + (==) a b = (==) (show a) (show b) +instance Ord FilePath where + compare a b = compare (show a) (show b) + +-- | error associated to filepath manipulation +data FilePath_Invalid + = ContiguousPathSeparator + -- ^ this mean there were 2 contiguous path separators. + -- + -- This is not valid in Foundation's FilePath specifications + deriving (Typeable, Show) +instance Exception FilePath_Invalid + +instance IsString FilePath where + fromString [] = FilePath Absolute mempty + fromString s@(x:xs) + | hasContigueSeparators s = throw ContiguousPathSeparator + | otherwise = FilePath relativity $ case relativity of + Absolute -> fromString <$> splitOn isSeparator xs + Relative -> fromString <$> splitOn isSeparator s + where + relativity :: Relativity + relativity = if isSeparator x then Absolute else Relative + +-- | A filename (or path entity) in the FilePath +-- +-- * Authorised +-- * "" +-- * "." +-- * ".." +-- * "foundation" +-- * Unauthorised +-- * "/" +-- * "file/" +-- * "/file" +-- * "file/path" +-- +data FileName = FileName (UArray Word8) + deriving (Eq) +-- | errors related to FileName manipulation +data FileName_Invalid + = ContainsNullByte + -- ^ this means a null byte was found in the FileName + | ContainsSeparator + -- ^ this means a path separator was found in the FileName + | EncodingError ValidationFailure + -- ^ encoding error + | UnknownTrailingBytes (UArray Word8) + -- ^ some unknown trainling bytes found + deriving (Typeable, Show) +instance Exception FileName_Invalid + +instance Show FileName where + show = fileNameToLString +instance IsString FileName where + fromString [] = FileName mempty + fromString xs | hasNullByte xs = throw ContainsNullByte + | hasSeparator xs = throw ContainsSeparator + | otherwise = FileName $ toBytes UTF8 $ fromString xs + +hasNullByte :: [Char] -> Bool +hasNullByte = Data.List.elem '\0' + +hasSeparator :: [Char] -> Bool +hasSeparator = Data.List.elem pathSeparatorC + +isSeparator :: Char -> Bool +isSeparator = (==) pathSeparatorC + +hasContigueSeparators :: [Char] -> Bool +hasContigueSeparators [] = False +hasContigueSeparators [_] = False +hasContigueSeparators (x1:x2:xs) = + (isSeparator x1 && x1 == x2) || hasContigueSeparators xs + +instance Monoid FileName where + mempty = FileName mempty + mappend (FileName a) (FileName b) = FileName $ a `mappend` b + +instance Path FilePath where + type PathEnt FilePath = FileName + type PathPrefix FilePath = Relativity + type PathSuffix FilePath = () + () = join + splitPath (FilePath r xs) = (r, xs, ()) + buildPath (r, xs , _) = FilePath r xs + +-- compare to the original , this type disallow to be able to append an absolute filepath to a filepath +join :: FilePath -> FileName -> FilePath +join p (FileName x) | null x = p +join (FilePath r xs) x = FilePath r $ snoc xs x + +filePathToString :: FilePath -> String +filePathToString (FilePath Absolute []) = fromString [pathSeparatorC] +filePathToString (FilePath Relative []) = fromString "." +filePathToString (FilePath Absolute fns) = cons pathSeparatorC $ filenameIntercalate fns +filePathToString (FilePath Relative fns) = filenameIntercalate fns + +filenameIntercalate :: [FileName] -> String +filenameIntercalate = mconcat . Data.List.intersperse pathSeparator . fmap fileNameToString + +-- | convert a FileName into a String +-- +-- This function may throw an exception associated to the encoding +fileNameToString :: FileName -> String +fileNameToString (FileName fp) = + -- FIXME probably incorrect considering windows. + -- this is just to get going to be able to be able to reuse System.IO functions which + -- works on [Char] + case fromBytes UTF8 fp of + (s, Nothing, bs) + | null bs -> s + | otherwise -> throw $ UnknownTrailingBytes bs + (_, Just err, _) -> throw $ EncodingError err + +-- | conversion of FileName into a list of Char +-- +-- this function may throw exceptions +fileNameToLString :: FileName -> [Char] +fileNameToLString = toList . fileNameToString + +-- | conversion of a FilePath into a list of Char +-- +-- this function may throw exceptions +filePathToLString :: FilePath -> [Char] +filePathToLString = toList . filePathToString + +-- | build a file path from a given list of filename +-- +-- this is unsafe and is mainly needed for testing purpose +unsafeFilePath :: Relativity -> [FileName] -> FilePath +unsafeFilePath = FilePath + +-- | build a file name from a given ByteArray +-- +-- this is unsafe and is mainly needed for testing purpose +unsafeFileName :: UArray Word8 -> FileName +unsafeFileName = FileName + +extension :: FileName -> Maybe FileName +extension (FileName fn) = case splitOn (\c -> c == 0x2E) fn of + [] -> Nothing + [_] -> Nothing + xs -> Just $ FileName $ fromPartial $ head $ reverse xs diff --git a/Foundation/VFS/Path.hs b/Foundation/VFS/Path.hs new file mode 100644 --- /dev/null +++ b/Foundation/VFS/Path.hs @@ -0,0 +1,141 @@ +-- | +-- Module : Foundation.VFS.Path +-- License : BSD-style +-- Maintainer : foundation +-- Stability : experimental +-- Portability : portable +-- + +{-# LANGUAGE FlexibleContexts #-} + +module Foundation.VFS.Path + ( + -- * Path class + Path(..) + + , parent + , filename + , prefix + , suffix + ) where + +import Foundation.Internal.Base + +-- | Path type class +-- +-- defines the Path associated types and basic functions to implement related +-- to the path manipulation +-- +-- # TODO, add missing enhancement: +-- +-- ``` +-- splitExtension :: PathEnt path -> (PathEnt path, PathEnt path) +-- addExtension :: PathEnt path -> PathEnt path -> PathEnt path +-- (<.>) :: path -> PathEnt path -> path +-- (-<.>) :: path -> PathEnt path -> path +-- ``` +-- +class Path path where + -- | the associated PathEntity of the given `path` + -- this type is the minimal element contained in the Path + -- a Path is not a collection but it is possible to see this + -- associated type equivalent to the `Foundation.Collection.Element` type family + type PathEnt path + + -- | the associated prefix of the given `path` + -- + -- in the case of a `FilePath`, it is a void (i.e. `()`) + -- in the case of an `URI`, it is the schema, host, port... + type PathPrefix path + + -- | the associated suffix of the given path + -- + -- in the case of the `FilePath`, it is a void (i.e. `()`) + -- in the case of the `URI`, it is a the query, the fragment + type PathSuffix path + + -- | join a path entity to a given path + () :: path -> PathEnt path -> path + + -- | split the path into the associated elements + splitPath :: path -> ( PathPrefix path + , [PathEnt path] + , PathSuffix path + ) + -- | build the path from the associated elements + buildPath :: ( PathPrefix path + , [PathEnt path] + , PathSuffix path + ) + -> path + + +-- | parent is only going to drop the filename. +-- +-- if you actually want to reference to the parent directory, simply uses: +-- +-- ``` +-- parent "." /= "." ".." +-- ``` +parent :: Path path => path -> path +parent path = buildPath (p, init ps, s) + where + (p, ps , s) = splitPath path + + +-- | get the filename of the given path +-- +-- If there is no filename, you will receive the mempty of the PathEnt +filename :: (Path path, Monoid (PathEnt path)) => path -> PathEnt path +filename path = case ps of + [] -> mempty + _ -> last ps + where + (_, ps , _) = splitPath path + +-- TODO: this might be better in Sequential ? +init :: [a] -> [a] +init [] = [] +init [_] = [] +init (x:xs) = x : init xs + +-- TODO: this might be better in Sequential ? +last :: [a] -> a +last [] = undefined +last [x] = x +last (_:xs) = last xs + + +-- | get the path prefix information +-- +-- ``` +-- prefix "/home/tab" == () +-- ``` +-- +-- or for URI (TODO, not yet accurate) +-- +-- ``` +-- prefix "http://github.com/vincenthz/hs-foundation?w=1" +-- == URISchema http Nothing Nothing "github.com" Nothing +-- ``` +prefix :: Path path => path -> PathPrefix path +prefix p = pre + where + (pre, _, _) = splitPath p + +-- | get the path suffix information +-- +-- ``` +-- suffix "/home/tab" == () +-- ``` +-- +-- or for URI (TODO, not yet accurate) +-- +-- ``` +-- suffix "http://github.com/vincenthz/hs-foundation?w=1" +-- == URISuffix (["w", "1"], Nothing) +-- ``` +suffix :: Path path => path -> PathSuffix path +suffix p = suf + where + (_, _, suf) = splitPath p diff --git a/Foundation/VFS/URI.hs b/Foundation/VFS/URI.hs new file mode 100644 --- /dev/null +++ b/Foundation/VFS/URI.hs @@ -0,0 +1,38 @@ +-- | +-- Module : Foundation.VFS.URI +-- License : BSD-style +-- Maintainer : foundation +-- Stability : experimental +-- Portability : portable +-- + +module Foundation.VFS.URI + ( URI(..) + , URISchema(..) + , URIAuthority(..) + , URIQuery(..) + , URIFragment(..) + , URIPath(..) + ) where + +import Foundation.Internal.Base +import Foundation.VFS.Path(Path(..)) + +-- ------------------------------------------------------------------------- -- +-- URI -- +-- ------------------------------------------------------------------------- -- + +-- | TODO this is not implemented yet +data URI = URI +data URISchema = URISchema +data URIAuthority = URIAuthority +data URIQuery = URIQuery +data URIFragment = URIFragment +data URIPath = URIPath +instance Path URI where + type PathEnt URI = URIPath + type PathPrefix URI = (URISchema, URIAuthority) + type PathSuffix URI = (URIQuery, URIFragment) + () = undefined + splitPath = undefined + buildPath = undefined diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2015-2016 Vincent Hanquez + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,65 @@ +Foundation +========== + +[![Build Status](https://travis-ci.org/haskell-foundation/foundation.png?branch=master)](https://travis-ci.org/haskell-foundation/foundation) +[![BSD](http://b.repl.ca/v1/license-BSD-blue.png)](http://en.wikipedia.org/wiki/BSD_licenses) +[![Haskell](http://b.repl.ca/v1/language-haskell-lightgrey.png)](http://haskell.org) + +Documentation: [foundation on hackage](http://hackage.haskell.org/package/foundation) + +Goals +===== + +* provide a base like set of modules that provide a consistent set of features and bugfixes across multiple versions of GHC (unlike base). +* provide a better and more efficient prelude than base's prelude. +* be self-sufficient: no external dependencies apart from base (or ghc packages). +* provide better data-types: packed unicode string by default, arrays. +* Better numerical classes that better represent mathematical things (No more all-in-one Num). + +How to use +========== + +Disable the built-in prelude at the top of your file: + +```haskell +{-# LANGUAGE NoImplicitPrelude #-} +``` + +Or directly in your project cabal file: + +```haskell +Default-Extensions: NoImplicitPrelude +``` + +Then in your modules: + +```haskell +import Foundation +``` + +How to contribute +================= + +Any contributions is welcome, but a short list includes: + +* Improve the code base +* Report an issue +* Fix an issue +* Improve the documentation +* Make tutorial on how to use foundation +* Make your project use foundation instead of base, report the missing coverage (IO, types, etc.), or what functionality is missing to make a succesful transition + + +Design +====== + +Foundation started on the simple idea of trying to put everything I need in one +simple and consistent package. The amazing haskell ecosystem is extremely +fragmented and maintained by different people with different goals, free time, +and style. The overall scare of not trying to change anything relatively +central (base, bytestring, text, vector ..) for a promise of stability has pushed +many people to work on their own thing, leading to unnecessary work duplication +and further fragmentation. + + +Foundation uses and abuses type families. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/benchs/Array.hs b/benchs/Array.hs new file mode 100644 --- /dev/null +++ b/benchs/Array.hs @@ -0,0 +1,16 @@ +module Main where + +import Foundation +import Foundation.Collection +import Criterion.Main + +main = defaultMain + [ bgroup "Uarray" + [ bench "fromList [Word8]" $ whnf (fromList :: [Word8] -> UArray Word8) [1..255] + , bench "fromList [Word16]" $ whnf (fromList :: [Word16] -> UArray Word16) [1..1024] + , bench "break" $ whnf (break (== 255)) input + ] + ] + where + input :: UArray Word8 + input = fromList ([1..255] <> [1..255]) diff --git a/benchs/ProfBreak.hs b/benchs/ProfBreak.hs new file mode 100644 --- /dev/null +++ b/benchs/ProfBreak.hs @@ -0,0 +1,9 @@ +module Main where + +import Foundation +import Foundation.Collection + +main = do + let v = fromList [1..255] :: UArray Word8 + let (v1,v2) = break ((==) 128) v + putStrLn $ (fromList $ show v1) <> (fromList $ show v2) diff --git a/foundation.cabal b/foundation.cabal new file mode 100644 --- /dev/null +++ b/foundation.cabal @@ -0,0 +1,156 @@ +Name: foundation +Version: 0.0.1 +Synopsis: Alternative prelude with batteries and no dependencies +Description: + A custom prelude with no dependencies apart from base. + . + This package has the following goals: + . + * provide a base like sets of modules that provide a consistent set of features and bugfixes across multiple versions of GHC (unlike base). + . + * provide a better and more efficient prelude than base's prelude. + . + * be self-sufficient: no external dependencies apart from base. + . + * provide better data-types: packed unicode string by default, arrays. + . + * Better numerical classes that better represent mathematical thing (No more all-in-one Num). + . + * Better I/O system with less Lazy IO + . + * Usual partial functions distinguished through type system +License: BSD3 +License-file: LICENSE +Copyright: Vincent Hanquez +Author: Vincent Hanquez +Maintainer: vincent@snarc.org +Category: foundation +Stability: experimental +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 == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 +extra-source-files: README.md + +source-repository head + type: git + location: https://github.com/haskell-foundation/foundation + +Library + Exposed-modules: Foundation + Foundation.Number + Foundation.Array + Foundation.Array.Internal + Foundation.Convertible + Foundation.String + Foundation.IO + Foundation.IO.FileMap + Foundation.VFS + Foundation.VFS.Path + Foundation.VFS.FilePath + Foundation.VFS.URI + Foundation.Foreign + Foundation.Collection + Foundation.Primitive + Foundation.System.Info + Foundation.Strict + Other-modules: Foundation.String.Internal + Foundation.String.UTF8 + Foundation.String.Encoding.Encoding + Foundation.String.Encoding.UTF16 + Foundation.String.Encoding.UTF32 + Foundation.String.Encoding.ASCII7 + Foundation.String.Encoding.ISO_8859_1 + Foundation.String.UTF8Table + Foundation.String.ModifiedUTF8 + Foundation.Tuple + Foundation.Collection.List + Foundation.Collection.Element + Foundation.Collection.InnerFunctor + Foundation.Collection.Sequential + Foundation.Collection.Keyed + Foundation.Collection.Indexed + Foundation.Collection.Foldable + Foundation.Collection.Mutable + Foundation.Collection.Zippable + Foundation.Internal.Base + Foundation.Internal.Primitive + Foundation.Internal.IsList + Foundation.Internal.Identity + Foundation.Internal.Proxy + Foundation.Internal.Types + Foundation.Internal.PrimTypes + Foundation.Internal.MonadTrans + Foundation.IO.File + Foundation.IO.Terminal + Foundation.Primitive.Types + Foundation.Primitive.Monad + Foundation.Primitive.Utils + Foundation.Primitive.FinalPtr + Foundation.Array.Common + Foundation.Array.Unboxed + Foundation.Array.Unboxed.Builder + Foundation.Array.Unboxed.Mutable + Foundation.Array.Unboxed.ByteArray + Foundation.Array.Boxed + Foundation.Array.Bitmap + Foundation.Foreign.MemoryMap + Foundation.Foreign.MemoryMap.Types + Foundation.Partial + if os(windows) + Other-modules: Foundation.Foreign.MemoryMap.Windows + else + Other-modules: Foundation.Foreign.MemoryMap.Posix + Default-Extensions: NoImplicitPrelude + TypeFamilies + BangPatterns + DeriveDataTypeable + Build-depends: base >= 4 && < 5 + , ghc-prim + -- FIXME add suport for armel mipsel + -- CPP-options: -DARCH_IS_LITTLE_ENDIAN + -- FIXME add support for powerpc powerpc64 armeb mipseb + -- CPP-options: -DARCH_IS_BIG_ENDIAN + if (arch(i386) || arch(x86_64)) + CPP-options: -DARCH_IS_LITTLE_ENDIAN + else + CPP-options: -DARCH_IS_UNKNOWN_ENDIAN + if os(windows) + Build-depends: Win32 + ghc-options: -Wall -fwarn-tabs + default-language: Haskell2010 + +Test-Suite test-foundation + type: exitcode-stdio-1.0 + hs-source-dirs: tests + Main-is: Tests.hs + Other-modules: ForeignUtils + Encoding + 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 + +Benchmark bench-array + Main-Is: Array.hs + hs-source-dirs: benchs + default-language: Haskell2010 + type: exitcode-stdio-1.0 + Default-Extensions: NoImplicitPrelude + BangPatterns + Build-depends: base >= 4, criterion, foundation + +Benchmark bench-profile-break + Main-Is: ProfBreak.hs + hs-source-dirs: benchs + default-language: Haskell2010 + type: exitcode-stdio-1.0 + Default-Extensions: NoImplicitPrelude + BangPatterns + Build-depends: foundation diff --git a/tests/Encoding.hs b/tests/Encoding.hs new file mode 100644 --- /dev/null +++ b/tests/Encoding.hs @@ -0,0 +1,956 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Encoding + ( EncodedString(..) + , sample0 + , sample1 + , sample2 + + , testEncodings + ) where + +import Foundation +import Foundation.String (Encoding(..), fromBytes, toBytes) +import Foundation.Array.Internal (recast) + +import Test.Tasty +import Test.Tasty.HUnit + +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/ForeignUtils.hs b/tests/ForeignUtils.hs new file mode 100644 --- /dev/null +++ b/tests/ForeignUtils.hs @@ -0,0 +1,26 @@ +module ForeignUtils + ( Ptr + , Storable + , createPtr + , free + ) where + +import Foreign.Marshal.Alloc + +import Foreign.Ptr +import Foreign.Storable +import Foundation +import Prelude (length, head, zip, null) +import Control.Monad (forM_) + +import Foundation.Foreign + +createPtr :: Storable e => [e] -> IO (FinalPtr e) +createPtr l + | null l = toFinalPtr nullPtr (\_ -> return ()) + | otherwise = do + let szElem = sizeOf (head l) + nbBytes = szElem * length l + ptr <- mallocBytes nbBytes + forM_ (zip [0..] l) $ \(o, e) -> pokeElemOff ptr o e + toFinalPtr ptr (\p -> free p) diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,571 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Main where + +import Test.Tasty +--import Test.Tasty.Options +import Control.Monad +import Test.QuickCheck.Monadic +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +import Foundation +import Foundation.Array +import Foundation.Collection +import Foundation.Foreign +import Foundation.String +import Foundation.VFS (Path (..), filename, parent) +import Foundation.VFS.FilePath +import qualified Data.List as L +import qualified Prelude + +import ForeignUtils +import Encoding + +data Unicode = Unicode { unUnicode :: LString } + deriving (Show) + +data Split = Split Unicode Char + deriving (Show) + +data CharMap = CharMap Unicode Prelude.Int + deriving (Show) + +addChar :: Prelude.Int -> Char -> Char +addChar n c = toEnum ((fromEnum c + n) `Prelude.mod` 0x10ffff) + +--instance Show Unicode where +-- show = unUnicode +-- +data ListElement a = ListElement [a] + +--instance Element a => Arbitrary ListElement where + +-- | A better version of arbitrary for Char +arbitraryChar :: Gen Char +arbitraryChar = + toEnum <$> oneof [choose (1, 0xff), choose (0x100, 0x1000), choose (0x100, 0x10000), choose (0x1, 0x1000)] + +instance Arbitrary Unicode where + arbitrary = do + n <- choose (0,49) + oneof + [ Unicode <$> replicateM n (toEnum <$> choose (1, 0xff)) + , Unicode <$> replicateM n (toEnum <$> choose (0x100, 0x1000)) + , Unicode <$> replicateM n (toEnum <$> choose (0x100, 0x10000)) + , Unicode <$> replicateM n (toEnum <$> choose (0x1, 0x1000)) + ] + +instance Arbitrary Split where + arbitrary = do + ch <- oneof [ toEnum <$> choose (0,0x7f), toEnum <$> choose (0x100, 0x10000) ] + l <- choose (0,4) >>= \n -> fmap unUnicode <$> replicateM n arbitrary + return (Split (Unicode $ L.intercalate [ch] l) ch) + +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) -> Unicode -> Bool +--stringEq back f g s = + +assertEq :: (Eq a, Show a) => a -> a -> Bool +assertEq got expected + | got == expected = True + | otherwise = error ("got: " <> show got <> " expected: " <> show expected) + +listOfElement :: Gen e -> Gen [e] +listOfElement e = choose (0,49) >>= flip replicateM e + +listOfElementMaxN :: Int -> Gen e -> Gen [e] +listOfElementMaxN n e = choose (0,n) >>= flip replicateM e + +-- | 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)) + +testEq :: (Show e, Eq e, Eq a, Element a ~ e, IsList a, Item a ~ Element a) => Proxy a -> Gen e -> [TestTree] +testEq proxy genElement = + [ 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 (listOfElement genElement) f + with2Elements f = forAll ((,) <$> listOfElement genElement <*> listOfElement genElement) f + +testOrd :: (Show e, Ord a, Ord e, Element a ~ e, IsList a, Item a ~ Element a) => Proxy a -> Gen e -> [TestTree] +testOrd proxy genElement = + [ testProperty "x `compare` y" $ with2Elements $ \(l1, l2) -> + (fromListP proxy l1 `compare` fromListP proxy l2) == (l1 `compare` l2) + ] + where + with2Elements f = forAll ((,) <$> listOfElement genElement <*> listOfElement genElement) f + +testMonoid :: (Show a, Show e, Ord a, Ord e, Monoid a, Element a ~ e, IsList a, Item a ~ Element a) => Proxy a -> Gen e -> [TestTree] +testMonoid proxy genElement = + testEq proxy genElement <> + testOrd proxy genElement <> + --[ testProperty "mempty <> mempty == mempty" $ \l -> + [ 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 (listOfElement genElement) f + with2Elements f = forAll ((,) <$> listOfElement genElement <*> listOfElement genElement) f + withNElements f = forAll (listOfElementMaxN 5 (listOfElement genElement)) f + +testCollectionProps :: (Show a, Sequential a, Eq a, e ~ Item a) => Proxy a -> Gen e -> [TestTree] +testCollectionProps proxy genElement = + [ 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 <$> listOfElement genElement) <*> arbitrary) f + +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 :: ([Char], 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 + +testCollection :: (Sequential a, Show a, Show (Element a), Eq (Element a), Ord a, Ord (Item a)) + => Proxy a -> Gen (Element a) -> [TestTree] +testCollection proxy genElement = + testMonoid proxy genElement <> + [ testProperty "c == [Element(c)]" $ withElements $ \l -> (toList $ fromListP proxy l) === l + , testProperty "length" $ withElements $ \l -> (length $ fromListP proxy l) === length l + , 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 "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 "splitOn" $ withElements2E $ \(l, ch) -> + fmap toList (splitOn (== ch) (fromListP proxy l)) === splitOn (== ch) l + , 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 + ] + <> testCollectionProps proxy genElement +{- + , testProperty "imap" $ \(CharMap (Unicode 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 (listOfElement genElement) f + withElements2 f = forAll ((,) <$> listOfElement genElement <*> arbitrary) f + withElements3 f = forAll ((,,) <$> listOfElement genElement <*> arbitrary <*> arbitrary) f + withElements2E f = forAll ((,) <$> listOfElement genElement <*> genElement) f + +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 ((,) <$> listOfElement genElementA <*> listOfElement genElementB) + withListOfTuples = forAll (listOfElement ((,) <$> 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 (const (const c)) (fromListP proxyA as) (fromListP proxyB bs) + ) == Prelude.replicate (Prelude.min (length as) (length bs)) c + ] + where + withList2AndE = forAll ( (,,) <$> listOfElement genElementA <*> listOfElement 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 (listOfElement genElementA) + withList2 = forAll ((,) <$> listOfElement genElementA <*> listOfElement genElementB) + +testUnboxedForeign :: (PrimType e, Show e, Element a ~ e, Storable 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 <- pick arbitrary + return $ take n (toArrayP proxy l) == take n (foreignMem fptr (length l)) + , testProperty "take" $ withElementsM $ \fptr l -> do + n <- pick arbitrary + return $ drop n (toArrayP proxy l) == drop n (foreignMem fptr (length l)) + ] + where + withElementsM f = monadicIO $ forAllM (listOfElement genElement) $ \l -> run (createPtr l) >>= \fptr -> f fptr l + toArrayP :: PrimType (Element c) => Proxy c -> [Element c] -> UArray (Element c) + toArrayP _ l = fromList l + +fromListP :: (IsList c, Item c ~ Element c) => Proxy c -> [Element c] -> c +fromListP p = \x -> asProxyTypeOf (fromList x) p + +toListP :: (IsList c, Item c ~ Element c) => Proxy c -> c -> [Element c] +toListP p x = toList (asProxyTypeOf x p) + +data RandomList = RandomList [Int] + deriving (Show,Eq) + +instance Arbitrary RandomList where + arbitrary = RandomList <$> (choose (100,400) >>= flip replicateM (choose (0,8))) + +chunks :: Sequential c => RandomList -> c -> [c] +chunks (RandomList randomInts) = loop (randomInts <> [1..]) + where + loop rx c + | null c = [] + | otherwise = + case rx of + r:rs -> + let (c1,c2) = splitAt r c + in c1 : loop rs c2 + [] -> + loop randomInts c + + +testStringCases :: [TestTree] +testStringCases = + [ testGroup "Validation" + [ testProperty "fromBytes . toBytes == valid" $ \(Unicode l) -> + let s = fromList l + in (fromBytes UTF8 $ toBytes UTF8 s) === (s, Nothing, mempty) + , testProperty "Streaming" $ \(Unicode l, randomInts) -> + let wholeS = fromList l + wholeBA = toBytes UTF8 wholeS + reconstruct (prevBa, errs, acc) ba = + let ba' = prevBa `mappend` ba + (s, merr, nextBa) = fromBytes UTF8 ba' + in (nextBa, merr : errs, s : acc) + + (remainingBa, allErrs, chunkS) = foldl reconstruct (mempty, [], []) $ chunks randomInts wholeBA + in (catMaybes allErrs === []) .&&. (remainingBa === mempty) .&&. (mconcat (reverse chunkS) === wholeS) + ] + , testGroup "Cases" + [ testGroup "Invalid-UTF8" + [ testCase "ff" $ expectFromBytesErr ("", Just InvalidHeader, 0) (fromList [0xff]) + , testCase "80" $ expectFromBytesErr ("", Just InvalidHeader, 0) (fromList [0x80]) + , testCase "E2 82 0C" $ expectFromBytesErr ("", Just InvalidContinuation, 0) (fromList [0xE2,0x82,0x0c]) + , testCase "30 31 E2 82 0C" $ expectFromBytesErr ("01", Just InvalidContinuation, 2) (fromList [0x30,0x31,0xE2,0x82,0x0c]) + ] + ] + ] + where + expectFromBytesErr (expectedString,expectedErr,positionErr) ba = do + let (s', merr, ba') = fromBytes UTF8 ba + assertEqual "error" expectedErr merr + assertEqual "remaining" (drop positionErr ba) ba' + assertEqual "string" expectedString (toList s') + +tests :: [TestTree] +tests = + [ testGroup "Array" + [ testGroup "Unboxed" + [ testGroup "UArray(W8)" (testCollection (Proxy :: Proxy (UArray Word8)) arbitrary) + , testGroup "UArray(W16)" (testCollection (Proxy :: Proxy (UArray Word16)) arbitrary) + , testGroup "UArray(W32)" (testCollection (Proxy :: Proxy (UArray Word32)) arbitrary) + , testGroup "UArray(W64)" (testCollection (Proxy :: Proxy (UArray Word64)) arbitrary) + , testGroup "UArray(I8)" (testCollection (Proxy :: Proxy (UArray Int8)) arbitrary) + , testGroup "UArray(I16)" (testCollection (Proxy :: Proxy (UArray Int16)) arbitrary) + , testGroup "UArray(I32)" (testCollection (Proxy :: Proxy (UArray Int32)) arbitrary) + , testGroup "UArray(I64)" (testCollection (Proxy :: Proxy (UArray Int64)) arbitrary) + , testGroup "UArray(F32)" (testCollection (Proxy :: Proxy (UArray Float)) arbitrary) + , testGroup "UArray(F64)" (testCollection (Proxy :: Proxy (UArray Double)) arbitrary) + ] + , 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 "Boxed" + [ testGroup "Array(W8)" (testCollection (Proxy :: Proxy (Array Word8)) arbitrary) + , testGroup "Array(W16)" (testCollection (Proxy :: Proxy (Array Word16)) arbitrary) + , testGroup "Array(W32)" (testCollection (Proxy :: Proxy (Array Word32)) arbitrary) + , testGroup "Array(W64)" (testCollection (Proxy :: Proxy (Array Word64)) arbitrary) + , testGroup "Array(I8)" (testCollection (Proxy :: Proxy (Array Int8)) arbitrary) + , testGroup "Array(I16)" (testCollection (Proxy :: Proxy (Array Int16)) arbitrary) + , testGroup "Array(I32)" (testCollection (Proxy :: Proxy (Array Int32)) arbitrary) + , testGroup "Array(I64)" (testCollection (Proxy :: Proxy (Array Int64)) arbitrary) + , testGroup "Array(F32)" (testCollection (Proxy :: Proxy (Array Float)) arbitrary) + , testGroup "Array(F64)" (testCollection (Proxy :: Proxy (Array Double)) arbitrary) + , testGroup "Array(Int)" (testCollection (Proxy :: Proxy (Array Int)) arbitrary) + , testGroup "Array(Int,Int)" (testCollection (Proxy :: Proxy (Array (Int,Int))) arbitrary) + , testGroup "Array(Integer)" (testCollection (Proxy :: Proxy (Array Integer)) arbitrary) + ] + , testGroup "Bitmap" (testCollection (Proxy :: Proxy (Bitmap)) arbitrary) + ] + , testGroup "String" + ( testCollection (Proxy :: Proxy String) arbitraryChar + <> testStringCases + <> [ testGroup "Encoding Sample0" (testEncodings sample0) + , testGroup "Encoding Sample1" (testEncodings sample1) + , testGroup "Encoding Sample2" (testEncodings sample2) + ] + ) + , testGroup "VFS" + [ testGroup "FilePath" $ testCaseFilePath <> (testPath (arbitrary :: Gen FilePath)) + ] + , testGroup "Number" + [ testGroup "Precedence" + [ testProperty "+ and - (1)" $ \a (b :: Int) (c :: Int) -> (a + b - c) === ((a + b) - c) + , testProperty "+ and - (2)" $ \a (b :: Int) (c :: Int) -> (a - b + c) === ((a - b) + c) + , testProperty "+ and * (1)" $ \a b (c :: Int) -> (a + b * c) === (a + (b * c)) + , testProperty "+ and * (2)" $ \a b (c :: Int) -> (a * b + c) === ((a * b) + c) + , testProperty "- and * (1)" $ \a b (c :: Int) -> (a - b * c) === (a - (b * c)) + , testProperty "- and * (2)" $ \a b (c :: Int) -> (a * b - c) === ((a * b) - c) + , testProperty "* and ^ (1)" $ \a (Positive b :: Positive Int) (c :: Int) -> (a ^ b * c) === ((a ^ b) * c) + , testProperty "* and ^ (2)" $ \a (b :: Int) (Positive c :: Positive Int) -> (a * b ^ c) === (a * (b ^ c)) + ] + ] + , 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 "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 ) + ] + ] + +testCaseModifiedUTF8 :: [Char] -> String -> Assertion +testCaseModifiedUTF8 ghcStr str + | ghcStr == fStr = return () + | otherwise = assertFailure $ + "expecting: " <> show ghcStr <> " received: " <> show fStr + where + fStr :: [Char] + fStr = toList str + +main :: IO () +main = defaultMain $ testGroup "foundation" tests