module PGF.Binary(putSplitAbs) where import PGF.CId import PGF.Data import PGF.Optimize import PGF.ByteCode import qualified PGF.OldBinary as Old import Data.Binary import Data.Binary.Put 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) = (2,1) instance Binary PGF where put pgf = do putWord16be pgfMajorVersion putWord16be pgfMinorVersion put (gflags pgf) put (absname pgf, abstract pgf) put (concretes pgf) get = do major<- getWord16be minor <- getWord16be let v = (major,minor) if major==pgfMajorVersion && minor<=pgfMinorVersion then getPGF' else if v==Old.version then Old.getPGF' else fail $ "Unsupported PGF version "++show (major,minor) getPGF'=do gflags <- get (absname,abstract) <- get concretes <- get return $ updateProductionIndices $ (PGF{ gflags=gflags , absname=absname, abstract=abstract , concretes=concretes }) instance Binary CId where put (CId bs) = put bs get = liftM CId get instance Binary Abstr where put abs = do put (aflags abs) put (Map.map (\(ty,arity,mb_eq,prob) -> (ty,arity,fmap fst mb_eq,prob)) (funs abs)) put (cats abs) get = do aflags <- get funs <- get cats <- get return (Abstr{ aflags=aflags , funs=Map.map (\(ty,arity,mb_eq,prob) -> (ty,arity,fmap (\eq -> (eq,[])) mb_eq,prob)) funs , cats=cats }) putSplitAbs :: PGF -> Put putSplitAbs pgf = do putWord16be pgfMajorVersion putWord16be pgfMinorVersion put (Map.insert (mkCId "split") (LStr "true") (gflags pgf)) put (absname pgf, abstract pgf) put [(name,cflags cnc) | (name,cnc) <- Map.toList (concretes pgf)] instance Binary Concr where put cnc = do put (cflags cnc) put (printnames cnc) putArray2 (sequences cnc) putArray (cncfuns cnc) put (lindefs cnc) put (linrefs cnc) put (productions cnc) put (cnccats cnc) put (totalCats cnc) get = do cflags <- get printnames <- get sequences <- getArray2 cncfuns <- getArray lindefs <- get linrefs <- get productions <- get cnccats <- get totalCats <- get return (Concr{ cflags=cflags, printnames=printnames , sequences=sequences, cncfuns=cncfuns , lindefs=lindefs, linrefs=linrefs , productions=productions , pproductions = IntMap.empty , lproductions = Map.empty , lexicon = IntMap.empty , cnccats=cnccats, totalCats=totalCats }) 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 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 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 (PAs x p) = putWord8 2 >> put (x,p) put PWild = putWord8 3 put (PLit l) = putWord8 4 >> put l put (PImplArg p) = putWord8 5 >> put p put (PTilde p) = putWord8 6 >> put p get = do tag <- getWord8 case tag of 0 -> liftM2 PApp get get 1 -> liftM PVar get 2 -> liftM2 PAs get get 3 -> return PWild 4 -> liftM PLit get 5 -> liftM PImplArg get 6 -> liftM PTilde get _ -> decodingError instance Binary Equation where put (Equ ps e) = put (ps,e) get = liftM2 Equ get get instance Binary Instr where put (CHECK_ARGS n) = putWord8 0 >> put n put (CASE id l) = putWord8 4 >> put (id,l) put (CASE_LIT (LInt n) l) = putWord8 8 >> put (n,l) put (CASE_LIT (LStr s) l) = putWord8 9 >> put (s,l) put (CASE_LIT (LFlt d) l) = putWord8 10 >> put (d,l) put (SAVE n) = putWord8 12 >> put n put (ALLOC n) = putWord8 16 >> put n put (PUT_CONSTR id) = putWord8 20 >> put id put (PUT_CLOSURE l) = putWord8 24 >> put l put (PUT_LIT (LInt n)) = putWord8 28 >> put n put (PUT_LIT (LStr s)) = putWord8 29 >> put s put (PUT_LIT (LFlt d)) = putWord8 30 >> put d put (SET (HEAP n)) = putWord8 32 >> put n put (SET (ARG_VAR n)) = putWord8 33 >> put n put (SET (FREE_VAR n)) = putWord8 34 >> put n put (SET (GLOBAL id)) = putWord8 35 >> put id put (SET_PAD ) = putWord8 36 put (PUSH_FRAME ) = putWord8 40 put (PUSH (HEAP n)) = putWord8 44 >> put n put (PUSH (ARG_VAR n)) = putWord8 45 >> put n put (PUSH (FREE_VAR n)) = putWord8 46 >> put n put (PUSH (GLOBAL id)) = putWord8 47 >> put id put (TUCK (HEAP n) i) = putWord8 48 >> put (n,i) put (TUCK (ARG_VAR n) i) = putWord8 49 >> put (n,i) put (TUCK (FREE_VAR n) i) = putWord8 50 >> put (n,i) put (TUCK (GLOBAL id) i) = putWord8 51 >> put (id,i) put (EVAL (HEAP n) RecCall) = putWord8 52 >> put n put (EVAL (ARG_VAR n) RecCall) = putWord8 53 >> put n put (EVAL (FREE_VAR n) RecCall) = putWord8 54 >> put n put (EVAL (GLOBAL id) RecCall) = putWord8 55 >> put id put (EVAL (HEAP n) (TailCall a)) = putWord8 56 >> put n >> put a put (EVAL (ARG_VAR n) (TailCall a)) = putWord8 57 >> put n >> put a put (EVAL (FREE_VAR n) (TailCall a)) = putWord8 58 >> put n >> put a put (EVAL (GLOBAL id) (TailCall a)) = putWord8 59 >> put id >> put a put (EVAL (HEAP n) UpdateCall) = putWord8 60 >> put n put (EVAL (ARG_VAR n) UpdateCall) = putWord8 61 >> put n put (EVAL (FREE_VAR n) UpdateCall) = putWord8 62 >> put n put (EVAL (GLOBAL id) UpdateCall) = putWord8 63 >> put id put (DROP n ) = putWord8 64 >> put n put (JUMP l ) = putWord8 68 >> put l put (FAIL ) = putWord8 72 put (PUSH_ACCUM (LInt n)) = putWord8 76 >> put n put (PUSH_ACCUM (LStr s)) = putWord8 77 >> put s put (PUSH_ACCUM (LFlt d)) = putWord8 78 >> put d put (POP_ACCUM ) = putWord8 80 put (ADD ) = putWord8 84 get = fail "Missing implementation for