GenJSON.dcl 8.39 KB
Newer Older
Camil Staps's avatar
Camil Staps committed
1
definition module Text.GenJSON
Camil Staps's avatar
Camil Staps committed
2 3

/**
4 5 6 7 8 9 10 11 12
 * This module provides functions to encode and decode any Clean data type
 * to JSON format. It provides two generic functions JSONEncode and JSONDecode
 * which must be derived for concrete types. Then toJSON and fromJSON may be
 * used to convert any value to and from JSON.
 *
 * For more info about JSON see: http://www.json.org/
 *
 * @property-bootstrap
 *     import StdEnv
13
 *     import Data.GenEq, Text
14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32
 *
 *     :: TestRecord = {a :: Int, b` :: [(Int,[Char])]}
 *
 *     derive ggen    TestRecord, JSONNode
 *     derive genShow TestRecord, JSONNode
 *     derive gPrint  TestRecord, JSONNode
 *
 *     derive gEq TestRecord
 *     instance == TestRecord where == a b = a === b
 *
 *     derive JSONEncode TestRecord
 *     derive JSONDecode TestRecord
 *
 * @property-test-with type=Int
 * @property-test-with type=Bool
 * @property-test-with type=Char
 * @property-test-with type=String
 * @property-test-with type=[TestRecord]
 */
33

34
import StdGeneric
Camil Staps's avatar
Camil Staps committed
35
from StdFile import class <<<
Camil Staps's avatar
Camil Staps committed
36
from StdOverloaded import class fromString, class toString, class ==(..)
37
from StdString import instance == {#Char}
Camil Staps's avatar
Camil Staps committed
38
from Data.List import !?
39
from Data.Maybe import :: Maybe(..)
40
from Data.GenEq import generic gEq
41

42 43 44 45 46 47 48 49 50 51 52 53 54
/**
 * @invariant noErrorOrRaw: A.json :: JSONNode:
 *     case json of
 *         JSONNull     = prop True
 *         JSONBool _   = prop True
 *         JSONInt _    = prop True
 *         JSONReal _   = prop True
 *         JSONString _ = prop True
 *         JSONArray a  = foldl (\p j -> p /\ noErrorOrRaw j) (prop True) a
 *         JSONObject o = foldl (\p (_,j) -> p /\ noErrorOrRaw j) (prop True) o
 *         JSONRaw _    = prop False
 *         JSONError    = prop False
 */
55 56 57 58
:: JSONNode	= JSONNull
			| JSONBool !Bool
			| JSONInt !Int
			| JSONReal !Real
59
			| JSONString !String //* Only control characters and '"' will be escaped
60
			| JSONArray ![JSONNode]
61
			| JSONObject ![(String,JSONNode)]
62 63 64 65 66 67
			| JSONRaw !String
			| JSONError
/**
* Serializing JSON structures is done with a toString instance
*/
instance toString JSONNode
68

69
/**
70 71 72 73 74 75 76
 * Deserializing JSON structures is done with a fromString instance
 *
 * @property no error/raw constructors for generated values: A.x :: type:
 *     noErrorOrRaw (fromString (toString (toJSON x)))
 * @property error for incomplete parsings: A.x :: type; s :: String:
 *     let json = toJSON x in
 *         toInt s == 0 ==> // we may append more digits to an int, in which case it is not invalid
77
 *         trim s <> "" ==> // if we only add whitespace it is not invalid
78 79 80
 *         size s > 0 ==>
 *         fromString (toString json +++ s) =.= JSONError
 */
81
instance fromString JSONNode
82

Camil Staps's avatar
Camil Staps committed
83 84 85 86 87
/**
* Serialize a JSON structure and write to a File
*/
instance <<< JSONNode

88 89
derive gEq JSONNode

90 91
/**
* Encodes any value to JSON format.
Camil Staps's avatar
Camil Staps committed
92 93
*
* @property correctness: A.a :: type:
94
*     maybe (prop False) ((=.=) a) (fromJSON (fromString (toString (toJSON a))))
Camil Staps's avatar
Camil Staps committed
95 96
*
* @property correctness Real: A.a :: Real:
97 98 99 100
*     toString (toReal (toString a)) == toString a ==>
*         case fromJSON (fromString (toString (toJSON a))) of
*             Nothing -> prop False
*             Just b -> if (isNaN a) (prop (isNaN b)) (toString a =.= fromReal b)
Camil Staps's avatar
Camil Staps committed
101
*
102 103 104
* @param The value to encode
* @return The JSON encoded value
*/
105
toJSON        :: !a -> JSONNode | JSONEncode{|*|} a
106 107 108

toJSONInField :: !a -> JSONNode | JSONEncode{|*|} a

109 110 111 112 113 114 115
/**
* Tries to parse a JSON encoded string.
* When parsing fails, the result is Nothing.
*
* @param The JSON encoded input
* @return Just the result, when parsing succeeds
*/
116
fromJSON	:: !JSONNode	-> Maybe a	| JSONDecode{|*|} a
117 118 119 120 121 122 123

/**
* Escapes a string for manual JSON construction
*
* @param The unescaped string
* @return A properly escaped string
*/
124 125 126 127 128 129 130 131 132
jsonEscape	:: !String	-> String

/**
* Unescapes a string that is escaped for use in a serialized JSON string
*
* @param The escaped string
* @return An unescaped string
*/
jsonUnescape :: !String -> String
133 134

/**
135 136 137 138 139 140 141 142 143
* Simple query-by-path function that enables searching of JSON structures
*
* @param The query path separated by '/'. Objects are indexed by fieldname
*        and arrays by their array index.
*        Example paths: 'node1/node3' 'node1/node2/23'
*
* @return The value if a value of the right type is at that path.
*/
jsonQuery :: !String !JSONNode -> Maybe a | JSONDecode{|*|} a
144

145
/**
Camil Staps's avatar
Camil Staps committed
146
* Generic encoding function. This function should not be used
147 148 149
* directly but always through the toJSON function. It must be derived
* for each type you want to encode in JSON format.
*/
150
generic JSONEncode t :: !Bool !t -> [JSONNode]
151
derive  JSONEncode Int, Real, Char, Bool, String, [], (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,), {}, {!}, Maybe, JSONNode
152

153 154
JSONEncode{|UNIT|} _ (UNIT) = []
JSONEncode{|PAIR|} fx fy _ (PAIR x y) = fx False x ++ fy False y
155 156 157 158
where
	(++) infixr 5::![.a] !u:[.a] -> u:[.a]
	(++) [hd:tl]	list	= [hd:tl ++ list]
	(++) nil 		list	= list
159 160 161 162 163
JSONEncode{|EITHER|} fx fy _ (LEFT x) = fx False x
JSONEncode{|EITHER|} fx fy _ (RIGHT y) = fy False y
JSONEncode{|OBJECT|} fx _ (OBJECT x) = fx False x
JSONEncode{|CONS of {gcd_name}|} fx _ (CONS x)
  = [JSONArray [JSONString gcd_name : fx False x]]
164
JSONEncode{|RECORD of {grd_fields}|} fx _ (RECORD x)
165 166 167 168 169
	= [JSONObject [(name, o) \\ o <- fx False x & name <- grd_fields | isNotNull o]]
where
	isNotNull :: !JSONNode -> Bool
	isNotNull JSONNull = False
	isNotNull _ = True
170 171
JSONEncode{|FIELD|} fx _ (FIELD x) = fx True x

172 173 174 175 176
/**
* Generic decoding function. This function should not be used
* directly, but always through the fromJSON function. It must be derived
* for each type you want to parse from JSON format.
*/
177
generic JSONDecode t :: !Bool ![JSONNode] -> (!Maybe t,![JSONNode])
178
derive  JSONDecode Int, Real, Char, Bool, String, [], (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,), {}, {!}, Maybe, JSONNode
179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194

JSONDecode{|UNIT|} _ l					= (Just UNIT, l)
JSONDecode{|EITHER|} fx fy _ l = case fx False l of
	(Just x, xs)				= (Just (LEFT x),xs)
	(Nothing, xs)				= case fy False l of
		(Just y, ys)			= (Just (RIGHT y),ys)
		(Nothing, ys)			= (Nothing, l)
JSONDecode{|OBJECT|} fx _ l = case fx False l of
	(Just x, xs)	= (Just (OBJECT x),xs)
	_				= (Nothing, l)
JSONDecode{|CONS of {gcd_name}|} fx _ l=:[JSONArray [JSONString name:fields] :xs]
	| name == gcd_name				= case fx False fields of
		(Just x, _)					= (Just (CONS x), xs)
		_							= (Nothing, l)
	| otherwise						= (Nothing, l)		
JSONDecode{|CONS|} fx _ l = (Nothing, l)
195 196
JSONDecode{|PAIR|} fx fy _ l = d1 fy (fx False l) l
  where
197
  d1 :: !(Bool [JSONNode] -> (Maybe b, [JSONNode])) !(!Maybe a, ![JSONNode]) ![JSONNode]
198 199 200
     -> (!Maybe (PAIR a b), ![JSONNode])
  d1 fy (Just x,xs)  l = d2 x (fy False xs) l
  d1 _  (Nothing, _) l = (Nothing, l)
201

202 203 204
  d2 :: !a !(!Maybe b, ![JSONNode]) ![JSONNode] -> (!Maybe (PAIR a b), ![JSONNode])
  d2 x (Just y, ys) l = (Just (PAIR x y), ys)
  d2 x (Nothing, _) l = (Nothing, l)
205
JSONDecode{|RECORD|} fx _ l=:[obj=:JSONObject fields : xs] = d (fx False [obj]) xs l
206 207 208 209 210 211 212 213 214
  where
  d :: !(Maybe a, b) ![JSONNode] ![JSONNode] -> (!Maybe (RECORD a), ![JSONNode])
  d (Just x, _)  xs l = (Just (RECORD x),xs)
  d (Nothing, _) xs l = (Nothing, l)
JSONDecode{|RECORD|} fx _ l=:[obj=:JSONArray fields : xs] = d (fx False [obj]) xs l
  where
  d :: !(Maybe a, b) ![JSONNode] ![JSONNode] -> (!Maybe (RECORD a), ![JSONNode])
  d (Just x, _)  xs l = (Just (RECORD x),xs)
  d (Nothing, _) xs l = (Nothing, l)
215 216
JSONDecode{|RECORD|} fx _ l = (Nothing,l)
JSONDecode{|FIELD of {gfd_name}|} fx _ l =:[JSONObject fields]
217 218 219 220 221
  #! field = findField gfd_name fields
  = case fx True field of
      (Just x, _) = (Just (FIELD x), l)
      (_, _)      = (Nothing, l)
  where
222
  findField :: !String ![(String, JSONNode)] -> [JSONNode]
223 224 225 226 227
  findField match [(l,x):xs]
    | l == match = [x]
    | otherwise  = findField match xs
  findField match [] = []
JSONDecode{|FIELD of {gfd_index}|} fx _ l =:[JSONArray fields]
Camil Staps's avatar
Camil Staps committed
228 229 230 231 232
	= case fields !? gfd_index of
		Nothing    = (Nothing, l)
		Just field = case fx True [field] of
			(Just x, _) = (Just (FIELD x), l)
			(_, _)      = (Nothing, l)
233
JSONDecode{|FIELD|} fx _ l = (Nothing, l)
Jeroen Henrix's avatar
Jeroen Henrix committed
234 235 236 237 238 239 240

/**
* Equality of JSON nodes.
* JSON Reals are considered equal if their string representation is equal.
* JSON Objects are considered equal if they contain the same non-null fields.
*/
instance == JSONNode
241 242 243 244 245 246

/**
* Pretty printed string encoding of JSON nodes.
* This function uses indenting and newlines to make the serialized JSON representation
* more readable than the standard toString instance, which uses minimal whitespace.
*/
247
jsonPrettyPrint :: !JSONNode -> String
248 249