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

gf.cabal

@@ -10,7 +10,7 @@ synopsis: Grammatical Framework
 description: GF, Grammatical Framework, is a programming language for multilingual grammar applications
 homepage: http://www.grammaticalframework.org/
 bug-reports: http://code.google.com/p/grammatical-framework/issues/list
-tested-with: GHC==7.4.2, GHC==7.6.2
+tested-with: GHC==7.4.2, GHC==7.6.3
 
 data-dir: src
 data-files: www/*.html
@@ -53,6 +53,10 @@ flag new-comp
   Description: Make -new-comp the default
   Default:     True
 
+flag custom-binary
+  Description: Use a customised version of the binary package
+  Default:     True
+
 library
   build-depends: base >= 4.2 && <5,
                  array,
@@ -63,6 +67,19 @@ library
                  pretty,
                  mtl
   hs-source-dirs: src/compiler src/runtime/haskell
+
+  if flag(custom-binary)
+    hs-source-dirs: src/binary
+    other-modules:
+      -- not really part of GF but I have changed the original binary library
+      -- and we have to keep the copy for now.
+      Data.Binary
+      Data.Binary.Put
+      Data.Binary.Get
+      Data.Binary.Builder
+  else
+    build-depends: binary
+
   extensions: 
   exposed-modules: 
     PGF
@@ -94,13 +111,6 @@ library
     GF.Data.ErrM
     GF.Data.Relation
     GF.Data.Operations
--- not really part of GF but I have changed the original binary library
--- and we have to keep the copy for now.
-    Data.Binary
-    Data.Binary.Put
-    Data.Binary.Get
-    Data.Binary.Builder
-    Data.Binary.IEEE754
 
 executable gf
   build-depends: base >= 4.2 && <5,
@@ -143,6 +153,13 @@ executable gf
   if impl(ghc>=7.0)
     ghc-options: -rtsopts
   hs-source-dirs: src/compiler src/runtime/haskell
+
+  if flag(custom-binary)
+    hs-source-dirs: src/binary
+    other-modules: Data.Binary.IEEE754
+  else
+    build-depends: binary, data-binary-ieee754
+
   extensions:
   main-is: GF.hs
   other-modules:
@@ -221,7 +238,6 @@ executable gf
     PGF.Binary
     PGF.Paraphrase
     PGF.TypeCheck
-    PGF.Binary
     PGF.Printer
     PGF.Optimize
     GFC

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
+--putGFOVersion = mapM_ (putWord8 . fromIntegral . ord) gfoVersion
-getGFOVersion = replicateM (length gfoVersion) (fmap (chr . fromIntegral) getWord8)
+--getGFOVersion = replicateM (length gfoVersion) (fmap (chr . fromIntegral) getWord8)
+--putGFOVersion = put gfoVersion
+--getGFOVersion = get :: Get VersionMagic
+
+
+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 = decodeFile' fpath (getGFOVersion >> get)
+decodeModule fpath = check =<< decodeFile' fpath
-
+  where
-decodeModuleHeader fpath = decodeFile' fpath getVersionedMod
+    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 =
+encodeModule fpath mo = encodeFile fpath (Tagged mo)
-  encodeFile_ fpath (putGFOVersion >> put mo)
 
--- | like decodeFile_ but adds file name to error message if there was an error
+-- | like 'decodeFile' but adds file name to error message if there was an error
-decodeFile' fpath get = addFPath fpath (decodeFile_ fpath get)
+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