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
|
module PGF.Binary where
import PGF.CId
import PGF.Data
import Data.Binary
import Data.Binary.Put
import Data.Binary.Get
import qualified Data.ByteString as BS
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import qualified Data.Set as Set
import Control.Monad
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
)
get = do v1 <- getWord16be
v2 <- getWord16be
absname <- get
cncnames <- get
gflags <- get
abstract <- get
concretes <- get
return (PGF{ absname=absname, cncnames=cncnames
, gflags=gflags
, abstract=abstract, concretes=concretes
})
instance Binary CId where
put (CId bs) = put bs
get = liftM CId get
instance Binary Abstr where
put abs = put (aflags abs, funs abs, cats abs)
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
})
instance Binary Concr where
put cnc = put ( cflags cnc, lins cnc, opers cnc
, lincats cnc, lindefs cnc
, printnames cnc, paramlincats cnc
, parser cnc
)
get = do cflags <- get
lins <- get
opers <- get
lincats <- get
lindefs <- get
printnames <- get
paramlincats <- get
parser <- get
return (Concr{ cflags=cflags, lins=lins, opers=opers
, lincats=lincats, lindefs=lindefs
, printnames=printnames
, paramlincats=paramlincats
, parser=parser
})
instance Binary Alternative where
put (Alt v x) = put v >> put x
get = liftM2 Alt get get
instance Binary Term where
put (R es) = putWord8 0 >> put es
put (S es) = putWord8 1 >> put es
put (FV es) = putWord8 2 >> put es
put (P e v) = putWord8 3 >> put (e,v)
put (W e v) = putWord8 4 >> put (e,v)
put (C i ) = putWord8 5 >> put i
put (TM i ) = putWord8 6 >> put i
put (F f) = putWord8 7 >> put f
put (V i) = putWord8 8 >> put i
put (K (KS s)) = putWord8 9 >> put s
put (K (KP d vs)) = putWord8 10 >> put (d,vs)
get = do tag <- getWord8
case tag of
0 -> liftM R get
1 -> liftM S get
2 -> liftM FV get
3 -> liftM2 P get get
4 -> liftM2 W get get
5 -> liftM C get
6 -> liftM TM get
7 -> liftM F get
8 -> liftM V get
9 -> liftM (K . KS) get
10 -> liftM2 (\d vs -> K (KP d vs)) get get
_ -> decodingError
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)
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
_ -> 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
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
_ -> decodingError
instance Binary Equation where
put (Equ ps e) = put (ps,e)
get = liftM2 Equ get get
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 FFun where
put (FFun fun lins) = put (fun,lins)
get = liftM2 FFun get get
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)
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
_ -> decodingError
instance Binary Production where
put (FApply ruleid args) = putWord8 0 >> put (ruleid,args)
put (FCoerce fcat) = putWord8 1 >> put fcat
get = do tag <- getWord8
case tag of
0 -> liftM2 FApply get get
1 -> liftM FCoerce get
_ -> decodingError
instance Binary ParserInfo where
put p = put (functions p, sequences p, productions0 p, totalCats p, startCats p)
get = do functions <- get
sequences <- get
productions0<- get
totalCats <- get
startCats <- get
return (ParserInfo{functions=functions,sequences=sequences
,productions0=productions0
,productions =filterProductions productions0
,totalCats=totalCats,startCats=startCats})
decodingError = fail "This PGF file was compiled with different version of GF"
|
