From 83a10ce25a2c92fec24400773aca640a873fb2e8 Mon Sep 17 00:00:00 2001
From: hallgren <hallgren@chalmers.se>
Date: Thu, 31 Oct 2013 15:43:12 +0000
Subject: Add a cabal flag to use the standard binary package

The standard binary package has improved efficiency and error handling [1], so
in the long run we should consider switching to it. At the moment, using it is
possible but not recommended, since it results in incomatible PGF files.

The modified modules from the binary package have been moved from
src/runtime/haskell to src/binary.

[1] http://lennartkolmodin.blogspot.se/2013/03/binary-07.html
---
 src/compiler/GF/Grammar/Binary.hs | 48 +++++++++++++++++++++++++++++----------
 1 file changed, 36 insertions(+), 12 deletions(-)

(limited to 'src/compiler')

diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs
index 34cb153d2..ba12fde06 100644
--- a/src/compiler/GF/Grammar/Binary.hs
+++ b/src/compiler/GF/Grammar/Binary.hs
@@ -7,7 +7,7 @@
 --
 -----------------------------------------------------------------------------
 
-module GF.Grammar.Binary where
+module GF.Grammar.Binary(decodeModule,decodeModuleHeader,encodeModule) where
 
 import Prelude hiding (catch)
 import Control.Exception(catch,ErrorCall(..),throwIO)
@@ -28,7 +28,6 @@ import PGF.Binary
 -- Please change this every time when the GFO format is changed
 gfoVersion = "GF02"
 
-
 instance Binary Ident where
   put id = put (ident2bs id)
   get    = do bs <- get
@@ -295,13 +294,32 @@ instance Binary RawIdent where
   put = put . rawId2bs
   get = fmap rawIdentC get
 
-putGFOVersion = mapM_ (putWord8 . fromIntegral . ord) gfoVersion
-getGFOVersion = replicateM (length gfoVersion) (fmap (chr . fromIntegral) getWord8)
+--putGFOVersion = mapM_ (putWord8 . fromIntegral . ord) gfoVersion
+--getGFOVersion = replicateM (length gfoVersion) (fmap (chr . fromIntegral) getWord8)
+--putGFOVersion = put gfoVersion
+--getGFOVersion = get :: Get VersionMagic
 
-decodeModule :: FilePath -> IO SourceModule
-decodeModule fpath = decodeFile' fpath (getGFOVersion >> get)
 
-decodeModuleHeader fpath = decodeFile' fpath getVersionedMod
+data VersionTagged a = Tagged {unV::a} | WrongVersion
+
+instance Binary a => Binary (VersionTagged a) where
+  put (Tagged a) = put (gfoBinVersion,a)
+  get = do ver <- get
+           if ver==gfoBinVersion
+             then fmap Tagged get
+             else return WrongVersion
+
+gfoBinVersion = (b1,b2,b3,b4)
+  where [b1,b2,b3,b4] = map (toEnum.fromEnum) gfoVersion :: [Word8]
+
+
+decodeModule :: FilePath -> IO SourceModule
+decodeModule fpath = check =<< decodeFile' fpath
+  where
+    check (Tagged m) = return m
+    check _ = fail ".gfo file version mismatch"
+{-
+decodeModuleHeader fpath = decodeFile_ fpath getVersionedMod
   where
     getVersionedMod = do
       ver <- getGFOVersion
@@ -309,13 +327,19 @@ decodeModuleHeader fpath = decodeFile' fpath getVersionedMod
         then do (m,mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc) <- get
                 return (Just (m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Nothing Map.empty))
         else return Nothing
-
+--}
+--{-
+decodeModuleHeader fpath = fmap check $ decodeFile' fpath
+  where
+    check (Tagged (m,mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc)) =
+        (Just (m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Nothing Map.empty))
+    check _ = Nothing
+--}
 encodeModule :: FilePath -> SourceModule -> IO ()
-encodeModule fpath mo =
-  encodeFile_ fpath (putGFOVersion >> put mo)
+encodeModule fpath mo = encodeFile fpath (Tagged mo)
 
--- | like decodeFile_ but adds file name to error message if there was an error
-decodeFile' fpath get = addFPath fpath (decodeFile_ fpath get)
+-- | like 'decodeFile' but adds file name to error message if there was an error
+decodeFile' fpath = addFPath fpath (decodeFile fpath)
 
 -- | Adds file name to error message if there was an error,
 -- | but laziness can cause errors to slip through
-- 
cgit v1.2.3