summaryrefslogtreecommitdiff
path: root/src/runtime
diff options
context:
space:
mode:
Diffstat (limited to 'src/runtime')
-rw-r--r--src/runtime/haskell/PGF/Binary.hs11
-rw-r--r--src/runtime/haskell/PGF/OldBinary.hs183
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++")"
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 14:42:43 +0000