module Data.JSON.QQ (JsonValue (..), HashKey (..), parsedJson) 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

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

-------
-- Internal representation

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)

type JsonParser = Parser JsonValue

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 :: String -> Parser 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 = do
       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]