diff options
| author | krasimir <krasimir@chalmers.se> | 2008-10-28 15:40:10 +0000 |
|---|---|---|
| committer | krasimir <krasimir@chalmers.se> | 2008-10-28 15:40:10 +0000 |
| commit | e6bb0a8edaf41ce19b8876a9ddb4a06f89f6be46 (patch) | |
| tree | 9078e043078a5ea86b61648cfa77a29c56770dac /src | |
| parent | 4448f92c236abe63a1c0596635963fe7fb6ce5ca (diff) | |
forgot to add PGF.Binary
Diffstat (limited to 'src')
| -rw-r--r-- | src/PGF/Binary.hs | 170 |
1 files changed, 170 insertions, 0 deletions
diff --git a/src/PGF/Binary.hs b/src/PGF/Binary.hs new file mode 100644 index 000000000..6ab1bcb33 --- /dev/null +++ b/src/PGF/Binary.hs @@ -0,0 +1,170 @@ +module PGF.Binary where
+
+import PGF.CId
+import PGF.Data
+import Data.Binary
+import Data.Binary.Put
+import Data.Binary.Get
+import qualified Data.ByteString as BS
+import qualified Data.Map as Map
+import Control.Monad
+import Debug.Trace
+
+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 (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, lins cnc, opers cnc
+ , lincats cnc, lindefs cnc
+ , printnames cnc, paramlincats cnc
+ , parser cnc
+ )
+ get = do cflags <- get
+ lins <- get
+ opers <- get
+ lincats <- get
+ lindefs <- get
+ printnames <- get
+ paramlincats <- get
+ parser <- get
+ return (Concr{ cflags=cflags, lins=lins, opers=opers
+ , lincats=lincats, lindefs=lindefs
+ , printnames=printnames
+ , paramlincats=paramlincats
+ , parser=parser
+ })
+
+instance Binary Tokn where
+ put (KS s) = putWord8 0 >> trace (show s) (put s)
+ put (KP d vs) = putWord8 1 >> put (d,vs)
+ get = do tag <- getWord8
+ case tag of
+ 0 -> do s <- get
+ trace (show s) $ return (KS s)
+ 1 -> liftM2 KP get get
+
+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 t) = putWord8 9 >> put t
+ 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 get
+
+instance Binary Expr where
+ put (EAbs x exp) = putWord8 0 >> put (x,exp)
+ put (EApp e1 e2) = putWord8 1 >> put (e1,e2)
+ put (EVar x) = putWord8 2 >> put x
+ put (ELit (LStr s)) = putWord8 3 >> put s
+ put (ELit (LFlt d)) = putWord8 4 >> put d
+ put (ELit (LInt i)) = putWord8 5 >> put i
+ put (EMeta i) = putWord8 6 >> put i
+ put (EEq eqs) = putWord8 7 >> put eqs
+ get = do tag <- getWord8
+ case tag of
+ 0 -> liftM2 EAbs get get
+ 1 -> liftM2 EApp get get
+ 2 -> liftM EVar get
+ 3 -> liftM (ELit . LStr) get
+ 4 -> liftM (ELit . LFlt) get
+ 5 -> liftM (ELit . LInt) get
+ 6 -> liftM EMeta get
+ 7 -> liftM EEq get
+
+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 Hypo where
+ put (Hyp v t) = put (v,t)
+ get = liftM2 Hyp get get
+
+instance Binary FFun where
+ put (FFun fun prof lins) = put (fun,prof,lins)
+ get = liftM3 FFun get 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 (FSymTok t) = putWord8 2 >> put t
+ get = do tag <- getWord8
+ case tag of
+ 0 -> liftM2 FSymCat get get
+ 1 -> liftM2 FSymLit get get
+ 2 -> liftM FSymTok get
+
+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
+
+instance Binary ParserInfo where
+ put p = put (functions p, sequences p, productions p, totalCats p, startCats p)
+ get = do functions <- get
+ sequences <- get
+ productions <- get
+ totalCats <- get
+ startCats <- get
+ return (ParserInfo{functions=functions,sequences=sequences,productions=productions
+ ,totalCats=totalCats,startCats=startCats})
|