From 83a10ce25a2c92fec24400773aca640a873fb2e8 Mon Sep 17 00:00:00 2001 From: hallgren Date: Thu, 31 Oct 2013 15:43:12 +0000 Subject: [PATCH] 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 | 34 +++++++++---- .../haskell => binary}/Data/Binary.hs | 0 .../haskell => binary}/Data/Binary/Builder.hs | 0 .../haskell => binary}/Data/Binary/Get.hs | 0 .../Data/Binary/IEEE754.lhs | 0 .../haskell => binary}/Data/Binary/Put.hs | 0 src/compiler/GF/Grammar/Binary.hs | 48 ++++++++++++++----- 7 files changed, 61 insertions(+), 21 deletions(-) rename src/{runtime/haskell => binary}/Data/Binary.hs (100%) rename src/{runtime/haskell => binary}/Data/Binary/Builder.hs (100%) rename src/{runtime/haskell => binary}/Data/Binary/Get.hs (100%) rename src/{runtime/haskell => binary}/Data/Binary/IEEE754.lhs (100%) rename src/{runtime/haskell => binary}/Data/Binary/Put.hs (100%) diff --git a/gf.cabal b/gf.cabal index cec15550b..7922eb556 100644 --- a/gf.cabal +++ b/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 diff --git a/src/runtime/haskell/Data/Binary.hs b/src/binary/Data/Binary.hs similarity index 100% rename from src/runtime/haskell/Data/Binary.hs rename to src/binary/Data/Binary.hs diff --git a/src/runtime/haskell/Data/Binary/Builder.hs b/src/binary/Data/Binary/Builder.hs similarity index 100% rename from src/runtime/haskell/Data/Binary/Builder.hs rename to src/binary/Data/Binary/Builder.hs diff --git a/src/runtime/haskell/Data/Binary/Get.hs b/src/binary/Data/Binary/Get.hs similarity index 100% rename from src/runtime/haskell/Data/Binary/Get.hs rename to src/binary/Data/Binary/Get.hs diff --git a/src/runtime/haskell/Data/Binary/IEEE754.lhs b/src/binary/Data/Binary/IEEE754.lhs similarity index 100% rename from src/runtime/haskell/Data/Binary/IEEE754.lhs rename to src/binary/Data/Binary/IEEE754.lhs diff --git a/src/runtime/haskell/Data/Binary/Put.hs b/src/binary/Data/Binary/Put.hs similarity index 100% rename from src/runtime/haskell/Data/Binary/Put.hs rename to src/binary/Data/Binary/Put.hs 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 + + +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) - -decodeModuleHeader fpath = decodeFile' fpath getVersionedMod +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