{-|
Module      : EventLoop.Json
Description : JSON library to parse and show JSON messages.
Copyright   : (c) Sebastiaan la Fleur, 2014
License     : BSD3
Maintainer  : sebastiaan.la.fleur@gmail.com
Stability   : experimental
Portability : All

This JSON library can parse JSON formatted 'String's into 'JSONMessage's. 
-}
module EventLoop.Json(JSONMember(..), JSONMessage(..), retrieve, retrieveError, FromJSON(..), JSONAble(..), stringToJsonObject)  where

import Data.Char (isDigit, isLower, isUpper)
import FPPrac

-- | A row within a 'JSONObject' consisting of a field name ('[Char]'/'String') and field content ('JSONMessage').
data JSONMember = JSONMember [Char] JSONMessage

-- | A 'JSONMessage'.
data JSONMessage = JSONFloat Float        -- ^ A 'JSONFloat'
                | JSONString [Char]       -- ^ A 'JSONString'
                | JSONBool Bool           -- ^ A 'JSONBool'
                | JSONObject [JSONMember] -- ^ A 'JSONObject'. Consists of 'JSONMembers' which express the rows within the object.
                | JSONArray [JSONMessage] -- ^ A 'JSONArray'. Consists of 'JSONMessage's which expresses the different elements in the array.
                
-- | Retrieves the field content ('JSONMessage') associated with the field name ('[Char]') from a list of 'JSONMember's.
retrieve :: [Char] -> [JSONMember] -> Maybe JSONMessage
retrieve search [] = Nothing
retrieve search ((JSONMember name member):list) | search == name = Just member
                                               | otherwise = retrieve search list                
            
-- | Same as 'retrieve' but instead of returning a 'Maybe', it raises an error when the field name could not be found.
--   Usable in situations where you know for sure the field name is in the list of 'JSONMember's.            
retrieveError :: [Char] -> [JSONMember] -> JSONMessage
retrieveError search members = case (retrieve search members) of
                                Nothing -> error ("Could not find " ++ search ++ " in JSON members")
                                Just result -> result

-- | Class expressing that type a is parsable from a 'JSONMessage'.
class FromJSON a where
    -- | Function to call to parse a 'JSONMessage' to type a.
    fromJsonMessage :: JSONMessage -> a
    
-- | Instance expressing how to 'Show' a 'JSONMessage'    
instance Show JSONMessage where    
    show (JSONFloat f)       = show f
    show (JSONString s)      = "\"" ++ escapeStringJson s ++ "\""
    show (JSONBool bool)     | bool      = "true"
                             | otherwise = "false"
    show (JSONObject (r:rs)) = "{" ++ rows ++ "}"
                                    where
                                        rows = foldl insertComma (show r) (map show rs)
    show (JSONArray [])       = "[]"
    show (JSONArray (x:xs))     = "[" ++ list ++ "]"
                                    where
                                        list = foldl insertComma (show x) (map show xs)

-- | Private support function
insertComma :: [Char] -> [Char] -> [Char]
insertComma a b = a ++ "," ++ b                

-- | Instance expressing how to 'Show' a 'JSONMember'.
instance Show JSONMember where
    show (JSONMember name m) = "\"" ++ name ++ "\": " ++ (show m)

-- | Function expressing which characters need to be escaped in a JSON formatted 'String'.
escapeStringJson :: [Char] -> [Char]
escapeStringJson [] = ""
escapeStringJson (c:cs) | c == '"' || c == '\\' = '\\':c:rest
                        | otherwise = c:rest
                        where
                            rest = escapeStringJson cs

-- | Class expressing that type a can be parsed into a 'JSONMessage'.
class JSONAble a where
    toJsonMessage :: a -> JSONMessage
  
-- | Function to parse a 'JSONMessage' from a 'String'.
stringToJsonObject :: [Char] -> JSONMessage
stringToJsonObject string = snd $ parse O string (JSONObject []) 
  
-- JSON Grammar for 1 object
-- Grammar returns (Rest, JSONObject [JSONRow])
-- O: '{' R+ '}'
-- R: '"' W '"' ':' V
-- V: '"' (JSONInt N | JSONString W) '"'
-- N: ('1' | '2' | '3' | ... | '0')+
-- W: ('a' | 'b' | 'c' | ... | 'z') (N | W | -)

-- | Private
data Grammer = O | R
-- | Private
type Rest = [Char]

-- | Private
errorMsg :: [Char] -> [Char] -> [Char]
errorMsg exp act = "Fault at parsing, expected '" ++ exp ++ "' but found '" ++ act ++ "'"

-- | Private
parse :: Grammer -> Rest -> JSONMessage -> (Rest, JSONMessage)
parse O [] _ = error (errorMsg "something" "premature end (start of message)")
parse O (c1:cs) (JSONObject rows)     | c1 == '{' = result
                                    | otherwise = error (errorMsg "{" [c1])
                                    where
                                        ((c1':cs'), object) = parse R cs (JSONObject rows)
                                        result     | c1' == '}' = (cs', object)
                                                | otherwise = error (errorMsg "}" [c1'])

parse R [] _ = error (errorMsg "something" "premature end (reading a row)")                                        
parse R (t:ts) (JSONObject rows) = object
                                    where
                                        ((r:rs), rowName) | t == '"' = parseWord ts                 -- Read row name
                                                          | otherwise = error (errorMsg "\"" [t])  
                                        rs'    | r == ':' = rs                                         -- Read row delimiter
                                            | otherwise = error (errorMsg ":" [r])
                                        ((r'':rs''), var2) = parseVariable rs'                      -- Read variable for row
                                        rows' = rows ++ [(JSONMember rowName var2)]                 -- Add found result to other rows
                                        object     | r'' == '}' = ((r'':rs''), JSONObject rows')       -- End, return result
                                                | r'' == ',' = parse R rs'' (JSONObject rows')      -- Read next row
                                                | otherwise = error (errorMsg "',' or '}'" [r''])                                    

-- Possibilities:
-- "\"string123value\"" -> JSONString "string123value" or "12345" -> JSONInt 12345 
-- | Private                                   
parseVariable :: Rest -> (Rest, JSONMessage)                                        
parseVariable [] = error (errorMsg "something" "premature end")
parseVariable [c1] = error (errorMsg "longer variable" (c1:" and premature end"))                
parseVariable (c1:cs)    | c1 == '"'  = (r1, JSONString word)
                         | isDigit c1 = (r2, JSONFloat (read number))
                         | otherwise = error (errorMsg "\" or digit" [c1])
                            where
                                (r1, word)   = parseWord (cs)
                                (r2, number) = parseNumber (c1:cs)

-- | Private
parseWord :: Rest -> (Rest, [Char])
parseWord [] = error (errorMsg "something" "premature end")
parseWord (c1:cs)   | c1 == '"' = (cs, [])
                    | otherwise = (r1, c1:result')
                    where
                        (r1, result') = parseWord cs

-- | Private
parseNumber :: Rest -> (Rest, [Char])                         
parseNumber [] = error (errorMsg "something" "premature end")                         
parseNumber (c1:cs) | isDigit c1 || c1 == '.' = (r1, c1:result')
                    | c1 == ',' || c1 == '}' = (c1:cs, [])
                    | otherwise = error (errorMsg "number" [c1])
                            where
                                (r1, result') = parseNumber cs