diff --git a/Data/CompactString.hs b/Data/CompactString.hs new file mode 100644 --- /dev/null +++ b/Data/CompactString.hs @@ -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 #-} diff --git a/Data/CompactString/ASCII.hs b/Data/CompactString/ASCII.hs new file mode 100644 --- /dev/null +++ b/Data/CompactString/ASCII.hs @@ -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" diff --git a/Data/CompactString/Encodings.hs b/Data/CompactString/Encodings.hs new file mode 100644 --- /dev/null +++ b/Data/CompactString/Encodings.hs @@ -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 diff --git a/Data/CompactString/Fusion.hs b/Data/CompactString/Fusion.hs new file mode 100644 --- /dev/null +++ b/Data/CompactString/Fusion.hs @@ -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 diff --git a/Data/CompactString/Internal.hs b/Data/CompactString/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/CompactString/Internal.hs @@ -0,0 +1,326 @@ +-- | +-- 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 + +#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) diff --git a/Data/CompactString/UTF16.hs b/Data/CompactString/UTF16.hs new file mode 100644 --- /dev/null +++ b/Data/CompactString/UTF16.hs @@ -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" diff --git a/Data/CompactString/UTF8.hs b/Data/CompactString/UTF8.hs new file mode 100644 --- /dev/null +++ b/Data/CompactString/UTF8.hs @@ -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" diff --git a/Data/CompactString/Unsafe.hs b/Data/CompactString/Unsafe.hs new file mode 100644 --- /dev/null +++ b/Data/CompactString/Unsafe.hs @@ -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 diff --git a/Data/CompactString/signatures.include b/Data/CompactString/signatures.include new file mode 100644 --- /dev/null +++ b/Data/CompactString/signatures.include @@ -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 () diff --git a/Data/CompactString/specialized.include b/Data/CompactString/specialized.include new file mode 100644 --- /dev/null +++ b/Data/CompactString/specialized.include @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/compact-string.cabal b/compact-string.cabal new file mode 100644 --- /dev/null +++ b/compact-string.cabal @@ -0,0 +1,42 @@ +name: compact-string +version: 0.3.1 +license: BSD3 +license-file: LICENSE +author: Twan van Laarhoven +maintainer: Twan van Laarhoven +homepage: http://twan.home.fmf.nl/compact-string/ +category: Data +synopsis: Fast, packed and strict strings with Unicode support, based on bytestrings. +description: + Fast, packed, strict strings with a list interface. + Based on "Data.ByteString". + Multiple encodings are supported. + +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 diff --git a/test/Properties.hs b/test/Properties.hs new file mode 100644 --- /dev/null +++ b/test/Properties.hs @@ -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 diff --git a/test/QuickCheckUtils.hs b/test/QuickCheckUtils.hs new file mode 100644 --- /dev/null +++ b/test/QuickCheckUtils.hs @@ -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)