{-# LANGUAGE OverloadedStrings #-}

module LCJF (
    prettyLeadingComma,
) where

import           Data.Aeson        (Value (..))
import qualified Data.Aeson        as Aeson
import qualified Data.Aeson.Key    as Key
import qualified Data.Aeson.KeyMap as KeyMap
import           Data.Bifunctor    (first)
import           Data.List         (sortOn)
import           Data.Scientific   (Scientific)
import qualified Data.Scientific   as Scientific
import qualified Data.Text         as T
import qualified Data.Vector       as V

prettyLeadingComma :: Value -> T.Text
prettyLeadingComma = renderValue 0

renderValue :: Int -> Value -> T.Text
renderValue indent value = case value of
    Null       -> "null"
    Bool True  -> "true"
    Bool False -> "false"
    Number n   -> renderNumber n
    String s   -> renderString s
    Array arr  -> renderArray indent arr
    Object obj -> renderObject indent obj

renderNumber :: Scientific -> T.Text
renderNumber n
    | Scientific.isInteger n = T.pack (show (floor n :: Integer))
    | otherwise = T.pack (show n)

renderString :: T.Text -> T.Text
renderString s = "\"" <> escapeString s <> "\""

escapeString :: T.Text -> T.Text
escapeString = T.concatMap escapeChar
  where
    escapeChar :: Char -> T.Text
    escapeChar c = case c of
        '"' -> "\\\""
        '\\' -> "\\\\"
        '\n' -> "\\n"
        '\r' -> "\\r"
        '\t' -> "\\t"
        _
            | c < ' ' -> T.pack ("\\u" <> pad4 (showHex' (fromEnum c)))
            | otherwise -> T.singleton c

    showHex' :: Int -> String
    showHex' n = showHexDigits n ""

    showHexDigits :: Int -> String -> String
    showHexDigits 0 acc = if null acc then "0" else acc
    showHexDigits m acc = showHexDigits (m `div` 16) (hexDigit (m `mod` 16) : acc)

    hexDigit :: Int -> Char
    hexDigit d
        | d < 10 = toEnum (fromEnum '0' + d)
        | otherwise = toEnum (fromEnum 'a' + d - 10)

    pad4 :: String -> String
    pad4 s = replicate (4 - length s) '0' <> s

indentStr :: Int -> T.Text
indentStr n = T.replicate n (T.singleton ' ')

renderArray :: Int -> V.Vector Value -> T.Text
renderArray indent arr
    | V.null arr = "[ ]"
    | otherwise =
        let items = V.toList arr
            renderedItems = map (renderValue (indent + 2)) items
            firstLine = "[ " <> head renderedItems
            restLines = map (", " <>) (tail renderedItems)
            allLines = firstLine : restLines
            ind = indentStr indent
         in T.intercalate ("\n" <> ind) allLines <> "\n" <> ind <> "]"

renderObject :: Int -> Aeson.Object -> T.Text
renderObject indent obj
    | KeyMap.null obj = "{ }"
    | otherwise =
        let pairs = sortOn fst (map (first Key.toText) (KeyMap.toList obj))
            renderedPairs = map (renderPair indent) pairs
            firstLine = "{ " <> head renderedPairs
            restLines = map (", " <>) (tail renderedPairs)
            allLines = firstLine : restLines
            ind = indentStr indent
         in T.intercalate ("\n" <> ind) allLines <> "\n" <> ind <> "}"

renderPair :: Int -> (T.Text, Value) -> T.Text
renderPair indent (key, value) =
    let renderedKey = renderString key
        renderedValue = renderValue (indent + 2) value
     in case value of
            Array _
                | not (isEmptyArray value) ->
                    renderedKey <> ":\n" <> indentStr (indent + 2) <> renderedValue
            Object _
                | not (isEmptyObject value) ->
                    renderedKey <> ":\n" <> indentStr (indent + 2) <> renderedValue
            _ ->
                renderedKey <> ": " <> renderedValue

isEmptyArray :: Value -> Bool
isEmptyArray (Array arr) = V.null arr
isEmptyArray _           = False

isEmptyObject :: Value -> Bool
isEmptyObject (Object obj) = KeyMap.null obj
isEmptyObject _            = False