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
|
module GF.Grammar.CanonicalJSON (
encodeJSON
) where
import Text.JSON
import Control.Applicative ((<|>))
import Data.Ratio (denominator, numerator)
import GF.Grammar.Canonical
import Control.Monad (guard)
import GF.Infra.Ident (RawIdent,showRawIdent,rawIdentS)
encodeJSON :: FilePath -> Grammar -> IO ()
encodeJSON fpath g = writeFile fpath (encode g)
-- in general we encode grammars using JSON objects/records,
-- except for newtypes/coercions/direct values
-- the top-level definitions use normal record labels,
-- but recursive types/values/ids use labels staring with a "."
instance JSON Grammar where
showJSON (Grammar abs cncs) = makeObj [("abstract", showJSON abs), ("concretes", showJSON cncs)]
readJSON o = Grammar <$> o!"abstract" <*> o!"concretes"
--------------------------------------------------------------------------------
-- ** Abstract Syntax
instance JSON Abstract where
showJSON (Abstract absid flags cats funs)
= makeObj [("abs", showJSON absid),
("flags", showJSON flags),
("cats", showJSON cats),
("funs", showJSON funs)]
readJSON o = Abstract
<$> o!"abs"
<*>(o!"flags" <|> return (Flags []))
<*> o!"cats"
<*> o!"funs"
instance JSON CatDef where
-- non-dependent categories are encoded as simple strings:
showJSON (CatDef c []) = showJSON c
showJSON (CatDef c cs) = makeObj [("cat", showJSON c), ("args", showJSON cs)]
readJSON o = CatDef <$> readJSON o <*> return []
<|> CatDef <$> o!"cat" <*> o!"args"
instance JSON FunDef where
showJSON (FunDef f ty) = makeObj [("fun", showJSON f), ("type", showJSON ty)]
readJSON o = FunDef <$> o!"fun" <*> o!"type"
instance JSON Type where
showJSON (Type bs ty) = makeObj [(".args", showJSON bs), (".result", showJSON ty)]
readJSON o = Type <$> o!".args" <*> o!".result"
instance JSON TypeApp where
-- non-dependent categories are encoded as simple strings:
showJSON (TypeApp c []) = showJSON c
showJSON (TypeApp c args) = makeObj [(".cat", showJSON c), (".args", showJSON args)]
readJSON o = TypeApp <$> readJSON o <*> return []
<|> TypeApp <$> o!".cat" <*> o!".args"
instance JSON TypeBinding where
-- non-dependent categories are encoded as simple strings:
showJSON (TypeBinding Anonymous (Type [] (TypeApp c []))) = showJSON c
showJSON (TypeBinding x ty) = makeObj [(".var", showJSON x), (".type", showJSON ty)]
readJSON o = do c <- readJSON o
return (TypeBinding Anonymous (Type [] (TypeApp c [])))
<|> TypeBinding <$> o!".var" <*> o!".type"
--------------------------------------------------------------------------------
-- ** Concrete syntax
instance JSON Concrete where
showJSON (Concrete cncid absid flags params lincats lins)
= makeObj [("cnc", showJSON cncid),
("abs", showJSON absid),
("flags", showJSON flags),
("params", showJSON params),
("lincats", showJSON lincats),
("lins", showJSON lins)]
readJSON o = Concrete
<$> o!"cnc"
<*> o!"abs"
<*>(o!"flags" <|> return (Flags []))
<*> o!"params"
<*> o!"lincats"
<*> o!"lins"
instance JSON ParamDef where
showJSON (ParamDef p pvs) = makeObj [("param", showJSON p), ("values", showJSON pvs)]
showJSON (ParamAliasDef p t) = makeObj [("param", showJSON p), ("alias", showJSON t)]
readJSON o = ParamDef <$> o!"param" <*> o!"values"
<|> ParamAliasDef <$> o!"param" <*> o!"alias"
instance JSON LincatDef where
showJSON (LincatDef c lt) = makeObj [("cat", showJSON c), ("lintype", showJSON lt)]
readJSON o = LincatDef <$> o!"cat" <*> o!"lintype"
instance JSON LinDef where
showJSON (LinDef f xs lv) = makeObj [("fun", showJSON f), ("args", showJSON xs), ("lin", showJSON lv)]
readJSON o = LinDef <$> o!"fun" <*> o!"args" <*> o!"lin"
instance JSON LinType where
-- the basic types (Str, Float, Int) are encoded as strings:
showJSON (StrType) = showJSON "Str"
showJSON (FloatType) = showJSON "Float"
showJSON (IntType) = showJSON "Int"
-- parameters are also encoded as strings:
showJSON (ParamType pt) = showJSON pt
-- tables/tuples are encoded as JSON objects:
showJSON (TableType pt lt) = makeObj [(".tblarg", showJSON pt), (".tblval", showJSON lt)]
showJSON (TupleType lts) = makeObj [(".tuple", showJSON lts)]
-- records are encoded as records:
showJSON (RecordType rows) = showJSON rows
readJSON o = StrType <$ parseString "Str" o
<|> FloatType <$ parseString "Float" o
<|> IntType <$ parseString "Int" o
<|> ParamType <$> readJSON o
<|> TableType <$> o!".tblarg" <*> o!".tblval"
<|> TupleType <$> o!".tuple"
<|> RecordType <$> readJSON o
instance JSON LinValue where
showJSON (LiteralValue l ) = showJSON l
-- most values are encoded as JSON objects:
showJSON (ParamConstant pv) = makeObj [(".param", showJSON pv)]
showJSON (PredefValue p ) = makeObj [(".predef", showJSON p)]
showJSON (TableValue t tvs) = makeObj [(".tblarg", showJSON t), (".tblrows", showJSON tvs)]
showJSON (TupleValue lvs) = makeObj [(".tuple", showJSON lvs)]
showJSON (VarValue v ) = makeObj [(".var", showJSON v)]
showJSON (ErrorValue s ) = makeObj [(".error", showJSON s)]
showJSON (Projection lv l ) = makeObj [(".project", showJSON lv), (".label", showJSON l)]
showJSON (Selection tv pv) = makeObj [(".select", showJSON tv), (".key", showJSON pv)]
showJSON (VariantValue vs) = makeObj [(".variants", showJSON vs)]
showJSON (PreValue pre def) = makeObj [(".pre", showJSON pre),(".default", showJSON def)]
-- records are encoded directly as JSON records:
showJSON (RecordValue rows) = showJSON rows
-- concatenation is encoded as a JSON array:
showJSON v@(ConcatValue _ _) = showJSON (flatten v [])
where flatten (ConcatValue v v') = flatten v . flatten v'
flatten v = (v :)
readJSON o = LiteralValue <$> readJSON o
<|> ParamConstant <$> o!".param"
<|> PredefValue <$> o!".predef"
<|> TableValue <$> o!".tblarg" <*> o!".tblrows"
<|> TupleValue <$> o!".tuple"
<|> VarValue <$> o!".var"
<|> ErrorValue <$> o!".error"
<|> Projection <$> o!".project" <*> o!".label"
<|> Selection <$> o!".select" <*> o!".key"
<|> VariantValue <$> o!".variants"
<|> PreValue <$> o!".pre" <*> o!".default"
<|> RecordValue <$> readJSON o
<|> do vs <- readJSON o :: Result [LinValue]
return (foldr1 ConcatValue vs)
instance JSON LinLiteral where
-- basic values (Str, Float, Int) are encoded as JSON strings/numbers:
showJSON (StrConstant s) = showJSON s
showJSON (FloatConstant f) = showJSON f
showJSON (IntConstant n) = showJSON n
readJSON = readBasicJSON StrConstant IntConstant FloatConstant
instance JSON LinPattern where
-- wildcards and patterns without arguments are encoded as strings:
showJSON (WildPattern) = showJSON "_"
showJSON (ParamPattern (Param p [])) = showJSON p
-- complex patterns are encoded as JSON objects:
showJSON (ParamPattern pv) = showJSON pv
-- and records as records:
showJSON (RecordPattern r) = showJSON r
readJSON o = do p <- parseString "_" o; return WildPattern
<|> do p <- readJSON o; return (ParamPattern (Param p []))
<|> ParamPattern <$> readJSON o
<|> RecordPattern <$> readJSON o
instance JSON arg => JSON (Param arg) where
-- parameters without arguments are encoded as strings:
showJSON (Param p []) = showJSON p
showJSON (Param p args) = makeObj [(".paramid", showJSON p), (".args", showJSON args)]
readJSON o = Param <$> readJSON o <*> return []
<|> Param <$> o!".paramid" <*> o!".args"
instance JSON a => JSON (RecordRow a) where
-- record rows and lists of record rows are both encoded as JSON records (i.e., objects)
showJSON row = showJSONs [row]
showJSONs rows = makeObj (map toRow rows)
where toRow (RecordRow (LabelId lbl) val) = (showRawIdent lbl, showJSON val)
readJSON obj = head <$> readJSONs obj
readJSONs obj = mapM fromRow (assocsJSObject obj)
where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
return (RecordRow (LabelId (rawIdentS lbl)) value)
instance JSON rhs => JSON (TableRow rhs) where
showJSON (TableRow l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)]
readJSON o = TableRow <$> o!".pattern" <*> o!".value"
-- *** Identifiers in Concrete Syntax
instance JSON PredefId where showJSON (PredefId s) = showJSON s ; readJSON = fmap PredefId . readJSON
instance JSON LabelId where showJSON (LabelId s) = showJSON s ; readJSON = fmap LabelId . readJSON
instance JSON VarValueId where showJSON (VarValueId s) = showJSON s ; readJSON = fmap VarValueId . readJSON
instance JSON ParamId where showJSON (ParamId s) = showJSON s ; readJSON = fmap ParamId . readJSON
instance JSON ParamType where showJSON (ParamTypeId s) = showJSON s ; readJSON = fmap ParamTypeId . readJSON
--------------------------------------------------------------------------------
-- ** Used in both Abstract and Concrete Syntax
instance JSON ModId where showJSON (ModId s) = showJSON s ; readJSON = fmap ModId . readJSON
instance JSON CatId where showJSON (CatId s) = showJSON s ; readJSON = fmap CatId . readJSON
instance JSON FunId where showJSON (FunId s) = showJSON s ; readJSON = fmap FunId . readJSON
instance JSON VarId where
-- the anonymous variable is the underscore:
showJSON Anonymous = showJSON "_"
showJSON (VarId x) = showJSON x
readJSON o = do parseString "_" o; return Anonymous
<|> VarId <$> readJSON o
instance JSON QualId where
showJSON (Qual (ModId m) n) = showJSON (showRawIdent m++"."++showRawIdent n)
showJSON (Unqual n) = showJSON n
readJSON o = do qualid <- readJSON o
let (mod, id) = span (/= '.') qualid
return $ if null mod then Unqual (rawIdentS id) else Qual (ModId (rawIdentS mod)) (rawIdentS id)
instance JSON RawIdent where
showJSON i = showJSON $ showRawIdent i
readJSON o = rawIdentS <$> readJSON o
instance JSON Flags where
-- flags are encoded directly as JSON records (i.e., objects):
showJSON (Flags fs) = makeObj [(showRawIdent f, showJSON v) | (f, v) <- fs]
readJSON obj = Flags <$> mapM fromRow (assocsJSObject obj)
where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
return (rawIdentS lbl, value)
instance JSON FlagValue where
-- flag values are encoded as basic JSON types:
showJSON (Str s) = showJSON s
showJSON (Int i) = showJSON i
showJSON (Flt f) = showJSON f
readJSON = readBasicJSON Str Int Flt
--------------------------------------------------------------------------------
-- ** Convenience functions
parseString :: String -> JSValue -> Result ()
parseString s o = guard . (== s) =<< readJSON o
(!) :: JSON a => JSValue -> String -> Result a
obj ! key = maybe (fail $ "CanonicalJSON.(!): Could not find key: " ++ show key)
readJSON
(lookup key (assocsJSObject obj))
assocsJSObject :: JSValue -> [(String, JSValue)]
assocsJSObject (JSObject o) = fromJSObject o
assocsJSObject (JSArray _) = fail $ "CanonicalJSON.assocsJSObject: Expected a JSON object, found an Array"
assocsJSObject jsvalue = fail $ "CanonicalJSON.assocsJSObject: Expected a JSON object, found " ++ show jsvalue
readBasicJSON :: (JSON int, Integral int, JSON flt, RealFloat flt) =>
(String -> v) -> (int -> v) -> (flt -> v) -> JSValue -> Result v
readBasicJSON str int flt o
= str <$> readJSON o
<|> int_or_flt <$> readJSON o
where int_or_flt f | f == fromIntegral n = int n
| otherwise = flt f
where n = round f
|
