]> gerrit.simantics Code Review - simantics/platform.git/blob - bundles/org.simantics.scl.runtime/scl/Json2.scl
Fix desktop product configuration
[simantics/platform.git] / bundles / org.simantics.scl.runtime / scl / Json2.scl
1 import "Prelude"
2 import "StringBuilder" as StringBuilder
3 import "Coercion"
4
5 class JSON a where
6     toJSON :: a -> String
7     buildJSON :: StringBuilder.T -> a -> <Proc> StringBuilder.T
8     buildJSONList :: StringBuilder.T -> [a] -> <Proc> StringBuilder.T
9     
10     toJSON v = runProc (StringBuilder.toString (buildJSON StringBuilder.new v))
11     buildJSONList sb v = printList buildJSON (sb << "[") v << "]"
12
13 // Basic types
14
15 instance JSON Integer where
16     buildJSON = (<+)
17 instance JSON Long where
18     buildJSON = (<+)
19 instance JSON Float where
20     buildJSON = (<+)
21 instance JSON Double where
22     buildJSON = (<+)
23 instance JSON String where
24     buildJSON = (<+)
25 instance JSON Boolean where
26     buildJSON sb v = if v then sb << "true" else sb << "false"
27     
28 // Compound types
29
30 @private
31 @inline
32 printList :: (StringBuilder.T -> a -> <Proc> StringBuilder.T) -> StringBuilder.T -> [a] -> <Proc> StringBuilder.T
33 printList f sb l = loop 0
34   where
35     len = length l
36     loop i = if i >= len then sb
37              else do
38                  f (if i==0 then sb else sb << ",") (l!i)
39                  loop (i+1)
40
41 instance (JSON a) => JSON [a] where
42     buildJSON = buildJSONList
43 instance JSON () where
44     buildJSON sb _ = sb << "[]" 
45 instance (JSON a,JSON b) => JSON (a,b) where
46     buildJSON sb (a,b) = buildJSON (buildJSON (sb << "[") a << ",") b << "]"
47 instance (JSON a,JSON b,JSON c) => JSON (a,b,c) where
48     buildJSON sb (a,b,c) = buildJSON (buildJSON (buildJSON (sb << "[") a << ",") b << ",") c << "]"
49 instance (JSON a,JSON b,JSON c,JSON d) => JSON (a,b,c,d) where
50     buildJSON sb (a,b,c,d) = buildJSON (buildJSON (buildJSON (buildJSON (sb << "[") a << ",") b << ",") c << ",") d << "]"
51 instance (JSON a) => JSON (Maybe a) where
52     buildJSON sb (Just a) = buildJSON sb a
53     buildJSON sb Nothing  = sb << "null"
54
55 // Building custom objects
56
57 data JSEntry = JSEntry String (StringBuilder.T -> <Proc> StringBuilder.T)
58
59 (:::) :: JSON a => String -> a -> JSEntry
60 key ::: value = JSEntry key (\sb -> buildJSON sb value)
61
62 instance JSON JSEntry where
63     buildJSON _ _ = fail "JSEntry cannot be directly serialized to JSON."
64     buildJSONList sb v = printList printJSEntry (sb << "{") v << "}"
65       where
66         printJSEntry sb (JSEntry key value) = value (sb <+ key << ":")
67
68 //
69
70 data JSObject = JSObject (StringBuilder.T -> <Proc> StringBuilder.T)
71
72 toJSONList :: JSON a => [a] -> [JSObject]
73 toJSONList = map (\v -> JSObject (\sb -> buildJSON sb v))
74
75 instance JSON JSObject where
76     buildJSON sb (JSObject f) = f sb