forked from GitHub/gf-core
283 lines
11 KiB
Haskell
283 lines
11 KiB
Haskell
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 ‘get’ in the instance declaration for ‘Binary Instr’"
|
||
|
||
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 CncFun where
|
||
put (CncFun fun lins) = put fun >> putArray lins
|
||
get = liftM2 CncFun get getArray
|
||
|
||
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 (SymVar n l) = putWord8 2 >> put (n,l)
|
||
put (SymKS ts) = putWord8 3 >> put ts
|
||
put (SymKP d vs) = putWord8 4 >> put (d,vs)
|
||
put SymBIND = putWord8 5
|
||
put SymSOFT_BIND = putWord8 6
|
||
put SymNE = putWord8 7
|
||
put SymSOFT_SPACE = putWord8 8
|
||
put SymCAPIT = putWord8 9
|
||
put SymALL_CAPIT = putWord8 10
|
||
get = do tag <- getWord8
|
||
case tag of
|
||
0 -> liftM2 SymCat get get
|
||
1 -> liftM2 SymLit get get
|
||
2 -> liftM2 SymVar get get
|
||
3 -> liftM SymKS get
|
||
4 -> liftM2 (\d vs -> SymKP d vs) get get
|
||
5 -> return SymBIND
|
||
6 -> return SymSOFT_BIND
|
||
7 -> return SymNE
|
||
8 -> return SymSOFT_SPACE
|
||
9 -> return SymCAPIT
|
||
10-> return SymALL_CAPIT
|
||
_ -> decodingError
|
||
|
||
instance Binary PArg where
|
||
put (PArg hypos fid) = put (map snd hypos,fid)
|
||
get = get >>= \(hypos,fid) -> return (PArg (zip (repeat fidVar) hypos) fid)
|
||
|
||
instance Binary Production where
|
||
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 -> liftM LStr get
|
||
1 -> liftM LInt get
|
||
2 -> liftM LFlt 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 file was compiled with different version of GF"
|