From 890d45579300f39d50a5a18a9f6feed8634ae8ba Mon Sep 17 00:00:00 2001 From: krasimir Date: Wed, 27 Jan 2010 09:39:14 +0000 Subject: cleanup the code of the PGF interpreter and polish the binary serialization to match the preliminary specification --- src/runtime/haskell/PGF/Binary.hs | 159 ++++++++++++++++++++++---------------- 1 file changed, 94 insertions(+), 65 deletions(-) (limited to 'src/runtime/haskell/PGF/Binary.hs') diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs index 66caef1da..bc46390f4 100644 --- a/src/runtime/haskell/PGF/Binary.hs +++ b/src/runtime/haskell/PGF/Binary.hs @@ -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 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 -> liftM2 FApply get get - 1 -> liftM FCoerce get + 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" -- cgit v1.2.3