diff --git a/Data/Encoding/ByteSource.hs b/Data/Encoding/ByteSource.hs index 2385f02..92e8270 100644 --- a/Data/Encoding/ByteSource.hs +++ b/Data/Encoding/ByteSource.hs @@ -6,7 +6,9 @@ import Data.Encoding.Exception import Data.Bits import Data.Binary.Get import Data.Char +import Data.Maybe import Data.Word +import Control.Applicative as A import Control.Monad.State import Control.Monad.Identity import Control.Monad.Reader @@ -19,7 +21,9 @@ import System.IO class (Monad m,Throws DecodingException m) => ByteSource m where sourceEmpty :: m Bool fetchWord8 :: m Word8 - fetchAhead :: m a -> m a + -- 'fetchAhead act' should return the same thing 'act' does, but should + -- only consume input if 'act' returns a 'Just' value + fetchAhead :: m (Maybe a) -> m (Maybe a) fetchWord16be :: m Word16 fetchWord16be = do w1 <- fetchWord8 @@ -95,7 +99,20 @@ instance Throws DecodingException Get where instance ByteSource Get where sourceEmpty = isEmpty fetchWord8 = getWord8 - fetchAhead = lookAhead +#if MIN_VERSION_binary(0,6,0) + fetchAhead act = (do + res <- act + case res of + Nothing -> A.empty + Just a -> return res + ) <|> return Nothing +#else + fetchAhead act = do + res <- lookAhead act + case res of + Nothing -> return Nothing + Just a -> act +#endif fetchWord16be = getWord16be fetchWord16le = getWord16le fetchWord32be = getWord32be @@ -103,6 +120,12 @@ instance ByteSource Get where fetchWord64be = getWord64be fetchWord64le = getWord64le +fetchAheadState act = do + chs <- get + res <- act + when (isNothing res) (put chs) + return res + instance ByteSource (StateT [Char] Identity) where sourceEmpty = gets null fetchWord8 = do @@ -112,11 +135,7 @@ instance ByteSource (StateT [Char] Identity) where c:cs -> do put cs return (fromIntegral $ ord c) - fetchAhead act = do - chs <- get - res <- act - put chs - return res + fetchAhead = fetchAheadState #if MIN_VERSION_base(4,3,0) #else @@ -135,33 +154,21 @@ instance ByteSource (StateT [Char] (Either DecodingException)) where c:cs -> do put cs return (fromIntegral $ ord c) - fetchAhead act = do - chs <- get - res <- act - put chs - return res + fetchAhead = fetchAheadState instance (Monad m,Throws DecodingException m) => ByteSource (StateT BS.ByteString m) where sourceEmpty = gets BS.null fetchWord8 = StateT (\str -> case BS.uncons str of Nothing -> throwException UnexpectedEnd Just (c,cs) -> return (c,cs)) - fetchAhead act = do - str <- get - res <- act - put str - return res + fetchAhead = fetchAheadState instance ByteSource (StateT LBS.ByteString (Either DecodingException)) where sourceEmpty = gets LBS.null fetchWord8 = StateT (\str -> case LBS.uncons str of Nothing -> Left UnexpectedEnd Just ns -> Right ns) - fetchAhead act = do - chs <- get - res <- act - put chs - return res + fetchAhead = fetchAheadState instance ByteSource (ReaderT Handle IO) where sourceEmpty = do @@ -176,5 +183,5 @@ instance ByteSource (ReaderT Handle IO) where h <- ask pos <- liftIO $ hGetPosn h res <- act - liftIO $ hSetPosn pos + when (isNothing res) (liftIO $ hSetPosn pos) return res diff --git a/Data/Encoding/ISO2022JP.hs b/Data/Encoding/ISO2022JP.hs index 743d665..2aab7e0 100644 --- a/Data/Encoding/ISO2022JP.hs +++ b/Data/Encoding/ISO2022JP.hs @@ -26,11 +26,10 @@ instance Encoding ISO2022JP where encodeable _ c = encodeable ASCII c || encodeable JISX0201 c || encodeable JISX0208 c instance ISO2022 ISO2022JP where - readEscape _ = do - w <- fetchAhead fetchWord8 + readEscape _ = fetchAhead $ do + w <- fetchWord8 if w == 27 then (do - fetchWord8 w2 <- fetchWord8 w3 <- fetchWord8 case w2 of diff --git a/encoding.cabal b/encoding.cabal index 640a746..9ff2ed8 100644 --- a/encoding.cabal +++ b/encoding.cabal @@ -1,5 +1,5 @@ Name: encoding -Version: 0.6.7.2 +Version: 0.7 Author: Henning Günther Maintainer: daniel@wagner-home.com License: BSD3 @@ -24,8 +24,6 @@ Extra-Source-Files: Flag splitBase description: Choose the new smaller, split-up base package. -Flag newGHC - description: Use ghc version > 6.10 Flag systemEncoding description: Provide the getSystemEncoding action to query the locale. @@ -36,16 +34,14 @@ Source-Repository head Source-Repository this Type: darcs Location: http://code.haskell.org/encoding - Tag: 0.6.7.1 + Tag: 0.7 Library - Build-Depends: binary < 0.6, extensible-exceptions, HaXml >= 1.22 && < 1.24 + Build-Depends: binary < 0.7, extensible-exceptions, HaXml >= 1.22 && < 1.24 if flag(splitBase) Build-Depends: bytestring, base >= 3 && < 5, mtl, containers, array, regex-compat - if flag(newGHC) - Build-Depends: ghc-prim, ghc >= 6.10 - else - Build-Depends: ghc < 6.10 + if impl(ghc >= 6.10) + Build-Depends: ghc-prim else Build-Depends: base < 3