Test behaviour between isolation modes

src/Data/Serialize/Get.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -128,7 +129,6 @@ import qualified Data.Tree                as T
 #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
 import GHC.Base
 import GHC.Word
-import Debug.Trace
 #endif
 
 -- | The result of a parse.
@@ -422,54 +422,64 @@ negativeIsolation = fail "Attempted to isolate a negative number of bytes"
 isolationUnderParse :: Get a
 isolationUnderParse =  fail "not all bytes parsed in isolate"
 
--- | Isolate an action to operating within a fixed block of bytes.  The action
---   is required to consume all the bytes that it is isolated to.
-isolate :: Int -> Get a -> Get a
-isolate 0 m = do
+isolationUnderSupply :: Get a
+isolationUnderSupply = failRaw "too few bytes" ["demandInput"]
+
+isolate0 :: Get a -> Get a
+isolate0 parser = do
   rest <- get
   cur <- bytesRead
   put mempty cur
-  a    <- m
+  a    <- parser
   put rest cur
   pure a
-isolate n m = do
-  M.when (n < 0) negativeIsolation
-  s <- ensure n
-  let (s',rest) = B.splitAt n s
-  cur <- bytesRead
-  put s' cur
-  a    <- m
-  used <- get
-  unless (B.null used) isolationUnderParse
-  put rest (cur + n)
-  return a
+
+-- | Isolate an action to operating within a fixed block of bytes.  The action
+--   is required to consume all the bytes that it is isolated to.
+isolate :: Int -> Get a -> Get a
+isolate n m
+  | n < 0 = negativeIsolation
+  | n == 0 = isolate0 m
+  | otherwise = do
+      s <- ensure n
+      let (s',rest) = B.splitAt n s
+      cur <- bytesRead
+      put s' cur
+      a    <- m
+      used <- get
+      unless (B.null used) isolationUnderParse
+      put rest (cur + n)
+      return a
 
 getAtMost :: Int -> Get B.ByteString
 getAtMost n = do
   (bs, rest) <- B.splitAt n <$> get
   curr <- bytesRead
-  unless (B.null rest) $ put rest (curr + B.length bs)
+  put rest (curr + B.length bs)
   pure bs
 
 -- | An incremental version of 'isolate', which doesn't try to read the input
 --   into a buffer all at once.
-isolateLazy :: forall a. Int -> Get a -> Get a
-isolateLazy n _ 
+isolateLazy :: forall a. Show a => Int -> Get a -> Get a
+isolateLazy n parser
   | n < 0 = negativeIsolation
+  | n == 0 = isolate0 parser
 isolateLazy n parser = go . runGetPartial parser =<< getAtMost n
   where
     go :: Result a -> Get a
     go r = case r of
       FailRaw (msg, stack) bs -> bytesRead >>= put bs >> failRaw msg stack
       Done a bs
-        | not (B.null bs) -> isolationUnderParse
         | otherwise -> do
             bytesRead' <- bytesRead
-            unless (bytesRead' == n) isolationUnderParse
-            -- fail $ "mismatch " ++ show (bytesRead', n)
+            -- Technically this is both undersupply, and underparse
+            -- buyt we use undersupply to match strict isolation
+            unless (bytesRead' == n) isolationUnderSupply
+            unless (B.null bs) isolationUnderParse
             pure a
       Partial cont -> do
-        bs <- getAtMost . (n -) =<< bytesRead
+        pos <- bytesRead
+        bs <- getAtMost $ n - pos
         go $ cont bs
 
 failRaw :: String -> [String] -> Get a
@@ -484,7 +494,6 @@ skip 0 = pure ()
 skip n = do
   s <- ensure n
   cur <- bytesRead
-  -- traceShow (n, s, cur) $
   put (B.drop n s) (cur + n)
 
 -- | Skip ahead up to @n@ bytes in the current chunk. No error if there aren't

tests/GetTests.hs

@@ -1,5 +1,6 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module GetTests (tests) where
 
@@ -17,6 +18,7 @@ import           Test.HUnit (Assertion, (@=?), assertFailure)
 import           Test.QuickCheck hiding (Result)
 import qualified Test.QuickCheck as QC
 import Data.List (isInfixOf)
+import Debug.Trace
 
 
 -- Data to express Get parser to generate
@@ -127,10 +129,12 @@ isEmpty2 = do
   pure True
 
 -- Compare with chunks
-(==~) :: Eq a => Get a -> Get a -> Property
+(==~) :: (Eq a, Show a) => Get a -> Get a -> Property
 p1 ==~ p2 =
   conjoin
-  [ counterexample (show in0) $ R (runGetLazy p1 s) == R (runGetLazy p2 s)
+  [ let rl = runGetLazy p1 s
+        rr = runGetLazy p2 s
+    in counterexample (show (in0, n, s, rl, rr)) $ R rl == R rr
   | n <- [0 .. testLength]
   , let Chunks in0 = mkChunks n
         s = LB.fromChunks [ BS.pack c | c <- in0 ]
@@ -294,14 +298,29 @@ isolateLazyLeavesRemainingBytes = go (runGetPartial parser $ BS.replicate 11 0)
       Fail failure _ -> unless (failStr `isInfixOf` failure) $ assertFailure "Wrong error!"
       Partial cont -> assertFailure "Asked for more input!"
 
-isolateAndIsolateLazy :: Int -> GetD -> Property
-isolateAndIsolateLazy n parser' = isolate n parser ==~ isolateLazy n parser
+instance Arbitrary LB.ByteString where
+  arbitrary = LB.fromChunks . pure . BS.pack <$> arbitrary
+
+newtype IsolationRes a = IRes (Either String a)
+  deriving Show
+
+-- Sometimes lazy and strict isolations return different errors,
+-- eg. when EOF is called before the end of an isolation which isn't prodided
+-- enough input.
+-- Strict sees it as a lack of bytes, Lazy sees it as a guard failure ("empty").
+instance Eq a => Eq (IsolationRes a) where
+  IRes a == IRes b = case (a, b) of
+    (Left e1, Left e2) -> e1 == e2 || errsEqAsymmetric e1 e2 || errsEqAsymmetric e2 e1
+    _ -> a == b
+    where
+      errsEqAsymmetric e1 e2 = "too few bytes" `isInfixOf` e1 && "empty" `isInfixOf` e2
+
+isolateAndIsolateLazy :: Int -> GetD -> LB.ByteString -> Property
+isolateAndIsolateLazy n parser' bs
+  = IRes (runGetLazy (isolate n parser) bs) === IRes (runGetLazy (isolateLazy n parser) bs)
   where
     parser = buildGet parser'
 
--- isolateLazyLeavesRemainingBytesAfterSuccess :: Assertion
--- isolateLazyLeavesRemainingBytesAfterSuccess = go
-
 isolateIsNotIncremental :: Assertion
 isolateIsNotIncremental = go (runGetPartial parser $ BS.replicate 11 0)
   where