mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-08 10:42:50 -06:00
cleanup the code of the PGF interpreter and polish the binary serialization to match the preliminary specification
This commit is contained in:
krasimir
@@ -6,6 +6,7 @@ import PGF.Macros
|
||||
import Data.Binary
|
||||
import Data.Binary.Put
|
||||
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
|
||||
@@ -16,23 +17,20 @@ 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
|
||||
)
|
||||
put pgf = do putWord16be pgfMajorVersion
|
||||
putWord16be pgfMinorVersion
|
||||
put (gflags pgf)
|
||||
put (absname pgf, abstract pgf)
|
||||
put (concretes pgf)
|
||||
get = do v1 <- getWord16be
|
||||
v2 <- getWord16be
|
||||
absname <- get
|
||||
cncnames <- get
|
||||
gflags <- get
|
||||
abstract <- get
|
||||
(absname,abstract) <- get
|
||||
concretes <- get
|
||||
return $ updateProductionIndices $
|
||||
(PGF{ absname=absname, cncnames=cncnames
|
||||
, gflags=gflags
|
||||
, abstract=abstract, concretes=concretes
|
||||
(PGF{ gflags=gflags
|
||||
, absname=absname, abstract=abstract
|
||||
, concretes=concretes
|
||||
})
|
||||
|
||||
instance Binary CId where
|
||||
@@ -44,35 +42,35 @@ instance Binary Abstr where
|
||||
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
|
||||
, catfuns=Map.empty
|
||||
})
|
||||
|
||||
instance Binary Concr where
|
||||
put cnc = put ( cflags cnc, printnames cnc
|
||||
, functions cnc, sequences cnc
|
||||
, productions cnc
|
||||
, totalCats cnc, startCats cnc
|
||||
)
|
||||
put cnc = do put (cflags cnc)
|
||||
put (printnames cnc)
|
||||
putArray2 (sequences cnc)
|
||||
putArray (cncfuns cnc)
|
||||
put (productions cnc)
|
||||
put (cnccats cnc)
|
||||
put (totalCats cnc)
|
||||
get = do cflags <- get
|
||||
printnames <- get
|
||||
functions <- get
|
||||
sequences <- get
|
||||
sequences <- getArray2
|
||||
cncfuns <- getArray
|
||||
productions <- get
|
||||
cnccats <- get
|
||||
totalCats <- get
|
||||
startCats <- get
|
||||
return (Concr{ cflags=cflags, printnames=printnames
|
||||
, functions=functions,sequences=sequences
|
||||
, productions = productions
|
||||
, sequences=sequences, cncfuns=cncfuns, productions=productions
|
||||
, pproductions = IntMap.empty
|
||||
, lproductions = Map.empty
|
||||
, totalCats=totalCats,startCats=startCats
|
||||
, cnccats=cnccats, totalCats=totalCats
|
||||
})
|
||||
|
||||
instance Binary Alternative where
|
||||
put (Alt v x) = put v >> put x
|
||||
put (Alt v x) = put (v,x)
|
||||
get = liftM2 Alt get get
|
||||
|
||||
instance Binary Term where
|
||||
@@ -106,41 +104,37 @@ instance Binary Term where
|
||||
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)
|
||||
put (ELit l) = putWord8 2 >> put l
|
||||
put (EMeta i) = putWord8 3 >> put i
|
||||
put (EFun f) = putWord8 4 >> put f
|
||||
put (EVar i) = putWord8 5 >> put i
|
||||
put (ETyped e ty) = putWord8 6 >> put (e,ty)
|
||||
put (EImplArg e) = putWord8 7 >> put e
|
||||
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
|
||||
2 -> liftM ELit get
|
||||
3 -> liftM EMeta get
|
||||
4 -> liftM EFun get
|
||||
5 -> liftM EVar get
|
||||
6 -> liftM2 ETyped get get
|
||||
7 -> liftM EImplArg 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
|
||||
put (PApp f ps) = putWord8 0 >> put (f,ps)
|
||||
put (PVar x) = putWord8 1 >> put x
|
||||
put PWild = putWord8 2
|
||||
put (PLit l) = putWord8 3 >> put l
|
||||
put (PImplArg p) = putWord8 4 >> put p
|
||||
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
|
||||
3 -> liftM PLit get
|
||||
4 -> liftM PImplArg get
|
||||
_ -> decodingError
|
||||
|
||||
instance Binary Equation where
|
||||
@@ -160,30 +154,65 @@ instance Binary BindType where
|
||||
1 -> return Implicit
|
||||
_ -> decodingError
|
||||
|
||||
instance Binary FFun where
|
||||
put (FFun fun lins) = put (fun,lins)
|
||||
get = liftM2 FFun get get
|
||||
instance Binary CncFun where
|
||||
put (CncFun fun lins) = put fun >> putArray lins
|
||||
get = liftM2 CncFun get getArray
|
||||
|
||||
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)
|
||||
instance Binary CncCat where
|
||||
put (CncCat s e labels) = do put (s,e)
|
||||
putArray labels
|
||||
get = liftM3 CncCat get get getArray
|
||||
|
||||
instance Binary Symbol where
|
||||
put (SymCat n l) = putWord8 0 >> put (n,l)
|
||||
put (SymLit n l) = putWord8 1 >> put (n,l)
|
||||
put (SymKS ts) = putWord8 2 >> put ts
|
||||
put (SymKP 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
|
||||
0 -> liftM2 SymCat get get
|
||||
1 -> liftM2 SymLit get get
|
||||
2 -> liftM SymKS get
|
||||
3 -> liftM2 (\d vs -> SymKP 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
|
||||
put (PApply ruleid args) = putWord8 0 >> put (ruleid,args)
|
||||
put (PCoerce fcat) = putWord8 1 >> put fcat
|
||||
get = do tag <- getWord8
|
||||
case tag of
|
||||
0 -> liftM2 FApply get get
|
||||
1 -> liftM FCoerce get
|
||||
0 -> liftM2 PApply get get
|
||||
1 -> liftM PCoerce get
|
||||
_ -> decodingError
|
||||
|
||||
instance Binary Literal where
|
||||
put (LStr s) = putWord8 0 >> put s
|
||||
put (LInt i) = putWord8 1 >> put i
|
||||
put (LFlt d) = putWord8 2 >> put d
|
||||
get = do tag <- getWord8
|
||||
case tag of
|
||||
0 -> liftM LStr get
|
||||
1 -> liftM LFlt get
|
||||
2 -> liftM LInt get
|
||||
_ -> decodingError
|
||||
|
||||
|
||||
putArray :: (Binary e, IArray a e) => a Int e -> Put
|
||||
putArray a = do put (rangeSize $ bounds a) -- write the length
|
||||
mapM_ put (elems a) -- now the elems.
|
||||
|
||||
getArray :: (Binary e, IArray a e) => Get (a Int e)
|
||||
getArray = do n <- get -- read the length
|
||||
xs <- replicateM n get -- now the elems.
|
||||
return (listArray (0,n-1) xs)
|
||||
|
||||
putArray2 :: (Binary e, IArray a1 (a2 Int e), IArray a2 e) => a1 Int (a2 Int e) -> Put
|
||||
putArray2 a = do put (rangeSize $ bounds a) -- write the length
|
||||
mapM_ putArray (elems a) -- now the elems.
|
||||
|
||||
getArray2 :: (Binary e, IArray a1 (a2 Int e), IArray a2 e) => Get (a1 Int (a2 Int e))
|
||||
getArray2 = do n <- get -- read the length
|
||||
xs <- replicateM n getArray -- now the elems.
|
||||
return (listArray (0,n-1) xs)
|
||||
|
||||
decodingError = fail "This PGF file was compiled with different version of GF"
|
||||
|
||||
Reference in New Issue
Block a user