Skip to content

Instantly share code, notes, and snippets.

@mthadley
Created August 10, 2020 05:06
Show Gist options
  • Save mthadley/79b104a521be48e79dbf8c7ceac169ae to your computer and use it in GitHub Desktop.
Save mthadley/79b104a521be48e79dbf8c7ceac169ae to your computer and use it in GitHub Desktop.
#!/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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment