From 97c3579a60e07866c9efaaa11d4b915424a43868 Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Mon, 9 Aug 2004 11:03:04 +0000
Subject: [haddock @ 2004-08-09 11:03:04 by simonmar] Add FormatVersion
Patch submitted by: George Russell <ger@informatik.uni-bremen.de>
---
src/Binary.hs | 69 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1 file changed, 69 insertions(+)
diff --git a/src/Binary.hs b/src/Binary.hs
index e0a31e11..092d29f2 100644
--- a/src/Binary.hs
+++ b/src/Binary.hs
@@ -53,6 +53,9 @@ module Binary
-- re-export for the benefit of other modules.
openBinaryFile
+ FormatVersion,
+ nullFormatVersion,
+ mkFormatVersion,
) where
#include "MachDeps.h"
@@ -315,6 +318,20 @@ getWord8 (BinIO _ ix_r h) = do
writeFastMutInt ix_r (ix+1)
return $! (fromIntegral (ord c)) -- XXX not really correct
+-- | Get the next byte, but don't change the pointer.
+peekWord8 :: BinHandle -> IO Word8
+peekWord8 (BinMem _ ix_r sz_r0 arr_r0) = do
+ ix <- readFastMutInt ix_r
+ sz <- readFastMutInt sz_r0
+ when (ix >= sz) $
+ ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
+ arr <- readIORef arr_r0
+ w <- unsafeRead arr ix
+ return w
+peekWord8 (BinIO _ ix_r h) = do
+ c <- hLookAhead h
+ return $! (fromIntegral (ord c)) -- XXX not really correct
+
putByte :: BinHandle -> Word8 -> IO ()
putByte bh w = put_ bh w
@@ -496,6 +513,17 @@ instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary
f <- get bh
return (a,b,c,d,e,f)
+instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f,Binary g) => Binary (a,b,c,d,e,f,g) where
+ put_ bh (a,b,c,d,e,f,g) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; put_ bh g
+ get bh = do a <- get bh
+ b <- get bh
+ c <- get bh
+ d <- get bh
+ e <- get bh
+ f <- get bh
+ g <- get bh
+ return (a,b,c,d,e,f,g)
+
instance Binary a => Binary (Maybe a) where
put_ bh Nothing = putByte bh 0
put_ bh (Just a) = do putByte bh 1; put_ bh a
@@ -618,3 +646,44 @@ lazyGet bh = do
a <- unsafeInterleaveIO (getAt bh p_a)
seekBin bh p -- skip over the object for now
return a
+
+-- -----------------------------------------------------------------------------
+-- FormatVersion's.
+-- The FormatVersion is always non-negative. Furthermore, if the
+-- FormatVersion is 0, nothing is output.
+--
+-- FormatVersion should only be encoded before something we KNOW to have
+-- an encoding which never begins with a negative byte, such as a non-negative
+-- integer or a list.
+--
+-- The advantage of this is that we can read a FormatVersion (which will
+-- be the nullFormatVersion) even when we didn't write one in the first
+-- place, such as from earlier versions of this program, just so long
+-- as we did at any rate write a list.
+
+newtype FormatVersion = FormatVersion Int deriving (Eq,Ord)
+
+nullFormatVersion :: FormatVersion
+nullFormatVersion = mkFormatVersion 0
+
+mkFormatVersion :: Int -> FormatVersion
+mkFormatVersion i = FormatVersion i
+
+instance Binary FormatVersion where
+ put_ bh (FormatVersion i) =
+ case compare i 0 of
+ EQ -> return ()
+ GT -> put_ bh (-i)
+ LT -> error (
+ "Binary.hs: negative FormatVersion " ++ show i
+ ++ " is not allowed")
+ get bh =
+ do
+ w8 <- peekWord8 bh
+ if testBit w8 7
+ then
+ do
+ i <- get bh
+ return (FormatVersion (-i))
+ else
+ return nullFormatVersion
--
cgit v1.2.3