1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
|
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
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"
|
