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.

2 files changed, 191 insertions, 3 deletions

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++")"