diff options
| -rw-r--r-- | gf.cabal | 34 | ||||
| -rw-r--r-- | src/binary/Data/Binary.hs (renamed from src/runtime/haskell/Data/Binary.hs) | 0 | ||||
| -rw-r--r-- | src/binary/Data/Binary/Builder.hs (renamed from src/runtime/haskell/Data/Binary/Builder.hs) | 0 | ||||
| -rw-r--r-- | src/binary/Data/Binary/Get.hs (renamed from src/runtime/haskell/Data/Binary/Get.hs) | 0 | ||||
| -rw-r--r-- | src/binary/Data/Binary/IEEE754.lhs (renamed from src/runtime/haskell/Data/Binary/IEEE754.lhs) | 0 | ||||
| -rw-r--r-- | src/binary/Data/Binary/Put.hs (renamed from src/runtime/haskell/Data/Binary/Put.hs) | 0 | ||||
| -rw-r--r-- | src/compiler/GF/Grammar/Binary.hs | 48 |
7 files changed, 61 insertions, 21 deletions
@@ -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 index 4b3f06a80..4b3f06a80 100644 --- a/src/runtime/haskell/Data/Binary.hs +++ b/src/binary/Data/Binary.hs diff --git a/src/runtime/haskell/Data/Binary/Builder.hs b/src/binary/Data/Binary/Builder.hs index 20e287237..20e287237 100644 --- a/src/runtime/haskell/Data/Binary/Builder.hs +++ b/src/binary/Data/Binary/Builder.hs diff --git a/src/runtime/haskell/Data/Binary/Get.hs b/src/binary/Data/Binary/Get.hs index 728720b3e..728720b3e 100644 --- a/src/runtime/haskell/Data/Binary/Get.hs +++ b/src/binary/Data/Binary/Get.hs diff --git a/src/runtime/haskell/Data/Binary/IEEE754.lhs b/src/binary/Data/Binary/IEEE754.lhs index 96cbefc5a..96cbefc5a 100644 --- a/src/runtime/haskell/Data/Binary/IEEE754.lhs +++ b/src/binary/Data/Binary/IEEE754.lhs diff --git a/src/runtime/haskell/Data/Binary/Put.hs b/src/binary/Data/Binary/Put.hs index a1f78dfba..a1f78dfba 100644 --- a/src/runtime/haskell/Data/Binary/Put.hs +++ b/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
-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
|