implementation module JSON

import StdEnv
import StdGeneric, StdMaybe, StdString
import Text
import Types

//Token type which is the intermediary representation during JSON parsing
:: Token	= TokenInt Int
			| TokenReal	Real
			| TokenString String
			| TokenBool	Bool
			| TokenNull
			| TokenBracketOpen
			| TokenBracketClose
			| TokenBraceOpen
			| TokenBraceClose
			| TokenName	String
			| TokenColon
			| TokenComma
			| TokenWhitespace String
			| TokenFail	

//Basic JSON serialization
instance toString JSONNode
where
	//Escape all strings -> make target string -> copy characters
	//The reason why first a big string is made into which the characters are copied is to
	//avoid many string concatenations with big strings
	toString node
		# node = escapeAll node
		# len = sizeOf node
		= snd (copyNode 0 node (createArray len '\0'))

//Determine serialized size of a JSON datastructure
sizeOf :: !JSONNode -> Int
sizeOf (JSONNull)		= 4
sizeOf (JSONBool True)	= 4
sizeOf (JSONBool False)	= 5
sizeOf (JSONInt x)		= size (toString x)
sizeOf (JSONReal x)		= size (toString x)
sizeOf (JSONString x)	= size x + 2
sizeOf (JSONArray x)	= let len = length x in (if (len > 0) (sum (map sizeOf x) + len - 1) 0) + 2
sizeOf (JSONObject x)	= let len = length x in (if (len > 0) (sum (map (\(l,o) -> size l + 2 + 1 + sizeOf o) x) + len - 1) 0) + 2
sizeOf (JSONRaw x)		= size x
sizeOf (JSONError)		= 0

//Escape all strings in a JSON structure
escapeAll :: !JSONNode -> JSONNode
escapeAll (JSONString s)	= JSONString (jsonEscape s)
escapeAll (JSONArray x)		= JSONArray (map escapeAll x)
escapeAll (JSONObject x)	= JSONObject (map (\(l,o) -> (l,escapeAll o)) x)
escapeAll node				= node

//Copy structure to a string
copyNode :: !Int !JSONNode !*{#Char} -> *(!Int, !*{#Char})
copyNode start (JSONNull) buffer		= (start + 4, copyChars start 0 4 "null" buffer)
copyNode start (JSONBool True) buffer	= (start + 4, copyChars start 0 4 "true" buffer)
copyNode start (JSONBool False) buffer	= (start + 5, copyChars start 0 5 "false" buffer)
copyNode start (JSONInt x) buffer		= let s = toString x in (start + size s, copyChars start 0 (size s) s buffer)
copyNode start (JSONReal x) buffer		= let s = toString x in (start + size s, copyChars start 0 (size s) s buffer)
copyNode start (JSONString x) buffer	= let len = size x in (start + len + 2 , copyChars (start + 1) 0 len x {buffer & [start] = '"', [start + len + 1] = '"'})
copyNode start (JSONArray items) buffer
	# (start,buffer)	= (start + 1, {buffer & [start] = '['})
	# (start,buffer)	= copyArrayItems start items buffer
	= (start + 1, {buffer & [start] = ']'})
where
	copyArrayItems start [] buffer = (start,buffer)
	copyArrayItems start [x] buffer = copyNode start x buffer
	copyArrayItems start [x:xs] buffer
		# (start,buffer) = copyNode start x buffer
		= copyArrayItems (start + 1) xs {buffer & [start] = ','}
copyNode start (JSONObject items) buffer
	# (start,buffer)	= (start + 1, {buffer & [start] = '{'})
	# (start,buffer)	= copyObjectItems start items buffer
	= (start + 1, {buffer &	[start] = '}'})
where
	copyObjectItems start [] buffer = (start,buffer)
	copyObjectItems start [(l,x)] buffer
		# (start,buffer) = let len = size l in (start + len + 3 , copyChars (start + 1) 0 len l {buffer & [start] = '"', [start + len + 1] = '"', [start + len + 2] = ':'})
		= copyNode start x buffer
	copyObjectItems start [(l,x):xs] buffer
		# (start,buffer) = let len = size l in (start + len + 3 , copyChars (start + 1) 0 len l {buffer & [start] = '"', [start + len + 1] = '"', [start + len + 2] = ':'})
		# (start,buffer) = copyNode start x buffer
		= copyObjectItems (start + 1) xs {buffer & [start] = ','}
copyNode start (JSONRaw x) buffer	= (start + size x, copyChars start 0 (size x) x buffer) 	
copyNode start _ buffer				= (start,buffer)

copyChars offset i num src dst
	| i == num		= dst
	| otherwise		= copyChars offset (inc i) num src {dst & [offset + i] = src.[i]}

//Basic JSON deserialization (just structure)
instance fromString JSONNode
where
	//Lex -> remove whitespace -> parse 
	fromString s = fst (parse (removeWhitespace (snd (lex s 0 []))))

lex :: String Int [Token] -> (Int, [Token])
lex input offset tokens
	| offset >= size input	= (offset, reverse tokens) 				//Done
							= lex input newOffset [token:tokens]	//Lex another token and do recursive call
where
	(newOffset, token)		= lexAny input offset lexFunctions
	lexFunctions			= [ lexBracketOpen
							  , lexBracketClose
							  , lexBraceOpen
							  , lexBraceClose
							  , lexColon
							  , lexComma
							  , lexNull
							  , lexTrue
							  , lexFalse
							  , lexWhitespace
							  , lexNumber
							  , lexString
							  ]
	//Try any of the lexers in the list until one succeeds
	lexAny :: String Int [(String Int -> Maybe (Int, Token))] -> (Int, Token) 
	lexAny input offset [] = (size input, TokenFail)
	lexAny input offset [f:fs] = case f input offset of
		(Just result)	= result
		(Nothing)		= lexAny input offset fs
	
	//Lex token of fixed size
	lexFixed chars token input offset
		| input % (offset,offset + (size chars) - 1) == chars	= Just (offset + (size chars), token)
																= Nothing
	//Single character lex functions													
	
	lexBracketOpen	= lexFixed "[" TokenBracketOpen
	lexBracketClose	= lexFixed "]" TokenBracketClose
	lexBraceOpen	= lexFixed "{" TokenBraceOpen
	lexBraceClose	= lexFixed "}" TokenBraceClose
	lexColon		= lexFixed ":" TokenColon
	lexComma		= lexFixed "," TokenComma
	
	//Fixed width lex functions
	
	lexNull			= lexFixed "null" TokenNull
	lexTrue			= lexFixed "true" (TokenBool True)
	lexFalse		= lexFixed "false" (TokenBool False)
	
	//Variable width lex functions
	
	//Whitespace
	lexWhitespace input offset
		| last == offset	= Nothing
							= Just (last, TokenWhitespace (input % (offset,last - 1)))
	where
		last = findEnd isSpace input offset
	//Numbers
	lexNumber input offset
		| intpart == offset	= Nothing
		| otherwise
			| fracpart == intpart	= Just (intpart, TokenInt (toInt (input % (offset,intpart - 1))))
			| otherwise
				| exppart == fracpart	= Just (fracpart, TokenReal (toReal (input % (offset, fracpart - 1))))
				| otherwise				= Just (exppart, TokenReal (toReal (input % (offset, exppart - 1))))
	where	
		intpart		= findEnd isDigit input (optMin input offset)
		fracpart	= optFrac input intpart
		exppart		= optExp input fracpart

	//If the current char is a -, advance the offset by one
	optMin input offset
		| offset >= size input			= offset
		| input.[offset] == '-'			= offset + 1
										= offset
	//If the current char is a '.' advance the offset as long as we find digits
	optFrac input offset
		| offset >= size input			= offset
		| input.[offset] == '.'			= findEnd isDigit input (offset + 1)
										= offset
	//If the current char is 'e' or 'E' advance the offset as long as we can
	//after an optional '-'. If we can't advance after the 'e' stop.
	optExp input offset
		| offset >= size input			= offset
		| input.[offset] == 'e' || input.[offset] == 'E'
			| end == offset + 1			= offset
			| otherwise					= end
		| otherwise						= offset
	where
		end	= findEnd isDigit input (optMin input (offset + 1))
		
	//Find the first offset where the predicate no longer holds					
	findEnd pred input offset
			| offset >= size input		= offset
			| pred input.[offset]		= findEnd pred input (offset + 1)
										= offset
	//String
	lexString input offset
		| offset >= size input			= Nothing
		| input.[offset] <> '"'			= Nothing
										= Just (end, TokenString (input % (offset + 1, end - 2)))
	where
		end = findStringEnd input (offset + 1)
		
		findStringEnd input offset
			| offset >= size input		= offset
			| input.[offset] == '"'		= offset + 1
			| input.[offset] == '\\'	= findStringEnd input (offset + 2) //Skip the escaped character
										= findStringEnd input (offset + 1)
		
//Whitespace removal
removeWhitespace :: [Token] -> [Token]
removeWhitespace l = filter (not o isWhitespaceToken) l

isWhitespaceToken :: Token -> Bool
isWhitespaceToken (TokenWhitespace _)	= True
isWhitespaceToken _						= False

//Simple recursive descent parser
parse :: ![Token] -> (!JSONNode,![Token])
parse [TokenNull:ts] 							= (JSONNull, ts)
parse [TokenBool x:ts] 							= (JSONBool x, ts)
parse [TokenInt x:ts]							= (JSONInt x, ts)
parse [TokenReal x:ts] 							= (JSONReal x, ts)
parse [TokenString x:ts]						= (JSONString (jsonUnescape x), ts)
parse [TokenBracketOpen,TokenBracketClose:ts]	= (JSONArray [], ts)
parse [TokenBracketOpen:ts]
	= case (parseArrayItems ts []) of
		([TokenBracketClose:ts`],items)	= (JSONArray (reverse items), ts`)
		_								= (JSONError, ts)
where
	parseArrayItems :: ![Token] ![JSONNode] -> (![Token],![JSONNode])
	parseArrayItems tokens nodes
		= case (parse tokens) of
			(node,[TokenComma:ts])	= parseArrayItems ts [node:nodes]
			(node,ts)				= (ts,[node:nodes])
parse [TokenBraceOpen:TokenBraceClose:ts]		= (JSONObject [], ts)
parse [TokenBraceOpen:ts]
	= case (parseObjectItems ts []) of
		([TokenBraceClose:ts`],items)	= (JSONObject (reverse items), ts`)
		_								= (JSONError, ts)
where
	parseObjectItems :: ![Token] ![(!String,!JSONNode)] -> (![Token],![(!String,!JSONNode)])
	parseObjectItems tokens nodes
		= case (parse tokens) of
			(JSONString label,[TokenColon:ts])
				= case (parse ts) of
					(node,[TokenComma:ts`])	= parseObjectItems ts` [(label,node):nodes]
					(node,ts`)				= (ts`,[(label,node):nodes])
			_
				= (tokens,nodes)
parse tokens = (JSONError,tokens)


//Escape a string
jsonEscape :: !String -> String
jsonEscape src = copyChars 0 0 reps src (createArray (size src + length reps) '\0')
where
	reps	= findChars 0 src	
	//Find the special characters
	findChars :: Int String -> [(!Int,!Char)]
	findChars i s
		| i >= size s 	= []
		| c == '\\' || c == '"' || c == '/' || c == '\b' || c == '\f' || c == '\n' || c == '\r' || c == '\t'
			= [(i,c): findChars (i + 1) s] 
			= findChars (i + 1) s
		where 
			c = s.[i]
	//Build the escaped string from the original and the replacements		
	copyChars :: Int Int [(!Int, !Char)] String *String -> *String
	copyChars is id [] src dest
		| is < size src		=	copyChars (is + 1) (id + 1) [] src {dest & [id] = src.[is]}
							=	dest
	copyChars is id reps=:[(ir,c):rs] src dest
		| is == ir			=	copyChars (is + 1) (id + 2) rs src {dest & [id] = '\\', [id + 1] = rep c}
							=	copyChars (is + 1) (id + 1) reps src {dest & [id] = src.[is]}
		where
			rep '\\'	= '\\'
			rep '"'		= '"'
			rep '/'		= '/'
			rep '\b'	= 'b'
			rep '\f'	= 'f'
			rep '\n'	= 'n'
			rep '\r'	= 'r'
			rep '\t'	= 't'
			
//Unescape a string
jsonUnescape :: !String -> String
jsonUnescape s = unescape` s 0
where
	unescape` s offset
		| offset >= size s	= s
		| s.[offset] == '\\'
			| offset + 1 >= size s		= s
			| otherwise = tryReplace s (offset + 1) controlChars
		| otherwise			= unescape` s (offset + 1)
	
	tryReplace s offset []	= unescape` s offset 
	tryReplace s offset [(c,r):xs]
		| s.[offset] == c	= s % (0, offset - 2) +++ r +++ jsonUnescape (s % (offset + 1, size s))
		| otherwise			= tryReplace s offset xs
		
	controlChars = [('\\',"\\"),('"',"\""),('/',"/"),('b',"\b"),('f',"\f"),('n',"\n"),('t',"\t")]

//Intersperse an element on a list
intersperse :: a [a] -> [a]
intersperse i [] = []
intersperse i [x] = [x]
intersperse i [x:xs] = [x,i:intersperse i xs]

//-------------------------------------------------------------------------------------------

toJSON :: a -> JSONNode | JSONEncode{|*|} a
toJSON x = case (JSONEncode{|*|} x) of
	[node]	= node
	_		= JSONError 

/*
* Generic JSON encoder
*/
generic JSONEncode t :: t -> [JSONNode]

JSONEncode{|Int|} x = [JSONInt x]
JSONEncode{|Real|} x = [JSONReal x]
JSONEncode{|Char|} x = [JSONString {x}]
JSONEncode{|Bool|} x = [JSONBool x]
JSONEncode{|String|} x = [JSONString x]
JSONEncode{|UNIT|} (UNIT) = []
JSONEncode{|PAIR|} fx fy (PAIR x y) = fx x ++ fy y
JSONEncode{|EITHER|} fx fy (LEFT x) = fx x
JSONEncode{|EITHER|} fx fy (RIGHT y) = fy y
JSONEncode{|OBJECT|} fx (OBJECT x) = fx x
JSONEncode{|CONS of d|} fx (CONS x)
	//Record
	| length d.gcd_fields <> 0	= [JSONObject [ (f.gfd_name, o)\\ o <- fx x & f <- d.gcd_fields ]]
	//Constructor without parameters
	| d.gcd_arity == 0			= [JSONString d.gcd_name]
	//Constructor with parameters				
	| otherwise					= [JSONArray [JSONString d.gcd_name : fx x]]
	
JSONEncode{|FIELD of d|} fx (FIELD x) = fx x							
JSONEncode{|[]|} fx x = [JSONArray (flatten [fx e \\ e <- x])]
JSONEncode{|(,)|} fx fy (x,y) = [JSONArray (fx x ++ fy y)]
JSONEncode{|(,,)|} fx fy fz (x,y,z) = [JSONArray (fx x ++ fy y ++ fz z)]
JSONEncode{|(,,,)|} fx fy fz fi (x,y,z,i) = [JSONArray (fx x ++ fy y ++ fz z ++ fi i)]
JSONEncode{|(,,,,)|} fx fy fz fi fj (x,y,z,i,j) = [JSONArray (fx x ++ fy y ++ fz z ++ fi i ++ fj j)]
JSONEncode{|{}|} fx x = [JSONArray (flatten [fx e \\ e <-: x])]
JSONEncode{|{!}|} fx x = [JSONArray (flatten [fx e \\ e <-: x])]
JSONEncode{|Maybe|} fx (Just x) = fx x
JSONEncode{|Maybe|} fx (Nothing) = [JSONNull]
JSONEncode{|JSONNode|} node = [node]

//-------------------------------------------------------------------------------------------
fromJSON :: JSONNode -> Maybe a | JSONDecode{|*|} a
fromJSON node = fst (JSONDecode{|*|} [node])

/*
* Generic JSON parser, using a list of tokens
*/
generic JSONDecode t :: [JSONNode] -> (!Maybe t, ![JSONNode])

JSONDecode{|Int|} [JSONInt i:xs]		= (Just i, xs)
JSONDecode{|Int|} l						= (Nothing, l)

JSONDecode{|Real|} [JSONReal r:xs]		= (Just r, xs)
JSONDecode{|Real|} [JSONInt i:xs]		= (Just (toReal i), xs)
JSONDecode{|Real|} l					= (Nothing, l)

JSONDecode{|Char|} l =: [JSONString s:xs]
	| size s == 1						= (Just s.[0],xs)
										= (Nothing, l)
JSONDecode{|Char|} l					= (Nothing, l)

JSONDecode{|Bool|} [JSONBool b:xs]		= (Just b,xs)
JSONDecode{|Bool|} l					= (Nothing, l)

JSONDecode{|String|} [JSONString s:xs]	= (Just s, xs)
JSONDecode{|String|} l					= (Nothing, l)

JSONDecode{|UNIT|} l					= (Just UNIT, l)

JSONDecode{|PAIR|} fx fy l = case fx l of
	(Just x,xs)	= case fy xs of
		(Just y, ys)			= (Just (PAIR x y), ys)
		_						= (Nothing, l)
	_							= (Nothing, l)
	
JSONDecode{|EITHER|} fx fy l = case fx l of
	(Just x, xs)				= (Just (LEFT x),xs)
	(Nothing, xs)				= case fy l of
		(Just y, ys)			= (Just (RIGHT y),ys)
		(Nothing, ys)			= (Nothing, l)

JSONDecode{|OBJECT|} fx l = case fx l of
	(Just x, xs)	= (Just (OBJECT x),xs)
	_				= (Nothing, l)

JSONDecode{|CONS of d|} fx l
	//Records
	| length d.gcd_fields <> 0	= case l of
		[JSONObject fields: xs] = case fx [JSONObject fields] of
			(Just x, _)						= (Just (CONS x),xs)
			_								= (Nothing, l)
		_									= (Nothing, l)
	//Constructor without parameters
	| d.gcd_arity == 0			= case l of
		[JSONString name: xs]
			| name == d.gcd_name			= case fx xs of
				(Just x, ys)				= (Just (CONS x),ys)
				_							= (Nothing, l)
			| otherwise						= (Nothing, l)
		_									= (Nothing, l)
	//Constructor with parameters
	| otherwise					= case l of
		[JSONArray [JSONString name:fields] :xs]
			| name == d.gcd_name			= case fx fields of
				(Just x, _)					= (Just (CONS x), xs)
				_							= (Nothing, l)
			| otherwise						= (Nothing, l)
		_									= (Nothing, l)
		
JSONDecode{|CONS|} fx l = (Nothing, l)

JSONDecode{|FIELD of d|} fx l =: [JSONObject fields]
	= case findField d.gfd_name fields of
		(Just field)	= case fx [field] of
			(Just x, _)	= (Just (FIELD x), l)
			_			= (Nothing, l)
		_				= (Nothing, l)
where
	findField match [] 	= Nothing
	findField match [(l,x):xs]
		| l == match 	= Just x
						= findField match xs
						
JSONDecode{|FIELD|} fx l = (Nothing, l)

JSONDecode{|[]|} fx l =:[JSONArray items:xs]
	= case decodeItems fx items of
		(Just x)		= (Just x, xs)
		_				= (Nothing, l)
JSONDecode{|[]|} fx l 	= (Nothing, l)

JSONDecode{|(,)|} fx fy l =:[JSONArray [xo,yo]:xs]
	= case fx [xo] of
		(Just x,_)	= case fy [yo] of
			(Just y,_)		= (Just (x,y), xs)
			_				= (Nothing, l)
		_					= (Nothing, l)
JSONDecode{|(,)|} fx fy l	= (Nothing, l)

JSONDecode{|(,,)|} fx fy fz l =:[JSONArray [xo,yo,zo]:xs]
	= case fx [xo] of
		(Just x,_)	= case fy [yo] of
			(Just y,_)			= case fz [zo] of
				(Just z,_)		= (Just (x,y,z), xs)
				_				= (Nothing, l)
			_					= (Nothing, l)
		_						= (Nothing, l)
JSONDecode{|(,,)|} fx fy fz l	= (Nothing, l)

JSONDecode{|(,,,)|} fx fy fz fi l =:[JSONArray [xo,yo,zo,io]:xs]
	= case fx [xo] of
		(Just x,_)	= case fy [yo] of
			(Just y,_)	= case fz [zo] of
				(Just z,_) = case fi [io] of
					(Just i,_)		= (Just (x,y,z,i), xs)
					_				= (Nothing, l)
				_					= (Nothing, l)
			_						= (Nothing, l)
		_							= (Nothing, l)
JSONDecode{|(,,,)|} fx fy fz fi l	= (Nothing, l)

JSONDecode{|(,,,,)|} fx fy fz fi fj l =:[JSONArray [xo,yo,zo,io,jo]:xs]
	= case fx [xo] of
		(Just x,_)	= case fy [yo] of
			(Just y,_)	= case fz [zo] of
				(Just z,_) = case fi [io] of
					(Just i,_)	= case fj [jo] of
						(Just j,_)		= (Just (x,y,z,i,j), xs)
						_				= (Nothing, l)
					_					= (Nothing, l)
				_						= (Nothing, l)
			_							= (Nothing, l)
		_								= (Nothing, l)
JSONDecode{|(,,,,)|} fx fy fz fi fj l	= (Nothing, l)

JSONDecode{|{}|} fx l =:[JSONArray items:xs]
	= case decodeItems fx items of
		(Just x)		= (Just {e \\ e <- x}, xs)
		_				= (Nothing, l)
JSONDecode{|{}|} fx l 	= (Nothing, l)

JSONDecode{|{!}|} fx l =:[JSONArray items:xs]
	= case decodeItems fx items of
		(Just x)		= (Just {e \\ e <- x}, xs)
		_				= (Nothing, l)
JSONDecode{|{!}|} fx l 	= (Nothing, l)

decodeItems fx [] 		= Just []
decodeItems fx [ox:oxs]	= case fx [ox] of
	(Just x, _)	= case decodeItems fx oxs of
		(Just xs)	= Just [x:xs]
		_ 			= Nothing
	_			= Nothing

JSONDecode{|Maybe|} fx [JSONNull:xs]	= (Just Nothing, xs)
JSONDecode{|Maybe|} fx l = case fx l of
	(Just x,xs)							= (Just (Just x), xs)
	_									= (Nothing,l)

JSONDecode{|JSONNode|} [x:xs]			= (Just x, xs)
JSONDecode{|JSONNode|} l				= (Nothing, l)

jsonQuery :: !String !JSONNode -> Maybe a | JSONDecode{|*|} a
jsonQuery path node
	= case (findNode (split "/" path) node ) of
		Just child	= fromJSON child
		Nothing		= Nothing
where
	findNode :: ![String] !JSONNode -> (Maybe JSONNode)
	findNode [] node	= Just node
	findNode [s:ss] (JSONObject fields)
		= case findField s fields of
			Just f	= findNode ss f
			Nothing	= Nothing
	findNode [s:ss] (JSONArray items)
		# index = toInt s
		| index >= 0 && index < length items	= findNode ss (items !! index)
		| otherwise								= Nothing
	findNode _ _		= Nothing
	
	findField s []			= Nothing
	findField s [(l,x):xs]	= if (l == s) (Just x) (findField s xs)