PrettyJson.hs

#!/usr/bin/env nix-shell
#! nix-shell -i runhaskell -p ghcid ghc

import Control.Applicative
import Data.Char
import Data.List
import Data.Maybe
import Text.Read

main :: IO ()
main = interact $ prettifyJson
  where
    prettifyJson string = fromMaybe "Bad Json" $ prettyShow <$> parseJson string

data JsonValue
  = JsonNull
  | JsonBool Bool
  | JsonNumber Int
  | JsonString String
  | JsonArray [JsonValue]
  | JsonObject [(String, JsonValue)]
  deriving (Show)

newtype Parser a = Parser {runP :: String -> Maybe (String, a)}

instance Functor Parser where
  fmap f (Parser parser) = Parser $ \string -> do
    (rest, a) <- parser string
    pure (rest, f a)

instance Applicative Parser where
  pure a = Parser $ \string -> Just (string, a)
  (Parser p1) <*> (Parser p2) = Parser $ \string -> do
    (rest1, f) <- p1 string
    (rest2, a) <- p2 rest1
    pure (rest2, f a)

instance Alternative Parser where
  empty = Parser $ \_ -> Nothing
  (Parser p1) <|> (Parser p2) = Parser $ \string -> p1 string <|> p2 string

instance Monad Parser where
  (Parser p1) >>= f = Parser $ \string -> do
    (rest, a) <- p1 string
    runP (f a) rest

prettyShow :: JsonValue -> String
prettyShow string = go 1 string <> "\n"
  where
    go i value =
      case value of
        JsonNull -> "null"
        JsonBool True -> "true"
        JsonBool False -> "false"
        JsonNumber number -> show number
        JsonString string -> "\"" <> string <> "\""
        JsonArray [] -> "[]"
        JsonArray values ->
          "[\n" <> prettyValues <> "\n" <> (withIndent (i - 1) "]")
          where
            prettyValues = withCommaBreaks $ map (withIndent i . go (i + 1)) values
        JsonObject [] -> "{}"
        JsonObject pairs ->
          "{\n" <> prettyPairs <> "\n" <> (withIndent (i - 1) "}")
          where
            prettyPairs = withCommaBreaks $ map (withIndent i . prettyPair) pairs
            prettyPair (key, value) = "\"" <> key <> "\": " <> go (i + 1) value
      where
        withIndent amount str = (concat $ replicate amount "    ") <> str
    withCommaBreaks = intercalate ",\n"

parseJson :: String -> Maybe JsonValue
parseJson string = snd <$> runP jsonValue string

jsonValue :: Parser JsonValue
jsonValue = jsonNull <|> jsonBool <|> jsonNumber <|> jsonString <|> jsonArray <|> jsonObject

jsonObject :: Parser JsonValue
jsonObject = JsonObject <$> (charP '{' *> ws *> pairs <* ws <* charP '}')
  where
    pairs = sepBy (ws *> charP ',' <* ws) pair
    pair = (,) <$> (quotedString <* ws <* charP ':' <* ws) <*> jsonValue

jsonArray :: Parser JsonValue
jsonArray = JsonArray <$> (charP '[' *> ws *> arrayItems <* ws <* charP ']')
  where
    arrayItems = sepBy (ws *> charP ',' <* ws) jsonValue

sepBy :: Parser a -> Parser b -> Parser [b]
sepBy sep item = (:) <$> item <*> many (ws *> charP ',' *> ws *> item) <|> pure []

jsonString :: Parser JsonValue
jsonString = JsonString <$> quotedString

quotedString :: Parser String
quotedString = (charP '"' *> whileP (/= '"') <* charP '"')

jsonNumber :: Parser JsonValue
jsonNumber = whileP isDigit >>= parseNumber
  where
    parseNumber string =
      case readMaybe string of
        Just number -> pure $ JsonNumber number
        Nothing -> empty

jsonBool :: Parser JsonValue
jsonBool = jsonTrue <|> jsonFalse
  where
    jsonTrue = const (JsonBool True) <$> stringP "true"
    jsonFalse = const (JsonBool False) <$> stringP "false"

jsonNull :: Parser JsonValue
jsonNull = const JsonNull <$> stringP "null"

ws :: Parser String
ws = whileP isSpace

whileP :: (Char -> Bool) -> Parser String
whileP f = Parser $ \string ->
  let (parsed, rest) = span f string
   in Just (rest, parsed)

stringP :: String -> Parser String
stringP = traverse charP

charP :: Char -> Parser Char
charP char = Parser f
  where
    f (c : rest)
      | c == char = Just (rest, c)
      | otherwise = Nothing
    f [] = Nothing