forked from GitHub/gf-core
182 lines
6.0 KiB
Haskell
182 lines
6.0 KiB
Haskell
-- | 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.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,fmap (flip (,) []) y,z)) funs
|
|
, cats=fmap (\(x,y) -> (x,y,0)) cats
|
|
})
|
|
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 (fmap (:[]) 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++")"
|