iteratee 0.3.6 → 0.8.9.6
raw patch · 36 files changed
Files
- CONTRIBUTORS +9/−1
- Examples/Tiff.hs +632/−0
- Examples/Wave.hs +330/−0
- Examples/headers.hs +8/−11
- Examples/itertut.lhs +440/−0
- Examples/short.wav binary
- Examples/test_wc.hs +16/−0
- Examples/wave_reader.hs +0/−43
- Examples/word.hs +39/−12
- bench/BenchAll.hs +7/−0
- bench/BenchBase.hs +243/−0
- bench/BenchIO.hs +80/−0
- iteratee.cabal +81/−58
- src/Data/Iteratee.hs +48/−5
- src/Data/Iteratee/Base.hs +224/−750
- src/Data/Iteratee/Base/LooseMap.hs +11/−4
- src/Data/Iteratee/Base/ReadableChunk.hs +52/−0
- src/Data/Iteratee/Base/StreamChunk.hs +0/−95
- src/Data/Iteratee/Binary.hs +166/−46
- src/Data/Iteratee/Char.hs +102/−121
- src/Data/Iteratee/Codecs/Tiff.hs +0/−626
- src/Data/Iteratee/Codecs/Wave.hs +0/−325
- src/Data/Iteratee/Exception.hs +211/−0
- src/Data/Iteratee/IO.hs +119/−35
- src/Data/Iteratee/IO/Fd.hs +120/−145
- src/Data/Iteratee/IO/Handle.hs +119/−97
- src/Data/Iteratee/IO/Interact.hs +22/−25
- src/Data/Iteratee/Iteratee.hs +564/−0
- src/Data/Iteratee/ListLike.hs +1074/−0
- src/Data/Iteratee/PTerm.hs +282/−0
- src/Data/Iteratee/Parallel.hs +127/−0
- src/Data/Iteratee/WrappedByteString.hs +0/−110
- src/Data/NullPoint.hs +27/−0
- src/Data/Nullable.hs +28/−0
- tests/QCUtils.hs +23/−11
- tests/testIteratee.hs +349/−41
CONTRIBUTORS view
@@ -1,13 +1,21 @@ Thanks to the following individuals for contributing to this project. -Brian Buecking Oleg Kiselyov+Michael Baikov+Gregory Collins+Nick Ingolia Brian Lewis+Alex Lang John Lato+Antoine Latter+Ben M Echo Nolan Conrad Parker+Akio Takano Paulo Tanimoto Magnus Therning Johan Tibell Bas van Dijk Valery Vorotyntsev+Maciej Wos+Edward Yang
+ Examples/Tiff.hs view
@@ -0,0 +1,632 @@+{-# LANGUAGE Rank2Types #-}++-- Random and Binary IO with IterateeM++-- A general-purpose TIFF library++-- The library gives the user the TIFF dictionary, which the user+-- can search for specific tags and obtain the values associated with+-- the tags, including the pixel matrix.+--+-- The overarching theme is incremental processing: initially,+-- only the TIFF dictionary is read. The value associated with a tag+-- is read only when that tag is looked up (unless the value was short+-- and was packed in the TIFF dictionary entry). The pixel matrix+-- (let alone the whole TIFF file) is not loaded in memory --+-- the pixel matrix is not even located before it is needed.+-- The matrix is processed incrementally, by a user-supplied+-- iteratee.+--+-- The incremental processing is accomplished by iteratees and enumerators.+-- The enumerators are indeed first-class, they are stored+-- in the interned TIFF dictionary data structure. These enumerators+-- represent the values associated with tags; the values will be read+-- on demand, when the enumerator is applied to a user-given iteratee.+--+-- The library extensively uses nested streams, tacitly converting the+-- stream of raw bytes from the file into streams of integers,+-- rationals and other user-friendly items. The pixel matrix is+-- presented as a contiguous stream, regardless of its segmentation+-- into strips and physical arrangement.+-- The library exhibits random IO and binary parsing, reading+-- of multi-byte numeric data in big- or little-endian formats.+-- The library can be easily adopted for AIFF, RIFF and other+-- IFF formats.+--+-- We show a representative application of the library: reading a sample+-- TIFF file, printing selected values from the TIFF dictionary,+-- verifying the values of selected pixels and computing the histogram+-- of pixel values. The pixel verification procedure stops reading the+-- pixel matrix as soon as all specified pixel values are verified.+-- The histogram accumulation does read the entire matrix, but+-- incrementally. Neither pixel matrix processing procedure loads+-- the whole matrix in memory. In fact, we never read and retain+-- more than the IO-buffer-full of raw data.++-- This TIFF library is to be contrasted with the corresponding Scheme+-- code:+-- http://okmij.org/ftp/Scheme/binary-io.html#tiff+-- The main distinction is using iteratees for on-demand processing.++module Data.Iteratee.Codecs.Tiff where++import Data.Iteratee+import qualified Data.Iteratee as Iter+import qualified Data.ListLike as LL+import Data.Iteratee.Binary+import Control.Monad+import Control.Monad.Trans+import Data.Char (chr)+import Data.Int+import Data.Word+import Data.Ratio+import Data.Maybe+import qualified Data.IntMap as IM+++-- ========================================================================+-- Sample TIFF user code+-- The following is sample code using the TIFF library (whose implementation+-- is in the second part of this file).+-- Our sample code prints interesting information from the TIFF+-- dictionary (such as the dimensions, the resolution and the name+-- of the image)++-- The main user function. tiff_reader is the library function,+-- which builds the TIFF dictionary.+-- process_tiff is the user function, to extract useful data+-- from the dictionary++test_tiff :: FilePath -> IO ()+test_tiff = fileDriverRandom (tiff_reader >>= process_tiff)++-- Sample TIFF processing function+process_tiff :: MonadIO m => Maybe (IM.IntMap TIFFDE) ->+ Iteratee [Word8] m ()+process_tiff Nothing = return ()+process_tiff (Just dict) = do+ note ["dict size: ", show $ IM.size dict]+ -- Check tag values against the known values for the sample image+ check_tag TG_IMAGEWIDTH (flip dict_read_int dict) 129+ check_tag TG_IMAGELENGTH (flip dict_read_int dict) 122+ check_tag TG_BITSPERSAMPLE (flip dict_read_int dict) 8+ check_tag TG_IMAGEDESCRIPTION (flip dict_read_string dict)+ "JPEG:gnu-head-sm.jpg 129x122"+ check_tag TG_COMPRESSION (flip dict_read_int dict) 1+ check_tag TG_SAMPLESPERPIXEL (flip dict_read_int dict) 1+ check_tag TG_STRIPBYTECOUNTS (flip dict_read_int dict) 15738 -- nrows*ncols+ check_tag TG_XRESOLUTION (flip dict_read_rat dict) (72%1)+ check_tag TG_YRESOLUTION (flip dict_read_rat dict) (72%1)++ (n,hist) <- compute_hist dict+ note ["computed histogram over ", show n, " values\n", show hist]+ --iterReportError >>= maybe (return ()) error+ note ["Verifying values of sample pixels"]+ verify_pixel_vals dict [(0,255), (17,248)]+ --err <- iterReportError+ --maybe (return ()) error err+ --return err+ where check_tag tag action v = do+ vc <- action tag+ case vc of+ Just v' | v' == v -> note ["Tag ",show tag, " value ", show v]+ _ -> error $ unwords ["Tag", show tag, "unexpected:", show vc]++-- process_tiff Nothing = return Nothing++-- sample processing of the pixel matrix: computing the histogram+compute_hist :: MonadIO m =>+ TIFFDict ->+ Iteratee [Word8] m (Int,IM.IntMap Int)+compute_hist dict = Iter.joinI $ pixel_matrix_enum dict $ compute_hist' 0 IM.empty+ where+ --compute_hist' count = liftI . Cont . step count+ compute_hist' count hist = icont (step count hist) Nothing+ step count hist (Chunk ch)+ | LL.null ch = icont (step count hist) Nothing+ | otherwise = icont+ (step (count + LL.length ch) (foldr accum hist ch))+ Nothing+ step count hist s = idone (count,hist) s+ accum e = IM.insertWith (+) (fromIntegral e) 1++-- Another sample processor of the pixel matrix: verifying values of+-- some pixels+-- This processor does not read the whole matrix; it stops as soon+-- as everything is verified or the error is detected+verify_pixel_vals :: MonadIO m =>+ TIFFDict -> [(IM.Key, Word8)] -> Iteratee [Word8] m ()+verify_pixel_vals dict pixels = Iter.joinI $ pixel_matrix_enum dict $+ verify 0 (IM.fromList pixels)+ where+ verify _ m | IM.null m = return ()+ verify n m = icont (step n m) Nothing+ step n m (Chunk xs)+ | LL.null xs = icont (step n m) Nothing+ | otherwise = let (h, t) = (LL.head xs, LL.tail xs) in+ case IM.updateLookupWithKey (\_k _e -> Nothing) n m of+ (Just v,m') -> if v == h+ then step (succ n) m' (Chunk t)+ else let er = (unwords ["Pixel #",show n,+ "expected:",show v,+ "found", show h])+ in icont (const . throwErr . iterStrExc $ er) (Just $ iterStrExc er)+ (Nothing,m')-> step (succ n) m' (Chunk t)+ step _n _m s = idone () s+++-- ========================================================================+-- TIFF library code++-- A TIFF directory is a finite map associating a TIFF tag with+-- a record TIFFDE+type TIFFDict = IM.IntMap TIFFDE++data TIFFDE = TIFFDE{tiffde_count :: Int, -- number of items+ tiffde_enum :: TIFFDE_ENUM -- enumerator to get values+ }++type EnumeratorM sFrom sTo m a = Iteratee sTo m a -> m (Iteratee sFrom m a)++joinL :: (Monad m, Nullable s) => m (Iteratee s m a) -> Iteratee s m a+joinL = join . lift++data TIFFDE_ENUM =+ TEN_CHAR (forall a m. Monad m => EnumeratorM [Word8] [Char] m a)+ | TEN_BYTE (forall a m. Monad m => EnumeratorM [Word8] [Word8] m a)+ | TEN_INT (forall a m. Monad m => EnumeratorM [Word8] [Int] m a)+ | TEN_RAT (forall a m. Monad m => EnumeratorM [Word8] [Ratio Int] m a)++-- Standard TIFF data types+data TIFF_TYPE = TT_NONE -- 0+ | TT_byte -- 1 8-bit unsigned integer+ | TT_ascii -- 2 8-bit bytes with last byte null+ | TT_short -- 3 16-bit unsigned integer+ | TT_long -- 4 32-bit unsigned integer+ | TT_rational -- 5 64-bit fractional (numer+denominator)+ -- The following was added in TIFF 6.0+ | TT_sbyte -- 6 8-bit signed (2s-complement) integer+ | TT_undefined -- 7 An 8-bit byte, "8-bit chunk"+ | TT_sshort -- 8 16-bit signed (2s-complement) integer+ | TT_slong -- 9 32-bit signed (2s-complement) integer+ | TT_srational -- 10 "signed rational", two SLONGs (num+denominator)+ | TT_float -- 11 "IEEE 32-bit float", single precision (4-byte)+ | TT_double -- 12 "IEEE 64-bit double", double precision (8-byte)+ deriving (Eq, Enum, Ord, Bounded, Show)+++-- Standard TIFF tags+data TIFF_TAG = TG_other Int -- other than below+ | TG_SUBFILETYPE -- subfile data descriptor+ | TG_OSUBFILETYPE -- +kind of data in subfile+ | TG_IMAGEWIDTH -- image width in pixels+ | TG_IMAGELENGTH -- image height in pixels+ | TG_BITSPERSAMPLE -- bits per channel (sample)+ | TG_COMPRESSION -- data compression technique+ | TG_PHOTOMETRIC -- photometric interpretation+ | TG_THRESHOLDING -- +thresholding used on data+ | TG_CELLWIDTH -- +dithering matrix width+ | TG_CELLLENGTH -- +dithering matrix height+ | TG_FILLORDER -- +data order within a byte+ | TG_DOCUMENTNAME -- name of doc. image is from+ | TG_IMAGEDESCRIPTION -- info about image+ | TG_MAKE -- scanner manufacturer name+ | TG_MODEL -- scanner model name/number+ | TG_STRIPOFFSETS -- offsets to data strips+ | TG_ORIENTATION -- +image orientation+ | TG_SAMPLESPERPIXEL -- samples per pixel+ | TG_ROWSPERSTRIP -- rows per strip of data+ | TG_STRIPBYTECOUNTS -- bytes counts for strips+ | TG_MINSAMPLEVALUE -- +minimum sample value+ | TG_MAXSAMPLEVALUE -- maximum sample value+ | TG_XRESOLUTION -- pixels/resolution in x+ | TG_YRESOLUTION -- pixels/resolution in y+ | TG_PLANARCONFIG -- storage organization+ | TG_PAGENAME -- page name image is from+ | TG_XPOSITION -- x page offset of image lhs+ | TG_YPOSITION -- y page offset of image lhs+ | TG_FREEOFFSETS -- +byte offset to free block+ | TG_FREEBYTECOUNTS -- +sizes of free blocks+ | TG_GRAYRESPONSEUNIT -- gray scale curve accuracy+ | TG_GRAYRESPONSECURVE -- gray scale response curve+ | TG_GROUP3OPTIONS -- 32 flag bits+ | TG_GROUP4OPTIONS -- 32 flag bits+ | TG_RESOLUTIONUNIT -- units of resolutions+ | TG_PAGENUMBER -- page numbers of multi-page+ | TG_COLORRESPONSEUNIT -- color scale curve accuracy+ | TG_COLORRESPONSECURVE -- RGB response curve+ | TG_SOFTWARE -- name & release+ | TG_DATETIME -- creation date and time+ | TG_ARTIST -- creator of image+ | TG_HOSTCOMPUTER -- machine where created+ | TG_PREDICTOR -- prediction scheme w/ LZW+ | TG_WHITEPOINT -- image white point+ | TG_PRIMARYCHROMATICITIES -- primary chromaticities+ | TG_COLORMAP -- RGB map for pallette image+ | TG_BADFAXLINES -- lines w/ wrong pixel count+ | TG_CLEANFAXDATA -- regenerated line info+ | TG_CONSECUTIVEBADFAXLINES -- max consecutive bad lines+ | TG_MATTEING -- alpha channel is present+ deriving (Eq, Show)++tag_map :: Num t => [(TIFF_TAG, t)]+tag_map = [+ (TG_SUBFILETYPE,254),+ (TG_OSUBFILETYPE,255),+ (TG_IMAGEWIDTH,256),+ (TG_IMAGELENGTH,257),+ (TG_BITSPERSAMPLE,258),+ (TG_COMPRESSION,259),+ (TG_PHOTOMETRIC,262),+ (TG_THRESHOLDING,263),+ (TG_CELLWIDTH,264),+ (TG_CELLLENGTH,265),+ (TG_FILLORDER,266),+ (TG_DOCUMENTNAME,269),+ (TG_IMAGEDESCRIPTION,270),+ (TG_MAKE,271),+ (TG_MODEL,272),+ (TG_STRIPOFFSETS,273),+ (TG_ORIENTATION,274),+ (TG_SAMPLESPERPIXEL,277),+ (TG_ROWSPERSTRIP,278),+ (TG_STRIPBYTECOUNTS,279),+ (TG_MINSAMPLEVALUE,280),+ (TG_MAXSAMPLEVALUE,281),+ (TG_XRESOLUTION,282),+ (TG_YRESOLUTION,283),+ (TG_PLANARCONFIG,284),+ (TG_PAGENAME,285),+ (TG_XPOSITION,286),+ (TG_YPOSITION,287),+ (TG_FREEOFFSETS,288),+ (TG_FREEBYTECOUNTS,289),+ (TG_GRAYRESPONSEUNIT,290),+ (TG_GRAYRESPONSECURVE,291),+ (TG_GROUP3OPTIONS,292),+ (TG_GROUP4OPTIONS,293),+ (TG_RESOLUTIONUNIT,296),+ (TG_PAGENUMBER,297),+ (TG_COLORRESPONSEUNIT,300),+ (TG_COLORRESPONSECURVE,301),+ (TG_SOFTWARE,305),+ (TG_DATETIME,306),+ (TG_ARTIST,315),+ (TG_HOSTCOMPUTER,316),+ (TG_PREDICTOR,317),+ (TG_WHITEPOINT,318),+ (TG_PRIMARYCHROMATICITIES,319),+ (TG_COLORMAP,320),+ (TG_BADFAXLINES,326),+ (TG_CLEANFAXDATA,327),+ (TG_CONSECUTIVEBADFAXLINES,328),+ (TG_MATTEING,32995)+ ]++tag_map' :: IM.IntMap TIFF_TAG+tag_map' = IM.fromList $ map (\(tag,v) -> (v,tag)) tag_map++tag_to_int :: TIFF_TAG -> Int+tag_to_int (TG_other x) = x+tag_to_int x = fromMaybe (error $ "not found tag: " ++ show x) $ lookup x tag_map++int_to_tag :: Int -> TIFF_TAG+int_to_tag x = fromMaybe (TG_other x) $ IM.lookup x tag_map'+++-- The library function to read the TIFF dictionary+tiff_reader :: Iteratee [Word8] IO (Maybe TIFFDict)+tiff_reader = do+ endian <- read_magic+ check_version+ case endian of+ Just e -> do+ endianRead4 e >>= Iter.seek . fromIntegral+ load_dict e+ Nothing -> return Nothing+ where+ -- Read the magic and set the endianness+ read_magic = do+ c1 <- Iter.head+ c2 <- Iter.head+ case (c1,c2) of+ (0x4d, 0x4d) -> return $ Just MSB+ (0x49, 0x49) -> return $ Just LSB+ _ -> (throwErr . iterStrExc $ "Bad TIFF magic word: " ++ show [c1,c2])+ >> return Nothing++ -- Check the version in the header. It is always ...+ tiff_version = 42+ check_version = do+ v <- endianRead2 MSB+ if v == tiff_version+ then return ()+ else throwErr (iterStrExc $ "Bad TIFF version: " ++ show v)++-- A few conversion procedures+u32_to_float :: Word32 -> Double+u32_to_float _x = -- unsigned 32-bit int -> IEEE float+ error "u32->float is not yet implemented"++u32_to_s32 :: Word32 -> Int32 -- unsigned 32-bit int -> signed 32 bit+u32_to_s32 = fromIntegral+-- u32_to_s32 0x7fffffff == 0x7fffffff+-- u32_to_s32 0xffffffff == -1++u16_to_s16 :: Word16 -> Int16 -- unsigned 16-bit int -> signed 16 bit+u16_to_s16 = fromIntegral+-- u16_to_s16 32767 == 32767+-- u16_to_s16 32768 == -32768+-- u16_to_s16 65535 == -1++u8_to_s8 :: Word8 -> Int8 -- unsigned 8-bit int -> signed 8 bit+u8_to_s8 = fromIntegral+-- u8_to_s8 127 == 127+-- u8_to_s8 128 == -128+-- u8_to_s8 255 == -1++note :: (MonadIO m, Nullable s) => [String] -> Iteratee s m ()+note = liftIO . putStrLn . concat++-- An internal function to load the dictionary. It assumes that the stream+-- is positioned to read the dictionary+load_dict :: MonadIO m => Endian -> Iteratee [Word8] m (Maybe TIFFDict)+load_dict e = do+ nentries <- endianRead2 e+ dict <- foldr (const read_entry) (return (Just IM.empty)) [1..nentries]+ next_dict <- endianRead4 e+ when (next_dict > 0) $+ note ["The TIFF file contains several images, ",+ "only the first one will be considered"]+ return dict+ where+ read_entry dictM = dictM >>=+ maybe (return Nothing) (\dict -> do+ tag <- endianRead2 e+ typ' <- endianRead2 e+ typ <- convert_type (fromIntegral typ')+ count <- endianRead4 e+ -- we read the val-offset later. We need to check the size and the type+ -- of the datum, because val-offset may contain the value itself,+ -- in its lower-numbered bytes, regardless of the big/little endian+ -- order!++ note ["TIFFEntry: tag ",show . int_to_tag . fromIntegral $ tag,+ " type ", show typ, " count ", show count]+ enum_m <- maybe (return Nothing)+ (\t -> read_value t e (fromIntegral count)) typ+ case enum_m of+ Just enum ->+ return . Just $ IM.insert (fromIntegral tag)+ (TIFFDE (fromIntegral count) enum) dict+ _ -> return (Just dict)+ )++ convert_type :: (Monad m, Nullable s) => Int -> Iteratee s m (Maybe TIFF_TYPE)+ convert_type typ | typ > 0 && typ <= fromEnum (maxBound::TIFF_TYPE)+ = return . Just . toEnum $ typ+ convert_type typ = do+ throwErr . iterStrExc $ "Bad type of entry: " ++ show typ+ return Nothing++ read_value :: MonadIO m => TIFF_TYPE -> Endian -> Int ->+ Iteratee [Word8] m (Maybe TIFFDE_ENUM)++ read_value typ e' 0 = do+ endianRead4 e'+ throwErr . iterStrExc $ "Zero count in the entry of type: " ++ show typ+ return Nothing++ -- Read an ascii string from the offset in the+ -- dictionary. The last byte of+ -- an ascii string is always zero, which is+ -- included in 'count' but we don't need to read it+ read_value TT_ascii e' count | count > 4 = do -- val-offset is offset+ offset <- endianRead4 e'+ return . Just . TEN_CHAR $ \iter_char -> return $ do+ Iter.seek (fromIntegral offset)+ let iter = convStream+ (liftM ((:[]) . chr . fromIntegral) Iter.head)+ iter_char+ Iter.joinI $ Iter.joinI $ Iter.take (pred count) iter++ -- Read the string of 0 to 3 characters long+ -- The zero terminator is included in count, but+ -- we don't need to read it+ read_value TT_ascii _e count = do -- count is within 1..4+ let len = pred count -- string length+ let loop acc 0 = return . Just . reverse $ acc+ loop acc n = Iter.head >>= (\v -> loop ((chr . fromIntegral $ v):acc)+ (pred n))+ str <- loop [] len+ Iter.drop (4-len)+ case str of+ Just str' -> return . Just . TEN_CHAR $ immed_value str'+ Nothing -> return Nothing++ -- Read the array of signed or unsigned bytes+ read_value typ e' count | count > 4 && typ == TT_byte || typ == TT_sbyte = do+ offset <- endianRead4 e'+ return . Just . TEN_INT $ \iter_int -> return $ do+ Iter.seek (fromIntegral offset)+ let iter = convStream+ (liftM ((:[]) . conv_byte typ) Iter.head)+ iter_int+ Iter.joinI $ Iter.joinI $ Iter.take count iter++ -- Read the array of 1 to 4 bytes+ read_value typ _e count | typ == TT_byte || typ == TT_sbyte = do+ let loop acc 0 = return . Just . reverse $ acc+ loop acc n = Iter.head >>= (\v -> loop (conv_byte typ v:acc)+ (pred n))+ str <- (loop [] count)+ Iter.drop (4-count)+ case str of+ Just str' -> return . Just . TEN_INT $ immed_value str'+ Nothing -> return Nothing++ -- Read the array of Word8+ read_value TT_undefined e' count | count > 4 = do+ offset <- endianRead4 e'+ return . Just . TEN_BYTE $ \iter -> return $ do+ Iter.seek (fromIntegral offset)+ Iter.joinI $ Iter.take count iter++ -- Read the array of Word8 of 1..4 elements,+ -- packed in the offset field+ read_value TT_undefined _e count = do+ let loop acc 0 = return . Just . reverse $ acc+ loop acc n = Iter.head >>= (\v -> loop (v:acc) (pred n))+ str <- loop [] count+ Iter.drop (4-count)+ case str of+ Just str' -> return . Just . TEN_BYTE $ immed_value str'+ Nothing -> return Nothing+ --return . Just . TEN_BYTE $ immed_value str++ -- Read the array of short integers++ -- of 1 element: the offset field contains the value+ read_value typ e' 1 | typ == TT_short || typ == TT_sshort = do+ item <- endianRead2 e'+ Iter.drop 2 -- skip the padding+ return . Just . TEN_INT $ immed_value [conv_short typ item]++ -- of 2 elements: the offset field contains the value+ read_value typ e' 2 | typ == TT_short || typ == TT_sshort = do+ i1 <- endianRead2 e'+ i2 <- endianRead2 e'+ return . Just . TEN_INT $+ immed_value [conv_short typ i1, conv_short typ i2]++ -- of n elements+ read_value typ e' count | typ == TT_short || typ == TT_sshort = do+ offset <- endianRead4 e'+ return . Just . TEN_INT $ \iter_int -> return $ do+ Iter.seek (fromIntegral offset)+ let iter = convStream+ (liftM ((:[]) . conv_short typ) (endianRead2 e'))+ iter_int+ Iter.joinI $ Iter.joinI $ Iter.take (2*count) iter+++ -- Read the array of long integers+ -- of 1 element: the offset field contains the value+ read_value typ e' 1 | typ == TT_long || typ == TT_slong = do+ item <- endianRead4 e'+ return . Just . TEN_INT $ immed_value [conv_long typ item]++ -- of n elements+ read_value typ e' count | typ == TT_long || typ == TT_slong = do+ offset <- endianRead4 e'+ return . Just . TEN_INT $ \iter_int -> return $ do+ Iter.seek (fromIntegral offset)+ let iter = convStream+ (liftM ((:[]) . conv_long typ) (endianRead4 e'))+ iter_int+ Iter.joinI $ Iter.joinI $ Iter.take (4*count) iter+++ read_value typ e' count = do -- stub+ _offset <- endianRead4 e'+ note ["unhandled type: ", show typ, " with count ", show count]+ return Nothing++ immed_value :: (Monad m) => [el] -> EnumeratorM [Word8] [el] m a+ immed_value item iter =+ --(Iter.enumPure1Chunk item >. enumEof) iter >>== Iter.joinI . return+ return . joinI . return . joinIM $ (enumPure1Chunk item >>> enumEof) iter++ conv_byte :: TIFF_TYPE -> Word8 -> Int+ conv_byte TT_byte = fromIntegral+ conv_byte TT_sbyte = fromIntegral . u8_to_s8+ conv_byte _ = error "conv_byte called with non-byte type"++ conv_short :: TIFF_TYPE -> Word16 -> Int+ conv_short TT_short = fromIntegral+ conv_short TT_sshort = fromIntegral . u16_to_s16+ conv_short _ = error "conv_short called with non-short type"++ conv_long :: TIFF_TYPE -> Word32 -> Int+ conv_long TT_long = fromIntegral+ conv_long TT_slong = fromIntegral . u32_to_s32+ conv_long _ = error "conv_long called with non-long type"++-- Reading the pixel matrix+-- For simplicity, we assume no compression and 8-bit pixels+pixel_matrix_enum :: MonadIO m => TIFFDict -> Enumeratee [Word8] [Word8] m a+pixel_matrix_enum dict iter = validate_dict >>= proceed+ where+ -- Make sure we can handle this particular TIFF image+ validate_dict = do+ dict_assert TG_COMPRESSION 1+ dict_assert TG_SAMPLESPERPIXEL 1+ dict_assert TG_BITSPERSAMPLE 8+ ncols <- liftM (fromMaybe 0) $ dict_read_int TG_IMAGEWIDTH dict+ nrows <- liftM (fromMaybe 0) $ dict_read_int TG_IMAGELENGTH dict+ strip_offsets <- liftM (fromMaybe [0]) $+ dict_read_ints TG_STRIPOFFSETS dict+ rps <- liftM (fromMaybe nrows) (dict_read_int TG_ROWSPERSTRIP dict)+ if ncols > 0 && nrows > 0 && rps > 0+ then return $ Just (ncols,nrows,rps,strip_offsets)+ else return Nothing++ dict_assert tag v = do+ vfound <- dict_read_int tag dict+ case vfound of+ Just v' | v' == v -> return $ Just ()+ _ -> throwErr (iterStrExc (unwords ["dict_assert: tag:", show tag,+ "expected:", show v, "found:", show vfound])) >>+ return Nothing++ proceed Nothing = throwErr $ iterStrExc "Can't handle this TIFF"++ proceed (Just (ncols,nrows,rows_per_strip,strip_offsets)) = do+ let strip_size = rows_per_strip * ncols+ image_size = nrows * ncols+ note ["Processing the pixel matrix, ", show image_size, " bytes"]+ let loop _pos [] iter' = return iter'+ loop pos (strip:strips) iter' = do+ Iter.seek (fromIntegral strip)+ let len = min strip_size (image_size - pos)+ iter'' <- Iter.take (fromIntegral len) iter'+ loop (pos+len) strips iter''+ loop 0 strip_offsets iter+++-- A few helpers for getting data from TIFF dictionary++dict_read_int :: Monad m => TIFF_TAG -> TIFFDict ->+ Iteratee [Word8] m (Maybe Int)+dict_read_int tag dict = do+ els <- dict_read_ints tag dict+ case els of+ Just (e:_) -> return $ Just e+ _ -> return Nothing++dict_read_ints :: Monad m => TIFF_TAG -> TIFFDict ->+ Iteratee [Word8] m (Maybe [Int])+dict_read_ints tag dict =+ case IM.lookup (tag_to_int tag) dict of+ Just (TIFFDE _ (TEN_INT enum)) -> do+ e <- joinL $ enum stream2list+ return (Just e)+ _ -> return Nothing++dict_read_rat :: Monad m => TIFF_TAG -> TIFFDict ->+ Iteratee [Word8] m (Maybe (Ratio Int))+dict_read_rat tag dict =+ case IM.lookup (tag_to_int tag) dict of+ Just (TIFFDE 1 (TEN_RAT enum)) -> do+ [e] <- joinL $ enum stream2list+ return (Just e)+ _ -> return Nothing++dict_read_string :: Monad m => TIFF_TAG -> TIFFDict ->+ Iteratee [Word8] m (Maybe String)+dict_read_string tag dict =+ case IM.lookup (tag_to_int tag) dict of+ Just (TIFFDE _ (TEN_CHAR enum)) -> do+ e <- joinL $ enum stream2list+ return (Just e)+ _ -> return Nothing
+ Examples/Wave.hs view
@@ -0,0 +1,330 @@+{-# LANGUAGE RankNTypes, FlexibleContexts #-}++{-++This module is not meant primarily for instructive and pedagogical purposes.+As such, it is not fully featured, and sacrifices performance and generality+for clarity of code.++-}++module Data.Iteratee.Codecs.Wave {-# DEPRECATED "This will be moved to a separate package in the future" #-} (+ WAVEDE (..),+ WAVEDE_ENUM (..),+ WAVE_CHUNK (..),+ AudioFormat (..),+ waveReader,+ readRiff,+ waveChunk,+ chunkToString,+ dictReadFormat,+ dictReadFirstFormat,+ dictReadLastFormat,+ dictReadFirstData,+ dictReadLastData,+ dictReadData,+ dictProcessData+)+where++import Prelude as P+import Control.Monad (join)+import Control.Monad.Trans (lift)+import Data.Iteratee+import qualified Data.Iteratee as Iter+import Data.Iteratee.Binary+import Data.Char (chr, ord)+import Data.Int+import Data.Word+import Data.Bits (shiftL)+import Data.Maybe+import qualified Data.IntMap as IM++-- =====================================================+-- WAVE libary code++-- useful type synonyms++-- |A WAVE directory is a list associating WAVE chunks with+-- a record WAVEDE+type WAVEDict = IM.IntMap [WAVEDE]++data WAVEDE = WAVEDE{+ wavede_count :: Int, -- ^length of chunk+ wavede_type :: WAVE_CHUNK, -- ^type of chunk+ wavede_enum :: WAVEDE_ENUM -- ^enumerator to get values of chunk+ }++type EnumeratorM sFrom sTo m a = Iteratee sTo m a -> m (Iteratee sFrom m a)++joinL :: (Monad m, Nullable s) => m (Iteratee s m a) -> Iteratee s m a+joinL = join . lift++data WAVEDE_ENUM =+ WEN_BYTE (forall a. EnumeratorM [Word8] [Word8] IO a)+ | WEN_DUB (forall a. EnumeratorM [Word8] [Double] IO a)++-- |Standard WAVE Chunks+data WAVE_CHUNK = WAVE_FMT -- ^Format+ | WAVE_DATA -- ^Data+ | WAVE_OTHER String -- ^Other+ deriving (Eq, Ord, Show)+instance Enum WAVE_CHUNK where+ fromEnum WAVE_FMT = 1+ fromEnum WAVE_DATA = 2+ fromEnum (WAVE_OTHER _) = 3+ toEnum 1 = WAVE_FMT+ toEnum 2 = WAVE_DATA+ toEnum 3 = WAVE_OTHER ""+ toEnum _ = error "Invalid enumeration value"++-- -----------------+-- wave chunk reading/writing functions++-- |Convert a string to WAVE_CHUNK type+waveChunk :: String -> Maybe WAVE_CHUNK+waveChunk str+ | str == "fmt " = Just WAVE_FMT+ | str == "data" = Just WAVE_DATA+ | P.length str == 4 = Just $ WAVE_OTHER str+ | otherwise = Nothing++-- |Convert a WAVE_CHUNK to the representative string+chunkToString :: WAVE_CHUNK -> String+chunkToString WAVE_FMT = "fmt "+chunkToString WAVE_DATA = "data"+chunkToString (WAVE_OTHER str) = str++-- -----------------+data AudioFormat = AudioFormat {+ numberOfChannels :: NumChannels, -- ^Number of channels in the audio data+ sampleRate :: SampleRate, -- ^Sample rate of the audio+ bitDepth :: BitDepth -- ^Bit depth of the audio data+ } deriving (Show, Eq)++type NumChannels = Integer+type SampleRate = Integer+type BitDepth = Integer++-- convenience function to read a 4-byte ASCII string+stringRead4 :: Monad m => Iteratee [Word8] m String+stringRead4 = do+ s1 <- Iter.head+ s2 <- Iter.head+ s3 <- Iter.head+ s4 <- Iter.head+ return $ map (chr . fromIntegral) [s1, s2, s3, s4]++-- -----------------++-- |The library function to read the WAVE dictionary+waveReader :: Iteratee [Word8] IO (Maybe WAVEDict)+waveReader = do+ readRiff+ tot_size <- endianRead4 LSB+ readRiffWave+ chunks_m <- findChunks $ fromIntegral tot_size+ loadDict $ joinM chunks_m++-- |Read the RIFF header of a file.+readRiff :: Iteratee [Word8] IO ()+readRiff = do+ cnt <- heads $ fmap (fromIntegral . ord) "RIFF"+ if cnt == 4 then return () else throwErr $ iterStrExc "Bad RIFF header"++-- | Read the WAVE part of the RIFF header.+readRiffWave :: Iteratee [Word8] IO ()+readRiffWave = do+ cnt <- heads $ fmap (fromIntegral . ord) "WAVE"+ if cnt == 4 then return () else throwErr $ iterStrExc "Bad RIFF/WAVE header"++-- | An internal function to find all the chunks. It assumes that the+-- stream is positioned to read the first chunk.+findChunks :: Int -> Iteratee [Word8] IO (Maybe [(Int, WAVE_CHUNK, Int)])+findChunks n = findChunks' 12 []+ where+ findChunks' offset acc = do+ typ <- stringRead4+ count <- endianRead4 LSB+ case waveChunk typ of+ Nothing -> (throwErr . iterStrExc $ "Bad subchunk descriptor: " ++ show typ)+ >> return Nothing+ Just chk -> let newpos = offset + 8 + count in+ case newpos >= fromIntegral n of+ True -> return . Just $ reverse $+ (fromIntegral offset, chk, fromIntegral count) : acc+ False -> do+ Iter.seek $ fromIntegral newpos+ findChunks' newpos $+ (fromIntegral offset, chk, fromIntegral count) : acc++loadDict :: [(Int, WAVE_CHUNK, Int)] ->+ Iteratee [Word8] IO (Maybe WAVEDict)+loadDict = P.foldl read_entry (return (Just IM.empty))+ where+ read_entry dictM (offset, typ, count) = dictM >>=+ maybe (return Nothing) (\dict -> do+ enum_m <- readValue dict offset typ count+ case (enum_m, IM.lookup (fromEnum typ) dict) of+ (Just enum, Nothing) -> --insert new entry+ return . Just $ IM.insert (fromEnum typ)+ [WAVEDE (fromIntegral count) typ enum] dict+ (Just enum, Just _vals) -> --existing entry+ return . Just $ IM.update+ (\ls -> Just $ ls ++ [WAVEDE (fromIntegral count) typ enum])+ (fromEnum typ) dict+ (Nothing, _) -> return (Just dict)+ )++readValue :: WAVEDict ->+ Int -> -- Offset+ WAVE_CHUNK -> -- Chunk type+ Int -> -- Count+ Iteratee [Word8] IO (Maybe WAVEDE_ENUM)+readValue _dict offset _ 0 = do+ throwErr . iterStrExc $ "Zero count in the entry of chunk at: " ++ show offset+ return Nothing++readValue dict offset WAVE_DATA count = do+ fmt_m <- dictReadLastFormat dict+ case fmt_m of+ Just fmt ->+ return . Just . WEN_DUB $ \iter_dub -> return $ do+ Iter.seek (8 + fromIntegral offset)+ let iter = Iter.convStream (convFunc fmt) iter_dub+ joinI . joinI . Iter.take count $ iter+ Nothing -> do+ throwErr . iterStrExc $ "No valid format for data chunk at: " ++ show offset+ return Nothing++-- return the WaveFormat iteratee+readValue _dict offset WAVE_FMT count =+ return . Just . WEN_BYTE $ \iter -> return $ do+ Iter.seek (8 + fromIntegral offset)+ Iter.joinI $ Iter.take count iter++-- for WAVE_OTHER, return Word8s and maybe the user can parse them+readValue _dict offset (WAVE_OTHER _str) count =+ return . Just . WEN_BYTE $ \iter -> return $ do+ Iter.seek (8 + fromIntegral offset)+ Iter.joinI $ Iter.take count iter+++-- |Convert Word8s to Doubles+convFunc :: AudioFormat -> Iteratee [Word8] IO [Double]+convFunc (AudioFormat _nc _sr 8) = fmap+ ((:[]) . normalize 8 . (fromIntegral :: Word8 -> Int8))+ Iter.head+convFunc (AudioFormat _nc _sr 16) = fmap+ ((:[]) . normalize 16 . (fromIntegral :: Word16 -> Int16))+ (endianRead2 LSB)+convFunc (AudioFormat _nc _sr 24) = fmap+ ((:[]) . normalize 24 . (fromIntegral :: Word32 -> Int32))+ (endianRead3 LSB)+convFunc (AudioFormat _nc _sr 32) = fmap+ ((:[]) . normalize 32 . (fromIntegral :: Word32 -> Int32))+ (endianRead4 LSB)+convFunc _ = error "unrecognized audio format in convFunc"++eitherToMaybe :: Either a b -> Maybe b+eitherToMaybe = either (const Nothing) Just++-- |An Iteratee to read a wave format chunk+sWaveFormat :: Iteratee [Word8] IO (Maybe AudioFormat)+sWaveFormat = do+ f' <- endianRead2 LSB --data format, 1==PCM+ nc <- endianRead2 LSB+ sr <- endianRead4 LSB+ Iter.drop 6+ bd <- endianRead2 LSB+ case f' == 1 of+ True -> return . Just $ AudioFormat (fromIntegral nc)+ (fromIntegral sr)+ (fromIntegral bd)+ False -> return Nothing++-- ---------------------+-- functions to assist with reading from the dictionary++-- |Read the first format chunk in the WAVE dictionary.+dictReadFirstFormat :: WAVEDict -> Iteratee [Word8] IO (Maybe AudioFormat)+dictReadFirstFormat dict = case IM.lookup (fromEnum WAVE_FMT) dict of+ Just [] -> return Nothing+ Just ((WAVEDE _ WAVE_FMT (WEN_BYTE enum)) : _xs) -> joinIM $ enum sWaveFormat+ _ -> return Nothing++-- |Read the last fromat chunk from the WAVE dictionary. This is useful+-- when parsing all chunks in the dictionary.+dictReadLastFormat :: WAVEDict -> Iteratee [Word8] IO (Maybe AudioFormat)+dictReadLastFormat dict = case IM.lookup (fromEnum WAVE_FMT) dict of+ Just [] -> return Nothing+ Just xs -> let (WAVEDE _ WAVE_FMT (WEN_BYTE enum)) = last xs in+ joinIM $ enum sWaveFormat+ _ -> return Nothing++-- |Read the specified format chunk from the WAVE dictionary+dictReadFormat :: Int -> --Index in the format chunk list to read+ WAVEDict -> --Dictionary+ Iteratee [Word8] IO (Maybe AudioFormat)+dictReadFormat ix dict = case IM.lookup (fromEnum WAVE_FMT) dict of+ Just xs -> let (WAVEDE _ WAVE_FMT (WEN_BYTE enum)) = (!!) xs ix in+ joinIM $ enum sWaveFormat+ _ -> return Nothing++-- |Read the first data chunk in the WAVE dictionary.+dictReadFirstData :: WAVEDict -> Iteratee [Word8] IO (Maybe [Double])+dictReadFirstData dict = case IM.lookup (fromEnum WAVE_DATA) dict of+ Just [] -> return Nothing+ Just ((WAVEDE _ WAVE_DATA (WEN_DUB enum)) : _xs) -> do+ e <- joinIM $ enum Iter.stream2list+ return $ Just e+ _ -> return Nothing++-- |Read the last data chunk in the WAVE dictionary.+dictReadLastData :: WAVEDict -> Iteratee [Word8] IO (Maybe [Double])+dictReadLastData dict = case IM.lookup (fromEnum WAVE_DATA) dict of+ Just [] -> return Nothing+ Just xs -> let (WAVEDE _ WAVE_DATA (WEN_DUB enum)) = last xs in do+ e <- joinIM $ enum Iter.stream2list+ return $ Just e+ _ -> return Nothing++-- |Read the specified data chunk from the WAVE dictionary.+dictReadData :: Int -> --Index in the data chunk list to read+ WAVEDict -> --Dictionary+ Iteratee [Word8] IO (Maybe [Double])+dictReadData ix dict = case IM.lookup (fromEnum WAVE_DATA) dict of+ Just xs -> let (WAVEDE _ WAVE_DATA (WEN_DUB enum)) = (!!) xs ix in do+ e <- joinIM $ enum Iter.stream2list+ return $ Just e+ _ -> return Nothing++-- |Read the specified data chunk from the dictionary, applying the+-- data to the specified Iteratee.+dictProcessData :: Int -> -- Index in the data chunk list to read+ WAVEDict -> -- Dictionary+ Iteratee [Double] IO a ->+ Iteratee [Word8] IO (Maybe a)+dictProcessData ix dict iter = case IM.lookup (fromEnum WAVE_DATA) dict of+ Just xs -> let (WAVEDE _ WAVE_DATA (WEN_DUB enum)) = (!!) xs ix in do+ e <- joinIM $ enum iter+ return $ Just e+ _ -> return Nothing++-- ---------------------+-- convenience functions++-- |Convert (Maybe []) to []. Nothing maps to an empty list.+joinM :: Maybe [a] -> [a]+joinM Nothing = []+joinM (Just a) = a++-- |Normalize a given value for the provided bit depth.+normalize :: Integral a => BitDepth -> a -> Double+normalize 8 a = (fromIntegral a - 128) / 128+normalize bd a = case (a > 0) of+ True -> fromIntegral a / divPos+ False -> fromIntegral a / divNeg+ where+ divPos = fromIntegral (1 `shiftL` fromIntegral (bd - 1) :: Int) - 1+ divNeg = fromIntegral (1 `shiftL` fromIntegral (bd - 1) :: Int)
Examples/headers.hs view
@@ -63,7 +63,7 @@ read_hex acc (d:rest) | isHexDigit d = read_hex (16*acc + digitToInt d) rest read_hex acc _ = Nothing - frame_err e iter = IterateeG (\_ ->+ frame_err e iter = IterateeT (\_ -> return $ Cont (joinIM $ enumErr e iter) (Just $ Err "Frame error")) @@ -74,7 +74,7 @@ read_lines_rest :: Iteratee Identity (Either [Line] [Line], String) read_lines_rest = do- ls <- readLines+ ls <- readLines ErrOnEof rest <- Iter.break (const False) return (ls, rest) @@ -106,7 +106,7 @@ test_driver_full filepath = do putStrLn "About to read headers"- result <- fileDriver (mapStream mapfn read_headers_body) filepath >>= run+ result <- fileDriver read_headers_body filepath putStrLn "Finished reading" case result of (Right headers, Right body, _) ->@@ -128,12 +128,10 @@ putStrLn "Incomplete body" print body where- mapfn :: Word8 -> Char- mapfn = chr . fromIntegral read_headers_body = do- headers <- readLines- body <- joinIM $ enum_chunk_decoded readLines- status <- isFinished+ headers <- readLines ErrOnEof+ body <- joinIM . enum_chunk_decoded $ readLines ErrOnEof+ status <- getStatus return (headers, body, status) test31 = do@@ -142,7 +140,7 @@ putStrLn "Finished reading" putStrLn "Complete headers" putStrLn "[\"header1: v1\",\"header2: v2\",\"header3: v3\",\"header4: v4\"]"- putStrLn "Problem Just (Err \"EOF\")"+ putStrLn "Problem EofNoError" putStrLn "Incomplete body" putStrLn "[\"body line 1\",\"body line 2\",\"body line 3\",\"body line 4\"]" putStrLn ""@@ -164,11 +162,10 @@ putStrLn "Finished reading" putStrLn "Complete headers" putStrLn "[\"header1: v1\",\"header2: v2\",\"header3: v3\",\"header4: v4\"]"- putStrLn "Problem Just (Err \"EOF\")"+ putStrLn "Problem EofNoError" putStrLn "Incomplete body" putStrLn "[\"body line 1\",\"body line 2\",\"body line 3\",\"body line 4\",\"body line 5\"]" putStrLn "" putStrLn "Actual result is:" test_driver_full "test_full3.txt"-
+ Examples/itertut.lhs view
@@ -0,0 +1,440 @@+> {-# LANGUAGE RankNTypes #-}+>+> module IterTut where+>+> import Prelude hiding (drop, take)+> import Data.Iteratee+> import qualified Data.ListLike as LL+> import Control.Monad.Identity++Reference material on Iteratees :++http://okmij.org/ftp/Streams.html++http://ianen.org/articles/understanding-iteratees/++This tutorial is based on+http://okmij.org/ftp/Haskell/Iteratee/IterateeIO-talk-notes.pdf+amongst other sources. Hopefully you will find my additions positive.++[This tutorial is still incomplete, however I am including it in this release+as I hope the section on the CPS transform will be useful to users+switching to the new library. JL]++Exercises : given a text file of Ints separated by newlines, write a+function which returns the first Int greater than a given k, or+Nothing. Do this once using explicit handle operations (hGetLine) and+again using lazy IO (hGetContents.)++Problems : Handle IO is inconvenient : imperative, not composeable.+LazyIO (e.g. hGetContents) has unreliable semantics : when do the+handles get closed? What is the resouce usage? This example is a+toy -- imagine parsing HTTP requests in a high-performance server.+Imperative parsers are ugly, but we cannot sacrifice performance and+use lazy IO.++Oleg's solution : realize IO as left folds over streams. Recall the+left fold++foldl :: (a -> b -> a) -> a -> [b] -> a++This is broken up into three parts : the input list [b], the worker+function (a -> b -> a) and initial state a, and the folding+function itself ("fold").++The input list is generalized into the Stream type :++> type ErrMsg = String+>+> data BasicStream a = B_Chunk [a] | B_EOF (Maybe ErrMsg)++We support chunked reads and non-blocking IO. B_Chunk [] means the+handle is open but there isn't data available yet.++The worker function (plus state) is generalized into the Iteratee type :++> data BasicIteratee a b = Done b (BasicStream a)+> | Cont (BasicStream a -> BasicIteratee a b) (Maybe ErrMsg)++An iteratee is either done, returning a value and the remaining input,+or ready for more input. The first argument to B_Cont is a function+that accepts more input, and advances the iteratee's state -- a+"continuation." An iteratee can possibly be in an error state+(e.g. if parsing invalid data), as indicated by the second argument.++Simple examples :++> peekB :: BasicIteratee a (Maybe a)+> peekB = Cont step Nothing+> where step (B_Chunk []) = peekB+> step c@(B_Chunk (x:xs)) = Done (Just x) c+> step stream = Done Nothing stream+>+> headBI :: BasicIteratee a a+> headBI = Cont step Nothing+> where step (B_Chunk []) = headBI+> step c@(B_Chunk (x:xs)) = Done x $ B_Chunk xs+> step iter = Cont step $ Just "EOF"+>+> throwErrB :: ErrMsg -> BasicIteratee a b+> throwErrB e = Cont (\_ -> throwErrB e) (Just e)+>+> dropB :: Int -> BasicIteratee a ()+> dropB n = Cont (step n) Nothing+> where step 0 st = Done () st+++peek returns the next element, or Nothing if the stream is EOF.+headBI is like head.++The folding function is generalized to the Enumerator type. It's job+is to feed an iteratee the contents of some resource, until it is+exhausted or the iteratee is done.++> type BasicEnumerator a b = BasicIteratee a b -> BasicIteratee a b++The simplest enumerator just feeds EOF :++> sendEOF :: BasicEnumerator a b+> sendEOF (Cont k Nothing) =+> case k $ B_EOF Nothing of+> iter@(Cont _ Nothing) -> throwErrB "Divergent iteratee"+> iter -> iter+> sendEOF (Done x _) = Done x $ B_EOF Nothing+> sendEOF i = i++We can feed the contents of a list to an iteratee :++> enumListB :: [a] -> BasicEnumerator a b+> enumListB lst (Cont k Nothing) = k $ B_Chunk lst+> enumListB _ i = i+>+> enumListNChunkB :: [a] -> Int -> BasicEnumerator a b+> enumListNChunkB ls n it+> | n <= 0 = error "Invalid n"+> | Prelude.null ls = it+> | otherwise =+> case it of+> Cont k Nothing -> enumListNChunkB t n $ k (B_Chunk h)+> where (h,t) = splitAt n ls+> _ -> it++The first sends the list in one big chunk; the second in chunks of+size no larger than n.++Advantages :++One perspective : lazy IO does not couple the resource (the handle)+with the demand tightly enough -- the list interface is too abstract.+The iteratee / enumerator protocol makes the demand explicit, and the+continuation passing style makes resource lifetime understandable.++------------------------+Composition : Horizontal+------------------------++Iteratees, unlike Handle IO, are compositional in many ways. First is+"horizontal" :++> instance Monad (BasicIteratee a) where++Monadic composition is chaining iteratees : "horizontal." In the+simplest case, if the first iteratee is done without any remaining+input, we pass the value it returns to the function f.++> Done x (B_Chunk []) >>= f = f x++If it is done but has more input or an EOF, we pass that to the next+iteratee.++> Done x st >>= f = case f x of++If the next iteratee is also done, it is safe to ignore the "rest" of+its "stream", since it was not actually fed any input. Otherwise we+pass the stream (or error state) along.++> Done y _ -> Done y st+> Cont k Nothing -> k st+> i -> i++If the first iteratee wants to continue, the composition continues.+If f has type b -> BasicIteratee a c, then (>>= f) has type+BasicIteratee a b -> BasicIteratee a c.++> Cont k e >>= f = Cont ((>>= f) . k) e++Meanwhile a monadic value is a done iteratee returning the value.++> return x = Done x (B_Chunk [])+++functors, applicative+enumerator composition++----------------------+Composition : Vertical+----------------------++joinI, enumeratees++> type BasicEnumeratee outer inner out =+> BasicIteratee inner out -> BasicIteratee outer (BasicIteratee inner out)++'takeB' sends only the first n elements of the stream to the inner iteratee; even if more are available.++> takeB :: Int -> BasicEnumeratee a a b+> takeB 0 iter = return iter+> takeB n it@(Done x _) = dropB n >> return (return x)+> takeB n it@(Cont _ (Just e)) = dropB n >> throwErrB e+> takeB n it@(Cont k Nothing) = Cont (step n k) Nothing+> where step n k (B_Chunk []) = Cont (step n k) Nothing+> step n k c@(B_Chunk l)+> | Prelude.length l < n = takeB (n - Prelude.length l) $ k c+> | otherwise = Done (k (B_Chunk h)) (B_Chunk t)+> where (h,t) = splitAt n l+> step n k st = Done (k st) st++---------------+Generalizations+---------------++StreamG, ListLike, Nullable / NullPoint : turn pattern-matching on+lists into guards++---------------+Monadic actions+---------------++> type BasicEnumeratorM m a b = BasicIteratee a b -> m (BasicIteratee a b)++BasicIterateeM, BasicEnumeratorM, BasicEnumerateeM+++---------+CPS-style+---------++The actual iteratee library is "CPS transformed." (See Oleg's+IterateeMCPS.hs.) It uses CPS on two levels : the first is in the+continuation for the Cont state, and the second is to eliminate+constructors.++newtype Iteratee s m a = Iteratee {+ runIter :: forall r.+ (a -> StreamG s -> m r) ->+ ((StreamG s -> Iteratee s m a) -> Maybe SomeException -> m r) ->+ m r }++The two arguments are continuations which return a value of type m r+(for some Monad m); the iteratee will call one of these two+continuations and return the value. The first argument is the+continuation to call if the iteratee is in the "Done" state, the+second if in the "Cont" state.++Basic rule : replace separate constructors with calls to the+appropriate arguments, and pattern matching with continuations passed+into the appropriate argument.++Streams stay the same.++Iteratees :++an iteratee in state X ==> a function that calls continuation X+B_Done x s ==> Iteratee $ \onDone _ -> onDone x s+B_Cont k e ==> Iteratee $ \_ onCont -> onCont k' e++where k' s is the transformation of the BasicIteratee k s.++Some synonyms :++idone x s = Iteratee $ \od _ -> od x s+return x = idone x (Chunk empty)+icont k e = Iteratee $ \_ oc -> oc k e+liftI k = icont k Nothing++so B_Cont k Nothing = liftI k'.++Example :++headBI :: BasicIteratee a a+headBI = Cont step Nothing -- turns into liftI step'+ where step (B_Chunk []) = headBI -- ListLike guard+ step c@(B_Chunk (x:xs)) = Done x $ B_Chunk xs -- Done ==> idone+ step iter = Cont step $ Just $ ErrMsg "EOF" -- Cont ==> icont++==>++> headI :: (Monad m, LL.ListLike s a) => Iteratee s m a+> headI = liftI step'+> where step' (Chunk c)+> | LL.null c = headI+> | otherwise = idone (LL.head c) (Chunk $ LL.tail c)+> step' st = icont step' (Just (setEOF st))++If the state of the iteratee depends some other parameter, the result+of the continuation will be an argument of both state arguments (and+the parameter.)++myit x = Iteratee step+ where step od oc = ...++Enumerators :++pattern-match on an iteratee in state X => pass continuation into+iteratee argument X++case iter of+ B_Done x s -> f x s+ B_cont k e -> g k e++==>++runIter iter onDone onCont+ where onDone x s = f' x s+ onCont k e = g' k e++where f' x s is the transformation of the (monadic) iteratee f x s,+and likewise for g' k e.++Example : the identity (monadic) enumerator++> idIB :: (Monad m) => BasicEnumeratorM m a b+> idIB (Done x s) = return $ Done x s+> idIB (Cont k e) = return $ Cont k e++is transformed into++> idI iter = runIter iter onDone onCont+> where onDone x s = return $ idone x s+> onCont k e = return $ icont k e++With the synonyms++idoneM = return . idone+icontM = return . icont++this simplifies to++> idI' iter = runIter iter idoneM icontM++Example :++enumListNChunkB :: [a] -> Int -> BasicEnumerator a b+enumListNChunkB ls n it+ | n <= 0 = error "Invalid n"+ | Prelude.null ls = it+ | otherwise =+ case it of+ Cont k Nothing -> enumListNChunkB t n $ k (B_Chunk h)+ where (h,t) = splitAt n ls+ _ -> it++==>++> enumListNChunks :: (Monad m, LL.ListLike s el) =>+> s -> Int -> Enumerator s m b+> enumListNChunks ls n it+> | n <= 0 = error "Invalid n"+> | LL.null ls = return it+> | otherwise = runIter it idoneM onCont -- idoneM is the identity in the Done state+> where onCont k Nothing = enumListNChunks t n $ k (Chunk h)+> where (h, t) = LL.splitAt n ls+> onCont k e = icontM k e -- icontM is the identity in the Cont state++Enumeratees :++("iteratees and enumerators at the same time.") An example to keep in mind.++mapB :: (el -> el') -> BasicEnumeratee el el' a+mapB f it@(Done _ _) = Done it (B_Chunk [])+mapB _ it@(Cont k (Just e)) = throwErrB e+mapB f it@(Cont k Nothing) = Cont step Nothing+ where step (B_Chunk s) = mapB f $ k (B_Chunk $ map f s)+ step (B_EOF e) = mapB f $ k (B_EOF e)++Let's try our hand at a translation :++mapI f inner = ...++An idiom : the return value is a nested iteratee, with an outer+("from") part and an inner part ("to"). According to our iteratee+translation this is++mapI f inner = Iteratee $ \onDoneF onContF -> ...++The result of this outer iteratee typically depends on the state of+the inner iteratee. Hence like with Enumerators we do a "pattern match"++mapI f inner = Iteratee $ \onDoneF onContF ->+ let onDoneT x s = ...+ onContT k e = ...+ in runIter inner onDoneT onContT++I've prefered using let instead of a where because it keeps the outer+continuations onDoneF and onContF in scope. One of onDoneT or onContT+will get called, depending on what state the "To" iteratee is in.+Remember though we want to eventually call either onDoneF or onContF+to signal what state the outer "From" iteratee is in. In the simplest+cases we will simply directly call them, e.g.++mapB f it@(Done _ _) = Done it (B_Chunk [])+===>+let onDoneT x s = onDoneF it (Chunk empty)++If we however build up our desired iteratee value via combinators, we+need to remember to pass them the outer continuation messages :++mapB _ it@(Cont k (Just e)) = throwErrB e -- this is a Cont iteratee+===>+let onContT k (Just e) = runIter (throwErr e) onDoneF onContF++Note only onContF will get called, since throwErr delivers a+continuing iteratee.++The complete translation (we've truncated onDoneF to odf, etc.) :++> mapI :: (Monad m, LL.ListLike (s el) el, LL.ListLike (s el') el',+> NullPoint (s el), NullPoint (s el') ) =>+> (el -> el') -> Enumeratee (s el) (s el') m a+> mapI f it = Iteratee $ \odf ocf ->+> let odt x s = odf it (Chunk empty)+> oct _ (Just e) = runIter (throwErr e) odf ocf+> oct k Nothing = ocf step Nothing+> where+> step (Chunk xs)+> | LL.null xs = icont step Nothing+> | otherwise = mapI f $ k (Chunk $ LL.map f xs)+> step (EOF e) = mapI f $ k (EOF e)+> in runIter it odt oct++Another example :++takeB :: Int -> BasicEnumeratee a a b+takeB 0 iter = return iter+takeB n it@(Done x _) = dropB n >> return (return x)+takeB n it@(Cont _ (Just e)) = dropB n >> throwErrB e+takeB n it@(Cont k Nothing) = Cont (step n k) Nothing+ where step n k (B_Chunk []) = Cont (step n k) Nothing+ step n k c@(B_Chunk l)+ | Prelude.length l < n = takeB (n - Prelude.length l) $ k c+ | otherwise = Done (k (B_Chunk h)) (B_Chunk t)+ where (h,t) = splitAt n l+ step n k st = Done (k st) st++==>++> takeI :: (Monad m, Nullable a, LL.ListLike a el) => Int -> Enumeratee a a m b+> takeI 0 iter = return iter+> takeI n it =+> Iteratee $ \odf ocf ->+> let odt x _ = runIter (drop n >> return (return x)) odf ocf+> oct _ (Just e) = runIter (drop n >> throwErr e) odf ocf+> oct k Nothing = ocf (step n k) Nothing+> where step n k c@(Chunk xs)+> | LL.length xs < n = takeI (n - LL.length xs) $ k c+> | otherwise = idone (k (Chunk h)) (Chunk t)+> where (h,t) = LL.splitAt n xs+> step n k st = idone (k st) st+> in runIter it odt oct++Exercise : why the calls to idone instead of odf?
− Examples/short.wav
binary file changed (54 → absent bytes)
+ Examples/test_wc.hs view
@@ -0,0 +1,16 @@+import qualified Data.ByteString.Char8 as C+import qualified Data.Iteratee as I++import System++cnt :: I.Iteratee C.ByteString IO Int+cnt = I.liftI (step 0)+ where+ step acc (I.Chunk s)+ | C.null s = I.icont (step acc) Nothing+ | True = let acc' = acc + C.count '\n' s in acc' `seq` I.icont (step acc') Nothing+ step acc str = I.idone acc str++main = do+ [f] <- getArgs+ I.fileDriverVBuf (2^16) cnt f >>= print
− Examples/wave_reader.hs
@@ -1,43 +0,0 @@--- Read a wave file and return some information about it.--{-# LANGUAGE BangPatterns #-}-module Main where--import Data.Iteratee as Iter-import Data.Iteratee.Codecs.Wave-import qualified Data.IntMap as IM-import Data.List (foldl')-import Data.Word (Word8)-import Control.Monad.Trans-import System--main :: IO ()-main = do- args <- getArgs- case args of- [] -> putStrLn "Usage: wave_reader FileName"- fname:xs -> do- putStrLn $ "Reading file: " ++ fname- fileDriverRandom (waveReader >>= test) fname- return ()---- Use the collection of [WAVEDE] returned from wave_reader to--- do further processing. The IntMap has an entry for each type of chunk--- in the wave file. Read the first format chunk and disply the--- format information, then use the dict_process_data function--- to enumerate over the maxIter iteratee to find the maximum value--- (peak amplitude) in the file.-test :: Maybe (IM.IntMap [WAVEDE]) -> IterateeG [] Word8 IO ()-test Nothing = lift $ putStrLn "No dictionary"-test (Just dict) = do- fmtm <- dictReadFirstFormat dict- lift . putStrLn $ show fmtm- maxm <- dictProcessData 0 dict maxIter- lift . putStrLn $ show maxm- return ()---- an iteratee that calculates the maximum value found so far.--- this could be written with head as well, however it is more--- efficient to use foldl'-maxIter :: IterateeG [] Double IO Double-maxIter = Iter.foldl' (flip (max . abs)) 0
Examples/word.hs view
@@ -1,25 +1,52 @@--- A simple wc-like program using Data.Iteratee+{-# LANGUAGE BangPatterns #-}++-- A simple wc-like program using Data.Iteratee.+-- Demonstrates a few different ways of composing iteratees. module Main where import Prelude as P import Data.Iteratee import Data.Iteratee.Char as C-import System+import qualified Data.Iteratee as I+import qualified Data.ByteString.Char8 as BC+import Data.Word+import Data.Char+import Data.ListLike as LL+import System.Environment --- An iteratee to calculate the number of characters in a stream. Very basic.-numChars :: Monad m => IterateeG [] el m Int-numChars = C.length+-- | An iteratee to calculate the number of characters in a stream.+-- Very basic, assumes ASCII, not particularly efficient.+numChars :: (Monad m, ListLike s el) => I.Iteratee s m Int+numChars = I.length --- An iteratee to calculate the number of words in a stream.-numWords :: (Monad m, Functor m) => IterateeG [] Char m Int-numWords = joinI $ enumWords C.length+-- | An iteratee to calculate the number of words in a stream of Word8's.+-- this operates on a Word8 stream in order to use ByteStrings.+--+-- This function converts the stream of Word8s into a stream of words,+-- then counts the words with Data.Iteratee.length+-- This is the equivalent of "length . BC.words".+numWords :: Monad m => I.Iteratee BC.ByteString m Int+numWords = I.joinI $ enumWordsBS I.length --- Count the number of lines, similar to numWords-numLines :: (Monad m, Functor m) => IterateeG [] Char m Int-numLines = joinI $ enumLines C.length+-- | Count the number of lines, in the same manner as numWords.+numLines :: Monad m => I.Iteratee BC.ByteString m Int+numLines = I.joinI $ enumLinesBS I.length +-- | A much more efficient numLines using the foldl' iteratee.+-- Rather than converting a stream, this simply counts newline characters.+numLines2 :: Monad m => I.Iteratee BC.ByteString m Int+numLines2 = I.foldl' step 0+ where+ step !acc el = if el == (fromIntegral $ ord '\n') then acc + 1 else acc++-- | Combine multiple iteratees into a single unit using "enumPair".+-- The iteratees combined with enumPair are run in parallel.+-- Any number of iteratees can be joined with multiple enumPair's.+twoIter :: Monad m => I.Iteratee BC.ByteString m (Int, Int)+twoIter = numLines2 `I.zip` numChars+ main = do f:_ <- getArgs- words <- fileDriver (numLines `enumPair` numWords `enumPair` numChars) f+ words <- fileDriverVBuf 65536 twoIter f print words
+ bench/BenchAll.hs view
@@ -0,0 +1,7 @@+module Main where++import Criterion.Main+import BenchBase (allByteStringBenches)+import BenchIO (ioBenches)++main = defaultMain (allByteStringBenches: ioBenches)
+ bench/BenchBase.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes, KindSignatures, NoMonomorphismRestriction #-}++-- some basic benchmarking of iteratee++module BenchBase where++import Data.Iteratee+import qualified Data.Iteratee.ListLike as I+import qualified Data.Iteratee.Parallel as I+import qualified Data.Iteratee.Binary as I+import Data.Iteratee.ListLike (enumPureNChunk, stream2list, stream2stream)+import Data.Word+import Data.Monoid+import qualified Data.ByteString as BS+import Control.Applicative+import Control.DeepSeq+import Control.Monad.Identity+import Control.Monad+import qualified Data.ListLike as LL++import Criterion.Main++main = defaultMain [allListBenches, allByteStringBenches]++-- -------------------------------------------------------------+-- helper functions and data++-- |Hold information about a benchmark. This allows each+-- benchmark (and baseline) to be created independently of the stream types,+-- for easy comparison of different streams.+-- BDList is for creating baseline comparison functions. Although the name+-- is BDList, it will work for any stream type (e.g. bytestrings).+data BD a b s (m :: * -> *) = BDIter1 String (a -> b) (Iteratee s m a) + | BDIterN String Int (a -> b) (Iteratee s m a)+ | BDList String (s -> b) s++id1 name i = BDIter1 name id i+idN name i = BDIterN name 5 id i+idNx name sz i = BDIterN name sz id i+idNl name i = BDIterN name 1000 id i++defTotalSize = 10000++makeList name f = BDList name f [1..defTotalSize]++makeBench :: BD n eval [Int] Identity -> Benchmark+makeBench (BDIter1 n eval i) = bench n $+ proc eval runIdentity (enumPure1Chunk [1..defTotalSize]) i+makeBench (BDIterN n csize eval i) = bench n $+ proc eval runIdentity (enumPureNChunk [1..defTotalSize] csize) i+makeBench (BDList n f l) = bench n $ whnf f l++packedBS :: BS.ByteString+packedBS = (BS.pack [1..defTotalSize])++makeBenchBS (BDIter1 n eval i) = bench n $+ proc eval runIdentity (enumPure1Chunk packedBS) i+makeBenchBS (BDIterN n csize eval i) = bench n $+ proc eval runIdentity (enumPureNChunk packedBS csize) i+makeBenchBS (BDList n f l) = error "makeBenchBS can't be called on BDList"++proc :: (Functor m, Monad m)+ => (a -> b) --function to force evaluation of result+ -> (m a -> a)+ -> I.Enumerator s m a+ -> I.Iteratee s m a+ -> Pure+proc eval runner enum iter = whnf (eval . runner . (I.run <=< enum)) iter++-- -------------------------------------------------------------+-- benchmark groups+makeGroup n = bgroup n . map makeBench++makeGroupBS :: String -> [BD t t1 BS.ByteString Identity] -> Benchmark+makeGroupBS n = bgroup n . map makeBenchBS++listbench = makeGroup "stream2List" (slistBenches :: [BD [Int] () [Int] Identity])+streambench = makeGroup "stream" (streamBenches :: [BD [Int] () [Int] Identity])+breakbench = makeGroup "break" $ break0 : break0' : breakBenches+headsbench = makeGroup "heads" headsBenches+dropbench = makeGroup "drop" $ drop0 : dropBenches+zipbench = makeGroup "zip" $ zipBenches+consbench = makeGroup "consumed" consBenches+lengthbench = makeGroup "length" listBenches+takebench = makeGroup "take" $ take0 : takeBenches+takeUpTobench = makeGroup "takeUpTo" takeUpToBenches+groupbench = makeGroup "group" groupBenches+mapbench = makeGroup "map" $ mapBenches+foldbench = makeGroup "fold" $ foldBenches+convbench = makeGroup "convStream" convBenches+miscbench = makeGroup "other" miscBenches++listbenchbs = makeGroupBS "stream2List" slistBenches+streambenchbs = makeGroupBS "stream" streamBenches+breakbenchbs = makeGroupBS "break" breakBenches+headsbenchbs = makeGroupBS "heads" headsBenches+dropbenchbs = makeGroupBS "drop" dropBenches+zipbenchbs = makeGroupBS "zip" zipBenches+consbenchbs = makeGroupBS "consumed" consBenches+lengthbenchbs = makeGroupBS "length" listBenches+takebenchbs = makeGroupBS "take" takeBenches+takeUpTobenchbs = makeGroupBS "takeUpTo" takeUpToBenches+groupbenchbs = makeGroupBS "group" groupBenches+mapbenchbs = makeGroupBS "map" mapBenches+foldbenchbs = makeGroupBS "fold" $ foldBenches+convbenchbs = makeGroupBS "convStream" convBenches+miscbenchbs = makeGroupBS "other" miscBenches++endian2benchbs = makeGroupBS "2" endian2Benches+endian3benchbs = makeGroupBS "3" endian3Benches+endian4benchbs = makeGroupBS "4" endian4Benches+endian8benchbs = makeGroupBS "8" endian8Benches+endianbenchbs = bgroup "endian" [endian2benchbs, endian3benchbs, endian4benchbs, endian8benchbs]+++allListBenches = bgroup "list" [listbench, streambench, breakbench, headsbench, dropbench, zipbench, lengthbench, takebench, takeUpTobench, groupbench, mapbench, foldbench, convbench, miscbench, consbench]++allByteStringBenches = bgroup "bytestring" [listbenchbs, streambenchbs, breakbenchbs, headsbenchbs, dropbenchbs, zipbenchbs, lengthbenchbs, takebenchbs, takeUpTobenchbs, groupbenchbs, mapbenchbs, foldbenchbs, convbenchbs, endianbenchbs, miscbenchbs, consbenchbs]++list0 = makeList "list one go" deepseq+list1 = BDIter1 "stream2list one go" (flip deepseq ()) stream2list+list2 = BDIterN "stream2list chunk by 4" 4 (flip deepseq ()) stream2list+list3 = BDIterN "stream2list chunk by 1024" 1024 (flip deepseq ()) stream2list+slistBenches = [list1, list2, list3]++stream1 = BDIter1 "stream2stream one go" (flip deepseq ()) stream2stream+stream2 = BDIterN "stream2stream chunk by 4" 4 (flip deepseq ()) stream2stream+stream3 = BDIterN "stream2stream chunk by 1024" 1024 (flip deepseq ()) stream2stream+streamBenches = [stream1, stream2, stream3]++break0 = makeList "break early list" (fst . Prelude.break (>5))+break0' = makeList "break never list" (fst . Prelude.break (<0))+break1 = id1 "break early one go" (I.break (>5))+break2 = id1 "break never" (I.break (<0)) -- not ever true.+break3 = idN "break early chunked" (I.break (>500))+break4 = idN "break never chunked" (I.break (<0)) -- not ever true+break5 = idN "break late chunked" (I.break (>8000))+breakBenches = [break1, break2, break3, break4, break5]++heads1 = id1 "heads null" (I.heads $ LL.fromList [])+heads2 = id1 "heads 1" (I.heads $ LL.fromList [1])+heads3 = id1 "heads 100" (I.heads $ LL.fromList [1..100])+heads4 = idN "heads 100 over chunks" (I.heads $ LL.fromList [1..100])+headsBenches = [heads1, heads2, heads3, heads4]++benchpeek = id1 "peek" I.peek+benchskip = id1 "skipToEof" (I.skipToEof >> return Nothing)+miscBenches = [benchpeek, benchskip]++drop0 = makeList "drop plain (list only)"+ ( flip seq () . Prelude.drop 100)+drop1 = id1 "drop null" (I.drop 0)+drop2 = id1 "drop plain" (I.drop 100)+drop3 = idN "drop over chunks" (I.drop 100)++dropw0 = makeList "dropWhile all (list only)" (Prelude.dropWhile (const True))+dropw1 = id1 "dropWhile all" (I.dropWhile (const True))+dropw2 = idN "dropWhile all chunked" (I.dropWhile (const True))+dropw3 = id1 "dropWhile small" (I.dropWhile ( < 100))+dropw4 = id1 "dropWhile large" (I.dropWhile ( < 6000))+dropBenches = [drop1, drop2, drop3, dropw1, dropw2, dropw3, dropw4]++b_zip0 = idN "zip balanced" (I.zip (I.dropWhile (<100)) (I.dropWhile (<200))+ >> identity)+b_zip1 = idN "zip unbalanced" (I.zip (I.dropWhile (<8000)) (I.head) >> identity)+b_zip2 = idN "zip unbalanced 2" (I.zip identity I.length >> identity)+b_zip3 = idN "zip complete" (I.zip identity identity >> identity)+b_zip4 = idN "zip nonterminating" (I.zip I.length I.stream2stream >> identity)+zipBenches = [b_zip0, b_zip1, b_zip2, b_zip3, b_zip4 ]++consumed0 = idN "countConsumed" (I.countConsumed (I.foldl' (+) 0))+consumed1 = idN "countConsumed baseline (`I.enumWith` I.length)" (I.foldl' (+) 0 `I.enumWith` I.length)+consBenches = [consumed0, consumed1]+++l1 = makeList "length of list" Prelude.length+l2 = id1 "length single iteratee" I.length+l3 = idN "length chunked" I.length+listBenches = [l2, l3]++take0 = makeList "take length of list long" (Prelude.length . Prelude.take 1000)+take1 = id1 "take head short one go" (I.joinI $ I.take 20 I.head)+take2 = id1 "take head long one go" (I.joinI $ I.take 1000 I.head)+take3 = idN "take head short chunked" (I.joinI $ I.take 20 I.head)+take4 = idN "take head long chunked" (I.joinI $ I.take 1000 I.head)+take5 = id1 "take length long one go" (I.joinI $ I.take 1000 I.length)+take6 = idN "take length long chunked" (I.joinI $ I.take 1000 I.length)+takeBenches = [take1, take2, take3, take4, take5, take6]++takeUpTo1 = id1 "takeUpTo head short one go" (I.joinI $ I.take 20 I.head)+takeUpTo2 = id1 "takeUpTo head long one go" (I.joinI $ I.takeUpTo 1000 I.head)+takeUpTo3 = idN "takeUpTo head short chunked" (I.joinI $ I.takeUpTo 20 I.head)+takeUpTo4 = idN "takeUpTo head long chunked" (I.joinI $ I.takeUpTo 1000 I.head)+takeUpTo5 = id1 "takeUpTo length long one go" (I.joinI $ I.takeUpTo 1000 I.length)+takeUpTo6 = idN "takeUpTo length long chunked" (I.joinI $ I.takeUpTo 1000 I.length)+takeUpToBenches = [takeUpTo1, takeUpTo2, takeUpTo3, takeUpTo4, takeUpTo5, takeUpTo6]++group1 = id1 "group split" (I.joinI $ (I.group 24 ><> I.mapStream LL.length) I.length)+group2 = idN "group coalesce" (I.joinI $ (I.group 512 ><> I.mapStream LL.length) I.length)+groupBenches = [group1,group2]++map1 = id1 "map length one go" (I.joinI $ I.rigidMapStream id I.length)+map2 = idN "map length chunked" (I.joinI $ I.rigidMapStream id I.length)+map3 = id1 "map head one go" (I.joinI $ I.rigidMapStream id I.head)+map4 = idN "map head chunked" (I.joinI $ I.rigidMapStream id I.head)+mapBenches = [map1, map2, map3, map4]++foldB1 = idNl "foldl' sum" (I.foldl' (+) 0)+foldB2 = idNl "mapReduce foldl' 2 sum" (getSum <$> I.mapReduce 2 (Sum . LL.foldl' (+) 0))+foldB3 = idNl "mapReduce foldl' 4 sum" (getSum <$> I.mapReduce 4 (Sum . LL.foldl' (+) 0))+foldBenches = [foldB1, foldB2, foldB3]++conv1 = idN "convStream id head chunked" (I.joinI . I.convStream idChunk $ I.head)+conv2 = idN "convStream id length chunked" (I.joinI . I.convStream idChunk $ I.length)+idChunk = I.liftI step+ where+ step (I.Chunk xs)+ | LL.null xs = idChunk+ | True = idone xs (I.Chunk mempty)+convBenches = [conv1, conv2]++#if MIN_VERSION_bytestring(0,10,0)+#else+instance NFData BS.ByteString where+#endif++instance NFData a => NFData (Sum a) where+ rnf (Sum a) = rnf a++endianRead2_1 = id1 "endianRead2 single" (I.endianRead2 MSB)+endianRead2_2 = idNx "endianRead2 chunked" 1 (I.endianRead2 MSB)+endianRead3_1 = id1 "endianRead3 single" (I.endianRead3 MSB)+endianRead3_2 = idNx "endianRead3 chunked" 2 (I.endianRead3 MSB)+endianRead4_1 = id1 "endianRead4 single" (I.endianRead4 MSB)+endianRead4_2 = idNx "endianRead4 chunked" 2 (I.endianRead4 MSB)+endianRead8_1 = id1 "endianRead8 single" (I.endianRead8 MSB)+endianRead8_2 = idN "endianRead8 chunked" (I.endianRead8 MSB)+endianRead8_3 = idNx "endianRead8 multiple chunked" 2 (I.endianRead8 MSB)+endian2Benches = [endianRead2_1, endianRead2_2]+endian3Benches = [endianRead3_1, endianRead3_2]+endian4Benches = [endianRead4_1, endianRead4_2]+endian8Benches = [endianRead8_1, endianRead8_2, endianRead8_3]
+ bench/BenchIO.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE BangPatterns #-}++module BenchIO where++import Prelude hiding (null, length)+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Criterion.Main+import Data.Monoid+import Data.Word+import Data.Iteratee+import Data.Iteratee.Parallel+import Data.Iteratee.Base.ReadableChunk+import Data.Iteratee.IO.Fd (fileDriverFd)+import Data.Iteratee.IO.Handle (fileDriverHandle)++bufSize = 65536+file = "/usr/share/dict/words"++length' :: Monad m => Iteratee ByteString m Int+length' = length++testFdString :: IO ()+testFdString = fileDriverFd bufSize len file >> return ()+ where+ len :: Monad m => Iteratee String m Int+ len = length++testFdByte :: IO ()+testFdByte = fileDriverFd bufSize len file >> return ()+ where+ len :: Monad m => Iteratee ByteString m Int+ len = length++testHdString :: IO ()+testHdString = fileDriverHandle bufSize len file >> return ()+ where+ len :: Monad m => Iteratee String m Int+ len = length++testHdByte :: IO ()+testHdByte = fileDriverHandle bufSize len file >> return ()+ where+ len :: Monad m => Iteratee ByteString m Int+ len = length++testFdMapReduce :: Int -> IO ()+testFdMapReduce n = fileDriverFd bufSize sum file >> return ()+ where+ sum :: Iteratee ByteString IO Word8+ sum = getSum `fmap` mapReduce n (Sum . B.foldl' (+) 0)++testFdFold :: IO ()+testFdFold = fileDriverFd bufSize sum file >> return ()+ where+ sum :: Iteratee ByteString IO Word8+ sum = foldl' (+) 0++main = defaultMain (stringIO ++ ioBenches)++stringIO =+ [ bgroup "String"+ [bench "Fd" testFdString+ ,bench "Hd with String" testHdString+ ]+ ]++ioBenches =+ [bgroup "ByteString" [+ bench "Fd" testFdByte+ ,bench "Hd" testHdByte+ ]++ ,bgroup "folds" [+ bench "Fd/fold" testFdFold+ ,bench "Fd/mapReduce 2" $ testFdMapReduce 2+ ,bench "Fd/mapReduce 4" $ testFdMapReduce 4+ ,bench "Fd/mapReduce 8" $ testFdMapReduce 8+ ]+ ]
iteratee.cabal view
@@ -1,50 +1,37 @@ name: iteratee-version: 0.3.6+version: 0.8.9.6 synopsis: Iteratee-based I/O description:- The IterateeGM monad provides strict, safe, and functional I/O. In addition+ The Iteratee monad provides strict, safe, and functional I/O. In addition to pure Iteratee processors, file IO and combinator functions are provided.++ See @Data.Iteratee@ for full documentation. category: System, Data-author: Oleg Kiselyov+author: Oleg Kiselyov, John W. Lato maintainer: John W. Lato <jwlato@gmail.com> license: BSD3 license-file: LICENSE-homepage: http://inmachina.net/~jwlato/haskell/iteratee-tested-with: GHC == 6.12.1+homepage: http://www.tiresiaspress.us/haskell/iteratee+tested-with: GHC == 7.6.0, GHC == 7.4.2 stability: experimental -cabal-version: >= 1.6+cabal-version: >= 1.10 build-type: Simple extra-source-files: CONTRIBUTORS README Examples/*.hs+ Examples/*.lhs Examples/*.txt- Examples/*.wav--flag splitBase- description: Use the new split-up base package.--flag buildTests- description: Build test executables.- default: False--flag includeCodecs- description: Build Tiff and Wave codec modules- default: False+ tests/*.hs+ bench/*.hs library+ default-language: Haskell2010 hs-source-dirs: src - if flag(splitBase)- build-depends:- base >= 3 && < 5- else- build-depends:- base < 3- if os(windows) cpp-options: -DUSE_WINDOWS exposed-modules:@@ -58,62 +45,98 @@ unix >= 2 && < 3 build-depends:- ListLike >= 1.0 && < 2,- bytestring >= 0.9 && < 0.10,- containers >= 0.2 && < 0.4,- extensible-exceptions >= 0.1 && < 0.2,- transformers >= 0.2.0.0 && < 0.3+ base >= 3 && < 6,+ ListLike >= 3.0 && < 5,+ monad-control == 0.3.* ,+ bytestring >= 0.9 && < 0.11,+ containers >= 0.2 && < 0.6,+ exceptions >= 0.3 && < 0.7,+ parallel >= 2 && < 4,+ transformers >= 0.2 && < 0.5,+ transformers-base >= 0.4 && < 0.5 exposed-modules:+ Data.Nullable+ Data.NullPoint Data.Iteratee Data.Iteratee.Base- Data.Iteratee.Base.StreamChunk+ Data.Iteratee.Base.ReadableChunk Data.Iteratee.Base.LooseMap Data.Iteratee.Binary Data.Iteratee.Char+ Data.Iteratee.Exception Data.Iteratee.IO Data.Iteratee.IO.Handle Data.Iteratee.IO.Interact- Data.Iteratee.WrappedByteString-- if flag(includeCodecs)- exposed-modules:- Data.Iteratee.Codecs.Tiff- Data.Iteratee.Codecs.Wave+ Data.Iteratee.Iteratee+ Data.Iteratee.ListLike+ Data.Iteratee.Parallel+ Data.Iteratee.PTerm other-modules: Data.Iteratee.IO.Base - ghc-options: -Wall+ ghc-options: -Wall -O2 if impl(ghc >= 6.8) ghc-options: -fwarn-tabs -executable testIteratee- hs-source-dirs:- src- tests-+Test-Suite testIteratee+ default-language: Haskell2010+ type: exitcode-stdio-1.0 main-is: testIteratee.hs-- other-modules:- QCUtils+ hs-source-dirs: tests src - if flag(buildTests)+ if os(windows)+ cpp-options: -DUSE_WINDOWS+ else+ cpp-options: -DUSE_POSIX build-depends:+ unix >= 2 && < 3++ build-depends:+ base,+ bytestring,+ iteratee,+ exceptions,+ monad-control,+ mtl,+ ListLike,+ transformers,+ transformers-base,+ HUnit >= 1.2 , QuickCheck >= 2 && < 3,- test-framework >= 0.3 && < 0.4,- test-framework-quickcheck2 >= 0.2 && < 0.3- else- executable: False- buildable: False+ test-framework >= 0.3 && < 0.9,+ test-framework-quickcheck2 >= 0.2 && < 0.4,+ test-framework-hunit >= 0.2 && < 0.4 - if flag(splitBase)- build-depends:- base >= 3 && < 5+benchmark bench-all+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ main-is: BenchAll.hs++ if os(windows)+ cpp-options: -DUSE_WINDOWS else+ cpp-options: -DUSE_POSIX build-depends:- base < 3+ unix >= 2 && < 3 + build-depends:+ iteratee,+ bytestring,+ monad-control,+ exceptions,+ mtl,+ ListLike,+ transformers,+ transformers-base,+ base >= 3 && < 6,+ criterion >= 0.6 && < 0.9,+ deepseq >= 1.2 && < 2,+ mtl+ ghc-options: -O2+ source-repository head- type: darcs- location: http://tanimoto.us/~jwlato/haskell/iteratee-0.3+ type: git+ location: http://www.tiresiaspress.us/haskell/iteratee
src/Data/Iteratee.hs view
@@ -1,18 +1,61 @@-{- | Provide iteratee-based IO as described in Oleg Kiselyov's paper http://okmij.org/ftp/Haskell/Iteratee/.+{- | Provide iteratee-based IO as described in Oleg Kiselyov's paper 'http://okmij.org/ftp/Haskell/Iteratee/'. -Oleg's original code uses lists to store buffers of data for reading in the iteratee. This package allows the use of arbitrary types through use of the StreamChunk type class. See Data.Iteratee.WrappedByteString for implementation details.+Oleg's original code uses lists to store buffers of data for reading in the iteratee. This package allows the use of arbitrary types through use of the ListLike type class. +Iteratees can be thought of as stream processor combinators. Iteratees are combined to run in sequence or in parallel, and then processed by enumerators. The result of the enumeration is another iteratee, which may then be used again, or have the result obtained via the 'run' function.++> -- count the number of bytes in a file, reading at most 8192 bytes at a time+> import Data.Iteratee as I+> import Data.Iteratee.IO+> import Data.ByteString+> +> byteCounter :: Monad m => Iteratee ByteString m Int+> byteCounter = I.length+> +> countBytes = do+> i' <- enumFile 8192 "/usr/share/dict/words" byteCounter+> result <- run i'+> print result++Iteratees can be combined to perform much more complex tasks. The iteratee monad allows for sequencing iteratee operations.++> iter2 = do+> I.drop 4+> I.head++In addition to enumerations over files and Handles, enumerations can be programmatically generated.++> get5thElement = enumPure1Chunk [1..10] iter2 >>= run >>= print++Iteratees can also work as stream transformers, called 'Enumeratee's. A very simple example is provided by 'Data.Iteratee.ListLike.filter'. When working with enumeratees, it's very common to collaps the nested iteratee with 'joinI'.++This function returns the 5th element greater than 5.++> iterfilt = joinI $ I.filter (>5) iter2+> find5thOver5 = enumPure1Chunk [10,1,4,6,7,4,2,8,5,9::Int] iterfilt >>= run >>= print++Another common use of iteratees is 'takeUpTo', which guarantees that an iteratee consumes a bounded number of elements. This is often useful when parsing data. You can check how much data an iteratee has consumed with 'enumWith'++> iter3 :: (Num el, Ord el, Monad m) => Iteratee [el] m (el,Int)+> iter3 = joinI (I.takeUpTo 100 (enumWith iterfilt I.length))++Many more functions are provided, and there are many other useful ways to combine iteratees and enumerators.+ -} module Data.Iteratee (- module Data.Iteratee.Base, module Data.Iteratee.Binary,+ module Data.Iteratee.ListLike,+ module Data.Iteratee.PTerm, fileDriver,- fileDriverRandom+ fileDriverVBuf,+ fileDriverRandom,+ fileDriverRandomVBuf ) where -import Data.Iteratee.Base import Data.Iteratee.Binary import Data.Iteratee.IO+import Data.Iteratee.ListLike+import Data.Iteratee.PTerm
src/Data/Iteratee/Base.hs view
@@ -1,94 +1,64 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP+ ,TypeFamilies+ ,MultiParamTypeClasses+ ,FlexibleContexts+ ,FlexibleInstances+ ,UndecidableInstances+ ,Rank2Types+ ,DeriveDataTypeable+ ,ExistentialQuantification #-} --- |Monadic and General Iteratees:+-- |Monadic Iteratees: -- incremental input parsers, processors and transformers module Data.Iteratee.Base ( -- * Types- ErrMsg (..),- StreamG (..),- IterGV (..),- IterateeG (..),- EnumeratorN,- EnumeratorGM,- EnumeratorGMM,- -- * Iteratees- -- ** Iteratee Utilities- joinI,- liftI,- isFinished,- run,- joinIM,- stream2list,- stream2stream,- checkIfDone,- liftInner,- -- ** Error handling- setEOF,- throwErr,- checkErr,- -- ** Basic Iteratees- break,- dropWhile,- drop,- identity,- head,- heads,- peek,- last,- skipToEof,- length,- -- ** Nested iteratee combinators- take,- takeR,- mapStream,- rigidMapStream,- looseMapStream,- convStream,- convStateStream,- filter,- -- ** Folds- foldl,- foldl',- foldl1,- -- ** Special Folds- sum,- product,- -- ** Monadic variants of iteratees- mapM_,- -- * Enumerators- -- ** Basic enumerators- enumEof,- enumErr,- enumPure1Chunk,- enumPureNChunk,- -- ** Enumerator Combinators- (>.),- enumPair,- -- * Misc.- seek,- FileOffset,+ Stream (..)+ ,StreamStatus (..)+ -- ** Exception types+ ,module Data.Iteratee.Exception+ -- ** Iteratees+ ,Iteratee (..)+ -- * Functions+ -- ** Control functions+ ,run+ ,tryRun+ ,mapIteratee+ ,ilift+ ,ifold+ -- ** Creating Iteratees+ ,idone+ ,icont+ ,liftI+ ,idoneM+ ,icontM+ -- ** Stream Functions+ ,setEOF -- * Classes- module Data.Iteratee.Base.LooseMap+ ,module X ) where -import Prelude hiding (head, last, drop, dropWhile, take, break, foldl, foldl1, length, filter, sum, product, mapM_)-import qualified Prelude as P+import Prelude hiding (null)+import Data.Iteratee.Exception+import Data.Iteratee.Base.LooseMap as X+import Data.Nullable as X+import Data.NullPoint as X -import qualified Data.Iteratee.Base.StreamChunk as SC-import qualified Data.ListLike as LL-import qualified Data.ListLike.FoldableLL as FLL-import Data.Iteratee.Base.LooseMap-import Data.Iteratee.IO.Base-import Control.Monad hiding (mapM_)-import Control.Applicative-import Control.Monad.Trans.Class-import Control.Monad.IO.Class+import Data.Maybe import Data.Monoid-import Data.Maybe (fromMaybe) +import Control.Monad (liftM, join)+import Control.Monad.Base+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Control+import Control.Monad.Catch as CIO+import Control.Applicative hiding (empty)+import qualified Control.Exception as E+import Data.Data + -- |A stream is a (continuing) sequence of elements bundled in Chunks. -- The first variant indicates termination of the stream. -- Chunk a gives the currently available part of the stream.@@ -98,714 +68,218 @@ -- informally speaking, ``suspend itself'' and wait for more data -- to arrive. -data StreamG c el =- EOF (Maybe ErrMsg)- | Chunk (c el)--instance Eq (c el) => Eq (StreamG c el) where- EOF mErr1 == EOF mErr2 = mErr1 == mErr2- Chunk xs == Chunk ys = xs == ys- _ == _ = False--instance Show (c el) => Show (StreamG c el) where- show (EOF mErr) = "StreamG: EOF " ++ show mErr- show (Chunk xs) = "StreamG: Chunk " ++ show xs+data Stream c =+ EOF (Maybe SomeException)+ | Chunk c+ deriving (Show, Typeable) -instance Functor c => Functor (StreamG c) where- fmap _ (EOF mErr) = EOF mErr- fmap f (Chunk xs) = Chunk $ fmap f xs+instance (Eq c) => Eq (Stream c) where+ (Chunk c1) == (Chunk c2) = c1 == c2+ (EOF Nothing) == (EOF Nothing) = True+ (EOF (Just e1)) == (EOF (Just e2)) = typeOf e1 == typeOf e2+ _ == _ = False -instance Monoid (c el) => Monoid (StreamG c el) where+instance Monoid c => Monoid (Stream c) where mempty = Chunk mempty mappend (EOF mErr) _ = EOF mErr mappend _ (EOF mErr) = EOF mErr mappend (Chunk s1) (Chunk s2) = Chunk (s1 `mappend` s2) -- |Map a function over a stream.-strMap :: (c el -> c' el') -> StreamG c el -> StreamG c' el'-strMap f (Chunk xs) = Chunk $ f xs-strMap _ (EOF mErr) = EOF mErr--data ErrMsg = Err String- | Seek FileOffset- deriving (Show, Eq)--instance Monoid ErrMsg where- mempty = Err ""- mappend (Err s1) (Err s2) = Err (s1 ++ s2)- mappend e@(Err _) _ = e- mappend _ e@(Err _) = e- mappend (Seek _) (Seek b) = Seek b---- |Iteratee -- a generic stream processor, what is being folded over--- a stream--- When Iteratee is in the 'done' state, it contains the computed--- result and the remaining part of the stream.--- In the 'cont' state, the iteratee has not finished the computation--- and needs more input.--- We assume that all iteratees are `good' -- given bounded input,--- they do the bounded amount of computation and take the bounded amount--- of resources. The monad m describes the sort of computations done--- by the iteratee as it processes the stream. The monad m could be--- the identity monad (for pure computations) or the IO monad--- (to let the iteratee store the stream processing results as they--- are computed).--- We also assume that given a terminated stream, an iteratee--- moves to the done state, so the results computed so far could be returned.--data IterGV c el m a =- Done a (StreamG c el)- | Cont (IterateeG c el m a) (Maybe ErrMsg)--instance (Show (c el), Show a) => Show (IterGV c el m a) where- show (Done a str) = "IterGV Done <<" ++ show a ++ ">> : <<" ++ show str ++ ">>"- show (Cont _ mErr) = "IterGV Cont :: " ++ show mErr--newtype IterateeG c el m a = IterateeG{- runIter :: StreamG c el -> m (IterGV c el m a)- }----- Useful combinators for implementing iteratees and enumerators---- | Lift an IterGV result into an 'IterateeG'-liftI :: (Monad m, SC.StreamChunk s el) => IterGV s el m a -> IterateeG s el m a-liftI (Cont k Nothing) = k-liftI (Cont _k (Just err)) = throwErr err-liftI i@(Done _ (EOF _ )) = IterateeG (const (return i))-liftI (Done a (Chunk st )) = IterateeG (check st)- where- check str (Chunk str') = return $ Done a (Chunk $ str `mappend` str')- check _str e@(EOF _) = return $ Done a e---- | Run an 'IterateeG' and get the result. An 'EOF' is sent to the--- iteratee as it is run.-run :: (Monad m, SC.StreamChunk s el) => IterateeG s el m a -> m a-run iter = runIter iter (EOF Nothing) >>= \res ->- case res of- Done x _ -> return x- Cont _ e -> error $ "control message: " ++ show e---- | Check if a stream has finished ('EOF').-isFinished :: (SC.StreamChunk s el, Monad m) =>- IterateeG s el m (Maybe ErrMsg)-isFinished = IterateeG check- where- check s@(EOF e) = return $ Done (Just $ fromMaybe (Err "EOF") e) s- check s = return $ Done Nothing s---- |If the iteratee ('IterGV') has finished, return its value. If it has not--- finished then apply it to the given 'EnumeratorGM'.--- If in error, throw the error.-checkIfDone :: (SC.StreamChunk s el, Monad m) =>- (IterateeG s el m a -> m (IterateeG s el m a)) ->- IterGV s el m a ->- m (IterateeG s el m a)-checkIfDone _ (Done x _) = return . return $ x-checkIfDone k (Cont x Nothing) = k x-checkIfDone _ (Cont _ (Just e)) = return . throwErr $ e---- |The following is a `variant' of join in the IterateeGM s el m monad--- When el' is the same as el, the type of joinI is indeed that of--- true monadic join. However, joinI is subtly different: since--- generally el' is different from el, it makes no sense to--- continue using the internal, IterateeG el' m a: we no longer--- have elements of the type el' to feed to that iteratee.--- We thus send EOF to the internal Iteratee and propagate its result.--- This join function is useful when dealing with `derived iteratees'--- for embedded/nested streams. In particular, joinI is useful to--- process the result of take, mapStream, or convStream below.-joinI :: (SC.StreamChunk s el, SC.StreamChunk s' el', Monad m) =>- IterateeG s el m (IterateeG s' el' m a) ->- IterateeG s el m a-joinI m = IterateeG (docase <=< runIter m)- where- docase (Done ma str) = liftM (flip Done str) (run ma)- docase (Cont k mErr) = return $ Cont (joinI k) mErr---- |Layer a monad transformer over the inner monad.-liftInner :: (Monad m, MonadTrans t, Monad (t m)) =>- IterateeG s el m a ->- IterateeG s el (t m) a-liftInner iter = IterateeG step- where- step str = do- igv <- lift $ runIter iter str- case igv of- Done a res -> return $ Done a res- Cont k mErr -> return $ Cont (liftInner k) mErr---- It turns out, IterateeG form a monad. We can use the familiar do--- notation for composing Iteratees--instance (Monad m) => Monad (IterateeG s el m) where- return x = IterateeG (return . Done x)- (>>=) = iterBind--iterBind :: (Monad m ) =>- IterateeG s el m a ->- (a -> IterateeG s el m b) ->- IterateeG s el m b-iterBind m f = IterateeG (docase <=< runIter m)- where- docase (Done a str) = runIter (f a) str- docase (Cont k mErr) = return $ Cont (k `iterBind` f) mErr--{-# INLINE iterBind #-}--instance (Monad m, Functor m) =>- Functor (IterateeG s el m) where- fmap f m = IterateeG (docase <=< runIter m)- where- -- docase :: IterGV s el m a -> m (IterGV s el m a)- docase (Done a stream) = return $ Done (f a) stream- docase (Cont k mErr) = return $ Cont (fmap f k) mErr--instance (Monad m, Functor m) => Applicative (IterateeG s el m) where- pure = return- m <*> a = m >>= flip fmap a--instance MonadTrans (IterateeG s el) where- lift m = IterateeG $ \str -> liftM (flip Done str) m--instance (MonadIO m) => MonadIO (IterateeG s el m) where- liftIO = lift . liftIO---- --------------------------------------------------------------------------- Primitive iteratees---- |Read a stream to the end and return all of its elements as a list-stream2list :: (SC.StreamChunk s el, Monad m) => IterateeG s el m [el]-stream2list = IterateeG (step mempty)- where- -- step :: s el -> StreamG s el -> m (IterGV s el m [el])- step acc (Chunk ls)- | SC.null ls = return $ Cont (IterateeG (step acc)) Nothing- step acc (Chunk ls) = return $ Cont- (IterateeG (step (acc `mappend` ls)))- Nothing- step acc str = return $ Done (SC.toList acc) str---- |Read a stream to the end and return all of its elements as a stream-stream2stream :: (SC.StreamChunk s el, Monad m) => IterateeG s el m (s el)-stream2stream = IterateeG (step mempty)- where- step acc (Chunk ls)- | SC.null ls = return $ Cont (IterateeG (step acc)) Nothing- step acc (Chunk ls) = return $ Cont- (IterateeG (step (acc `mappend` ls)))- Nothing- step acc str = return $ Done acc str+instance Functor Stream where+ fmap f (Chunk xs) = Chunk $ f xs+ fmap _ (EOF mErr) = EOF mErr +-- |Describe the status of a stream of data.+data StreamStatus =+ DataRemaining+ | EofNoError+ | EofError SomeException+ deriving (Show, Typeable) --- |Report and propagate an error. Disregard the input first and then--- propagate the error.-throwErr :: (Monad m) => ErrMsg -> IterateeG s el m a-throwErr e = IterateeG (\_ -> return $ Cont (throwErr e) (Just e))+-- ----------------------------------------------+-- create exception type hierarchy --- |Produce the EOF error message. If the stream was terminated because--- of an error, keep the original error message.-setEOF :: StreamG c el -> ErrMsg+-- |Produce the 'EOF' error message. If the stream was terminated because+-- of an error, keep the error message.+setEOF :: Stream c -> SomeException setEOF (EOF (Just e)) = e-setEOF _ = Err "EOF"---- |Check if an iteratee produces an error.--- Returns 'Right a' if it completes without errors, otherwise 'Left ErrMsg'--- checkErr is useful for iteratees that may not terminate, such as 'head'--- with an empty stream. In particular, it enables them to be used with--- 'convStream'.-checkErr :: (Monad m, SC.StreamChunk s el) =>- IterateeG s el m a ->- IterateeG s el m (Either ErrMsg a)-checkErr iter = IterateeG (check <=< runIter iter)- where- check (Done a str) = return $ Done (Right a) str- check (Cont _ (Just err)) = return $ Done (Left err) mempty- check (Cont k Nothing) = return $ Cont (checkErr k) Nothing------ --------------------------------------------------------------------------- Parser combinators---- |The analogue of List.break--- It takes an element predicate and returns the (possibly empty) prefix of--- the stream. None of the characters in the string satisfy the character--- predicate.--- If the stream is not terminated, the first character on the stream--- satisfies the predicate.--break :: (SC.StreamChunk s el, Monad m) =>- (el -> Bool) ->- IterateeG s el m (s el)-break cpred = IterateeG (step mempty)- where- step before (Chunk str) | SC.null str = return $- Cont (IterateeG (step before)) Nothing- step before (Chunk str) =- case LL.break cpred str of- (_, tail') | SC.null tail' -> return $ Cont- (IterateeG (step (before `mappend` str)))- Nothing- (str', tail') -> return $ Done (before `mappend` str') (Chunk tail')- step before stream = return $ Done before stream---- |The identity iterator. Doesn't do anything.-identity :: (Monad m) => IterateeG s el m ()-identity = return ()----- |Attempt to read the next element of the stream and return it--- Raise a (recoverable) error if the stream is terminated-head :: (SC.StreamChunk s el, Monad m) => IterateeG s el m el-head = IterateeG step- where- step (Chunk vec)- | SC.null vec = return $ Cont head Nothing- | otherwise = return $ Done (SC.head vec) (Chunk $ SC.tail vec)- step stream = return $ Cont head (Just (setEOF stream))----- |Given a sequence of characters, attempt to match them against--- the characters on the stream. Return the count of how many--- characters matched. The matched characters are removed from the--- stream.--- For example, if the stream contains "abd", then (heads "abc")--- will remove the characters "ab" and return 2.-heads :: (SC.StreamChunk s el, Monad m, Eq el) =>- s el ->- IterateeG s el m Int-heads st | SC.null st = return 0-heads st = loop 0 st- where- loop cnt xs | SC.null xs = return cnt- loop cnt xs = IterateeG (step cnt xs)- step cnt str (Chunk xs) | SC.null xs = return $ Cont (loop cnt str) Nothing- step cnt str stream | SC.null str = return $ Done cnt stream- step cnt str s@(Chunk xs) =- if SC.head str == SC.head xs- then step (succ cnt) (SC.tail str) (Chunk $ SC.tail xs)- else return $ Done cnt s- step cnt _ stream = return $ Done cnt stream----- |Look ahead at the next element of the stream, without removing--- it from the stream.--- Return (Just c) if successful, return Nothing if the stream is--- terminated (by EOF or an error)-peek :: (SC.StreamChunk s el, Monad m) => IterateeG s el m (Maybe el)-peek = IterateeG step- where- step s@(Chunk vec)- | SC.null vec = return $ Cont peek Nothing- | otherwise = return $ Done (Just $ SC.head vec) s- step stream = return $ Done Nothing stream---- | Attempt to skip to the last element of the stream and return it-last :: (SC.StreamChunk s el, Monad m) => IterateeG s el m el-last = do x <- head- next <- peek- case next of- Just _ -> last- Nothing -> return x---- |Skip the rest of the stream-skipToEof :: (Monad m) => IterateeG s el m ()-skipToEof = IterateeG step- where- step (Chunk _) = return $ Cont skipToEof Nothing- step s = return $ Done () s----- |Seek to a position in the stream-seek :: (Monad m) => FileOffset -> IterateeG s el m ()-seek n = IterateeG step- where- step (Chunk _) = return $ Cont identity (Just (Seek n))- step s = return $ Done () s------ |Skip n elements of the stream, if there are that many--- This is the analogue of List.drop-drop :: (SC.StreamChunk s el, Monad m) => Int -> IterateeG s el m ()-drop 0 = return ()-drop n = IterateeG step- where- step (Chunk str)- | SC.length str <= n = return $ Cont (drop (n - SC.length str)) Nothing- step (Chunk str) = return $ Done () (Chunk (LL.drop n str))- step stream = return $ Done () stream---- |Skip all elements while the predicate is true.--- This is the analogue of List.dropWhile-dropWhile :: (SC.StreamChunk s el, Monad m) =>- (el -> Bool) ->- IterateeG s el m ()-dropWhile p = IterateeG step- where- step (Chunk str) = let dropped = LL.dropWhile p str- in if LL.null dropped- then return $ Cont (dropWhile p) Nothing- else return $ Done () (Chunk dropped)- step stream = return $ Done () stream----- |Return the total length of the stream-length :: (Num a, LL.ListLike (s el) el, Monad m) => IterateeG s el m a-length = length' 0- where- length' = IterateeG . step- step i (Chunk xs) = let a = i + (LL.length xs)- in a `seq` return $ Cont (length' a) Nothing- step i stream = return $ Done (fromIntegral i) stream----- ------------------------------------------------------ The converters show a different way of composing two iteratees:--- `vertical' rather than `horizontal'---- |The type of the converter from the stream with elements el_outer--- to the stream with element el_inner. The result is the iteratee--- for the outer stream that uses an `IterateeG el_inner m a'--- to process the embedded, inner stream as it reads the outer stream.-type EnumeratorN s_outer el_outer s_inner el_inner m a =- IterateeG s_inner el_inner m a ->- IterateeG s_outer el_outer m (IterateeG s_inner el_inner m a)---- |Read n elements from a stream and apply the given iteratee to the--- stream of the read elements. Unless the stream is terminated early, we--- read exactly n elements (even if the iteratee has accepted fewer).-take :: (SC.StreamChunk s el, Monad m) =>- Int -> EnumeratorN s el s el m a-take 0 iter = return iter-take n iter = IterateeG step- where- step s@(Chunk str)- | LL.null str = return $ Cont (take n iter) Nothing- | LL.length str < n = liftM (flip Cont Nothing) inner- where inner = check (n - LL.length str) `liftM` runIter iter s- step (Chunk str) = done (Chunk s1) (Chunk s2)- where (s1, s2) = LL.splitAt n str- step str = done str str- check n' (Done x _) = drop n' >> return (return x)- check n' (Cont x Nothing) = take n' x- check n' (Cont _ (Just e)) = drop n' >> throwErr e- done s1 s2 = liftM (flip Done s2) (runIter iter s1 >>= checkIfDone return)----- |Read n elements from a stream and apply the given iteratee to the--- stream of the read elements. If the given iteratee accepted fewer--- elements, we stop.--- This is the variation of `take' with the early termination--- of processing of the outer stream once the processing of the inner stream--- finished early.-takeR :: (SC.StreamChunk s el, Monad m) =>- Int -> EnumeratorN s el s el m a-takeR 0 iter = return iter-takeR n iter = IterateeG step- where- step s@(Chunk str)- | LL.null str = return $ Cont (takeR n iter) Nothing- | LL.length str <= n = runIter iter s >>= check (n - LL.length str)- | otherwise = done (Chunk str1) (Chunk str2)- where (str1, str2) = LL.splitAt n str- step str = done str str- check _ (Done a str) = return $ Done (return a) str- check n' (Cont k mErr) = return $ Cont (takeR n' k) mErr- done s1 s2 = liftM (flip Done s2) (runIter iter s1 >>= checkIfDone return)--{-# SPECIALIZE takeR :: Int -> IterateeG [] el IO a -> IterateeG [] el IO (IterateeG [] el IO a) #-}-{-# SPECIALIZE takeR :: Monad m => Int -> IterateeG [] el m a -> IterateeG [] el m (IterateeG [] el m a) #-}----- |Map the stream: yet another iteratee transformer--- Given the stream of elements of the type el and the function el->el',--- build a nested stream of elements of the type el' and apply the--- given iteratee to it.--- Note the contravariance--mapStream :: (SC.StreamChunk s el, SC.StreamChunk s el', Monad m) =>- (el -> el')- -> EnumeratorN s el s el' m a-mapStream f i = step i- where- step iter = IterateeG ((check <=< runIter iter) . strMap (SC.cMap f))- check (Done a _) = return $ Done (return a) (Chunk LL.empty)- check (Cont k mErr) = return $ Cont (step k) mErr---- |Map a stream without changing the element type. For StreamChunks--- with limited element types (e.g. bytestrings)--- this can be much more efficient than regular mapStream-rigidMapStream :: (SC.StreamChunk s el, Monad m) =>- (el -> el)- -> EnumeratorN s el s el m a-rigidMapStream f i = step i- where- step iter = IterateeG ((check <=< runIter iter) . strMap (LL.rigidMap f))- check (Done a _) = return $ Done (return a) (Chunk LL.empty)- check (Cont k mErr) = return $ Cont (step k) mErr+setEOF _ = toException EofException --- |Yet another stream mapping function. For container instances with--- class contexts, such as uvector or storablevector, this allows--- the native map function to be used and is likely to be much--- more efficient than the standard mapStream.-looseMapStream :: (SC.StreamChunk s el,- SC.StreamChunk s el',- LooseMap s el el',- Monad m) =>- (el -> el')- -> EnumeratorN s el s el' m a-looseMapStream f i = step i- where- step iter = IterateeG ((check <=< runIter iter) . strMap (looseMap f))- check (Done a _) = return $ Done (return a) (Chunk LL.empty)- check (Cont x mErr) = return $ Cont (step x) mErr+-- ----------------------------------------------+-- | Monadic iteratee+newtype Iteratee s m a = Iteratee{ runIter :: forall r.+ (a -> Stream s -> m r) ->+ ((Stream s -> Iteratee s m a) -> Maybe SomeException -> m r) ->+ m r} +-- ---------------------------------------------- --- |Convert one stream into another, not necessarily in `lockstep'--- The transformer mapStream maps one element of the outer stream--- to one element of the nested stream. The transformer below is more--- general: it may take several elements of the outer stream to produce--- one element of the inner stream, or the other way around.--- The transformation from one stream to the other is specified as--- IterateeGM s el m (Maybe (s' el')). The Maybe type is in case of--- errors (or end of stream).-convStream :: Monad m =>- IterateeG s el m (Maybe (s' el')) ->- EnumeratorN s el s' el' m a-convStream fi iter = fi >>= check- where- check (Just xs) = lift (runIter iter (Chunk xs)) >>= docase- check (Nothing) = return iter- docase (Done a _) = return . return $ a- docase (Cont k Nothing) = convStream fi k- docase (Cont _ (Just e)) = return $ throwErr e+idone :: a -> Stream s -> Iteratee s m a+idone a s = Iteratee $ \onDone _ -> onDone a s -{-# INLINE convStream #-}+icont :: (Stream s -> Iteratee s m a) -> Maybe SomeException -> Iteratee s m a+icont k e = Iteratee $ \_ onCont -> onCont k e --- |Convert one stream into another while continually updating an internal--- state. The state of type 't' is updated by the supplied function, which--- maybe returns a tuple consisting of the updated state, the remaining--- unprocessed portion of the input stream, and the output stream.--- In order to produce elements of the output stream from data that spans--- stream chunks, the remaining portion of the input stream is passed to the--- following iteration of the supplied function, which should prepend it to--- its input stream chunk.--- The supplied function should return Nothing on EOF.-convStateStream :: MonadIO m =>- (t -> s el -> IterateeG s el m (Maybe (t, s el, s' el'))) ->- t -> s el ->- EnumeratorN s el s' el' m b-convStateStream outer state pre inner = outer state pre >>= convStateCheck outer inner+liftI :: (Stream s -> Iteratee s m a) -> Iteratee s m a+liftI k = Iteratee $ \_ onCont -> onCont k Nothing -{-# INLINE convStateStream #-}+-- Monadic versions, frequently used by enumerators+idoneM :: Monad m => a -> Stream s -> m (Iteratee s m a)+idoneM x str = return $ Iteratee $ \onDone _ -> onDone x str -convStateCheck :: (MonadIO m) =>- (t -> s el -> IterateeG s el m (Maybe (t, s el, s' el')))- -> IterateeG s' el' m b- -> Maybe (t, s el, s' el')- -> IterateeG s el m (IterateeG s' el' m b)-convStateCheck outer inner (Just (state', remainder, result)) =- lift (runIter inner (Chunk result)) >>= docase- where- docase (Done a _) = return . return $ a- docase (Cont k Nothing) = convStateStream outer state' remainder k- docase (Cont _ (Just e)) = return $ throwErr e-convStateCheck _ iter (Nothing) = return iter+icontM+ :: Monad m =>+ (Stream s -> Iteratee s m a)+ -> Maybe SomeException+ -> m (Iteratee s m a)+icontM k e = return $ Iteratee $ \_ onCont -> onCont k e -{-# INLINE convStateCheck #-}+instance (Functor m) => Functor (Iteratee s m) where+ fmap f m = Iteratee $ \onDone onCont ->+ let od = onDone . f+ oc = onCont . (fmap f .)+ in runIter m od oc --- |Creates an enumerator with only elements from the stream that--- satisfy the predicate function.-filter :: (LL.ListLike (s el) el, Monad m) =>- (el -> Bool) ->- EnumeratorN s el s el m a-filter p = convStream f'- where- f' = IterateeG step- step (Chunk xs) | LL.null xs = return $ Cont f' Nothing- step (Chunk xs) = return $ Done (Just $ LL.filter p xs) mempty- step stream = return $ Done Nothing stream+instance (Functor m, Monad m, Nullable s) => Applicative (Iteratee s m) where+ pure x = idone x (Chunk empty)+ {-# INLINE (<*>) #-}+ m <*> a = m >>= flip fmap a --- --------------------------------------------------------------------------- Folds+instance (Monad m, Nullable s) => Monad (Iteratee s m) where+ {-# INLINE return #-}+ return x = Iteratee $ \onDone _ -> onDone x (Chunk empty)+ {-# INLINE (>>=) #-}+ (>>=) = bindIteratee --- | Left-associative fold.-foldl :: (LL.ListLike (s el) el, FLL.FoldableLL (s el) el, Monad m) =>- (a -> el -> a) ->- a ->- IterateeG s el m a-foldl f i = iter i- where- iter ac = IterateeG step+{-# INLINE bindIteratee #-}+bindIteratee :: (Monad m, Nullable s)+ => Iteratee s m a+ -> (a -> Iteratee s m b)+ -> Iteratee s m b+bindIteratee = self where- step (Chunk xs) | LL.null xs = return $ Cont (iter ac) Nothing- step (Chunk xs) = return $ Cont (iter (FLL.foldl f ac xs)) Nothing- step stream = return $ Done ac stream---- | Left-associative fold that is strict in the accumulator.-foldl' :: (LL.ListLike (s el) el, FLL.FoldableLL (s el) el, Monad m) =>- (a -> el -> a) ->- a ->- IterateeG s el m a-foldl' f i = IterateeG (step i)- where- step ac (Chunk xs) | LL.null xs = return $ Cont (IterateeG (step ac))- Nothing- step ac (Chunk xs) = return $ Cont (IterateeG (step $! FLL.foldl' f ac xs))- Nothing- step ac stream = return $ Done ac stream--{-# INLINE foldl' #-}---- | Variant of foldl with no base case. Requires at least one element--- in the stream.-foldl1 :: (LL.ListLike (s el) el, FLL.FoldableLL (s el) el, Monad m) =>- (el -> el -> el) ->- IterateeG s el m el-foldl1 f = IterateeG step- where- step (Chunk xs) | LL.null xs = return $ Cont (foldl1 f) Nothing- -- After the first chunk, just use regular foldl in order to account for- -- the accumulator.- step (Chunk xs) = return $ Cont (foldl f (FLL.foldl1 f xs)) Nothing- step stream = return $ Cont (foldl1 f) (Just (setEOF stream))---- | Sum of a stream.-sum :: (LL.ListLike (s el) el, Num el, Monad m) =>- IterateeG s el m el-sum = IterateeG (step 0)- where- step acc (Chunk xs)- | LL.null xs = return $ Cont (IterateeG (step acc)) Nothing- step acc (Chunk xs) = return $ Cont (IterateeG . step $! acc + (LL.sum xs))- Nothing- step acc str = return $ Done acc str---- | Product of a stream-product :: (LL.ListLike (s el) el, Num el, Monad m) =>- IterateeG s el m el-product = IterateeG (step 1)- where- step acc (Chunk xs)- | LL.null xs = return $ Cont (IterateeG (step acc)) Nothing- step acc (Chunk xs) = return $ Cont (IterateeG . step $! acc *- (LL.product xs))- Nothing- step acc str = return $ Done acc str---- --------------------------------------------------------------------------- Zips---- |Enumerate two iteratees over a single stream simultaneously.-enumPair :: (LL.ListLike (s el) el, Monad m) =>- IterateeG s el m a ->- IterateeG s el m b ->- IterateeG s el m (a,b)-enumPair i1 i2 = IterateeG step- where- longest c1@(Chunk xs) c2@(Chunk ys) = if LL.length xs > LL.length ys- then c1 else c2- longest e@(EOF _) _ = e- longest _ e@(EOF _) = e- step (Chunk xs) | LL.null xs = return $ Cont (IterateeG step) Nothing- step str = do- ia <- runIter i1 str- ib <- runIter i2 str- case (ia, ib) of- (Done a astr, Done b bstr) -> return $ Done (a,b) $ longest astr bstr- (Done a _astr, Cont k mErr) -> return $ Cont (enumPair (return a) k) mErr- (Cont k mErr, Done b _bstr) -> return $ Cont (enumPair k (return b)) mErr- (Cont a aEr, Cont b bEr) -> return $ Cont (enumPair a b)- (aEr `mappend` bEr)+ self m f = Iteratee $ \onDone onCont ->+ let m_done a (Chunk s)+ | nullC s = runIter (f a) onDone onCont+ m_done a stream = runIter (f a) (const . flip onDone stream) f_cont+ where f_cont k Nothing = runIter (k stream) onDone onCont+ f_cont k e = onCont k e+ in runIter m m_done (onCont . (flip self f .)) --- --------------------------------------------------------------------------- Enumerators--- |Each enumerator takes an iteratee and returns an iteratee--- an Enumerator is an iteratee transformer.--- The enumerator normally stops when the stream is terminated--- or when the iteratee moves to the done state, whichever comes first.--- When to stop is of course up to the enumerator...+instance NullPoint s => MonadTrans (Iteratee s) where+ lift m = Iteratee $ \onDone _ -> m >>= flip onDone (Chunk empty) --- We have two choices of composition: compose iteratees or compose--- enumerators. The latter is useful when one iteratee--- reads from the concatenation of two data sources.+instance (MonadBase b m, Nullable s, NullPoint s) => MonadBase b (Iteratee s m) where+ liftBase = lift . liftBase -type EnumeratorGM s el m a = IterateeG s el m a -> m (IterateeG s el m a)+instance (MonadIO m, Nullable s, NullPoint s) => MonadIO (Iteratee s m) where+ liftIO = lift . liftIO --- |More general enumerator type: enumerator that maps--- streams (not necessarily in lock-step). This is--- a flattened (`joinI-ed') EnumeratorN sfrom elfrom sto elto m a-type EnumeratorGMM sfrom elfrom sto elto m a =- IterateeG sto elto m a -> m (IterateeG sfrom elfrom m a)+instance (MonadThrow m, Nullable s, NullPoint s) =>+ MonadThrow (Iteratee s m) where+ throwM e = lift $ CIO.throwM e --- |The most primitive enumerator: applies the iteratee to the terminated--- stream. The result is the iteratee usually in the done state.-enumEof :: Monad m =>- EnumeratorGM s el m a-enumEof iter = runIter iter (EOF Nothing) >>= check- where- check (Done x _) = return $ IterateeG $ return . Done x- check (Cont _ e) = return $ throwErr (fromMaybe (Err "Divergent Iteratee") e)+instance (MonadCatch m, Nullable s, NullPoint s) =>+ MonadCatch (Iteratee s m) where+ m `catch` f = Iteratee $ \od oc -> runIter m od oc `CIO.catch` (\e -> runIter (f e) od oc) --- |Another primitive enumerator: report an error-enumErr :: (SC.StreamChunk s el, Monad m) =>- String ->- EnumeratorGM s el m a-enumErr e iter = runIter iter (EOF (Just (Err e))) >>= check- where- check (Done x _) = return $ IterateeG (return . Done x)- check (Cont _ e') = return $ throwErr- (fromMaybe (Err "Divergent Iteratee") e')+-- prior to exceptions-0.6, these were part of MonadCatch+#if MIN_VERSION_exceptions(0,6,0)+instance (MonadMask m, Nullable s, NullPoint s) =>+ MonadMask (Iteratee s m) where+#endif+ mask q = Iteratee $ \od oc -> CIO.mask $ \u -> runIter (q $ ilift u) od oc+ uninterruptibleMask q = Iteratee $ \od oc -> CIO.uninterruptibleMask $ \u -> runIter (q $ ilift u) od oc --- |The composition of two enumerators: essentially the functional composition--- It is convenient to flip the order of the arguments of the composition--- though: in e1 >. e2, e1 is executed first+instance forall s. (NullPoint s, Nullable s) => MonadTransControl (Iteratee s) where+ newtype StT (Iteratee s) x =+ StIter { unStIter :: Either (x, Stream s) (Maybe SomeException) }+ liftWith f = lift $ f $ \t -> liftM StIter+ (runIter t (\x s -> return $ Left (x,s))+ (\_ e -> return $ Right e) )+ restoreT = join . lift . liftM+ (either (uncurry idone)+ (te . fromMaybe (iterStrExc+ "iteratee: error in MonadTransControl instance"))+ . unStIter )+ {-# INLINE liftWith #-}+ {-# INLINE restoreT #-} -(>.):: (SC.StreamChunk s el, Monad m) =>- EnumeratorGM s el m a -> EnumeratorGM s el m a -> EnumeratorGM s el m a-(>.) e1 e2 = e2 <=< e1+instance (MonadBaseControl b m, Nullable s) => MonadBaseControl b (Iteratee s m) where+ newtype StM (Iteratee s m) a =+ StMIter { unStMIter :: ComposeSt (Iteratee s) m a}+ liftBaseWith = defaultLiftBaseWith StMIter+ restoreM = defaultRestoreM unStMIter --- |The pure 1-chunk enumerator--- It passes a given list of elements to the iteratee in one chunk--- This enumerator does no IO and is useful for testing of base parsing-enumPure1Chunk :: (SC.StreamChunk s el, Monad m) =>- s el ->- EnumeratorGM s el m a-enumPure1Chunk str iter = runIter iter (Chunk str) >>= checkIfDone return+te :: SomeException -> Iteratee s m a+te e = icont (const (te e)) (Just e) +-- |Send 'EOF' to the @Iteratee@ and disregard the unconsumed part of the+-- stream. If the iteratee is in an exception state, that exception is+-- thrown with 'Control.Exception.throw'. Iteratees that do not terminate+-- on @EOF@ will throw 'EofException'.+run :: Monad m => Iteratee s m a -> m a+run iter = runIter iter onDone onCont+ where+ onDone x _ = return x+ onCont k Nothing = runIter (k (EOF Nothing)) onDone onCont'+ onCont _ (Just e) = E.throw e+ onCont' _ Nothing = E.throw EofException+ onCont' _ (Just e) = E.throw e --- |The pure n-chunk enumerator--- It passes a given chunk of elements to the iteratee in n chunks--- This enumerator does no IO and is useful for testing of base parsing--- and handling of chunk boundaries-enumPureNChunk :: (SC.StreamChunk s el, Monad m) =>- s el ->- Int ->- EnumeratorGM s el m a-enumPureNChunk str _ iter | SC.null str = return iter-enumPureNChunk str n iter | n > 0 = runIter iter (Chunk s1) >>=- checkIfDone (enumPureNChunk s2 n)+-- |Run an iteratee, returning either the result or the iteratee exception.+-- Note that only internal iteratee exceptions will be returned; exceptions+-- thrown with @Control.Exception.throw@ or @Control.Monad.CatchIO.throw@ will+-- not be returned.+-- +-- See 'Data.Iteratee.Exception.IFException' for details.+tryRun :: (Exception e, Monad m) => Iteratee s m a -> m (Either e a)+tryRun iter = runIter iter onDone onCont where- (s1, s2) = SC.splitAt n str-enumPureNChunk _ n _ = error $ "enumPureNChunk called with n==" ++ show n---- |A variant of join for Iteratees in a monad.-joinIM :: (Monad m) => m (IterateeG s el m a) -> IterateeG s el m a-joinIM m = IterateeG (\str -> m >>= flip runIter str)+ onDone x _ = return $ Right x+ onCont k Nothing = runIter (k (EOF Nothing)) onDone onCont'+ onCont _ (Just e) = return $ maybeExc e+ onCont' _ Nothing = return $ maybeExc (toException EofException)+ onCont' _ (Just e) = return $ maybeExc e+ maybeExc e = maybe (Left (E.throw e)) Left (fromException e) --- --------------------------------------------------------------------------- Monadic variants of iteratees+-- |Transform a computation inside an @Iteratee@.+mapIteratee :: (NullPoint s, Monad n, Monad m) =>+ (m a -> n b)+ -> Iteratee s m a+ -> Iteratee s n b+mapIteratee f = lift . f . run+{-# DEPRECATED mapIteratee "This function will be removed, compare to 'ilift'" #-} --- | Map a monadic function over all elements of a stream, and ignore the result-mapM_ :: (LL.ListLike (s el) el, MonadIO m)- => (el -> m ()) -> IterateeG s el m ()-mapM_ f = IterateeG step- where- step (Chunk xs) | LL.null xs = return $ Cont (IterateeG step) Nothing- step (Chunk xs) = do LL.mapM_ f xs- return $ Cont (IterateeG step) Nothing- step stream = return $ Done () stream+-- | Lift a computation in the inner monad of an iteratee.+-- +-- A simple use would be to lift a logger iteratee to a monad stack.+-- +-- > logger :: Iteratee String IO ()+-- > logger = mapChunksM_ putStrLn+-- > +-- > loggerG :: MonadIO m => Iteratee String m ()+-- > loggerG = ilift liftIO logger+-- +-- A more complex example would involve lifting an iteratee to work with+-- interleaved streams. See the example at 'Data.Iteratee.ListLike.merge'.+ilift ::+ (Monad m, Monad n)+ => (forall r. m r -> n r)+ -> Iteratee s m a+ -> Iteratee s n a+ilift f i = Iteratee $ \od oc ->+ let onDone a str = return $ Left (a,str)+ onCont k mErr = return $ Right (ilift f . k, mErr)+ in f (runIter i onDone onCont) >>= either (uncurry od) (uncurry oc) -{-# INLINE mapM_ #-}+-- | Lift a computation in the inner monad of an iteratee, while threading+-- through an accumulator.+ifold :: (Monad m, Monad n) => (forall r. m r -> acc -> n (r, acc))+ -> acc -> Iteratee s m a -> Iteratee s n (a, acc)+ifold f acc i = Iteratee $ \ od oc -> do+ (r, acc') <- flip f acc $+ runIter i (curry $ return . Left) (curry $ return . Right)+ either (uncurry (od . flip (,) acc'))+ (uncurry (oc . (ifold f acc .))) r
src/Data/Iteratee/Base/LooseMap.hs view
@@ -1,4 +1,9 @@-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}++-- |Monadic Iteratees: incremental input parsers, processors, and transformers+--+-- Maps over restricted-element containers+ module Data.Iteratee.Base.LooseMap ( LooseMap (..) )@@ -6,7 +11,9 @@ where -- |Enable map functions for containers that require class contexts on the--- element types. There's really no reason to ever use this with--- types that are fully polymorphic, such as Lists.+-- element types. For lists, this is identical to plain `map`. class LooseMap c el el' where- looseMap :: (el -> el') -> c el -> c el'+ lMap :: (el -> el') -> c el -> c el'++instance LooseMap [] el el' where+ lMap = map
+ src/Data/Iteratee/Base/ReadableChunk.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies #-}++-- |Monadic Iteratees:+-- incremental input parsers, processors and transformers+--+-- Support for IO enumerators++module Data.Iteratee.Base.ReadableChunk (+ ReadableChunk (..)+)+where++import Prelude hiding (head, tail, dropWhile, length, splitAt )++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.Word+import Control.Monad.IO.Class+import Foreign.C+import Foreign.Ptr+import Foreign.Storable+import Foreign.Marshal.Array++-- |Class of streams which can be filled from a 'Ptr'. Typically these+-- are streams which can be read from a file, @Handle@, or similar resource.+--+--+class (Storable el) => ReadableChunk s el | s -> el where+ readFromPtr ::+ MonadIO m =>+ Ptr el+ -> Int -- ^ The pointer must not be used after @readFromPtr@ completes.+ -> m s -- ^ The Int parameter is the length of the data in *bytes*.++instance ReadableChunk [Char] Char where+ readFromPtr buf l = liftIO $ peekCAStringLen (castPtr buf, l)++instance ReadableChunk [Word8] Word8 where+ readFromPtr buf l = liftIO $ peekArray l buf+instance ReadableChunk [Word16] Word16 where+ readFromPtr buf l = liftIO $ peekArray l buf+instance ReadableChunk [Word32] Word32 where+ readFromPtr buf l = liftIO $ peekArray l buf+instance ReadableChunk [Word] Word where+ readFromPtr buf l = liftIO $ peekArray l buf++instance ReadableChunk B.ByteString Word8 where+ readFromPtr buf l = liftIO $ B.packCStringLen (castPtr buf, l)++instance ReadableChunk L.ByteString Word8 where+ readFromPtr buf l = liftIO $+ return . L.fromChunks . (:[]) =<< readFromPtr buf l
− src/Data/Iteratee/Base/StreamChunk.hs
@@ -1,95 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}---- |Monadic and General Iteratees:--- incremental input parsers, processors and transformers--module Data.Iteratee.Base.StreamChunk (- -- * Types- StreamChunk (..),- ReadableChunk (..)-)-where--import Prelude hiding (head, tail, dropWhile, length, splitAt )-import qualified Prelude as P--import qualified Data.List as L-import qualified Data.ListLike as LL-import Data.Word-import Foreign.C-import Foreign.Ptr-import Foreign.Storable-import Foreign.Marshal.Array-import System.IO---- |Class of types that can be used to hold chunks of data within Iteratee--- streams.-class LL.ListLike (c el) el => StreamChunk c el where- -- |Length of currently available data.- length :: c el -> Int- length = LL.length-- -- |Test if the current stream is null.- null :: c el -> Bool- null = LL.null-- -- |Prepend an element to the front of the data.- cons :: el -> c el -> c el- cons = LL.cons-- -- |Return the first element of the stream.- head :: c el -> el- head = LL.head-- -- |Return the tail of the stream.- tail :: c el -> c el- tail = LL.tail-- -- |First index matching the predicate.- findIndex :: (el -> Bool) -> c el -> Maybe Int- findIndex = LL.findIndex-- -- |Split the data at the specified index.- splitAt :: Int -> c el -> (c el, c el)- splitAt = LL.splitAt-- -- |Drop data matching the predicate.- dropWhile :: (el -> Bool) -> c el -> c el- dropWhile = LL.dropWhile-- -- |Create a stream from a list.- fromList :: [el] -> c el- fromList = LL.fromList-- -- |Create a list from the stream.- toList :: c el -> [el]- toList = LL.toList-- -- |Map a computation over the stream.- cMap :: (StreamChunk c el') => (el -> el') -> c el -> c el'- cMap f = LL.foldr (LL.cons . f) LL.empty--instance StreamChunk [] el where- cMap = map---- |Class of streams which can be filled from a 'Ptr'. Typically these--- are streams which can be read from a file.--- The Int parameter is the length of the data in bytes.--- N.B. The pointer must not be returned or used after readFromPtr completes.-class (StreamChunk s el, Storable el) => ReadableChunk s el where- readFromPtr :: Ptr (el) -> Int -> IO (s el)--instance ReadableChunk [] Char where- readFromPtr buf l = peekCAStringLen (castPtr buf, l)--instance ReadableChunk [] Word8 where- readFromPtr = flip peekArray--instance ReadableChunk [] Word16 where- readFromPtr = flip peekArray--instance ReadableChunk [] Word32 where- readFromPtr = flip peekArray--instance ReadableChunk [] Word where- readFromPtr = flip peekArray
src/Data/Iteratee/Binary.hs view
@@ -1,77 +1,197 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts, BangPatterns #-} --- |Iteratees for parsing binary data.+-- |Monadic Iteratees:+-- incremental input parsers, processors, and transformers+--+-- Iteratees for parsing binary data.+ module Data.Iteratee.Binary ( -- * Types- Endian (..),+ Endian (..) -- * Endian multi-byte iteratees- endianRead2,- endianRead3,- endianRead4+ ,endianRead2+ ,endianRead3+ ,endianRead3i+ ,endianRead4+ ,endianRead8+ -- ** bytestring specializations+ -- | In current versions of @iteratee@ there is no difference between the+ -- bytestring specializations and polymorphic functions. They exist+ -- for compatibility.+ ,readWord16be_bs+ ,readWord16le_bs+ ,readWord32be_bs+ ,readWord32le_bs+ ,readWord64be_bs+ ,readWord64le_bs ) where -import Data.Iteratee.Base.StreamChunk (StreamChunk)-import qualified Data.Iteratee.Base as It+import Data.Iteratee.Base+import qualified Data.Iteratee.ListLike as I+import qualified Data.ListLike as LL+import qualified Data.ByteString as B import Data.Word import Data.Bits import Data.Int - -- ------------------------------------------------------------------------ -- Binary Random IO Iteratees -- Iteratees to read unsigned integers written in Big- or Little-endian ways --- |Indicate endian-ness.+-- | Indicate endian-ness. data Endian = MSB -- ^ Most Significant Byte is first (big-endian) | LSB -- ^ Least Significan Byte is first (little-endian) deriving (Eq, Ord, Show, Enum) -endianRead2 :: (StreamChunk s Word8, Monad m) => Endian ->- It.IterateeG s Word8 m Word16-endianRead2 e = do- c1 <- It.head- c2 <- It.head- case e of- MSB -> return $ (fromIntegral c1 `shiftL` 8) .|. fromIntegral c2- LSB -> return $ (fromIntegral c2 `shiftL` 8) .|. fromIntegral c1+endianRead2+ :: (Nullable s, LL.ListLike s Word8, Monad m)+ => Endian+ -> Iteratee s m Word16+endianRead2 e = endianReadN e 2 word16'+{-# INLINE endianRead2 #-} --- |read 3 bytes in an endian manner. If the first bit is set (negative),--- set the entire first byte so the Word32 can be properly set negative as+endianRead3+ :: (Nullable s, LL.ListLike s Word8, Monad m)+ => Endian+ -> Iteratee s m Word32+endianRead3 e = endianReadN e 3 (word32' . (0:))+{-# INLINE endianRead3 #-}++-- |Read 3 bytes in an endian manner. If the first bit is set (negative),+-- set the entire first byte so the Int32 will be negative as -- well.-endianRead3 :: (StreamChunk s Word8, Monad m) => Endian ->- It.IterateeG s Word8 m Word32-endianRead3 e = do- c1 <- It.head- c2 <- It.head- c3 <- It.head+endianRead3i+ :: (Nullable s, LL.ListLike s Word8, Monad m)+ => Endian+ -> Iteratee s m Int32+endianRead3i e = do+ c1 <- I.head+ c2 <- I.head+ c3 <- I.head case e of MSB -> return $ (((fromIntegral c1 `shiftL` 8) .|. fromIntegral c2) `shiftL` 8) .|. fromIntegral c3 LSB -> let m :: Int32- m = shiftR (shiftL (fromIntegral c3) 24) 8 in- return $ (((fromIntegral c3+ m = shiftR (shiftL (fromIntegral c3) 24) 8+ in return $ (((fromIntegral c3 `shiftL` 8) .|. fromIntegral c2) `shiftL` 8) .|. fromIntegral m+{-# INLINE endianRead3i #-} -endianRead4 :: (StreamChunk s Word8, Monad m) => Endian ->- It.IterateeG s Word8 m Word32-endianRead4 e = do- c1 <- It.head- c2 <- It.head- c3 <- It.head- c4 <- It.head- case e of- MSB -> return $- (((((fromIntegral c1- `shiftL` 8) .|. fromIntegral c2)- `shiftL` 8) .|. fromIntegral c3)- `shiftL` 8) .|. fromIntegral c4- LSB -> return $- (((((fromIntegral c4- `shiftL` 8) .|. fromIntegral c3)- `shiftL` 8) .|. fromIntegral c2)- `shiftL` 8) .|. fromIntegral c1+endianRead4+ :: (Nullable s, LL.ListLike s Word8, Monad m)+ => Endian+ -> Iteratee s m Word32+endianRead4 e = endianReadN e 4 word32'+{-# INLINE endianRead4 #-}++endianRead8+ :: (Nullable s, LL.ListLike s Word8, Monad m)+ => Endian+ -> Iteratee s m Word64+endianRead8 e = endianReadN e 8 word64'+{-# INLINE endianRead8 #-}++-- This function does all the parsing work, depending upon provided arguments+endianReadN ::+ (Nullable s, LL.ListLike s Word8, Monad m)+ => Endian+ -> Int+ -> ([Word8] -> b)+ -> Iteratee s m b+endianReadN MSB n0 cnct = liftI (step n0 [])+ where+ step !n acc (Chunk c)+ | LL.null c = liftI (step n acc)+ | LL.length c >= n = let (this,next) = LL.splitAt n c+ !result = cnct $ acc ++ LL.toList this+ in idone result (Chunk next)+ | otherwise = liftI (step (n - LL.length c) (acc ++ LL.toList c))+ step !n acc (EOF Nothing) = icont (step n acc) (Just $ toException EofException)+ step !n acc (EOF (Just e)) = icont (step n acc) (Just e)+endianReadN LSB n0 cnct = liftI (step n0 [])+ where+ step !n acc (Chunk c)+ | LL.null c = liftI (step n acc)+ | LL.length c >= n = let (this,next) = LL.splitAt n c+ !result = cnct $ reverse (LL.toList this) ++ acc+ in idone result (Chunk next)+ | otherwise = liftI (step (n - LL.length c)+ (reverse (LL.toList c) ++ acc))+ step !n acc (EOF Nothing) = icont (step n acc)+ (Just $ toException EofException)+ step !n acc (EOF (Just e)) = icont (step n acc) (Just e)+{-# INLINE endianReadN #-}++-- As of now, the polymorphic code is as fast as the best specializations+-- I have found, so these just call out. They may be improved in the+-- future, or possibly deprecated.+-- JWL, 2012-01-16++readWord16be_bs :: Monad m => Iteratee B.ByteString m Word16+readWord16be_bs = endianRead2 MSB+{-# INLINE readWord16be_bs #-}++readWord16le_bs :: Monad m => Iteratee B.ByteString m Word16+readWord16le_bs = endianRead2 LSB+{-# INLINE readWord16le_bs #-}++readWord32be_bs :: Monad m => Iteratee B.ByteString m Word32+readWord32be_bs = endianRead4 MSB+{-# INLINE readWord32be_bs #-}++readWord32le_bs :: Monad m => Iteratee B.ByteString m Word32+readWord32le_bs = endianRead4 LSB+{-# INLINE readWord32le_bs #-}++readWord64be_bs :: Monad m => Iteratee B.ByteString m Word64+readWord64be_bs = endianRead8 MSB+{-# INLINE readWord64be_bs #-}++readWord64le_bs :: Monad m => Iteratee B.ByteString m Word64+readWord64le_bs = endianRead8 LSB+{-# INLINE readWord64le_bs #-}++word16' :: [Word8] -> Word16+word16' [c1,c2] = word16 c1 c2+word16' _ = error "iteratee: internal error in word16'"++word16 :: Word8 -> Word8 -> Word16+word16 c1 c2 = (fromIntegral c1 `shiftL` 8) .|. fromIntegral c2+{-# INLINE word16 #-}++word32' :: [Word8] -> Word32+word32' [c1,c2,c3,c4] = word32 c1 c2 c3 c4+word32' _ = error "iteratee: internal error in word32'"++word32 :: Word8 -> Word8 -> Word8 -> Word8 -> Word32+word32 c1 c2 c3 c4 =+ (fromIntegral c1 `shiftL` 24) .|.+ (fromIntegral c2 `shiftL` 16) .|.+ (fromIntegral c3 `shiftL` 8) .|.+ fromIntegral c4+{-# INLINE word32 #-}++word64' :: [Word8] -> Word64+word64' [c1,c2,c3,c4,c5,c6,c7,c8] = word64 c1 c2 c3 c4 c5 c6 c7 c8+word64' _ = error "iteratee: internal error in word64'"+{-# INLINE word64' #-}++word64+ :: Word8 -> Word8 -> Word8 -> Word8 + -> Word8 -> Word8 -> Word8 -> Word8 + -> Word64+word64 c1 c2 c3 c4 c5 c6 c7 c8 =+ (fromIntegral c1 `shiftL` 56) .|.+ (fromIntegral c2 `shiftL` 48) .|.+ (fromIntegral c3 `shiftL` 40) .|.+ (fromIntegral c4 `shiftL` 32) .|.+ (fromIntegral c5 `shiftL` 24) .|.+ (fromIntegral c6 `shiftL` 16) .|.+ (fromIntegral c7 `shiftL` 8) .|.+ fromIntegral c8+{-# INLINE word64 #-}
src/Data/Iteratee/Char.hs view
@@ -1,170 +1,151 @@--- Haskell98!---- |Utilties for Char-based iteratee processing.+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-} --- The running example, parts 1 and 2--- Part 1 is reading the headers, the sequence of lines terminated by an--- empty line. Each line is terminated by CR, LF, or CRLF.--- We should return the headers in order. In the case of error,--- we should return the headers read so far and the description of the error.--- Part 2 is reading the headers and reading all the lines from the--- HTTP-chunk-encoded content that follows the headers. Part 2 thus--- verifies layering of streams, and processing of one stream--- embedded (chunk encoded) into another stream.+-- | Utilities for Char-based iteratee processing. module Data.Iteratee.Char (- -- * Type synonyms- Stream,- Iteratee,- EnumeratorM,- Line, -- * Word and Line processors- line,- printLines,- readLines,- enumLines,- enumWords,-- module Data.Iteratee.Base+ printLines+ ,printLinesUnterminated+ ,enumLines+ ,enumLinesBS+ ,enumWords+ ,enumWordsBS ) where -import qualified Data.Iteratee.Base as Iter-import Data.Iteratee.Base hiding (break, last)-import Data.Char-import Control.Monad.IO.Class+import Data.Iteratee.Iteratee+import qualified Data.Iteratee.ListLike as I+import Data.Iteratee.ListLike (heads)+import Data.Char+import Data.Monoid import qualified Data.ListLike as LL-import Data.Monoid+import Control.Monad (liftM)+import Control.Monad.IO.Class+import qualified Data.ByteString.Char8 as BC --- |A particular instance of StreamG: the stream of characters.--- This stream is used by many input parsers.-type Stream = StreamG [] Char -type Iteratee = IterateeG [] Char---- Useful combinators for implementing iteratees and enumerators--type Line = String -- The line of text, terminators are not included---- |Read the line of text from the stream--- The line can be terminated by CR, LF or CRLF.--- Return (Right Line) if successful. Return (Left Line) if EOF or--- a stream error were encountered before the terminator is seen.--- The returned line is the string read so far.---- The code is the same as that of pure Iteratee, only the signature--- has changed.--- Compare the code below with GHCBufferIO.line_lazy-line :: Monad m => IterateeG [] Char m (Either Line Line)-line = Iter.break (\c -> c == '\r' || c == '\n') >>= \l ->- terminators >>= check l- where- check l 0 = return . Left $ l- check l _ = return . Right $ l- terminators = heads "\r\n" >>= \l -> if l == 0 then heads "\n" else return l---- Line iteratees: processors of a stream whose elements are made of Lines---- Collect all read lines and return them as a list--- see stream2list- -- |Print lines as they are received. This is the first `impure' iteratee -- with non-trivial actions during chunk processing-printLines :: IterateeG [] Char IO ()+--+-- Only lines ending with a newline are printed,+-- data terminated with EOF is not printed.+printLines :: Iteratee String IO () printLines = lines'- where- lines' = Iter.break (\c -> c == '\r' || c == '\n') >>= \l ->- terminators >>= check l+ where+ lines' = I.break (`elem` "\r\n") >>= \l -> terminators >>= check l check _ 0 = return () check "" _ = return () check l _ = liftIO (putStrLn l) >> lines'- terminators = heads "\r\n" >>= \l -> if l == 0 then heads "\n" else return l ---- |Read a sequence of lines from the stream up to the empty lin--- The line can be terminated by CR, LF, or CRLF -- or by EOF or stream error.--- Return the read lines, in order, not including the terminating empty line--- Upon EOF or stream error, return the complete, terminated lines accumulated--- so far.+-- |Print lines as they are received.+--+-- All lines are printed, including a line with a terminating EOF.+-- If the final line is terminated by EOF without a newline,+-- no newline is printed.+-- this function should be used in preference to printLines when possible,+-- as it is more efficient with long lines.+printLinesUnterminated :: forall s el.+ (Eq el, Nullable s, LL.StringLike s, LL.ListLike s el)+ => Iteratee s IO ()+printLinesUnterminated = lines'+ where+ lines' = do+ joinI $ I.breakE (`LL.elem` t1) (I.mapChunksM_ (putStr . LL.toString))+ terminators >>= check+ check 0 = return ()+ check _ = liftIO (putStrLn "") >> lines'+ t1 :: s+ t1 = LL.fromString "\r\n" -readLines :: (Monad m) => IterateeG [] Char m (Either [Line] [Line])-readLines = lines' []- where- lines' acc = Iter.break (\c -> c == '\r' || c == '\n') >>= \l ->- terminators >>= check acc l- check acc _ 0 = return . Left . reverse $ acc -- no terminator found- check acc "" _ = return . Right . reverse $ acc- check acc l _ = lines' (l:acc)- terminators = heads "\r\n" >>= \l -> if l == 0 then heads "\n" else return l+terminators :: (Eq el, Nullable s, LL.StringLike s, LL.ListLike s el)+ => Iteratee s IO Int+terminators = do+ l <- heads (LL.fromString "\r\n")+ if l == 0 then heads (LL.fromString "\n") else return l -- |Convert the stream of characters to the stream of lines, and -- apply the given iteratee to enumerate the latter. -- The stream of lines is normally terminated by the empty line. -- When the stream of characters is terminated, the stream of lines--- is also terminated, abnormally.+-- is also terminated. -- This is the first proper iteratee-enumerator: it is the iteratee of the -- character stream and the enumerator of the line stream. -enumLines :: (LL.ListLike (s el) el, LL.StringLike (s el), Functor m, Monad m) =>- IterateeG [] (s el) m a ->- IterateeG s el m (IterateeG [] (s el) m a)+enumLines+ :: (LL.ListLike s el, LL.StringLike s, Nullable s, Monad m) =>+ Enumeratee s [s] m a enumLines = convStream getter where- getter = IterateeG step+ getter = icont step Nothing lChar = (== '\n') . last . LL.toString step (Chunk xs)- | LL.null xs = return $ Cont getter Nothing- | lChar xs = return $ Done (Just $ LL.lines xs) (Chunk mempty)- | True = return $ Cont (IterateeG (step' xs)) Nothing- step str = return $ Done Nothing str+ | LL.null xs = getter+ | lChar xs = idone (LL.lines xs) mempty+ | otherwise = icont (step' xs) Nothing+ step _str = getter step' xs (Chunk ys)- | LL.null ys = return $ Cont (IterateeG (step' xs)) Nothing- | lChar ys = return $ Done (Just . LL.lines . mappend xs $ ys)- (Chunk mempty)- | True = let w' = LL.lines $ mappend xs ys+ | LL.null ys = icont (step' xs) Nothing+ | lChar ys = idone (LL.lines . mappend xs $ ys) mempty+ | otherwise = let w' = LL.lines $ mappend xs ys ws = init w' ck = last w'- in return $ Done (Just ws) (Chunk ck)- step' xs str = return $ Done (Just $ LL.lines xs) str-+ in idone ws (Chunk ck)+ step' xs str = idone (LL.lines xs) str -- |Convert the stream of characters to the stream of words, and -- apply the given iteratee to enumerate the latter. -- Words are delimited by white space. -- This is the analogue of List.words--- One should keep in mind that enumWords is a more general, monadic--- function.+enumWords :: (LL.ListLike s Char, Nullable s, Monad m) => Enumeratee s [s] m a+enumWords = convStream $ I.dropWhile isSpace >> liftM (:[]) (I.break isSpace)+{-# INLINE enumWords #-} -enumWords :: (LL.ListLike (s el) el- , LL.StringLike (s el)- , Functor m, Monad m)- => IterateeG [] (s el) m a- -> IterateeG s el m (IterateeG [] (s el) m a)-enumWords = convStream getter+-- Like enumWords, but operates on ByteStrings.+-- This is provided as a higher-performance alternative to enumWords, and+-- is equivalent to treating the stream as a Data.ByteString.Char8.ByteString.+enumWordsBS+ :: (Monad m) => Enumeratee BC.ByteString [BC.ByteString] m a +enumWordsBS iter = convStream getter iter where- getter = IterateeG step- lChar = isSpace . last . LL.toString- step (Chunk xs) | LL.null xs = return $ Cont getter Nothing+ getter = liftI step+ lChar = isSpace . BC.last step (Chunk xs)- | LL.null xs = return $ Cont getter Nothing- | lChar xs = return $ Done (Just $ LL.words xs) (Chunk mempty)- | True = return $ Cont (IterateeG (step' xs)) Nothing- step str = return $ Done Nothing str+ | BC.null xs = getter+ | lChar xs = idone (BC.words xs) (Chunk BC.empty)+ | otherwise = icont (step' xs) Nothing+ step str = idone mempty str step' xs (Chunk ys)- | LL.null ys = return $ Cont (IterateeG (step' xs)) Nothing- | lChar ys = return $ Done (Just . LL.words . mappend xs $ ys)- (Chunk mempty)- | True = let w' = LL.words $ mappend xs ys+ | BC.null ys = icont (step' xs) Nothing+ | lChar ys = idone (BC.words . BC.append xs $ ys) mempty+ | otherwise = let w' = BC.words . BC.append xs $ ys ws = init w' ck = last w'- in return $ Done (Just ws) (Chunk ck)- step' xs str = return $ Done (Just $ LL.words xs) str+ in idone ws (Chunk ck)+ step' xs str = idone (BC.words xs) str -{-# INLINE enumWords #-}+{-# INLINE enumWordsBS #-} --- --------------------------------------------------------------------------- Enumerators+-- Like enumLines, but operates on ByteStrings.+-- This is provided as a higher-performance alternative to enumLines, and+-- is equivalent to treating the stream as a Data.ByteString.Char8.ByteString.+enumLinesBS :: (Monad m) => Enumeratee BC.ByteString [BC.ByteString] m a+enumLinesBS = convStream getter+ where+ getter = icont step Nothing+ lChar = (== '\n') . BC.last+ step (Chunk xs)+ | BC.null xs = getter+ | lChar xs = idone (BC.lines xs) (Chunk BC.empty)+ | otherwise = icont (step' xs) Nothing+ step str = idone mempty str+ step' xs (Chunk ys)+ | BC.null ys = icont (step' xs) Nothing+ | lChar ys = idone (BC.lines . BC.append xs $ ys) mempty+ | otherwise = let w' = BC.lines $ BC.append xs ys+ ws = init w'+ ck = last w'+ in idone ws (Chunk ck)+ step' xs str = idone (BC.lines xs) str -type EnumeratorM m a = EnumeratorGM [] Char m a
− src/Data/Iteratee/Codecs/Tiff.hs
@@ -1,626 +0,0 @@-{-# LANGUAGE Rank2Types #-}---- Random and Binary IO with IterateeM---- A general-purpose TIFF library---- The library gives the user the TIFF dictionary, which the user--- can search for specific tags and obtain the values associated with--- the tags, including the pixel matrix.------ The overarching theme is incremental processing: initially,--- only the TIFF dictionary is read. The value associated with a tag--- is read only when that tag is looked up (unless the value was short--- and was packed in the TIFF dictionary entry). The pixel matrix--- (let alone the whole TIFF file) is not loaded in memory ----- the pixel matrix is not even located before it is needed.--- The matrix is processed incrementally, by a user-supplied--- iteratee.------ The incremental processing is accomplished by iteratees and enumerators.--- The enumerators are indeed first-class, they are stored--- in the interned TIFF dictionary data structure. These enumerators--- represent the values associated with tags; the values will be read--- on demand, when the enumerator is applied to a user-given iteratee.------ The library extensively uses nested streams, tacitly converting the--- stream of raw bytes from the file into streams of integers,--- rationals and other user-friendly items. The pixel matrix is--- presented as a contiguous stream, regardless of its segmentation--- into strips and physical arrangement.--- The library exhibits random IO and binary parsing, reading--- of multi-byte numeric data in big- or little-endian formats.--- The library can be easily adopted for AIFF, RIFF and other--- IFF formats.------ We show a representative application of the library: reading a sample--- TIFF file, printing selected values from the TIFF dictionary,--- verifying the values of selected pixels and computing the histogram--- of pixel values. The pixel verification procedure stops reading the--- pixel matrix as soon as all specified pixel values are verified.--- The histogram accumulation does read the entire matrix, but--- incrementally. Neither pixel matrix processing procedure loads--- the whole matrix in memory. In fact, we never read and retain--- more than the IO-buffer-full of raw data.---- This TIFF library is to be contrasted with the corresponding Scheme--- code:--- http://okmij.org/ftp/Scheme/binary-io.html#tiff--- The main distinction is using iteratees for on-demand processing.--module Data.Iteratee.Codecs.Tiff {-# DEPRECATED "This will be moved to a separate package in the future" #-} where--import Data.Iteratee-import qualified Data.Iteratee as Iter-import qualified Data.Iteratee.Base.StreamChunk as SC-import Data.Iteratee.Binary-import Control.Monad-import Control.Monad.Trans-import Data.Char (chr)-import Data.Int-import Data.Word-import Data.Ratio-import Data.Maybe-import qualified Data.IntMap as IM----- ========================================================================--- Sample TIFF user code--- The following is sample code using the TIFF library (whose implementation--- is in the second part of this file).--- Our sample code prints interesting information from the TIFF--- dictionary (such as the dimensions, the resolution and the name--- of the image)---- The main user function. tiff_reader is the library function,--- which builds the TIFF dictionary.--- process_tiff is the user function, to extract useful data--- from the dictionary--- test_tiff :: IO (Maybe String)--- test_tiff = test_driver_random (tiff_reader >>= process_tiff) "filename.tiff"---- Sample TIFF processing function-process_tiff :: MonadIO m => Maybe (IM.IntMap TIFFDE) ->- IterateeG [] Word8 m ()-process_tiff Nothing = return ()-process_tiff (Just dict) = do- note ["dict size: ", show $ IM.size dict]- -- Check tag values against the known values for the sample image- check_tag TG_IMAGEWIDTH (flip dict_read_int dict) 129- check_tag TG_IMAGELENGTH (flip dict_read_int dict) 122- check_tag TG_BITSPERSAMPLE (flip dict_read_int dict) 8- check_tag TG_IMAGEDESCRIPTION (flip dict_read_string dict)- "JPEG:gnu-head-sm.jpg 129x122"- check_tag TG_COMPRESSION (flip dict_read_int dict) 1- check_tag TG_SAMPLESPERPIXEL (flip dict_read_int dict) 1- check_tag TG_STRIPBYTECOUNTS (flip dict_read_int dict) 15738 -- nrows*ncols- check_tag TG_XRESOLUTION (flip dict_read_rat dict) (72%1)- check_tag TG_YRESOLUTION (flip dict_read_rat dict) (72%1)-- (n,hist) <- compute_hist dict- note ["computed histogram over ", show n, " values\n", show hist]- --iterReportError >>= maybe (return ()) error- note ["Verifying values of sample pixels"]- verify_pixel_vals dict [(0,255), (17,248)]- --err <- iterReportError- --maybe (return ()) error err- --return err- where check_tag tag action v = do- vc <- action tag- case vc of- Just v' | v' == v -> note ["Tag ",show tag, " value ", show v]- _ -> error $ unwords ["Tag", show tag, "unexpected:", show vc]---- process_tiff Nothing = return Nothing---- sample processing of the pixel matrix: computing the histogram-compute_hist :: MonadIO m =>- TIFFDict ->- IterateeG [] Word8 m (Int,IM.IntMap Int)-compute_hist dict = Iter.joinI $ pixel_matrix_enum dict $ compute_hist' 0 IM.empty- where- --compute_hist' count = liftI . Cont . step count- compute_hist' count hist = IterateeG (step count hist)- step count hist (Chunk ch)- | SC.null ch = return $ Cont (compute_hist' count hist) Nothing- | otherwise = return $ Cont- (compute_hist' (count + SC.length ch) (foldr accum hist ch))- Nothing- step count hist s = return $ Done (count,hist) s- accum e = IM.insertWith (+) (fromIntegral e) 1---- Another sample processor of the pixel matrix: verifying values of--- some pixels--- This processor does not read the whole matrix; it stops as soon--- as everything is verified or the error is detected-verify_pixel_vals :: MonadIO m =>- TIFFDict -> [(IM.Key, Word8)] -> IterateeG [] Word8 m ()-verify_pixel_vals dict pixels = Iter.joinI $ pixel_matrix_enum dict $- verify 0 (IM.fromList pixels)- where- verify _ m | IM.null m = return ()- verify n m = IterateeG (step n m)- step n m (Chunk xs)- | SC.null xs = return $ Cont (verify n m) Nothing- | otherwise = let (h, t) = (SC.head xs, SC.tail xs) in- case IM.updateLookupWithKey (\_k _e -> Nothing) n m of- (Just v,m') -> if v == h- then step (succ n) m' (Chunk t)- else let er = (unwords ["Pixel #",show n,- "expected:",show v,- "found", show h])- in return $ Cont (throwErr . Err $ er) (Just $ Err er)- (Nothing,m')-> step (succ n) m' (Chunk t)- step _n _m s = return $ Done () s----- ========================================================================--- TIFF library code---- A TIFF directory is a finite map associating a TIFF tag with--- a record TIFFDE-type TIFFDict = IM.IntMap TIFFDE--data TIFFDE = TIFFDE{tiffde_count :: Int, -- number of items- tiffde_enum :: TIFFDE_ENUM -- enumerator to get values- }--data TIFFDE_ENUM =- TEN_CHAR (forall a m. Monad m => EnumeratorGMM [] Word8 [] Char m a)- | TEN_BYTE (forall a m. Monad m => EnumeratorGMM [] Word8 [] Word8 m a)- | TEN_INT (forall a m. Monad m => EnumeratorGMM [] Word8 [] Int m a)- | TEN_RAT (forall a m. Monad m => EnumeratorGMM [] Word8 [] (Ratio Int) m a)---- Standard TIFF data types-data TIFF_TYPE = TT_NONE -- 0- | TT_byte -- 1 8-bit unsigned integer- | TT_ascii -- 2 8-bit bytes with last byte null- | TT_short -- 3 16-bit unsigned integer- | TT_long -- 4 32-bit unsigned integer- | TT_rational -- 5 64-bit fractional (numer+denominator)- -- The following was added in TIFF 6.0- | TT_sbyte -- 6 8-bit signed (2s-complement) integer- | TT_undefined -- 7 An 8-bit byte, "8-bit chunk"- | TT_sshort -- 8 16-bit signed (2s-complement) integer- | TT_slong -- 9 32-bit signed (2s-complement) integer- | TT_srational -- 10 "signed rational", two SLONGs (num+denominator)- | TT_float -- 11 "IEEE 32-bit float", single precision (4-byte)- | TT_double -- 12 "IEEE 64-bit double", double precision (8-byte)- deriving (Eq, Enum, Ord, Bounded, Show)----- Standard TIFF tags-data TIFF_TAG = TG_other Int -- other than below- | TG_SUBFILETYPE -- subfile data descriptor- | TG_OSUBFILETYPE -- +kind of data in subfile- | TG_IMAGEWIDTH -- image width in pixels- | TG_IMAGELENGTH -- image height in pixels- | TG_BITSPERSAMPLE -- bits per channel (sample)- | TG_COMPRESSION -- data compression technique- | TG_PHOTOMETRIC -- photometric interpretation- | TG_THRESHOLDING -- +thresholding used on data- | TG_CELLWIDTH -- +dithering matrix width- | TG_CELLLENGTH -- +dithering matrix height- | TG_FILLORDER -- +data order within a byte- | TG_DOCUMENTNAME -- name of doc. image is from- | TG_IMAGEDESCRIPTION -- info about image- | TG_MAKE -- scanner manufacturer name- | TG_MODEL -- scanner model name/number- | TG_STRIPOFFSETS -- offsets to data strips- | TG_ORIENTATION -- +image orientation- | TG_SAMPLESPERPIXEL -- samples per pixel- | TG_ROWSPERSTRIP -- rows per strip of data- | TG_STRIPBYTECOUNTS -- bytes counts for strips- | TG_MINSAMPLEVALUE -- +minimum sample value- | TG_MAXSAMPLEVALUE -- maximum sample value- | TG_XRESOLUTION -- pixels/resolution in x- | TG_YRESOLUTION -- pixels/resolution in y- | TG_PLANARCONFIG -- storage organization- | TG_PAGENAME -- page name image is from- | TG_XPOSITION -- x page offset of image lhs- | TG_YPOSITION -- y page offset of image lhs- | TG_FREEOFFSETS -- +byte offset to free block- | TG_FREEBYTECOUNTS -- +sizes of free blocks- | TG_GRAYRESPONSEUNIT -- gray scale curve accuracy- | TG_GRAYRESPONSECURVE -- gray scale response curve- | TG_GROUP3OPTIONS -- 32 flag bits- | TG_GROUP4OPTIONS -- 32 flag bits- | TG_RESOLUTIONUNIT -- units of resolutions- | TG_PAGENUMBER -- page numbers of multi-page- | TG_COLORRESPONSEUNIT -- color scale curve accuracy- | TG_COLORRESPONSECURVE -- RGB response curve- | TG_SOFTWARE -- name & release- | TG_DATETIME -- creation date and time- | TG_ARTIST -- creator of image- | TG_HOSTCOMPUTER -- machine where created- | TG_PREDICTOR -- prediction scheme w/ LZW- | TG_WHITEPOINT -- image white point- | TG_PRIMARYCHROMATICITIES -- primary chromaticities- | TG_COLORMAP -- RGB map for pallette image- | TG_BADFAXLINES -- lines w/ wrong pixel count- | TG_CLEANFAXDATA -- regenerated line info- | TG_CONSECUTIVEBADFAXLINES -- max consecutive bad lines- | TG_MATTEING -- alpha channel is present- deriving (Eq, Show)--tag_map :: Num t => [(TIFF_TAG, t)]-tag_map = [- (TG_SUBFILETYPE,254),- (TG_OSUBFILETYPE,255),- (TG_IMAGEWIDTH,256),- (TG_IMAGELENGTH,257),- (TG_BITSPERSAMPLE,258),- (TG_COMPRESSION,259),- (TG_PHOTOMETRIC,262),- (TG_THRESHOLDING,263),- (TG_CELLWIDTH,264),- (TG_CELLLENGTH,265),- (TG_FILLORDER,266),- (TG_DOCUMENTNAME,269),- (TG_IMAGEDESCRIPTION,270),- (TG_MAKE,271),- (TG_MODEL,272),- (TG_STRIPOFFSETS,273),- (TG_ORIENTATION,274),- (TG_SAMPLESPERPIXEL,277),- (TG_ROWSPERSTRIP,278),- (TG_STRIPBYTECOUNTS,279),- (TG_MINSAMPLEVALUE,280),- (TG_MAXSAMPLEVALUE,281),- (TG_XRESOLUTION,282),- (TG_YRESOLUTION,283),- (TG_PLANARCONFIG,284),- (TG_PAGENAME,285),- (TG_XPOSITION,286),- (TG_YPOSITION,287),- (TG_FREEOFFSETS,288),- (TG_FREEBYTECOUNTS,289),- (TG_GRAYRESPONSEUNIT,290),- (TG_GRAYRESPONSECURVE,291),- (TG_GROUP3OPTIONS,292),- (TG_GROUP4OPTIONS,293),- (TG_RESOLUTIONUNIT,296),- (TG_PAGENUMBER,297),- (TG_COLORRESPONSEUNIT,300),- (TG_COLORRESPONSECURVE,301),- (TG_SOFTWARE,305),- (TG_DATETIME,306),- (TG_ARTIST,315),- (TG_HOSTCOMPUTER,316),- (TG_PREDICTOR,317),- (TG_WHITEPOINT,318),- (TG_PRIMARYCHROMATICITIES,319),- (TG_COLORMAP,320),- (TG_BADFAXLINES,326),- (TG_CLEANFAXDATA,327),- (TG_CONSECUTIVEBADFAXLINES,328),- (TG_MATTEING,32995)- ]--tag_map' :: IM.IntMap TIFF_TAG-tag_map' = IM.fromList $ map (\(tag,v) -> (v,tag)) tag_map--tag_to_int :: TIFF_TAG -> Int-tag_to_int (TG_other x) = x-tag_to_int x = fromMaybe (error $ "not found tag: " ++ show x) $ lookup x tag_map--int_to_tag :: Int -> TIFF_TAG-int_to_tag x = fromMaybe (TG_other x) $ IM.lookup x tag_map'----- The library function to read the TIFF dictionary-tiff_reader :: IterateeG [] Word8 IO (Maybe TIFFDict)-tiff_reader = do- endian <- read_magic- check_version- case endian of- Just e -> do- endianRead4 e >>= Iter.seek . fromIntegral- load_dict e- Nothing -> return Nothing- where- -- Read the magic and set the endianness- read_magic = do- c1 <- Iter.head- c2 <- Iter.head- case (c1,c2) of- (0x4d, 0x4d) -> return $ Just MSB- (0x49, 0x49) -> return $ Just LSB- _ -> (throwErr .Err $ "Bad TIFF magic word: " ++ show [c1,c2])- >> return Nothing-- -- Check the version in the header. It is always ...- tiff_version = 42- check_version = do- v <- endianRead2 MSB- if v == tiff_version- then return ()- else throwErr (Err $ "Bad TIFF version: " ++ show v)---- A few conversion procedures-u32_to_float :: Word32 -> Double-u32_to_float _x = -- unsigned 32-bit int -> IEEE float- error "u32->float is not yet implemented"--u32_to_s32 :: Word32 -> Int32 -- unsigned 32-bit int -> signed 32 bit-u32_to_s32 = fromIntegral--- u32_to_s32 0x7fffffff == 0x7fffffff--- u32_to_s32 0xffffffff == -1--u16_to_s16 :: Word16 -> Int16 -- unsigned 16-bit int -> signed 16 bit-u16_to_s16 = fromIntegral--- u16_to_s16 32767 == 32767--- u16_to_s16 32768 == -32768--- u16_to_s16 65535 == -1--u8_to_s8 :: Word8 -> Int8 -- unsigned 8-bit int -> signed 8 bit-u8_to_s8 = fromIntegral--- u8_to_s8 127 == 127--- u8_to_s8 128 == -128--- u8_to_s8 255 == -1--note :: (MonadIO m) => [String] -> IterateeG [] el m ()-note = liftIO . putStrLn . concat---- An internal function to load the dictionary. It assumes that the stream--- is positioned to read the dictionary-load_dict :: MonadIO m => Endian -> IterateeG [] Word8 m (Maybe TIFFDict)-load_dict e = do- nentries <- endianRead2 e- dict <- foldr (const read_entry) (return (Just IM.empty)) [1..nentries]- next_dict <- endianRead4 e- when (next_dict > 0) $- note ["The TIFF file contains several images, ",- "only the first one will be considered"]- return dict- where- read_entry dictM = dictM >>=- maybe (return Nothing) (\dict -> do- tag <- endianRead2 e- typ' <- endianRead2 e- typ <- convert_type (fromIntegral typ')- count <- endianRead4 e- -- we read the val-offset later. We need to check the size and the type- -- of the datum, because val-offset may contain the value itself,- -- in its lower-numbered bytes, regardless of the big/little endian- -- order!-- note ["TIFFEntry: tag ",show . int_to_tag . fromIntegral $ tag,- " type ", show typ, " count ", show count]- enum_m <- maybe (return Nothing)- (\t -> read_value t e (fromIntegral count)) typ- case enum_m of- Just enum ->- return . Just $ IM.insert (fromIntegral tag)- (TIFFDE (fromIntegral count) enum) dict- _ -> return (Just dict)- )-- convert_type :: (Monad m) => Int -> IterateeG [] el m (Maybe TIFF_TYPE)- convert_type typ | typ > 0 && typ <= fromEnum (maxBound::TIFF_TYPE)- = return . Just . toEnum $ typ- convert_type typ = do- throwErr . Err $ "Bad type of entry: " ++ show typ- return Nothing-- read_value :: MonadIO m => TIFF_TYPE -> Endian -> Int ->- IterateeG [] Word8 m (Maybe TIFFDE_ENUM)-- read_value typ e' 0 = do- endianRead4 e'- throwErr . Err $ "Zero count in the entry of type: " ++ show typ- return Nothing-- -- Read an ascii string from the offset in the- -- dictionary. The last byte of- -- an ascii string is always zero, which is- -- included in 'count' but we don't need to read it- read_value TT_ascii e' count | count > 4 = do -- val-offset is offset- offset <- endianRead4 e'- return . Just . TEN_CHAR $ \iter_char -> return $ do- Iter.seek (fromIntegral offset)- let iter = convStream- (liftM (either (const Nothing) (Just . (:[]) . chr . fromIntegral)) (checkErr Iter.head))- iter_char- Iter.joinI $ Iter.joinI $ Iter.takeR (pred count) iter-- -- Read the string of 0 to 3 characters long- -- The zero terminator is included in count, but- -- we don't need to read it- read_value TT_ascii _e count = do -- count is within 1..4- let len = pred count -- string length- let loop acc 0 = return . Just . reverse $ acc- loop acc n = Iter.head >>= (\v -> loop ((chr . fromIntegral $ v):acc)- (pred n))- str <- loop [] len- Iter.drop (4-len)- case str of- Just str' -> return . Just . TEN_CHAR $ immed_value str'- Nothing -> return Nothing-- -- Read the array of signed or unsigned bytes- read_value typ e' count | count > 4 && typ == TT_byte || typ == TT_sbyte = do- offset <- endianRead4 e'- return . Just . TEN_INT $ \iter_int -> return $ do- Iter.seek (fromIntegral offset)- let iter = convStream- (liftM (either (const Nothing) (Just . (:[]) . conv_byte typ)) (checkErr Iter.head))- iter_int- Iter.joinI $ Iter.joinI $ Iter.takeR count iter-- -- Read the array of 1 to 4 bytes- read_value typ _e count | typ == TT_byte || typ == TT_sbyte = do- let loop acc 0 = return . Just . reverse $ acc- loop acc n = Iter.head >>= (\v -> loop (conv_byte typ v:acc)- (pred n))- str <- (loop [] count)- Iter.drop (4-count)- case str of- Just str' -> return . Just . TEN_INT $ immed_value str'- Nothing -> return Nothing-- -- Read the array of Word8- read_value TT_undefined e' count | count > 4 = do- offset <- endianRead4 e'- return . Just . TEN_BYTE $ \iter -> return $ do- Iter.seek (fromIntegral offset)- Iter.joinI $ Iter.takeR count iter-- -- Read the array of Word8 of 1..4 elements,- -- packed in the offset field- read_value TT_undefined _e count = do- let loop acc 0 = return . Just . reverse $ acc- loop acc n = Iter.head >>= (\v -> loop (v:acc) (pred n))- str <- loop [] count- Iter.drop (4-count)- case str of- Just str' -> return . Just . TEN_BYTE $ immed_value str'- Nothing -> return Nothing- --return . Just . TEN_BYTE $ immed_value str-- -- Read the array of short integers-- -- of 1 element: the offset field contains the value- read_value typ e' 1 | typ == TT_short || typ == TT_sshort = do- item <- endianRead2 e'- Iter.drop 2 -- skip the padding- return . Just . TEN_INT $ immed_value [conv_short typ item]-- -- of 2 elements: the offset field contains the value- read_value typ e' 2 | typ == TT_short || typ == TT_sshort = do- i1 <- endianRead2 e'- i2 <- endianRead2 e'- return . Just . TEN_INT $- immed_value [conv_short typ i1, conv_short typ i2]-- -- of n elements- read_value typ e' count | typ == TT_short || typ == TT_sshort = do- offset <- endianRead4 e'- return . Just . TEN_INT $ \iter_int -> return $ do- Iter.seek (fromIntegral offset)- let iter = convStream- (liftM (either (const Nothing) (Just . (:[]) . conv_short typ)) (checkErr (endianRead2 e')))- iter_int- Iter.joinI $ Iter.joinI $ Iter.takeR (2*count) iter--- -- Read the array of long integers- -- of 1 element: the offset field contains the value- read_value typ e' 1 | typ == TT_long || typ == TT_slong = do- item <- endianRead4 e'- return . Just . TEN_INT $ immed_value [conv_long typ item]-- -- of n elements- read_value typ e' count | typ == TT_long || typ == TT_slong = do- offset <- endianRead4 e'- return . Just . TEN_INT $ \iter_int -> return $ do- Iter.seek (fromIntegral offset)- let iter = convStream- (liftM (either (const Nothing) (Just . (:[]) . conv_long typ)) (checkErr (endianRead4 e')))- iter_int- Iter.joinI $ Iter.joinI $ Iter.takeR (4*count) iter--- read_value typ e' count = do -- stub- _offset <- endianRead4 e'- note ["unhandled type: ", show typ, " with count ", show count]- return Nothing-- immed_value :: (Monad m) => [el] -> EnumeratorGMM [] Word8 [] el m a- immed_value item iter =- --(Iter.enumPure1Chunk item >. enumEof) iter >>== Iter.joinI . return- return . joinI . return . joinIM $ (enumPure1Chunk item >. enumEof) iter-- conv_byte :: TIFF_TYPE -> Word8 -> Int- conv_byte TT_byte = fromIntegral- conv_byte TT_sbyte = fromIntegral . u8_to_s8- conv_byte _ = error "conv_byte called with non-byte type"-- conv_short :: TIFF_TYPE -> Word16 -> Int- conv_short TT_short = fromIntegral- conv_short TT_sshort = fromIntegral . u16_to_s16- conv_short _ = error "conv_short called with non-short type"-- conv_long :: TIFF_TYPE -> Word32 -> Int- conv_long TT_long = fromIntegral- conv_long TT_slong = fromIntegral . u32_to_s32- conv_long _ = error "conv_long called with non-long type"---- Reading the pixel matrix--- For simplicity, we assume no compression and 8-bit pixels-pixel_matrix_enum :: MonadIO m => TIFFDict -> EnumeratorN [] Word8 [] Word8 m a-pixel_matrix_enum dict iter = validate_dict >>= proceed- where- -- Make sure we can handle this particular TIFF image- validate_dict = do- dict_assert TG_COMPRESSION 1- dict_assert TG_SAMPLESPERPIXEL 1- dict_assert TG_BITSPERSAMPLE 8- ncols <- liftM (fromMaybe 0) $ dict_read_int TG_IMAGEWIDTH dict- nrows <- liftM (fromMaybe 0) $ dict_read_int TG_IMAGELENGTH dict- strip_offsets <- liftM (fromMaybe [0]) $- dict_read_ints TG_STRIPOFFSETS dict- rps <- liftM (fromMaybe nrows) (dict_read_int TG_ROWSPERSTRIP dict)- if ncols > 0 && nrows > 0 && rps > 0- then return $ Just (ncols,nrows,rps,strip_offsets)- else return Nothing-- dict_assert tag v = do- vfound <- dict_read_int tag dict- case vfound of- Just v' | v' == v -> return $ Just ()- _ -> throwErr (Err (unwords ["dict_assert: tag:", show tag,- "expected:", show v, "found:", show vfound])) >>- return Nothing-- proceed Nothing = throwErr $ Err "Can't handle this TIFF"-- proceed (Just (ncols,nrows,rows_per_strip,strip_offsets)) = do- let strip_size = rows_per_strip * ncols- image_size = nrows * ncols- note ["Processing the pixel matrix, ", show image_size, " bytes"]- let loop _pos [] iter' = return iter'- loop pos (strip:strips) iter' = do- Iter.seek (fromIntegral strip)- let len = min strip_size (image_size - pos)- iter'' <- Iter.takeR (fromIntegral len) iter'- loop (pos+len) strips iter''- loop 0 strip_offsets iter----- A few helpers for getting data from TIFF dictionary--dict_read_int :: Monad m => TIFF_TAG -> TIFFDict ->- IterateeG [] Word8 m (Maybe Int)-dict_read_int tag dict = do- els <- dict_read_ints tag dict- case els of- Just (e:_) -> return $ Just e- _ -> return Nothing--dict_read_ints :: Monad m => TIFF_TAG -> TIFFDict ->- IterateeG [] Word8 m (Maybe [Int])-dict_read_ints tag dict =- case IM.lookup (tag_to_int tag) dict of- Just (TIFFDE _ (TEN_INT enum)) -> do- e <- joinIM $ enum stream2list- return (Just e)- _ -> return Nothing--dict_read_rat :: Monad m => TIFF_TAG -> TIFFDict ->- IterateeG [] Word8 m (Maybe (Ratio Int))-dict_read_rat tag dict =- case IM.lookup (tag_to_int tag) dict of- Just (TIFFDE 1 (TEN_RAT enum)) -> do- [e] <- joinIM $ enum stream2list- return (Just e)- _ -> return Nothing--dict_read_string :: Monad m => TIFF_TAG -> TIFFDict ->- IterateeG [] Word8 m (Maybe String)-dict_read_string tag dict =- case IM.lookup (tag_to_int tag) dict of- Just (TIFFDE _ (TEN_CHAR enum)) -> do- e <- joinIM $ enum stream2list- return (Just e)- _ -> return Nothing
− src/Data/Iteratee/Codecs/Wave.hs
@@ -1,325 +0,0 @@-{-# LANGUAGE RankNTypes, FlexibleContexts #-}--{---This module is not meant primarily for instructive and pedagogical purposes.-As such, it is not fully featured, and sacrifices performance and generality-for clarity of code.---}--module Data.Iteratee.Codecs.Wave {-# DEPRECATED "This will be moved to a separate package in the future" #-} (- WAVEDE (..),- WAVEDE_ENUM (..),- WAVE_CHUNK (..),- AudioFormat (..),- waveReader,- readRiff,- waveChunk,- chunkToString,- dictReadFormat,- dictReadFirstFormat,- dictReadLastFormat,- dictReadFirstData,- dictReadLastData,- dictReadData,- dictProcessData-)-where--import Prelude as P-import Data.Iteratee.Base-import qualified Data.Iteratee.Base as Iter-import Data.Iteratee.Binary-import Data.Char (chr, ord)-import Data.Int-import Data.Word-import Data.Bits (shiftL)-import Data.Maybe-import qualified Data.IntMap as IM---- =====================================================--- WAVE libary code---- useful type synonyms--type L = []---- |A WAVE directory is a list associating WAVE chunks with--- a record WAVEDE-type WAVEDict = IM.IntMap [WAVEDE]--data WAVEDE = WAVEDE{- wavede_count :: Int, -- ^length of chunk- wavede_type :: WAVE_CHUNK, -- ^type of chunk- wavede_enum :: WAVEDE_ENUM -- ^enumerator to get values of chunk- }--data WAVEDE_ENUM =- WEN_BYTE (forall a. EnumeratorGMM L Word8 L Word8 IO a)- | WEN_DUB (forall a. EnumeratorGMM L Word8 L Double IO a)---- |Standard WAVE Chunks-data WAVE_CHUNK = WAVE_FMT -- ^Format- | WAVE_DATA -- ^Data- | WAVE_OTHER String -- ^Other- deriving (Eq, Ord, Show)-instance Enum WAVE_CHUNK where- fromEnum WAVE_FMT = 1- fromEnum WAVE_DATA = 2- fromEnum (WAVE_OTHER _) = 3- toEnum 1 = WAVE_FMT- toEnum 2 = WAVE_DATA- toEnum 3 = WAVE_OTHER ""- toEnum _ = error "Invalid enumeration value"---- -------------------- wave chunk reading/writing functions---- |Convert a string to WAVE_CHUNK type-waveChunk :: String -> Maybe WAVE_CHUNK-waveChunk str- | str == "fmt " = Just WAVE_FMT- | str == "data" = Just WAVE_DATA- | P.length str == 4 = Just $ WAVE_OTHER str- | otherwise = Nothing---- |Convert a WAVE_CHUNK to the representative string-chunkToString :: WAVE_CHUNK -> String-chunkToString WAVE_FMT = "fmt "-chunkToString WAVE_DATA = "data"-chunkToString (WAVE_OTHER str) = str---- ------------------data AudioFormat = AudioFormat {- numberOfChannels :: NumChannels, -- ^Number of channels in the audio data- sampleRate :: SampleRate, -- ^Sample rate of the audio- bitDepth :: BitDepth -- ^Bit depth of the audio data- } deriving (Show, Eq)--type NumChannels = Integer-type SampleRate = Integer-type BitDepth = Integer---- convenience function to read a 4-byte ASCII string-stringRead4 :: Monad m => IterateeG L Word8 m String-stringRead4 = do- s1 <- Iter.head- s2 <- Iter.head- s3 <- Iter.head- s4 <- Iter.head- return $ map (chr . fromIntegral) [s1, s2, s3, s4]---- --------------------- |The library function to read the WAVE dictionary-waveReader :: IterateeG L Word8 IO (Maybe WAVEDict)-waveReader = do- readRiff- tot_size <- endianRead4 LSB- readRiffWave- chunks_m <- findChunks $ fromIntegral tot_size- loadDict $ joinM chunks_m---- |Read the RIFF header of a file.-readRiff :: IterateeG L Word8 IO ()-readRiff = do- cnt <- heads $ fmap (fromIntegral . ord) "RIFF"- if cnt == 4 then return () else throwErr $ Err "Bad RIFF header"---- | Read the WAVE part of the RIFF header.-readRiffWave :: IterateeG L Word8 IO ()-readRiffWave = do- cnt <- heads $ fmap (fromIntegral . ord) "WAVE"- if cnt == 4 then return () else throwErr $ Err "Bad RIFF/WAVE header"---- | An internal function to find all the chunks. It assumes that the--- stream is positioned to read the first chunk.-findChunks :: Int -> IterateeG L Word8 IO (Maybe [(Int, WAVE_CHUNK, Int)])-findChunks n = findChunks' 12 []- where- findChunks' offset acc = do- typ <- stringRead4- count <- endianRead4 LSB- case waveChunk typ of- Nothing -> (throwErr . Err $ "Bad subchunk descriptor: " ++ show typ)- >> return Nothing- Just chk -> let newpos = offset + 8 + count in- case newpos >= fromIntegral n of- True -> return . Just $ reverse $- (fromIntegral offset, chk, fromIntegral count) : acc- False -> do- Iter.seek $ fromIntegral newpos- findChunks' newpos $- (fromIntegral offset, chk, fromIntegral count) : acc--loadDict :: [(Int, WAVE_CHUNK, Int)] ->- IterateeG L Word8 IO (Maybe WAVEDict)-loadDict = P.foldl read_entry (return (Just IM.empty))- where- read_entry dictM (offset, typ, count) = dictM >>=- maybe (return Nothing) (\dict -> do- enum_m <- readValue dict offset typ count- case (enum_m, IM.lookup (fromEnum typ) dict) of- (Just enum, Nothing) -> --insert new entry- return . Just $ IM.insert (fromEnum typ)- [WAVEDE (fromIntegral count) typ enum] dict- (Just enum, Just _vals) -> --existing entry- return . Just $ IM.update- (\ls -> Just $ ls ++ [WAVEDE (fromIntegral count) typ enum])- (fromEnum typ) dict- (Nothing, _) -> return (Just dict)- )--readValue :: WAVEDict ->- Int -> -- Offset- WAVE_CHUNK -> -- Chunk type- Int -> -- Count- IterateeG L Word8 IO (Maybe WAVEDE_ENUM)-readValue _dict offset _ 0 = do- throwErr . Err $ "Zero count in the entry of chunk at: " ++ show offset- return Nothing--readValue dict offset WAVE_DATA count = do- fmt_m <- dictReadLastFormat dict- case fmt_m of- Just fmt ->- return . Just . WEN_DUB $ \iter_dub -> return $ do- Iter.seek (8 + fromIntegral offset)- let iter = Iter.convStream (convFunc fmt) iter_dub- joinI . joinI . takeR count $ iter- Nothing -> do- throwErr . Err $ "No valid format for data chunk at: " ++ show offset- return Nothing---- return the WaveFormat iteratee-readValue _dict offset WAVE_FMT count =- return . Just . WEN_BYTE $ \iter -> return $ do- Iter.seek (8 + fromIntegral offset)- Iter.joinI $ Iter.takeR count iter---- for WAVE_OTHER, return Word8s and maybe the user can parse them-readValue _dict offset (WAVE_OTHER _str) count =- return . Just . WEN_BYTE $ \iter -> return $ do- Iter.seek (8 + fromIntegral offset)- Iter.joinI $ Iter.takeR count iter----- |Convert Word8s to Doubles-convFunc :: AudioFormat -> IterateeG L Word8 IO (Maybe (L Double))-convFunc (AudioFormat _nc _sr 8) = (fmap . fmap)- ((:[]) . normalize 8 . (fromIntegral :: Word8 -> Int8))- (fmap eitherToMaybe (checkErr Iter.head))-convFunc (AudioFormat _nc _sr 16) = (fmap . fmap)- ((:[]) . normalize 16 . (fromIntegral :: Word16 -> Int16))- (fmap eitherToMaybe (checkErr $ endianRead2 LSB))-convFunc (AudioFormat _nc _sr 24) = (fmap . fmap)- ((:[]) . normalize 24 . (fromIntegral :: Word32 -> Int32))- (fmap eitherToMaybe (checkErr $ endianRead3 LSB))-convFunc (AudioFormat _nc _sr 32) = (fmap . fmap)- ((:[]) . normalize 32 . (fromIntegral :: Word32 -> Int32))- (fmap eitherToMaybe (checkErr $ endianRead4 LSB))-convFunc _ = return Nothing--eitherToMaybe :: Either a b -> Maybe b-eitherToMaybe = either (const Nothing) Just---- |An Iteratee to read a wave format chunk-sWaveFormat :: IterateeG L Word8 IO (Maybe AudioFormat)-sWaveFormat = do- f' <- endianRead2 LSB --data format, 1==PCM- nc <- endianRead2 LSB- sr <- endianRead4 LSB- Iter.drop 6- bd <- endianRead2 LSB- case f' == 1 of- True -> return . Just $ AudioFormat (fromIntegral nc)- (fromIntegral sr)- (fromIntegral bd)- False -> return Nothing---- ------------------------ functions to assist with reading from the dictionary---- |Read the first format chunk in the WAVE dictionary.-dictReadFirstFormat :: WAVEDict -> IterateeG L Word8 IO (Maybe AudioFormat)-dictReadFirstFormat dict = case IM.lookup (fromEnum WAVE_FMT) dict of- Just [] -> return Nothing- Just ((WAVEDE _ WAVE_FMT (WEN_BYTE enum)) : _xs) -> joinIM $ enum sWaveFormat- _ -> return Nothing---- |Read the last fromat chunk from the WAVE dictionary. This is useful--- when parsing all chunks in the dictionary.-dictReadLastFormat :: WAVEDict -> IterateeG L Word8 IO (Maybe AudioFormat)-dictReadLastFormat dict = case IM.lookup (fromEnum WAVE_FMT) dict of- Just [] -> return Nothing- Just xs -> let (WAVEDE _ WAVE_FMT (WEN_BYTE enum)) = last xs in- joinIM $ enum sWaveFormat- _ -> return Nothing---- |Read the specified format chunk from the WAVE dictionary-dictReadFormat :: Int -> --Index in the format chunk list to read- WAVEDict -> --Dictionary- IterateeG L Word8 IO (Maybe AudioFormat)-dictReadFormat ix dict = case IM.lookup (fromEnum WAVE_FMT) dict of- Just xs -> let (WAVEDE _ WAVE_FMT (WEN_BYTE enum)) = (!!) xs ix in- joinIM $ enum sWaveFormat- _ -> return Nothing---- |Read the first data chunk in the WAVE dictionary.-dictReadFirstData :: WAVEDict -> IterateeG L Word8 IO (Maybe [Double])-dictReadFirstData dict = case IM.lookup (fromEnum WAVE_DATA) dict of- Just [] -> return Nothing- Just ((WAVEDE _ WAVE_DATA (WEN_DUB enum)) : _xs) -> do- e <- joinIM $ enum Iter.stream2list- return $ Just e- _ -> return Nothing---- |Read the last data chunk in the WAVE dictionary.-dictReadLastData :: WAVEDict -> IterateeG L Word8 IO (Maybe [Double])-dictReadLastData dict = case IM.lookup (fromEnum WAVE_DATA) dict of- Just [] -> return Nothing- Just xs -> let (WAVEDE _ WAVE_DATA (WEN_DUB enum)) = last xs in do- e <- joinIM $ enum Iter.stream2list- return $ Just e- _ -> return Nothing---- |Read the specified data chunk from the WAVE dictionary.-dictReadData :: Int -> --Index in the data chunk list to read- WAVEDict -> --Dictionary- IterateeG L Word8 IO (Maybe [Double])-dictReadData ix dict = case IM.lookup (fromEnum WAVE_DATA) dict of- Just xs -> let (WAVEDE _ WAVE_DATA (WEN_DUB enum)) = (!!) xs ix in do- e <- joinIM $ enum Iter.stream2list- return $ Just e- _ -> return Nothing---- |Read the specified data chunk from the dictionary, applying the--- data to the specified IterateeG.-dictProcessData :: Int -> -- Index in the data chunk list to read- WAVEDict -> -- Dictionary- IterateeG L Double IO a ->- IterateeG L Word8 IO (Maybe a)-dictProcessData ix dict iter = case IM.lookup (fromEnum WAVE_DATA) dict of- Just xs -> let (WAVEDE _ WAVE_DATA (WEN_DUB enum)) = (!!) xs ix in do- e <- joinIM $ enum iter- return $ Just e- _ -> return Nothing---- ------------------------ convenience functions---- |Convert (Maybe []) to []. Nothing maps to an empty list.-joinM :: Maybe [a] -> [a]-joinM Nothing = []-joinM (Just a) = a---- |Normalize a given value for the provided bit depth.-normalize :: Integral a => BitDepth -> a -> Double-normalize 8 a = (fromIntegral a - 128) / 128-normalize bd a = case (a > 0) of- True -> fromIntegral a / divPos- False -> fromIntegral a / divNeg- where- divPos = fromIntegral (1 `shiftL` fromIntegral (bd - 1) :: Int) - 1- divNeg = fromIntegral (1 `shiftL` fromIntegral (bd - 1) :: Int)
+ src/Data/Iteratee/Exception.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE DeriveDataTypeable, ExistentialQuantification #-}++-- |Monadic and General Iteratees:+-- Messaging and exception handling.+--+-- Iteratees use an internal exception handling mechanism that is parallel to+-- that provided by 'Control.Exception'. This allows the iteratee framework+-- to handle its own exceptions outside @IO@.+--+-- Iteratee exceptions are divided into two categories, 'IterException' and+-- 'EnumException'. @IterExceptions@ are exceptions within an iteratee, and+-- @EnumExceptions@ are exceptions within an enumerator.+--+-- Enumerators can be constructed to handle an 'IterException' with+-- @Data.Iteratee.Iteratee.enumFromCallbackCatch@. If the enumerator detects+-- an @iteratee exception@, the enumerator calls the provided exception handler.+-- The enumerator is then able to continue feeding data to the iteratee,+-- provided the exception was successfully handled. If the handler could+-- not handle the exception, the 'IterException' is converted to an+-- 'EnumException' and processing aborts.+--+-- Exceptions can also be cleared by @Data.Iteratee.Iteratee.checkErr@,+-- although in this case the iteratee continuation cannot be recovered.+--+-- When viewed as Resumable Exceptions, iteratee exceptions provide a means+-- for iteratees to send control messages to enumerators. The @seek@+-- implementation provides an example. @Data.Iteratee.Iteratee.seek@ stores+-- the current iteratee continuation and throws a 'SeekException', which+-- inherits from 'IterException'. @Data.Iteratee.IO.enumHandleRandom@ is+-- constructed with @enumFromCallbackCatch@ and a handler that performs+-- an @hSeek@. Upon receiving the 'SeekException', @enumHandleRandom@ calls+-- the handler, checks that it executed properly, and then continues with+-- the stored continuation.+--+-- As the exception hierarchy is open, users can extend it with custom+-- exceptions and exception handlers to implement sophisticated messaging+-- systems based upon resumable exceptions.+++module Data.Iteratee.Exception (+ -- * Exception types+ IFException (..)+ ,Exception (..) -- from Control.Exception+ -- ** Enumerator exceptions+ ,EnumException (..)+ ,DivergentException (..)+ ,EnumStringException (..)+ ,EnumUnhandledIterException (..)+ -- ** Iteratee exceptions+ ,IException (..)+ ,IterException (..)+ ,SeekException (..)+ ,EofException (..)+ ,IterStringException (..)+ -- * Functions+ ,enStrExc+ ,iterStrExc+ ,wrapIterExc+ ,iterExceptionToException+ ,iterExceptionFromException+)+where++import Data.Iteratee.IO.Base++import Control.Exception+import Data.Data+++-- ----------------------------------------------+-- create exception type hierarchy++-- |Root of the Iteratee exception hierarchy. @IFException@ derives from+-- @Control.Exception.SomeException@. 'EnumException', 'IterException',+-- and all inheritants are descendents of 'IFException'.+data IFException = forall e . Exception e => IFException e+ deriving Typeable++instance Show IFException where+ show (IFException e) = show e++instance Exception IFException++ifExceptionToException :: Exception e => e -> SomeException+ifExceptionToException = toException . IFException++ifExceptionFromException :: Exception e => SomeException -> Maybe e+ifExceptionFromException x = do+ IFException a <- fromException x+ cast a++-- Root of enumerator exceptions.+data EnumException = forall e . Exception e => EnumException e+ deriving Typeable++instance Show EnumException where+ show (EnumException e) = show e++instance Exception EnumException where+ toException = ifExceptionToException+ fromException = ifExceptionFromException++enumExceptionToException :: Exception e => e -> SomeException+enumExceptionToException = toException . IterException++enumExceptionFromException :: Exception e => SomeException -> Maybe e+enumExceptionFromException x = do+ IterException a <- fromException x+ cast a++-- |The @iteratee@ diverged upon receiving 'EOF'.+data DivergentException = DivergentException+ deriving (Show, Typeable)++instance Exception DivergentException where+ toException = enumExceptionToException+ fromException = enumExceptionFromException++-- |Create an enumerator exception from a @String@.+data EnumStringException = EnumStringException String+ deriving (Show, Typeable)++instance Exception EnumStringException where+ toException = enumExceptionToException+ fromException = enumExceptionFromException++-- |Create an 'EnumException' from a string.+enStrExc :: String -> EnumException+enStrExc = EnumException . EnumStringException++-- |The enumerator received an 'IterException' it could not handle.+data EnumUnhandledIterException = EnumUnhandledIterException IterException+ deriving (Show, Typeable)++instance Exception EnumUnhandledIterException where+ toException = enumExceptionToException+ fromException = enumExceptionFromException++-- |Convert an 'IterException' to an 'EnumException'. Meant to be used+-- within an @Enumerator@ to signify that it could not handle the+-- @IterException@.+wrapIterExc :: IterException -> EnumException+wrapIterExc = EnumException . EnumUnhandledIterException++-- iteratee exceptions++-- |A class for @iteratee exceptions@. Only inheritants of @IterException@+-- should be instances of this class.+class Exception e => IException e where+ toIterException :: e -> IterException+ toIterException = IterException+ fromIterException :: IterException -> Maybe e+ fromIterException = fromException . toException++-- |Root of iteratee exceptions.+data IterException = forall e . Exception e => IterException e+ deriving Typeable++instance Show IterException where+ show (IterException e) = show e++instance Exception IterException where+ toException = ifExceptionToException+ fromException = ifExceptionFromException++iterExceptionToException :: Exception e => e -> SomeException+iterExceptionToException = toException . IterException++iterExceptionFromException :: Exception e => SomeException -> Maybe e+iterExceptionFromException x = do+ IterException a <- fromException x+ cast a++instance IException IterException where+ toIterException = id+ fromIterException = Just++-- |A seek request within an @Iteratee@.+data SeekException = SeekException FileOffset+ deriving (Typeable, Show)++instance Exception SeekException where+ toException = iterExceptionToException+ fromException = iterExceptionFromException++instance IException SeekException where++-- |The @Iteratee@ needs more data but received @EOF@.+data EofException = EofException+ deriving (Typeable, Show)++instance Exception EofException where+ toException = iterExceptionToException+ fromException = iterExceptionFromException++instance IException EofException where++-- |An @Iteratee exception@ specified by a @String@.+data IterStringException = IterStringException String deriving (Typeable, Show)++instance Exception IterStringException where+ toException = iterExceptionToException+ fromException = iterExceptionFromException++instance IException IterStringException where++-- |Create an @iteratee exception@ from a string.+-- This convenience function wraps 'IterStringException' and 'toException'.+iterStrExc :: String -> SomeException+iterStrExc= toException . IterStringException+
src/Data/Iteratee/IO.hs view
@@ -1,75 +1,159 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-} -- |Random and Binary IO with generic Iteratees. module Data.Iteratee.IO(+ -- * Data+ defaultBufSize, -- * File enumerators -- ** Handle-based enumerators- enumHandle,- enumHandleRandom,+ H.enumHandle,+ H.enumHandleRandom,+ enumFile,+ enumFileRandom, #if defined(USE_POSIX) -- ** FileDescriptor based enumerators- enumFd,- enumFdRandom,+ FD.enumFd,+ FD.enumFdRandom, #endif -- * Iteratee drivers -- These are FileDescriptor-based on POSIX systems, otherwise they are- -- Handle-based.+ -- Handle-based. The Handle-based drivers are accessible on POSIX systems+ -- at Data.Iteratee.IO.Handle fileDriver,+ fileDriverVBuf, fileDriverRandom,+ fileDriverRandomVBuf, ) where -import Data.Iteratee.Base.StreamChunk (ReadableChunk (..))-import Data.Iteratee.Base+import Data.Iteratee.Base.ReadableChunk+import Data.Iteratee.Iteratee import Data.Iteratee.Binary()-import Data.Iteratee.IO.Handle+import qualified Data.Iteratee.IO.Handle as H #if defined(USE_POSIX)-import Data.Iteratee.IO.Fd+import qualified Data.Iteratee.IO.Fd as FD #endif +import Control.Monad.Catch import Control.Monad.IO.Class +#if MIN_VERSION_exceptions(0,6,0)+#else+type MonadMask = MonadCatch+#endif++-- | The default buffer size.+defaultBufSize :: Int+defaultBufSize = 1024+ -- If Posix is available, use the fileDriverRandomFd as fileDriverRandom. Otherwise, use a handle-based variant. #if defined(USE_POSIX) --- |Process a file using the given IterateeG. This function wraps+enumFile+ :: (MonadIO m, MonadMask m, NullPoint s, ReadableChunk s el) =>+ Int+ -> FilePath+ -> Enumerator s m a+enumFile = FD.enumFile++enumFileRandom+ :: (MonadIO m, MonadMask m, NullPoint s, ReadableChunk s el) =>+ Int+ -> FilePath+ -> Enumerator s m a+enumFileRandom = FD.enumFileRandom++-- |Process a file using the given Iteratee. This function wraps -- enumFd as a convenience.-fileDriver :: (MonadIO m, ReadableChunk s el) =>- IterateeG s el m a ->- FilePath ->- m a-fileDriver = fileDriverFd+fileDriver+ :: (MonadIO m, MonadMask m, NullPoint s, ReadableChunk s el) =>+ Iteratee s m a+ -> FilePath+ -> m a+fileDriver = FD.fileDriverFd defaultBufSize --- |Process a file using the given IterateeG. This function wraps+-- |A version of fileDriver with a user-specified buffer size (in elements).+fileDriverVBuf+ :: (MonadIO m, MonadMask m, NullPoint s, ReadableChunk s el) =>+ Int+ -> Iteratee s m a+ -> FilePath+ -> m a+fileDriverVBuf = FD.fileDriverFd++-- |Process a file using the given Iteratee. This function wraps -- enumFdRandom as a convenience.-fileDriverRandom :: (MonadIO m, ReadableChunk s el) =>- IterateeG s el m a ->- FilePath ->- m a-fileDriverRandom = fileDriverRandomFd+fileDriverRandom+ :: (MonadIO m, MonadMask m, NullPoint s, ReadableChunk s el) =>+ Iteratee s m a+ -> FilePath+ -> m a+fileDriverRandom = FD.fileDriverRandomFd defaultBufSize +fileDriverRandomVBuf+ :: (MonadIO m, MonadMask m, NullPoint s, ReadableChunk s el) =>+ Int+ -> Iteratee s m a+ -> FilePath+ -> m a+fileDriverRandomVBuf = FD.fileDriverRandomFd+ #else -- ----------------------------------------------- -- Handle-based operations for compatibility. --- |Process a file using the given IterateeG. This function wraps--- enumHandle as a convenience.-fileDriver :: (MonadIO m, ReadableChunk s el) =>- IterateeG s el m a ->- FilePath ->- m a-fileDriver = fileDriverHandle+-- |Process a file using the given Iteratee. This function wraps+-- @enumHandle@ as a convenience.+fileDriver ::+ (MonadIO m, MonadMask m, NullPoint s, ReadableChunk s el) =>+ Iteratee s m a+ -> FilePath+ -> m a+fileDriver = H.fileDriverHandle defaultBufSize --- |Process a file using the given IterateeG. This function wraps--- enumFdHandle as a convenience.-fileDriverRandom :: (MonadIO m, ReadableChunk s el) =>- IterateeG s el m a ->- FilePath ->- m a-fileDriverRandom = fileDriverRandomHandle+-- |A version of fileDriver with a user-specified buffer size (in elements).+fileDriverVBuf ::+ (MonadIO m, MonadMask m, NullPoint s, ReadableChunk s el) =>+ Int+ -> Iteratee s m a+ -> FilePath+ -> m a+fileDriverVBuf = H.fileDriverHandle++-- |Process a file using the given Iteratee. This function wraps+-- @enumRandomHandle@ as a convenience.+fileDriverRandom+ :: (MonadIO m, MonadMask m, NullPoint s, ReadableChunk s el) =>+ Iteratee s m a+ -> FilePath+ -> m a+fileDriverRandom = H.fileDriverRandomHandle defaultBufSize++fileDriverRandomVBuf+ :: (MonadIO m, MonadMask m, NullPoint s, ReadableChunk s el) =>+ Int+ -> Iteratee s m a+ -> FilePath+ -> m a+fileDriverRandomVBuf = H.fileDriverRandomHandle++enumFile+ :: (MonadIO m, MonadMask m, NullPoint s, ReadableChunk s el) =>+ Int+ -> FilePath+ -> Enumerator s m a+enumFile = H.enumFile++enumFileRandom+ :: (MonadIO m, MonadMask m, NullPoint s, ReadableChunk s el) =>+ Int+ -> FilePath+ -> Enumerator s m a+enumFileRandom = H.enumFileRandom #endif
src/Data/Iteratee/IO/Fd.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP, ScopedTypeVariables #-}+{-# LANGUAGE ConstraintKinds #-} -- |Random and Binary IO with generic Iteratees, using File Descriptors for IO. -- when available, these are the preferred functions for performing IO as they@@ -7,13 +8,14 @@ module Data.Iteratee.IO.Fd( #if defined(USE_POSIX) -- * File enumerators- -- ** FileDescriptor based enumerators+ -- ** FileDescriptor based enumerators for monadic iteratees enumFd- ,enumFdFollow+ ,enumFdCatch ,enumFdRandom+ ,enumFile+ ,enumFileRandom -- * Iteratee drivers ,fileDriverFd- ,fileDriverFollowFd ,fileDriverRandomFd #endif )@@ -21,172 +23,145 @@ where #if defined(USE_POSIX)-import Data.Iteratee.Base.StreamChunk (ReadableChunk (..))-import Data.Iteratee.Base+import Data.Iteratee.Base.ReadableChunk+import Data.Iteratee.Iteratee import Data.Iteratee.Binary() import Data.Iteratee.IO.Base +import Control.Concurrent (yield)+import Control.Exception import Control.Monad+import Control.Monad.Catch as CIO import Control.Monad.IO.Class import Foreign.Ptr-import Foreign.ForeignPtr import Foreign.Storable+import Foreign.Marshal.Alloc import System.IO (SeekMode(..)) import System.Posix hiding (FileOffset)-import GHC.Conc +#if MIN_VERSION_exceptions(0,6,0)+#else+type MonadMask = MonadCatch+#endif++ -- ------------------------------------------------------------------------ -- Binary Random IO enumerators +makefdCallback ::+ (MonadIO m, NullPoint s, ReadableChunk s el) =>+ Ptr el+ -> ByteCount+ -> Fd+ -> st+ -> m (Either SomeException ((Bool, st), s))+makefdCallback p bufsize fd st = do+ n <- liftIO $ myfdRead fd (castPtr p) bufsize+ case n of+ Left _ -> return $ Left (error "myfdRead failed")+ Right 0 -> liftIO yield >> return (Right ((False, st), empty))+ Right n' -> liftM (\s -> Right ((True, st), s)) $+ readFromPtr p (fromIntegral n')+ -- |The enumerator of a POSIX File Descriptor. This version enumerates -- over the entire contents of a file, in order, unless stopped by -- the iteratee. In particular, seeking is not supported.-enumFd :: forall s el m a.(ReadableChunk s el, MonadIO m) =>- Fd ->- EnumeratorGM s el m a-enumFd fd iter' =- liftIO (mallocForeignPtrBytes (fromIntegral buffer_size)) >>= loop iter'- where- buffer_size = fromIntegral $ 4096 - mod 4096 (sizeOf (undefined :: el))- loop iter fp = do- s <- liftIO . withForeignPtr fp $ \p -> do- liftIO $ GHC.Conc.threadWaitRead fd- n <- myfdRead fd (castPtr p) buffer_size- case n of- Left _errno -> return $ Left "IO error"- Right 0 -> return $ Right Nothing- Right n' -> liftM (Right . Just) $ readFromPtr p (fromIntegral n')- checkres fp iter s- checkres fp iter = either (flip enumErr iter)- (maybe (return iter)- (check fp <=< runIter iter . Chunk))- check _p (Done x _) = return . return $ x- check p (Cont i Nothing) = loop i p- check _p (Cont _ (Just e)) = return $ throwErr e+enumFd+ :: forall s el m a.(NullPoint s, ReadableChunk s el, MonadIO m, MonadMask m) =>+ Int+ -> Fd+ -> Enumerator s m a+enumFd bs fd iter =+ let bufsize = bs * (sizeOf (undefined :: el))+ in CIO.bracket (liftIO $ mallocBytes bufsize)+ (liftIO . free)+ (\p -> enumFromCallback (makefdCallback p (fromIntegral bufsize) fd) () iter) --- |The enumerator of a POSIX File Descriptor: a variation of enumFd--- that follows the tail of growing input.-enumFdFollow :: forall s el a.(ReadableChunk s el) =>- Fd ->- EnumeratorGM s el IO a-enumFdFollow fd iter' =- liftIO (mallocForeignPtrBytes (fromIntegral buffer_size)) >>= loop iter'+-- |A variant of enumFd that catches exceptions raised by the @Iteratee@.+enumFdCatch+ :: forall e s el m a.(IException e, NullPoint s, ReadableChunk s el, MonadIO m, MonadMask m)+ => Int+ -> Fd+ -> (e -> m (Maybe EnumException))+ -> Enumerator s m a+enumFdCatch bs fd handler iter =+ let bufsize = bs * (sizeOf (undefined :: el))+ in CIO.bracket (liftIO $ mallocBytes bufsize)+ (liftIO . free)+ (\p -> enumFromCallbackCatch (makefdCallback p (fromIntegral bufsize) fd) handler () iter)+++-- |The enumerator of a POSIX File Descriptor: a variation of @enumFd@ that+-- supports RandomIO (seek requests).+enumFdRandom+ :: forall s el m a.(NullPoint s, ReadableChunk s el, MonadIO m, MonadMask m) =>+ Int+ -> Fd+ -> Enumerator s m a+enumFdRandom bs fd iter = enumFdCatch bs fd handler iter where- buffer_size = fromIntegral $ 4096 - mod 4096 (sizeOf (undefined :: el))- loop iter fp = do- s <- readFollow iter fp- checkres fp iter s- readFollow iter fp = do- liftIO . withForeignPtr fp $ \p -> do- liftIO $ GHC.Conc.threadWaitRead fd- n <- myfdRead fd (castPtr p) buffer_size- case n of- Left _errno -> return $ Left "IO error"- Right 0 -> do liftIO $ threadDelay (250 * 1000)- readFollow iter fp- Right n' -> liftM (Right . Just) $ readFromPtr p (fromIntegral n')- checkres fp iter = either (flip enumErr iter)- (maybe (return iter)- (check fp <=< runIter iter . Chunk))- check _p (Done x _) = return . return $ x- check p (Cont i Nothing) = loop i p- check _p (Cont _ (Just e)) = return $ throwErr e+ handler (SeekException off) =+ liftM (either+ (const . Just $ enStrExc "Error seeking within file descriptor")+ (const Nothing))+ . liftIO . myfdSeek fd AbsoluteSeek $ fromIntegral off --- |The enumerator of a POSIX File Descriptor: a variation of enumFd that--- supports RandomIO (seek requests)-enumFdRandom :: forall s el m a.(ReadableChunk s el, MonadIO m) =>- Fd ->- EnumeratorGM s el m a-enumFdRandom fd iter' =- liftIO (mallocForeignPtrBytes (fromIntegral buffer_size)) >>= loop (0,0) iter'- where- -- this can be usefully varied. Values between 512 and 4096 seem- -- to provide the best performance for most cases.- buffer_size = fromIntegral $ 4096 - mod 4096 (sizeOf (undefined :: el))- -- the first argument of loop is (off,len), describing which part- -- of the file is currently in the buffer 'fp'- loop :: (FileOffset,Int) ->- IterateeG s el m a ->- ForeignPtr el ->- m (IterateeG s el m a)- -- Thanks to John Lato for the strictness annotation- -- Otherwise, the `off + fromIntegral len' below accumulates thunks- loop (off,len) _iter _fp | off `seq` len `seq` False = undefined- loop (off,len) iter fp = do- s <- liftIO . withForeignPtr fp $ \p -> do- liftIO $ GHC.Conc.threadWaitRead fd- n <- myfdRead fd (castPtr p) buffer_size- case n of- Left _errno -> return $ Left "IO error"- Right 0 -> return $ Right Nothing- Right n' -> liftM- (Right . Just . (,) (off + fromIntegral len, fromIntegral n'))- (readFromPtr p (fromIntegral n'))- checkres fp iter s- seekTo pos@(off, len) off' iter fp- | off <= off' && off' < off + fromIntegral len = -- Seek within buffer- do- let local_off = fromIntegral $ off' - off- s <- liftIO $ withForeignPtr fp $ \p ->- readFromPtr (p `plusPtr` local_off) (len - local_off)- igv <- runIter iter (Chunk s)- check pos fp igv- seekTo _pos off iter fp = do -- Seek outside buffer- off' <- liftIO $ myfdSeek fd AbsoluteSeek (fromIntegral off)- case off' of- Left _errno -> enumErr "IO error" iter- Right off'' -> loop (off'',0) iter fp- checkres fp iter = either- (flip enumErr iter)- (maybe (return iter) (uncurry $ runS fp iter))- runS fp iter o s = runIter iter (Chunk s) >>= check o fp- check _ _fp (Done x _) = return . return $ x- check o fp (Cont i Nothing) = loop o i fp- check o fp (Cont i (Just (Seek off))) = seekTo o off i fp- check _ _fp (Cont _ (Just e)) = return $ throwErr e+fileDriver+ :: (MonadIO m, MonadMask m, ReadableChunk s el) =>+ (Int -> Fd -> Enumerator s m a)+ -> Int+ -> Iteratee s m a+ -> FilePath+ -> m a+fileDriver enumf bufsize iter filepath = CIO.bracket+ (liftIO $ openFd filepath ReadOnly Nothing defaultFileFlags)+ (liftIO . closeFd)+ (run <=< flip (enumf bufsize) iter) --- |Process a file using the given IterateeGM. This function wraps--- enumFd as a convenience.-fileDriverFd :: (MonadIO m, ReadableChunk s el) =>- IterateeG s el m a ->- FilePath ->- m a-fileDriverFd iter filepath = do- fd <- liftIO $ openFd filepath ReadOnly Nothing defaultFileFlags- result <- enumFd fd iter >>= run- liftIO $ closeFd fd- return result+-- |Process a file using the given @Iteratee@.+fileDriverFd+ :: (NullPoint s, MonadIO m, MonadMask m, ReadableChunk s el) =>+ Int -- ^Buffer size (number of elements)+ -> Iteratee s m a+ -> FilePath+ -> m a+fileDriverFd = fileDriver enumFd --- |Process a file using the given IterateeGM. This function wraps--- enumFdFollow as a convenience.--- The first iteratee is used to scan through to the end of the file, using--- enumFd. The second iteratee is used from then onwards on the growing tail--- of the file, using enumFdFollow.-fileDriverFollowFd :: (ReadableChunk s el) =>- IterateeG s el IO a ->- (a -> IterateeG s el IO b) ->- FilePath ->- IO b-fileDriverFollowFd scanIter followIter filepath = do- fd <- liftIO $ openFd filepath ReadOnly Nothing defaultFileFlags- state <- enumFd fd scanIter >>= run- result <- enumFdFollow fd (followIter state) >>= run- liftIO $ closeFd fd- return result+-- |A version of fileDriverFd that supports seeking.+fileDriverRandomFd+ :: (NullPoint s, MonadIO m, MonadMask m, ReadableChunk s el) =>+ Int+ -> Iteratee s m a+ -> FilePath+ -> m a+fileDriverRandomFd = fileDriver enumFdRandom --- |Process a file using the given IterateeGM. This function wraps--- enumFdRandom as a convenience.-fileDriverRandomFd :: (MonadIO m, ReadableChunk s el) =>- IterateeG s el m a ->- FilePath ->- m a-fileDriverRandomFd iter filepath = do- fd <- liftIO $ openFd filepath ReadOnly Nothing defaultFileFlags- result <- enumFdRandom fd iter >>= run- liftIO $ closeFd fd- return result+enumFile' :: (NullPoint s, MonadIO m, MonadMask m, ReadableChunk s el) =>+ (Int -> Fd -> Enumerator s m a)+ -> Int -- ^Buffer size+ -> FilePath+ -> Enumerator s m a+enumFile' enumf bufsize filepath iter = CIO.bracket+ (liftIO $ openFd filepath ReadOnly Nothing defaultFileFlags)+ (liftIO . closeFd)+ (flip (enumf bufsize) iter)++enumFile ::+ (NullPoint s, MonadIO m, MonadMask m, ReadableChunk s el)+ => Int -- ^Buffer size+ -> FilePath+ -> Enumerator s m a+enumFile = enumFile' enumFd++enumFileRandom ::+ (NullPoint s, MonadIO m, MonadMask m, ReadableChunk s el)+ => Int -- ^Buffer size+ -> FilePath+ -> Enumerator s m a+enumFileRandom = enumFile' enumFdRandom+ #endif
src/Data/Iteratee/IO/Handle.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ScopedTypeVariables #-} -- |Random and Binary IO with generic Iteratees. These functions use Handles@@ -8,7 +10,10 @@ module Data.Iteratee.IO.Handle( -- * File enumerators enumHandle+ ,enumHandleCatch ,enumHandleRandom+ ,enumFile+ ,enumFileRandom -- * Iteratee drivers ,fileDriverHandle ,fileDriverRandomHandle@@ -16,123 +21,140 @@ where -import Data.Iteratee.Base.StreamChunk (ReadableChunk (..))-import Data.Iteratee.Base+import Data.Iteratee.Base.ReadableChunk+import Data.Iteratee.Iteratee import Data.Iteratee.Binary() -import Data.Int-import Control.Exception.Extensible+import Control.Exception import Control.Monad+import Control.Monad.Catch as CIO import Control.Monad.IO.Class import Foreign.Ptr-import Foreign.ForeignPtr import Foreign.Storable+import Foreign.Marshal.Alloc import System.IO +#if MIN_VERSION_exceptions(0,6,0)+#else+type MonadMask = MonadCatch+#endif -- ------------------------------------------------------------------------ -- Binary Random IO enumerators --- |The enumerator of a file Handle. This version enumerates+makeHandleCallback ::+ (MonadIO m, MonadCatch m, NullPoint s, ReadableChunk s el) =>+ Ptr el+ -> Int+ -> Handle+ -> st+ -> m (Either SomeException ((Bool, st), s))+makeHandleCallback p bsize h st = do+ n' <- liftIO (CIO.try $ hGetBuf h p bsize :: IO (Either SomeException Int))+ case n' of+ Left e -> return $ Left e+ Right 0 -> return $ Right ((False, st), empty)+ Right n -> liftM (\s -> Right ((True, st), s)) $+ readFromPtr p (fromIntegral n)+++-- |The (monadic) enumerator of a file Handle. This version enumerates -- over the entire contents of a file, in order, unless stopped by -- the iteratee. In particular, seeking is not supported.-enumHandle :: forall s el m a.(ReadableChunk s el, MonadIO m) =>- Handle ->- EnumeratorGM s el m a-enumHandle h i =- liftIO (mallocForeignPtrBytes (fromIntegral buffer_size)) >>= loop i- where- buffer_size = 4096 - mod 4096 (sizeOf (undefined :: el))- loop iter fp = do- s <- liftIO . withForeignPtr fp $ \p -> do- n <- try $ hGetBuf h p buffer_size :: IO (Either SomeException Int)- case n of- Left _ -> return $ Left "IO error"- Right 0 -> return $ Right Nothing- Right n' -> liftM (Right . Just) $ readFromPtr p (fromIntegral n')- checkres fp iter s- checkres fp iter = either (flip enumErr iter)- (maybe (return iter)- (check fp <=< runIter iter . Chunk))- check _p (Done x _) = return . return $ x- check p (Cont i' Nothing) = loop i' p- check _p (Cont _ (Just e)) = return $ throwErr e+-- Data is read into a buffer of the specified size.+enumHandle ::+ forall s el m a.(NullPoint s, ReadableChunk s el, MonadIO m, MonadMask m) =>+ Int -- ^Buffer size (number of elements per read)+ -> Handle+ -> Enumerator s m a+enumHandle bs h i =+ let bufsize = bs * sizeOf (undefined :: el)+ in CIO.bracket (liftIO $ mallocBytes bufsize)+ (liftIO . free)+ (\p -> enumFromCallback (makeHandleCallback p bufsize h) () i) +-- |An enumerator of a file handle that catches exceptions raised by+-- the Iteratee.+enumHandleCatch+ ::+ forall e s el m a.(IException e,+ NullPoint s,+ ReadableChunk s el,+ MonadIO m, MonadMask m) =>+ Int -- ^Buffer size (number of elements per read)+ -> Handle+ -> (e -> m (Maybe EnumException))+ -> Enumerator s m a+enumHandleCatch bs h handler i =+ let bufsize = bs * sizeOf (undefined :: el)+ in CIO.bracket (liftIO $ mallocBytes bufsize)+ (liftIO . free)+ (\p -> enumFromCallbackCatch (makeHandleCallback p bufsize h) handler () i)++ -- |The enumerator of a Handle: a variation of enumHandle that--- supports RandomIO (seek requests)-enumHandleRandom :: forall s el m a.(ReadableChunk s el, MonadIO m) =>- Handle ->- EnumeratorGM s el m a-enumHandleRandom h i =- liftIO (mallocForeignPtrBytes (fromIntegral buffer_size)) >>= loop (0,0) i- where- buffer_size = 4096 - mod 4096 (sizeOf (undefined :: el))- -- the first argument of loop is (off,len), describing which part- -- of the file is currently in the buffer 'fp'- loop :: (FileOffset,Int) ->- IterateeG s el m a ->- ForeignPtr el ->- m (IterateeG s el m a)- -- strictify `off', else the `off + fromIntegral len' accumulates thunks- loop (off,len) _iter _p | off `seq` len `seq` False = undefined- loop (off,len) iter fp = do- s <- liftIO . withForeignPtr fp $ \p -> do- n <- try $ hGetBuf h p buffer_size :: IO (Either SomeException Int)- case n of- Left _errno -> return $ Left "IO error"- Right 0 -> return $ Right Nothing- Right n' -> liftM- (Right . Just . (,) (off + fromIntegral len, fromIntegral n'))- (readFromPtr p (fromIntegral n'))- checkres fp iter s- seekTo pos@(off, len) off' iter fp- | off <= off' && off' < off + fromIntegral len = -- Seek within buffer- do- let local_off = fromIntegral $ off' - off- s <- liftIO $ withForeignPtr fp $ \p ->- readFromPtr (p `plusPtr` local_off) (len - local_off)- igv <- runIter iter (Chunk s)- check pos fp igv- seekTo _pos off iter fp = do -- Seek outside buffer- off' <- liftIO (try $ hSeek h AbsoluteSeek- (fromIntegral off) :: IO (Either SomeException ()))- case off' of- Left _errno -> enumErr "IO error" iter- Right _ -> loop (off,0) iter fp- checkres fp iter = either- (flip enumErr iter)- (maybe (return iter) (uncurry $ runS fp iter))- runS fp iter o s = runIter iter (Chunk s) >>= check o fp- check _ _ (Done x _) = return . return $ x- check o fp (Cont i' Nothing) = loop o i' fp- check o fp (Cont i' (Just (Seek off))) = seekTo o off i' fp- check _ _ (Cont _ (Just e)) = return $ throwErr e+-- supports RandomIO (seek requests).+-- Data is read into a buffer of the specified size.+enumHandleRandom ::+ forall s el m a.(NullPoint s, ReadableChunk s el, MonadIO m, MonadMask m) =>+ Int -- ^ Buffer size (number of elements per read)+ -> Handle+ -> Enumerator s m a+enumHandleRandom bs h i = enumHandleCatch bs h handler i+ where+ handler (SeekException off) =+ liftM (either+ (Just . EnumException :: IOException -> Maybe EnumException)+ (const Nothing))+ . liftIO . CIO.try $ hSeek h AbsoluteSeek $ fromIntegral off -- ---------------------------------------------- -- File Driver wrapper functions. --- |Process a file using the given IterateeGM. This function wraps--- enumHandle as a convenience.-fileDriverHandle :: (MonadIO m, ReadableChunk s el) =>- IterateeG s el m a ->- FilePath ->- m a-fileDriverHandle iter filepath = do- h <- liftIO $ openBinaryFile filepath ReadMode- result <- enumHandle h iter >>= run- liftIO $ hClose h- return result+enumFile' :: (NullPoint s, MonadIO m, MonadMask m, ReadableChunk s el) =>+ (Int -> Handle -> Enumerator s m a)+ -> Int -- ^Buffer size+ -> FilePath+ -> Enumerator s m a+enumFile' enumf bufsize filepath iter = CIO.bracket+ (liftIO $ openBinaryFile filepath ReadMode)+ (liftIO . hClose)+ (flip (enumf bufsize) iter) --- |Process a file using the given IterateeGM. This function wraps--- enumHandleRandom as a convenience.-fileDriverRandomHandle :: (MonadIO m, ReadableChunk s el) =>- IterateeG s el m a ->- FilePath ->- m a-fileDriverRandomHandle iter filepath = do- h <- liftIO $ openBinaryFile filepath ReadMode- result <- enumHandleRandom h iter >>= run- liftIO $ hClose h- return result+enumFile ::+ (NullPoint s, MonadIO m, MonadMask m, ReadableChunk s el)+ => Int -- ^Buffer size+ -> FilePath+ -> Enumerator s m a+enumFile = enumFile' enumHandle++enumFileRandom ::+ (NullPoint s, MonadIO m, MonadMask m, ReadableChunk s el)+ => Int -- ^Buffer size+ -> FilePath+ -> Enumerator s m a+enumFileRandom = enumFile' enumHandleRandom++-- |Process a file using the given @Iteratee@. This function wraps+-- @enumHandle@ as a convenience.+fileDriverHandle+ :: (NullPoint s, MonadIO m, MonadMask m, ReadableChunk s el) =>+ Int -- ^Buffer size (number of elements)+ -> Iteratee s m a+ -> FilePath+ -> m a+fileDriverHandle bufsize iter filepath =+ enumFile bufsize filepath iter >>= run++-- |A version of @fileDriverHandle@ that supports seeking.+fileDriverRandomHandle+ :: (NullPoint s, MonadIO m, MonadMask m, ReadableChunk s el) =>+ Int -- ^ Buffer size (number of elements)+ -> Iteratee s m a+ -> FilePath+ -> m a+fileDriverRandomHandle bufsize iter filepath =+ enumFileRandom bufsize filepath iter >>= run+
src/Data/Iteratee/IO/Interact.hs view
@@ -1,31 +1,28 @@ module Data.Iteratee.IO.Interact ( ioIter-) where--import Control.Monad.IO.Class (MonadIO, liftIO)+)+where +import Control.Monad.IO.Class import Data.Iteratee-import qualified Data.Iteratee.Base.StreamChunk as SC -- | Use an IO function to choose what iteratee to run.--- Typically this function handles user interaction and--- returns with a simple iteratee such as 'head' or 'seek'.--- --- The IO function takes a value of type 'a' as input, and--- should return 'Right a' to continue, or 'Left b'--- to terminate. Upon termination, ioIter will return 'Done b'.------ The second argument to 'ioIter' is used as the initial input--- to the IO function, and on each successive iteration the--- previously returned value is used as input. Put another way,--- the value of type 'a' is used like a fold accumulator.--- The value of type 'b' is typically some form of control code--- that the application uses to signal the reason for termination.-ioIter :: (SC.StreamChunk s el, MonadIO m)- => (a -> IO (Either b (IterateeG s el m a))) -> a -> IterateeG s el m b-ioIter f a = do i'e <- liftIO $ f a- case i'e of- Left e -> return e- Right i -> do a' <- i- ioIter f a'-+-- -- Typically this function handles user interaction and+-- -- returns with a simple iteratee such as 'head' or 'seek'.+-- --+-- -- The IO function takes a value of type 'a' as input, and+-- -- should return 'Right a' to continue, or 'Left b'+-- -- to terminate. Upon termination, ioIter will return 'Done b'.+-- --+-- -- The second argument to 'ioIter' is used as the initial input+-- -- to the IO function, and on each successive iteration the+-- -- previously returned value is used as input. Put another way,+-- -- the value of type 'a' is used like a fold accumulator.+-- -- The value of type 'b' is typically some form of control code+-- -- that the application uses to signal the reason for termination.+ioIter :: (MonadIO m, Nullable s)+ => (a -> IO (Either b (Iteratee s m a)))+ -> a+ -> Iteratee s m b+ioIter f a = either return (>>= ioIter f) =<< liftIO (f a)+{-# INLINE ioIter #-}
+ src/Data/Iteratee/Iteratee.hs view
@@ -0,0 +1,564 @@+{-# LANGUAGE KindSignatures+ ,RankNTypes+ ,FlexibleContexts+ ,ScopedTypeVariables+ ,BangPatterns+ ,DeriveDataTypeable #-}++-- |Monadic and General Iteratees:+-- incremental input parsers, processors and transformers++module Data.Iteratee.Iteratee (+ -- * Types+ EnumerateeHandler+ -- ** Error handling+ ,throwErr+ ,throwRecoverableErr+ ,checkErr+ -- ** Basic Iteratees+ ,identity+ ,skipToEof+ ,isStreamFinished+ -- ** Chunkwise Iteratees+ ,mapChunksM_+ ,foldChunksM+ ,getChunk+ ,getChunks+ -- ** Nested iteratee combinators+ ,mapChunks+ ,mapChunksM+ ,convStream+ ,unfoldConvStream+ ,unfoldConvStreamCheck+ ,joinI+ ,joinIM+ -- * Enumerators+ ,Enumerator+ ,Enumeratee+ -- ** Basic enumerators+ ,enumChunk+ ,enumEof+ ,enumErr+ ,enumPure1Chunk+ ,enumList+ ,enumCheckIfDone+ ,enumFromCallback+ ,enumFromCallbackCatch+ -- ** Enumerator Combinators+ ,(>>>)+ ,eneeCheckIfDone+ ,eneeCheckIfDoneHandle+ ,eneeCheckIfDoneIgnore+ ,eneeCheckIfDonePass+ ,mergeEnums+ -- ** Enumeratee Combinators+ ,($=)+ ,(=$)+ ,(><>)+ ,(<><)+ -- * Misc.+ ,seek+ ,FileOffset+ -- * Classes+ ,module Data.Iteratee.Base+)+where++import Prelude hiding (head, drop, dropWhile, take, break, foldl, foldl1, length, filter, sum, product)++import Data.Iteratee.IO.Base+import Data.Iteratee.Base++import Control.Exception+import Control.Monad.Trans.Class+import Data.Maybe+import Data.Typeable++-- exception helpers+excDivergent :: SomeException+excDivergent = toException DivergentException++-- ------------------------------------------------------------------------+-- Primitive iteratees++-- |Report and propagate an unrecoverable error.+-- Disregard the input first and then propagate the error. This error+-- cannot be handled by 'enumFromCallbackCatch', although it can be cleared+-- by 'checkErr'.+throwErr :: SomeException -> Iteratee s m a+throwErr e = icont (const (throwErr e)) (Just e)++-- |Report and propagate a recoverable error. This error can be handled by+-- both 'enumFromCallbackCatch' and 'checkErr'.+throwRecoverableErr ::+ SomeException+ -> (Stream s -> Iteratee s m a)+ -> Iteratee s m a+throwRecoverableErr e i = icont i (Just e)+++-- |Check if an iteratee produces an error.+-- Returns @Right a@ if it completes without errors, otherwise+-- @Left SomeException@. 'checkErr' is useful for iteratees that may not+-- terminate, such as @Data.Iteratee.head@ with an empty stream.+checkErr ::+ (NullPoint s) =>+ Iteratee s m a+ -> Iteratee s m (Either SomeException a)+checkErr iter = Iteratee $ \onDone onCont ->+ let od = onDone . Right+ oc k Nothing = onCont (checkErr . k) Nothing+ oc _ (Just e) = onDone (Left e) (Chunk empty)+ in runIter iter od oc++-- ------------------------------------------------------------------------+-- Parser combinators++-- |The identity iteratee. Doesn't do any processing of input.+identity :: (NullPoint s) => Iteratee s m ()+identity = idone () (Chunk empty)++-- |Get the stream status of an iteratee.+isStreamFinished :: (Nullable s) => Iteratee s m (Maybe SomeException)+isStreamFinished = liftI check+ where+ check s@(Chunk xs)+ | nullC xs = isStreamFinished+ | otherwise = idone Nothing s+ check s@(EOF e) = idone (Just $ fromMaybe (toException EofException) e) s+{-# INLINE isStreamFinished #-}+++-- |Skip the rest of the stream+skipToEof :: Iteratee s m ()+skipToEof = icont check Nothing+ where+ check (Chunk _) = skipToEof+ check s = idone () s+++-- |Seek to a position in the stream+seek :: (NullPoint s) => FileOffset -> Iteratee s m ()+seek o = throwRecoverableErr (toException $ SeekException o) (const identity)++-- | Map a monadic function over the chunks of the stream and ignore the+-- result. Useful for creating efficient monadic iteratee consumers, e.g.+-- +-- > logger = mapChunksM_ (liftIO . putStrLn)+-- +-- these can be efficiently run in parallel with other iteratees via+-- @Data.Iteratee.ListLike.zip@.+mapChunksM_ :: (Monad m, Nullable s) => (s -> m b) -> Iteratee s m ()+mapChunksM_ f = liftI step+ where+ step (Chunk xs)+ | nullC xs = liftI step+ | otherwise = lift (f xs) >> liftI step+ step s@(EOF _) = idone () s+{-# INLINE mapChunksM_ #-}++-- | A fold over chunks+foldChunksM :: (Monad m, Nullable s) => (a -> s -> m a) -> a -> Iteratee s m a+foldChunksM f = liftI . go+ where+ go a (Chunk c) = lift (f a c) >>= liftI . go+ go a e = idone a e+{-# INLINE foldChunksM #-}++-- | Get the current chunk from the stream.+getChunk :: (Nullable s, NullPoint s) => Iteratee s m s+getChunk = liftI step+ where+ step (Chunk xs)+ | nullC xs = liftI step+ | otherwise = idone xs $ Chunk empty+ step (EOF Nothing) = throwErr $ toException EofException+ step (EOF (Just e)) = throwErr e+{-# INLINE getChunk #-}++-- | Get a list of all chunks from the stream.+getChunks :: (Nullable s) => Iteratee s m [s]+getChunks = liftI (step id)+ where+ step acc (Chunk xs)+ | nullC xs = liftI (step acc)+ | otherwise = liftI (step $ acc . (xs:))+ step acc stream = idone (acc []) stream+{-# INLINE getChunks #-}++-- ---------------------------------------------------+-- The converters show a different way of composing two iteratees:+-- `vertical' rather than `horizontal'++type Enumeratee sFrom sTo (m :: * -> *) a =+ Iteratee sTo m a+ -> Iteratee sFrom m (Iteratee sTo m a)++-- The following pattern appears often in Enumeratee code+{-# INLINE eneeCheckIfDone #-}++-- | Utility function for creating enumeratees. Typical usage is demonstrated+-- by the @breakE@ definition.+-- +-- > breakE+-- > :: (Monad m, LL.ListLike s el, NullPoint s)+-- > => (el -> Bool)+-- > -> Enumeratee s s m a+-- > breakE cpred = eneeCheckIfDone (liftI . step)+-- > where+-- > step k (Chunk s)+-- > | LL.null s = liftI (step k)+-- > | otherwise = case LL.break cpred s of+-- > (str', tail')+-- > | LL.null tail' -> eneeCheckIfDone (liftI . step) . k $ Chunk str'+-- > | otherwise -> idone (k $ Chunk str') (Chunk tail')+-- > step k stream = idone (k stream) stream+-- +eneeCheckIfDone ::+ (Monad m, NullPoint elo) =>+ ((Stream eli -> Iteratee eli m a) -> Iteratee elo m (Iteratee eli m a))+ -> Enumeratee elo eli m a+eneeCheckIfDone f = eneeCheckIfDonePass f'+ where+ f' k Nothing = f k+ f' k (Just e) = throwRecoverableErr e (\s -> joinIM $ enumChunk s $ eneeCheckIfDone f (liftI k))++type EnumerateeHandler eli elo m a =+ (Stream eli -> Iteratee eli m a)+ -> SomeException+ -> Iteratee elo m (Iteratee eli m a)++-- | The same as eneeCheckIfDonePass, with one extra argument:+-- a handler which is used+-- to process any exceptions in a separate method.+eneeCheckIfDoneHandle+ :: (NullPoint elo)+ => EnumerateeHandler eli elo m a+ -> ((Stream eli -> Iteratee eli m a)+ -> Maybe SomeException+ -> Iteratee elo m (Iteratee eli m a)+ )+ -> Enumeratee elo eli m a+eneeCheckIfDoneHandle h f inner = Iteratee $ \od oc ->+ let onDone x s = od (idone x s) (Chunk empty)+ onCont k Nothing = runIter (f k Nothing) od oc+ onCont k (Just e) = runIter (h k e) od oc+ in runIter inner onDone onCont+{-# INLINABLE eneeCheckIfDoneHandle #-}++eneeCheckIfDonePass+ :: (NullPoint elo)+ => ((Stream eli -> Iteratee eli m a)+ -> Maybe SomeException+ -> Iteratee elo m (Iteratee eli m a)+ )+ -> Enumeratee elo eli m a+eneeCheckIfDonePass f = eneeCheckIfDoneHandle (\k e -> f k (Just e)) f+{-# INLINABLE eneeCheckIfDonePass #-}++eneeCheckIfDoneIgnore+ :: (NullPoint elo)+ => ((Stream eli -> Iteratee eli m a)+ -> Maybe SomeException+ -> Iteratee elo m (Iteratee eli m a)+ )+ -> Enumeratee elo eli m a+eneeCheckIfDoneIgnore f = eneeCheckIfDoneHandle (\k _ -> f k Nothing) f++-- | Convert one stream into another with the supplied mapping function.+-- This function operates on whole chunks at a time, contrasting to+-- @mapStream@ which operates on single elements.+-- +-- > unpacker :: Enumeratee B.ByteString [Word8] m a+-- > unpacker = mapChunks B.unpack+-- +mapChunks :: (NullPoint s) => (s -> s') -> Enumeratee s s' m a+mapChunks f = eneeCheckIfDonePass (icont . step)+ where+ step k (Chunk xs) = eneeCheckIfDonePass (icont . step) . k . Chunk $ f xs+ step k str@(EOF mErr) = idone (k $ EOF mErr) str+{-# INLINE mapChunks #-}++-- | Convert a stream of @s@ to a stream of @s'@ using the supplied function.+mapChunksM+ :: (Monad m, NullPoint s, Nullable s)+ => (s -> m s')+ -> Enumeratee s s' m a+mapChunksM f = eneeCheckIfDonePass (icont . step)+ where+ step k (Chunk xs) = lift (f xs) >>=+ eneeCheckIfDonePass (icont . step) . k . Chunk+ step k str@(EOF mErr) = idone (k $ EOF mErr) str+{-# INLINE mapChunksM #-}++-- |Convert one stream into another, not necessarily in lockstep.+-- +-- The transformer mapStream maps one element of the outer stream+-- to one element of the nested stream. The transformer below is more+-- general: it may take several elements of the outer stream to produce+-- one element of the inner stream, or the other way around.+-- The transformation from one stream to the other is specified as+-- Iteratee s m s'.+convStream ::+ (Monad m, Nullable s) =>+ Iteratee s m s'+ -> Enumeratee s s' m a+convStream fi = eneeCheckIfDonePass check+ where+ check k (Just e) = throwRecoverableErr e (const identity) >> check k Nothing+ check k _ = isStreamFinished >>= maybe (step k) (idone (liftI k) . EOF . Just)+ step k = fi >>= eneeCheckIfDonePass check . k . Chunk+{-# INLINABLE convStream #-}++-- |The most general stream converter. Given a function to produce iteratee+-- transformers and an initial state, convert the stream using iteratees+-- generated by the function while continually updating the internal state.+unfoldConvStream ::+ (Monad m, Nullable s) =>+ (acc -> Iteratee s m (acc, s'))+ -> acc+ -> Enumeratee s s' m a+unfoldConvStream f acc0 = eneeCheckIfDonePass (check acc0)+ where+ check acc k (Just e) = throwRecoverableErr e (const identity) >> check acc k Nothing+ check acc k _ = isStreamFinished >>=+ maybe (step acc k) (idone (liftI k) . EOF . Just)+ step acc k = f acc >>= \(acc', s') ->+ eneeCheckIfDonePass (check acc') . k . Chunk $ s'+{-# INLINABLE unfoldConvStream #-}++unfoldConvStreamCheck+ :: (Monad m, Nullable elo)+ => (((Stream eli -> Iteratee eli m a)+ -> Maybe SomeException+ -> Iteratee elo m (Iteratee eli m a)+ )+ -> Enumeratee elo eli m a+ )+ -> (acc -> Iteratee elo m (acc, eli))+ -> acc+ -> Enumeratee elo eli m a+unfoldConvStreamCheck checkDone f acc0 = checkDone (check acc0)+ where+ check acc k mX = isStreamFinished >>=+ maybe (step acc k mX) (idone (icont k mX) . EOF . Just)+ step acc k Nothing = f acc >>= \(acc', s') ->+ (checkDone (check acc') . k $ Chunk s')+ step acc k (Just ex) = throwRecoverableErr ex $ \str' ->+ let i = f acc >>= \(acc', s') ->+ (checkDone (check acc') . k $ Chunk s')+ in joinIM $ enumChunk str' i+{-# INLINABLE unfoldConvStreamCheck #-}++-- | Collapse a nested iteratee. The inner iteratee is terminated by @EOF@.+-- Errors are propagated through the result.+-- +-- The stream resumes from the point of the outer iteratee; any remaining+-- input in the inner iteratee will be lost.+-- Differs from 'Control.Monad.join' in that the inner iteratee is terminated,+-- and may have a different stream type than the result.+joinI ::+ (Monad m, Nullable s) =>+ Iteratee s m (Iteratee s' m a)+ -> Iteratee s m a+joinI = (>>=+ \inner -> Iteratee $ \od oc ->+ let onDone x _ = od x (Chunk empty)+ onCont k Nothing = runIter (k (EOF Nothing)) onDone onCont'+ onCont _ (Just e) = runIter (throwErr e) od oc+ onCont' _ e = runIter (throwErr (fromMaybe excDivergent e)) od oc+ in runIter inner onDone onCont)+{-# INLINE joinI #-}++-- | Lift an iteratee inside a monad to an iteratee.+joinIM :: (Monad m) => m (Iteratee s m a) -> Iteratee s m a+joinIM mIter = Iteratee $ \od oc -> mIter >>= \iter -> runIter iter od oc+++-- ------------------------------------------------------------------------+-- Enumerators+-- | Each enumerator takes an iteratee and returns an iteratee+-- +-- an Enumerator is an iteratee transformer.+-- The enumerator normally stops when the stream is terminated+-- or when the iteratee moves to the done state, whichever comes first.+-- When to stop is of course up to the enumerator...++type Enumerator s m a = Iteratee s m a -> m (Iteratee s m a)++-- |Applies the iteratee to the given stream. This wraps 'enumEof',+-- 'enumErr', and 'enumPure1Chunk', calling the appropriate enumerator+-- based upon 'Stream'.+enumChunk :: (Monad m) => Stream s -> Enumerator s m a+enumChunk (Chunk xs) = enumPure1Chunk xs+enumChunk (EOF Nothing) = enumEof+enumChunk (EOF (Just e)) = enumErr e++-- |The most primitive enumerator: applies the iteratee to the terminated+-- stream. The result is the iteratee in the Done state. It is an error+-- if the iteratee does not terminate on EOF.+enumEof :: (Monad m) => Enumerator s m a+enumEof iter = runIter iter onDone onCont+ where+ onDone x _str = return $ idone x (EOF Nothing)+ onCont k Nothing = runIter (k (EOF Nothing)) onDone onCont'+ onCont k e = return $ icont k e+ onCont' _ Nothing = return $ throwErr excDivergent+ onCont' k e = return $ icont k e++-- |Another primitive enumerator: tell the Iteratee the stream terminated+-- with an error.+enumErr :: (Exception e, Monad m) => e -> Enumerator s m a+enumErr e iter = runIter iter onDone onCont+ where+ onDone x _ = return $ idone x (EOF . Just $ toException e)+ onCont k Nothing = runIter (k (EOF (Just (toException e)))) onDone onCont'+ onCont k e' = return $ icont k e'+ onCont' _ Nothing = return $ throwErr excDivergent+ onCont' k e' = return $ icont k e'+++-- |The composition of two enumerators: essentially the functional composition+-- +-- It is convenient to flip the order of the arguments of the composition+-- though: in e1 >>> e2, e1 is executed first++(>>>) :: (Monad m) => Enumerator s m a -> Enumerator s m a -> Enumerator s m a+(e1 >>> e2) i = e1 i >>= e2+ -- I think (>>>) is identical to (>=>)...++infixr 0 =$++-- | Combines an Enumeratee from @s@ to @s'@ and an Iteratee that+-- consumes @s'@ into an Iteratee which consumes @s@+(=$)+ :: (Nullable s, Nullable s', Monad m)+ => Enumeratee s s' m a+ -> Iteratee s' m a+ -> Iteratee s m a+(=$) = (.) joinI++infixl 1 $=++-- | Combines Enumerator which produces stream of @s@ and @Enumeratee@+-- which transforms stream of @s@ to stream+-- of @s'@ to into Enumerator which produces stream of @s'@+($=)+ :: (Nullable s, Nullable s', Monad m)+ => (forall a. Enumerator s m a)+ -> Enumeratee s s' m b+ -> Enumerator s' m b+($=) enum enee iter = enum (enee iter) >>= run+++-- | Enumeratee composition+-- Run the second enumeratee within the first. In this example, stream2list+-- is run within the 'take 10', which is itself run within 'take 15', resulting+-- in 15 elements being consumed+-- +-- >>> run =<< enumPure1Chunk [1..1000 :: Int] (joinI $ (I.take 15 ><> I.take 10) I.stream2list)+-- [1,2,3,4,5,6,7,8,9,10]+-- +(><>) ::+ (Nullable s1, Monad m)+ => (forall x . Enumeratee s1 s2 m x)+ -> Enumeratee s2 s3 m a+ -> Enumeratee s1 s3 m a+f ><> g = joinI . f . g++-- | enumeratee composition with the arguments flipped, see '><>'+(<><) ::+ (Nullable s1, Monad m)+ => Enumeratee s2 s3 m a+ -> (forall x. Enumeratee s1 s2 m x)+ -> Enumeratee s1 s3 m a+f <>< g = joinI . g . f++-- | Combine enumeration over two streams. The merging enumeratee would+-- typically be the result of 'Data.Iteratee.ListLike.merge' or+-- 'Data.Iteratee.ListLike.mergeByChunks' (see @merge@ for example).+mergeEnums :: + (Nullable s2, Nullable s1, Monad m)+ => Enumerator s1 m a -- ^ inner enumerator+ -> Enumerator s2 (Iteratee s1 m) a -- ^ outer enumerator+ -> Enumeratee s2 s1 (Iteratee s1 m) a -- ^ merging enumeratee+ -> Enumerator s1 m a+mergeEnums e1 e2 etee i = e1 $ e2 (joinI . etee $ ilift lift i) >>= run+{-# INLINE mergeEnums #-}++-- | The pure 1-chunk enumerator+-- +-- It passes a given list of elements to the iteratee in one chunk+-- This enumerator does no IO and is useful for testing of base parsing+enumPure1Chunk :: (Monad m) => s -> Enumerator s m a+enumPure1Chunk str iter = runIter iter idoneM onCont+ where+ onCont k Nothing = return $ k $ Chunk str+ onCont k e = return $ icont k e++-- | Enumerate chunks from a list+-- +enumList :: (Monad m) => [s] -> Enumerator s m a+enumList chunks = go chunks+ where+ go [] i = return i+ go xs' i = runIter i idoneM (onCont xs')+ where+ onCont (x:xs) k Nothing = go xs . k $ Chunk x+ onCont _ _ (Just e) = return $ throwErr e+ onCont _ k Nothing = return $ icont k Nothing+{-# INLINABLE enumList #-}++-- | Checks if an iteratee has finished.+-- +-- This enumerator runs the iteratee, performing any monadic actions.+-- If the result is True, the returned iteratee is done.+enumCheckIfDone :: (Monad m) => Iteratee s m a -> m (Bool, Iteratee s m a)+enumCheckIfDone iter = runIter iter onDone onCont+ where+ onDone x str = return (True, idone x str)+ onCont k e = return (False, icont k e)+{-# INLINE enumCheckIfDone #-}+++-- |Create an enumerator from a callback function+enumFromCallback ::+ (Monad m, NullPoint s) =>+ (st -> m (Either SomeException ((Bool, st), s)))+ -> st+ -> Enumerator s m a+enumFromCallback c st =+ enumFromCallbackCatch c (\NotAnException -> return Nothing) st++-- Dummy exception to catch in enumFromCallback+-- This never gets thrown, but it lets us+-- share plumbing+data NotAnException = NotAnException+ deriving (Show, Typeable)++instance Exception NotAnException where+instance IException NotAnException where++-- |Create an enumerator from a callback function with an exception handler.+-- The exception handler is called if an iteratee reports an exception.+enumFromCallbackCatch+ :: (IException e, Monad m, NullPoint s)+ => (st -> m (Either SomeException ((Bool, st), s)))+ -> (e -> m (Maybe EnumException))+ -> st+ -> Enumerator s m a+enumFromCallbackCatch c handler = loop+ where+ loop st iter = runIter iter idoneM (onCont st)+ check k (True, st') = loop st' . k . Chunk+ check k (False,_st') = return . k . Chunk+ onCont st k Nothing = c st >>=+ either (return . k . EOF . Just) (uncurry (check k))+ onCont st k j@(Just e) = case fromException e of+ Just e' -> handler e' >>=+ maybe (loop st . k $ Chunk empty)+ (return . icont k . Just) . fmap toException+ Nothing -> return (icont k j)+{-# INLINE enumFromCallbackCatch #-}++
+ src/Data/Iteratee/ListLike.hs view
@@ -0,0 +1,1074 @@+{-# LANGUAGE FlexibleContexts, BangPatterns, TupleSections, ScopedTypeVariables #-}++-- |Monadic Iteratees:+-- incremental input parsers, processors and transformers+-- +-- This module provides many basic iteratees from which more complicated+-- iteratees can be built. In general these iteratees parallel those in+-- @Data.List@, with some additions.++module Data.Iteratee.ListLike (+ -- * Iteratees+ -- ** Iteratee Utilities+ isFinished+ ,stream2list+ ,stream2stream+ -- ** Basic Iteratees+ ,break+ ,dropWhile+ ,drop+ ,head+ ,tryHead+ ,last+ ,heads+ ,peek+ ,roll+ ,length+ ,chunkLength+ ,takeFromChunk+ -- ** Nested iteratee combinators+ ,breakE+ ,take+ ,takeUpTo+ ,takeWhile+ ,takeWhileE+ ,mapStream+ ,rigidMapStream+ ,filter+ ,group+ ,groupBy+ ,merge+ ,mergeByChunks+ -- ** Folds+ ,foldl+ ,foldl'+ ,foldl1+ ,foldl1'+ -- ** Special Folds+ ,sum+ ,product+ -- * Enumerators+ -- ** Basic enumerators+ ,enumPureNChunk+ -- ** Enumerator Combinators+ ,enumPair+ ,enumWith+ ,zip+ ,zip3+ ,zip4+ ,zip5+ ,sequence_+ ,countConsumed+ ,greedy+ -- ** Monadic functions+ ,mapM_+ ,foldM+ -- * Re-exported modules+ ,module Data.Iteratee.Iteratee+)+where++import Prelude hiding (mapM_, null, head, last, drop, dropWhile, take, takeWhile, break, foldl, foldl1, length, filter, sum, product, zip, zip3, sequence_)++import qualified Prelude as Prelude++import Data.List (partition)+import qualified Data.ListLike as LL+import qualified Data.ListLike.FoldableLL as FLL+import Data.Iteratee.Iteratee+import Data.Monoid+import Control.Applicative ((<$>), (<*>), (<*))+import Control.Monad (liftM, liftM2, mplus, (<=<))+import Control.Monad.Trans.Class+import Data.Word (Word8)+import qualified Data.ByteString as B++-- Useful combinators for implementing iteratees and enumerators++-- | Check if a stream has received 'EOF'.+isFinished :: (Nullable s) => Iteratee s m Bool+isFinished = liftI check+ where+ check c@(Chunk xs)+ | nullC xs = liftI check+ | otherwise = idone False c+ check s@(EOF _) = idone True s+{-# INLINE isFinished #-}++-- ------------------------------------------------------------------------+-- Primitive iteratees++-- |Read a stream to the end and return all of its elements as a list.+-- This iteratee returns all data from the stream *strictly*.+stream2list :: (Monad m, Nullable s, LL.ListLike s el) => Iteratee s m [el]+stream2list = liftM (concatMap LL.toList) getChunks+{-# INLINE stream2list #-}++-- |Read a stream to the end and return all of its elements as a stream.+-- This iteratee returns all data from the stream *strictly*.+stream2stream :: (Monad m, Nullable s, Monoid s) => Iteratee s m s+stream2stream = liftM mconcat getChunks+{-# INLINE stream2stream #-}+++-- ------------------------------------------------------------------------+-- Parser combinators++-- |Takes an element predicate and returns the (possibly empty) prefix of+-- the stream. None of the characters in the string satisfy the character+-- predicate.+-- If the stream is not terminated, the first character of the remaining stream+-- satisfies the predicate.+-- +-- N.B. 'breakE' should be used in preference to @break@.+-- @break@ will retain all data until the predicate is met, which may+-- result in a space leak.+-- +-- The analogue of @List.break@++break :: (LL.ListLike s el) => (el -> Bool) -> Iteratee s m s+break cpred = icont (step mempty) Nothing+ where+ step bfr (Chunk str)+ | LL.null str = icont (step bfr) Nothing+ | otherwise = case LL.break cpred str of+ (str', tail')+ | LL.null tail' -> icont (step (bfr `mappend` str)) Nothing+ | otherwise -> idone (bfr `mappend` str') (Chunk tail')+ step bfr stream = idone bfr stream+{-# INLINE break #-}+++-- |Attempt to read the next element of the stream and return it+-- Raise a (recoverable) error if the stream is terminated.+-- +-- The analogue of @List.head@+-- +-- Because @head@ can raise an error, it shouldn't be used when constructing+-- iteratees for @convStream@. Use @tryHead@ instead.+head :: (LL.ListLike s el) => Iteratee s m el+head = liftI step+ where+ step (Chunk vec)+ | LL.null vec = icont step Nothing+ | otherwise = idone (LL.head vec) (Chunk $ LL.tail vec)+ step stream = icont step (Just (setEOF stream))+{-# INLINE head #-}++-- | Similar to @head@, except it returns @Nothing@ if the stream+-- is terminated.+tryHead :: (LL.ListLike s el) => Iteratee s m (Maybe el)+tryHead = liftI step+ where+ step (Chunk vec)+ | LL.null vec = liftI step+ | otherwise = idone (Just $ LL.head vec) (Chunk $ LL.tail vec)+ step stream = idone Nothing stream+{-# INLINE tryHead #-}++-- |Attempt to read the last element of the stream and return it+-- Raise a (recoverable) error if the stream is terminated+-- +-- The analogue of @List.last@+last :: (LL.ListLike s el, Nullable s) => Iteratee s m el+last = liftI (step Nothing)+ where+ step l (Chunk xs)+ | nullC xs = liftI (step l)+ | otherwise = liftI $ step (Just $ LL.last xs)+ step l s@(EOF _) = case l of+ Nothing -> icont (step l) . Just . setEOF $ s+ Just x -> idone x s+{-# INLINE last #-}+++-- |Given a sequence of characters, attempt to match them against+-- the characters on the stream. Return the count of how many+-- characters matched. The matched characters are removed from the+-- stream.+-- For example, if the stream contains 'abd', then (heads 'abc')+-- will remove the characters 'ab' and return 2.+heads :: (Monad m, Nullable s, LL.ListLike s el, Eq el) => s -> Iteratee s m Int+heads st | nullC st = return 0+heads st = loop 0 st+ where+ loop cnt xs+ | nullC xs = return cnt+ | otherwise = liftI (step cnt xs)+ step cnt str (Chunk xs) | nullC xs = liftI (step cnt str)+ step cnt str stream | nullC str = idone cnt stream+ step cnt str s@(Chunk xs) =+ if LL.head str == LL.head xs+ then step (succ cnt) (LL.tail str) (Chunk $ LL.tail xs)+ else idone cnt s+ step cnt _ stream = idone cnt stream+{-# INLINE heads #-}+++-- |Look ahead at the next element of the stream, without removing+-- it from the stream.+-- Return @Just c@ if successful, return @Nothing@ if the stream is+-- terminated by 'EOF'.+peek :: (LL.ListLike s el) => Iteratee s m (Maybe el)+peek = liftI step+ where+ step s@(Chunk vec)+ | LL.null vec = liftI step+ | otherwise = idone (Just $ LL.head vec) s+ step stream = idone Nothing stream+{-# INLINE peek #-}++-- | Return a chunk of @t@ elements length while consuming @d@ elements+-- from the stream. Useful for creating a 'rolling average' with+-- 'convStream'.+roll+ :: (Monad m, Functor m, Nullable s, LL.ListLike s el, LL.ListLike s' s)+ => Int -- ^ length of chunk (t)+ -> Int -- ^ amount to consume (d)+ -> Iteratee s m s'+roll t d | t > d = liftI step+ where+ step (Chunk vec)+ | LL.length vec >= t =+ idone (LL.singleton $ LL.take t vec) (Chunk $ LL.drop d vec)+ | LL.null vec = liftI step+ | otherwise = liftI (step' vec)+ step stream = idone LL.empty stream+ step' v1 (Chunk vec) = step . Chunk $ v1 `mappend` vec+ step' v1 stream = idone (LL.singleton v1) stream+roll t d = LL.singleton <$> joinI (take t stream2stream) <* drop (d-t)+ -- d is >= t, so this version works+{-# INLINE roll #-}+++-- |Drop n elements of the stream, if there are that many.+-- +-- The analogue of @List.drop@+drop :: (Nullable s, LL.ListLike s el) => Int -> Iteratee s m ()+drop 0 = idone () (Chunk empty)+drop n' = liftI (step n')+ where+ step n (Chunk str)+ | LL.length str < n = liftI (step (n - LL.length str))+ | otherwise = idone () (Chunk (LL.drop n str))+ step _ stream = idone () stream+{-# INLINE drop #-}++-- |Skip all elements while the predicate is true.+-- +-- The analogue of @List.dropWhile@+dropWhile :: (LL.ListLike s el) => (el -> Bool) -> Iteratee s m ()+dropWhile p = liftI step+ where+ step (Chunk str)+ | LL.null left = liftI step+ | otherwise = idone () (Chunk left)+ where+ left = LL.dropWhile p str+ step stream = idone () stream+{-# INLINE dropWhile #-}+++-- | Return the total length of the remaining part of the stream.+-- +-- This forces evaluation of the entire stream.+-- +-- The analogue of @List.length@+length :: (Num a, LL.ListLike s el) => Iteratee s m a+length = liftI (step 0)+ where+ step !i (Chunk xs) = liftI (step $ i + fromIntegral (LL.length xs))+ step !i stream = idone i stream+{-# INLINE length #-}++-- | Get the length of the current chunk, or @Nothing@ if 'EOF'.+-- +-- This function consumes no input.+chunkLength :: (LL.ListLike s el) => Iteratee s m (Maybe Int)+chunkLength = liftI step+ where+ step s@(Chunk xs) = idone (Just $ LL.length xs) s+ step stream = idone Nothing stream+{-# INLINE chunkLength #-}++-- | Take @n@ elements from the current chunk, or the whole chunk if+-- @n@ is greater.+takeFromChunk ::+ (Nullable s, LL.ListLike s el)+ => Int+ -> Iteratee s m s+takeFromChunk n | n <= 0 = idone empty (Chunk empty)+takeFromChunk n = liftI step+ where+ step (Chunk xs) = let (h,t) = LL.splitAt n xs in idone h $ Chunk t+ step stream = idone empty stream+{-# INLINE takeFromChunk #-}++-- ---------------------------------------------------+-- The converters show a different way of composing two iteratees:+-- `vertical' rather than `horizontal'++-- |Takes an element predicate and an iteratee, running the iteratee+-- on all elements of the stream until the predicate is met.+-- +-- the following rule relates @break@ to @breakE@+-- @break@ pred === @joinI@ (@breakE@ pred stream2stream)+-- +-- @breakE@ should be used in preference to @break@ whenever possible.+breakE+ :: (LL.ListLike s el, NullPoint s)+ => (el -> Bool)+ -> Enumeratee s s m a+breakE cpred = eneeCheckIfDonePass (icont . step)+ where+ step k (Chunk s)+ | LL.null s = liftI (step k)+ | otherwise = case LL.break cpred s of+ (str', tail')+ | LL.null tail' -> eneeCheckIfDonePass (icont . step) . k $ Chunk str'+ | otherwise -> idone (k $ Chunk str') (Chunk tail')+ step k stream = idone (liftI k) stream+{-# INLINE breakE #-}++-- |Read n elements from a stream and apply the given iteratee to the+-- stream of the read elements. Unless the stream is terminated early, we+-- read exactly n elements, even if the iteratee has accepted fewer.+-- +-- The analogue of @List.take@+take ::+ (Monad m, Nullable s, LL.ListLike s el)+ => Int -- ^ number of elements to consume+ -> Enumeratee s s m a+take n' iter+ | n' <= 0 = return iter+ | otherwise = Iteratee $ \od oc -> runIter iter (on_done od oc) (on_cont od oc)+ where+ on_done od oc x _ = runIter (drop n' >> return (return x)) od oc+ on_cont od oc k Nothing = if n' == 0 then od (liftI k) (Chunk mempty)+ else runIter (liftI (step n' k)) od oc+ on_cont od oc _ (Just e) = runIter (drop n' >> throwErr e) od oc+ step n k (Chunk str)+ | LL.null str = liftI (step n k)+ | LL.length str <= n = take (n - LL.length str) $ k (Chunk str)+ | otherwise = idone (k (Chunk s1)) (Chunk s2)+ where (s1, s2) = LL.splitAt n str+ step _n k stream = idone (liftI k) stream+{-# INLINE take #-}++-- |Read n elements from a stream and apply the given iteratee to the+-- stream of the read elements. If the given iteratee accepted fewer+-- elements, we stop.+-- This is the variation of 'take' with the early termination+-- of processing of the outer stream once the processing of the inner stream+-- finished early.+-- +-- Iteratees composed with 'takeUpTo' will consume only enough elements to+-- reach a done state. Any remaining data will be available in the outer+-- stream.+-- +-- > > let iter = do+-- > h <- joinI $ takeUpTo 5 I.head+-- > t <- stream2list+-- > return (h,t)+-- > +-- > > enumPureNChunk [1..10::Int] 3 iter >>= run >>= print+-- > (1,[2,3,4,5,6,7,8,9,10])+-- > +-- > > enumPureNChunk [1..10::Int] 7 iter >>= run >>= print+-- > (1,[2,3,4,5,6,7,8,9,10])+-- +-- in each case, @I.head@ consumes only one element, returning the remaining+-- 4 elements to the outer stream+takeUpTo :: (Monad m, Nullable s, LL.ListLike s el) => Int -> Enumeratee s s m a+takeUpTo i iter+ | i <= 0 = idone iter (Chunk empty)+ | otherwise = Iteratee $ \od oc ->+ runIter iter (onDone od oc) (onCont od oc)+ where+ onDone od oc x str = runIter (idone (return x) str) od oc+ onCont od oc k Nothing = if i == 0 then od (liftI k) (Chunk mempty)+ else runIter (liftI (step i k)) od oc+ onCont od oc _ (Just e) = runIter (throwErr e) od oc+ step n k (Chunk str)+ | LL.null str = liftI (step n k)+ | LL.length str < n = takeUpTo (n - LL.length str) $ k (Chunk str)+ | otherwise =+ -- check to see if the inner iteratee has completed, and if so,+ -- grab any remaining stream to put it in the outer iteratee.+ -- the outer iteratee is always complete at this stage, although+ -- the inner may not be.+ let (s1, s2) = LL.splitAt n str+ in Iteratee $ \od' _ -> do+ res <- runIter (k (Chunk s1)) (\a s -> return $ Left (a, s))+ (\k' e -> return $ Right (k',e))+ case res of+ Left (a,Chunk s1') -> od' (return a)+ (Chunk $ s1' `LL.append` s2)+ Left (a,s') -> od' (idone a s') (Chunk s2)+ Right (k',e) -> od' (icont k' e) (Chunk s2)+ step _ k stream = idone (liftI k) stream+{-# INLINE takeUpTo #-}++-- | Takes an element predicate and returns the (possibly empty)+-- prefix of the stream. All characters+-- in the string will satisfy the character predicate. If the stream+-- is not terminated, the first character of the+-- remaining stream will not satisfy the predicate.+-- +-- The analogue of @List.takeWhile@, see also @break@ and @takeWhileE@+takeWhile :: (LL.ListLike s el ) => (el -> Bool) -> Iteratee s m s+takeWhile = break . (not .)+{-# INLINEABLE takeWhile #-}++-- |Takes an element predicate and an iteratee, running the iteratee+-- on all elements of the stream while the predicate is met.+-- +-- This is preferred to @takeWhile@.+takeWhileE+ :: (LL.ListLike s el, NullPoint s)+ => (el -> Bool)+ -> Enumeratee s s m a+takeWhileE = breakE . (not .)+{-# INLINEABLE takeWhileE #-}++-- |Map the stream: another iteratee transformer+-- Given the stream of elements of the type @el@ and the function @(el->el')@,+-- build a nested stream of elements of the type @el'@ and apply the+-- given iteratee to it.+-- +-- The analog of @List.map@+mapStream+ :: (LL.ListLike (s el) el+ ,LL.ListLike (s el') el'+ ,NullPoint (s el)+ ,LooseMap s el el')+ => (el -> el')+ -> Enumeratee (s el) (s el') m a+mapStream f = mapChunks (lMap f)+{-# SPECIALIZE mapStream :: (el -> el') -> Enumeratee [el] [el'] m a #-}++-- |Map the stream rigidly.+-- +-- Like 'mapStream', but the element type cannot change.+-- This function is necessary for @ByteString@ and similar types+-- that cannot have 'LooseMap' instances, and may be more efficient.+rigidMapStream+ :: (LL.ListLike s el, NullPoint s)+ => (el -> el)+ -> Enumeratee s s m a+rigidMapStream f = mapChunks (LL.rigidMap f)+{-# SPECIALIZE rigidMapStream :: (el -> el) -> Enumeratee [el] [el] m a #-}+{-# SPECIALIZE rigidMapStream :: (Word8 -> Word8) -> Enumeratee B.ByteString B.ByteString m a #-}+++-- |Creates an 'enumeratee' with only elements from the stream that+-- satisfy the predicate function. The outer stream is completely consumed.+-- +-- The analogue of @List.filter@+filter+ :: (Monad m, Functor m, Nullable s, LL.ListLike s el)+ => (el -> Bool)+ -> Enumeratee s s m a+filter p = convStream (LL.filter p <$> getChunk)+{-# INLINE filter #-}++-- |Creates an 'Enumeratee' in which elements from the stream are+-- grouped into @sz@-sized blocks. The final block may be smaller+-- than \sz\.+group+ :: (LL.ListLike s el, Monad m, Nullable s)+ => Int -- ^ size of group+ -> Enumeratee s [s] m a+group cksz iinit = liftI (step 0 id iinit)+ where+ -- there are two cases to consider for performance purposes:+ -- 1 - grouping lots of small chunks into bigger chunks+ -- 2 - breaking large chunks into smaller pieces+ -- case 2 is easier, simply split a chunk into as many pieces as necessary+ -- and pass them to the inner iteratee as one list. @gsplit@ does this.+ --+ -- case 1 is a bit harder, need to hold onto each chunk and coalesce them+ -- after enough have been received. Currently using a difference list+ -- for this, i.e ([s] -> [s])+ --+ -- not using eneeCheckIfDone because that loses final chunks at EOF+ step sz pfxd icur (Chunk s)+ | LL.null s = liftI (step sz pfxd icur)+ | LL.length s + sz < cksz = liftI (step (sz+LL.length s) (pfxd . (s:)) icur)+ | otherwise =+ let (full, rest) = gsplit . mconcat $ pfxd [s]+ pfxd' = if LL.null rest then id else (rest:)+ onDone x str = return $ Left (x,str)+ onCont k Nothing = return . Right . Left . k $ Chunk full+ onCont k e = return . Right $ Right (liftI k, e)+ in do+ res <- lift $ runIter icur onDone onCont+ case res of+ Left (x,str) -> idone (idone x str) (Chunk rest)+ Right (Left inext) -> liftI $ step (LL.length rest) pfxd' inext+ Right (Right (inext, e)) -> icont (step (LL.length rest)+ pfxd' inext)+ e+ step _ pfxd icur mErr = case pfxd [] of+ [] -> idone icur mErr+ rest -> do+ inext <- lift $ enumPure1Chunk [mconcat rest] icur+ idone inext mErr+ gsplit ls = case LL.splitAt cksz ls of+ (g, rest) | LL.null rest -> if LL.length g == cksz+ then ([g], LL.empty)+ else ([], g)+ | otherwise -> let (grest, leftover) = gsplit rest+ g' = g : grest+ in (g', leftover)+++-- | Creates an 'enumeratee' in which elements are grouped into+-- contiguous blocks that are equal according to a predicate.+-- +-- The analogue of 'List.groupBy'+groupBy+ :: (LL.ListLike s el, Monad m, Nullable s)+ => (el -> el -> Bool)+ -> Enumeratee s [s] m a+groupBy same iinit = liftI $ go iinit (const True, id)+ where + -- As in group, need to handle grouping efficiently when we're fed+ -- many small chunks.+ -- + -- Move the accumulation of groups by chunks into an accumulator+ -- that runs through gsplit, which is pfx / partial here. When we+ -- get a chunk, use gsplit to retrieve any full chunks and get the+ -- carried accumulator.+ -- + -- At the end, "finish" the accumulator and handle the last chunk,+ -- unless the stream was entirely empty and there is no+ -- accumulator.+ go icurr pfx (Chunk s) = case gsplit pfx s of+ ([], partial) -> liftI $ go icurr partial+ (full, partial) -> do+ -- if the inner iteratee is done, the outer iteratee needs to be+ -- notified to terminate.+ -- if the inner iteratee is in an error state, that error should+ -- be lifted to the outer iteratee+ let onCont k Nothing = return $ Right $ Left $ k $ Chunk full+ onCont k e = return $ Right $ Right (liftI k, e)+ onDone x str = return $ Left (x,str)+ res <- lift $ runIter icurr onDone onCont+ case res of+ Left (x,str) -> idone (idone x str) (Chunk (mconcat $ snd partial []))+ Right (Left inext) -> liftI $ go inext partial+ Right (Right (inext,e)) -> icont (go inext partial) e+ go icurr (_inpfx, pfxd) (EOF mex) = case pfxd [] of+ [] -> lift . enumChunk (EOF mex) $ icurr+ rest -> do inext <- lift . enumPure1Chunk [mconcat rest] $ icurr+ lift . enumChunk (EOF mex) $ inext+ -- Here, gsplit carries an accumulator consisting of a predicate+ -- "inpfx" that indicates whether a new element belongs in the+ -- growing group, and a difference list to ultimately generate the+ -- group.+ --+ -- The initial accumulator is a group that can accept anything and+ -- is empty.+ -- + -- New chunks are split into groups. The cases are ++ -- 0. Trivially, empty chunk++ -- 1. One chunk, in the currently growing group: continue the+ -- current prefix (and generate a new predicate, in case we had+ -- the initial predicate+ + -- 2. One chunk, but not in the current group: finish the+ -- current group and return a new accumulator for the+ -- newly-started gorup+ + -- 3. Multiple chunks, the first of which completes the+ -- currently growing group+ + -- 4. Multiple chunks, the first of which is a new group+ -- separate from the currently-growing group+ gsplit (inpfx, pfxd) curr = case llGroupBy same curr of+ [] -> ([], (inpfx, pfxd))+ [g0] | inpfx (LL.head g0) -> ([], (same $ LL.head g0, pfxd . (g0 :)))+ | otherwise -> ([mconcat $ pfxd []], (same $ LL.head g0, pfxd . (g0 :)))+ (g0:grest@(_:_)) | inpfx (LL.head g0) -> let glast = Prelude.last grest+ gfirst = mconcat $ (pfxd . (g0 :)) []+ gdone = gfirst : Prelude.init grest+ in ( gdone, (same (LL.head glast), (glast :)) )+ | otherwise -> let glast = Prelude.last grest+ gfirst = mconcat $ pfxd []+ gdone = gfirst : Prelude.init grest+ in ( gdone, (same (LL.head glast), (glast :)) )+ llGroupBy eq l -- Copied from Data.ListLike, avoid spurious (Eq el) constraint+ | LL.null l = []+ | otherwise = (LL.cons x ys):(llGroupBy eq zs)+ where (ys, zs) = LL.span (eq x) xs+ x = LL.head l+ xs = LL.tail l++{-# INLINE groupBy #-}++-- | @merge@ offers another way to nest iteratees: as a monad stack.+-- This allows for the possibility of interleaving data from multiple+-- streams.+-- +-- > -- print each element from a stream of lines.+-- > logger :: (MonadIO m) => Iteratee [ByteString] m ()+-- > logger = mapM_ (liftIO . putStrLn . B.unpack)+-- >+-- > -- combine alternating lines from two sources+-- > -- To see how this was derived, follow the types from+-- > -- 'ileaveLines logger' and work outwards.+-- > run =<< enumFile 10 "file1" (joinI $ enumLinesBS $+-- > ( enumFile 10 "file2" . joinI . enumLinesBS $ joinI+-- > (ileaveLines logger)) >>= run)+-- > +-- > ileaveLines :: (Functor m, Monad m)+-- > => Enumeratee [ByteString] [ByteString] (Iteratee [ByteString] m)+-- > [ByteString]+-- > ileaveLines = merge (\l1 l2 ->+-- > [B.pack "f1:\n\t" ,l1 ,B.pack "f2:\n\t" ,l2 ]+-- > +-- > +-- +merge ::+ (LL.ListLike s1 el1+ ,LL.ListLike s2 el2+ ,Nullable s1+ ,Nullable s2+ ,Monad m+ ,Functor m)+ => (el1 -> el2 -> b)+ -> Enumeratee s2 b (Iteratee s1 m) a+merge f = convStream $ f <$> lift head <*> head+{-# INLINE merge #-}++-- | A version of merge which operates on chunks instead of elements.+-- +-- mergeByChunks offers more control than 'merge'. 'merge' terminates+-- when the first stream terminates, however mergeByChunks will continue+-- until both streams are exhausted.+-- +-- 'mergeByChunks' guarantees that both chunks passed to the merge function+-- will have the same number of elements, although that number may vary+-- between calls.+mergeByChunks ::+ (Nullable c2, Nullable c1+ ,NullPoint c2, NullPoint c1+ ,LL.ListLike c1 el1, LL.ListLike c2 el2+ ,Functor m, Monad m)+ => (c1 -> c2 -> c3) -- ^ merge function+ -> (c1 -> c3)+ -> (c2 -> c3)+ -> Enumeratee c2 c3 (Iteratee c1 m) a+mergeByChunks f f1 f2 = unfoldConvStream iter (0 :: Int)+ where+ iter 1 = (1,) . f1 <$> lift getChunk+ iter 2 = (2,) . f2 <$> getChunk+ iter _ = do+ ml1 <- lift chunkLength+ ml2 <- chunkLength+ case (ml1, ml2) of+ (Just l1, Just l2) -> do+ let tval = min l1 l2+ c1 <- lift $ takeFromChunk tval+ c2 <- takeFromChunk tval+ return (0, f c1 c2)+ (Just _, Nothing) -> iter 1+ (Nothing, _) -> iter 2+{-# INLINE mergeByChunks #-}++-- ------------------------------------------------------------------------+-- Folds++-- | Left-associative fold.+-- +-- The analogue of @List.foldl@+foldl+ :: (LL.ListLike s el, FLL.FoldableLL s el)+ => (a -> el -> a)+ -> a+ -> Iteratee s m a+foldl f i = liftI (step i)+ where+ step acc (Chunk xs)+ | LL.null xs = liftI (step acc)+ | otherwise = liftI (step $ FLL.foldl f acc xs)+ step acc stream = idone acc stream+{-# INLINE foldl #-}+++-- | Left-associative fold that is strict in the accumulator.+-- This function should be used in preference to 'foldl' whenever possible.+-- +-- The analogue of @List.foldl'@.+foldl'+ :: (LL.ListLike s el, FLL.FoldableLL s el)+ => (a -> el -> a)+ -> a+ -> Iteratee s m a+foldl' f i = liftI (step i)+ where+ step acc (Chunk xs)+ | LL.null xs = liftI (step acc)+ | otherwise = liftI (step $! FLL.foldl' f acc xs)+ step acc stream = idone acc stream+{-# INLINE foldl' #-}++-- | Variant of foldl with no base case. Requires at least one element+-- in the stream.+-- +-- The analogue of @List.foldl1@.+foldl1+ :: (LL.ListLike s el, FLL.FoldableLL s el)+ => (el -> el -> el)+ -> Iteratee s m el+foldl1 f = liftI step+ where+ step (Chunk xs)+ -- After the first chunk, just use regular foldl.+ | LL.null xs = liftI step+ | otherwise = foldl f $ FLL.foldl1 f xs+ step stream = icont step (Just (setEOF stream))+{-# INLINE foldl1 #-}+++-- | Strict variant of 'foldl1'.+foldl1'+ :: (LL.ListLike s el, FLL.FoldableLL s el)+ => (el -> el -> el)+ -> Iteratee s m el+foldl1' f = liftI step+ where+ step (Chunk xs)+ -- After the first chunk, just use regular foldl'.+ | LL.null xs = liftI step+ | otherwise = foldl' f $ FLL.foldl1 f xs+ step stream = icont step (Just (setEOF stream))+{-# INLINE foldl1' #-}+++-- | Sum of a stream.+sum :: (LL.ListLike s el, Num el) => Iteratee s m el+sum = liftI (step 0)+ where+ step acc (Chunk xs)+ | LL.null xs = liftI (step acc)+ | otherwise = liftI (step $! acc + LL.sum xs)+ step acc str = idone acc str+{-# INLINE sum #-}+++-- | Product of a stream.+product :: (LL.ListLike s el, Num el) => Iteratee s m el+product = liftI (step 1)+ where+ step acc (Chunk xs)+ | LL.null xs = liftI (step acc)+ | otherwise = liftI (step $! acc * LL.product xs)+ step acc str = idone acc str+{-# INLINE product #-}+++-- ------------------------------------------------------------------------+-- Zips++-- |Enumerate two iteratees over a single stream simultaneously.+-- Deprecated, use `Data.Iteratee.ListLike.zip` instead.+-- +-- Compare to @zip@.+{-# DEPRECATED enumPair "use Data.Iteratee.ListLike.zip" #-}+enumPair+ :: (Monad m, Nullable s, LL.ListLike s el)+ => Iteratee s m a+ -> Iteratee s m b+ -> Iteratee s m (a, b)+enumPair = zip++-- |Enumerate two iteratees over a single stream simultaneously.+-- +-- Compare to @List.zip@.+zip+ :: (Monad m, Nullable s, LL.ListLike s el)+ => Iteratee s m a+ -> Iteratee s m b+ -> Iteratee s m (a, b)+zip x0 y0 = do+ -- need to check if both iteratees are initially finished. If so,+ -- we don't want to push a chunk which will be dropped+ (a', x') <- lift $ runIter x0 od oc+ (b', y') <- lift $ runIter y0 od oc+ case checkDone a' b' of+ Just (Right (a,b,s)) -> idone (a,b) s -- 's' may be EOF, needs to stay+ Just (Left (Left a)) -> liftM (a,) y'+ Just (Left (Right b)) -> liftM (,b) x'+ Nothing -> liftI (step x' y')+ where+ step x y (Chunk xs) | nullC xs = liftI (step x y)+ step x y (Chunk xs) = do+ (a', x') <- lift $ (\i -> runIter i od oc) =<< enumPure1Chunk xs x+ (b', y') <- lift $ (\i -> runIter i od oc) =<< enumPure1Chunk xs y+ case checkDone a' b' of+ Just (Right (a,b,s)) -> idone (a,b) s+ Just (Left (Left a)) -> liftM (a,) y'+ Just (Left (Right b)) -> liftM (,b) x'+ Nothing -> liftI (step x' y')+ step x y (EOF err) = joinIM $ case err of+ Nothing -> (liftM2.liftM2) (,) (enumEof x) (enumEof y)+ Just e -> (liftM2.liftM2) (,) (enumErr e x) (enumErr e y)++ od a s = return (Just (a, s), idone a s)+ oc k e = return (Nothing , icont k e)++ checkDone r1 r2 = case (r1, r2) of+ (Just (a, s1), Just (b,s2)) -> Just $ Right (a, b, shorter s1 s2)+ (Just (a, _), Nothing) -> Just . Left $ Left a+ (Nothing, Just (b, _)) -> Just . Left $ Right b+ (Nothing, Nothing) -> Nothing++ shorter c1@(Chunk xs) c2@(Chunk ys)+ | LL.length xs < LL.length ys = c1+ | otherwise = c2+ shorter e@(EOF _) _ = e+ shorter _ e@(EOF _) = e+{-# INLINE zip #-}++zip3+ :: (Monad m, Nullable s, LL.ListLike s el)+ => Iteratee s m a -> Iteratee s m b+ -> Iteratee s m c -> Iteratee s m (a, b, c)+zip3 a b c = zip a (zip b c) >>=+ \(r1, (r2, r3)) -> return (r1, r2, r3)+{-# INLINE zip3 #-}++zip4+ :: (Monad m, Nullable s, LL.ListLike s el)+ => Iteratee s m a -> Iteratee s m b+ -> Iteratee s m c -> Iteratee s m d+ -> Iteratee s m (a, b, c, d)+zip4 a b c d = zip a (zip3 b c d) >>=+ \(r1, (r2, r3, r4)) -> return (r1, r2, r3, r4)+{-# INLINE zip4 #-}++zip5+ :: (Monad m, Nullable s, LL.ListLike s el)+ => Iteratee s m a -> Iteratee s m b+ -> Iteratee s m c -> Iteratee s m d+ -> Iteratee s m e -> Iteratee s m (a, b, c, d, e)+zip5 a b c d e = zip a (zip4 b c d e) >>=+ \(r1, (r2, r3, r4, r5)) -> return (r1, r2, r3, r4, r5)+{-# INLINE zip5 #-}++-- | Enumerate over two iteratees in parallel as long as the first iteratee+-- is still consuming input. The second iteratee will be terminated with EOF+-- when the first iteratee has completed. An example use is to determine+-- how many elements an iteratee has consumed:+-- +-- > snd <$> enumWith (dropWhile (<5)) length+-- +-- Compare to @zip@+enumWith+ :: (Monad m, Nullable s, LL.ListLike s el)+ => Iteratee s m a+ -> Iteratee s m b+ -> Iteratee s m (a, b)+enumWith i1 i2 = do+ -- as with zip, first check to see if the initial iteratee is complete,+ -- otherwise data would be dropped.+ -- running the second iteratee as well to prevent a monadic effect mismatch+ -- although I think that would be highly unlikely to happen in common+ -- code+ (a', x') <- lift $ runIter i1 od oc+ (_, y') <- lift $ runIter i2 od oc+ case a' of+ Just (a, s) -> flip idone s =<< lift (liftM (a,) $ run i2)+ Nothing -> go x' y'+ where+ od a s = return (Just (a, s), idone a s)+ oc k e = return (Nothing , icont k e)++ getUsed xs (Chunk ys) = LL.take (LL.length xs - LL.length ys) xs+ getUsed xs (EOF _) = xs++ go x y = liftI step+ where+ step (Chunk xs) | nullC xs = liftI step+ step (Chunk xs) = do+ (a', x') <- lift $ (\i -> runIter i od oc) =<< enumPure1Chunk xs x+ case a' of+ Just (a, s) -> do+ b <- lift $ run =<< enumPure1Chunk (getUsed xs s) y+ idone (a, b) s+ Nothing -> lift (enumPure1Chunk xs y) >>= go x'+ step (EOF err) = joinIM $ case err of+ Nothing -> (liftM2.liftM2) (,) (enumEof x) (enumEof y)+ Just e -> (liftM2.liftM2) (,) (enumErr e x) (enumErr e y)+{-# INLINE enumWith #-}++-- |Enumerate a list of iteratees over a single stream simultaneously+-- and discard the results. This is a different behavior than Prelude's+-- sequence_ which runs iteratees in the list one after the other.+-- +-- Compare to @Prelude.sequence_@.+sequence_+ :: (Monad m, LL.ListLike s el, Nullable s)+ => [Iteratee s m a]+ -> Iteratee s m ()+sequence_ = self+ where+ self is = liftI step+ where+ step (Chunk xs) | LL.null xs = liftI step+ step s@(Chunk _) = do+ -- give a chunk to each iteratee+ is' <- lift $ mapM (enumChunk s) is+ -- filter done iteratees+ (done, notDone) <- lift $ partition fst `liftM` mapM enumCheckIfDone is'+ if Prelude.null notDone+ then idone () <=< remainingStream $ map snd done+ else self $ map snd notDone+ step s@(EOF _) = do+ s' <- remainingStream <=< lift $ mapM (enumChunk s) is+ case s' of+ EOF (Just e) -> throwErr e+ _ -> idone () s'++ -- returns the unconsumed part of the stream; "sequence_ is" consumes as+ -- much of the stream as the iteratee in is that consumes the most; e.g.+ -- sequence_ [I.head, I.last] consumes whole stream+ remainingStream+ :: (Monad m, Nullable s, LL.ListLike s el)+ => [Iteratee s m a] -> Iteratee s m (Stream s)+ remainingStream is = lift $+ return . Prelude.foldl1 shorter <=< mapM (\i -> runIter i od oc) $ is+ where+ od _ s = return s+ oc _ e = return $ case e of+ Nothing -> mempty+ _ -> EOF e++ -- return the shorter one of two streams; errors are propagated with the+ -- priority given to the "left"+ shorter c1@(Chunk xs) c2@(Chunk ys)+ | LL.length xs < LL.length ys = c1+ | otherwise = c2+ shorter (EOF e1 ) (EOF e2 ) = EOF (e1 `mplus` e2)+ shorter e@(EOF _) _ = e+ shorter _ e@(EOF _) = e++-- |Transform an iteratee into one that keeps track of how much data it+-- consumes.+countConsumed :: forall a s el m n.+ (Monad m, LL.ListLike s el, Nullable s, Integral n) =>+ Iteratee s m a+ -> Iteratee s m (a, n)+countConsumed i = go 0 (const i) (Chunk empty)+ where+ go :: n -> (Stream s -> Iteratee s m a) -> Stream s+ -> Iteratee s m (a, n)+ go !n f str@(EOF _) = (, n) `liftM` f str+ go !n f str@(Chunk c) = Iteratee rI+ where+ newLen = n + fromIntegral (LL.length c)+ rI od oc = runIter (f str) onDone onCont+ where+ onDone a str'@(Chunk c') =+ od (a, newLen - fromIntegral (LL.length c')) str'+ onDone a str'@(EOF _) = od (a, n) str'+ onCont f' mExc = oc (go newLen f') mExc+{-# INLINE countConsumed #-}++-- ------------------------------------------------------------------------+-- Enumerators++-- |The pure n-chunk enumerator+-- It passes a given stream of elements to the iteratee in @n@-sized chunks.+enumPureNChunk :: (Monad m, LL.ListLike s el) => s -> Int -> Enumerator s m a+enumPureNChunk str n iter+ | LL.null str = return iter+ | n > 0 = enum' str iter+ | otherwise = error $ "enumPureNChunk called with n==" ++ show n+ where+ enum' str' iter'+ | LL.null str' = return iter'+ | otherwise = let (s1, s2) = LL.splitAt n str'+ on_cont k Nothing = enum' s2 . k $ Chunk s1+ on_cont k e = return $ icont k e+ in runIter iter' idoneM on_cont+{-# INLINE enumPureNChunk #-}++-- | Convert an iteratee to a \"greedy\" version.+--+-- When a chunk is received, repeatedly run the input iteratee+-- until the entire chunk is consumed, then the outputs+-- are combined (via 'mconcat').+--+-- > > let l = [1..5::Int]+-- > > run =<< enumPure1Chunk l (joinI (take 2 stream2list))+-- > [1,2]+-- > > run =<< enumPure1Chunk l (greedy $ joinI (I.take 2 stream2list))+-- > [1,2,3,4,5]+--+-- Note that a greedy iteratee will consume the entire input chunk and force+-- the next chunk before returning a value. A portion of the second chunk may+-- be consumed.+-- +-- 'greedy' may be useful on the first parameter of 'convStream', e.g.+-- +-- > convStream (greedy someIter)+--+-- to create more efficient converters.+greedy ::+ (Monad m, Functor m, LL.ListLike s el', Monoid a) =>+ Iteratee s m a+ -> Iteratee s m a+greedy iter' = liftI (step [] iter')+ where+ step acc iter (Chunk str)+ | LL.null str = liftI (step acc iter)+ | otherwise = joinIM $ do+ i2 <- enumPure1Chunk str iter+ result <- runIter i2 (\a s -> return $ Left (a,s))+ (\k e -> return $ Right (icont k e))+ case result of+ Left (a, Chunk resS)+ | LL.null resS+ || LL.length resS == LL.length str -> return $+ idone (mconcat $ reverse (a:acc)) (Chunk resS)+ Left (a, stream) -> return $ step (a:acc) iter stream+ Right i -> return $ fmap (mconcat . reverse . (:acc)) i+ step acc iter stream = joinIM $+ enumChunk stream (fmap (mconcat . reverse . (:acc)) iter)+{-# INLINE greedy #-}++-- ------------------------------------------------------------------------+-- Monadic functions++-- | Map a monadic function over the elements of the stream and ignore the+-- result.+mapM_+ :: (Monad m, LL.ListLike s el, Nullable s)+ => (el -> m b)+ -> Iteratee s m ()+mapM_ f = liftI step+ where+ step (Chunk xs) | LL.null xs = liftI step+ step (Chunk xs) = lift (LL.mapM_ f xs) >> liftI step+ step s@(EOF _) = idone () s+{-# INLINE mapM_ #-}++-- |The analogue of @Control.Monad.foldM@+foldM+ :: (Monad m, LL.ListLike s b, Nullable s)+ => (a -> b -> m a)+ -> a+ -> Iteratee s m a+foldM f e = liftI step+ where+ step (Chunk xs) | LL.null xs = liftI step+ step (Chunk xs) = do+ x <- lift $ f e (LL.head xs)+ joinIM $ enumPure1Chunk (LL.tail xs) (foldM f x)+ step (EOF _) = return e+{-# INLINE foldM #-}
+ src/Data/Iteratee/PTerm.hs view
@@ -0,0 +1,282 @@+{-# LANGUAGE KindSignatures+ ,RankNTypes+ ,FlexibleContexts+ ,ScopedTypeVariables+ ,BangPatterns+ ,DeriveDataTypeable #-}++-- | Enumeratees - pass terminals variant.+-- +-- Provides enumeratees that pass terminal markers ('EOF') to the inner+-- 'iteratee'.+-- +-- Most enumeratees, upon receipt of @EOF@, will enter a done state and return+-- the inner iteratee without sending @EOF@ to it. This allows for composing+-- enumerators as in:+-- +-- > myEnum extraData i = do+-- > nested <- enumFile "file" (mapChunks unpacker i)+-- > inner <- run nested+-- > enumList extraData inner+-- +-- if @mapChunks unpacker@ sent 'EOF' to the inner iteratee @i@, there would+-- be no way to submit extra data to it after 'run'ing the result from+-- @enumFile@.+-- +-- In certain cases, this is not the desired behavior. Consider:+-- +-- > consumer :: Iteratee String IO ()+-- > consumer = liftI (go 0)+-- > where+-- > go c (Chunk xs) = liftIO (putStr s) >> liftI (go c)+-- > go 10 e = liftIO (putStr "10 loops complete")+-- > >> idone () (Chunk "")+-- > go n e = I.seek 0 >> liftI (go (n+1))+--+-- The @consumer@ iteratee does not complete until after it has received +-- 10 @EOF@s. If you attempt to use it in a standard enumeratee, it will+-- never terminate. When the outer enumeratee is terminated, the inner+-- iteratee will remain in a @cont@ state, but in general there is no longer+-- any valid data for the continuation. The enumeratee itself must pass the+-- EOF marker to the inner iteratee and remain in a cont state until the inner+-- iteratee signals its completion.+-- +-- All enumeratees in this module will pass 'EOF' terminators to the inner+-- iteratees.++module Data.Iteratee.PTerm (+ -- * Nested iteratee combinators+ mapChunksPT+ ,mapChunksMPT+ ,convStreamPT+ ,unfoldConvStreamPT+ ,unfoldConvStreamCheckPT+ -- * ListLike analog functions+ ,breakEPT+ ,takePT+ ,takeUpToPT+ ,takeWhileEPT+ ,mapStreamPT+ ,rigidMapStreamPT+ ,filterPT+)+where++import Prelude hiding (head, drop, dropWhile, take, break, foldl, foldl1, length, filter, sum, product)++import Data.Iteratee.Iteratee+import Data.Iteratee.ListLike (drop)++import qualified Data.ListLike as LL++import Control.Applicative ((<$>))+import Control.Exception+import Control.Monad.Trans.Class++import qualified Data.ByteString as B+import Data.Monoid+import Data.Word (Word8)++-- ---------------------------------------------------+-- The converters show a different way of composing two iteratees:+-- `vertical' rather than `horizontal'++-- | Convert one stream into another with the supplied mapping function.+-- +-- A version of 'mapChunks' that sends 'EOF's to the inner iteratee.+-- +mapChunksPT :: (NullPoint s) => (s -> s') -> Enumeratee s s' m a+mapChunksPT f = eneeCheckIfDonePass (icont . step)+ where+ step k (Chunk xs) = eneeCheckIfDonePass (icont . step) . k . Chunk $ f xs+ step k (EOF mErr) = eneeCheckIfDonePass (icont . step) . k $ EOF mErr+{-# INLINE mapChunksPT #-}++-- | Convert a stream of @s@ to a stream of @s'@ using the supplied function.+-- +-- A version of 'mapChunksM' that sends 'EOF's to the inner iteratee.+mapChunksMPT+ :: (Monad m, NullPoint s, Nullable s)+ => (s -> m s')+ -> Enumeratee s s' m a+mapChunksMPT f = eneeCheckIfDonePass (icont . step)+ where+ step k (Chunk xs) = lift (f xs) >>=+ eneeCheckIfDonePass (icont . step) . k . Chunk+ step k (EOF mErr) = eneeCheckIfDonePass (icont . step) . k $ EOF mErr+{-# INLINE mapChunksMPT #-}++-- |Convert one stream into another, not necessarily in lockstep.+-- +-- A version of 'convStream' that sends 'EOF's to the inner iteratee.+convStreamPT+ :: (Monad m, Nullable s, NullPoint s')+ => Iteratee s m s'+ -> Enumeratee s s' m a+convStreamPT fi = go+ where+ go = eneeCheckIfDonePass check+ check k (Just e) = throwRecoverableErr e (const identity)+ >> go (k $ Chunk empty)+ check k _ = isStreamFinished >>= maybe (step k)+ (\e -> case fromException e of+ Just EofException -> go . k $ EOF Nothing+ Nothing -> go . k . EOF $ Just e)+ step k = fi >>= go . k . Chunk+{-# INLINABLE convStreamPT #-}++-- |The most general stream converter.+-- +-- A version of 'unfoldConvStream' that sends 'EOF's to the inner iteratee.+unfoldConvStreamPT ::+ (Monad m, Nullable s, NullPoint s') =>+ (acc -> Iteratee s m (acc, s'))+ -> acc+ -> Enumeratee s s' m a+unfoldConvStreamPT f acc0 = go acc0+ where+ go acc = eneeCheckIfDonePass (check acc)+ check acc k (Just e) = throwRecoverableErr e (const identity)+ >> go acc (k $ Chunk empty)+ check acc k _ = isStreamFinished >>= maybe (step acc k)+ (\e -> case fromException e of+ Just EofException -> go acc . k $ EOF Nothing+ Nothing -> go acc . k . EOF $ Just e)+ step acc k = f acc >>= \(acc', s') -> go acc' . k $ Chunk s'+{-+ check acc k _ = isStreamFinished >>=+ maybe (step acc k) (idone (liftI k) . EOF . Just)+ step acc k = f acc >>= \(acc', s') ->+ go acc' . k . Chunk $ s'+-}++-- | A version of 'unfoldConvStreamCheck' that sends 'EOF's+-- to the inner iteratee.+unfoldConvStreamCheckPT+ :: (Monad m, Nullable elo)+ => (((Stream eli -> Iteratee eli m a)+ -> Maybe SomeException+ -> Iteratee elo m (Iteratee eli m a)+ )+ -> Enumeratee elo eli m a+ )+ -> (acc -> Iteratee elo m (acc, eli))+ -> acc+ -> Enumeratee elo eli m a+unfoldConvStreamCheckPT checkDone f acc0 = checkDone (check acc0)+ where+ check acc k mX = step acc k mX+ step acc k Nothing = f acc >>= \(acc', s') ->+ (checkDone (check acc') . k $ Chunk s')+ step acc k (Just ex) = throwRecoverableErr ex $ \str' ->+ let i = f acc >>= \(acc', s') ->+ (checkDone (check acc') . k $ Chunk s')+ in joinIM $ enumChunk str' i+{-# INLINABLE unfoldConvStreamCheckPT #-}++-- -------------------------------------+-- ListLike variants++-- | A variant of 'Data.Iteratee.ListLike.breakE' that passes 'EOF's.+breakEPT+ :: (LL.ListLike s el, NullPoint s)+ => (el -> Bool)+ -> Enumeratee s s m a+breakEPT cpred = eneeCheckIfDonePass (icont . step)+ where+ step k (Chunk s)+ | LL.null s = liftI (step k)+ | otherwise = case LL.break cpred s of+ (str', tail')+ | LL.null tail' -> eneeCheckIfDonePass (icont . step) . k $ Chunk str'+ | otherwise -> idone (k $ Chunk str') (Chunk tail')+ step k stream = idone (k stream) stream+{-# INLINE breakEPT #-}++-- | A variant of 'Data.Iteratee.ListLike.take' that passes 'EOF's.+takePT ::+ (Monad m, Nullable s, LL.ListLike s el)+ => Int -- ^ number of elements to consume+ -> Enumeratee s s m a+takePT n' iter+ | n' <= 0 = return iter+ | otherwise = Iteratee $ \od oc -> runIter iter (on_done od oc) (on_cont od oc)+ where+ on_done od oc x _ = runIter (drop n' >> return (return x)) od oc+ on_cont od oc k Nothing = if n' == 0 then od (liftI k) (Chunk mempty)+ else runIter (liftI (step n' k)) od oc+ on_cont od oc _ (Just e) = runIter (drop n' >> throwErr e) od oc+ step n k (Chunk str)+ | LL.null str = liftI (step n k)+ | LL.length str <= n = takePT (n - LL.length str) $ k (Chunk str)+ | otherwise = idone (k (Chunk s1)) (Chunk s2)+ where (s1, s2) = LL.splitAt n str+ step _n k stream = idone (k stream) stream+{-# INLINE takePT #-}++-- | A variant of 'Data.Iteratee.ListLike.takeUpTo' that passes 'EOF's.+takeUpToPT :: (Monad m, Nullable s, LL.ListLike s el) => Int -> Enumeratee s s m a+takeUpToPT i iter+ | i <= 0 = idone iter (Chunk empty)+ | otherwise = Iteratee $ \od oc ->+ runIter iter (onDone od oc) (onCont od oc)+ where+ onDone od oc x str = runIter (idone (return x) str) od oc+ onCont od oc k Nothing = if i == 0 then od (liftI k) (Chunk mempty)+ else runIter (liftI (step i k)) od oc+ onCont od oc _ (Just e) = runIter (throwErr e) od oc+ step n k (Chunk str)+ | LL.null str = liftI (step n k)+ | LL.length str < n = takeUpToPT (n - LL.length str) $ k (Chunk str)+ | otherwise =+ -- check to see if the inner iteratee has completed, and if so,+ -- grab any remaining stream to put it in the outer iteratee.+ -- the outer iteratee is always complete at this stage, although+ -- the inner may not be.+ let (s1, s2) = LL.splitAt n str+ in Iteratee $ \od' _ -> do+ res <- runIter (k (Chunk s1)) (\a s -> return $ Left (a, s))+ (\k' e -> return $ Right (k',e))+ case res of+ Left (a,Chunk s1') -> od' (return a)+ (Chunk $ s1' `LL.append` s2)+ Left (a,s') -> od' (idone a s') (Chunk s2)+ Right (k',e) -> od' (icont k' e) (Chunk s2)+ step _ k stream = idone (k stream) stream+{-# INLINE takeUpToPT #-}++-- | A variant of 'Data.Iteratee.ListLike.takeWhileE' that passes 'EOF's.+takeWhileEPT+ :: (LL.ListLike s el, NullPoint s)+ => (el -> Bool)+ -> Enumeratee s s m a+takeWhileEPT = breakEPT . (not .)+{-# INLINEABLE takeWhileEPT #-}++-- | A variant of 'Data.Iteratee.ListLike.mapStream' that passes 'EOF's.+mapStreamPT+ :: (LL.ListLike (s el) el+ ,LL.ListLike (s el') el'+ ,NullPoint (s el)+ ,LooseMap s el el')+ => (el -> el')+ -> Enumeratee (s el) (s el') m a+mapStreamPT f = mapChunksPT (lMap f)+{-# SPECIALIZE mapStreamPT :: (el -> el') -> Enumeratee [el] [el'] m a #-}++-- | A variant of 'Data.Iteratee.ListLike.rigidMapStream' that passes 'EOF's.+rigidMapStreamPT+ :: (LL.ListLike s el, NullPoint s)+ => (el -> el)+ -> Enumeratee s s m a+rigidMapStreamPT f = mapChunksPT (LL.rigidMap f)+{-# SPECIALIZE rigidMapStreamPT :: (el -> el) -> Enumeratee [el] [el] m a #-}+{-# SPECIALIZE rigidMapStreamPT :: (Word8 -> Word8) -> Enumeratee B.ByteString B.ByteString m a #-}++-- | A variant of 'Data.Iteratee.ListLike.filter' that passes 'EOF's.+filterPT+ :: (Monad m, Functor m, Nullable s, LL.ListLike s el)+ => (el -> Bool)+ -> Enumeratee s s m a+filterPT p = convStreamPT (LL.filter p <$> getChunk)+{-# INLINE filterPT #-}
+ src/Data/Iteratee/Parallel.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE NoMonomorphismRestriction, BangPatterns #-}++module Data.Iteratee.Parallel (+ psequence_+ -- ,psequence+ ,parE+ ,parI+ ,liftParI+ ,mapReduce+)++where++import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Data.Iteratee as I hiding (mapM_, zip, filter)+import qualified Data.ListLike as LL++import Data.Monoid++import Control.Concurrent+import Control.Parallel+import Control.Monad++-- | Transform usual Iteratee into parallel composable one, introducing+-- one step extra delay.+-- +-- Ex - time spent in Enumerator working on x'th packet+-- Ix - time spent in Iteratee working on x'th packet+-- z - last packet, y = (z-1)'th packet+-- +-- regular Iteratee: E0 - I0, E1 - I1, E2 - I2 .. Ez -> Iz+-- parallel Iteratee: E0, E1, E2, .. Ez+-- \_ I0\_ I1\_ .. Iy\__ Iz+-- +parI :: (Nullable s, Monoid s) => Iteratee s IO a -> Iteratee s IO a+parI = liftI . firstStep+ where+ -- first step, here we fork separete thread for the next chain and at the+ -- same time ask for more date from the previous chain+ firstStep iter chunk = do+ var <- liftIO newEmptyMVar+ _ <- sideStep var chunk iter+ liftI $ go var++ -- somewhere in the middle, we are getting iteratee from previous step,+ -- feeding it with some new data, asking for more data and starting+ -- more processing in separete thread+ go var chunk@(Chunk _) = do+ iter <- liftIO $ takeMVar var+ _ <- sideStep var chunk iter+ liftI $ go var++ -- final step - no more data, so we need to inform our consumer about it+ go var e = do+ iter <- liftIO $ takeMVar var+ join . lift $ enumChunk e iter++ -- forks away from the main computation, return results via MVar+ sideStep var chunk iter = liftIO . forkIO $ runIter iter onDone onCont+ where+ onDone a s = putMVar var $ idone a s+ onCont k _ = runIter (k chunk) onDone onFina+ onFina k e = putMVar var $ icont k e++-- | Transform an Enumeratee into a parallel composable one, introducing+-- one step extra delay, see 'parI'.+parE ::+ (Nullable s1, Nullable s2, Monoid s1)+ => Enumeratee s1 s2 IO r+ -> Enumeratee s1 s2 IO r+parE outer inner = parI (outer inner)++-- | Enumerate a list of iteratees over a single stream simultaneously+-- and discard the results. Each iteratee runs in a separate forkIO thread,+-- passes all errors from iteratees up.+psequence_ ::+ (LL.ListLike s el, Nullable s)+ => [Iteratee s IO a]+ -> Iteratee s IO ()+psequence_ = I.sequence_ . map parI+++{-+-- | Enumerate a list of iteratees over a single stream simultaneously+-- and keeps the results. Each iteratee runs in a separete forkIO thread, passes all+-- errors from iteratees up.+psequence = I.sequence . map parI+-}++-- | A variant of 'parI' with the parallelized iteratee lifted into an+-- arbitrary MonadIO.+liftParI ::+ (Nullable s, Monoid s, MonadIO m)+ => Iteratee s IO a+ -> Iteratee s m a+liftParI = ilift liftIO . parI++-- | Perform a parallel map/reduce. The `bufsize` parameter controls+-- the maximum number of chunks to read at one time. A larger bufsize+-- allows for greater parallelism, but will require more memory.+--+-- Implementation of `sum`+--+-- > sum :: (Monad m, LL.ListLike s, Nullable s) => Iteratee s m Int64+-- > sum = getSum <$> mapReduce 4 (Sum . LL.sum)+mapReduce ::+ (Monad m, Nullable s, Monoid b)+ => Int -- ^ maximum number of chunks to read+ -> (s -> b) -- ^ map function+ -> Iteratee s m b+mapReduce bufsize f = liftI (step (0, []))+ where+ step a@(!buf,acc) (Chunk xs)+ | nullC xs = liftI (step a)+ | buf >= bufsize =+ let acc' = mconcat acc+ b' = f xs+ in b' `par` acc' `pseq` liftI (step (0,[b' `mappend` acc']))+ | otherwise =+ let b' = f xs+ in b' `par` liftI (step (succ buf,b':acc))+ step (_,acc) s@(EOF Nothing) =+ idone (mconcat acc) s+ step acc (EOF (Just err)) =+ throwRecoverableErr err (step acc)+
− src/Data/Iteratee/WrappedByteString.hs
@@ -1,110 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, BangPatterns #-}--module Data.Iteratee.WrappedByteString (- WrappedByteString (..)-)--where--import qualified Data.Iteratee.Base.StreamChunk as SC-import qualified Data.ByteString as BW-import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Internal as BBase-import qualified Data.ListLike as LL-import Data.Word-import Data.Monoid-import Foreign.Ptr-import Control.Monad---- |Wrap a Data.ByteString ByteString-newtype WrappedByteString a = WrapBS { unWrap :: BBase.ByteString }--instance Monoid (WrappedByteString Word8) where- mempty = WrapBS BW.empty- mappend a1 a2 = WrapBS (BW.append (unWrap a1) (unWrap a2))--instance LL.FoldableLL (WrappedByteString Word8) Word8 where- foldl f z = BW.foldl f z . unWrap- foldr f z = BW.foldr f z . unWrap---- Thanks to Echo Nolan for indicating that the bytestring must copy--- data to a new ptr to preserve referential transparency.-instance SC.ReadableChunk WrappedByteString Word8 where- readFromPtr buf l = let csl = (castPtr buf, l) in- liftM WrapBS $ BW.packCStringLen csl--instance SC.ReadableChunk WrappedByteString Char where- readFromPtr buf l = let csl = (castPtr buf, l) in- liftM WrapBS $ BC.packCStringLen csl--instance LL.ListLike (WrappedByteString Word8) Word8 where- length = BW.length . unWrap- null = BW.null . unWrap- singleton = WrapBS . BW.singleton- cons a = WrapBS . BW.cons a . unWrap- head = BW.head . unWrap- tail = WrapBS . BW.tail . unWrap- findIndex p = BW.findIndex p . unWrap- splitAt i s = let (a1, a2) = BW.splitAt i $ unWrap s- in (WrapBS a1, WrapBS a2)- dropWhile p = WrapBS . BW.dropWhile p . unWrap- fromList = WrapBS . BW.pack- toList = BW.unpack . unWrap- rigidMap f = WrapBS . BW.map f . unWrap--instance SC.StreamChunk WrappedByteString Word8 where- cMap = bwmap--bwmap :: (SC.StreamChunk s' el') =>- (Word8 -> el')- -> WrappedByteString Word8- -> s' el'-bwmap f xs = step xs- where- step bs- | LL.null bs = mempty- | True = f (LL.head bs) `LL.cons` step (LL.tail bs)---- Now the Char instance--instance Monoid (WrappedByteString Char) where- mempty = WrapBS BW.empty- mappend a1 a2 = WrapBS (BW.append (unWrap a1) (unWrap a2))--instance LL.FoldableLL (WrappedByteString Char) Char where- foldl f z = BC.foldl f z . unWrap- foldr f z = BC.foldr f z . unWrap--instance LL.ListLike (WrappedByteString Char) Char where- length = BC.length . unWrap- null = BC.null . unWrap- singleton = WrapBS . BC.singleton- cons a = WrapBS . BC.cons a . unWrap- head = BC.head . unWrap- tail = WrapBS . BC.tail . unWrap- findIndex p = BC.findIndex p . unWrap- splitAt i s = let (a1, a2) = BC.splitAt i $ unWrap s- in (WrapBS a1, WrapBS a2)- dropWhile p = WrapBS . BC.dropWhile p . unWrap- fromList = WrapBS . BC.pack- toList = BC.unpack . unWrap- rigidMap f = WrapBS . BC.map f . unWrap--instance LL.StringLike (WrappedByteString Char) where- toString = BC.unpack . unWrap- fromString = WrapBS . BC.pack- lines = LL.fromList . map WrapBS . BC.lines . unWrap- words = LL.fromList . map WrapBS . BC.words . unWrap--instance SC.StreamChunk WrappedByteString Char where- cMap = bcmap--bcmap :: (SC.StreamChunk s' el') =>- (Char -> el')- -> WrappedByteString Char- -> s' el'-bcmap f xs = step xs- where- step bs- | LL.null bs = mempty- | True = f (LL.head bs) `LL.cons` step (LL.tail bs)
+ src/Data/NullPoint.hs view
@@ -0,0 +1,27 @@+-- |NullPoint:+-- Pointed types (usually containers) that can be empty.+-- Corresponds to Data.Monoid.mempty++module Data.NullPoint (+ -- * Classes+ NullPoint (..)+)+where++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L++-- ----------------------------------------------+-- |NullPoint class. Containers that have a null representation, corresponding+-- to Data.Monoid.mempty.+class NullPoint c where+ empty :: c++instance NullPoint [a] where+ empty = []++instance NullPoint B.ByteString where+ empty = B.empty++instance NullPoint L.ByteString where+ empty = L.empty
+ src/Data/Nullable.hs view
@@ -0,0 +1,28 @@+-- |Nullable:+-- test if a type (container) is null.++module Data.Nullable (+ -- * Classes+ Nullable (..)+)+where++import Data.NullPoint+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+++-- ----------------------------------------------+-- |Nullable container class+class NullPoint c => Nullable c where+ nullC :: c -> Bool++instance Nullable [a] where+ nullC [] = True+ nullC _ = False++instance Nullable B.ByteString where+ nullC = B.null++instance Nullable L.ByteString where+ nullC = L.null
tests/QCUtils.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances #-} module QCUtils where @@ -7,35 +7,47 @@ import Test.QuickCheck.Gen import Data.Iteratee+import Data.Iteratee.Iteratee import qualified Data.Iteratee as I-import Data.Iteratee.Base.StreamChunk (StreamChunk)+import qualified Data.ListLike as LL import Data.Functor.Identity +import Control.Applicative+import Control.Exception+ -- Show instance-instance (Show a, StreamChunk s el) => Show (IterateeG s el Identity a) where+instance (Show a, LL.ListLike s el) => Show (Iteratee s Identity a) where show = (++) "<<Iteratee>> " . show . runIdentity . run -- Arbitrary instances -instance Arbitrary ErrMsg where- arbitrary = do- err <- arbitrary- n <- arbitrary :: Gen Int- elements [Err err, Seek (fromIntegral n)]--instance Arbitrary (c el) => Arbitrary (StreamG c el) where+instance Arbitrary c => Arbitrary (Stream c) where arbitrary = do err <- arbitrary xs <- arbitrary elements [EOF err, Chunk xs] -instance (Num a, Ord a, Arbitrary a, Monad m) => Arbitrary (IterateeG [] a m [a]) where+tE :: Exception e => e -> SomeException+tE = toException++instance Arbitrary SomeException where arbitrary = do+ str <- arbitrary+ off <- fromInteger <$> (arbitrary :: Gen Integer)+ elements [tE DivergentException, tE (SeekException off),+ tE EofException, iterStrExc str]++instance (Num a, Ord a, Arbitrary a, Monad m) => Arbitrary (Iteratee [a] m [a]) where+ arbitrary = do n <- suchThat arbitrary (>0) ns <- arbitrary elements [ I.drop n >> stream2list+ ,I.drop n >> return ns ,I.break (< 5) ,I.heads ns >> stream2list ,I.peek >> stream2list+ ,I.peek >> return ns+ ,I.identity >> return []+ ,I.identity >> return ns ]
tests/testIteratee.hs view
@@ -1,5 +1,5 @@ {-# OPTIONS_GHC -O #-}-{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE NoMonomorphismRestriction, ViewPatterns, TupleSections #-} import Prelude as P @@ -7,46 +7,44 @@ import Test.Framework (defaultMain, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit import Test.QuickCheck -import Data.Iteratee hiding (head, break)+import Data.Iteratee hiding (head, break) import qualified Data.Iteratee.Char as IC import qualified Data.Iteratee as Iter-import qualified Data.Iteratee.Base.StreamChunk as SC-import Data.Functor.Identity-import Data.Monoid+import Data.Functor.Identity+import qualified Data.List as List (groupBy, unfoldr)+import Data.Monoid import qualified Data.ListLike as LL -import Text.Printf (printf)-import System.Environment (getArgs)+import Control.Monad as CM+import Control.Monad.Writer+import Control.Exception (SomeException) instance Show (a -> b) where show _ = "<<function>>" -- ------------------------------------------------ StreamG instances+-- Stream instances -type ST = StreamG [] Int+type ST = Stream [Int] prop_eq str = str == str where types = str :: ST -prop_mempty = mempty == (Chunk [] :: StreamG [] Int)+prop_mempty = mempty == (Chunk [] :: Stream [Int]) prop_mappend str1 str2 | isChunk str1 && isChunk str2 = str1 `mappend` str2 == Chunk (chunkData str1 ++ chunkData str2) prop_mappend str1 str2 = isEOF $ str1 `mappend` str2 where types = (str1 :: ST, str2 :: ST) -prop_functor str@(EOF _) f = isEOF $ fmap f str-prop_functor str@(Chunk xs) f = fmap f str == Chunk (fmap f xs)- where types = (str :: ST, f :: Int -> Integer)- prop_mappend2 str = str `mappend` mempty == mempty `mappend` str where types = str :: ST - isChunk (Chunk _) = True isChunk (EOF _) = False @@ -58,8 +56,8 @@ -- --------------------------------------------- -- Iteratee instances -runner0 = runIdentity . Iter.run runner1 = runIdentity . Iter.run . runIdentity+enumSpecial xs n = enumPure1Chunk LL.empty >=> enumPureNChunk xs n prop_iterFmap xs f a = runner1 (enumPure1Chunk xs (fmap f $ return a)) == runner1 (enumPure1Chunk xs (return $ f a))@@ -69,15 +67,15 @@ == f (runner1 (enumPure1Chunk xs i)) where types = (xs :: [Int], i :: I, f :: [Int] -> [Int]) -prop_iterMonad1 xs a f = runner1 (enumPureNChunk xs 1 (return a >>= f))+prop_iterMonad1 xs a f = runner1 (enumSpecial xs 1 (return a >>= f)) == runner1 (enumPure1Chunk xs (f a)) where types = (xs :: [Int], a :: Int, f :: Int -> I) -prop_iterMonad2 m xs = runner1 (enumPureNChunk xs 1 (m >>= return))+prop_iterMonad2 m xs = runner1 (enumSpecial xs 1 (m >>= return)) == runner1 (enumPure1Chunk xs m) where types = (xs :: [Int], m :: I) -prop_iterMonad3 m f g xs = runner1 (enumPureNChunk xs 1 ((m >>= f) >>= g))+prop_iterMonad3 m f g xs = runner1 (enumSpecial xs 1 ((m >>= f) >>= g)) == runner1 (enumPure1Chunk xs (m >>= (\x -> f x >>= g))) where types = (xs :: [Int], m :: I, f :: [Int] -> I, g :: [Int] -> I) @@ -87,7 +85,7 @@ prop_list xs = runner1 (enumPure1Chunk xs stream2list) == xs where types = xs :: [Int] -prop_clist xs n = n > 0 ==> runner1 (enumPureNChunk xs n stream2list) == xs+prop_clist xs n = n > 0 ==> runner1 (enumSpecial xs n stream2list) == xs where types = xs :: [Int] prop_break f xs = runner1 (enumPure1Chunk xs (Iter.break f)) == fst (break f xs)@@ -96,15 +94,28 @@ prop_break2 f xs = runner1 (enumPure1Chunk xs (Iter.break f >> stream2list)) == snd (break f xs) where types = xs :: [Int] +prop_breakE f xs = runner1 (enumPure1Chunk xs (joinI $ Iter.breakE f stream2stream)) == fst (break f xs)+ where types = xs :: [Int]++prop_breakE2 f xs = runner1 (enumPure1Chunk xs (joinI (Iter.breakE f stream2stream) >> stream2list)) == snd (break f xs)+ where types = xs :: [Int]++ prop_head xs = P.length xs > 0 ==> runner1 (enumPure1Chunk xs Iter.head) == head xs where types = xs :: [Int] prop_head2 xs = P.length xs > 0 ==> runner1 (enumPure1Chunk xs (Iter.head >> stream2list)) == tail xs where types = xs :: [Int] -prop_heads xs = runner1 (enumPure1Chunk xs $ heads xs) == P.length xs+prop_tryhead xs = case xs of+ [] -> runner1 (enumPure1Chunk xs tryHead) == Nothing+ _ -> runner1 (enumPure1Chunk xs tryHead) == Just (P.head xs) where types = xs :: [Int] +prop_heads xs n = n > 0 ==>+ runner1 (enumSpecial xs n $ heads xs) == P.length xs+ where types = xs :: [Int]+ prop_heads2 xs = runner1 (enumPure1Chunk xs $ heads [] >>= \c -> stream2list >>= \s -> return (c,s)) == (0, xs)@@ -122,35 +133,78 @@ prop_skip xs = runner1 (enumPure1Chunk xs (skipToEof >> stream2list)) == [] where types = xs :: [Int] +prop_last1 xs = P.length xs > 0 ==>+ runner1 (enumPure1Chunk xs (Iter.last)) == P.last xs+ where types = xs :: [Int]++prop_last2 xs = P.length xs > 0 ==>+ runner1 (enumPure1Chunk xs (Iter.last >> Iter.peek)) == Nothing+ where types = xs :: [Int]++prop_drop xs n k = (n > 0 && k >= 0) ==>+ runner1 (enumSpecial xs n (Iter.drop k >> stream2list)) == P.drop k xs+ where types = xs :: [Int]++prop_dropWhile f xs =+ runner1 (enumPure1Chunk xs (Iter.dropWhile f >> stream2list))+ == P.dropWhile f xs+ where types = (xs :: [Int], f :: Int -> Bool)++prop_length xs = runner1 (enumPure1Chunk xs Iter.length) == P.length xs+ where types = xs :: [Int]++-- length 0 is an odd case. enumPureNChunk skips null inputs, returning+-- the original iteratee, which is then given to `enumEof` by `run`.+-- This is different from enumPure1Chunk, which will provide a null chunk+-- to the iteratee.+-- +-- not certain ATM which should be correct...+prop_chunkLength xs n = n > 0 ==>+ runner1 (enumPureNChunk xs n (liftM2 (,) chunkLength stream2list))+ == case P.length xs of+ 0 -> (Nothing, xs)+ xl | xl >= n -> (Just n, xs)+ | otherwise -> (Just (P.length xs), xs)+ where types = xs :: [Int]++prop_chunkLength2 xs =+ runner1 ((enumEof >=> enumPure1Chunk xs) chunkLength) == Nothing+ where types = xs :: [Int]++prop_takeFromChunk xs n k = n > 0 ==>+ runner1 (enumPureNChunk xs n (liftM2 (,) (takeFromChunk k) stream2list))+ == if k > n then splitAt n xs else splitAt k xs+ where types = xs :: [Int]+ -- --------------------------------------------- -- Simple enumerator tests -type I = IterateeG [] Int Identity [Int]+type I = Iteratee [Int] Identity [Int] prop_enumChunks n xs i = n > 0 ==>- runner1 (enumPure1Chunk xs i) == runner1 (enumPureNChunk xs n i)+ runner1 (enumPure1Chunk xs i) == runner1 (enumSpecial xs n i) where types = (n :: Int, xs :: [Int], i :: I) prop_app1 xs ys i = runner1 (enumPure1Chunk ys (joinIM $ enumPure1Chunk xs i)) == runner1 (enumPure1Chunk (xs ++ ys) i) where types = (xs :: [Int], ys :: [Int], i :: I) -prop_app2 xs ys = runner1 ((enumPure1Chunk xs >. enumPure1Chunk ys) stream2list)+prop_app2 xs ys = runner1 ((enumPure1Chunk xs >>> enumPure1Chunk ys) stream2list) == runner1 (enumPure1Chunk (xs ++ ys) stream2list) where types = (xs :: [Int], ys :: [Int]) -prop_app3 xs ys i = runner1 ((enumPure1Chunk xs >. enumPure1Chunk ys) i)+prop_app3 xs ys i = runner1 ((enumPure1Chunk xs >>> enumPure1Chunk ys) i) == runner1 (enumPure1Chunk (xs ++ ys) i) where types = (xs :: [Int], ys :: [Int], i :: I) prop_eof xs ys i = runner1 (enumPure1Chunk ys $ runIdentity $- (enumPure1Chunk xs >. enumEof) i)+ (enumPure1Chunk xs >>> enumEof) i) == runner1 (enumPure1Chunk xs i) where types = (xs :: [Int], ys :: [Int], i :: I) -prop_isFinished = runner1 (enumEof (isFinished :: IterateeG [] Int Identity (Maybe ErrMsg))) == Just (Err "EOF")+prop_isFinished = runner1 (enumEof (isFinished :: Iteratee [Int] Identity Bool)) == True -prop_isFinished2 = runner1 (enumErr "Error" (isFinished :: IterateeG [] Int Identity (Maybe ErrMsg))) == Just (Err "Error")+prop_isFinished2 = runner1 (enumErr (iterStrExc "Error") (isFinished :: Iteratee [Int] Identity Bool)) == True prop_null xs i = runner1 (enumPure1Chunk xs =<< enumPure1Chunk [] i) == runner1 (enumPure1Chunk xs i)@@ -160,7 +214,41 @@ runner1 (enumPure1Chunk xs =<< enumPure1Chunk [] Iter.head) == runner1 (enumPure1Chunk xs Iter.head) where types = xs :: [Int]++prop_enumList xs i =+ not (P.null xs) ==>+ runner1 (enumList (replicate 100 xs) i)+ == runner1 (enumPure1Chunk (concat $ replicate 100 xs) i)+ where types = (xs :: [Int], i :: I)++prop_enumCheckIfDone xs i =+ runner1 (enumPure1Chunk xs (lift (enumCheckIfDone i) >>= snd))+ == runner1 (enumPure1Chunk xs i)+ where types = (xs :: [Int], i :: I)+ -- ---------------------------------------------+-- Enumerator Combinators++prop_enumWith xs f n = n > 0 ==> runner1 (enumSpecial xs n $ fmap fst $ enumWith (Iter.dropWhile f) (stream2list))+ == runner1 (enumSpecial xs n $ Iter.dropWhile f)+ where types = (xs :: [Int])++prop_enumWith2 xs f n = n > 0 ==> runner1 (enumSpecial xs n $ enumWith (Iter.dropWhile f) (stream2list) >> stream2list)+ == runner1 (enumSpecial xs n $ Iter.dropWhile f >> stream2list)+ where types = (xs :: [Int])++prop_enumWith3 xs i n =+ n > 0+ ==> runner1 (enumSpecial xs n $ enumWith i stream2list >> stream2list)+ == runner1 (enumSpecial xs n (i >> stream2list))+ where types = (xs :: [Int], i :: I)++prop_countConsumed (Positive (min (2^10) -> n)) (Positive (min (2^20) -> a)) (Positive k) =+ runner1 (enumPureNChunk [1..] n iter) == (a, a)+ where+ iter = countConsumed . joinI $ (takeUpTo (a + k) ><> Iter.take a) Iter.last++-- --------------------------------------------- -- Nested Iteratees -- take, mapStream, convStream, and takeR@@ -172,7 +260,7 @@ where types = (i :: I, xs :: [Int]) prop_mapStream2 xs n i = n > 0 ==>- runner2 (enumPureNChunk xs n $ mapStream id i)+ runner2 (enumSpecial xs n $ mapStream id i) == runner1 (enumPure1Chunk xs i) where types = (i :: I, xs :: [Int]) @@ -181,15 +269,41 @@ == runner1 (enumPure1Chunk xs i) where types = (i :: I, xs :: [Int]) +prop_rigidMapStream xs n f = n > 0 ==>+ runner2 (enumSpecial xs n $ rigidMapStream f stream2list) == map f xs+ where types = (xs :: [Int]) -convId :: (SC.StreamChunk s el, Monad m) => IterateeG s el m (Maybe (s el))-convId = IterateeG (\str -> case str of- s@(Chunk xs) | LL.null xs -> return $ Cont convId Nothing- s@(Chunk xs) -> return $ Done (Just xs) (Chunk mempty)- s@(EOF e) -> return $ Done Nothing (EOF e)+prop_foldl xs n f x0 = n > 0 ==>+ runner1 (enumSpecial xs n (Iter.foldl f x0)) == P.foldl f x0 xs+ where types = (xs :: [Int], x0 :: Int)++prop_foldl' xs n f x0 = n > 0 ==>+ runner1 (enumSpecial xs n (Iter.foldl' f x0)) == LL.foldl' f x0 xs+ where types = (xs :: [Int], x0 :: Int)++prop_foldl1 xs n f = (n > 0 && not (null xs)) ==>+ runner1 (enumSpecial xs n (Iter.foldl1 f)) == P.foldl1 f xs+ where types = (xs :: [Int])++prop_foldl1' xs n f = (n > 0 && not (null xs)) ==>+ runner1 (enumSpecial xs n (Iter.foldl1' f)) == P.foldl1 f xs+ where types = (xs :: [Int])++prop_sum xs n = n > 0 ==> runner1 (enumSpecial xs n Iter.sum) == P.sum xs+ where types = (xs :: [Int])++prop_product xs n = n > 0 ==>+ runner1 (enumSpecial xs n Iter.product) == P.product xs+ where types = (xs :: [Int])++convId :: (LL.ListLike s el, Monad m) => Iteratee s m s+convId = liftI (\str -> case str of+ s@(Chunk xs) | LL.null xs -> convId+ s@(Chunk xs) -> idone xs (Chunk mempty)+ s@(EOF e) -> idone mempty (EOF e) ) -prop_convId xs = runner1 (enumPure1Chunk xs convId) == Just xs+prop_convId xs = runner1 (enumPure1Chunk xs convId) == xs where types = xs :: [Int] prop_convstream xs i = P.length xs > 0 ==>@@ -217,12 +331,149 @@ == runner1 (enumPure1Chunk (P.take n xs) peek) where types = xs :: [Int] -prop_takeR xs n = n >= 0 ==>+prop_takeUpTo xs n = n >= 0 ==> runner2 (enumPure1Chunk xs $ Iter.take n stream2list)- == runner2 (enumPure1Chunk xs $ takeR n stream2list)+ == runner2 (enumPure1Chunk xs $ takeUpTo n stream2list) where types = xs :: [Int] +prop_takeUpTo2 xs n = n >= 0 ==>+ runner2 (enumPure1Chunk xs (takeUpTo n identity)) == ()+ where types = xs :: [Int]++-- check for final stream state+prop_takeUpTo3 xs n d t = n > 0 ==>+ runner1 (enumPureNChunk xs n (joinI (takeUpTo t (Iter.drop d)) >> stream2list))+ == P.drop (min t d) xs+ where types = xs :: [Int]++prop_takeWhile xs n f = n > 0 ==>+ runner1 (enumSpecial xs n (liftM2 (,) (Iter.takeWhile f) stream2list))+ == (P.takeWhile f xs, P.dropWhile f xs)+ where types = xs :: [Int]++prop_filter xs n f = n > 0 ==>+ runner2 (enumSpecial xs n (Iter.filter f stream2list)) == P.filter f xs+ where types = xs :: [Int]++prop_group xs n = n > 0 ==>+ runner2 (enumPure1Chunk xs $ Iter.group n stream2list)+ == runner1 (enumPure1Chunk groups stream2list)+ where types = xs :: [Int]+ groups :: [[Int]]+ groups = List.unfoldr groupOne xs+ where groupOne [] = Nothing+ groupOne elts@(_:_) = Just . splitAt n $ elts+ +prop_groupBy xs = forAll (choose (2,5)) $ \m ->+ let pred z1 z2 = (z1 `mod` m == z2 `mod` m)+ in runner2 (enumPure1Chunk xs $ Iter.groupBy pred stream2list)+ == runner1 (enumPure1Chunk (List.groupBy pred xs) stream2list)+ where types = xs :: [Int]++prop_mapChunksM xs n = n > 0 ==>+ runWriter ((enumSpecial xs n (joinI $ Iter.mapChunksM f stream2list)) >>= run)+ == (xs, Sum (P.length xs))+ where f ck = tell (Sum $ P.length ck) >> return ck+ types = xs :: [Int]+{-+prop_mapjoin xs i =+ runIdentity (run (joinI . runIdentity $ enumPure1Chunk xs $ mapStream id i))+ == runner1 (enumPure1Chunk xs i)+ where types = (i :: I, xs :: [Int])+-}++prop_mapChunksM_ xs n = n > 0 ==>+ snd (runWriter ((enumSpecial xs n (Iter.mapChunksM_ f)) >>= run))+ == Sum (P.length xs)+ where f ck = tell (Sum $ P.length ck)+ types = xs :: [Int]++prop_mapM_ xs n = n > 0 ==>+ runWriter ((enumSpecial xs n (Iter.mapM_ f)) >>= run)+ == runWriter (CM.mapM_ f xs)+ where f = const $ tell (Sum 1)+ types = xs :: [Int]++prop_foldChunksM xs x0 n = n > 0 ==>+ runWriter ((enumSpecial xs n (Iter.foldChunksM f x0)) >>= run)+ == runWriter (f x0 xs)+ where f acc ck = CM.foldM f' acc ck+ f' acc el = tell (Sum 1) >> return (acc+el)+ types = xs :: [Int]++prop_foldM xs x0 n = n > 0 ==>+ runWriter ((enumSpecial xs n (Iter.foldM f x0)) >>= run)+ == runWriter (CM.foldM f x0 xs)+ where f acc el = tell (Sum 1) >> return (acc - el)+ types = xs :: [Int] -- ---------------------------------------------+-- Zips++prop_zip xs i1 i2 n = n > 0 ==>+ runner1 (enumPureNChunk xs n $ liftM2 (,) (Iter.zip i1 i2) stream2list)+ == let (r1, t1) = runner1 $ enumPure1Chunk xs $ liftM2 (,) i1 stream2list+ (r2, t2) = runner1 $ enumPure1Chunk xs $ liftM2 (,) i2 stream2list+ shorter = if P.length t1 > P.length t2 then t2 else t1+ in ((r1,r2), shorter)+ where types = (i1 :: I, i2 :: I, xs :: [Int])++-- ---------------------------------------------+-- Sequences++test_sequence_ =+ assertEqual "sequence_: no duplicate runs" ((),[4,5])+ (runWriter (Iter.enumList [[4],[5::Int]] (Iter.sequence_ [iter])+ >>= run))+ where+ iter = do+ x <- Iter.head+ lift $ tell [x]+ y <- Iter.head+ lift $ tell [y]++-- ---------------------------------------------+-- Data.Iteratee.PTerm++mk_prop_pt_id etee p_etee i xs n = n > 0 ==>+ runner1 (enumSpecial xs n $ joinI (p_etee i))+ == runner1 (enumSpecial xs n $ joinI (etee i))+ where types = (etee, p_etee, i, xs) :: (Etee, Etee, Itee, [Int])++instance Eq SomeException where+ l == r = show l == show r++type Etee = Enumeratee [Int] [Int] Identity [Int]+type Itee = Iteratee [Int] Identity [Int]++prop_mapChunksPT f i = mk_prop_pt_id (mapChunks f) (mapChunksPT f)+ where types = (i :: Itee)++prop_mapChunksMPT f i =+ mk_prop_pt_id (mapChunksM (return . f)) (mapChunksMPT (return . f))+ where types = (i :: Itee)++-- would like to test with arbitrary iteratees, but we need to guarantee+-- that they will return a value from the stream, which isn't always true+-- for the arbitrary instance.+-- could use a newtype to make it work...+prop_convStreamPT = mk_prop_pt_id (convStream getChunk) (convStreamPT getChunk)++prop_unfoldConvStreamPT f =+ mk_prop_pt_id (unfoldConvStream f' (0 :: Int)) (unfoldConvStreamPT f' 0)+ where f' x = fmap (f x,) getChunk++prop_breakEPT i = mk_prop_pt_id (breakE i) (breakEPT i)+prop_takePT i = mk_prop_pt_id (Iter.take i) (takePT i)+prop_takeUpToPT i = mk_prop_pt_id (Iter.takeUpTo i) (takeUpToPT i)+prop_takeWhileEPT i = mk_prop_pt_id (Iter.takeWhileE i) (takeWhileEPT i)++prop_mapStreamPT i = mk_prop_pt_id (Iter.mapStream i) (mapStreamPT i)+prop_rigidMapStreamPT i =+ mk_prop_pt_id (Iter.rigidMapStream i) (rigidMapStreamPT i)+prop_filterPT i = mk_prop_pt_id (Iter.filter i) (filterPT i)+++-- --------------------------------------------- -- Data.Iteratee.Char {-@@ -242,22 +493,30 @@ testGroup "Elementary" [ testProperty "list" prop_list ,testProperty "chunkList" prop_clist]- ,testGroup "StreamG tests" [+ ,testGroup "Stream tests" [ testProperty "mempty" prop_mempty ,testProperty "mappend" prop_mappend ,testProperty "mappend associates" prop_mappend2- ,testProperty "functor" prop_functor ,testProperty "eq" prop_eq ] ,testGroup "Simple Iteratees" [ testProperty "break" prop_break- ,testProperty "break remaineder" prop_break2+ ,testProperty "break remainder" prop_break2 ,testProperty "head" prop_head ,testProperty "head remainder" prop_head2+ ,testProperty "tryhead" prop_tryhead ,testProperty "heads" prop_heads ,testProperty "null heads" prop_heads2 ,testProperty "peek" prop_peek ,testProperty "peek2" prop_peek2+ ,testProperty "last" prop_last1+ ,testProperty "last ends properly" prop_last2+ ,testProperty "length" prop_length+ ,testProperty "chunkLength" prop_chunkLength+ ,testProperty "chunkLength of EoF" prop_chunkLength2+ ,testProperty "takeFromChunk" prop_takeFromChunk+ ,testProperty "drop" prop_drop+ ,testProperty "dropWhile" prop_dropWhile ,testProperty "skipToEof" prop_skip ,testProperty "iteratee Functor 1" prop_iterFmap ,testProperty "iteratee Functor 2" prop_iterFmap2@@ -275,21 +534,70 @@ ,testProperty "isFinished error" prop_isFinished2 ,testProperty "null data idempotence" prop_null ,testProperty "null data head idempotence" prop_nullH+ ,testProperty "enumList" prop_enumList+ ,testProperty "enumCheckIfDone" prop_enumCheckIfDone ] ,testGroup "Nested iteratees" [ testProperty "mapStream identity" prop_mapStream ,testProperty "mapStream identity 2" prop_mapStream2 ,testProperty "mapStream identity joinI" prop_mapjoin+ ,testProperty "rigidMapStream" prop_rigidMapStream+ ,testProperty "breakE" prop_breakE+ ,testProperty "breakE remainder" prop_breakE2 ,testProperty "take" prop_take ,testProperty "take (finished iteratee)" prop_take2- ,testProperty "takeR" prop_takeR+ ,testProperty "takeUpTo" prop_takeUpTo+ ,testProperty "takeUpTo (finished iteratee)" prop_takeUpTo2+ ,testProperty "takeUpTo (remaining stream)" prop_takeUpTo3+ ,testProperty "takeWhile" prop_takeWhile+ ,testProperty "filter" prop_filter+ ,testProperty "group" prop_group+ ,testProperty "groupBy" prop_groupBy ,testProperty "convStream EOF" prop_convstream2 ,testProperty "convStream identity" prop_convstream ,testProperty "convStream identity 2" prop_convstream3 ]+ ,testGroup "Enumerator Combinators" [+ testProperty "enumWith" prop_enumWith+ ,testProperty "enumWith remaining" prop_enumWith2+ ,testProperty "enumWith remaining 2" prop_enumWith3+ ,testProperty "countConsumed" prop_countConsumed+ ]+ ,testGroup "Folds" [+ testProperty "foldl" prop_foldl+ ,testProperty "foldl'" prop_foldl'+ ,testProperty "foldl1" prop_foldl1+ ,testProperty "foldl1'" prop_foldl1'+ ,testProperty "sum" prop_sum+ ,testProperty "product" prop_product+ ]+ ,testGroup "Zips" [+ testProperty "zip" prop_zip+ ,testCase "sequence_" test_sequence_+ ] ,testGroup "Data.Iteratee.Char" [ --testProperty "line" prop_line ]+ ,testGroup "PT variants" [+ testProperty "mapChunksPT" prop_mapChunksPT+ ,testProperty "mapChunksMPT" prop_mapChunksMPT+ ,testProperty "convStreamPT" prop_convStreamPT+ ,testProperty "unfoldConvStreamPT" prop_unfoldConvStreamPT+ ,testProperty "breakEPT" prop_breakEPT+ ,testProperty "takePT" prop_takePT+ ,testProperty "takeUpToPT" prop_takeUpToPT+ ,testProperty "takeWhileEPT" prop_takeWhileEPT+ ,testProperty "mapStreamPT" prop_mapStreamPT+ ,testProperty "rigidMapStreamPT" prop_rigidMapStreamPT+ ,testProperty "filterPT" prop_filterPT+ ]+ ,testGroup "Monadic functions" [+ testProperty "mapM_" prop_mapM_+ ,testProperty "foldM" prop_foldM+ ,testProperty "mapChunksM" prop_mapChunksM+ ,testProperty "mapChunksM_" prop_mapChunksM_+ ,testProperty "foldChunksM" prop_foldChunksM+ ] ] ------------------------------------------------------------------------