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

1 files changed, 36 insertions, 12 deletions

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