implementation module JSONTree

import StdEnv, StdMaybe
import JSON

//--- Decode ----------------------------------
toJSONTree :: String -> Maybe JsonNode
toJSONTree input
# p = (removeWhitespace (snd (lex input 0 [])))
= (parser p)

where
	toArray t = {i \\ i <- t}

	removeWhitespace l = filter (not o isWhitespaceToken) l

	isWhitespaceToken (TokenWhitespace _)	= True
	isWhitespaceToken _						= False

parser :: [Token] -> Maybe JsonNode
parser []		  = Nothing
parser [t:ts] 
| isBracketOpen t = buildArrayNode ts "root"
| isBraceOpen t   = buildObjectNode ts "root"
| otherwise = Nothing
where
	isBracketOpen TokenBracketOpen = True
	isBracketOpen _				   = False
	
	isBraceOpen TokenBraceOpen = True
	isBraceClose _			   = False

buildObjectNode :: [Token] String -> Maybe JsonNode
buildObjectNode [TokenBraceClose] name = Just (JsonEmpty name)
buildObjectNode [t]				  name = Nothing
buildObjectNode input			  name
= case last input of
	TokenBraceClose
		# split = splitContents ( init input )
		# cont  = [ buildNamedNode t \\ t <- split]
		| check cont = Just (JsonObject name [(fromJust t) \\ t <- cont])
		| otherwise = Nothing	
	_				= Nothing
where
	check [] = True
	check [Nothing : ts] = False
	check [(Just obj) : ts] = check ts

buildArrayNode :: [Token] String -> Maybe JsonNode
buildArrayNode [TokenBracketClose] name = Just (JsonEmpty name)
buildArrayNode [t]  			   name = Nothing
buildArrayNode input			   name
= case last input of
	TokenBracketClose
		# split = splitContents ( init input )
		# cont  = [ buildAnonNode t i \\ t <- split & i <- [1..] ]
		| check cont = Just (JsonArray name [(fromJust t) \\ t <- cont])
		| otherwise = Nothing	
	_				= Nothing
where
	check [] = True
	check [Nothing : ts] = False
	check [(Just obj) : ts] = check ts

buildNamedNode :: [Token] -> Maybe JsonNode
buildNamedNode [(TokenString name):TokenColon:rest] = buildNode rest name
buildNamedNode input = Nothing

buildAnonNode :: [Token] Int -> Maybe JsonNode
buildAnonNode input number = buildNode input (toString number)

buildNode :: [Token] String -> Maybe JsonNode
buildNode [(TokenInt v):r] name = Just (JsonInt name v)
buildNode [(TokenReal v):r] name = Just (JsonReal name v)
buildNode [(TokenString v):r] name = Just (JsonString name v) 
buildNode [(TokenBool v):r] name = Just (JsonBool name v)
buildNode [(TokenNull):r] name = Just (JsonNull name)
buildNode [(TokenBracketOpen):r] name = buildArrayNode r name
buildNode [(TokenBraceOpen):r] name = buildObjectNode r name
buildNode r name = Nothing

splitContents :: [Token] -> [[Token]]
splitContents [] = []
splitContents input
	# (c,r) = findComma input [] 0
	= [c : splitContents r]
where
	findComma :: [Token] [Token] Int -> ([Token],[Token])
	findComma [] acc lvl = (acc,[])
	findComma [t:ts] acc lvl
	# lvl						 = adjustLvl t lvl
	| isTokenComma t && lvl == 0 = (acc,ts)
	| otherwise					 = findComma ts (acc++[t]) lvl

	isTokenComma TokenComma = True
	isTokenComma _			= False
	
	adjustLvl TokenBraceOpen    lvl = (lvl+1)
	adjustLvl TokenBracketOpen  lvl = (lvl+1)
	adjustLvl TokenBraceClose   lvl = (lvl-1)
	adjustLvl TokenBracketClose lvl = (lvl-1)
	adjustLvl _					lvl = lvl

//--- Encode ----------------------------------
fromJSONTree :: JsonNode -> String
fromJSONTree (JsonObject name val) = "{"+++jsonTreeToString val+++"}"
fromJSONTree (JsonArray  name val) = "["+++jsonTreeToStringAnon val+++"]"
fromJSONTree node                  = "{"+++jsonTreeToString node+++"}"

class jsonTreeToString a :: a -> String

instance jsonTreeToString JsonNode
where
	jsonTreeToString :: JsonNode -> String
	jsonTreeToString (JsonInt name val) = "\""+++name+++"\" : "+++(toString val)
	jsonTreeToString (JsonReal name val) = "\""+++name+++"\" : "+++(toString val)
	jsonTreeToString (JsonBool name val) = "\""+++name+++"\" : "+++(toString val)
	jsonTreeToString (JsonString name val) = "\""+++name+++"\" : \""+++(toString val)+++"\""
	jsonTreeToString (JsonNull name) = "\""+++name+++"\" : null"
	jsonTreeToString (JsonEmpty name ) = "\""+++name+++"\" : null"
	jsonTreeToString (JsonObject name val) = "\""+++name+++"\" : {"+++jsonTreeToString val+++"}"
	jsonTreeToString (JsonArray name val) = "\""+++name+++"\" : ["+++jsonTreeToStringAnon val+++"]"

instance jsonTreeToString [JsonNode]
where
	jsonTreeToString :: [JsonNode] -> String
	jsonTreeToString []     = ""
	jsonTreeToString [n]    = jsonTreeToString n
	jsonTreeToString [n:ns] = jsonTreeToString n +++ "," +++ jsonTreeToString ns
	
class jsonTreeToStringAnon a :: a -> String

instance jsonTreeToStringAnon JsonNode
where
	jsonTreeToStringAnon :: JsonNode -> String
	jsonTreeToStringAnon (JsonInt name val) = (toString val)
	jsonTreeToStringAnon (JsonReal name val) = (toString val)
	jsonTreeToStringAnon (JsonBool name val) = (toString val)
	jsonTreeToStringAnon (JsonString name val) = "\""+++(toString val)+++"\""
	jsonTreeToStringAnon (JsonNull name) = "null"
	jsonTreeToStringAnon (JsonEmpty name ) = "null"
	jsonTreeToStringAnon (JsonObject name val) = "{"+++jsonTreeToString val+++"}"
	jsonTreeToStringAnon (JsonArray name val) = "["+++jsonTreeToStringAnon val+++"]"

instance jsonTreeToStringAnon [JsonNode]
where
	jsonTreeToStringAnon :: [JsonNode] -> String
	jsonTreeToStringAnon []     = ""
	jsonTreeToStringAnon [n]    = jsonTreeToStringAnon n
	jsonTreeToStringAnon [n:ns] = jsonTreeToStringAnon n +++ "," +++ jsonTreeToStringAnon ns
	

//--- Query -----------------------------------
queryJSONTree :: String JsonNode -> Maybe a | getValue a
queryJSONTree query tree
	# path = splitQuery query
	= seekJsonTree path tree
where
	splitQuery :: {#Char} -> [String]
	splitQuery "" = []
	splitQuery query
		# (c,r) = findSlash query ""
		= [c : splitQuery r]
	
	findSlash :: {#Char} {#Char} -> ({#Char},{#Char})
	findSlash "" acc = (acc,"")
	findSlash query acc
	| query.[0] == '\\' = (acc,{query.[i] \\ i <- [1..((size query)-1)]})
	| otherwise = findSlash {query.[i] \\ i <- [1..((size query)-1)]} (acc+++(toString query.[0]))

seekJsonTree :: [String] JsonNode -> Maybe a | getValue a
seekJsonTree []     node = Nothing
seekJsonTree [t]    node = 
	case seekChild t node of
	(Just child) = getValue child
	Nothing 	 = Nothing
seekJsonTree [t:ts] node =
	case seekChild t node of
	(Just child) = seekJsonTree ts child
	Nothing		 = Nothing

seekChild :: String JsonNode -> Maybe JsonNode
seekChild query (JsonObject name children) = seekChild` query children 
seekChild query (JsonArray name children)  = seekChild` query children 
seekChild query _						   = Nothing

seekChild` :: String [JsonNode] -> Maybe JsonNode
seekChild` query children
	# result = [ child \\ child <- children | (matchName child query) ]
	| length result > 0 = Just (hd result)
						= Nothing
where		
	matchName (JsonInt name val) query
	| (query == name) = True
	                  = False
	matchName (JsonReal name val) query 
	| (query == name) = True
	                  = False
	matchName (JsonString name val) query
	| (query == name) = True
	                  = False
	matchName (JsonBool name val) query 
	| (query == name) = True
	                  = False
	matchName (JsonNull name) query
	| (query == name) = True
	                  = False
	matchName (JsonObject name val) query 
	| (query == name) = True
	                  = False
	matchName (JsonArray name val) query
	| (query == name) = True
	                  = False
	matchName (JsonEmpty name) query 
	| (query == name) = True
	                  = False

instance getValue Int
where
	getValue :: JsonNode -> Maybe Int
	getValue (JsonInt name val) = Just val
	getValue _					= Nothing

instance getValue Real
where
	getValue :: JsonNode -> Maybe Real
	getValue (JsonReal name val) = Just val
	getValue _ 				     = Nothing

instance getValue Bool
where
	getValue :: JsonNode -> Maybe Bool
	getValue (JsonBool name val) = Just val
	getValue _ 				     = Nothing

instance getValue String
where
	getValue :: JsonNode -> Maybe String
	getValue (JsonString name val) = Just val
	getValue _ 				       = Nothing

instance getValue JsonNode
where 
	getValue :: JsonNode -> Maybe JsonNode
	getValue node = Just node

instance getValue [JsonNode]
where 
	getValue :: JsonNode -> Maybe [JsonNode]
	getValue (JsonObject name val) = Just val
	getValue (JsonArray  name val) = Just val
	getValue _					   = Nothing