From f85232947e74ee7ef8c7b0ad2338212e7e68f1be Mon Sep 17 00:00:00 2001 From: krasimir Date: Sun, 13 Dec 2009 18:50:29 +0000 Subject: reorganize the directories under src, and rescue the JavaScript interpreter from deprecated --- src/runtime/haskell/PGF/Binary.hs | 199 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 199 insertions(+) create mode 100644 src/runtime/haskell/PGF/Binary.hs (limited to 'src/runtime/haskell/PGF/Binary.hs') diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs new file mode 100644 index 000000000..e4ed98424 --- /dev/null +++ b/src/runtime/haskell/PGF/Binary.hs @@ -0,0 +1,199 @@ +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 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 (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 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 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 (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 + +instance Binary ParserInfo where + put p = put (functions p, sequences p, productions0 p, totalCats p, startCats p) + get = do functions <- get + sequences <- get + productions0<- get + totalCats <- get + startCats <- get + return (ParserInfo{functions=functions,sequences=sequences + ,productions0=productions0 + ,productions =filterProductions productions0 + ,totalCats=totalCats,startCats=startCats}) + +decodingError = fail "This PGF file was compiled with different version of GF" -- cgit v1.2.3