From e0481e3b8a8b6de306cff4c0645c6d19ae443e9a Mon Sep 17 00:00:00 2001 From: hallgren Date: Tue, 17 Dec 2013 13:27:37 +0000 Subject: [PATCH] Add backward compatibility for reading old PGF files Some backwards incompatible changes were made to the PGF file format after the release of GF 3.5. This patch adds a module for reading PGF files in the old format. This means that old PGF files on the grammaticalframework.org server will continue to work after we install the latest version of GF. --- .ghci | 2 +- gf.cabal | 1 + src/runtime/haskell/PGF/Binary.hs | 11 +- src/runtime/haskell/PGF/OldBinary.hs | 183 +++++++++++++++++++++++++++ 4 files changed, 193 insertions(+), 4 deletions(-) create mode 100644 src/runtime/haskell/PGF/OldBinary.hs diff --git a/.ghci b/.ghci index 7f054b48e..2af14c533 100644 --- a/.ghci +++ b/.ghci @@ -1,2 +1,2 @@ :set -isrc/compiler -isrc/runtime/haskell -isrc/server -isrc/example-based -isrc/server/transfer -idist/build/autogen -idist/build/gf/gf-tmp -:set -optP-DSERVER_MODE -optP-DUSE_INTERRUPT -optP-DCC_LAZY -optP-include -optPdist/build/autogen/cabal_macros.h -odir dist/build/gf/gf-tmp -hidir dist/build/gf/gf-tmp -stubdir dist/build/gf/gf-tmp +:set -fwarn-unused-imports -optP-DSERVER_MODE -optP-DUSE_INTERRUPT -optP-DCC_LAZY -optP-include -optPdist/build/autogen/cabal_macros.h -odir dist/build/gf/gf-tmp -hidir dist/build/gf/gf-tmp -stubdir dist/build/gf/gf-tmp diff --git a/gf.cabal b/gf.cabal index 992d6f568..7cc7e2d28 100644 --- a/gf.cabal +++ b/gf.cabal @@ -109,6 +109,7 @@ Library PGF.Forest PGF.TrieMap PGF.VisualizeTree + PGF.OldBinary Executable gf build-depends: gf, diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs index e2403809e..4d4c53102 100644 --- a/src/runtime/haskell/PGF/Binary.hs +++ b/src/runtime/haskell/PGF/Binary.hs @@ -1,8 +1,9 @@ -module PGF.Binary where +module PGF.Binary(putSplitAbs) where import PGF.CId import PGF.Data import PGF.Optimize +import qualified PGF.OldBinary as Old import Data.Binary import Data.Binary.Put import Data.Binary.Get @@ -14,7 +15,7 @@ import qualified Data.IntMap as IntMap import Control.Monad pgfMajorVersion, pgfMinorVersion :: Word16 -(pgfMajorVersion, pgfMinorVersion) = (2,0) +version@(pgfMajorVersion, pgfMinorVersion) = (2,0) instance Binary PGF where put pgf = do putWord16be pgfMajorVersion @@ -24,7 +25,11 @@ instance Binary PGF where put (concretes pgf) get = do v1 <- getWord16be v2 <- getWord16be - gflags <- get + case (v1,v2) of + v | v==version -> getPGF' + | v==Old.version -> Old.getPGF' + +getPGF'=do gflags <- get (absname,abstract) <- get concretes <- get return $ updateProductionIndices $ diff --git a/src/runtime/haskell/PGF/OldBinary.hs b/src/runtime/haskell/PGF/OldBinary.hs new file mode 100644 index 000000000..55a1f1a5c --- /dev/null +++ b/src/runtime/haskell/PGF/OldBinary.hs @@ -0,0 +1,183 @@ +-- | Read PGF files created with GF 3.5 and a few older releases +module PGF.OldBinary(getPGF,getPGF',version) where + +import PGF.CId +import PGF.Data +import PGF.Optimize +import Data.Binary +import Data.Binary.Get +import Data.Array.IArray +import qualified Data.ByteString as BS +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap +import qualified Data.Set as Set +import Control.Monad + +pgfMajorVersion, pgfMinorVersion :: Word16 +version@(pgfMajorVersion, pgfMinorVersion) = (1,0) + +getPGF = do v1 <- getWord16be + v2 <- getWord16be + let v=(v1,v2) + if v==version + then getPGF' + else decodingError ("version "++show v++"/="++show version) + +getPGF'=do gflags <- getFlags + absname <- getCId + abstract <- getAbstract + concretes <- getMap getCId getConcr + return $ updateProductionIndices $ + (PGF{ gflags=gflags + , absname=absname, abstract=abstract + , concretes=concretes + }) + +getCId = liftM CId get + +getAbstract = + do aflags <- getFlags + funs <- getMap getCId getFun + cats <- getMap getCId getCat + return (Abstr{ aflags=aflags + , funs=fmap (\(w,x,y,z) -> (w,x,y,z,0)) funs + , cats=fmap (\(x,y) -> (x,y,0,0)) cats + , code=BS.empty + }) +getFun :: Get (Type,Int,Maybe [Equation],Double) +getFun = (,,,) `fmap` getType `ap` get `ap` getMaybe (getList getEquation) `ap` get + +getCat :: Get ([Hypo],[(Double, CId)]) +getCat = getPair (getList getHypo) (getList (getPair get getCId)) + +getFlags = getMap getCId getLiteral + +getConcr = + do cflags <- getFlags + printnames <- getMap getCId get + (scnt,seqs) <- getList' getSequence + (fcnt,cncfuns) <- getList' getCncFun + lindefs <- get + productions <- getIntMap (getSet getProduction) + cnccats <- getMap getCId getCncCat + totalCats <- get + let rseq = listToArray [SymCat 0 0] + rfun = CncFun (mkCId "linref") (listToArray [scnt]) + linrefs = IntMap.fromList [(i,[fcnt])|i<-[0..totalCats-1]] + return (Concr{ cflags=cflags, printnames=printnames + , sequences=toArray (scnt+1,seqs++[rseq]) + , cncfuns=toArray (fcnt+1,cncfuns++[rfun]) + , lindefs=lindefs, linrefs=linrefs + , productions=productions + , pproductions = IntMap.empty + , lproductions = Map.empty + , lexicon = IntMap.empty + , cnccats=cnccats, totalCats=totalCats + }) + +getExpr = + do tag <- getWord8 + case tag of + 0 -> liftM3 EAbs getBindType getCId getExpr + 1 -> liftM2 EApp getExpr getExpr + 2 -> liftM ELit getLiteral + 3 -> liftM EMeta get + 4 -> liftM EFun getCId + 5 -> liftM EVar get + 6 -> liftM2 ETyped getExpr getType + 7 -> liftM EImplArg getExpr + _ -> decodingError "getExpr" + +getPatt = + do tag <- getWord8 + case tag of + 0 -> liftM2 PApp getCId (getList getPatt) + 1 -> liftM PVar getCId + 2 -> liftM2 PAs getCId getPatt + 3 -> return PWild + 4 -> liftM PLit getLiteral + 5 -> liftM PImplArg getPatt + 6 -> liftM PTilde getExpr + _ -> decodingError "getPatt" + +getEquation = liftM2 Equ (getList getPatt) getExpr + +getType = liftM3 DTyp (getList getHypo) getCId (getList getExpr) +getHypo = (,,) `fmap` getBindType `ap` getCId `ap` getType + +getBindType = + do tag <- getWord8 + case tag of + 0 -> return Explicit + 1 -> return Implicit + _ -> decodingError "getBindType" + +getCncFun = liftM2 CncFun getCId (getArray get) + +getCncCat = liftM3 CncCat get get (getArray get) + +getSequence = listToArray `fmap` getSymbols + +getSymbols = concat `fmap` getList getSymbol + +getSymbol :: Get [Symbol] +getSymbol = + do tag <- getWord8 + case tag of + 0 -> (:[]) `fmap` liftM2 SymCat get get + 1 -> (:[]) `fmap` liftM2 SymLit get get + 2 -> (:[]) `fmap` liftM2 SymVar get get + 3 -> liftM (map SymKS) get + 4 -> (:[]) `fmap` liftM2 SymKP (getList getTokenSymbol) getAlternatives + _ -> decodingError ("getSymbol "++show tag) + +getAlternatives = getList (getPair (getList getTokenSymbol) get) + :: Get [([Symbol],[String])] +getTokenSymbol = fmap SymKS get + +--getTokens = unwords `fmap` get + +getPArg = get >>= \(hypos,fid) -> return (PArg (zip (repeat fidVar) hypos) fid) + +getProduction = + do tag <- getWord8 + case tag of + 0 -> liftM2 PApply get (getList getPArg) + 1 -> liftM PCoerce get + _ -> decodingError "getProduction" + +getLiteral = + do tag <- getWord8 + case tag of + 0 -> liftM LStr get + 1 -> liftM LInt get + 2 -> liftM LFlt get + _ -> decodingError "getLiteral" + + +getArray :: IArray a e => Get e -> Get (a Int e) +getArray get1 = toArray `fmap` getList' get1 + +toArray (n,xs) = listArray (0::Int,n-1) xs +listToArray xs = toArray (length xs,xs) + +getArray2 :: (IArray a1 (a2 Int e), IArray a2 e) => Get e -> Get (a1 Int (a2 Int e)) +getArray2 get1 = getArray (getArray get1) + +getList get1 = snd `fmap` getList' get1 + +getList' get1 = do n <- get :: Get Int + xs <- replicateM n get1 + return (n,xs) + +getMaybe get1 = + do isJust <- get + if isJust then fmap Just get1 else return Nothing + +getMap getK getV = Map.fromDistinctAscList `fmap` getList (getPair getK getV) +getIntMap getV = IntMap.fromDistinctAscList `fmap` getList (getPair get getV) +getSet getV = Set.fromDistinctAscList `fmap` getList getV + +getPair get1 get2 = (,) `fmap` get1 `ap` get2 + +decodingError explain = fail $ "Unable to read PGF file ("++explain++")"