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
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
|
----------------------------------------------------------------------
-- |
-- Module : GF.Grammar.Binary
-- Maintainer : Krasimir Angelov
-- Stability : (stable)
-- Portability : (portable)
--
-----------------------------------------------------------------------------
module GF.Grammar.Binary where
import Prelude hiding (catch)
import Control.Exception(catch,ErrorCall(..),throwIO)
import Data.Char
import Data.Binary
import Control.Monad
import qualified Data.Map as Map
import qualified Data.ByteString.Char8 as BS
import GF.Data.Operations
import GF.Infra.Ident
import GF.Infra.Option
import GF.Grammar.Grammar
import PGF.Binary
-- Please change this every time when the GFO format is changed
gfoVersion = "GF02"
instance Binary Ident where
put id = put (ident2bs id)
get = do bs <- get
if bs == BS.pack "_"
then return identW
else return (identC bs)
instance Binary SourceGrammar where
put = put . modules
get = fmap mGrammar get
instance Binary SourceModInfo where
put mi = do put (mtype mi,mstatus mi,mflags mi,mextend mi,mwith mi,mopens mi,mexdeps mi,msrc mi,mseqs mi,jments mi)
get = do (mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc,mseqs,jments) <- get
return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc mseqs jments)
instance Binary ModuleType where
put MTAbstract = putWord8 0
put MTResource = putWord8 2
put (MTConcrete i) = putWord8 3 >> put i
put MTInterface = putWord8 4
put (MTInstance i) = putWord8 5 >> put i
get = do tag <- getWord8
case tag of
0 -> return MTAbstract
2 -> return MTResource
3 -> get >>= return . MTConcrete
4 -> return MTInterface
5 -> get >>= return . MTInstance
_ -> decodingError
instance Binary MInclude where
put MIAll = putWord8 0
put (MIOnly xs) = putWord8 1 >> put xs
put (MIExcept xs) = putWord8 2 >> put xs
get = do tag <- getWord8
case tag of
0 -> return MIAll
1 -> fmap MIOnly get
2 -> fmap MIExcept get
_ -> decodingError
instance Binary OpenSpec where
put (OSimple i) = putWord8 0 >> put i
put (OQualif i j) = putWord8 1 >> put (i,j)
get = do tag <- getWord8
case tag of
0 -> get >>= return . OSimple
1 -> get >>= \(i,j) -> return (OQualif i j)
_ -> decodingError
instance Binary ModuleStatus where
put MSComplete = putWord8 0
put MSIncomplete = putWord8 1
get = do tag <- getWord8
case tag of
0 -> return MSComplete
1 -> return MSIncomplete
_ -> decodingError
instance Binary Options where
put = put . optionsGFO
get = do opts <- get
case parseModuleOptions ["--" ++ flag ++ "=" ++ value | (flag,value) <- opts] of
Ok x -> return x
Bad msg -> fail msg
instance Binary Production where
put (Production res funid args) = put (res,funid,args)
get = do res <- get
funid <- get
args <- get
return (Production res funid args)
instance Binary PMCFG where
put (PMCFG prods funs) = put (prods,funs)
get = do prods <- get
funs <- get
return (PMCFG prods funs)
instance Binary Info where
put (AbsCat x) = putWord8 0 >> put x
put (AbsFun w x y z) = putWord8 1 >> put (w,x,y,z)
put (ResParam x y) = putWord8 2 >> put (x,y)
put (ResValue x) = putWord8 3 >> put x
put (ResOper x y) = putWord8 4 >> put (x,y)
put (ResOverload x y)= putWord8 5 >> put (x,y)
put (CncCat w x y z) = putWord8 6 >> put (w,x,y,z)
put (CncFun w x y z) = putWord8 7 >> put (w,x,y,z)
put (AnyInd x y) = putWord8 8 >> put (x,y)
get = do tag <- getWord8
case tag of
0 -> get >>= \x -> return (AbsCat x)
1 -> get >>= \(w,x,y,z) -> return (AbsFun w x y z)
2 -> get >>= \(x,y) -> return (ResParam x y)
3 -> get >>= \x -> return (ResValue x)
4 -> get >>= \(x,y) -> return (ResOper x y)
5 -> get >>= \(x,y) -> return (ResOverload x y)
6 -> get >>= \(w,x,y,z) -> return (CncCat w x y z)
7 -> get >>= \(w,x,y,z) -> return (CncFun w x y z)
8 -> get >>= \(x,y) -> return (AnyInd x y)
_ -> decodingError
instance Binary Location where
put NoLoc = putWord8 0
put (Local x y) = putWord8 1 >> put (x,y)
put (External x y) = putWord8 2 >> put (x,y)
get = do tag <- getWord8
case tag of
0 -> return NoLoc
1 -> get >>= \(x,y) -> return (Local x y)
2 -> get >>= \(x,y) -> return (External x y)
instance Binary a => Binary (L a) where
put (L x y) = put (x,y)
get = get >>= \(x,y) -> return (L x y)
instance Binary Term where
put (Vr x) = putWord8 0 >> put x
put (Cn x) = putWord8 1 >> put x
put (Con x) = putWord8 2 >> put x
put (Sort x) = putWord8 3 >> put x
put (EInt x) = putWord8 4 >> put x
put (EFloat x) = putWord8 5 >> put x
put (K x) = putWord8 6 >> put x
put (Empty) = putWord8 7
put (App x y) = putWord8 8 >> put (x,y)
put (Abs x y z) = putWord8 9 >> put (x,y,z)
put (Meta x) = putWord8 10 >> put x
put (ImplArg x) = putWord8 11 >> put x
put (Prod w x y z)= putWord8 12 >> put (w,x,y,z)
put (Typed x y) = putWord8 13 >> put (x,y)
put (Example x y) = putWord8 14 >> put (x,y)
put (RecType x) = putWord8 15 >> put x
put (R x) = putWord8 16 >> put x
put (P x y) = putWord8 17 >> put (x,y)
put (ExtR x y) = putWord8 18 >> put (x,y)
put (Table x y) = putWord8 19 >> put (x,y)
put (T x y) = putWord8 20 >> put (x,y)
put (V x y) = putWord8 21 >> put (x,y)
put (S x y) = putWord8 22 >> put (x,y)
put (Let x y) = putWord8 23 >> put (x,y)
put (Q x) = putWord8 24 >> put x
put (QC x) = putWord8 25 >> put x
put (C x y) = putWord8 26 >> put (x,y)
put (Glue x y) = putWord8 27 >> put (x,y)
put (EPatt x) = putWord8 28 >> put x
put (EPattType x) = putWord8 29 >> put x
put (ELincat x y) = putWord8 30 >> put (x,y)
put (ELin x y) = putWord8 31 >> put (x,y)
put (FV x) = putWord8 32 >> put x
put (Alts x y) = putWord8 33 >> put (x,y)
put (Strs x) = putWord8 34 >> put x
put (Error x) = putWord8 35 >> put x
get = do tag <- getWord8
case tag of
0 -> get >>= \x -> return (Vr x)
1 -> get >>= \x -> return (Cn x)
2 -> get >>= \x -> return (Con x)
3 -> get >>= \x -> return (Sort x)
4 -> get >>= \x -> return (EInt x)
5 -> get >>= \x -> return (EFloat x)
6 -> get >>= \x -> return (K x)
7 -> return (Empty)
8 -> get >>= \(x,y) -> return (App x y)
9 -> get >>= \(x,y,z) -> return (Abs x y z)
10 -> get >>= \x -> return (Meta x)
11 -> get >>= \x -> return (ImplArg x)
12 -> get >>= \(w,x,y,z)->return (Prod w x y z)
13 -> get >>= \(x,y) -> return (Typed x y)
14 -> get >>= \(x,y) -> return (Example x y)
15 -> get >>= \x -> return (RecType x)
16 -> get >>= \x -> return (R x)
17 -> get >>= \(x,y) -> return (P x y)
18 -> get >>= \(x,y) -> return (ExtR x y)
19 -> get >>= \(x,y) -> return (Table x y)
20 -> get >>= \(x,y) -> return (T x y)
21 -> get >>= \(x,y) -> return (V x y)
22 -> get >>= \(x,y) -> return (S x y)
23 -> get >>= \(x,y) -> return (Let x y)
24 -> get >>= \x -> return (Q x)
25 -> get >>= \x -> return (QC x)
26 -> get >>= \(x,y) -> return (C x y)
27 -> get >>= \(x,y) -> return (Glue x y)
28 -> get >>= \x -> return (EPatt x)
29 -> get >>= \x -> return (EPattType x)
30 -> get >>= \(x,y) -> return (ELincat x y)
31 -> get >>= \(x,y) -> return (ELin x y)
32 -> get >>= \x -> return (FV x)
33 -> get >>= \(x,y) -> return (Alts x y)
34 -> get >>= \x -> return (Strs x)
35 -> get >>= \x -> return (Error x)
_ -> decodingError
instance Binary Patt where
put (PC x y) = putWord8 0 >> put (x,y)
put (PP x y) = putWord8 1 >> put (x,y)
put (PV x) = putWord8 2 >> put x
put (PW) = putWord8 3
put (PR x) = putWord8 4 >> put x
put (PString x) = putWord8 5 >> put x
put (PInt x) = putWord8 6 >> put x
put (PFloat x) = putWord8 7 >> put x
put (PT x y) = putWord8 8 >> put (x,y)
put (PAs x y) = putWord8 10 >> put (x,y)
put (PNeg x) = putWord8 11 >> put x
put (PAlt x y) = putWord8 12 >> put (x,y)
put (PSeq x y) = putWord8 13 >> put (x,y)
put (PRep x) = putWord8 14 >> put x
put (PChar) = putWord8 15
put (PChars x) = putWord8 16 >> put x
put (PMacro x) = putWord8 17 >> put x
put (PM x) = putWord8 18 >> put x
put (PTilde x) = putWord8 19 >> put x
get = do tag <- getWord8
case tag of
0 -> get >>= \(x,y) -> return (PC x y)
1 -> get >>= \(x,y) -> return (PP x y)
2 -> get >>= \x -> return (PV x)
3 -> return (PW)
4 -> get >>= \x -> return (PR x)
5 -> get >>= \x -> return (PString x)
6 -> get >>= \x -> return (PInt x)
7 -> get >>= \x -> return (PFloat x)
8 -> get >>= \(x,y) -> return (PT x y)
10 -> get >>= \(x,y) -> return (PAs x y)
11 -> get >>= \x -> return (PNeg x)
12 -> get >>= \(x,y) -> return (PAlt x y)
13 -> get >>= \(x,y) -> return (PSeq x y)
14 -> get >>= \x -> return (PRep x)
15 -> return (PChar)
16 -> get >>= \x -> return (PChars x)
17 -> get >>= \x -> return (PMacro x)
18 -> get >>= \x -> return (PM x)
19 -> get >>= \x -> return (PTilde x)
_ -> decodingError
instance Binary TInfo where
put TRaw = putWord8 0
put (TTyped t) = putWord8 1 >> put t
put (TComp t) = putWord8 2 >> put t
put (TWild t) = putWord8 3 >> put t
get = do tag <- getWord8
case tag of
0 -> return TRaw
1 -> fmap TTyped get
2 -> fmap TComp get
3 -> fmap TWild get
_ -> decodingError
instance Binary Label where
put (LIdent bs) = putWord8 0 >> put bs
put (LVar i) = putWord8 1 >> put i
get = do tag <- getWord8
case tag of
0 -> fmap LIdent get
1 -> fmap LVar get
_ -> decodingError
putGFOVersion = mapM_ (putWord8 . fromIntegral . ord) gfoVersion
getGFOVersion = replicateM (length gfoVersion) (fmap (chr . fromIntegral) getWord8)
decodeModule :: FilePath -> IO SourceModule
decodeModule fpath = decodeFile' fpath (getGFOVersion >> get)
decodeModuleHeader fpath = decodeFile' fpath getVersionedMod
where
getVersionedMod = do
ver <- getGFOVersion
if ver == gfoVersion
then do (m,mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc) <- get
return (Just (m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Nothing Map.empty))
else return Nothing
encodeModule :: FilePath -> SourceModule -> IO ()
encodeModule fpath mo =
encodeFile_ fpath (putGFOVersion >> put mo)
-- | like decodeFile_ but adds file name to error message if there was an error
decodeFile' fpath get = addFPath fpath (decodeFile_ fpath get)
-- | Adds file name to error message if there was an error,
-- | but laziness can cause errors to slip through
addFPath fpath m = m `catch` handle
where
handle (ErrorCall msg) = throwIO (ErrorCall (fpath++": "++msg))
|
