compact-string-fix (empty) → 0.3.1
raw patch · 15 files changed
+4173/−0 lines, 15 filesdep +basedep +bytestringsetup-changed
Dependencies added: base, bytestring
Files
- Data/CompactString.hs +1153/−0
- Data/CompactString/ASCII.hs +9/−0
- Data/CompactString/Encodings.hs +609/−0
- Data/CompactString/Fusion.hs +113/−0
- Data/CompactString/Internal.hs +330/−0
- Data/CompactString/UTF16.hs +7/−0
- Data/CompactString/UTF8.hs +7/−0
- Data/CompactString/Unsafe.hs +71/−0
- Data/CompactString/signatures.include +746/−0
- Data/CompactString/specialized.include +371/−0
- LICENSE +27/−0
- Setup.lhs +3/−0
- compact-string-fix.cabal +43/−0
- test/Properties.hs +414/−0
- test/QuickCheckUtils.hs +270/−0
+ Data/CompactString.hs view
@@ -0,0 +1,1153 @@+{-# OPTIONS_GHC -cpp -fno-warn-orphans #-}+-- |+-- Module : Data.CompactString+-- License : BSD-style+-- Maintainer : twanvl@gmail.com+-- Stability : experimental+-- Portability : untested+-- +-- A time and space-efficient implementation of strings using+-- packed Word8 arrays, suitable for high performance use, both in terms+-- of large data quantities, or high speed requirements.+--+-- This module is intended to be imported @qualified@, to avoid name+-- clashes with "Prelude" functions. eg.+--+-- > import qualified Data.CompactString as C+--+-- Internally, CompactStrings are encoded 'ByteString's.+--+module Data.CompactString (+ + -- * The @CompactString@ type+ Encoding,+ CompactString, -- abstract, instances: Eq, Ord, Show, Monoid+ + -- * Introducing and eliminating 'CompactString's+ empty, -- :: CompactString+ singleton, -- :: Char -> CompactString+ pack, -- :: String -> CompactString+ unpack, -- :: CompactString -> String+ + -- * Basic interface+ cons, -- :: Char -> CompactString -> CompactString+ snoc, -- :: CompactString -> Char -> CompactString+ append, -- :: CompactString -> CompactString -> CompactString+ head, -- :: CompactString -> Char+ last, -- :: CompactString -> Char+ tail, -- :: CompactString -> CompactString+ init, -- :: CompactString -> CompactString+ headView, -- :: CompactString -> Maybe (Char, CompactString)+ lastView, -- :: CompactString -> Maybe (CompactString, Char)+ null, -- :: CompactString -> Bool+ length, -- :: CompactString -> Int+ + -- * Transforming 'CompactString's+ map, -- :: (Char -> Char) -> CompactString -> CompactString+ reverse, -- :: CompactString -> CompactString+ intersperse, -- :: Char -> CompactString -> CompactString+ intercalate, -- :: CompactString -> [CompactString] -> CompactString+ transpose, -- :: [CompactString] -> [CompactString]+ + -- * Reducing 'CompactString's (folds)+ foldl, -- :: (a -> Char -> a) -> a -> CompactString -> a+ foldl', -- :: (a -> Char -> a) -> a -> CompactString -> a+ foldl1, -- :: (Char -> Char -> Char) -> CompactString -> Char+ foldl1', -- :: (Char -> Char -> Char) -> CompactString -> Char+ + foldr, -- :: (Char -> a -> a) -> a -> CompactString -> a+ foldr', -- :: (Char -> a -> a) -> a -> CompactString -> a+ foldr1, -- :: (Char -> Char -> Char) -> CompactString -> Char+ foldr1', -- :: (Char -> Char -> Char) -> CompactString -> Char+ + -- ** Special folds+ concat, -- :: [CompactString] -> CompactString+ concatMap, -- :: (Char -> CompactString) -> CompactString -> CompactString+ any, -- :: (Char -> Bool) -> CompactString -> Bool+ all, -- :: (Char -> Bool) -> CompactString -> Bool+ maximum, -- :: CompactString -> Char+ minimum, -- :: CompactString -> Char+ + -- * Building CompactStrings+ -- ** Scans+ scanl, -- :: (Char -> Char -> Char) -> Char -> CompactString -> CompactString+ scanl1, -- :: (Char -> Char -> Char) -> CompactString -> CompactString+ scanr, -- :: (Char -> Char -> Char) -> Char -> CompactString -> CompactString+ scanr1, -- :: (Char -> Char -> Char) -> CompactString -> CompactString+ + -- ** Accumulating maps+ mapAccumL, -- :: (acc -> Char -> (acc, Char)) -> acc -> CompactString -> (acc, CompactString)+ mapAccumR, -- :: (acc -> Char -> (acc, Char)) -> acc -> CompactString -> (acc, CompactString)+ mapIndexed, -- :: (Int -> Char -> Char) -> CompactString -> CompactString+ + -- ** Unfolding CompactStrings+ replicate, -- :: Int -> Char -> CompactString+ unfoldr, -- :: (a -> Maybe (Char, a)) -> a -> CompactString+ unfoldrN, -- :: Int -> (a -> Maybe (Char, a)) -> a -> (CompactString, Maybe a)+ + -- * Substrings+ + -- ** Breaking strings+ take, -- :: Int -> CompactString -> CompactString+ drop, -- :: Int -> CompactString -> CompactString+ splitAt, -- :: Int -> CompactString -> (CompactString, CompactString)+ takeWhile, -- :: (Char -> Bool) -> CompactString -> CompactString+ dropWhile, -- :: (Char -> Bool) -> CompactString -> CompactString+ span, -- :: (Char -> Bool) -> CompactString -> (CompactString, CompactString)+ spanEnd, -- :: (Char -> Bool) -> CompactString -> (CompactString, CompactString)+ break, -- :: (Char -> Bool) -> CompactString -> (CompactString, CompactString)+ breakEnd, -- :: (Char -> Bool) -> CompactString -> (CompactString, CompactString)+ group, -- :: CompactString -> [CompactString]+ groupBy, -- :: (Char -> Char -> Bool) -> CompactString -> [CompactString]+ inits, -- :: CompactString -> [CompactString]+ tails, -- :: CompactString -> [CompactString]+ + -- ** Breaking into many substrings+ split, -- :: Char -> CompactString -> [CompactString]+ splitWith, -- :: (Char -> Bool) -> CompactString -> [CompactString]+ + -- ** Breaking into lines and words+ lines, -- :: CompactString -> [CompactString]+ words, -- :: CompactString -> [CompactString]+ unlines, -- :: [CompactString] -> CompactString+ unwords, -- :: CompactString -> [CompactString]+ + -- * Predicates+ isPrefixOf, -- :: CompactString -> CompactString -> Bool+ isSuffixOf, -- :: CompactString -> CompactString -> Bool+ isInfixOf, -- :: CompactString -> CompactString -> Bool+ + -- ** Search for arbitrary substrings+ findSubstring, -- :: CompactString -> CompactString -> Maybe Int+ findSubstrings, -- :: CompactString -> CompactString -> [Int]+ + -- * Searching CompactStrings+ + -- ** Searching by equality+ elem, -- :: Char -> CompactString -> Bool+ notElem, -- :: Char -> CompactString -> Bool+ + -- ** Searching with a predicate+ find, -- :: (Char -> Bool) -> CompactString -> Maybe Char+ filter, -- :: (Char -> Bool) -> CompactString -> CompactString+ partition, -- :: (Char -> Bool) -> CompactString -> (CompactString, CompactString)+ + -- * Indexing CompactStrings+ index, -- :: CompactString -> Int -> Char+ elemIndex, -- :: Char -> CompactString -> Maybe Int+ elemIndices, -- :: Char -> CompactString -> [Int]+ elemIndexEnd, -- :: Char -> CompactString -> Maybe Int+ findIndex, -- :: (Char -> Bool) -> CompactString -> Maybe Int+ findIndexEnd, -- :: (Char -> Bool) -> CompactString -> Maybe Int+ findIndices, -- :: (Char -> Bool) -> CompactString -> [Int]+ count, -- :: Char -> CompactString -> Int+ + -- * Zipping and unzipping CompactStrings+ zip, -- :: CompactString -> CompactString -> [(Char,Char)]+ zipWith, -- :: (Char -> Char -> c) -> CompactString -> CompactString -> [c]+ zipWith', -- :: (Char -> Char -> Char) -> CompactString -> CompactString -> CompactString+ unzip, -- :: [(Char,Char)] -> (CompactString,CompactString)+ + -- * Ordered CompactStrings+ sort, -- :: CompactString -> CompactString+ compare', -- :: CompactString a -> CompactString b -> Ordering+ + -- * Encoding+ toByteString, -- :: Encoding a => CompactString a -> ByteString+ fromByteString, -- :: Encoding a => ByteString -> m (CompactString a)+ fromByteString_, -- :: Encoding a => ByteString -> CompactString a+ validate, -- :: Encoding a => CompactString a -> m (CompactString a)+ validate_, -- :: Encoding a => CompactString a -> CompactString a+ -- ** Encoding conversion+ module Data.CompactString.Encodings,+ recode, -- :: (Encoding a, Encoding b) => CompactString a -> m (CompactString b)+ recode_, -- :: (Encoding a, Encoding b) => CompactString a -> CompactString b+ encode, -- :: (Encoding a, Encoding b) => a -> CompactString b -> m (ByteString)+ encode_, -- :: (Encoding a, Encoding b) => a -> CompactString b -> ByteString+ decode, -- :: (Encoding a, Encoding b) => a -> ByteString -> m (CompactString b)+ decode_, -- :: (Encoding a, Encoding b) => a -> ByteString -> CompactString b+ encodeBOM, -- :: Encoding a => CompactString a -> m (ByteString)+ encodeBOM_, -- :: Encoding a => CompactString a -> ByteString+ decodeBOM, -- :: Encoding a => ByteString -> m (CompactString a)+ decodeBOM_, -- :: Encoding a => ByteString -> CompactString a+ + -- * I\/O with 'CompactString's+ + -- ** Standard input and output+ getLine, -- :: IO CompactString+ getContents, -- :: IO CompactString+ putStr, -- :: CompactString -> IO ()+ putStrLn, -- :: CompactString -> IO ()+ interact, -- :: (CompactString -> CompactString) -> IO ()+ + -- ** Files+ readFile, -- :: FilePath -> IO CompactString+ readFile', -- :: FilePath -> IO CompactString+ writeFile, -- :: FilePath -> CompactString -> IO ()+ writeFile', -- :: FilePath -> CompactString -> IO ()+ appendFile, -- :: FilePath -> CompactString -> IO ()+ appendFile', -- :: FilePath -> CompactString -> IO ()+ + -- ** I\/O with Handles+ hGetLine, -- :: Handle -> IO CompactString+ hGetContents, -- :: Handle -> IO CompactString+ hGetContents', -- :: Handle -> IO CompactString+ hGet, -- :: Handle -> Int -> IO CompactString+ hGetNonBlocking, -- :: Handle -> Int -> IO CompactString+ hPut, -- :: Handle -> CompactString -> IO ()+ hPutStr, -- :: Handle -> CompactString -> IO ()+ hPutStrLn, -- :: Handle -> CompactString -> IO ()+ + ) where++import Prelude hiding+ (length, head, tail, last, init, null, + map, reverse, foldl, foldr, foldl1, foldr1, concat, concatMap,+ scanl, scanl1, scanr, scanr1, replicate,+ take, drop, splitAt, takeWhile, dropWhile,+ span, break, any, all, elem, notElem,+ maximum, minimum, filter, zip, zipWith, unzip,+ lines, unlines, words, unwords,+ putStr, putStrLn, getContents, getLine, interact,+ readFile, writeFile, appendFile)++import Data.Monoid+import qualified Data.List as L+import Data.Maybe (isJust, isNothing, listToMaybe)+import Data.String++import Foreign.Ptr (minusPtr)+import Foreign.ForeignPtr (withForeignPtr)++import System.IO (Handle,openFile,hClose,IOMode(..),+ hSeek,hTell,SeekMode(..),stdin,stdout)+import qualified System.IO (hGetLine)+import System.IO.Unsafe (unsafePerformIO)++import Control.Monad (liftM,MonadPlus)+import Control.Exception (bracket)++import Data.Char (isSpace)++import qualified Data.ByteString.Internal as B+import qualified Data.ByteString.Unsafe as B+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as C8++import Data.CompactString.Internal+import Data.CompactString.Fusion+import Data.CompactString.Unsafe+import Data.CompactString.Encodings++-- -----------------------------------------------------------------------------+--+-- Type signatures & documentation+--++#define COMPACTSTRING CompactString a+#define DESCRIPTION the encoding @a@+#define CONTEXT Encoding a =>+#define CONTEXT_ Encoding a, +#define IF_FIXED(a,b) b+#define IF_NOT_REPRESENT(a) a+#include "signatures.include"++-- -----------------------------------------------------------------------------+--+-- Useful macros, until we have bang patterns+--++#define STRICT1(f) f _a | _a `seq` False = undefined+#define STRICT2(f) f _a _b | _a `seq` _b `seq` False = undefined+#define STRICT3(f) f _a _b _c | _a `seq` _b `seq` _c `seq` False = undefined+#define STRICT4(f) f _a _b _c _d | _a `seq` _b `seq` _c `seq` _d `seq` False = undefined+#define STRICT5(f) f _a _b _c _d _e | _a `seq` _b `seq` _c `seq` _d `seq` _e `seq` False = undefined++-- -----------------------------------------------------------------------------+--+-- Comparison+--++instance Encoding a => Eq (CompactString a) where+ (CS a) == (CS b) = a == b++instance Encoding a => Monoid (CompactString a) where+ mempty = empty+ mappend = append+ mconcat = concat++instance Encoding a => Ord (CompactString a) where+ compare = doCompare++doCompare :: Encoding a => CompactString a -> CompactString a -> Ordering+doCompare a b+ | validOrdering (encoding a) = compare (unCS a) (unCS b)+ -- We can't compare the ByteStrings, because the encoding results in a different ordering+ | otherwise = compare' a b++-- -----------------------------------------------------------------------------+--+-- Construction/destruction+--++empty = CS $ B.empty+{-# INLINE empty #-}++singleton c = cs+ where+ cs = CS $ B.unsafeCreate l p+ (l,p) = pokeCharFun (encoding cs) c+{-# SPECIALIZE singleton :: Char -> CompactString UTF8 #-}++pack str = cs+ where+ cs = CS $ B.unsafeCreate (L.sum . L.map (pokeCharLen (encoding cs)) $ str) $ \p -> go p str+ go _ [] = return ()+ go p (x:xs) = do l <- pokeChar (encoding cs) p x+ go (p `plusPtr` l) xs+{-# SPECIALIZE pack :: String -> CompactString UTF8 #-}++unpack cs@(CS (PS ps ss ls)) = inlinePerformIO $ withForeignPtr ps $ \p -> return (loop p ss ls)+ where+ STRICT3(loop)+ loop _ _ 0 = []+ loop _ _ l | l < 0 = error $ "string length incorrect in " ++ show (PS ps ss ls) -- This really shouldn't happen!+ loop p s l = case inlinePerformIO $ peekChar (encoding cs) (p `plusPtr` s) of+ (l',c) -> c : loop p (s + l') (l - l')+{-# SPECIALIZE unpack :: CompactString UTF8 -> String #-}++{-# RULES++"CompactString pack/unpack" forall cs.+ pack (unpack cs) = cs+"CompactString unpack/pack" forall ls.+ unpack (pack ls) = ls++ #-}++instance Encoding a => Show (CompactString a) where+ showsPrec p = showsPrec p . unpack++instance Encoding a => IsString (CompactString a) where+ fromString = pack++-- -----------------------------------------------------------------------------+--+-- Basic interface+--++null = B.null . unCS+{-# INLINE null #-}++length cs@(CS (PS _ _ l)) = unsafeWithBuffer cs (length_ 0 l)+ where+ STRICT3(length_)+ length_ acc 0 _ = return acc+ length_ acc n p = do l' <- peekCharLen (encoding cs) p+ length_ (acc + 1) (n - l') (p `plusPtr` l')+{-# INLINE length #-}++cons c cs@(CS (PS _ _ l)) = unsafeWithBuffer cs $ \src -> create (l+l') $ \dst -> do+ pokeC dst+ memcpy (dst `plusPtr` l') src (fromIntegral l)+ where (l',pokeC) = pokeCharFun (encoding cs) c+{-# INLINE cons #-}++snoc cs@(CS (PS _ _ l)) c = unsafeWithBuffer cs $ \src -> create (l+l') $ \dst -> do+ memcpy dst src (fromIntegral l)+ pokeC (dst `plusPtr` l)+ where (l',pokeC) = pokeCharFun (encoding cs) c+{-# INLINE snoc #-}++append (CS xs) (CS ys) = CS (B.append xs ys)+{-# INLINE append #-}++-- -----------------------------------------------------------------------------+--+-- Head & tail and friends+--++head cs+ | null cs = errorEmptyList "head"+ | otherwise = unsafeHead cs+{-# INLINE head #-}++tail cs+ | null cs = errorEmptyList "tail"+ | otherwise = unsafeTail cs+{-# INLINE tail #-}++last cs+ | null cs = errorEmptyList "last"+ | otherwise = unsafeLast cs+{-# INLINE last #-}++init cs+ | null cs = errorEmptyList "init"+ | otherwise = unsafeInit cs+{-# INLINE init #-}++headView cs@(CS (PS x s l))+ | null cs = Nothing+ | otherwise = let (headlen,c) = unsafeWithBuffer cs $ peekChar (encoding cs)+ in Just (c, CS (PS x (s+headlen) (l-headlen)))+{-# INLINE headView #-}++lastView cs@(CS (PS x s l))+ | null cs = Nothing+ | otherwise = let (lastlen,c) = unsafeWithBuffer cs $ peekCharRev (encoding cs)+ in Just (CS (PS x s (l-lastlen)), c)+{-# INLINE lastView #-}+++-- -----------------------------------------------------------------------------+--+-- List functions+--++reverse cs@(CS (PS _ _ l)) = unsafeWithBufferEnd cs $ create l . reverse_ l+ where+ STRICT3(reverse_)+ reverse_ 0 _ _ = return ()+ reverse_ n src dst = do+ i <- copyCharRev (encoding cs) src dst+ reverse_ (n-i) (src `plusPtr` negate i) (dst `plusPtr` i)+{-# SPECIALIZE reverse :: CompactString UTF8 -> CompactString UTF8 #-}++intersperse c cs@(CS (PS _ _ l))+ | l == 0 = cs+ | otherwise = unsafeWithBuffer cs $ create (l+(len-1)*lc) . intersperse_copy l+ where+ (lc,pokeC) = pokeCharFun (encoding cs) c+ len = length cs+ STRICT3(intersperse_copy)+ intersperse_copy 0 _ _ = return ()+ intersperse_copy n src dst = do l' <- copyChar (encoding cs) src dst+ intersperse_inter (n-l') (src `plusPtr` l') (dst `plusPtr` l')+ STRICT3(intersperse_inter)+ intersperse_inter 0 _ _ = return ()+ intersperse_inter n src dst = do pokeC dst+ intersperse_copy n src (dst `plusPtr` lc)+{-# SPECIALIZE intersperse :: Char -> CompactString UTF8 -> CompactString UTF8 #-}++transpose ps = L.map pack (L.transpose (L.map unpack ps))++-- -----------------------------------------------------------------------------+--+-- Simple loops+--++--map f = loopArr . loopUp (mapEFL f) NoAcc+map f cs@(CS (PS _ _ l)) = result+ where+ result = CS $ inlinePerformIO $ withBuffer cs $ \p1 -> B.createAndTrim (newSize (encoding cs) l) $+ map_ p1+ map_ p1 p2 = go 0 0+ where+ STRICT2(go)+ go i j+ | i >= l = return j+ | otherwise = do+ (l1,c1) <- peekChar (encoding cs) (p1 `plusPtr` i)+ l2 <- pokeChar (encoding cs) (p2 `plusPtr` j) (f c1)+ go (i+l1) (j+l2)+{-# INLINE map #-}++--filter p = loopArr . loopUpC (filterEFL p) NoAcc+filter predicate cs@(CS (PS _ _ l))+ | null cs = cs+ | otherwise = result+ where+ result = CS $ unsafeWithBuffer cs $ \p1 -> B.createAndTrim l $ filter_ p1+ filter_ p1 p2 = go 0 0+ where+ STRICT2(go)+ go i j | i >= l = return j+ | otherwise = do+ (l1,c1) <- peekChar (encoding cs) (p1 `plusPtr` i)+ if predicate c1+ then do l2 <- pokeChar (encoding cs) (p2 `plusPtr` j) c1+ go (i+l1) (j+l2)+ else go (i+l1) j+{-# INLINE filter #-}++partition p cs = (filter p cs, filter (not . p) cs)++-- -----------------------------------------------------------------------------+--+-- Folds+--++foldl f z = loopUpFold f z+foldl' = foldl+foldr f z = loopDownFold (flip f) z -- TODO : Is this too strict?+foldr' f z = loopDownFold (flip f) z+++foldl1 f cs+ | null cs = errorEmptyList "foldl1"+ | otherwise = foldl f (unsafeHead cs) (unsafeTail cs)+{-# INLINE foldl1 #-}++foldl1' f cs+ | null cs = errorEmptyList "foldl1'"+ | otherwise = foldl' f (unsafeHead cs) (unsafeTail cs)+{-# INLINE foldl1' #-}++foldr1 f cs+ | null cs = errorEmptyList "foldr1"+ | otherwise = foldr f (unsafeLast cs) (unsafeInit cs)+{-# INLINE foldr1 #-}++foldr1' f cs+ | null cs = errorEmptyList "foldr1'"+ | otherwise = foldr' f (unsafeLast cs) (unsafeInit cs)+{-# INLINE [1] foldr1' #-}++-- ---------------------------------------------------------------------+-- Special folds++concat = CS . B.concat . L.map unCS++concatMap f = concat . foldr ((:) . f) []++intercalate s = concat . (L.intersperse s)+{-# INLINE [1] intercalate #-}++any p = isJust . find p+all p = isNothing . find (not . p)++maximum cs+ | null cs = errorEmptyList "maximum"+ | otherwise = foldl1' max cs+minimum cs+ | null cs = errorEmptyList "minimum"+ | otherwise = foldl1' min cs++-- ---------------------------------------------------------------------+-- Building CompactString : scans++scanl f z ps = loopArr . loopUp (scanEFL f) z $ (ps `snoc` '\0')+{-# INLINE scanl #-}++scanl1 f ps+ | null ps = empty+ | otherwise = scanl f (unsafeHead ps) (unsafeTail ps)+{-# INLINE scanl1 #-}++scanr f z ps = loopArr . loopDown (scanEFL (flip f)) z $ ('\0' `cons` ps) -- extra space+{-# INLINE scanr #-}++scanr1 f cs+ | null cs = empty+ | otherwise = scanr f (unsafeLast cs) (unsafeInit cs)+{-# INLINE scanr1 #-}++-- ---------------------------------------------------------------------+-- Building CompactString : Accumulating maps++mapAccumL f z = unSP . loopUp (mapAccumEFL f) z+{-# INLINE mapAccumL #-}+mapAccumR f z = unSP . loopDown (mapAccumEFL f) z+{-# INLINE mapAccumR #-}+mapIndexed f = loopArr . loopUp (mapIndexEFL f) 0+{-# INLINE mapIndexed #-}++-- ---------------------------------------------------------------------+-- Building CompactString : unfolding++replicate w c+ | w <= 0 = empty+ | otherwise = cs+ where+ cs = CS $ B.unsafeCreate (l*w) (go w)+ (l,pokeC) = pokeCharFun (encoding cs) c+ STRICT2(go)+ go 0 _ = return ()+ go n ptr = pokeC ptr >> go (n-1) (ptr `plusPtr` l)+{-# SPECIALIZE replicate :: Int -> Char -> CompactString UTF8 #-}++unfoldr f = concat . unfoldChunk 32 64+ where unfoldChunk n n' x =+ case unfoldrN n f x of+ (s, Nothing) -> s : []+ (s, Just x') -> s : unfoldChunk n' (n+n') x'+++unfoldrN i f x0+ | i <= 0 = (empty, Just x0)+ | otherwise = result+ where+ result = (\(b,s) -> (CS b,s)) $ unsafePerformIO $ B.createAndTrim' (byteCount (encoding (fst result)) i) go_+ go_ start_p = go start_p x0 0+ where+ STRICT3(go)+ go p x n+ | n == i = return (0, p `minusPtr` start_p, Just x)+ | otherwise = case f x of+ Nothing -> return (0, p `minusPtr` start_p, Nothing)+ Just (w,x') -> do l <- pokeChar (encoding (fst result)) p w+ go (p `plusPtr` l) x' (n+1)+++-- ---------------------------------------------------------------------+-- Substrings++take n cs@(CS (PS x s l))+ | n <= 0 = empty+ | idx == l = cs+ | otherwise = CS $ PS x s idx+ where idx = charIndex cs n+{-# INLINE take #-}++drop n cs@(CS (PS x s l))+ | n <= 0 = cs+ | idx == l = empty+ | otherwise = CS $ PS x (s+idx) (l-idx)+ where idx = charIndex cs n+{-# INLINE drop #-}++splitAt n cs@(CS (PS x s l))+ | n <= 0 = (empty, cs)+ | idx == l = (cs, empty)+ | otherwise = (CS $ PS x s idx, CS $ PS x (s+idx) (l-idx))+ where idx = charIndex cs n+{-# INLINE splitAt #-}++takeWhile f cs@(CS bs) = CS $ B.unsafeTake (findIndexOrEnd (not . f) cs) bs+dropWhile f cs@(CS bs) = CS $ B.unsafeDrop (findIndexOrEnd (not . f) cs) bs+{-# INLINE takeWhile #-}+{-# INLINE dropWhile #-}++break p cs@(CS bs) = (CS $ B.unsafeTake n bs, CS $ B.unsafeDrop n bs)+ where n = findIndexOrEnd p cs+span p ps = break (not . p) ps+{-# INLINE [1] break #-}+{-# INLINE [1] span #-}++breakEnd p cs@(CS bs) = (CS $ B.unsafeTake n bs, CS $ B.unsafeDrop n bs)+ where n = findIndexOrBeginRev p cs+spanEnd p cs = breakEnd (not . p) cs+{-# INLINE [1] breakEnd #-}+{-# INLINE [1] spanEnd #-}++-- ---------------------------------------------------------------------+-- To list++group = groupBy (==)++groupBy k cs@(CS bs) = case headView cs of+ Nothing -> []+ Just (x,xs) -> let n = pokeCharLen (encoding cs) x + findIndexOrEnd (not . k x) xs+ in CS (B.unsafeTake n bs) : groupBy k (CS (B.unsafeDrop n bs))+++inits cs@(CS (PS x s l)) = inits_ 0+ where+ STRICT1(inits_)+ inits_ n+ | n >= l = [cs]+ | otherwise = unsafeWithBuffer cs $ \ptr -> do+ len <- peekCharLen (encoding cs) (ptr `plusPtr` n)+ return (CS (PS x s n) : inits_ (n + len))++tails p | null p = [empty]+ | otherwise = p : tails (unsafeTail p)+++split x = splitWith (x==)++splitWith _ (CS (PS _ _ 0)) = []+splitWith p cs = loop p cs+ where+ STRICT2(loop)+ loop q qs = if null rest then [chunk]+ else chunk : loop q (unsafeTail rest)+ where (chunk,rest) = break q qs+++lines = dropEmptyLast . split '\n'+ where dropEmptyLast [] = []+ dropEmptyLast [x] | null x = []+ dropEmptyLast (x:xs) = x : dropEmptyLast xs+{-# INLINE lines #-}++unlines [] = empty+unlines ss = (concat $ L.intersperse nl ss) `append` nl+ where nl = singleton '\n'++words = L.filter (not . null) . splitWith isSpace+{-# INLINE words #-}++unwords = intercalate (singleton ' ')+{-# INLINE unwords #-}++-- ---------------------------------------------------------------------+-- Searching++isPrefixOf (CS a) (CS b) = B.isPrefixOf a b+isSuffixOf (CS a) (CS b) = B.isSuffixOf a b++isInfixOf p s+ | validSubstring (encoding p) = B.isInfixOf (unCS p) (unCS s)+ | otherwise = not $ L.null $ findSubstrings p s+{-# INLINE isInfixOf #-}++findSubstring = (listToMaybe .) . findSubstrings++-- NOTE: We can't just call the ByteString version, because a three byte+-- encoded char has a valid 1 byte encoded char as a substring.+-- TODO: copy the KMP algorithm from Data.ByteString here+findSubstrings pat@(CS (PS _ _ m)) = search 0+ where+ STRICT2(search)+ search i str@(CS (PS _ _ n))+ | n < m = []+ | pat `isPrefixOf` str = i : search (i+1) (unsafeTail str)+ | otherwise = search (i+1) (unsafeTail str)++-- ---------------------------------------------------------------------+-- Indexing CompactString++index cs@(CS (PS _ _ l)) n+ | n < 0 = moduleError "index" ("negative index: " ++ show n)+ | idx == l = moduleError "index" ("index too large: " ++ show n ++ ", length = " ++ show (length cs))+ | otherwise = snd $ unsafeWithBuffer cs $ peekChar (encoding cs) . (`plusPtr` idx)+ where idx = charIndex cs n+{-# INLINE index #-}++-- ---------------------------------------------------------------------+-- Element searching++elem c = any (c==)+notElem c = not . elem c+{-# INLINE elem #-}+{-# INLINE notElem #-}++elemIndex c = findIndex (c==)+elemIndexEnd c = findIndexEnd (c==)+elemIndices c = findIndices (c==)+{-# INLINE elemIndex #-}+++find f cs@(CS (PS _ _ l)) = unsafeWithBuffer cs $ \ptr -> go ptr (ptr `plusPtr` l)+ where+ STRICT2(go)+ go p q | p == q = return Nothing+ | otherwise = do (l',c) <- peekChar (encoding cs) p+ if f c then return (Just c) + else go (p `plusPtr` l') q+{-# INLINE find #-}++findIndex f cs@(CS (PS _ _ l)) = unsafeWithBuffer cs $ \ptr -> go 0 ptr (ptr `plusPtr` l)+ where+ STRICT3(go)+ go n p q | p == q = return Nothing+ | otherwise = do (l',c) <- peekChar (encoding cs) p+ if f c then return (Just n) + else go (n+1) (p `plusPtr` l') q+{-# INLINE findIndex #-}++findIndexEnd f cs@(CS (PS _ _ l)) = unsafeWithBufferEnd cs $ \ptr -> go 1 ptr (ptr `plusPtr` (-l))+ where+ STRICT3(go)+ go n p q | p == q = return Nothing+ | otherwise = do (l',c) <- peekCharRev (encoding cs) p+ if f c then return $! Just $! length cs - n+ else go (n+1) (p `plusPtr` (-l')) q++findIndices p cs = loop 0 cs+ where+ STRICT2(loop)+ loop n qs = case headView qs of+ Nothing -> []+ Just (q',qs')+ | p q' -> n : loop (n+1) qs'+ | otherwise -> loop (n+1) qs'+++count c = foldl' (\l x -> if x == c then l + 1 else l) 0+++-- ---------------------------------------------------------------------+-- Zipping++zip xxs yys = case (headView xxs, headView yys) of+ (Nothing, _ ) -> []+ (_, Nothing ) -> []+ (Just (x,xs), Just (y,ys)) -> (x,y) : zip xs ys++zipWith f xxs yys = case (headView xxs, headView yys) of+ (Nothing, _ ) -> []+ (_, Nothing ) -> []+ (Just (x,xs), Just (y,ys)) -> f x y : zipWith f xs ys+#if defined(__GLASGOW_HASKELL__)+{-# INLINE [1] zipWith #-}+#endif++zipWith' f a@(CS (PS _ _ l)) b@(CS (PS _ _ m)) = c+ where+ c = CS $ inlinePerformIO $+ withBuffer a $ \p1 ->+ withBuffer b $ \p2 ->+ B.createAndTrim (byteCount (encoding c) (charCount (encoding a) l `min` charCount (encoding b) m)) $+ zipWith_ p1 p2+ zipWith_ p1 p2 p3 = go 0 0 0+ where+ STRICT3(go)+ go i j k+ | i >= l || j >= m = return k+ | otherwise = do+ (l1,c1) <- peekChar (encoding a) (p1 `plusPtr` i)+ (l2,c2) <- peekChar (encoding b) (p2 `plusPtr` j)+ l3 <- pokeChar (encoding c) (p3 `plusPtr` k) (f c1 c2)+ go (i+l1) (j+l2) (k+l3)+{-# INLINE zipWith' #-}++{-# RULES++"CompactString specialise zipWith"+ forall (f :: Char -> Char -> Char) p q .+ zipWith f p q = unpack (zipWith' f p q)++ #-}++unzip ls = (pack (L.map fst ls), pack (L.map snd ls))+{-# INLINE unzip #-}+++-- ---------------------------------------------------------------------+-- Ordered CompactStrings++-- Implementation for lazy programmers+-- Maybe QuickSort would be appropriate here?+sort = pack . L.sort . unpack++-- | Compare two bytestrings, possibly with a different encoding.+compare' :: (Encoding a, Encoding b) => CompactString a -> CompactString b -> Ordering+compare' a@(CS (PS _ _ l1)) b@(CS (PS _ _ l2))+ = B.inlinePerformIO $+ withBuffer a $ \p1 ->+ withBuffer b $ \p2 -> comp p1 p2+ where+ comp p1 p2 = comp_ 0 0+ where+ STRICT2(comp_)+ comp_ pos1 pos2+ | pos1 >= l1 = return $! if l1 < l2 then LT else EQ+ | pos2 >= l2 = return $! GT+ | otherwise = do+ (lc1,c1) <- peekChar (encoding a) (p1 `plusPtr` pos1)+ (lc2,c2) <- peekChar (encoding b) (p2 `plusPtr` pos2)+ if c1 /= c2+ then return $! (c1 `compare` c2)+ else comp_ (pos1 + lc1) (pos2 + lc2)++{-# SPECIALIZE doCompare :: CompactString UTF8 -> CompactString UTF8 -> Ordering #-}+{-# RULES+"CompactString: compare' UTF8"+ compare' = doCompare :: CompactString UTF8 -> CompactString UTF8 -> Ordering+"CompactString: compare' UTF32BE"+ compare' = doCompare :: CompactString UTF32BE -> CompactString UTF32BE -> Ordering+"CompactString: compare' ASCII"+ compare' = doCompare :: CompactString ASCII -> CompactString ASCII -> Ordering+"CompactString: compare' Latin1"+ compare' = doCompare :: CompactString Latin1 -> CompactString Latin1 -> Ordering+ #-}++-- -----------------------------------------------------------------------------+--+-- Encoding+--++-- for type inference+toByteStringAs :: Encoding a => a -> CompactString a -> ByteString+toByteStringAs _ = toByteString+unsafeFromByteStringAs :: Encoding a => a -> ByteString -> CompactString a+unsafeFromByteStringAs _ = unsafeFromByteString+++toByteString = unCS++fromByteString = validate . unsafeFromByteString+fromByteString_ = validate_ . unsafeFromByteString+fromByteStringIO :: Encoding a => ByteString -> IO (CompactString a)+fromByteStringIO = validateIO . unsafeFromByteString++validate = unsafeTry . validateIO+validate_ = unsafePerformIO . validateIO++-- | Convert between two different encodings, fails if conversion is not possible.+recode :: (Encoding a, Encoding b, MonadPlus m) => CompactString a -> m (CompactString b)+recode = unsafeTry . recodeIO+-- | Convert between two different encodings, raises an error if conversion is not possible.+recode_ :: (Encoding a, Encoding b) => CompactString a -> CompactString b+recode_ = unsafePerformIO . recodeIO++-- | recode =<< validate+recodeV :: (Encoding a, Encoding b, MonadPlus m) => CompactString a -> m (CompactString b)+recodeV = unsafeTry . recodeVIO+-- | recode_ . validate_+recodeV_ :: (Encoding a, Encoding b) => CompactString a -> CompactString b+recodeV_ = unsafePerformIO . recodeVIO++encode e = liftM (toByteStringAs e) . recode+encode_ e = (toByteStringAs e) . recode_++decode e = recodeV . (unsafeFromByteStringAs e)+decode_ e = recodeV_ . (unsafeFromByteStringAs e)++encodeBOM e = encode e . cons '\xFEFF'+encodeBOM_ e = encode_ e . cons '\xFEFF'++decodeBOM = unsafeTry . decodeBOM_IO+decodeBOM_ = unsafePerformIO . decodeBOM_IO++{-# INLINE[1] validate #-}+{-# INLINE[1] validate_ #-}+{-# INLINE[1] recode #-}+{-# INLINE[1] recode_ #-}+{-# INLINE[1] recodeV #-}+{-# INLINE[1] recodeV_ #-}+{-# INLINE[1] decodeBOM #-}+{-# INLINE[1] decodeBOM_ #-}+{-# RULES++"CompactString: to/fromByteString"+ forall s.+ toByteString (unsafeFromByteString s) = s+"CompactString: from/toByteString"+ forall s.+ unsafeFromByteString (toByteString s) = s++"CompactString: recode -> return"+ recode = return+"CompactString: recode_ -> id"+ recode_ = id++"CompactString: recode/recode -> recode"+ forall s.+ recode s >>= recode = recode s+"CompactString: recode_/recode_ -> recode_"+ forall s.+ recode_ (recode_ s) = recode_ s++"CompactString: recode/validate"+ forall s.+ validate s >>= recode = recodeV s+"CompactString: recode_/validate_"+ forall s.+ recode_ (validate_ s) = recodeV_ s++"CompactString: recodeV -> validate"+ recodeV = validate+"CompactString: recodeV_ -> validate_"+ recodeV_ = validate_+"CompactString: recodeVIO -> validateIO"+ recodeVIO = validateIO+ +{-+-- TODO: Make these rules work+"CompactString: recode/fromByteString"+ forall bs.+ fromByteString bs >>= (recode :: (Encoding a, Encoding b, MonadPlus m) => CompactString a -> m (CompactString b))+ = decode (undefined::a) bs :: m (CompactString b)+"CompactString: recode_/fromByteString_"+ forall bs.+ recode_ (fromByteString_ bs :: Encoding a => CompactString a) = decode_ (undefined::a) bs+-}++ #-}++decodeBOM_IO :: Encoding a => ByteString -> IO (CompactString a)+decodeBOM_IO bs+ | t2 == [0,0] && t4 == [0xFE,0xFF] = decodeIO (UTF32 BE) (B.drop 4 bs)+ | t2 == [0xFF,0xFE] && t4 == [0,0] = decodeIO (UTF32 LE) (B.drop 4 bs)+ | t2 == [0xFE,0xFF] = decodeIO (UTF16 BE) (B.drop 2 bs)+ | t2 == [0xFF,0xFE] = decodeIO (UTF16 LE) (B.drop 2 bs)+ | t3 == [0xEF,0xBB,0xBF] = decodeIO UTF8 (B.drop 3 bs)+ | otherwise = decodeIO UTF8 bs -- no BOM+ where t2 = B.unpack (B.take 2 bs)+ t3 = B.unpack (B.take 3 bs)+ t4 = B.unpack (B.take 2 (B.drop 2 bs))+ decodeIO e = recodeVIO . (unsafeFromByteStringAs e)++-- | Validate encoding, convert to normal form+validateIO :: Encoding a => CompactString a -> IO (CompactString a)+validateIO cs@(CS (PS fp s l))+ | validEquality (encoding cs) = validateLength (encoding cs) l+ >> withForeignPtr fp (\p -> check (p `plusPtr` s))+ | otherwise = recodeVIO_ cs -- There are multiple representations of the same string, convert to a normal form+ where+ check src = loop 0+ where+ STRICT1(loop)+ loop src_off+ | src_off == l = return cs+ | src_off > l = failMessage "validate" "Incomplete character"+ | otherwise = do (l',_) <- peekCharSafe (encoding cs) (l - src_off) (src `plusPtr` src_off)+ loop (src_off+l')+{-# SPECIALIZE validateIO :: CompactString UTF8 -> IO (CompactString UTF8) #-}++-- | Convert between encodings+recodeIO :: (Encoding a, Encoding b) => CompactString a -> IO (CompactString b)+recodeIO a@(CS (PS fp s l))+ | l == 0 = return empty+ | otherwise = result+ where+ len = byteCount (encoding_b) (charCount (encoding a) l)+ result = liftM CS $+ withForeignPtr fp $ \p -> + B.createAndTrim len $ doRecode (p `plusPtr` s)+ encoding_b = (undefined :: IO (CompactString a) -> Proxy a) result+ doRecode src dest = loop 0 0+ where+ STRICT2(loop)+ loop src_off dest_off+ | src_off >= l = return dest_off+ | otherwise = do (l',c) <- peekChar (encoding a) (src `plusPtr` src_off)+ l'' <- pokeChar (encoding_b) (dest `plusPtr` dest_off) c+ loop (src_off+l') (dest_off+l'')++-- | Validate encoding, convert to normal form+-- Can be rewritten by rules, in particular: recodeVIO -> validateIO+recodeVIO :: (Encoding a, Encoding b) => CompactString a -> IO (CompactString b)+recodeVIO = recodeVIO_+{-# INLINE[1] validateIO #-}++-- | Convert between encodings, use peekCharSafe+recodeVIO_ :: (Encoding a, Encoding b) => CompactString a -> IO (CompactString b)+recodeVIO_ a@(CS (PS fp s l))+ | l == 0 = return empty+ | otherwise = result+ where+ len = byteCount (encoding_b) (charCount (encoding a) l)+ result = validateLength (encoding a) l+ >> (liftM CS $+ withForeignPtr fp $ \p -> + B.createAndTrim len $ doRecode (p `plusPtr` s))+ encoding_b = (undefined :: IO (CompactString a) -> Proxy a) result+ doRecode src dest = loop 0 0+ where+ STRICT2(loop)+ loop src_off dest_off+ | src_off >= l = return dest_off+ | otherwise = do (l',c) <- peekCharSafe (encoding a) (l - src_off) (src `plusPtr` src_off)+ l'' <- pokeChar (encoding_b) (dest `plusPtr` dest_off) c+ loop (src_off+l') (dest_off+l'')+++-- ---------------------------------------------------------------------+-- Standard IO++getLine = hGetLine stdin++getContents = hGetContents stdin++putStr = hPut stdout++putStrLn = hPutStrLn stdout++interact transformer = putStr . transformer =<< getContents++-- ---------------------------------------------------------------------+-- File IO++readFile f = C8.readFile f >>= fromByteStringIO+readFile' f = C8.readFile f >>= decodeBOM_IO++writeFile f txt = C8.writeFile f (toByteString txt)+writeFile' f txt = C8.writeFile f (toByteString ('\xFEFF' `cons` txt))++appendFile f txt = C8.appendFile f (toByteString txt)+appendFile' f txt = bracket (openFile f AppendMode) hClose+ (\h -> appendHandle h txt)++-- | Append a 'ByteString' to a file.+-- appendFile :: FilePath -> ByteString -> IO ()+-- TODO : Determine encoding used by the file, then append using the same encoding++appendHandle :: Encoding a => Handle -> CompactString a -> IO ()+appendHandle h cs = do+ pos <- hTell h+ hSeek h AbsoluteSeek 0+ enc <- findEncoding h+ bs <- enc cs+ hSeek h AbsoluteSeek pos+ B.hPut h bs++-- | Determine the encoding to use for a handle by examining the Byte Order Mark.+-- The handle should be positioned at the start of the file.+findEncoding :: Encoding a => Handle -> IO (CompactString a -> IO ByteString)+findEncoding h = do+ bs <- B.hGet h 4+ return (encodingOf bs)+ where encodingOf bs+ | B.null bs = return . toByteString . cons '\xFEFF' -- empty file, start with a BOM+ | t2 == [0,0] && t4 == [0xFE,0xFF] = encodeIO (UTF32 BE)+ | t2 == [0xFF,0xFE] && t4 == [0,0] = encodeIO (UTF32 LE)+ | t2 == [0xFE,0xFF] = encodeIO (UTF16 BE)+ | t2 == [0xFF,0xFE] = encodeIO (UTF16 LE)+ | otherwise = encodeIO UTF8 -- no BOM or UTF8 BOM+ where t2 = B.unpack (B.take 2 bs)+ t4 = B.unpack (B.take 2 (B.drop 2 bs))+ encodeIO e = liftM (toByteStringAs e) . recodeIO++-- ---------------------------------------------------------------------+-- Handle IO++hGetLine h = System.IO.hGetLine h >>= return . pack++hGetContents h = B.hGetContents h >>= fromByteStringIO+hGetContents' h = B.hGetContents h >>= decodeBOM_IO++hGet h i = B.hGet h i >>= fromByteStringIO+hGetNonBlocking h i = B.hGetNonBlocking h i >>= fromByteStringIO++hPut h = B.hPut h . toByteString++hPutStr = hPut++hPutStrLn h cs@(CS bs)+ | B.length bs < 1024 = hPut h (cs `snoc` '\n')+ | otherwise = hPut h cs >> hPut h (singleton '\n' `asTypeOf` cs) -- don't copy+++-- ---------------------------------------------------------------------+-- Internal utilities++-- | Find the byte position corresponding to the given character index,+-- the index must be positive.+charIndex :: Encoding a => CompactString a -> Int -> Int+charIndex cs@(CS (PS _ _ l)) n = unsafeWithBuffer cs $ \src -> (go src n 0)+ where+ STRICT3(go)+ go _ 0 p = return p+ go src i p+ | p >= l = return l+ | otherwise = do l' <- peekCharLen (encoding cs) (src `plusPtr` p)+ go src (i-1) (p+l')++-- | 'findIndexOrEnd' is a variant of findIndex, that returns the length+-- in bytes of the string if no element is found, rather than Nothing.+findIndexOrEnd :: Encoding a => (Char -> Bool) -> CompactString a -> Int+findIndexOrEnd f cs@(CS (PS _ _ l)) = unsafeWithBuffer cs $ \ptr -> go ptr 0+ where+ STRICT2(go)+ go ptr n | n >= l = return l+ | otherwise = do (l',c) <- peekChar (encoding cs) ptr+ if f c then return n+ else go (ptr `plusPtr` l') (n+l')+{-# INLINE findIndexOrEnd #-}++-- | 'findIndexOrBeginRev' is a variant of findIndexOrEnd, that searches+-- from the end instead of from the start+findIndexOrBeginRev :: Encoding a => (Char -> Bool) -> CompactString a -> Int+findIndexOrBeginRev f cs@(CS (PS _ _ l)) = unsafeWithBufferEnd cs $ \ptr -> go ptr l+ where+ STRICT2(go)+ go ptr n | n <= 0 = return 0+ | otherwise = do (l',c) <- peekCharRev (encoding cs) ptr+ if f c then return n+ else go (ptr `plusPtr` (-l')) (n-l')+{-# INLINE findIndexOrBeginRev #-}
+ Data/CompactString/ASCII.hs view
@@ -0,0 +1,9 @@+#define ENCODING ASCII+#define TYPE ASCII+#define DESCRIPTION ASCII+#define LONG_DESCRIPTION ASCII. \+ Note that not all characters can be encoded in ASCII, \+ if encoding is not possible the function will raise an error.+#define IF_NOT_REPRESENT(a) a+#define IF_FIXED(a,b) b+#include "specialized.include"
+ Data/CompactString/Encodings.hs view
@@ -0,0 +1,609 @@+-- |+-- Module : Data.CompactString.Encodings+-- License : BSD-style+-- Maintainer : twanvl@gmail.com+-- Stability : experimental+-- Portability : untested+-- +-- Different encodings of characters into bytes.+--+module Data.CompactString.Encodings (+ + -- * Unicode encodings+ UTF8(..),+ BE(..), LE(..), Native,+ UTF16(..), UTF16BE, UTF16LE, UTF16Native,+ UTF32(..), UTF32BE, UTF32LE, UTF32Native,+ + -- * Other encodings+ ASCII(..),+ Latin1(..),+ + -- * Non-standard encodings+ Compact(..)+ + ) where++import Data.Word+import Data.Bits++import Foreign.Ptr (Ptr)++import Control.Monad (when, unless)++import Data.CompactString.Internal++-- -----------------------------------------------------------------------------+--+-- Encoding : UTF8+--++-- | Tag representing the UTF-8 encoding.+-- Use @'CompactString' UTF8@ for UTF-8 encoded strings.+data UTF8 = UTF8++instance Encoding UTF8 where+ pokeCharFun _ c = case ord c of+ x | x < 0x80 -> (1, \p -> poke p $ fromIntegral x )+ | x < 0x800 -> (2, \p -> do poke p $ fromIntegral (x `shiftR` 6) .|. 0xC0+ pokeByteOff p 1 $ (fromIntegral x .&. 0x3F) .|. 0x80)+ | x < 0x10000 -> (3, \p -> do poke p $ fromIntegral (x `shiftR` 12) .|. 0xE0+ pokeByteOff p 1 $ (fromIntegral (x `shiftR` 6) .&. 0x3F) .|. 0x80+ pokeByteOff p 2 $ (fromIntegral x .&. 0x3F) .|. 0x80)+ | otherwise -> (4, \p -> do poke p $ fromIntegral (x `shiftR` 18) .|. 0xF0+ pokeByteOff p 1 $ (fromIntegral (x `shiftR` 12) .&. 0x3F) .|. 0x80+ pokeByteOff p 2 $ (fromIntegral (x `shiftR` 6) .&. 0x3F) .|. 0x80+ pokeByteOff p 3 $ (fromIntegral x .&. 0x3F) .|. 0x80)+ {-# INLINE pokeCharFun #-}+ + + peekChar _ p = do+ a <- peek p+ case charLenUTF8 a of+ 1 -> return (1, decodeUTF8_1 a)+ 2 -> do b <- peekByteOff p 1+ return (2, decodeUTF8_2 a b)+ 3 -> do b <- peekByteOff p 1+ c <- peekByteOff p 2+ return (3, decodeUTF8_3 a b c)+ _ -> do b <- peekByteOff p 1+ c <- peekByteOff p 2+ d <- peekByteOff p 3+ return (4, decodeUTF8_4 a b c d)+ + peekCharLen _ p = do+ a <- peek p+ return (charLenUTF8 a)+ {-# INLINE peekCharLen #-}+ + peekCharRev _ p =+ peek p >>= \a -> if not (a `testBit` 7) then return (1, decodeUTF8_1 a) else+ peekByteOff p (-1) >>= \b -> if (b `testBit` 6) then return (2, decodeUTF8_2 b a) else+ peekByteOff p (-2) >>= \c -> if (c `testBit` 6) then return (3, decodeUTF8_3 c b a) else+ peekByteOff p (-3) >>= \d -> return (4, decodeUTF8_4 d c b a)+ + peekCharLenRev _ p = + peek p >>= \a -> if not (a `testBit` 7) then return 1 else+ peekByteOff p (-1) >>= \b -> if (b `testBit` 6) then return 2 else+ peekByteOff p (-2) >>= \c -> if (c `testBit` 6) then return 3 else+ return 4+ {-# INLINE peekCharLenRev #-}+ + + peekCharSafe _ l p = do+ a <- peek p+ case () of+ _ | not (a `testBit` 7) -> returnChr 1 (fromIntegral a)+ | not (a `testBit` 6) -> failMessage "decode UTF8" "Invalid UTF8"+ | not (a `testBit` 5) -> do require 2+ b <- peekMore 1+ let x = ((fromIntegral a .&. 0x1F) `shiftL` 6) .|. b+ tooShort (x < 0x80)+ returnChr 2 x+ | not (a `testBit` 4) -> do require 3+ b <- peekMore 1+ c <- peekMore 2+ let x = ((fromIntegral a .&. 0x0F) `shiftL` 12) .|. (b `shiftL` 6) .|. c+ tooShort (x < 0x800)+ returnChr 3 x+ | not (a `testBit` 3) -> do require 4+ b <- peekMore 1+ c <- peekMore 2+ d <- peekMore 3+ let x = ((fromIntegral a .&. 0x07) `shiftL` 18) .|. (b `shiftL` 12) .|. (c `shiftL` 6) .|. d+ tooShort (x < 0x10000)+ returnChr 4 x+ | otherwise -> failMessage "decode UTF8" "Invalid UTF8"+ where peekMore off = do x <- peekByteOff p off+ when (x < 0x80 || x > 0xBF) (failMessage "decode UTF8" "Invalid UTF8")+ return $ fromIntegral (x .&. 0x3F)+ require len = when (l < len) (failMessage "decode UTF8" "Not enough input")+ tooShort b = when b (failMessage "decode UTF8" "Shorter encoding possible")+ + + copyChar enc src dst = do+ l <- peekCharLen enc src+ memcpy dst src (fromIntegral l)+ return l+ copyCharRev enc src dst = do+ l <- peekCharLenRev enc src+ memcpy dst (src `plusPtr` (1 - l)) (fromIntegral l)+ return l+ + + containsASCII _ = True+ validOrdering _ = True+ validSubstring _ = True+ byteCount _ n = 4 * n -- A char is at most 4 bytes+++-- | Length of a character is determined by the first byte+charLenUTF8 :: Word8 -> Int+charLenUTF8 x+ | not (x `testBit` 7) = 1+ | not (x `testBit` 5) = 2+ | not (x `testBit` 4) = 3+ | otherwise = 4 -- assumes the bytestring is valid UTF8+{-# INLINE charLenUTF8 #-}++-- | Decode a UTF8 encoded character+decodeUTF8_1 :: Word8 -> Char+decodeUTF8_1 a+ = unsafeChr $ (fromIntegral a)+decodeUTF8_2 :: Word8 -> Word8 -> Char+decodeUTF8_2 a b+ = unsafeChr $ (fromIntegral a `shiftL` 6)+ `xor` (fromIntegral b)+ `xor` 0x3080+decodeUTF8_3 :: Word8 -> Word8 -> Word8 -> Char+decodeUTF8_3 a b c+ = unsafeChr $ (fromIntegral a `shiftL` 12)+ `xor` (fromIntegral b `shiftL` 6)+ `xor` (fromIntegral c)+ `xor` 0xE2080+decodeUTF8_4 :: Word8 -> Word8 -> Word8 -> Word8 -> Char+decodeUTF8_4 a b c d+ = unsafeChr $ (fromIntegral a `shiftL` 18)+ `xor` (fromIntegral b `shiftL` 12)+ `xor` (fromIntegral c `shiftL` 6)+ `xor` (fromIntegral d)+ `xor` 0x3C82080+-- NOTE: the masks at the end are from the tag bits+-- for example the last one is:+-- 11110001000010000010000000+++-- -----------------------------------------------------------------------------+--+-- Endianness+--++-- | Tag representing big endian encoding+data BE = BE+-- | Tag representing little endian encoding+data LE = LE+-- | The platform native endianness+type Native = LE -- TODO : detect++-- | Class representing endianness+class Endian e where+ -- | Read a 16 bit word from the given location+ peekWord16 :: Proxy (t e) -> Ptr Word8 -> IO Word16+ -- | Write a 16 bit word to the given location+ pokeWord16 :: Proxy (t e) -> Ptr Word8 -> Word16 -> IO ()+ -- | Read a 32 bit word from the given location+ peekWord32 :: Proxy (t e) -> Ptr Word8 -> IO Word32+ -- | Write a 32 bit word to the given location+ pokeWord32 :: Proxy (t e) -> Ptr Word8 -> Word32 -> IO ()+ -- | Is this a big endian encoding+ isBE :: Proxy (t e) -> Bool++instance Endian BE where+ peekWord16 _ ptr = do+ a <- peek ptr+ b <- peekByteOff ptr 1+ return ((fromIntegral a `shiftL` 8) .|. fromIntegral b)+ {-# INLINE peekWord16 #-}+ pokeWord16 _ ptr x = do+ poke ptr $ fromIntegral (x `shiftR` 8)+ pokeByteOff ptr 1 $ fromIntegral x+ {-# INLINE pokeWord16 #-}+ peekWord32 _ ptr = do+ a <- peek ptr+ b <- peekByteOff ptr 1+ c <- peekByteOff ptr 2+ d <- peekByteOff ptr 3+ return $ (fromIntegral a `shiftL` 24) .|.+ (fromIntegral b `shiftL` 16) .|.+ (fromIntegral c `shiftL` 8 ) .|.+ (fromIntegral d )+ {-# INLINE peekWord32 #-}+ pokeWord32 _ ptr x = do+ poke ptr $ fromIntegral (x `shiftR` 24)+ pokeByteOff ptr 1 $ fromIntegral (x `shiftR` 16)+ pokeByteOff ptr 2 $ fromIntegral (x `shiftR` 8)+ pokeByteOff ptr 3 $ fromIntegral x+ {-# INLINE pokeWord32 #-}+ isBE _ = True++instance Endian LE where+ peekWord16 _ ptr = do+ a <- peek ptr+ b <- peekByteOff ptr 1+ return ((fromIntegral b `shiftL` 8) .|. fromIntegral a)+ {-# INLINE peekWord16 #-}+ pokeWord16 _ ptr x = do+ poke ptr $ fromIntegral x+ pokeByteOff ptr 1 $ fromIntegral (x `shiftR` 8)+ {-# INLINE pokeWord16 #-}+ peekWord32 _ ptr = do+ a <- peek ptr+ b <- peekByteOff ptr 1+ c <- peekByteOff ptr 2+ d <- peekByteOff ptr 3+ return $ (fromIntegral d `shiftL` 24) .|.+ (fromIntegral c `shiftL` 16) .|.+ (fromIntegral b `shiftL` 8 ) .|.+ (fromIntegral a )+ {-# INLINE peekWord32 #-}+ pokeWord32 _ ptr x = do+ poke ptr $ fromIntegral x+ pokeByteOff ptr 1 $ fromIntegral (x `shiftR` 8)+ pokeByteOff ptr 2 $ fromIntegral (x `shiftR` 16)+ pokeByteOff ptr 3 $ fromIntegral (x `shiftR` 24)+ {-# INLINE pokeWord32 #-}+ isBE _ = False++-- -----------------------------------------------------------------------------+--+-- Encoding : UTF16+--++-- | Tag representing the UTF-16 encoding+data UTF16 endianness = UTF16 endianness++-- | Tag representing the big endian UTF-16 encoding, aka. UTF-16BE.+type UTF16BE = UTF16 BE++-- | Tag representing the little endian UTF-16 encoding, aka. UTF-16LE.+type UTF16LE = UTF16 LE++-- | Tag representing the platform native UTF-16 encoding.+type UTF16Native = UTF16 Native++instance Endian e => Encoding (UTF16 e) where+ pokeCharFun enc c+ | isSurrogate x = (2, \_ -> failMessage "encoding UTF16" "Surrogate character")+ | x <= 0xFFFF = (2, \p -> pokeWord16 enc p $ fromIntegral x)+ | otherwise = (4, \p -> pokeWord16 enc p h+ >> pokeWord16 enc (p `plusPtr` 2) l)+ where x = ord c+ x' = x - 0x10000+ h = fromIntegral $ (x' `shiftR` 10) .|. 0xD800+ l = fromIntegral $ (x' .&. 0x3FF) .|. 0xDC00+ + pokeCharLen _ c = if ord c <= 0xFFFF then 2 else 4+ + peekChar enc p = do a <- peekWord16 enc p+ if isSurrogate a+ then do+ b <- peekWord16 enc (p `plusPtr` 2)+ decodeUTF16 a b+ else+ return (2, unsafeChr $ fromIntegral a)+ peekCharRev enc p = do a <- peekWord16 enc (p `plusPtr` (-1))+ if isSurrogate a+ then do+ b <- peekWord16 enc (p `plusPtr` (-3))+ decodeUTF16 b a+ else+ return (2, unsafeChr $ fromIntegral a)+ peekCharLen enc p = do a <- peekWord16 enc p+ return (if isSurrogate a then 4 else 2)+ peekCharLenRev enc p = do a <- peekWord16 enc (p `plusPtr` (-1))+ return (if isSurrogate a then 4 else 2)+ + peekCharSafe enc l p = do a <- peekWord16 enc p+ if isSurrogate a+ then do+ when (l < 4) (failMessage "decode UTF16" "Not enough input")+ b <- peekWord16 enc (p `plusPtr` 2)+ decodeUTF16Safe a b+ else+ return (2, unsafeChr $ fromIntegral a)+ validateLength _ len+ | len `mod` 2 /= 0 = failMessage "decode UTF16" "Not enough input"+ | otherwise = return ()+ + containsASCII _ = False+ validEquality _ = False -- there are two ways to encode a character+ validOrdering _ = False+ validSubstring _ = False+ + charCount _ n = n `div` 2 -- at least 2 bytes per char+ byteCount _ n = n * 4 -- at most 4 bytes per char+ newSize _ n = n * 2++isSurrogate :: (Num a, Ord a) => a -> Bool+isSurrogate c = c >= 0xD800 && c <= 0xDFFF++-- | Decode an UTF16 surrogate pair, does no error checking+decodeUTF16 :: Word16 -> Word16 -> IO (Int,Char)+decodeUTF16 a b+ | a <= 0xDBFF = return (4, unsafeChr $ (((fromIntegral a .&. 0x3FF) `shiftL` 10) .|. (fromIntegral b .&. 0x3FF)) + 0x10000)+ | otherwise = return (4, unsafeChr $ (((fromIntegral b .&. 0x3FF) `shiftL` 10) .|. (fromIntegral a .&. 0x3FF)) + 0x10000)++decodeUTF16Safe :: Word16 -> Word16 -> IO (Int,Char)+decodeUTF16Safe a b+ | ahi && blo = returnChr 4 $ (((fromIntegral a .&. 0x3FF) `shiftL` 10) .|. (fromIntegral b .&. 0x3FF)) + 0x10000+ | alo && bhi = returnChr 4 $ (((fromIntegral b .&. 0x3FF) `shiftL` 10) .|. (fromIntegral a .&. 0x3FF)) + 0x10000+ | otherwise = failMessage "decode UTF16" "Unpaired surrogate"+ where ahi = a >= 0xD800 && a <= 0xDBFF+ alo = a >= 0xDC00 && a <= 0xDFFF+ bhi = b >= 0xD800 && b <= 0xDBFF+ blo = b >= 0xDC00 && b <= 0xDFFF++-- -----------------------------------------------------------------------------+--+-- Encoding : UTF32+--++-- | Tag representing the UTF-32 encoding+data UTF32 endianness = UTF32 endianness++-- | Tag representing the big endian UTF-32 encoding, aka. UTF-32BE.+type UTF32BE = UTF32 BE++-- | Tag representing the little endian UTF-32 encoding, aka. UTF-32LE.+type UTF32LE = UTF32 LE++-- | Tag representing the platform native UTF-32 encoding.+type UTF32Native = UTF32 Native++instance Endian e => Encoding (UTF32 e) where+ pokeCharFun enc c = (4, \p -> pokeWord32 enc p (fromIntegral (ord c)))+ + pokeCharLen _ _ = 4+ + peekChar enc p = do a <- peekWord32 enc p+ return (4, unsafeChr $ fromIntegral a)+ peekCharRev enc p = do a <- peekWord32 enc (p `plusPtr` (-3))+ return (4, unsafeChr $ fromIntegral a)+ peekCharLen _ _ = return 4+ peekCharLenRev _ _ = return 4+ + peekCharSafe enc _ p = do a <- peekWord32 enc p+ returnChr 4 a+ validateLength _ len+ | len `mod` 4 /= 0 = failMessage "decode UTF32" "Not enough input"+ | otherwise = return ()+ + containsASCII _ = False+ validOrdering enc = isBE enc+ validSubstring _ = True+ + charCount _ n = n `div` 4 -- at least 4 bytes per char+ byteCount _ n = n * 4 -- at most 4 bytes per char+ newSize _ n = n++-- -----------------------------------------------------------------------------+--+-- Encoding : ASCII+--++-- | Tag representing the ASCII encoding.+data ASCII = ASCII++instance Encoding ASCII where+ pokeCharFun _ c+ | c <= '\x7F' = (1, \p -> poke p (fromIntegral (ord c)))+ | otherwise = (1, \_ -> failMessage "encode ASCII" "Not an ASCII character")+ + pokeCharLen _ _ = 1+ + peekChar _ p = do a <- peek p+ return (1, unsafeChr $ fromIntegral a)+ peekCharRev _ p = do a <- peek p+ return (1, unsafeChr $ fromIntegral a)+ peekCharLen _ _ = return 1+ peekCharLenRev _ _ = return 1+ + peekCharSafe _ _ p = do a <- peek p+ unless (a <= 0x7F) (failMessage "decode ASCII" "Not an ASCII character")+ returnChr 1 (fromIntegral a)+ + containsASCII _ = True+ validOrdering _ = True+ validSubstring _ = True+ + charCount _ n = n+ byteCount _ n = n+ newSize _ n = n++-- -----------------------------------------------------------------------------+--+-- Encoding : Latin1+--++-- | Tag representing the ISO 8859-1 encoding (latin 1).+data Latin1 = Latin1++instance Encoding Latin1 where+ pokeCharFun _ c+ | c <= '\xFF' = (1, \p -> poke p (fromIntegral (ord c)))+ | otherwise = (1, \_ -> failMessage "encode Latin1" "Not a Latin1 character")+ + pokeCharLen _ _ = 1+ + peekChar _ p = do a <- peek p+ return (1, unsafeChr $ fromIntegral a)+ peekCharRev _ p = do a <- peek p+ return (1, unsafeChr $ fromIntegral a)+ peekCharLen _ _ = return 1+ peekCharLenRev _ _ = return 1+ + peekCharSafe _ _ p = do a <- peek p+ unless (a <= 0xFF) (failMessage "decode Latin1" "Not a Latin1 character")+ returnChr 1 (fromIntegral a)+ + containsASCII _ = True+ validOrdering _ = True+ validSubstring _ = True+ + charCount _ n = n+ byteCount _ n = n+ newSize _ n = n++-- -----------------------------------------------------------------------------+--+-- Encoding : Compact+--++-- | Tag representing a custom encoding optimized for memory usage.+--+-- This encoding looks like UTF-8, but is slightly more efficient.+-- It requires at most 3 byes per character, as opposed to 4 for UTF-8.+--+-- Encoding looks like:+--+-- > 0zzzzzzz -> 0zzzzzzz+-- > 00yyyyyy yzzzzzzz -> 1xxxxxxx 1yyyyyyy+-- > 000xxxxx xxyyyyyy yzzzzzzz -> 1xxxxxxx 0yyyyyyy 1zzzzzzz+--+-- The reasoning behind the tag bits is that this allows the char to be read both forwards+-- and backwards.+data Compact = Compact++instance Encoding Compact where+ pokeCharFun _ c = case ord c of+ x | x < 0x80 -> (1, \p -> poke p $ fromIntegral x )+ | x < 0x4000 -> (2, \p -> do poke p $ fromIntegral (x `shiftR` 7) .|. 0x80+ pokeByteOff p 1 $ fromIntegral x .|. 0x80 )+ | otherwise -> (3, \p -> do poke p $ fromIntegral (x `shiftR` 14) .|. 0x80+ pokeByteOff p 1 $ fromIntegral (x `shiftR` 7) .&. 0x7F+ pokeByteOff p 2 $ fromIntegral x .|. 0x80 )+ {-# INLINE pokeCharFun #-}+ + pokeCharLen _ c = case ord c of+ x | x < 0x80 -> 1+ | x < 0x4000 -> 2+ | otherwise -> 3+ {-# INLINE pokeCharLen #-}+ + + peekChar _ p = do+ aw <- peek p+ let a = fromIntegral aw+ if a `testBit` 7+ then do+ bw <- peekByteOff p 1+ let b = fromIntegral bw+ if b `testBit` 7+ then -- 2 bytes+ return (2, unsafeChr $ (a `shiftL` 7) `xor` b `xor` 0x4080 )+ else do -- 3 bytes+ cw <- peekByteOff p 2+ let c = fromIntegral cw+ return (3, unsafeChr $ (a `shiftL` 14) `xor` (b `shiftL` 7) `xor` c `xor` 0x200080 )+ else return (1, unsafeChr a) -- 1 byte+ + peekCharLen _ p = do+ a <- peek p+ if a `testBit` 7+ then do+ b <- peekByteOff p 1+ return (if b `testBit` 7 then 2 else 3)+ else return 1+ {-# INLINE peekCharLen #-}+ + peekCharRev _ p = do+ cw <- peek p+ let c = fromIntegral cw+ if c `testBit` 7+ then do+ bw <- peekByteOff p (-1)+ let b = fromIntegral bw+ if b `testBit` 7+ then -- 2 bytes+ return (2, unsafeChr $ (b `shiftL` 7) `xor` c `xor` 0x4080 )+ else do -- 3 bytes+ aw <- peekByteOff p (-2)+ let a = fromIntegral aw+ return (3, unsafeChr $ (a `shiftL` 14) `xor` (b `shiftL` 7) `xor` c `xor` 0x200080 )+ else return (1, unsafeChr c) -- 1 byte+ + peekCharLenRev _ p = do+ a <- peek p+ if a `testBit` 7+ then do+ b <- peekByteOff p (-1)+ return (if b `testBit` 7 then 2 else 3)+ else return 1+ {-# INLINE peekCharLenRev #-}+ + peekCharSafe _ l p = do+ aw <- peek p+ let a = fromIntegral aw+ if a `testBit` 7+ then do+ require 2+ bw <- peekByteOff p 1+ let b = fromIntegral bw+ if b `testBit` 7+ then do -- 2 bytes+ let x = ((a `shiftL` 7) `xor` b `xor` 0x4080)+ tooShort (x < 0x80)+ returnChr 2 x+ else do -- 3 bytes+ require 3+ cw <- peekByteOff p 2+ let c = fromIntegral cw+ unless (c `testBit` 7) (failMessage "decode Compact" "Invalid byte sequence")+ let x = ((a `shiftL` 14) `xor` (b `shiftL` 7) `xor` c `xor` 0x200080)+ tooShort (x < 0x4000)+ returnChr 3 x+ else returnChr 1 a -- 1 byte+ where require len = when (l < len) (failMessage "decode Compact" "Not enough input")+ tooShort b = when b (failMessage "decode UTF8" "Shorter encoding possible")+ + copyChar _ src dst = do+ aw <- peek src+ poke dst aw+ if aw `testBit` 7+ then do+ bw <- peekByteOff src 1+ pokeByteOff dst 1 bw+ if bw `testBit` 7+ then do -- 2 bytes+ return 2+ else do -- 3 bytes+ peekByteOff src 2 >>= pokeByteOff dst 2+ return 3+ else do -- 1 byte+ return 1+ + copyCharRev _ src dst = do+ aw <- peek src+ if aw `testBit` 7+ then do+ bw <- peekByteOff src (-1)+ if bw `testBit` 7+ then do -- 2 bytes+ poke dst bw+ pokeByteOff dst 1 aw+ return 2+ else do -- 3 bytes+ cw <- peekByteOff src (-2)+ poke dst cw+ pokeByteOff dst 1 bw+ pokeByteOff dst 2 aw+ return 3+ else do -- 1 byte+ poke dst aw+ return 1+ + + containsASCII _ = True+ validOrdering _ = False+ validSubstring _ = False+ byteCount _ n = 3 * n -- A char is at most 3 bytes
+ Data/CompactString/Fusion.hs view
@@ -0,0 +1,113 @@+-- |+-- Module : Data.CompactString.Fusion+-- License : BSD-style+-- Maintainer : twanvl@gmail.com+-- Stability : experimental+-- Portability : untested+-- +-- Fusable loop functions, mirrors "Data.ByteString.Fusion".+--+module Data.CompactString.Fusion+ ( loopAcc, loopArr, NoAcc(..)+ , foldEFL, mapEFL, filterEFL, scanEFL, mapAccumEFL, mapIndexEFL+ , loopUp, loopUpC, loopDown, loopUpFold, loopDownFold+ ) where++import Data.CompactString.Internal+import qualified Data.ByteString.Internal as B++-- -----------------------------------------------------------------------------+--+-- Same as older bytestrings+--++-- |Data type for accumulators which can be ignored. The rewrite rules rely on+-- the fact that no bottoms of this type are ever constructed; hence, we can+-- assume @(_ :: NoAcc) `seq` x = x@.+--+data NoAcc = NoAcc++-- | Projection functions that are fusion friendly (as in, we determine when+-- they are inlined)+loopArr :: (PairS acc arr) -> arr+loopArr (_ :*: arr) = arr+#if defined(__GLASGOW_HASKELL__)+{-# INLINE [1] loopArr #-}+#endif++loopAcc :: (PairS acc arr) -> acc+loopAcc (acc :*: _) = acc+#if defined(__GLASGOW_HASKELL__)+{-# INLINE [1] loopAcc #-}+#endif++-- -----------------------------------------------------------------------------+--+-- EFLs+--++mapEFL :: (Char -> Char) -> AccEFL NoAcc+mapEFL f = \_ e -> (NoAcc :*: (JustS $ f e))++foldEFL :: (acc -> Char -> acc) -> AccEFL acc+foldEFL f = \a e -> (f a e :*: NothingS)++filterEFL :: (Char -> Bool) -> AccEFL NoAcc+filterEFL p = \_ e -> if p e then (NoAcc :*: JustS e)+ else (NoAcc :*: NothingS)++scanEFL :: (Char -> Char -> Char) -> AccEFL Char+scanEFL f = \a e -> (f a e :*: JustS a)++-- | Element function implementing a map and fold+mapAccumEFL :: (acc -> Char -> (acc, Char)) -> AccEFL acc+mapAccumEFL f = \a e -> case f a e of (a', e') -> (a' :*: JustS e')++-- | Element function implementing a map with index+mapIndexEFL :: (Int -> Char -> Char) -> AccEFL Int+mapIndexEFL f = \i e -> let i' = i+1 in i' `seq` (i' :*: JustS (f i e))++#if defined(__GLASGOW_HASKELL__)+{-# INLINE [1] foldEFL #-}+{-# INLINE [1] mapEFL #-}+{-# INLINE [1] filterEFL #-}+{-# INLINE [1] scanEFL #-}+{-# INLINE [1] mapAccumEFL #-}+{-# INLINE [1] mapIndexEFL #-}+#endif++-- -----------------------------------------------------------------------------+--+-- Looping+--++loopUp :: Encoding a => AccEFL acc -> acc -> CompactString a -> PairS acc (CompactString a)+loopUp f a arr = loopWrapper (newSize (encoding arr)) (doUpLoop (encoding arr) f a) arr++-- | like loopUp, but the size of the buffer can only become smaller+loopUpC :: Encoding a => AccEFL acc -> acc -> CompactString a -> PairS acc (CompactString a)+loopUpC f a arr = loopWrapper id (doUpLoop (encoding arr) f a) arr++loopDown :: Encoding a => AccEFL acc -> acc -> CompactString a -> PairS acc (CompactString a)+loopDown f a arr = loopWrapper (newSize (encoding arr)) (doDownLoop (encoding arr) f a) arr++loopUpFold :: Encoding a => FoldEFL acc -> acc -> CompactString a -> acc+loopUpFold f a arr = loopWrapperFold (doUpLoopFold (encoding arr) f a) arr++loopDownFold :: Encoding a => FoldEFL acc -> acc -> CompactString a -> acc+loopDownFold f a arr = loopWrapperFold (doDownLoopFold (encoding arr) f a) arr++-------------------------------------------------------------------------------+-- Wrappers++-- first argument is the factor by which the string can grow+-- maxCharSize for map (all 1 byte chars become maxCharSize byte chars)+loopWrapper :: (Int -> Int) -> ImperativeLoop acc -> CompactString a -> PairS acc (CompactString a)+loopWrapper factor body cs@(CS (B.PS _ _ srcLen)) = unsafeWithBuffer cs $ \src -> do+ (ps, acc) <- B.createAndTrim' (factor srcLen) $ \dest -> do+ (acc :*: destOffset :*: destLen) <- body src dest srcLen+ return (destOffset, destLen, acc)+ return (acc :*: CS ps)++loopWrapperFold :: ImperativeLoop_ acc -> CompactString a -> acc+loopWrapperFold body cs@(CS (B.PS _ _ srcLen)) = unsafeWithBuffer cs $ \src -> body src srcLen
+ Data/CompactString/Internal.hs view
@@ -0,0 +1,330 @@+-- |+-- Module : Data.CompactString.Internal+-- License : BSD-style+-- Maintainer : twanvl@gmail.com+-- Stability : experimental+-- Portability : untested+-- +-- Internal functions for the CompactString type.+--+module Data.CompactString.Internal (+ CompactString(..),+ Proxy, encoding, Encoding(..),+ PairS(..), MaybeS(..), unSP,+ AccEFL, FoldEFL, ImperativeLoop, ImperativeLoop_,+ ByteString(..), memcpy, inlinePerformIO,+ withBuffer, withBufferEnd, unsafeWithBuffer, unsafeWithBufferEnd, create,+ ord, unsafeChr, returnChr,+ plusPtr, peekByteOff, pokeByteOff, peek, poke,+ failMessage, moduleError, errorEmptyList, unsafeTry, unsafeTryIO+ ) where++import Foreign.Ptr (Ptr)+import qualified Foreign.Ptr (plusPtr)+import Foreign.Storable (Storable, peek, poke)+import qualified Foreign.Storable+import Foreign.ForeignPtr (withForeignPtr)++import Data.Word (Word8, Word32)+import Data.Char (ord)++import Control.Monad+import Control.Exception+import System.IO.Error (isUserError, ioeGetErrorString)++#if defined(__GLASGOW_HASKELL__)+import GHC.Base (unsafeChr)+#else+import Data.Char (chr)+#endif++import System.IO.Unsafe++import Data.ByteString.Internal (ByteString(..), memcpy, inlinePerformIO)+import qualified Data.ByteString.Internal as B++-- -----------------------------------------------------------------------------+--+-- Useful macros, until we have bang patterns+--++#define STRICT1(f) f _a | _a `seq` False = undefined+#define STRICT2(f) f _a _b | _a `seq` _b `seq` False = undefined+#define STRICT3(f) f _a _b _c | _a `seq` _b `seq` _c `seq` False = undefined+#define STRICT4(f) f _a _b _c _d | _a `seq` _b `seq` _c `seq` _d `seq` False = undefined+#define STRICT5(f) f _a _b _c _d _e | _a `seq` _b `seq` _c `seq` _d `seq` _e `seq` False = undefined++-- -----------------------------------------------------------------------------+--+-- Utilities+--++data PairS a b = {-# UNPACK #-} !a :*: {-# UNPACK #-} !b+data MaybeS a = NothingS | JustS {-# UNPACK #-} !a+infixl 2 :*:++unSP :: PairS a b -> (a,b)+unSP (a :*: b) = (a,b)++-- -----------------------------------------------------------------------------+--+-- Type+--++-- | A String using a compact, strict representation.+-- A @CompactString a@ is encoded using encoding @a@, for example @CompactString 'UTF8'@.+newtype CompactString a = CS { unCS :: ByteString }++-- Invariants used by CompactString:+-- - All characters in the bytestring are complete and valid (see below)+-- - Characters use the shortest possible encoding++-- -----------------------------------------------------------------------------+--+-- Encoding+--++-- From Data.Proxy proposal+data Proxy a++-- | A way to encode characters into bytes+class Encoding a where+ -- | Given a character returns the length of that character,+ -- and a function to write it to a memory buffer.+ -- if the encoding can not represent the character, the io function should @fail@.+ pokeCharFun :: Proxy a -> Char -> (Int, Ptr Word8 -> IO ())+ -- | The size needed to store a character+ pokeCharLen :: Proxy a -> Char -> Int+ pokeCharLen a = fst . pokeCharFun a+ -- | Write a character and return the size used+ pokeChar :: Proxy a -> Ptr Word8 -> Char -> IO Int+ pokeChar enc p c = case pokeCharFun enc c of (l,f) -> f p >> return l+ {-# INLINE pokeChar #-}+ -- | Write a character given a pointer to its last byte, and return the size used+ pokeCharRev :: Proxy a -> Ptr Word8 -> Char -> IO Int+ pokeCharRev enc p c = case pokeCharFun enc c of (l,f) -> f (p `plusPtr` (1-l)) >> return l+ {-# INLINE pokeCharRev #-}+ + -- | Read a character from a memory buffer, return it and its length.+ -- The buffer is guaranteed to contain a valid character.+ peekChar :: Proxy a -> Ptr Word8 -> IO (Int, Char)+ -- | Return the length of the character in a memory buffer+ peekCharLen :: Proxy a -> Ptr Word8 -> IO Int+ -- | Read a character from a memory buffer, return it and its length,+ -- given a pointer to the /last/ byte.+ -- The buffer is guaranteed to contain a valid character.+ peekCharRev :: Proxy a -> Ptr Word8 -> IO (Int, Char)+ -- | Return the length of the character in a memory buffer,+ -- given a pointer to the /last/ byte.+ peekCharLenRev :: Proxy a -> Ptr Word8 -> IO Int+ + -- | Read a character from a memory buffer, return it and its length.+ -- The buffer is not guaranteed to contain a valid character, so that should+ -- be verified. There is also no guarantee that the length of the buffer (also given)+ -- is sufficient to contain a whole character.+ peekCharSafe :: Proxy a -> Int -> Ptr Word8 -> IO (Int, Char)+ -- | Validate the length, should be used before peekCharSafe is called.+ -- Can be used to remove the number of checks used by peekCharSafe.+ validateLength :: Proxy a -> Int -> IO ()+ validateLength _ _ = return ()+ + -- | Copy a character from one buffer to another, return the length of the character+ copyChar :: Proxy a -> Ptr Word8 -> Ptr Word8 -> IO Int+ copyChar enc src dst = do+ (l,c) <- peekChar enc src+ pokeChar enc dst c+ return l+ -- | Copy a character from one buffer to another, where the source pointer+ -- points to the last byte of the character.+ -- return the length of the character.+ copyCharRev :: Proxy a -> Ptr Word8 -> Ptr Word8 -> IO Int+ copyCharRev enc src dst = do+ (l,c) <- peekCharRev enc src+ pokeChar enc dst c+ return l+ + -- | Is ASCII a valid subset of the encoding?+ containsASCII :: Proxy a -> Bool+ -- | Is @(a == b) == (toBS a == toBS b)@?+ validEquality :: Proxy a -> Bool+ validEquality _ = True+ -- | Is @(a `compare` b) == (toBS a `compare` toBS b)@?+ validOrdering :: Proxy a -> Bool+ -- | Is @(a `isSubstringOf` b) == (toBS a `isSubstringOf` toBS b)@?+ validSubstring :: Proxy a -> Bool+ + -- | What is the maximum number of character a string with the given number of bytes contains?+ charCount :: Proxy a -> Int -> Int+ charCount _ n = n+ -- | What is the maximum number of bytes a string with the given number of characters contains?+ byteCount :: Proxy a -> Int -> Int+ -- | What is the maximum size in bytes after transforming (using map) a string?+ newSize :: Proxy a -> Int -> Int+ newSize e = byteCount e . charCount e+ + -----------------------------------------------------------------------------+ --+ -- Fusion+ --+ + doUpLoop :: Proxy a -> AccEFL acc -> acc -> ImperativeLoop acc+ doUpLoop enc f acc0 src dest len = loop 0 0 acc0+ where STRICT3(loop)+ loop src_off dest_off acc+ | src_off >= len = return (acc :*: 0 :*: dest_off)+ | otherwise = do+ (l,x) <- peekChar enc (src `plusPtr` src_off)+ case f acc x of+ (acc' :*: NothingS) -> loop (src_off+l) dest_off acc'+ (acc' :*: JustS x') -> do l' <- pokeChar enc (dest `plusPtr` dest_off) x'+ loop (src_off+l) (dest_off+l') acc'+ + doDownLoop :: Proxy a -> AccEFL acc -> acc -> ImperativeLoop acc+ doDownLoop enc f acc0 src dest len = loop (len-1) (newSize enc len-1) acc0+ where STRICT3(loop)+ loop src_off dest_off acc+ | src_off < 0 = return (acc :*: dest_off + 1 :*: newSize enc len - (dest_off+1))+ | otherwise = do+ (l,x) <- peekCharRev enc (src `plusPtr` src_off)+ case f acc x of+ (acc' :*: NothingS) -> loop (src_off-l) dest_off acc'+ (acc' :*: JustS x') -> do l' <- pokeCharRev enc (dest `plusPtr` dest_off) x'+ loop (src_off-l) (dest_off-l') acc'+ + doUpLoopFold :: Proxy a -> FoldEFL acc -> acc -> ImperativeLoop_ acc+ doUpLoopFold enc f acc0 src len = loop 0 acc0+ where STRICT2(loop)+ loop src_off acc+ | src_off >= len = return acc+ | otherwise = do+ (l,x) <- peekChar enc (src `plusPtr` src_off)+ loop (src_off + l) (f acc x)+ + doDownLoopFold :: Proxy a -> FoldEFL acc -> acc -> ImperativeLoop_ acc+ doDownLoopFold enc f acc0 src len = loop (len-1) acc0+ where STRICT2(loop)+ loop src_off acc+ | src_off < 0 = return acc+ | otherwise = do+ (l,x) <- peekCharRev enc (src `plusPtr` src_off)+ loop (src_off - l) (f acc x)++-- -----------------------------------------------------------------------------+--+-- Fusion types+--++-- |Type of loop functions+type AccEFL acc = acc -> Char -> (PairS acc (MaybeS Char))+type FoldEFL acc = acc -> Char -> acc++-- | An imperative loop transforming a string, using an accumulating parameter.+-- See Data.ByteString.Fusion+type ImperativeLoop acc =+ Ptr Word8 -- pointer to the start of the source byte array+ -> Ptr Word8 -- pointer to ther start of the destination byte array+ -> Int -- length of the source byte array+ -> IO (PairS (PairS acc Int) Int) -- result and offset, length of dest that was filled++-- | ImperativeLoop with no output+type ImperativeLoop_ acc =+ Ptr Word8 -- pointer to the start of the source byte array+ -> Int -- length of the source byte array+ -> IO acc -- result++-- -----------------------------------------------------------------------------+--+-- Utilities : buffer stuff+--++-- | Perform a function given a pointer to the buffer of a CompactString+withBuffer :: CompactString a -> (Ptr Word8 -> IO b) -> IO b+withBuffer (CS (PS x s _)) f = withForeignPtr x $ \p -> f (p `plusPtr` s)+{-# INLINE withBuffer #-}++-- | Perform a function given a pointer to the last byte in the buffer of a CompactString+withBufferEnd :: CompactString a -> (Ptr Word8 -> IO b) -> IO b+withBufferEnd (CS (PS x s l)) f = withForeignPtr x $ \p -> f (p `plusPtr` (s + l - 1))+{-# INLINE withBufferEnd #-}++-- | Perform a function given a pointer to the buffer of a CompactString+unsafeWithBuffer :: CompactString a -> (Ptr Word8 -> IO b) -> b+unsafeWithBuffer cs f = inlinePerformIO $ withBuffer cs f+{-# INLINE unsafeWithBuffer #-}++-- | Perform a function given a pointer to the last byte in the buffer of a CompactString+unsafeWithBufferEnd :: CompactString a -> (Ptr Word8 -> IO b) -> b+unsafeWithBufferEnd cs f = inlinePerformIO $ withBufferEnd cs f+{-# INLINE unsafeWithBufferEnd #-}++create :: Int -> (Ptr Word8 -> IO ()) -> IO (CompactString a)+create len f = liftM CS $ B.create len f+{-# INLINE create #-}++-- -----------------------------------------------------------------------------+--+-- Utilities : characters+--++#if !defined(__GLASGOW_HASKELL__)+unsafeChr = chr+#endif++-- | Safe variant of chr, combined with return; does more checks.+-- At least GHC does not check for surrogate pairs+returnChr :: Int -> Word32 -> IO (Int, Char)+returnChr a c+ | c >= 0xD800 && c <= 0xDFFF = failMessage "decode" "Surrogate character"+ | c > 0x10FFFF = failMessage "decode" "Character out of range"+ | otherwise = return (a, unsafeChr $ fromIntegral c)++-- -----------------------------------------------------------------------------+--+-- Utilities : Type safety/inference+--++-- | plusPtr that preserves the pointer type+plusPtr :: Ptr a -> Int -> Ptr a+plusPtr = Foreign.Ptr.plusPtr++peekByteOff :: Storable a => Ptr a -> Int -> IO a+peekByteOff = Foreign.Storable.peekByteOff++pokeByteOff :: Storable a => Ptr a -> Int -> a -> IO ()+pokeByteOff = Foreign.Storable.pokeByteOff++encoding :: CompactString a -> Proxy a+encoding = undefined++-- -----------------------------------------------------------------------------+--+-- Utilities : Error handling+--+-- Common up near identical calls to `error' to reduce the number+-- constant strings created when compiled:+--++-- | Fail with an error message including the module name and function+failMessage :: String -> String -> IO a+failMessage fun msg = fail ("Data.CompactString." ++ fun ++ ':':' ':msg)+{-# NOINLINE failMessage #-}++-- | Raise an errorr, with the message including the module name and function+moduleError :: String -> String -> a+moduleError fun msg = error ("Data.CompactString." ++ fun ++ ':':' ':msg)+{-# NOINLINE moduleError #-}++errorEmptyList :: String -> a+errorEmptyList fun = moduleError fun "empty CompactString"+{-# NOINLINE errorEmptyList #-}++-- | Catch exceptions from fail in the IO monad, and wrap them in another monad+unsafeTry :: MonadPlus m => IO a -> m a+unsafeTry ioa = unsafePerformIO (unsafeTryIO ioa)++-- | Catch exceptions from fail in the IO monad, and wrap them in another monad+unsafeTryIO :: MonadPlus m => IO a -> IO (m a)+unsafeTryIO ioa = handleJust userErrors (return . fail) (fmap return ioa)++userErrors :: IOError -> Maybe String+userErrors e = if isUserError e then Just (ioeGetErrorString e) else Nothing
+ Data/CompactString/UTF16.hs view
@@ -0,0 +1,7 @@+#define ENCODING UTF16+#define TYPE UTF16Native+#define DESCRIPTION UTF-16+#define LONG_DESCRIPTION platform native UTF-16+#define IF_NOT_REPRESENT(a)+#define IF_FIXED(a,b) b+#include "specialized.include"
+ Data/CompactString/UTF8.hs view
@@ -0,0 +1,7 @@+#define ENCODING UTF8+#define TYPE UTF8+#define DESCRIPTION UTF-8+#define LONG_DESCRIPTION UTF-8+#define IF_NOT_REPRESENT(a)+#define IF_FIXED(a,b) b+#include "specialized.include"
+ Data/CompactString/Unsafe.hs view
@@ -0,0 +1,71 @@+-- |+-- Module : Data.CompactString.Unsafe+-- License : BSD-style+-- Maintainer : twanvl@gmail.com+-- Stability : experimental+-- Portability : untested+-- +-- Unsafe functions on 'CompactString's.+-- All these functions can lead to crashes if not used properly.+--+module Data.CompactString.Unsafe (+ + -- * Basic interface+ unsafeHead, -- :: Encoding a => CompactString a -> Char+ unsafeLast, -- :: Encoding a => CompactString a -> Char+ unsafeTail, -- :: Encoding a => CompactString a -> CompactString+ unsafeInit, -- :: Encoding a => CompactString a -> CompactString+ + -- * Conversion from 'ByteString'+ unsafeFromByteString -- :: ByteString -> CompactString a+ + ) where++import Data.CompactString.Internal++-- -----------------------------------------------------------------------------+--+-- Basic interface+--++-- | A variety of 'head' for non-empty CompactString. 'unsafeHead' omits the+-- check for the empty case, so there is an obligation on the programmer+-- to provide a proof that the CompactString is non-empty.+unsafeHead :: Encoding a => CompactString a -> Char+unsafeHead cs = snd $ unsafeWithBuffer cs $ peekChar (encoding cs)+{-# INLINE unsafeHead #-}++-- | A variety of 'tail' for non-empty CompactString. 'unsafeTail' omits the+-- check for the empty case, so there is an obligation on the programmer+-- to provide a proof that the CompactString is non-empty.+unsafeTail :: Encoding a => CompactString a -> CompactString a+unsafeTail cs@(CS (PS x s l))+ = let headlen = unsafeWithBuffer cs $ peekCharLen (encoding cs)+ in CS (PS x (s+headlen) (l-headlen))+{-# INLINE unsafeTail #-}++-- | A variety of 'last' for non-empty CompactString. 'unsafeLast' omits the+-- check for the empty case, so there is an obligation on the programmer+-- to provide a proof that the CompactString is non-empty.+unsafeLast :: Encoding a => CompactString a -> Char+unsafeLast cs = snd $ unsafeWithBufferEnd cs $ peekCharRev (encoding cs)+{-# INLINE unsafeLast #-}++-- | A variety of 'init' for non-empty CompactString. 'unsafeInit' omits the+-- check for the empty case, so there is an obligation on the programmer+-- to provide a proof that the CompactString is non-empty.+unsafeInit :: Encoding a => CompactString a -> CompactString a+unsafeInit cs@(CS (PS x s l))+ = let lastlen = unsafeWithBufferEnd cs $ peekCharLenRev (encoding cs)+ in CS (PS x s (l-lastlen))+{-# INLINE unsafeInit #-}++-- -----------------------------------------------------------------------------+--+-- Conversion+--++-- | Convert a ByteString to a CompactString,+-- does not check whether the ByteString represents a valid string in the encoding a.+unsafeFromByteString :: ByteString -> CompactString a+unsafeFromByteString = CS
+ Data/CompactString/signatures.include view
@@ -0,0 +1,746 @@++-- Type signatures & Haddock comment+-- these are used by both the normal Data.CompactString+-- and the versions specialized to a specific encoding+-- +-- Requires:+-- #define COMPACTSTRING+-- #define CONTEXT++-- -----------------------------------------------------------------------------+--+-- Construction+--++-- | /O(1)/ The empty 'CompactString'+empty :: COMPACTSTRING++-- | /O(1)/ Convert a 'Char' into a 'CompactString'+singleton :: CONTEXT Char -> COMPACTSTRING++-- | /O(n)/ Convert a 'String' into a 'CompactString'.+pack :: CONTEXT String -> COMPACTSTRING++-- | /O(n)/ Converts a 'CompactString' to a 'String'.+unpack :: CONTEXT COMPACTSTRING -> String++-- -----------------------------------------------------------------------------+--+-- Basic interface+--++-- | /O(n)/ 'cons' is analogous to (:) for lists, but of different+-- complexity, as it requires a memcpy.+cons :: CONTEXT Char -> COMPACTSTRING -> COMPACTSTRING++-- | /O(n)/ Append a byte to the end of a 'CompactString'+snoc :: CONTEXT COMPACTSTRING -> Char -> COMPACTSTRING++-- | /O(1)/ Extract the first element of a CompactString, which must be non-empty.+-- An exception will be thrown in the case of an empty CompactString.+head :: CONTEXT COMPACTSTRING -> Char++-- | /O(1)/ Extract the elements after the head of a CompactString, which must be non-empty.+-- An exception will be thrown in the case of an empty CompactString.+tail :: CONTEXT COMPACTSTRING -> COMPACTSTRING++-- | /O(1)/ Extract the last element of a ByteString, which must be finite and non-empty.+-- An exception will be thrown in the case of an empty ByteString.+last :: CONTEXT COMPACTSTRING -> Char++-- | /O(1)/ Return all the elements of a 'CompactString' except the last one.+-- An exception will be thrown in the case of an empty ByteString.+init :: CONTEXT COMPACTSTRING -> COMPACTSTRING++-- | /O(1)/ A view of the front of a 'CompactString'.+--+-- > headView s = if null s then Nothing else Just (head s, tail s)+headView :: CONTEXT COMPACTSTRING -> Maybe (Char, COMPACTSTRING)++-- | /O(1)/ A view of the back of a 'CompactString'.+--+-- > lastView s = if null s then Nothing else Just (init s, last s)+lastView :: CONTEXT COMPACTSTRING -> Maybe (COMPACTSTRING, Char)++-- | /O(n)/ Append two CompactStrings+append :: CONTEXT COMPACTSTRING -> COMPACTSTRING -> COMPACTSTRING++-- | /O(1)/ Test whether a CompactString is empty.+null :: CONTEXT COMPACTSTRING -> Bool++-- | /O(n)/ 'length' returns the length of a CompactString as an 'Int'.+length :: CONTEXT COMPACTSTRING -> Int+++-- -----------------------------------------------------------------------------+--+-- Transforming 'CompactString's+--++-- | /O(n)/ 'map' @f xs@ is the CompactString obtained by applying @f@ to each+-- element of @xs@. This function is subject to array fusion.+map :: CONTEXT (Char -> Char) -> COMPACTSTRING -> COMPACTSTRING++-- | Reverse a 'CompactString'+reverse :: CONTEXT COMPACTSTRING -> COMPACTSTRING++-- | /O(n)/ The 'intersperse' function takes a 'Char' and a+-- 'CompactString' and \`intersperses\' that character between the elements of+-- the 'CompactString'. It is analogous to the intersperse function on+-- Lists.+intersperse :: CONTEXT Char -> COMPACTSTRING -> COMPACTSTRING++-- | /O(n)/ The 'intercalate' function takes a 'CompactString' and a list of+-- 'CompactString's and concatenates the list after interspersing the first+-- argument between each element of the list.+intercalate :: CONTEXT COMPACTSTRING -> [COMPACTSTRING] -> COMPACTSTRING++-- | The 'transpose' function transposes the rows and columns of its+-- 'CompactString' argument.+transpose :: CONTEXT [COMPACTSTRING] -> [COMPACTSTRING]+ +-- -----------------------------------------------------------------------------+--+-- Reducing 'CompactString's (folds)+--++-- | 'foldl', applied to a binary operator, a starting value (typically+-- the left-identity of the operator), and a CompactString, reduces the+-- CompactString using the binary operator, from left to right.+-- This function is subject to array fusion.+foldl :: CONTEXT (acc -> Char -> acc) -> acc -> COMPACTSTRING -> acc++-- | 'foldl\'' is like 'foldl', but strict in the accumulator.+-- Though actually foldl is also strict in the accumulator.+foldl'+ :: CONTEXT (acc -> Char -> acc) -> acc -> COMPACTSTRING -> acc++-- | 'foldr', applied to a binary operator, a starting value+-- (typically the right-identity of the operator), and a CompactString,+-- reduces the CompactString using the binary operator, from right to left.+foldr :: CONTEXT (Char -> acc -> acc) -> acc -> COMPACTSTRING -> acc++-- | 'foldr', applied to a binary operator, a starting value+-- (typically the right-identity of the operator), and a CompactString,+-- reduces the CompactString using the binary operator, from right to left.+foldr'+ :: CONTEXT (Char -> acc -> acc) -> acc -> COMPACTSTRING -> acc++-- | 'foldl1' is a variant of 'foldl' that has no starting value+-- argument, and thus must be applied to non-empty 'CompactString'.+-- This function is subject to array fusion. +-- An exception will be thrown in the case of an empty CompactString.+foldl1 :: CONTEXT (Char -> Char -> Char) -> COMPACTSTRING -> Char++-- | 'foldl1\'' is like 'foldl1', but strict in the accumulator.+-- An exception will be thrown in the case of an empty CompactString.+foldl1'+ :: CONTEXT (Char -> Char -> Char) -> COMPACTSTRING -> Char++-- | 'foldr1' is a variant of 'foldr' that has no starting value argument,+-- and thus must be applied to non-empty 'CompactString's+-- An exception will be thrown in the case of an empty CompactString.+foldr1 :: CONTEXT (Char -> Char -> Char) -> COMPACTSTRING -> Char++-- | 'foldr1\'' is a variant of 'foldr1', but is strict in the+-- accumulator.+-- An exception will be thrown in the case of an empty CompactString.+foldr1'+ :: CONTEXT (Char -> Char -> Char) -> COMPACTSTRING -> Char++-- -----------------------------------------------------------------------------+--+-- Special folds+--++-- | /O(n)/ Concatenate a list of 'CompactString's.+concat :: CONTEXT [COMPACTSTRING] -> COMPACTSTRING++-- | Map a function over a 'CompactString' and concatenate the results+concatMap :: CONTEXT (Char -> COMPACTSTRING) -> COMPACTSTRING -> COMPACTSTRING++-- | /O(n)/ Applied to a predicate and a CompactString, 'any' determines if+-- any element of the 'CompactString' satisfies the predicate.+any :: CONTEXT (Char -> Bool) -> COMPACTSTRING -> Bool+-- | /O(n)/ Applied to a predicate and a CompactString, 'any' determines if+-- all elements of the 'CompactString' satisfy the predicate.+all :: CONTEXT (Char -> Bool) -> COMPACTSTRING -> Bool++-- | /O(n)/ 'maximum' returns the maximum value from a 'CompactString'+-- An exception will be thrown in the case of an empty CompactString.+maximum :: CONTEXT COMPACTSTRING -> Char+-- | /O(n)/ 'minimum' returns the minimum value from a 'CompactString'+-- An exception will be thrown in the case of an empty CompactString.+minimum :: CONTEXT COMPACTSTRING -> Char++-- -----------------------------------------------------------------------------+--+-- Building CompactStrings : Scans+--++-- | 'scanl' is similar to 'foldl', but returns a list of successive+-- reduced values from the left. This function will fuse.+--+-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]+--+-- Note that+--+-- > last (scanl f z xs) == foldl f z xs.+scanl :: CONTEXT (Char -> Char -> Char) -> Char -> COMPACTSTRING -> COMPACTSTRING++-- | 'scanl1' is a variant of 'scanl' that has no starting value argument.+-- This function will fuse.+--+-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]+scanl1 :: CONTEXT (Char -> Char -> Char) -> COMPACTSTRING -> COMPACTSTRING++-- | scanr is the right-to-left dual of scanl.+scanr :: CONTEXT (Char -> Char -> Char) -> Char -> COMPACTSTRING -> COMPACTSTRING++-- | 'scanr1' is a variant of 'scanr' that has no starting value argument.+scanr1 :: CONTEXT (Char -> Char -> Char) -> COMPACTSTRING -> COMPACTSTRING++-- -----------------------------------------------------------------------------+--+-- Building CompactStrings : Accumulating maps+--++-- | The 'mapAccumL' function behaves like a combination of 'map' and+-- 'foldl'; it applies a function to each element of a CompactString,+-- passing an accumulating parameter from left to right, and returning a+-- final value of this accumulator together with the new CompactString.+mapAccumL :: CONTEXT (acc -> Char -> (acc, Char)) -> acc -> COMPACTSTRING -> (acc, COMPACTSTRING)++-- | The 'mapAccumR' function behaves like a combination of 'map' and+-- 'foldr'; it applies a function to each element of a CompactString,+-- passing an accumulating parameter from right to left, and returning a+-- final value of this accumulator together with the new CompactString.+mapAccumR :: CONTEXT (acc -> Char -> (acc, Char)) -> acc -> COMPACTSTRING -> (acc, COMPACTSTRING)++-- | /O(n)/ map Char functions, provided with the index at each position.+mapIndexed :: CONTEXT (Int -> Char -> Char) -> COMPACTSTRING -> COMPACTSTRING++-- -----------------------------------------------------------------------------+--+-- Building CompactStrings : Unfolding CompactStrings+--++-- | /O(n)/ 'replicate' @n x@ is a CompactString of length @n@ with @x@+-- the value of every element. The following holds:+--+-- > replicate w c = unfoldr w (\u -> Just (u,u)) c+replicate :: CONTEXT Int -> Char -> COMPACTSTRING++-- | /O(n)/, where /n/ is the length of the result. The 'unfoldr' +-- function is analogous to the List \'unfoldr\'. 'unfoldr' builds a +-- ByteString from a seed value. The function takes the element and +-- returns 'Nothing' if it is done producing the CompactString or returns +-- 'Just' @(a,b)@, in which case, @a@ is the next byte in the string, +-- and @b@ is the seed value for further production.+--+-- Examples:+--+-- > unfoldr (\x -> if x <= 5 then Just (x, x + 1) else Nothing) 0+-- > == pack [0, 1, 2, 3, 4, 5]+--+unfoldr :: CONTEXT (acc -> Maybe (Char, acc)) -> acc -> COMPACTSTRING++-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a ByteString from a seed+-- value. However, the length of the result is limited by the first+-- argument to 'unfoldrN'. This function is more efficient than 'unfoldr'+-- when the maximum length of the result is known.+--+-- The following equation relates 'unfoldrN' and 'unfoldr':+--+-- > fst (unfoldrN n f s) == take n (unfoldr f s)+--+unfoldrN :: CONTEXT Int -> (acc -> Maybe (Char, acc)) -> acc -> (COMPACTSTRING, Maybe acc)++-- -----------------------------------------------------------------------------+--+-- Substrings : Breaking strings+--++-- | /O(n)/ 'take' @n@, applied to a CompactString @xs@, returns the prefix+-- of @xs@ of length @n@, or @xs@ itself if @n > 'length' xs@.+take :: CONTEXT Int -> COMPACTSTRING -> COMPACTSTRING++-- | /O(n)/ 'drop' @n xs@ returns the suffix of @xs@ after the first @n@+-- elements, or @empty@ if @n > 'length' xs@.+drop :: CONTEXT Int -> COMPACTSTRING -> COMPACTSTRING++-- | /O(n)/ 'splitAt' @n xs@ is equivalent to @('take' n xs, 'drop' n xs)@.+splitAt :: CONTEXT Int -> COMPACTSTRING -> (COMPACTSTRING, COMPACTSTRING)++-- | 'takeWhile', applied to a predicate @p@ and a CompactString @xs@,+-- returns the longest prefix (possibly empty) of @xs@ of elements that+-- satisfy @p@.+takeWhile :: CONTEXT (Char -> Bool) -> COMPACTSTRING -> COMPACTSTRING++-- | 'dropWhile' @p xs@ returns the suffix remaining after 'takeWhile' @p xs@.+dropWhile :: CONTEXT (Char -> Bool) -> COMPACTSTRING -> COMPACTSTRING++-- | 'break' @p@ is equivalent to @'span' ('not' . p)@.+break :: CONTEXT (Char -> Bool) -> COMPACTSTRING -> (COMPACTSTRING, COMPACTSTRING)++-- | 'span' @p xs@ breaks the ByteString into two segments. It is+-- equivalent to @('takeWhile' p xs, 'dropWhile' p xs)@+span :: CONTEXT (Char -> Bool) -> COMPACTSTRING -> (COMPACTSTRING, COMPACTSTRING)++-- | 'breakEnd' behaves like 'break' but from the end of the 'CompactString'+-- +-- > breakEnd p == spanEnd (not.p)+breakEnd :: CONTEXT (Char -> Bool) -> COMPACTSTRING -> (COMPACTSTRING, COMPACTSTRING)++-- | 'spanEnd' behaves like 'span' but from the end of the 'CompactString'+-- +-- We have+--+-- > spanEnd (not.isSpace) "x y z" == ("x y ","z")+--+-- and+--+-- > spanEnd (not . isSpace) cs+-- > == +-- > let (x,y) = span (not.isSpace) (reverse cs) in (reverse y, reverse x)+--+spanEnd :: CONTEXT (Char -> Bool) -> COMPACTSTRING -> (COMPACTSTRING, COMPACTSTRING)+++-- | The 'group' function takes a 'CompactString' and returns a list of+-- CompactStrings such that the concatenation of the result is equal to the+-- argument. Moreover, each sublist in the result contains only equal+-- elements. For example,+--+-- > group "Mississippi" = ["M","i","ss","i","ss","i","pp","i"]+--+-- It is a special case of 'groupBy', which allows the programmer to+-- supply their own equality test.+group :: CONTEXT COMPACTSTRING -> [COMPACTSTRING]++-- | The 'groupBy' function is the non-overloaded version of 'group'.+groupBy :: CONTEXT (Char -> Char -> Bool) -> COMPACTSTRING -> [COMPACTSTRING]++-- | /O(n)/ Return all initial segments of the given 'CompactString', shortest first.+inits :: CONTEXT COMPACTSTRING -> [COMPACTSTRING]++-- | /O(n)/ Return all final segments of the given 'CompactString', longest first.+tails :: CONTEXT COMPACTSTRING -> [COMPACTSTRING]++-- -----------------------------------------------------------------------------+--+-- Substrings : Breaking into many substrings+--++-- | /O(n)/ Splits a 'CompactString' into components delimited by+-- separators, where the predicate returns True for a separator element.+-- The resulting components do not contain the separators. Two adjacent+-- separators result in an empty component in the output. eg.+--+-- > splitWith (=='a') "aabbaca" == ["","","bb","c",""]+-- > splitWith (=='a') [] == []+--+splitWith :: CONTEXT (Char -> Bool) -> COMPACTSTRING -> [COMPACTSTRING]++-- | /O(n)/ Break a 'ByteString' into pieces separated by the byte+-- argument, consuming the delimiter. I.e.+--+-- > split '\n' "a\nb\nd\ne" == ["a","b","d","e"]+-- > split 'a' "aXaXaXa" == ["","X","X","X",""]+-- > split 'x' "x" == ["",""]+-- +-- and+--+-- > intercalate [c] . split c == id+-- > split == splitWith . (==)+-- +-- As for all splitting functions in this library, this function does+-- not copy the substrings, it just constructs new 'CompactString' that+-- are slices of the original.+--+split :: CONTEXT Char -> COMPACTSTRING -> [COMPACTSTRING]++-- -----------------------------------------------------------------------------+--+-- Substrings : Breaking into lines and words+--++-- | 'lines' breaks a 'CompactString' up into a list of CompactStrings at+-- newline Chars. The resulting strings do not contain newlines.+lines :: CONTEXT COMPACTSTRING -> [COMPACTSTRING]++-- | 'unlines' is an inverse operation to 'lines'. It joins lines,+-- after appending a terminating newline to each.+unlines :: CONTEXT [COMPACTSTRING] -> COMPACTSTRING++-- | 'words' breaks a ByteString up into a list of words, which+-- were delimited by Chars representing white space. And+--+-- > words = filter (not . null) . splitWith isSpace+--+words :: CONTEXT COMPACTSTRING -> [COMPACTSTRING]++-- | The 'unwords' function is analogous to the 'unlines' function, on words.+unwords :: CONTEXT [COMPACTSTRING] -> COMPACTSTRING++-- -----------------------------------------------------------------------------+--+-- Predicates+--++-- | /O(n)/ The 'isPrefixOf' function takes two CompactString and returns 'True'+-- iff the first is a prefix of the second.+isPrefixOf :: COMPACTSTRING -> COMPACTSTRING -> Bool++-- | /O(n)/ The 'isSuffixOf' function takes two CompactString and returns 'True'+-- iff the first is a suffix of the second.+--+-- The following holds:+--+-- > isSuffixOf x y == reverse x `isPrefixOf` reverse y+--+isSuffixOf :: CONTEXT COMPACTSTRING -> COMPACTSTRING -> Bool++-- -----------------------------------------------------------------------------+--+-- Predicates : Search for arbitrary substrings+--++-- | Check whether one string is a substring of another. @isInfixOf+-- p s@ is equivalent to @not (null (findSubstrings p s))@.+isInfixOf :: CONTEXT COMPACTSTRING -- ^ String to search for.+ -> COMPACTSTRING -- ^ String to search in.+ -> Bool++-- | Get the first index of a substring in another string,+-- or 'Nothing' if the string is not found.+-- @findSubstring p s@ is equivalent to @listToMaybe (findSubstrings p s)@.+findSubstring :: CONTEXT COMPACTSTRING -- ^ String to search for.+ -> COMPACTSTRING -- ^ String to seach in.+ -> Maybe Int++-- | Find the indexes of all (possibly overlapping) occurances of a+-- substring in a string. This function uses the Knuth-Morris-Pratt+-- string matching algorithm.+findSubstrings :: CONTEXT COMPACTSTRING -- ^ String to search for.+ -> COMPACTSTRING -- ^ String to seach in.+ -> [Int]++-- -----------------------------------------------------------------------------+--+-- Searching by equality+--++-- | /O(n)/ 'elem' is the 'CompactString' membership predicate.+elem :: CONTEXT Char -> COMPACTSTRING -> Bool++-- | /O(n)/ 'notElem' is the inverse of 'elem'+notElem :: CONTEXT Char -> COMPACTSTRING -> Bool++-- -----------------------------------------------------------------------------+--+-- Searching with a predicate+--++-- | /O(n)/ The 'find' function takes a predicate and a 'CompactString',+-- and returns the first element in matching the predicate, or 'Nothing'+-- if there is no such element.+--+-- > find f p = case findIndex f p of Just n -> Just (p `index` n) ; _ -> Nothing+--+find :: CONTEXT (Char -> Bool) -> COMPACTSTRING -> Maybe Char++-- | /O(n)/ 'filter', applied to a predicate and a 'CompactString',+-- returns a CompactString containing those characters that satisfy the+-- predicate. This function is subject to array fusion.+filter :: CONTEXT (Char -> Bool) -> COMPACTSTRING -> COMPACTSTRING++-- | /O(n)/ 'partition', applied to a predicate and a 'CompactString',+-- returns a pair of CompactStrings.+-- The first containing those characters that satisfy the predicate,+-- the second containg those that don't.+partition :: CONTEXT (Char -> Bool) -> COMPACTSTRING -> (COMPACTSTRING, COMPACTSTRING)++-- -----------------------------------------------------------------------------+--+-- Indexing CompactStrings+--++-- | /O(IF_FIXED(1,n))/ 'CompactString' index (subscript) operator, starting from 0.+index :: CONTEXT COMPACTSTRING -> Int -> Char++-- | /O(n)/ The 'elemIndex' function returns the index of the first+-- element in the given 'ByteString' which is equal to the query+-- element, or 'Nothing' if there is no such element. +elemIndex :: CONTEXT Char -> COMPACTSTRING -> Maybe Int++-- | /O(n)/ The 'elemIndexEnd' function returns the last index of the+-- element in the given 'CompactString' which is equal to the query+-- element, or 'Nothing' if there is no such element. The following+-- holds:+--+-- > elemIndexEnd c xs == +-- > (-) (length xs - 1) `fmap` elemIndex c (reverse xs)+--+elemIndexEnd :: CONTEXT Char -> COMPACTSTRING -> Maybe Int++-- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by returning+-- the indices of all elements equal to the query element, in ascending order.+elemIndices :: CONTEXT Char -> COMPACTSTRING -> [Int]++-- | The 'findIndex' function takes a predicate and a 'CompactString' and+-- returns the index of the first element in the CompactString+-- satisfying the predicate.+findIndex :: CONTEXT (Char -> Bool) -> COMPACTSTRING -> Maybe Int++-- | /O(n)/ The 'findIndexEnd' function returns the last index of the+-- element in the given 'CompactString' which satisfies the predicate,+-- or 'Nothing' if there is no such element. The following holds:+--+-- > findIndexEnd c xs == +-- > (-) (length xs - 1) `fmap` findIndex c (reverse xs)+--+findIndexEnd :: CONTEXT (Char -> Bool) -> COMPACTSTRING -> Maybe Int++-- | The 'findIndices' function extends 'findIndex', by returning the+-- indices of all elements satisfying the predicate, in ascending order.+findIndices :: CONTEXT (Char -> Bool) -> COMPACTSTRING -> [Int]++-- | count returns the number of times its argument appears in the 'CompactString'+--+-- > count c = length . elemIndices c+count :: CONTEXT Char -> COMPACTSTRING -> Int++-- -----------------------------------------------------------------------------+--+-- Zipping and unzipping CompactStrings+--++-- | /O(n)/ 'zip' takes two ByteStrings and returns a list of+-- corresponding pairs of bytes. If one input ByteString is short,+-- excess elements of the longer ByteString are discarded. This is+-- equivalent to a pair of 'unpack' operations.+zip :: CONTEXT COMPACTSTRING -> COMPACTSTRING -> [(Char,Char)]++-- | '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 ByteStrings to produce the list of+-- corresponding sums. +zipWith :: CONTEXT (Char -> Char -> b) -> COMPACTSTRING -> COMPACTSTRING -> [b]++--+-- | A specialised version of 'zipWith' for the common case of a+-- simultaneous map over two 'CompactString's, to build a 3rd. Rewrite rules+-- are used to automatically covert zipWith into zipWith' when a pack is+-- performed on the result of zipWith, but we also export it for+-- convenience.+--+zipWith'+ :: CONTEXT (Char -> Char -> Char) -> COMPACTSTRING -> COMPACTSTRING -> COMPACTSTRING++-- | /O(n)/ 'unzip' transforms a list of pairs of bytes into a pair of+-- CompactStrings. Note that this performs two 'pack' operations.+unzip :: CONTEXT [(Char,Char)] -> (COMPACTSTRING,COMPACTSTRING)++-- -----------------------------------------------------------------------------+--+-- Ordered CompactStrings+--++-- | /O(n log n)/ Sort a CompactString+sort :: CONTEXT COMPACTSTRING -> COMPACTSTRING++-- -----------------------------------------------------------------------------+--+-- Encoding+--++-- | Convert a CompactString to a ByteString+toByteString :: CONTEXT COMPACTSTRING -> ByteString++-- | Convert a ByteString to a CompactString.+-- Fails if the ByteString is not a valid encoded string.+fromByteString :: (CONTEXT_ MonadPlus m) => ByteString -> m (COMPACTSTRING)+-- | Convert a ByteString to a CompactString.+-- Raises an error if the ByteString is not a valid encoded string.+fromByteString_ :: CONTEXT ByteString -> COMPACTSTRING++-- | Validates a CompactString.+-- If the string is invalid, fails, otherwise returns the input.+validate :: (CONTEXT_ MonadPlus m) => COMPACTSTRING -> m (COMPACTSTRING)+-- | Validates a CompactString.+-- If the string is invalid, throws an error, otherwise returns the input.+validate_ :: CONTEXT COMPACTSTRING -> COMPACTSTRING++-- | Encode a CompactString to a ByteString using the given encoding.+--+-- > encode e = liftM toByteString . recode+--+-- But it might be faster for some combinations of encodings.+--+-- Fails if the string is cannot be encoded in the target encoding.+encode :: (CONTEXT_ Encoding e, MonadPlus m) => e -> COMPACTSTRING -> m ByteString+-- | Encode a CompactString to a ByteString using the given encoding.+--+-- > encode_ e = toByteString . recode+--+-- But it might be faster for some combinations of encodings.+--+-- Raises an error if the string is cannot be encoded in the target encoding.+encode_ :: (CONTEXT_ Encoding e) => e -> COMPACTSTRING -> ByteString++-- | Decode a ByteString to a CompactString using the given encoding.+--+-- > decode e = recode =<< fromByteString+--+-- but it might be faster for some combinations of encodings.+--+-- Fails if the ByteString is not a valid encoded string+-- IF_NOT_REPRESENT(or if the string can not be represented in DESCRIPTION.)+decode :: (CONTEXT_ Encoding e, MonadPlus m) => e -> ByteString -> m (COMPACTSTRING)+-- | Decode a ByteString to a CompactString using the given encoding.+--+-- > decode_ e = recode_ . fromByteString_+--+-- but it might be faster for some combinations of encodings.+--+-- Raises an error if the ByteString is not a valid encoded string+-- IF_NOT_REPRESENT(or if the string can not be represented in DESCRIPTION.)+decode_ :: (CONTEXT_ Encoding e) => e -> ByteString -> COMPACTSTRING++-- | Encode a 'CompactString' using the given encoding, and add a Byte Order Mark.+-- Byte Order Marks are common on Windows, but not on other platforms.+--+-- Fails if the string is cannot be encoded in the target encoding.+encodeBOM :: (CONTEXT_ Encoding e, MonadPlus m) => e -> COMPACTSTRING -> m ByteString+-- | Encode a 'CompactString' using the given encoding, and add a Byte Order Mark.+-- Byte Order Marks are common on Windows, but not on other platforms.+--+-- Raises an error if the string is cannot be encoded in the target encoding.+encodeBOM_ :: (CONTEXT_ Encoding e) => e -> COMPACTSTRING -> ByteString++-- | Decode a 'ByteString' into a 'CompactString', by investigating the Byte Order Mark.+-- If there is no BOM assumes UTF-8.+-- Fails if the input is not a valid encoded string+-- IF_NOT_REPRESENT(or if the string can not be represented in DESCRIPTION.)+-- +-- For portability, this function should be prefered over @decode UTF8@ when reading files.+decodeBOM :: (CONTEXT_ MonadPlus m) => ByteString -> m (COMPACTSTRING)+-- | Decode a 'ByteString' into a 'CompactString', by investigating the Byte Order Mark.+-- If there is no BOM assumes UTF-8.+-- Raises an error if the input is not a valid encoded string+-- IF_NOT_REPRESENT(or if the string can not be represented in DESCRIPTION.)+-- +-- For portability, this function should be prefered over @decode UTF8@ when reading files.+decodeBOM_ :: CONTEXT ByteString -> COMPACTSTRING++-- -----------------------------------------------------------------------------+--+-- Standard input and output+--++-- | Read a line from stdin.+getLine :: CONTEXT IO (COMPACTSTRING)++-- | getContents. Equivalent to @hGetContents stdin@+--+-- Input is assumed to be in DESCRIPTION, this may not be appropriate.+getContents :: CONTEXT IO (COMPACTSTRING)++-- | Write a 'CompactString' to stdout.+--+-- Output is written in DESCRIPTION, this may not be appropriate.+putStr :: CONTEXT COMPACTSTRING -> IO ()++-- | Write a 'CompactString' to stdout, appending a newline character.+--+-- Output is written in DESCRIPTION, this may not be appropriate.+putStrLn :: CONTEXT COMPACTSTRING -> IO ()++-- | The interact function takes a function of type @CompactString -> CompactString@+-- as its argument. The entire input from the standard input device is passed+-- to this function as its argument, and the resulting string is output on the+-- standard output device. It's great for writing one line programs!+interact :: CONTEXT (COMPACTSTRING -> COMPACTSTRING) -> IO ()++-- -----------------------------------------------------------------------------+--+-- Files+--++-- | Read an entire file strictly into a 'CompactString'. This is far more+-- efficient than reading the characters into a 'String' and then using+-- 'pack'. Files are read using 'text mode' on Windows.+--+-- Files are assumed to be in DESCRIPTION.+readFile :: CONTEXT FilePath -> IO (COMPACTSTRING)+-- | Read an entire file strictly into a 'CompactString'. This is far more+-- efficient than reading the characters into a 'String' and then using+-- 'pack'. Files are read using 'text mode' on Windows.+--+-- The encoding of the file is determined based on a Byte Order Mark, see 'decodeBOM'.+readFile'+ :: CONTEXT FilePath -> IO (COMPACTSTRING)++-- | Write a 'CompactString' to a file.+--+-- Files are written using DESCRIPTION.+writeFile :: CONTEXT FilePath -> COMPACTSTRING -> IO ()+-- | Write a 'CompactString' to a file.+--+-- Files are written using DESCRIPTION.+-- A Byte Order Mark is also written.+writeFile'+ :: CONTEXT FilePath -> COMPACTSTRING -> IO ()++-- | Append a 'CompactString' to a file.+--+-- Files are written using DESCRIPTION.+appendFile :: CONTEXT FilePath -> COMPACTSTRING -> IO ()+-- | Append a 'CompactString' to a file.+--+-- The encoding of the file is determined based on a Byte Order Mark.+-- If the file is empty, it is written using DESCRIPTION with a Byte Order Mark.+-- If the encoding can not be determined the file is assumed to be UTF-8.+appendFile'+ :: CONTEXT FilePath -> COMPACTSTRING -> IO ()++-- -----------------------------------------------------------------------------+--+-- I\/O with Handles+--++-- | Read a line from a handle+hGetLine :: CONTEXT Handle -> IO (COMPACTSTRING)++-- | Read entire handle contents into a 'CompactString'.+--+-- The handle is interpreted as DESCRIPTION.+hGetContents :: CONTEXT Handle -> IO (COMPACTSTRING)+-- | Read entire handle contents into a 'CompactString'.+--+-- The encoding is determined based on a Byte Order Mark, see 'decodeBOM'.+hGetContents'+ :: CONTEXT Handle -> IO (COMPACTSTRING)++-- | Read a 'CompactString' directly from the specified 'Handle'.+--+-- The handle is interpreted as DESCRIPTION.+hGet :: CONTEXT Handle -> Int -> IO (COMPACTSTRING)+-- | hGetNonBlocking is identical to 'hGet', except that it will never block+-- waiting for data to become available, instead it returns only whatever data+-- is available.+--+-- The handle is interpreted as DESCRIPTION.+hGetNonBlocking :: CONTEXT Handle -> Int -> IO (COMPACTSTRING)++-- | Outputs a 'CompactString' to the specified 'Handle'.+--+-- Output is written in DESCRIPTION.+hPut :: CONTEXT Handle -> COMPACTSTRING -> IO ()+-- | A synonym for @hPut@, for compatibility +hPutStr :: CONTEXT Handle -> COMPACTSTRING -> IO ()+-- | Write a 'CompactString' to a handle, appending a newline byte+--+-- Output is written in DESCRIPTION.+hPutStrLn :: CONTEXT Handle -> COMPACTSTRING -> IO ()
+ Data/CompactString/specialized.include view
@@ -0,0 +1,371 @@+-- |+-- Module : Data.CompactString.Unsafe+-- License : BSD-style+-- Maintainer : twanvl@gmail.com+-- Stability : experimental+-- Portability : untested+-- +-- CompactString specialized to LONG_DESCRIPTION.+--+-- This module can be used to reduce the need for type signatures,+-- since in most cases only a single encoding is used.+--+module Data.CompactString.ENCODING (+ + -- * The CompactString type+ CompactString, -- abstract instances: Eq Ord Show Monoid+ + -- * Introducing and eliminating CompactStrings+ empty, -- :: CompactString+ singleton, -- :: Char -> CompactString+ pack, -- :: String -> CompactString+ unpack, -- :: CompactString -> String+ + -- * Basic interface+ cons, -- :: Char -> CompactString -> CompactString+ snoc, -- :: CompactString -> Char -> CompactString+ append, -- :: CompactString -> CompactString -> CompactString+ head, -- :: CompactString -> Char+ last, -- :: CompactString -> Char+ tail, -- :: CompactString -> CompactString+ init, -- :: CompactString -> CompactString+ headView, -- :: CompactString -> Maybe (Char, CompactString)+ lastView, -- :: CompactString -> Maybe (CompactString, Char)+ null, -- :: CompactString -> Bool+ length, -- :: CompactString -> Int+ + -- * Transforming CompactStrings+ map, -- :: (Char -> Char) -> CompactString -> CompactString+ reverse, -- :: CompactString -> CompactString+ intersperse, -- :: Char -> CompactString -> CompactString+ intercalate, -- :: CompactString -> [CompactString] -> CompactString+ transpose, -- :: [CompactString] -> [CompactString]+ + -- * Reducing CompactStrings (folds)+ foldl, -- :: (a -> Char -> a) -> a -> CompactString -> a+ foldl', -- :: (a -> Char -> a) -> a -> CompactString -> a+ foldl1, -- :: (Char -> Char -> Char) -> CompactString -> Char+ foldl1', -- :: (Char -> Char -> Char) -> CompactString -> Char+ + foldr, -- :: (Char -> a -> a) -> a -> CompactString -> a+ foldr', -- :: (Char -> a -> a) -> a -> CompactString -> a+ foldr1, -- :: (Char -> Char -> Char) -> CompactString -> Char+ foldr1', -- :: (Char -> Char -> Char) -> CompactString -> Char+ + -- ** Special folds+ concat, -- :: [CompactString] -> CompactString+ concatMap, -- :: (Char -> CompactString) -> CompactString -> CompactString+ any, -- :: (Char -> Bool) -> CompactString -> Bool+ all, -- :: (Char -> Bool) -> CompactString -> Bool+ maximum, -- :: CompactString -> Char+ minimum, -- :: CompactString -> Char+ + -- * Building CompactStrings+ -- ** Scans+ scanl, -- :: (Char -> Char -> Char) -> Char -> CompactString -> CompactString+ scanl1, -- :: (Char -> Char -> Char) -> CompactString -> CompactString+ scanr, -- :: (Char -> Char -> Char) -> Char -> CompactString -> CompactString+ scanr1, -- :: (Char -> Char -> Char) -> CompactString -> CompactString+ + -- ** Accumulating maps+ mapAccumL, -- :: (acc -> Char -> (acc, Char)) -> acc -> CompactString -> (acc, CompactString)+ mapAccumR, -- :: (acc -> Char -> (acc, Char)) -> acc -> CompactString -> (acc, CompactString)+ mapIndexed, -- :: (Int -> Char -> Char) -> CompactString -> CompactString+ + -- ** Unfolding CompactStrings+ replicate, -- :: Int -> Char -> CompactString+ unfoldr, -- :: (a -> Maybe (Char, a)) -> a -> CompactString+ unfoldrN, -- :: Int -> (a -> Maybe (Char, a)) -> a -> (CompactString, Maybe a)+ + -- * Substrings+ + -- ** Breaking strings+ take, -- :: Int -> CompactString -> CompactString+ drop, -- :: Int -> CompactString -> CompactString+ splitAt, -- :: Int -> CompactString -> (CompactString, CompactString)+ takeWhile, -- :: (Char -> Bool) -> CompactString -> CompactString+ dropWhile, -- :: (Char -> Bool) -> CompactString -> CompactString+ span, -- :: (Char -> Bool) -> CompactString -> (CompactString, CompactString)+ spanEnd, -- :: (Char -> Bool) -> CompactString -> (CompactString, CompactString)+ break, -- :: (Char -> Bool) -> CompactString -> (CompactString, CompactString)+ breakEnd, -- :: (Char -> Bool) -> CompactString -> (CompactString, CompactString)+ group, -- :: CompactString -> [CompactString]+ groupBy, -- :: (Char -> Char -> Bool) -> CompactString -> [CompactString]+ inits, -- :: CompactString -> [CompactString]+ tails, -- :: CompactString -> [CompactString]+ + -- ** Breaking into many substrings+ split, -- :: Char -> CompactString -> [CompactString]+ splitWith, -- :: (Char -> Bool) -> CompactString -> [CompactString]+ + -- ** Breaking into lines and words+ lines, -- :: CompactString -> [CompactString]+ words, -- :: CompactString -> [CompactString]+ unlines, -- :: [CompactString] -> CompactString+ unwords, -- :: CompactString -> [CompactString]+ + -- * Predicates+ isPrefixOf, -- :: CompactString -> CompactString -> Bool+ isSuffixOf, -- :: CompactString -> CompactString -> Bool+ isInfixOf, -- :: CompactString -> CompactString -> Bool+ + -- ** Search for arbitrary substrings+ findSubstring, -- :: CompactString -> CompactString -> Maybe Int+ findSubstrings, -- :: CompactString -> CompactString -> [Int]+ + -- * Searching CompactStrings+ + -- ** Searching by equality+ elem, -- :: Char -> CompactString -> Bool+ notElem, -- :: Char -> CompactString -> Bool+ + -- ** Searching with a predicate+ find, -- :: (Char -> Bool) -> CompactString -> Maybe Char+ filter, -- :: (Char -> Bool) -> CompactString -> CompactString+ partition, -- :: (Char -> Bool) -> CompactString -> (CompactString, CompactString)+ + -- * Indexing CompactStrings+ index, -- :: CompactString -> Int -> Char+ elemIndex, -- :: Char -> CompactString -> Maybe Int+ elemIndices, -- :: Char -> CompactString -> [Int]+ elemIndexEnd, -- :: Char -> CompactString -> Maybe Int+ findIndex, -- :: (Char -> Bool) -> CompactString -> Maybe Int+ findIndexEnd, -- :: (Char -> Bool) -> CompactString -> Maybe Int+ findIndices, -- :: (Char -> Bool) -> CompactString -> [Int]+ count, -- :: Char -> CompactString -> Int+ + -- * Zipping and unzipping CompactStrings+ zip, -- :: CompactString -> CompactString -> [(Char,Char)]+ zipWith, -- :: (Char -> Char -> c) -> CompactString -> CompactString -> [c]+ zipWith', -- :: (Char -> Char -> Char) -> CompactString -> CompactString -> CompactString+ unzip, -- :: [(Char,Char)] -> (CompactString,CompactString)+ + -- * Ordered CompactStrings+ sort, -- :: CompactString -> CompactString+ + -- * Encoding+ toByteString, -- :: CompactString -> ByteString+ fromByteString, -- :: ByteString -> m CompactString+ fromByteString_, -- :: ByteString -> CompactString+ validate, -- :: CompactString -> m CompactString+ validate_, -- :: CompactString -> CompactString+ -- ** Encoding conversion+ encode, -- :: Encoding a => a -> CompactString -> m (ByteString)+ encode_, -- :: Encoding a => a -> CompactString -> ByteString+ decode, -- :: Encoding a => a -> ByteString -> m (CompactString)+ decode_, -- :: Encoding a => a -> ByteString -> CompactString+ encodeBOM, -- :: CompactString -> m (ByteString)+ encodeBOM_, -- :: CompactString -> ByteString+ decodeBOM, -- :: ByteString -> m (CompactString)+ decodeBOM_, -- :: ByteString -> CompactString+ + -- * I\/O with 'CompactString's+ + -- ** Standard input and output+ getLine, -- :: IO CompactString+ getContents, -- :: IO CompactString+ putStr, -- :: CompactString -> IO ()+ putStrLn, -- :: CompactString -> IO ()+ interact, -- :: (CompactString -> CompactString) -> IO ()+ + -- ** Files+ readFile, -- :: FilePath -> IO CompactString+ readFile', -- :: FilePath -> IO CompactString+ writeFile, -- :: FilePath -> CompactString -> IO ()+ writeFile', -- :: FilePath -> CompactString -> IO ()+ appendFile, -- :: FilePath -> CompactString -> IO ()+ appendFile', -- :: FilePath -> CompactString -> IO ()+ + -- ** I\/O with Handles+ hGetLine, -- :: Handle -> IO CompactString+ hGetContents, -- :: Handle -> IO CompactString+ hGetContents', -- :: Handle -> IO CompactString+ hGet, -- :: Handle -> Int -> IO CompactString+ hGetNonBlocking, -- :: Handle -> Int -> IO CompactString+ hPut, -- :: Handle -> CompactString -> IO ()+ hPutStr, -- :: Handle -> CompactString -> IO ()+ hPutStrLn, -- :: Handle -> CompactString -> IO ()+ + ) where++import Prelude hiding+ (length, head, tail, last, init, null, + map, reverse, foldl, foldr, foldl1, foldr1, concat, concatMap,+ scanl, scanl1, scanr, scanr1, replicate,+ take, drop, splitAt, takeWhile, dropWhile,+ span, break, any, all, elem, notElem,+ maximum, minimum, filter, zip, zipWith, unzip,+ lines, unlines, words, unwords,+ putStr, putStrLn, getContents, getLine, interact,+ readFile, writeFile, appendFile)++import System.IO (Handle)+import Control.Monad (MonadPlus)++import Data.CompactString.Internal (Encoding, ByteString)+import qualified Data.CompactString as C+import qualified Data.CompactString.Encodings as C++-- -----------------------------------------------------------------------------+--+-- The @CompactString@ type+--++-- | CompactString specialized to DESCRIPTION.+type CompactString = C.CompactString C.TYPE++-- -----------------------------------------------------------------------------+--+-- Type signatures & documentation+--++#define COMPACTSTRING CompactString+#define CONTEXT+#define CONTEXT_+#include "signatures.include"++-- -----------------------------------------------------------------------------+--+-- Specialized versions+--++empty = C.empty+singleton = C.singleton+pack = C.pack+unpack = C.unpack++cons = C.cons+snoc = C.snoc+append = C.append+head = C.head+last = C.last+tail = C.tail+init = C.init+headView = C.headView+lastView = C.lastView+null = C.null+length = C.length++map = C.map+reverse = C.reverse+intersperse = C.intersperse+intercalate = C.intercalate+transpose = C.transpose++foldl = C.foldl+foldl' = C.foldl'+foldl1 = C.foldl1+foldl1' = C.foldl1'+foldr = C.foldr+foldr' = C.foldr'+foldr1 = C.foldr1+foldr1' = C.foldr1'++concat = C.concat+concatMap = C.concatMap+any = C.any+all = C.all+maximum = C.maximum+minimum = C.minimum++scanl = C.scanl+scanl1 = C.scanl1+scanr = C.scanr+scanr1 = C.scanr1++mapAccumL = C.mapAccumL+mapAccumR = C.mapAccumR+mapIndexed = C.mapIndexed++replicate = C.replicate+unfoldr = C.unfoldr+unfoldrN = C.unfoldrN++take = C.take+drop = C.drop+splitAt = C.splitAt +takeWhile = C.takeWhile+dropWhile = C.dropWhile+span = C.span+spanEnd = C.spanEnd+break = C.break+breakEnd = C.breakEnd+group = C.group+groupBy = C.groupBy+inits = C.inits+tails = C.tails++split = C.split+splitWith = C.splitWith++lines = C.lines+unlines = C.unlines+words = C.words+unwords = C.unwords++isPrefixOf = C.isPrefixOf+isSuffixOf = C.isSuffixOf++isInfixOf = C.isInfixOf+findSubstring = C.findSubstring+findSubstrings = C.findSubstrings++elem = C.elem+notElem = C.notElem++find = C.find+filter = C.filter+partition = C.partition++index = C.index+elemIndex = C.elemIndex+elemIndices = C.elemIndices+elemIndexEnd = C.elemIndexEnd+findIndex = C.findIndex+findIndexEnd = C.findIndexEnd+findIndices = C.findIndices+count = C.count++zip = C.zip+zipWith = C.zipWith+zipWith' = C.zipWith'+unzip = C.unzip++sort = C.sort++toByteString = C.toByteString+fromByteString = C.fromByteString+fromByteString_ = C.fromByteString_+validate = C.validate+validate_ = C.validate_++encode = C.encode+encode_ = C.encode_+decode = C.decode+decode_ = C.decode_+encodeBOM = C.encodeBOM+encodeBOM_ = C.encodeBOM_+decodeBOM = C.decodeBOM+decodeBOM_ = C.decodeBOM_++getLine = C.getLine+getContents = C.getContents+putStr = C.putStr+putStrLn = C.putStrLn+interact = C.interact++readFile = C.readFile+readFile' = C.readFile'+writeFile = C.writeFile+writeFile' = C.writeFile'+appendFile = C.appendFile+appendFile' = C.appendFile'++hGetLine = C.hGetLine+hGetContents = C.hGetContents+hGetContents' = C.hGetContents'+hGet = C.hGet+hGetNonBlocking = C.hGetNonBlocking+hPut = C.hPut+hPutStr = C.hPutStr+hPutStrLn = C.hPutStrLn
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) Twan van Laarhoven 2007.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ compact-string-fix.cabal view
@@ -0,0 +1,43 @@+name: compact-string-fix +version: 0.3.1 +license: BSD3 +license-file: LICENSE +author: Twan van Laarhoven +maintainer: Tony Hannan <tony@10gen.com> +homepage: http://twan.home.fmf.nl/compact-string/ +category: Data +synopsis: Same as compact-string except with a small fix so it builds on ghc-6.12 +description: + Fast, packed, strict strings with a list interface. + Based on "Data.ByteString". + Multiple encodings are supported.+ This is the same package as compact-string-0.3.1 except for a small fix to work with the new Exception library. Once Twan updates that package, this package will be deprecated. + +build-type: Simple +cabal-version: >= 1.2 +extra-source-files: + Data/CompactString/signatures.include + Data/CompactString/specialized.include + test/QuickCheckUtils.hs + test/Properties.hs + +library + build-depends: base >= 3 && < 5, bytestring >= 0.9 + + exposed-modules: + Data.CompactString + Data.CompactString.ASCII + Data.CompactString.Encodings + Data.CompactString.UTF16 + Data.CompactString.UTF8 + Data.CompactString.Unsafe + Data.CompactString.Internal + Data.CompactString.Fusion + + include-dirs: Data/CompactString + + extensions: CPP, EmptyDataDecls + ghc-options: -Wall -O2 -funbox-strict-fields + + if impl(ghc <= 6.4.2) + cpp-options: -DSLOW_FOREIGN_PTR
+ test/Properties.hs view
@@ -0,0 +1,414 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++import Test.QuickCheck+import Data.Char (ord)+import Control.Monad++import Text.Printf+import Debug.Trace+import System.Environment++import qualified Data.CompactString.UTF8 as C+import qualified Data.List as L+import Data.CompactString.Encodings++import qualified Data.ByteString as B++import QuickCheckUtils hiding (C)++type C = C.CompactString++------------------------------------------------------------------------+-- Functions not in Data.List++l_headView [] = Nothing+l_headView (x:xs) = Just (x, xs)+l_lastView xs = if L.null xs then Nothing else Just (L.init xs, L.last xs)++l_mapIndexed f = L.zipWith f [0..]++l_spanEnd p = (\(x,y) -> (reverse y, reverse x)) . span p . reverse+l_breakEnd p = l_spanEnd (not . p)++l_findSubstring pat str = case l_findSubstrings pat str of+ [] -> Nothing+ (x:xs) -> Just x+l_findSubstrings pat str = L.map fst $ L.filter snd $ zip [0..] $ L.map (pat `L.isPrefixOf`) (L.tails str)++l_split c = l_splitWith (==c)+l_splitWith p [] = []+l_splitWith p xs = sw xs+ where sw xs = case L.break p xs of+ (_ ,[] ) -> [xs]+ (ys,(_:zs)) -> ys : sw zs++l_count c = L.length . L.filter (==c)++------------------------------------------------------------------------+-- Properties : Internal consistency++prop_validate cs = C.validate cs == Just cs++------------------------------------------------------------------------+-- Properties : Functions not in the prelude++prop_pack xs = C.unpack (C.pack xs) == xs+prop_unpack cs = C.pack (C.unpack cs) == cs++prop_elemIndexEnd c xs =+ C.elemIndexEnd c xs ==+ (-) (C.length xs - 1) `fmap` C.elemIndex c (C.reverse xs)++prop_findIndexEnd c xs =+ C.findIndexEnd c xs ==+ (-) (C.length xs - 1) `fmap` C.findIndex c (C.reverse xs)+++------------------------------------------------------------------------+-- Properties : Comparing with lists++prop_eq = eq2+ ((==) :: C -> C -> Bool)+ ((==) :: S -> S -> Bool)+prop_compare = eq2+ (compare :: C -> C -> Ordering)+ (compare :: S -> S -> Ordering)+prop_show = eq1+ (show :: C -> String)+ (show :: S -> String)++prop_empty = C.empty `eq0` ""+prop_singleton = C.singleton `eq1` (return :: Char -> S)++prop_cons = C.cons `eq2` ((:) :: Char -> S -> S)+prop_snoc = C.snoc `eq2` ((\s c -> s ++ [c]) :: S -> Char -> S)+prop_append = C.append `eq2` ((++) :: S -> S -> S)+prop_head = C.head `eqnotnull1` (L.head :: S -> Char)+prop_tail = C.tail `eqnotnull1` (L.tail :: S -> S)+prop_last = C.last `eqnotnull1` (L.last :: S -> Char)+prop_init = C.init `eqnotnull1` (L.init :: S -> S)+prop_headView = C.headView `eq1` (l_headView :: S -> Maybe (Char, S))+prop_lastView = C.lastView `eq1` (l_lastView :: S -> Maybe (S, Char))+prop_null = C.null `eq1` (L.null :: S -> Bool)+prop_length = C.length `eq1` (L.length :: S -> Int)++prop_map = C.map `eq2` (L.map :: (Char -> Char) -> (S -> S))+prop_reverse = C.reverse `eq1` (L.reverse :: S -> S)+prop_intersperse= C.intersperse `eq2` (L.intersperse :: Char -> S -> S)+prop_transpose = C.transpose `eq1` (L.transpose :: [S] -> [S])++prop_foldl = eq3+ (C.foldl :: (Int -> Char -> Int) -> Int -> C -> Int)+ (L.foldl :: (Int -> Char -> Int) -> Int -> S -> Int)+prop_foldr = eq3+ (C.foldr :: (Char -> Int -> Int) -> Int -> C -> Int)+ (L.foldr :: (Char -> Int -> Int) -> Int -> S -> Int)+prop_foldl' = eq3+ (C.foldl' :: (Int -> Char -> Int) -> Int -> C -> Int)+ (L.foldl' :: (Int -> Char -> Int) -> Int -> S -> Int)+prop_foldl1 = C.foldl1 `eqnotnull2` (L.foldl1 :: (Char -> Char -> Char) -> S -> Char)+prop_foldr1 = C.foldr1 `eqnotnull2` (L.foldr1 :: (Char -> Char -> Char) -> S -> Char)+prop_foldl1' = C.foldl1' `eqnotnull2` (L.foldl1' :: (Char -> Char -> Char) -> S -> Char)++prop_concat = C.concat `eq1` (L.concat :: [S] -> S)+prop_concatMap = C.concatMap `eq2b` (L.concatMap :: (Char -> S) -> S -> S)+prop_any = C.any `eq2` (L.any :: (Char -> Bool) -> S -> Bool)+prop_all = C.all `eq2` (L.all :: (Char -> Bool) -> S -> Bool)+prop_maximum = C.maximum `eqnotnull1` (L.maximum :: S -> Char)+prop_minimum = C.minimum `eqnotnull1` (L.minimum :: S -> Char)++prop_concatMap2 = c_concatMap2 `eq2b` (L.concatMap :: (Char -> S) -> S -> S)+ where c_concatMap2 f = C.concat . L.map (C.validate_ . f) . C.unpack+prop_concatMap3 = c_concatMap3 `eq2` (L.map :: (Char -> S) -> S -> [S])+ where+ c_concatMap3 :: (Char -> C) -> C -> [C]+ c_concatMap3 f = L.map f . C.unpack++prop_concatMapFoldr = eq2+ (\f -> C.foldr ((:) . f) [] :: C -> [C])+ (\f -> L.foldr ((:) . f) [] :: S -> [S])++prop_scanl = C.scanl `eq3` (L.scanl :: (Char -> Char -> Char) -> Char -> S -> S)+prop_scanr = C.scanr `eq3` (L.scanr :: (Char -> Char -> Char) -> Char -> S -> S)+prop_scanl1 = C.scanl1 `eqnotnull2` (L.scanl1 :: (Char -> Char -> Char) -> S -> S)+prop_scanr1 = C.scanr1 `eqnotnull2` (L.scanr1 :: (Char -> Char -> Char) -> S -> S)++prop_mapAccumL = eq3+ (C.mapAccumL :: (Int -> Char -> (Int, Char)) -> Int -> C -> (Int, C))+ (L.mapAccumL :: (Int -> Char -> (Int, Char)) -> Int -> S -> (Int, S))+prop_mapAccumR = eq3+ (C.mapAccumR :: (Int -> Char -> (Int, Char)) -> Int -> C -> (Int, C))+ (L.mapAccumR :: (Int -> Char -> (Int, Char)) -> Int -> S -> (Int, S))+prop_mapIndexed = eq2+ (C.mapIndexed :: (Int -> Char -> Char) -> C -> C)+ (l_mapIndexed :: (Int -> Char -> Char) -> S -> S)++prop_replicate = C.replicate `eq2` (L.replicate :: Int -> Char -> S)+-- note: we have to take a finite length, otherwise we could loop+-- since C.unfoldr is strict this is not possible+--prop_unfoldr = eq3+-- (\n -> C.take n (C.unfoldr :: (Int -> Maybe (Char, Int)) -> Int -> C))+-- (\n -> C.take n (L.unfoldr :: (Int -> Maybe (Char, Int)) -> Int -> S))+prop_unfoldrN = eq3+ (\n f a -> fst $ (C.unfoldrN :: Int -> (Int -> Maybe (Char, Int)) -> Int -> (C, Maybe Int)) n f a)+ (\n f a -> L.take n $ (L.unfoldr :: (Int -> Maybe (Char, Int)) -> Int -> S ) f a)++prop_take = C.take `eq2` (L.take :: Int -> S -> S)+prop_drop = C.drop `eq2` (L.drop :: Int -> S -> S)+prop_splitAt = C.splitAt `eq2` (L.splitAt :: Int -> S -> (S,S))+prop_takeWhile = C.takeWhile `eq2` (L.takeWhile :: (Char -> Bool) -> S -> S)+prop_dropWhile = C.dropWhile `eq2` (L.dropWhile :: (Char -> Bool) -> S -> S)+prop_break = C.break `eq2` (L.break :: (Char -> Bool) -> S -> (S,S))+prop_span = C.span `eq2` (L.span :: (Char -> Bool) -> S -> (S,S))+prop_breakEnd = C.breakEnd `eq2` (l_breakEnd :: (Char -> Bool) -> S -> (S,S))+prop_spanEnd = C.spanEnd `eq2` (l_spanEnd :: (Char -> Bool) -> S -> (S,S))+prop_group = C.group `eq1` (L.group :: S -> [S])+prop_groupBy = C.groupBy `eq2` (L.groupBy :: (Char -> Char -> Bool) -> S -> [S])+prop_inits = C.inits `eq1` (L.inits :: S -> [S])+prop_tails = C.tails `eq1` (L.tails :: S -> [S])++prop_split = C.split `eq2` (l_split :: Char -> S -> [S])+prop_splitWith = C.splitWith `eq2` (l_splitWith :: (Char -> Bool) ->S -> [S])++prop_lines = C.lines `eq1` (L.lines :: S -> [S])+prop_unlines = C.unlines `eq1` (L.unlines :: [S] -> S)+prop_words = C.words `eq1` (L.words :: S -> [S])+prop_unwords = C.unwords `eq1` (L.unwords :: [S] -> S)++prop_isPrefixOf = C.isPrefixOf `eq2` (L.isPrefixOf :: S -> S -> Bool)+prop_isSuffixOf = C.isSuffixOf `eq2` (L.isSuffixOf :: S -> S -> Bool)+prop_isSubstringOf = C.isInfixOf `eq2` (L.isInfixOf :: S -> S -> Bool)++prop_findSubstring = C.findSubstring `eq2` (l_findSubstring:: S -> S -> Maybe Int)+prop_findSubstrings = C.findSubstrings `eq2` (l_findSubstrings::S -> S -> [Int])++prop_elem = C.elem `eq2` (L.elem :: Char -> S -> Bool)+prop_notElem = C.notElem `eq2` (L.notElem :: Char -> S -> Bool)++prop_find = C.find `eq2` (L.find :: (Char -> Bool) -> S -> Maybe Char)+prop_filter = C.filter `eq2` (L.filter :: (Char -> Bool) -> S -> S)+prop_partition = C.partition `eq2` (L.partition :: (Char -> Bool) -> S -> (S,S))++prop_index = C.index `eqexcept2` ((L.!!) :: S -> Int -> Char)+prop_elemIndex = C.elemIndex `eq2` (L.elemIndex :: Char -> S -> Maybe Int)+prop_elemIndices = C.elemIndices `eq2` (L.elemIndices :: Char -> S -> [Int])+prop_findIndex = C.findIndex `eq2` (L.findIndex :: (Char -> Bool) -> S -> Maybe Int)+prop_findIndices = C.findIndices `eq2` (L.findIndices :: (Char -> Bool) -> S -> [Int])+prop_count = C.count `eq2` (l_count :: Char -> S -> Int)++prop_zip = C.zip `eq2` (L.zip :: S -> S -> [(Char,Char)])+prop_zipWith = eq3+ (C.zipWith :: (Char -> Char -> Int) -> C -> C -> [Int])+ (L.zipWith :: (Char -> Char -> Int) -> S -> S -> [Int])+prop_zipWith' = C.zipWith' `eq3` (L.zipWith :: (Char -> Char -> Char) -> S -> S -> S)+prop_unzip = C.unzip `eq1` (L.unzip :: [(Char,Char)] -> (S,S))++prop_sort = C.sort `eq1` (L.sort :: S -> S)++------------------------------------------------------------------------+-- Properties : Encding++-- "C.fromByteString . C.toByteString = id"+prop_fromToByteString cs = C.fromByteString (C.toByteString cs) == Just cs++-- "decode . encode = id"+prop_de enc = \x -> case C.encode enc x of+ Nothing -> False ==> False+ Just y -> property $ C.decode enc y == Just x++-- "encode . decode = id"+prop_ed enc = \x -> case C.decode enc x of+ Nothing -> False ==> False+ Just y -> property $ C.encode enc y == Just x++-- "decodeBOM . encodeBOM = id"+prop_decode_bom enc = \x -> C.decodeBOM (C.encodeBOM_ enc x) == Just x++prop_decode_encode_UTF8 = prop_de UTF8+prop_decode_encode_UTF16BE = prop_de (UTF16 BE)+prop_decode_encode_UTF16LE = prop_de (UTF16 LE)+prop_decode_encode_UTF32BE = prop_de (UTF32 BE)+prop_decode_encode_UTF32LE = prop_de (UTF32 LE)+prop_decode_encode_ASCII = prop_de ASCII+prop_decode_encode_Latin1 = prop_de Latin1+prop_decode_encode_Compact = prop_de Compact++prop_encode_decode_UTF8 = prop_ed UTF8+-- This does not hold for UTF16, because two different bytestrings can represent the+-- same Unicode string: The order of a surrogate pair can be swapped+--prop_encode_decode_UTF16BE = prop_ed (decode (UTF16 BE)) (encode (UTF16 BE))+--prop_encode_decode_UTF16LE = prop_ed (decode (UTF16 LE)) (encode (UTF16 LE))+prop_encode_decode_UTF32BE = prop_ed (UTF32 BE)+prop_encode_decode_UTF32LE = prop_ed (UTF32 LE)+prop_encode_decode_ASCII = prop_ed ASCII+prop_encode_decode_Latin1 = prop_ed Latin1+prop_encode_decode_Compact = prop_ed Compact++prop_decode_no_bom = \x -> C.take 1 x /= C.pack "\xFEFF"+ ==> C.decodeBOM (C.encode_ UTF8 x) == Just x+prop_decode_bom_UTF8 = prop_decode_bom UTF8+prop_decode_bom_UTF16BE = prop_decode_bom (UTF16 BE)+prop_decode_bom_UTF16LE = prop_decode_bom (UTF16 LE)+prop_decode_bom_UTF32BE = prop_decode_bom (UTF32 BE)+prop_decode_bom_UTF32LE = prop_decode_bom (UTF32 LE)++------------------------------------------------------------------------+-- The tests++tests = list_tests+ ++ other_tests+ ++ encoding_tests++list_tests :: [(String, Int -> IO ())]+list_tests =+ [("validate", mytest prop_validate)+ + ,("eq", mytest prop_eq)+ ,("compare", mytest prop_compare)+ ,("show", mytest prop_show)+ + ,("empty", mytest prop_empty)+ ,("singleton", mytest prop_singleton)+ + ,("cons", mytest prop_cons)+ ,("snoc", mytest prop_snoc)+ ,("append", mytest prop_append)+ ,("head", mytest prop_head)+ ,("tail", mytest prop_tail)+ ,("init", mytest prop_init)+ ,("null", mytest prop_null)+ ,("length", mytest prop_length)+ + ,("map", mytest prop_map)+ ,("reverse", mytest prop_reverse)+ ,("intersperse", mytest prop_intersperse)+ ,("transpose", mytest prop_transpose)+ ,("foldl", mytest prop_foldl)+ ,("foldr", mytest prop_foldr)+ ,("foldl'", mytest prop_foldl')+ ,("foldl1", mytest prop_foldl1)+ ,("foldr1", mytest prop_foldr1)+ ,("foldl1'", mytest prop_foldl1')+ + ,("concat", mytest prop_concat)+ ,("concatMap", mytest prop_concatMap)+ ,("any", mytest prop_any)+ ,("all", mytest prop_all)+ ,("maximum", mytest prop_maximum)+ ,("minimum", mytest prop_minimum)+ + ,("scanl", mytest prop_scanl)+ ,("scanr", mytest prop_scanr)+ ,("scanl1", mytest prop_scanl1)+ ,("scanr1", mytest prop_scanr1)+ + ,("mapAccumL", mytest prop_mapAccumL)+ ,("mapAccumR", mytest prop_mapAccumR)+ ,("mapIndexed", mytest prop_mapIndexed)+ + ,("replicate", mytest prop_replicate)+ ,("unfoldrN", mytest prop_unfoldrN)+ + ,("take", mytest prop_take)+ ,("drop", mytest prop_drop)+ ,("splitAt", mytest prop_splitAt)+ ,("takeWhile", mytest prop_takeWhile)+ ,("dropWhile", mytest prop_dropWhile)+ ,("break", mytest prop_break)+ ,("span", mytest prop_span)+ ,("breakEnd", mytest prop_breakEnd)+ ,("spanEnd", mytest prop_spanEnd)+ ,("group", mytest prop_group)+ ,("groupBy", mytest prop_groupBy)+ ,("inits", mytest prop_inits)+ ,("tails", mytest prop_tails)++ ,("split", mytest prop_split)+ ,("splitWith", mytest prop_splitWith)++ ,("lines", mytest prop_lines)+ ,("unlines", mytest prop_unlines)+ ,("words", mytest prop_words)+ ,("unwords", mytest prop_unwords)+ + ,("isPrefixOf", mytest prop_isPrefixOf)+ ,("isSuffixOf", mytest prop_isSuffixOf)+ + ,("isSubstringOf", mytest prop_isSubstringOf)+ ,("findSubstring", mytest prop_findSubstring)+ ,("findSubstrings", mytest prop_findSubstrings)+ + ,("elem", mytest prop_elem)+ ,("notElem", mytest prop_notElem)+ + ,("find", mytest prop_find)+ ,("filter", mytest prop_filter)+ ,("partition", mytest prop_partition)+ + ,("index", mytest prop_index)+ ,("elemIndex", mytest prop_elemIndex)+ ,("elemIndices", mytest prop_elemIndices)+ ,("findIndex", mytest prop_findIndex)+ ,("findIndices", mytest prop_findIndices)+ ,("count", mytest prop_count)+ + ,("zip", mytest prop_zip)+ ,("zipWith", mytest prop_zipWith)+ ,("zipWith'", mytest prop_zipWith')+ ,("unzip", mytest prop_unzip)+ + ,("sort", mytest prop_sort)+ + {-+ ,("", mytest )+ -}+ ]++other_tests :: [(String, Int -> IO ())]+other_tests =+ [("unpack . pack", mytest prop_pack)+ ,("pack . unpack", mytest prop_unpack)+ ,("elemIndexEnd", mytest prop_elemIndexEnd)+ ,("findIndexEnd", mytest prop_findIndexEnd)+ ]++encoding_tests :: [(String, Int -> IO ())]+encoding_tests =+ [("from . toByteString", mytest prop_fromToByteString)+ + ,("decode . encode: UTF-8", mytest prop_decode_encode_UTF8)+ ,("decode . encode: UTF-16BE", mytest prop_decode_encode_UTF16BE)+ ,("decode . encode: UTF-16LE", mytest prop_decode_encode_UTF16LE)+ ,("decode . encode: UTF-32BE", mytest prop_decode_encode_UTF32BE)+ ,("decode . encode: UTF-32LE", mytest prop_decode_encode_UTF32LE)+ ,("decode . encode: ASCII", mytest prop_decode_encode_ASCII)+ ,("decode . encode: Latin1", mytest prop_decode_encode_Latin1)+ ,("decode . encode: Compact", mytest prop_decode_encode_Compact)+ + ,("encode . decode: UTF-8", mytest prop_encode_decode_UTF8)+ --,("encode . decode: UTF-16BE", mytest prop_encode_decode_UTF16BE)+ --,("encode . decode: UTF-16LE", mytest prop_encode_decode_UTF16LE)+ ,("encode . decode: UTF-32BE", mytest prop_encode_decode_UTF32BE)+ ,("encode . decode: UTF-32LE", mytest prop_encode_decode_UTF32LE)+ ,("encode . decode: ASCII", mytest prop_encode_decode_ASCII)+ ,("encode . decode: Latin1", mytest prop_encode_decode_Latin1)+ ,("encode . decode: Compact", mytest prop_encode_decode_Compact)+ + ,("decode no BOM", mytest prop_decode_no_bom)+ ,("decode / BOM: UTF-8", mytest prop_decode_bom_UTF8)+ ,("decode / BOM: UTF-16BE", mytest prop_decode_bom_UTF16BE)+ ,("decode / BOM: UTF-16LE", mytest prop_decode_bom_UTF16LE)+ ,("decode / BOM: UTF-32BE", mytest prop_decode_bom_UTF32BE)+ ,("decode / BOM: UTF-32LE", mytest prop_decode_bom_UTF32LE)+ ]++------------------------------------------------------------------------+-- The entry point++main = run tests++run :: [(String, Int -> IO ())] -> IO ()+run tests = do+ x <- getArgs+ let n = if null x then 100 else read . head $ x+ mapM_ (\(s,a) -> printf "%-25s: " s >> a n) tests
+ test/QuickCheckUtils.hs view
@@ -0,0 +1,270 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+--+-- Uses multi-param type classes+-- Copied from Data.ByteString+--+module QuickCheckUtils where++import Test.QuickCheck.Batch+import Test.QuickCheck+import Text.Show.Functions++import Control.Monad ( liftM, liftM2 )+import qualified Control.Exception as E+import Data.Char+import Data.List+import Data.Word+import Data.Int+import Debug.Trace+import System.Random+import System.IO+import System.IO.Unsafe+ +import qualified Data.CompactString as C +import qualified Data.ByteString as B +import Data.CompactString.Encodings++-- Enable this to get verbose test output. Including the actual tests.+debug = False++mytest :: Testable a => a -> Int -> IO ()+mytest a n = mycheck defaultConfig+ { configMaxTest=n+ , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a++mycheck :: Testable a => Config -> a -> IO ()+mycheck config a =+ do rnd <- newStdGen+ mytests config (evaluate a) rnd 0 0 []++mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO ()+mytests config gen rnd0 ntest nfail stamps+ | ntest == configMaxTest config = do done "OK," ntest stamps+ | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps+ | otherwise =+ do putStr (configEvery config ntest (arguments result)) >> hFlush stdout+ case ok result of+ Nothing ->+ mytests config gen rnd1 ntest (nfail+1) stamps+ Just True ->+ mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps)+ Just False ->+ putStr ( "Falsifiable after "+ ++ show ntest+ ++ " tests:\n"+ ++ unlines (arguments result)+ ) >> hFlush stdout+ where+ result = generate (configSize config ntest) rnd2 gen+ (rnd1,rnd2) = split rnd0++done :: String -> Int -> [[String]] -> IO ()+done mesg ntest stamps =+ do putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table )+ where+ table = display+ . map entry+ . reverse+ . sort+ . map pairLength+ . group+ . sort+ . filter (not . null)+ $ stamps++ display [] = ".\n"+ display [x] = " (" ++ x ++ ").\n"+ display xs = ".\n" ++ unlines (map (++ ".") xs)++ pairLength xss@(xs:_) = (length xss, xs)+ entry (n, xs) = percentage n ntest+ ++ " "+ ++ concat (intersperse ", " xs)++ percentage n m = show ((100 * n) `div` m) ++ "%"+ + +------------------------------------------------------------------------ +-- Debugging + +-- | Do a test on a property with 1 argument, return the first argument that fails +firstFail :: Arbitrary a => (a -> Bool) -> Int -> IO (Maybe a) +firstFail f n =+ do rnd <- newStdGen+ firstFail' defaultConfig{configMaxTest=n} arbitrary f rnd 0 + +firstFail' :: Config -> Gen a -> (a -> Bool) -> StdGen -> Int -> IO (Maybe a) +firstFail' config gen test rnd0 ntest + | ntest == configMaxTest config = return Nothing + | otherwise = case test input of+ False -> do+ putStr ( "Falsifiable after "+ ++ show ntest+ ++ " tests"+ )+ hFlush stdout+ return (Just input)+ _ ->+ firstFail' config gen test rnd1 (ntest + 1) + where+ input = generate (configSize config ntest) rnd2 gen+ (rnd1,rnd2) = split rnd0 + +-- | Do a test, comparing two functions, return the first argument and result that lead to inequality +firstNeq :: (Eq b, Arbitrary a) => (a -> b) -> (a -> b) -> Int -> IO (Maybe (a, b, b)) +firstNeq f1 f2 n =+ do rnd <- newStdGen+ firstNeq' defaultConfig{configMaxTest=n} arbitrary f1 f2 rnd 0 + +firstNeq' :: Eq b => Config -> Gen a -> (a -> b) -> (a -> b) -> StdGen -> Int -> IO (Maybe (a, b, b)) +firstNeq' config gen t1 t2 rnd0 ntest + | ntest == configMaxTest config = return Nothing + | otherwise = if o1 /= o2 then do+ putStr ( "Falsifiable after "+ ++ show ntest+ ++ " tests"+ )+ hFlush stdout+ return (Just (input, o1, o2))+ else+ firstNeq' config gen t1 t2 rnd1 (ntest + 1) + where+ input = generate (configSize config ntest) rnd2 gen+ o1 = t1 input+ o2 = t2 input+ (rnd1,rnd2) = split rnd0 + +------------------------------------------------------------------------ +-- Types + +type C = C.CompactString +type B = B.ByteString +type S = String + +------------------------------------------------------------------------ +-- Arbitrary instances + +instance Arbitrary Char where + arbitrary = liftM toChar $ choose (0,maxToChar) + coarbitrary c = variant (ord c `rem` 4) + +maxToChar = 0x10FFFF-0x800 +toChar c + | c >= 0xD800 = chr (c + 0x800) -- skip surrogate pairs + | otherwise = chr c + +instance Arbitrary Word8 where + arbitrary = liftM fromIntegral $ choose (0::Int,255) + coarbitrary c = variant (fromIntegral c `rem` 4) + +instance C.Encoding a => Arbitrary (C a) where + arbitrary = liftM C.pack arbitrary + coarbitrary = coarbitrary . C.unpack + +instance Arbitrary B where + arbitrary = liftM B.pack arbitrary + coarbitrary = coarbitrary . B.unpack ++------------------------------------------------------------------------+-- (from ByteString)+--+-- The Model class connects a type and its model type, via a conversion+-- function. +--+--+class Model a b where+ model :: a -> b -- get the abstract vale from a concrete value++instance C.Encoding a => Model (C a) [Char] where model = C.unpack++-- Types are trivially modeled by themselves+instance Model Bool Bool where model = id+instance Model Int Int where model = id+instance Model Char Char where model = id+instance Model Ordering Ordering where model = id++-- Type constructors are modeled recursively+instance Model a b => Model [a] [b] where model = fmap model+instance Model a b => Model (Maybe a) (Maybe b) where model = fmap model+instance Model a b => Model (x -> a) (x -> b) where model = fmap model+instance (Model a b, Model c d) => Model (a,c) (b,d) where model (a,c) = (model a, model c)++instance Functor ((->) r) where+ fmap = (.)++instance Monad ((->) r) where+ return = const+ f >>= k = \ r -> k (f r) r++instance Functor ((,) a) where+ fmap f (x,y) = (x, f y)++------------------------------------------------------------------------+--+-- These comparison functions handle wrapping and equality.+--+-- A single class for these would be nice, but note that they differe in+-- the number of arguments, and those argument types, so we'd need HList+-- tricks. See here: http://okmij.org/ftp/Haskell/vararg-fn.lhs+--++eq0 f g = + model f == g+eq1 f g = \a ->+ model (f a) == g (model a)+eq2 f g = \a b ->+ model (f a b) == g (model a) (model b)+eq3 f g = \a b c ->+ model (f a b c) == g (model a) (model b) (model c)+eq4 f g = \a b c d ->+ model (f a b c d) == g (model a) (model b) (model c) (model d)+eq5 f g = \a b c d e ->+ model (f a b c d e) == g (model a) (model b) (model c) (model d) (model e)++eq2b :: C.Encoding a+ => ((Char -> C a) -> C a -> C a)+ -> ((Char -> S) -> S -> S)+ -> (Char -> C a) -> C a -> Bool+eq2b f g = \a b ->+ --model (f a b) == g (model a) (model b)+ let ma = model a+ mb = model b+ mfab = model (f a b)+ gmab = g ma mb+ in if mfab == gmab then True+ else trace ("f " ++ show a ++ " " ++ show b ++ " = " ++ show mfab)+ $ trace ("g " ++ show ma ++ " " ++ show mb ++ " = " ++ show gmab)+ $ trace (show $ model (f a b) == g (model a) (model b))+ -- $ trace (unlines $ map (show . f a) (model b))+ -- $ trace (unlines $ map (show . (model a::Char->S)) (C.unpack b))+ $ False++--+-- And for functions that take non-null input+--+eqnotnull1 f g = \x -> (not (isNull x)) ==> eq1 f g x+eqnotnull2 f g = \x y -> (not (isNull y)) ==> eq2 f g x y+eqnotnull3 f g = \x y z -> (not (isNull z)) ==> eq3 f g x y z++class IsNull t where isNull :: t -> Bool+instance IsNull S where isNull = null+instance C.Encoding a => IsNull (C a) where isNull = C.null+++------------------------------------------------------------------------+-- Exception catching++withCatch :: a -> Maybe a+withCatch a = unsafePerformIO $+ (E.evaluate a >>= return . Just)+ `E.catch`+ (\(E.ErrorCall _) -> return Nothing)++withCatch1 f x = withCatch (f x)+withCatch2 f x y = withCatch (f x y)++--+-- Eq for functions that can throw exceptions+--+eqexcept1 f g = eq1 (withCatch1 f) (withCatch1 g)+eqexcept2 f g = eq2 (withCatch2 f) (withCatch2 g)