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