iteratee 0.3.6 → 0.4.0

raw patch · 32 files changed

+2921/−2499 lines, 32 filesdep +MonadCatchIO-transformersdep −extensible-exceptionsdep ~transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: MonadCatchIO-transformers

Dependencies removed: extensible-exceptions

Dependency ranges changed: transformers

API changes (from Hackage documentation)

Files

• CONTRIBUTORS +3/−1
• Examples/Tiff.hs +632/−0
• Examples/Wave.hs +330/−0
• Examples/headers.hs +8/−11
• Examples/short.wav binary
• Examples/test_wc.hs +16/−0
• Examples/wave_reader.hs +0/−43
• Examples/word.hs +38/−11
• iteratee.cabal +17/−23
• src/Data/Iteratee.hs +5/−3
• src/Data/Iteratee/Base.hs +144/−760
• src/Data/Iteratee/Base/LooseMap.hs +11/−4
• src/Data/Iteratee/Base/ReadableChunk.hs +47/−0
• src/Data/Iteratee/Base/StreamChunk.hs +0/−95
• src/Data/Iteratee/Binary.hs +55/−27
• src/Data/Iteratee/Char.hs +72/−120
• src/Data/Iteratee/Codecs/Tiff.hs +0/−626
• src/Data/Iteratee/Codecs/Wave.hs +0/−325
• src/Data/Iteratee/Exception.hs +208/−0
• src/Data/Iteratee/IO.hs +74/−30
• src/Data/Iteratee/IO/Fd.hs +84/−145
• src/Data/Iteratee/IO/Handle.hs +92/−97
• src/Data/Iteratee/IO/Interact.hs +0/−31
• src/Data/Iteratee/Iteratee.hs +290/−0
• src/Data/Iteratee/ListLike.hs +471/−0
• src/Data/Iteratee/WrappedByteString.hs +0/−110
• src/Data/NullPoint.hs +24/−0
• src/Data/Nullable.hs +24/−0
• tests/QCUtils.hs +19/−11
• tests/benchmarkHandle.hs +50/−0
• tests/benchmarks.hs +188/−0
• tests/testIteratee.hs +19/−26

@@ -1,9 +1,10 @@ Thanks to the following individuals for contributing to this project. -Brian Buecking Oleg Kiselyov+Gregory Collins Brian Lewis John Lato+Antoine Latter Echo Nolan Conrad Parker Paulo Tanimoto@@ -11,3 +12,4 @@ Johan Tibell Bas van Dijk Valery Vorotyntsev+Edward Yang

@@ -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

@@ -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)

@@ -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"-

binary file changed (54 → absent bytes)

@@ -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

@@ -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

@@ -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 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  --- 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.enumPair` numChars+ main = do   f:_ <- getArgs-  words <- fileDriver (numLines `enumPair` numWords `enumPair` numChars) f+  words <- fileDriverVBuf 65536 twoIter f   print words

@@ -1,11 +1,11 @@ name:          iteratee-version:       0.3.6+version:       0.4.0 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. category:      System, Data-author:        Oleg Kiselyov+author:        Oleg Kiselyov, John W. Lato maintainer:    John W. Lato <jwlato@gmail.com> license:       BSD3 license-file:  LICENSE@@ -21,19 +21,15 @@   README   Examples/*.hs   Examples/*.txt-  Examples/*.wav+  tests/*.hs  flag splitBase-  description: Use the new split-up base package.+  description: Use the split-up base package.  flag buildTests   description: Build test executables.   default:     False -flag includeCodecs-  description: Build Tiff and Wave codec modules-  default:     False- library   hs-source-dirs:     src@@ -58,28 +54,26 @@       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+    ListLike                  >= 1.0     && < 2,+    MonadCatchIO-transformers >  0.2     && < 0.3,+    bytestring                >= 0.9     && < 0.10,+    containers                >= 0.2     && < 0.4,+    transformers              >= 0.2     && < 0.3    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    other-modules:     Data.Iteratee.IO.Base@@ -116,4 +110,4 @@  source-repository head   type:     darcs-  location: http://tanimoto.us/~jwlato/haskell/iteratee-0.3+  location: http://inmachina.net/~jwlato/haskell/iteratee

@@ -5,14 +5,16 @@ -}  module Data.Iteratee (-  module Data.Iteratee.Base,   module Data.Iteratee.Binary,+  module Data.Iteratee.ListLike,   fileDriver,-  fileDriverRandom+  fileDriverVBuf,+  fileDriverRandom,+  fileDriverRandomVBuf )  where -import Data.Iteratee.Base import Data.Iteratee.Binary import Data.Iteratee.IO+import Data.Iteratee.ListLike

@@ -1,94 +1,54 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, 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+  -- ** Creating Iteratees+  ,idone+  ,icont+  ,liftI+  ,idoneM+  ,icontM+  -- ** Stream Functions+  ,setEOF   -- * Classes-  module Data.Iteratee.Base.LooseMap+  ,module Data.NullPoint+  ,module Data.Nullable+  ,module Data.Iteratee.Base.LooseMap ) where -import Prelude hiding (head, last, drop, dropWhile, take, break, foldl, foldl1, length, filter, sum, product, mapM_)-import qualified Prelude as P--import qualified Data.Iteratee.Base.StreamChunk as SC-import qualified Data.ListLike as LL-import qualified Data.ListLike.FoldableLL as FLL+import Prelude hiding (null, catch) 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.Iteratee.Exception+import Data.Nullable+import Data.NullPoint import Data.Monoid-import Data.Maybe (fromMaybe) +import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.CatchIO (MonadCatchIO (..), Exception (..),+  catch, block, toException, fromException)+import Control.Applicative hiding (empty)+import Control.Exception (SomeException)+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 +58,138 @@ -- 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---- |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----- |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--{-# INLINE convStream #-}---- |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--{-# INLINE convStateStream #-}--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--{-# INLINE convStateCheck #-}---- |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---- --------------------------------------------------------------------------- Folds---- | 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-    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+setEOF _              = toException EofException --- |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)+-- ----------------------------------------------+-- | 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} --- --------------------------------------------------------------------------- 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...+-- ---------------------------------------------- --- 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.+idone :: Monad m => a -> Stream s -> Iteratee s m a+idone a s = Iteratee $ \onDone _ -> onDone a s -type EnumeratorGM s el m a = IterateeG s el m a -> m (IterateeG s el m a)+icont :: (Stream s -> Iteratee s m a) -> Maybe SomeException -> Iteratee s m a+icont k e = Iteratee $ \_ onCont -> onCont k e --- |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)+liftI :: Monad m => (Stream s -> Iteratee s m a) -> Iteratee s m a+liftI k = Iteratee $ \_ onCont -> onCont k Nothing --- |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)+-- 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 --- |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')+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 --- |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 (Functor m, Monad 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 -(>.):: (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 (Functor m, Monad m, Nullable s) => Applicative (Iteratee s m) where+    pure x  = idone x (Chunk empty)+    m <*> a = m >>= flip fmap a --- |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+instance (Monad m, Nullable s) => Monad (Iteratee s m) where+  {-# INLINE return #-}+  return x = Iteratee $ \onDone _ -> onDone x (Chunk empty)+  {-# INLINE (>>=) #-}+  m >>= f = Iteratee $ \onDone onCont ->+     let m_done a (Chunk s)+           | null 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 . ((>>= f) .)) +instance NullPoint s => MonadTrans (Iteratee s) where+  lift m = Iteratee $ \onDone _ -> m >>= flip onDone (Chunk empty) --- |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)-  where-  (s1, s2) = SC.splitAt n str-enumPureNChunk _ n _ = error $ "enumPureNChunk called with n==" ++ show n+instance (MonadIO m, Nullable s, NullPoint s) => MonadIO (Iteratee s m) where+  liftIO = lift . liftIO --- |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)+instance (MonadCatchIO m, Nullable s, NullPoint s) =>+  MonadCatchIO (Iteratee s m) where+    m `catch` f = Iteratee $ \od oc -> runIter m od oc `catch` (\e -> runIter (f e) od oc)+    block       = mapIteratee block+    unblock     = mapIteratee unblock --- --------------------------------------------------------------------------- Monadic variants of iteratees+-- |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 --- | 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+-- |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-  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+    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) -{-# INLINE mapM_ #-}+-- |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

@@ -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

@@ -0,0 +1,47 @@+{-# 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 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)

@@ -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

@@ -1,18 +1,24 @@ {-# LANGUAGE FlexibleContexts #-} --- |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 ) 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 Data.Word import Data.Bits import Data.Int@@ -28,42 +34,64 @@   | 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+  :: (Nullable s, LL.ListLike s Word8, Monad m) =>+     Endian+     -> Iteratee s m Word16 endianRead2 e = do-  c1 <- It.head-  c2 <- It.head+  c1 <- I.head+  c2 <- I.head   case e of     MSB -> return $ (fromIntegral c1 `shiftL` 8) .|. fromIntegral c2     LSB -> return $ (fromIntegral c2 `shiftL` 8) .|. fromIntegral c1 --- |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--- well.-endianRead3 :: (StreamChunk s Word8, Monad m) => Endian ->-  It.IterateeG s Word8 m Word32+endianRead3+  :: (Nullable s, LL.ListLike s Word8, Monad m) =>+     Endian+     -> Iteratee s m Word32 endianRead3 e = do-  c1 <- It.head-  c2 <- It.head-  c3 <- It.head+  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 -> return $ (((fromIntegral c3+                        `shiftL` 8) .|. fromIntegral c2)+                        `shiftL` 8) .|. fromIntegral c1++-- |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.+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 -endianRead4 :: (StreamChunk s Word8, Monad m) => Endian ->-  It.IterateeG s Word8 m Word32+endianRead4+  :: (Nullable s, LL.ListLike s Word8, Monad m) =>+     Endian+     -> Iteratee s m Word32 endianRead4 e = do-  c1 <- It.head-  c2 <- It.head-  c3 <- It.head-  c4 <- It.head+  c1 <- I.head+  c2 <- I.head+  c3 <- I.head+  c4 <- I.head   case e of     MSB -> return $                (((((fromIntegral c1

@@ -1,170 +1,122 @@--- Haskell98!---- |Utilties for Char-based iteratee processing.+{-# LANGUAGE 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+  ,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 ()+printLines :: Iteratee String IO () printLines = lines'   where-  lines' = Iter.break (\c -> c == '\r' || c == '\n') >>= \l ->-               terminators >>= check l+  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.--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-- -- |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+      | True       = 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)+      | LL.null ys = icont (step' xs) Nothing+      | lChar ys   = idone (LL.lines . mappend xs $ ys) mempty       | True       = 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)+      | True       = 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+      | True       = 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)+      | True       = 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+      | True       = 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

@@ -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

@@ -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)

@@ -0,0 +1,208 @@+{-# 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 (..)+  -- ** Enumerator exceptions+  ,EnumException (..)+  ,DivergentException (..)+  ,EnumStringException (..)+  ,EnumUnhandledIterException (..)+  -- ** Iteratee exceptions+  ,IException (..)+  ,IterException (..)+  ,SeekException (..)+  ,EofException (..)+  ,IterStringException (..)+  -- * Functions+  ,enStrExc+  ,iterStrExc+  ,wrapIterExc+)+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+

@@ -14,15 +14,18 @@ #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 @@ -30,46 +33,87 @@ import Data.Iteratee.IO.Fd #endif -import Control.Monad.IO.Class+import Control.Monad.CatchIO +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+-- |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+  :: (MonadCatchIO m, NullPoint s, ReadableChunk s el) =>+     Iteratee s m a+     -> FilePath+     -> m a+fileDriver = 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+  :: (MonadCatchIO m, NullPoint s, ReadableChunk s el) =>+     Int+     -> Iteratee s m a+     -> FilePath+     -> m a+fileDriverVBuf = 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+  :: (MonadCatchIO m, NullPoint s, ReadableChunk s el) =>+     Iteratee s m a+     -> FilePath+     -> m a+fileDriverRandom = fileDriverRandomFd defaultBufSize +fileDriverRandomVBuf+  :: (MonadCatchIO m, NullPoint s, ReadableChunk s el) =>+     Int+     -> Iteratee s m a+     -> FilePath+     -> m a+fileDriverRandomVBuf = 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 ::+ (MonadCatchIO m, NullPoint s, ReadableChunk s el) =>+  Iteratee s m a+  -> FilePath+  -> m a+fileDriver = 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 ::+ (MonadCatchIO m, NullPoint s, ReadableChunk s el) =>+  Int+  -> Iteratee s m a+  -> FilePath+  -> m a+fileDriverVBuf = fileDriverHandle++-- |Process a file using the given Iteratee.  This function wraps+-- @enumRandomHandle@ as a convenience.+fileDriverRandom+  :: (MonadCatchIO m, NullPoint s, ReadableChunk s el) =>+     Iteratee s m a+     -> FilePath+     -> m a+fileDriverRandom = fileDriverRandomHandle defaultBufSize++fileDriverRandomVBuf+  :: (MonadCatchIO m, NullPoint s, ReadableChunk s el) =>+     Int+     -> Iteratee s m a+     -> FilePath+     -> m a+fileDriverRandomVBuf = fileDriverRandomHandle  #endif

@@ -7,13 +7,12 @@ module Data.Iteratee.IO.Fd( #if defined(USE_POSIX)   -- * File enumerators-  -- ** FileDescriptor based enumerators+  -- ** FileDescriptor based enumerators for monadic iteratees   enumFd-  ,enumFdFollow+  ,enumFdCatch   ,enumFdRandom   -- * Iteratee drivers   ,fileDriverFd-  ,fileDriverFollowFd   ,fileDriverRandomFd #endif )@@ -21,17 +20,19 @@ 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.Exception import Control.Monad+import Control.Monad.CatchIO as CIO import Control.Monad.IO.Class  import Foreign.Ptr-import Foreign.ForeignPtr import Foreign.Storable+import Foreign.Marshal.Alloc  import System.IO (SeekMode(..)) @@ -41,152 +42,90 @@ -- ------------------------------------------------------------------------ -- Binary Random IO enumerators +makefdCallback ::+  (MonadIO m, NullPoint s, ReadableChunk s el) =>+  Ptr el+  -> ByteCount+  -> Fd+  -> m (Either SomeException (Bool, s))+makefdCallback p bufsize fd = do+  liftIO $ GHC.Conc.threadWaitRead fd+  n <- liftIO $ myfdRead fd (castPtr p) bufsize+  case n of+    Left _   -> return $ Left undefined+    Right 0  -> return $ Right (False, empty)+    Right n' -> liftM (\s -> Right (True, 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) =>+     Int+     -> Fd+     -> Enumerator s m a+enumFd bs fd iter = do+  let bufsize = bs * (sizeOf (undefined :: el))+  p <- liftIO $ mallocBytes bufsize+  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'-  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+-- |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)+    => Int+    -> Fd+    -> (e -> m (Maybe EnumException))+    -> Enumerator s m a+enumFdCatch bs fd handler iter = do+  let bufsize = bs * (sizeOf (undefined :: el))+  p <- liftIO $ mallocBytes bufsize+  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.(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 --- |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+-- |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) =>+    Int+    -> Fd+    -> Enumerator s m a+enumFdRandom bs fd iter = enumFdCatch bs fd handler iter+  where+    handler (SeekException off) =+      liftM (either+             (const . Just $ enStrExc "Error seeking within file descriptor")+             (const Nothing))+            . liftIO . myfdSeek fd AbsoluteSeek $ fromIntegral off --- |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+fileDriver+  :: (MonadCatchIO 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--- 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+-- |Process a file using the given @Iteratee@.+fileDriverFd+  :: (NullPoint s, MonadCatchIO m, ReadableChunk s el) =>+     Int -- ^Buffer size (number of elements)+     -> Iteratee s m a+     -> FilePath+     -> m a+fileDriverFd = fileDriver enumFd++-- |A version of fileDriverFd that supports seeking.+fileDriverRandomFd+  :: (NullPoint s, MonadCatchIO m, ReadableChunk s el) =>+     Int+     -> Iteratee s m a+     -> FilePath+     -> m a+fileDriverRandomFd = fileDriver enumFdRandom  #endif

@@ -8,6 +8,7 @@ module Data.Iteratee.IO.Handle(   -- * File enumerators   enumHandle+  ,enumHandleCatch   ,enumHandleRandom   -- * Iteratee drivers   ,fileDriverHandle@@ -16,18 +17,18 @@  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.CatchIO as CIO import Control.Monad.IO.Class  import Foreign.Ptr-import Foreign.ForeignPtr import Foreign.Storable+import Foreign.Marshal.Alloc  import System.IO @@ -35,104 +36,98 @@ -- ------------------------------------------------------------------------ -- Binary Random IO enumerators --- |The enumerator of a file Handle.  This version enumerates+makeHandleCallback ::+  (MonadCatchIO m, NullPoint s, ReadableChunk s el) =>+  Ptr el+  -> Int+  -> Handle+  -> m (Either SomeException (Bool, s))+makeHandleCallback p bsize h = 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, empty)+    Right n -> liftM (\s -> Right (True, 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, MonadCatchIO m) =>+  Int -- ^Buffer size (number of elements per read)+  -> Handle+  -> Enumerator s m a+enumHandle bs h i = do+  let bufsize = bs * sizeOf (undefined :: el)+  p <- liftIO $ mallocBytes bufsize+  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,+                    MonadCatchIO m) =>+  Int -- ^Buffer size (number of elements per read)+  -> Handle+  -> (e -> m (Maybe EnumException))+  -> Enumerator s m a+enumHandleCatch bs h handler i = do+  let bufsize = bs * sizeOf (undefined :: el)+  p <- liftIO $ mallocBytes bufsize+  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, MonadCatchIO 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+fileDriver :: (NullPoint s, MonadCatchIO m, ReadableChunk s el) =>+  (Int -> Handle -> Enumerator s m a)+  -> Int -- ^Buffer size+  -> Iteratee s m a+  -> FilePath+  -> m a+fileDriver enumf bufsize iter filepath = CIO.bracket+  (liftIO $ openBinaryFile filepath ReadMode)+  (liftIO . hClose)+  (run <=< 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+-- |Process a file using the given @Iteratee@.  This function wraps+-- @enumHandle@ as a convenience.+fileDriverHandle+  :: (NullPoint s, MonadCatchIO m, ReadableChunk s el) =>+     Int -- ^Buffer size (number of elements)+     -> Iteratee s m a+     -> FilePath+     -> m a+fileDriverHandle = fileDriver enumHandle++-- |A version of @fileDriverHandle@ that supports seeking.+fileDriverRandomHandle+  :: (NullPoint s, MonadCatchIO m, ReadableChunk s el) =>+     Int+     -> Iteratee s m a+     -> FilePath+     -> m a+fileDriverRandomHandle = fileDriver enumHandleRandom+

@@ -1,31 +0,0 @@-module Data.Iteratee.IO.Interact (-  ioIter-) where--import Control.Monad.IO.Class (MonadIO, liftIO)--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'-

@@ -0,0 +1,290 @@+{-# LANGUAGE KindSignatures, FlexibleContexts, ScopedTypeVariables, DeriveDataTypeable #-}++-- |Monadic and General Iteratees:+-- incremental input parsers, processors and transformers++module Data.Iteratee.Iteratee (+  -- * Types+  -- ** Error handling+  throwErr+  ,throwRecoverableErr+  ,checkErr+  -- ** Basic Iteratees+  ,identity+  ,skipToEof+  ,isStreamFinished+  -- ** Nested iteratee combinators+  ,convStream+  ,unfoldConvStream+  ,joinI+  ,joinIM+  -- * Enumerators+  ,Enumerator+  ,Enumeratee+  -- ** Basic enumerators+  ,enumChunk+  ,enumEof+  ,enumErr+  ,enumPure1Chunk+  ,enumCheckIfDone+  ,enumFromCallback+  ,enumFromCallbackCatch+  -- ** Enumerator Combinators+  ,(>>>)+  ,eneeCheckIfDone+  -- * 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 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 :: (Monad m) => 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 ::+ (Monad m) =>+  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 ::+ (Monad m, 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 :: (Monad m, NullPoint s) => Iteratee s m ()+identity = idone () (Chunk empty)++-- |Get the stream status of an iteratee.+isStreamFinished :: Monad m => Iteratee s m (Maybe SomeException)+isStreamFinished = liftI check+  where+    check s@(EOF e) = idone (Just $ fromMaybe (toException EofException) e) s+    check s         = idone Nothing s+{-# INLINE isStreamFinished #-}+++-- |Skip the rest of the stream+skipToEof :: (Monad m) => Iteratee s m ()+skipToEof = icont check Nothing+  where+    check (Chunk _) = skipToEof+    check s         = idone () s+++-- |Seek to a position in the stream+seek :: (Monad m, NullPoint s) => FileOffset -> Iteratee s m ()+seek o = throwRecoverableErr (toException $ SeekException o) (const identity)+++-- ---------------------------------------------------+-- 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 #-}++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 inner = Iteratee $ \od oc -> +  let on_done x s = od (idone x s) (Chunk empty)+      on_cont k Nothing  = runIter (f k) od oc+      on_cont _ (Just e) = runIter (throwErr e) od oc+  in runIter inner on_done on_cont+++-- |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 el s'.+convStream ::+ (Monad m, Nullable s) =>+  Iteratee s m s'+  -> Enumeratee s s' m a+convStream fi = eneeCheckIfDone check+  where+    check k = isStreamFinished >>= maybe (step k) (idone (liftI k) . EOF . Just)+    step k = fi >>= convStream fi . k . Chunk++-- |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 acc = eneeCheckIfDone check+  where+    check k = isStreamFinished >>= maybe (step k) (idone (liftI k) . EOF . Just)+    step k = f acc >>= \(acc', s') -> unfoldConvStream f acc' . k . Chunk $ s'+++joinI ::+ (Monad m, Nullable s) =>+  Iteratee s m (Iteratee s' m a)+  -> Iteratee s m a+joinI = (>>=+  \inner -> Iteratee $ \od oc ->+  let on_done  x _        = od x (Chunk empty)+      on_cont  k Nothing  = runIter (k (EOF Nothing)) on_done on_cont'+      on_cont  _ (Just e) = runIter (throwErr e) od oc+      on_cont' _ e        = runIter (throwErr (fromMaybe excDivergent e)) od oc+  in runIter inner on_done on_cont)++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++-- |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++-- |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) =>+  m (Either SomeException (Bool, s))+  -> Enumerator s m a+enumFromCallback = flip enumFromCallbackCatch+  (\NotAnException -> return Nothing)++-- 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) =>+  m (Either SomeException (Bool, s))+  -> (e -> m (Maybe EnumException))+  -> Enumerator s m a+enumFromCallbackCatch c handler = loop+  where+    loop iter = runIter iter idoneM on_cont+    on_cont k Nothing = c >>= either (return . k . EOF . Just) (uncurry check)+      where+        check b = if b then loop . k . Chunk else return . k . Chunk+    on_cont k j@(Just e) = case fromException e of+      Just e' -> handler e' >>= maybe (loop . k $ Chunk empty)+                                 (return . icont k . Just) . fmap toException+      Nothing -> return (icont k j)+

@@ -0,0 +1,471 @@+{-# LANGUAGE FlexibleContexts, BangPatterns #-}++-- |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+  ,heads+  ,peek+  ,length+  -- ** Nested iteratee combinators+  ,take+  ,takeUpTo+  ,mapStream+  ,rigidMapStream+  ,filter+  -- ** Folds+  ,foldl+  ,foldl'+  ,foldl1+  ,foldl1'+  -- ** Special Folds+  ,sum+  ,product+  -- * Enumerators+  -- ** Basic enumerators+  ,enumPureNChunk+  -- ** Enumerator Combinators+  ,enumPair+  -- * Classes+  ,module Data.Iteratee.Iteratee+)+where++import Prelude hiding (null, head, drop, dropWhile, take, break, foldl, foldl1, length, filter, sum, product)++import qualified Data.ListLike as LL+import qualified Data.ListLike.FoldableLL as FLL+import Data.Iteratee.Iteratee+import Data.Monoid+import Control.Monad.Trans.Class+import Data.Word (Word8)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+++-- Useful combinators for implementing iteratees and enumerators++-- | Check if a stream has received 'EOF'.+isFinished :: (Monad m, Nullable s) => Iteratee s m Bool+isFinished = liftI check+  where+  check c@(Chunk xs)+    | null xs     = liftI check+    | True        = 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 = liftI (step [])+  where+    step acc (Chunk ls)+      | null ls  = liftI (step acc)+      | True     = liftI (step (acc ++ LL.toList ls))+    step acc str = idone acc str+{-# 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 = icont (step mempty) Nothing+  where+    step acc (Chunk ls)+      | null ls   = icont (step acc) Nothing+      | True      = icont (step (acc `mappend` ls)) Nothing+    step acc str  = idone acc str+{-# 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.+--+-- The analogue of @List.break@++break :: (Monad m, 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+      | True              =  case LL.break cpred str of+        (str', tail')+          | LL.null tail' -> icont (step (bfr `mappend` str)) Nothing+          | True          -> 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@+head :: (Monad m, LL.ListLike s el) => Iteratee s m el+head = liftI step+  where+  step (Chunk vec)+    | LL.null vec  = icont step Nothing+    | True         = idone (LL.head vec) (Chunk $ LL.tail vec)+  step stream      = icont step (Just (setEOF stream))+{-# INLINE head #-}+++-- |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 | null st = return 0+heads st = loop 0 st+  where+  loop cnt xs+    | null xs = return cnt+    | True    = liftI (step cnt xs)+  step cnt str (Chunk xs) | null xs  = liftI (step cnt str)+  step cnt str stream     | null 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 :: (Monad m, LL.ListLike s el) => Iteratee s m (Maybe el)+peek = liftI step+  where+    step s@(Chunk vec)+      | LL.null vec = liftI step+      | True        = idone (Just $ LL.head vec) s+    step stream     = idone Nothing stream+{-# INLINE peek #-}+++-- |Drop n elements of the stream, if there are that many.+--+-- The analogue of @List.drop@+drop :: (Monad m, Nullable s, LL.ListLike s el) => Int -> Iteratee s m ()+drop 0  = return ()+drop n' = liftI (step n')+  where+    step n (Chunk str)+      | LL.length str <= n = liftI (step (n - LL.length str))+      | True               = 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 :: (Monad m, LL.ListLike s el) => (el -> Bool) -> Iteratee s m ()+dropWhile p = liftI step+  where+    step (Chunk str)+      | LL.null left = liftI step+      | True         = 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 :: (Monad m, Num a, LL.ListLike s el) => Iteratee s m a+length = liftI (step 0)+  where+    step !i (Chunk xs) = liftI (step $ i + LL.length xs)+    step !i stream     = idone (fromIntegral i) stream+{-# INLINE length #-}+++-- ---------------------------------------------------+-- The converters show a different way of composing two iteratees:+-- `vertical' rather than `horizontal'++-- |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 -> Enumeratee s s m a+take n' iter+ | n' <= 0 = return iter+ | True    = 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)+      | True               = idone (k (Chunk s1)) (Chunk s2)+      where (s1, s2) = LL.splitAt n str+    step _n k stream       = idone (k stream) stream+{-# SPECIALIZE take :: Monad m => Int -> Enumeratee [el] [el] m a #-}+{-# SPECIALIZE take :: Monad m => Int -> Enumeratee B.ByteString B.ByteString m a #-}+{-# SPECIALIZE take :: Monad m => Int -> Enumeratee BC.ByteString BC.ByteString m a #-}++-- |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.+--+-- N.B. If the inner iteratee finishes early, remaining data within the current+-- chunk will be dropped.+takeUpTo :: (Monad m, Nullable s, LL.ListLike s el) => Int -> Enumeratee s s m a+takeUpTo i iter+ | i <= 0    = return iter+ | otherwise = Iteratee $ \od oc ->+    runIter iter (onDone od oc) (onCont od oc)+  where+    onDone od oc x _        = runIter (return (return x)) 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)+      | True                = idone (k (Chunk s1)) (Chunk s2)+      where (s1, s2) = LL.splitAt n str+    step _ k stream         = idone (k stream) stream+{-# SPECIALIZE takeUpTo :: Monad m => Int -> Enumeratee [el] [el] m a #-}+{-# SPECIALIZE takeUpTo :: Monad m => Int -> Enumeratee B.ByteString B.ByteString m a #-}+++-- |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 ::+ (Monad m,+  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 = eneeCheckIfDone (liftI . step)+  where+    step k (Chunk xs)+      | LL.null xs = liftI (step k)+      | True       = mapStream f $ k (Chunk $ lMap f xs)+    step k s       = idone (liftI k) s+{-# SPECIALIZE mapStream :: Monad m => (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 ::+ (Monad m, LL.ListLike s el, NullPoint s) =>+  (el -> el)+  -> Enumeratee s s m a+rigidMapStream f = eneeCheckIfDone (liftI . step)+  where+    step k (Chunk xs)+      | LL.null xs = liftI (step k)+      | True       = rigidMapStream f $ k (Chunk $ LL.rigidMap f xs)+    step k s       = idone (liftI k) s+{-# SPECIALIZE rigidMapStream :: Monad m => (el -> el) -> Enumeratee [el] [el] m a #-}+{-# SPECIALIZE rigidMapStream :: Monad m => (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, Nullable s, LL.ListLike s el) =>+  (el -> Bool)+  -> Enumeratee s s m a+filter p = convStream f'+  where+    f' = icont step Nothing+    step (Chunk xs)+      | LL.null xs = f'+      | True       = idone (LL.filter p xs) mempty+    step _ = f'+{-# INLINE filter #-}++-- ------------------------------------------------------------------------+-- Folds++-- | Left-associative fold.+--+-- The analogue of @List.foldl@+foldl ::+ (Monad m, 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)+      | True   = 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' ::+ (Monad m, 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)+      | True       = 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 ::+ (Monad m, 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+      | True       = foldl f $ FLL.foldl1 f xs+    step stream    = icont step (Just (setEOF stream))+{-# INLINE foldl1 #-}+++-- | Strict variant of 'foldl1'.+foldl1' ::+ (Monad m, 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+      | True       = foldl' f $ FLL.foldl1 f xs+    step stream    = icont step (Just (setEOF stream))+{-# INLINE foldl1' #-}+++-- | Sum of a stream.+sum :: (Monad m, 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)+      | True       = liftI (step $! acc + LL.sum xs)+    step acc str   = idone acc str+{-# INLINE sum #-}+++-- | Product of a stream.+product :: (Monad m, 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)+      | True       = liftI (step $! acc * LL.product xs)+    step acc str   = idone acc str+{-# INLINE product #-}+++-- ------------------------------------------------------------------------+-- Zips++-- |Enumerate two iteratees over a single stream simultaneously.+--+-- Compare to @zip@.+enumPair ::+ (Monad m, Nullable s, LL.ListLike s el) =>+  Iteratee s m a+  -> Iteratee s m b+  -> Iteratee s m (a,b)+enumPair i1 i2 = Iteratee $ \od oc -> runIter i1 (onDone od oc) (onCont od oc)+  where+    onDone od oc x s        = runIter i2 (oD12 od oc x s) (onCont' od oc x)+    oD12 od oc x1 s1 x2 s2  = runIter (idone (x1,x2) (longest s1 s2)) od oc+    onCont od oc k mErr     = runIter (icont (step k) mErr) od oc+      where+    onCont' od oc x1 k mErr = runIter (icont (step2 x1 k) mErr) od oc+    step k c@(Chunk str)+      | null str            = liftI (step k)+      | True                = lift (enumPure1Chunk str i2) >>= enumPair (k c)+    step k s@(EOF Nothing)  = lift (enumEof i2) >>= enumPair (k s)+    step k s@(EOF (Just e)) = lift (enumErr e i2) >>= enumPair (k s)+    step2 x1 k (Chunk str)+      | null str            = liftI (step2 x1 k)+    step2 x1 k str          = enumPair (return x1) (k str)+    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+{-# INLINE enumPair #-}+++-- ------------------------------------------------------------------------+-- 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+  | True        = error $ "enumPureNChunk called with n==" ++ show n+  where+    enum' str' iter'+      | LL.null str' = return iter'+      | True         = 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 #-}

@@ -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)

@@ -0,0 +1,24 @@+-- |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++-- ----------------------------------------------+-- |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+

@@ -0,0 +1,24 @@+-- |Nullable:+-- test if a type (container) is null.++module Data.Nullable (+  -- * Classes+  Nullable (..)+)+where++import Data.NullPoint+import qualified Data.ByteString as B+++-- ----------------------------------------------+-- |Nullable container class+class NullPoint c => Nullable c where+  null :: c -> Bool++instance Nullable [a] where+  null [] = True+  null _  = False++instance Nullable B.ByteString where+  null = B.null

@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances #-}  module QCUtils where @@ -7,29 +7,37 @@ 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

@@ -0,0 +1,50 @@+{-# LANGUAGE BangPatterns #-}++module Main where++import Prelude hiding (null, length)+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Criterion.Main+import Data.Word+import Data.Iteratee+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++main = defaultMain+  [ bench "Fd with String" testFdString+  , bench "Hd with String" testHdString+  , bench "Fd with ByteString" testFdByte+  , bench "Hd with ByteString" testHdByte+  ]

@@ -0,0 +1,188 @@+{-# LANGUAGE RankNTypes, KindSignatures, NoMonomorphismRestriction #-}++-- some basic benchmarking of iteratee++module Main where++import Data.Iteratee+import qualified Data.Iteratee.ListLike as I+import Data.Iteratee.ListLike (enumPureNChunk, stream2list, stream2stream)+import Data.Word+import Data.Monoid+import qualified Data.ByteString as BS+import Control.Monad.Identity+import Control.Monad+import qualified Data.ListLike as LL+import Control.DeepSeq++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++makeList name f = BDList name f [1..10000]++makeBench :: BD n eval [Int] Identity -> Benchmark+makeBench (BDIter1 n eval i) = bench n $+  proc eval runIdentity (enumPure1Chunk [1..10000]) i+makeBench (BDIterN n csize eval i) = bench n $+  proc eval runIdentity (enumPureNChunk [1..10000] csize) i+makeBench (BDList n f l) = bench n $ whnf f l++packedBS :: BS.ByteString+packedBS  = (BS.pack [1..10000])++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++defaultProc = proc id runIdentity (enumPure1Chunk [1..10000])+defaultNProc = proc id runIdentity (enumPureNChunk [1..10000] 5)++-- -------------------------------------------------------------+-- 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+lengthbench = makeGroup "length" listBenches+takebench = makeGroup "take" $ take0 : takeBenches+--takeRbench = makeGroup "takeR" $ takeR0 : takeRBenches+takeRbench = makeGroup "takeR" []+mapbench = makeGroup "map" $ mapBenches+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+lengthbenchbs = makeGroupBS "length" listBenches+takebenchbs = makeGroupBS "take" takeBenches+takeRbenchbs = makeGroupBS "takeR" takeRBenches+mapbenchbs = makeGroupBS "map" mapBenches+convbenchbs = makeGroupBS "convStream" convBenches+miscbenchbs = makeGroupBS "other" miscBenches+++allListBenches = bgroup "list" [listbench, streambench, breakbench, headsbench, dropbench, lengthbench, takebench, takeRbench, mapbench, convbench, miscbench]++allByteStringBenches = bgroup "bytestring" [listbenchbs, streambenchbs, breakbenchbs, headsbenchbs, dropbenchbs, lengthbenchbs, takebenchbs, takeRbenchbs, mapbenchbs, convbenchbs, miscbenchbs]++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]+++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]++{-+takeR0 = makeList "take length of list long" (Prelude.length . Prelude.take 1000)+takeR1 = id1 "takeR head short one go" (I.joinI $ I.take 20 I.head)+takeR2 = id1 "takeR head long one go" (I.joinI $ I.takeR 1000 I.head)+takeR3 = idN "takeR head short chunked" (I.joinI $ I.takeR 20 I.head)+takeR4 = idN "takeR head long chunked" (I.joinI $ I.takeR 1000 I.head)+takeR5 = id1 "takeR length long one go" (I.joinI $ I.takeR 1000 I.length)+takeR6 = idN "takeR length long chunked" (I.joinI $ I.takeR 1000 I.length)+takeRBenches = [takeR1, takeR2, takeR3, takeR4, takeR5, takeR6]+-}+takeRBenches = []++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]++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]++instance NFData BS.ByteString where

@@ -13,7 +13,6 @@ 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 qualified Data.ListLike as LL@@ -25,28 +24,23 @@   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 @@ -125,7 +119,7 @@ -- --------------------------------------------- -- 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)@@ -135,22 +129,22 @@                     == 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)@@ -182,14 +176,14 @@   where types = (i :: I, 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)+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,9 +211,9 @@                   == 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]  -- ---------------------------------------------@@ -242,11 +236,10 @@   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" [@@ -282,7 +275,7 @@     ,testProperty "mapStream identity joinI" prop_mapjoin     ,testProperty "take" prop_take     ,testProperty "take (finished iteratee)" prop_take2-    ,testProperty "takeR" prop_takeR+    ,testProperty "takeUpTo" prop_takeUpTo     ,testProperty "convStream EOF" prop_convstream2     ,testProperty "convStream identity" prop_convstream     ,testProperty "convStream identity 2" prop_convstream3