cleanup the code of the PGF interpreter and polish the binary serialization to match the preliminary specification

1 files changed, 94 insertions, 65 deletions

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"