-- TODO: Ask wether #{ } should be changed to something else as it might be confusing

module QuickPlot.IPC.QQParser (
      JSONValue (..)
    , HashKey (..)
    , parseTHJSON
) where

import           Control.Applicative
import           Language.Haskell.TH
import           Text.ParserCombinators.Parsec hiding (many, (<|>))
import           Language.Haskell.Meta.Parse
import qualified Data.Attoparsec.Text as A
import           Data.Scientific (Scientific)
import qualified Data.Text as T


data JSONValue = JSONNull
               | JSONString String
               | JSONNumber Scientific
               | JSONObject [(HashKey,JSONValue)]
               | JSONArray [JSONValue]
               | JSONBool Bool
               | JSONCode Exp
               deriving (Eq, Show)

data HashKey = HashVarKey String
             | HashStringKey String
             deriving (Eq, Show)



parseTHJSON :: String -> Either ParseError JSONValue
parseTHJSON = parse (jpValue <* eof) "txt"

type JSONParser = Parser JSONValue

jpValue :: JSONParser
jpValue = do
    spaces
    res <- jpBool <|> jpNull <|> jpString <|> jpObject <|> jpNumber  <|> jpArray <|> jpCode
    spaces
    return res

-- jpValue :: JSONParser
-- jpValue = do
--     spaces
--     res <- jpBool <|> jpNull <|> jpString <|> jpObject <|> jpNumber  <|> jpArray <|> jpCode
--     spaces
--     return res

jpBool :: JSONParser
jpBool = JSONBool <$> (string "true" *> pure True <|> string "false" *> pure False)

jpCode :: JSONParser
jpCode = JSONCode <$> (string "#{" *> parseExp')
    where parseExp' = do
                str <- many1 (noneOf "}") <* char '}'
                case parseExp str of
                    Left l -> fail l
                    Right r -> return r

jpNull :: JSONParser
jpNull = string "null" *> pure JSONNull

jpString :: JSONParser
jpString = between (char '"') (char '"') (option [""] $ many chars) >>= return . JSONString . concat -- do

jpNumber :: JSONParser
jpNumber = JSONNumber <$> do
    isMinus <- option "" (string "-")
    d <- many1 digit
    o <- option "" withDot
    e <- option "" withE
    convert (isMinus ++ d ++ o ++ e)
    where withE = do
                e <- char 'e' <|> char 'E'
                plusMinus <- option "" (string "+" <|> string "-")
                d <- many digit
                return $ e : plusMinus ++ d
          withDot = do
                o <- char '.'
                d <- many digit
                return $ o:d


convert :: Monad m => String -> m Scientific
convert = either fail return . A.parseOnly (A.scientific <* A.endOfInput) . T.pack


jpObject :: JSONParser
jpObject = do
    list <- between (char '{') (char '}') (spaces *> commaSep jpHash)
    return $ JSONObject list
    where
        jpHash :: CharParser () (HashKey,JSONValue) -- (String,JSONValue)
        jpHash = do
            spaces
            name <- varKey <|> symbolKey <|> quotedStringKey
            spaces
            _ <- char ':'
            spaces
            value <- jpValue
            spaces
            return (name,value)

symbolKey :: CharParser () HashKey
symbolKey = HashStringKey <$> symbol

quotedStringKey :: CharParser () HashKey
quotedStringKey = HashStringKey <$> quotedString

varKey :: CharParser () HashKey
varKey = HashVarKey <$> (char '$' *> symbol)

jpArray :: CharParser () JSONValue
jpArray = JSONArray <$> between (char '[') (char ']') (spaces *> commaSep jpValue)

-------
-- helpers for parser/grammar
quotedString :: CharParser () String
quotedString = concat <$> between (char '"') (char '"') (option [""] $ many chars)

symbol :: CharParser () String
symbol = many1 (noneOf "\\ \":;><${}")

commaSep :: CharParser () a -> CharParser () [a]
commaSep p  = p `sepBy` (char ',')

chars :: CharParser () String
chars = try (string "\\\"" *> pure "\"")
    <|> try (string "\\\\" *> pure "\\")
    <|> try (string "\\/" *> pure "/")
    <|> try (string "\\b" *> pure "\b")
    <|> try (string "\\f" *> pure "\f")
    <|> try (string "\\n" *> pure "\n")
    <|> try (string "\\r" *> pure "\r")
    <|> try (string "\\t" *> pure "\t")
    <|> try  unicodeChars
    <|> many1 (noneOf "\\\"")

unicodeChars :: CharParser () String
unicodeChars = do
    u <- string "\\u"
    d1 <- hexDigit
    d2 <- hexDigit
    d3 <- hexDigit
    d4 <- hexDigit
    return $ u ++ (d1 : d2 : d3 : [d4])