mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-18 17:29:32 -06:00
190 lines
6.3 KiB
Haskell
190 lines
6.3 KiB
Haskell
module PGF.Binary where
|
|
|
|
import PGF.CId
|
|
import PGF.Data
|
|
import PGF.Macros
|
|
import Data.Binary
|
|
import Data.Binary.Put
|
|
import Data.Binary.Get
|
|
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
|
|
(pgfMajorVersion, pgfMinorVersion) = (1,0)
|
|
|
|
instance Binary PGF where
|
|
put pgf = putWord16be pgfMajorVersion >>
|
|
putWord16be pgfMinorVersion >>
|
|
put ( absname pgf, cncnames pgf
|
|
, gflags pgf
|
|
, abstract pgf, concretes pgf
|
|
)
|
|
get = do v1 <- getWord16be
|
|
v2 <- getWord16be
|
|
absname <- get
|
|
cncnames <- get
|
|
gflags <- get
|
|
abstract <- get
|
|
concretes <- get
|
|
return $ updateProductionIndices $
|
|
(PGF{ absname=absname, cncnames=cncnames
|
|
, gflags=gflags
|
|
, abstract=abstract, concretes=concretes
|
|
})
|
|
|
|
instance Binary CId where
|
|
put (CId bs) = put bs
|
|
get = liftM CId get
|
|
|
|
instance Binary Abstr where
|
|
put abs = put (aflags abs, funs abs, cats abs)
|
|
get = do aflags <- get
|
|
funs <- get
|
|
cats <- get
|
|
let catfuns = Map.mapWithKey (\cat _ -> [f | (f, (DTyp _ c _,_,_)) <- Map.toList funs, c==cat]) cats
|
|
return (Abstr{ aflags=aflags
|
|
, funs=funs, cats=cats
|
|
, catfuns=catfuns
|
|
})
|
|
|
|
instance Binary Concr where
|
|
put cnc = put ( cflags cnc, printnames cnc
|
|
, functions cnc, sequences cnc
|
|
, productions cnc
|
|
, totalCats cnc, startCats cnc
|
|
)
|
|
get = do cflags <- get
|
|
printnames <- get
|
|
functions <- get
|
|
sequences <- get
|
|
productions <- get
|
|
totalCats <- get
|
|
startCats <- get
|
|
return (Concr{ cflags=cflags, printnames=printnames
|
|
, functions=functions,sequences=sequences
|
|
, productions = productions
|
|
, pproductions = IntMap.empty
|
|
, lproductions = Map.empty
|
|
, totalCats=totalCats,startCats=startCats
|
|
})
|
|
|
|
instance Binary Alternative where
|
|
put (Alt v x) = put v >> put x
|
|
get = liftM2 Alt get get
|
|
|
|
instance Binary Term where
|
|
put (R es) = putWord8 0 >> put es
|
|
put (S es) = putWord8 1 >> put es
|
|
put (FV es) = putWord8 2 >> put es
|
|
put (P e v) = putWord8 3 >> put (e,v)
|
|
put (W e v) = putWord8 4 >> put (e,v)
|
|
put (C i ) = putWord8 5 >> put i
|
|
put (TM i ) = putWord8 6 >> put i
|
|
put (F f) = putWord8 7 >> put f
|
|
put (V i) = putWord8 8 >> put i
|
|
put (K (KS s)) = putWord8 9 >> put s
|
|
put (K (KP d vs)) = putWord8 10 >> put (d,vs)
|
|
|
|
get = do tag <- getWord8
|
|
case tag of
|
|
0 -> liftM R get
|
|
1 -> liftM S get
|
|
2 -> liftM FV get
|
|
3 -> liftM2 P get get
|
|
4 -> liftM2 W get get
|
|
5 -> liftM C get
|
|
6 -> liftM TM get
|
|
7 -> liftM F get
|
|
8 -> liftM V get
|
|
9 -> liftM (K . KS) get
|
|
10 -> liftM2 (\d vs -> K (KP d vs)) get get
|
|
_ -> decodingError
|
|
|
|
instance Binary Expr where
|
|
put (EAbs b x exp) = putWord8 0 >> put (b,x,exp)
|
|
put (EApp e1 e2) = putWord8 1 >> put (e1,e2)
|
|
put (ELit (LStr s)) = putWord8 2 >> put s
|
|
put (ELit (LFlt d)) = putWord8 3 >> put d
|
|
put (ELit (LInt i)) = putWord8 4 >> put i
|
|
put (EMeta i) = putWord8 5 >> put i
|
|
put (EFun f) = putWord8 6 >> put f
|
|
put (EVar i) = putWord8 7 >> put i
|
|
put (ETyped e ty) = putWord8 8 >> put (e,ty)
|
|
get = do tag <- getWord8
|
|
case tag of
|
|
0 -> liftM3 EAbs get get get
|
|
1 -> liftM2 EApp get get
|
|
2 -> liftM (ELit . LStr) get
|
|
3 -> liftM (ELit . LFlt) get
|
|
4 -> liftM (ELit . LInt) get
|
|
5 -> liftM EMeta get
|
|
6 -> liftM EFun get
|
|
7 -> liftM EVar get
|
|
8 -> liftM2 ETyped get get
|
|
_ -> decodingError
|
|
|
|
instance Binary Patt where
|
|
put (PApp f ps) = putWord8 0 >> put (f,ps)
|
|
put (PVar x) = putWord8 1 >> put x
|
|
put PWild = putWord8 2
|
|
put (PLit (LStr s)) = putWord8 3 >> put s
|
|
put (PLit (LFlt d)) = putWord8 4 >> put d
|
|
put (PLit (LInt i)) = putWord8 5 >> put i
|
|
get = do tag <- getWord8
|
|
case tag of
|
|
0 -> liftM2 PApp get get
|
|
1 -> liftM PVar get
|
|
2 -> return PWild
|
|
3 -> liftM (PLit . LStr) get
|
|
4 -> liftM (PLit . LFlt) get
|
|
5 -> liftM (PLit . LInt) get
|
|
_ -> decodingError
|
|
|
|
instance Binary Equation where
|
|
put (Equ ps e) = put (ps,e)
|
|
get = liftM2 Equ get get
|
|
|
|
instance Binary Type where
|
|
put (DTyp hypos cat exps) = put (hypos,cat,exps)
|
|
get = liftM3 DTyp get get get
|
|
|
|
instance Binary BindType where
|
|
put Explicit = putWord8 0
|
|
put Implicit = putWord8 1
|
|
get = do tag <- getWord8
|
|
case tag of
|
|
0 -> return Explicit
|
|
1 -> return Implicit
|
|
_ -> decodingError
|
|
|
|
instance Binary FFun where
|
|
put (FFun fun lins) = put (fun,lins)
|
|
get = liftM2 FFun get get
|
|
|
|
instance Binary FSymbol where
|
|
put (FSymCat n l) = putWord8 0 >> put (n,l)
|
|
put (FSymLit n l) = putWord8 1 >> put (n,l)
|
|
put (FSymKS ts) = putWord8 2 >> put ts
|
|
put (FSymKP d vs) = putWord8 3 >> put (d,vs)
|
|
get = do tag <- getWord8
|
|
case tag of
|
|
0 -> liftM2 FSymCat get get
|
|
1 -> liftM2 FSymLit get get
|
|
2 -> liftM FSymKS get
|
|
3 -> liftM2 (\d vs -> FSymKP d vs) get get
|
|
_ -> decodingError
|
|
|
|
instance Binary Production where
|
|
put (FApply ruleid args) = putWord8 0 >> put (ruleid,args)
|
|
put (FCoerce fcat) = putWord8 1 >> put fcat
|
|
get = do tag <- getWord8
|
|
case tag of
|
|
0 -> liftM2 FApply get get
|
|
1 -> liftM FCoerce get
|
|
_ -> decodingError
|
|
|
|
decodingError = fail "This PGF file was compiled with different version of GF"
|