[commit: packages/binary] ghc-head: Reimplement lookAheadE (2d53508)
git at git.haskell.org
git at git.haskell.org
Fri Aug 30 15:20:43 CEST 2013
Repository : ssh://git@git.haskell.org/binary
On branch : ghc-head
Link : http://git.haskell.org/?p=packages/binary.git;a=commit;h=2d53508647cac46a375ac6911f9048525af7107b
>---------------------------------------------------------------
commit 2d53508647cac46a375ac6911f9048525af7107b
Author: Lennart Kolmodin <kolmodin at gmail.com>
Date: Sat Apr 20 11:11:15 2013 +0400
Reimplement lookAheadE
Including tests.
>---------------------------------------------------------------
2d53508647cac46a375ac6911f9048525af7107b
src/Data/Binary/Get.hs | 1 +
src/Data/Binary/Get/Internal.hs | 13 +++++++++++--
tests/Action.hs | 40 +++++++++++++++++++++++++++++++++------
3 files changed, 46 insertions(+), 8 deletions(-)
diff --git a/src/Data/Binary/Get.hs b/src/Data/Binary/Get.hs
index 0cd99ac..656b712 100644
--- a/src/Data/Binary/Get.hs
+++ b/src/Data/Binary/Get.hs
@@ -146,6 +146,7 @@ module Data.Binary.Get (
, bytesRead
, lookAhead
, lookAheadM
+ , lookAheadE
-- ** ByteStrings
, getByteString
diff --git a/src/Data/Binary/Get/Internal.hs b/src/Data/Binary/Get/Internal.hs
index a79f16d..7dac47d 100644
--- a/src/Data/Binary/Get/Internal.hs
+++ b/src/Data/Binary/Get/Internal.hs
@@ -30,6 +30,7 @@ module Data.Binary.Get.Internal (
, isEmpty
, lookAhead
, lookAheadM
+ , lookAheadE
-- ** ByteStrings
, getByteString
@@ -253,10 +254,18 @@ lookAhead g = do
-- If the given decoder fails, then so will this function.
lookAheadM :: Get (Maybe a) -> Get (Maybe a)
lookAheadM g = do
+ let g' = maybe (Left ()) Right <$> g
+ either (const Nothing) Just <$> lookAheadE g'
+
+-- | Run the given decoder, and only consume its input if it returns 'Right'.
+-- If 'Left' is returned, the input will be unconsumed.
+-- If the given decoder fails, then so will this function.
+lookAheadE :: Get (Either a b) -> Get (Either a b)
+lookAheadE g = do
(decoder, bs) <- runAndKeepTrack g
case decoder of
- Done _ Nothing -> pushBack bs >> return Nothing
- Done inp (Just x) -> C $ \_ ks -> ks inp (Just x)
+ Done _ (Left x) -> pushBack bs >> return (Left x)
+ Done inp (Right x) -> C $ \_ ks -> ks inp (Right x)
Fail inp s -> C $ \_ _ -> Fail inp s
_ -> error "Binary: impossible"
diff --git a/tests/Action.hs b/tests/Action.hs
index 2b5abbc..806d0b7 100644
--- a/tests/Action.hs
+++ b/tests/Action.hs
@@ -4,6 +4,7 @@ module Action where
import Control.Applicative
import Control.Monad
import Test.QuickCheck
+import Data.Maybe ( fromJust )
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
@@ -19,6 +20,8 @@ data Action
| LookAhead [Action]
-- | First argument is True if this action returns Just, otherwise False.
| LookAheadM Bool [Action]
+ -- | First argument is True if this action returns Right, otherwise Left.
+ | LookAheadE Bool [Action]
| BytesRead
| Fail
deriving (Show, Eq)
@@ -33,6 +36,7 @@ instance Arbitrary Action where
Fail -> []
LookAhead a -> Actions a : [ LookAhead a' | a' <- shrink a ]
LookAheadM b a -> Actions a : [ LookAheadM b a' | a' <- shrink a]
+ LookAheadE b a -> Actions a : [ LookAheadE b a' | a' <- shrink a]
Try [Fail] b -> Actions b : [ Try [Fail] b' | b' <- shrink b ]
Try a b ->
(if not (willFail a) then [Actions a] else [])
@@ -49,9 +53,13 @@ willFail (x:xs) =
Try a b -> (willFail a && willFail b) || willFail xs
LookAhead a -> willFail a || willFail xs
LookAheadM _ a -> willFail a || willFail xs
+ LookAheadE _ a -> willFail a || willFail xs
BytesRead -> willFail xs
Fail -> True
+-- | The maximum length of input decoder can request.
+-- The decoder may end up using less, but never more.
+-- This way, you know how much input to generate for running a decoder test.
max_len :: [Action] -> Int
max_len [] = 0
max_len (x:xs) =
@@ -65,7 +73,12 @@ max_len (x:xs) =
LookAheadM b a | willFail a -> max_len a
| b -> max_len a + max_len xs
| otherwise -> max (max_len a) (max_len xs)
+ LookAheadE b a | willFail a -> max_len a
+ | b -> max_len a + max_len xs
+ | otherwise -> max (max_len a) (max_len xs)
+-- | The actual length of input that will be consumed when
+-- a decoder is executed, or Nothing if the decoder will fail.
actual_len :: [Action] -> Maybe Int
actual_len [] = Just 0
actual_len (x:xs) =
@@ -79,6 +92,9 @@ actual_len (x:xs) =
LookAheadM b a | willFail a -> Nothing
| b -> (+) <$> actual_len a <*> rest
| otherwise -> rest
+ LookAheadE b a | willFail a -> Nothing
+ | b -> (+) <$> actual_len a <*> rest
+ | otherwise -> rest
Try a b | not (willFail a) -> (+) <$> actual_len a <*> rest
| not (willFail b) -> (+) <$> actual_len b <*> rest
| otherwise -> Nothing
@@ -128,18 +144,27 @@ eval str = go 0
_ <- Binary.lookAhead (go pos a)
go pos xs
LookAheadM b a -> do
- let f True = leg pos a
+ let f True = Just <$> leg pos a
f False = go pos a >> return Nothing
len <- Binary.lookAheadM (f b)
case len of
Nothing -> go pos xs
Just offset -> go (pos+offset) xs
- Try a b -> do
- len <- leg pos a <|> leg pos b
+ LookAheadE b a -> do
+ let f True = Right <$> leg pos a
+ f False = go pos a >> return (Left ())
+ len <- Binary.lookAheadE (f b)
case len of
- Nothing -> error "got Nothing, but we're still here..."
- Just offset -> go (pos+offset) xs
- leg pos t = go pos t >> return (actual_len t)
+ Left _ -> go pos xs
+ Right offset -> go (pos+offset) xs
+ Try a b -> do
+ offset <- leg pos a <|> leg pos b
+ go (pos+offset) xs
+ leg pos t = do
+ go pos t
+ case actual_len t of
+ Nothing -> error "impossible: branch should have failed"
+ Just offset -> return offset
gen_actions :: Gen [Action]
gen_actions = sized (go False)
@@ -157,4 +182,7 @@ gen_actions = sized (go False)
, do t <- go inTry (s`div`2)
b <- arbitrary
(:) (LookAheadM b t) <$> go inTry (s-1)
+ , do t <- go inTry (s`div`2)
+ b <- arbitrary
+ (:) (LookAheadE b t) <$> go inTry (s-1)
] ++ [ return [Fail] | inTry ]
\ No newline at end of file
More information about the ghc-commits
mailing list