mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
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.
This commit is contained in:
hallgren
2
.ghci
2
.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
|
||||
|
||||
1
gf.cabal
1
gf.cabal
@@ -109,6 +109,7 @@ Library
|
||||
PGF.Forest
|
||||
PGF.TrieMap
|
||||
PGF.VisualizeTree
|
||||
PGF.OldBinary
|
||||
|
||||
Executable gf
|
||||
build-depends: gf,
|
||||
|
||||
@@ -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 $
|
||||
|
||||
183
src/runtime/haskell/PGF/OldBinary.hs
Normal file
183
src/runtime/haskell/PGF/OldBinary.hs
Normal file
@@ -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++")"
|
||||
Reference in New Issue
Block a user