activitypub-exploration/Json.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ViewPatterns      #-}

module Json where

import Control.Applicative
import Data.Char
import Numeric
import System.Exit

data Input = Input
  { inputLoc :: Int
  , inputStr :: String
  } deriving (Show, Eq)

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

data ParserError = ParserError Int String deriving (Show)

newtype Parser a = Parser
  { runParser :: Input -> Either ParserError (Input, a)
  }

instance Functor Parser where
  fmap f (Parser p) =
    Parser $ \input -> do
      (input', x) <- p input
      return (input', f x)

instance Applicative Parser where
  pure x = Parser $ \input -> Right (input, x)
  (Parser p1) <*> (Parser p2) =
    Parser $ \input -> do
      (input', f) <- p1 input
      (input'', a) <- p2 input'
      return (input'', f a)

instance Alternative (Either ParserError) where
  empty = Left $ ParserError 0 "empty"
  Left _ <|> e2 = e2
  e1 <|> _ = e1

instance Alternative Parser where
  empty = Parser $ const empty
  (Parser p1) <|> (Parser p2) =
    Parser $ \input -> p1 input <|> p2 input

-- | Pull the first character of the input if there is still input
inputChar :: Input -> Maybe (Char, Input)
inputChar (Input _ [])       = Nothing
inputChar (Input loc (x:xs)) = Just (x, Input (loc + 1) xs)

-- | Parser for null json
null :: Parser JsonValue
null = JsonNull <$ parameterized_string "null"

-- | Create a parser for a single specific character
char :: Char -> Parser Char
char x = Parser f
  where
    f input@(inputChar -> Just (y, ys))
      | y == x = Right (ys, x)
      | otherwise =
        Left $
        ParserError
          (inputLoc input)
          ("Expected '" ++ [x] ++ "', but found '" ++ [y] ++ "'")
    f input =
      Left $
      ParserError
        (inputLoc input)
        ("Expected '" ++ [x] ++ "', but reached end of string")

-- | Create a parser for a specific string
parameterized_string :: String -> Parser String
parameterized_string str =
  Parser $ \input ->
    case runParser (traverse char str) input of
      Left _ ->
        Left $
        ParserError
          (inputLoc input)
          ("Expected \"" ++ str ++ "\", but found \"" ++ inputStr input ++ "\"")
      result -> result

-- | Create a parser for boolean values
bool :: Parser JsonValue
bool = true <|> false
  where
    true  = JsonBool True  <$ parameterized_string "true"
    false = JsonBool False <$ parameterized_string "false"

-- | Parser of a character that satisfies a predicate
predicate_char :: String -> (Char -> Bool) -> Parser Char
predicate_char desc f =
  Parser $ \input ->
    case input of
      (inputChar -> Just (y, ys))
        | f y -> Right (ys, y)
        | otherwise ->
          Left $
          ParserError
            (inputLoc input)
            ("Expected " ++ desc ++ ", but found '" ++ [y] ++ "'")
      _ ->
        Left $
        ParserError
          (inputLoc input)
          ("Expected " ++ desc ++ ", but reached end of string")

-- | Parser of strings where all characters satifsfy a predicate
predicate_string :: String -> (Char -> Bool) -> Parser String
predicate_string desc = many . predicate_char desc

{-
See page 12 of
http://www.ecma-international.org/publications/files/ECMA-ST/ECMA-404.pdf
-}
-- | Parser for doubles
double_literal :: Parser Double
double_literal =
  double_from_parts
    <$> (minus <|> pure 1)
    <*> (read <$> digits)
    <*> ((read <$> (('0':) <$> ((:) <$> char '.' <*> digits))) <|> pure 0)
    <*> ((e *> ((*) <$> (plus <|> minus <|> pure 1) <*> (read <$> digits))) <|> pure 0)
  where
    digits = some $ predicate_char "digit" isDigit
    minus = (-1) <$ char '-'
    plus = 1 <$ char '+'
    e = char 'e' <|> char 'E'

-- | Build a Double from its parts (sign, integral part, decimal part, exponent)
double_from_parts :: Integer  -- sign
                  -> Integer  -- integral part
                  -> Double   -- decimal part
                  -> Integer  -- exponent
                  -> Double
double_from_parts sign int dec expo =
  fromIntegral sign * (fromIntegral int + dec) * (10 ^^ expo)

-- | Parser for json number values
number :: Parser JsonValue
number = JsonNumber <$> double_literal

-- | Parser for hex encoded unicode characters in input
escaped_unicode :: Parser Char
escaped_unicode = chr . fst . head . readHex <$> sequenceA (replicate 4 (predicate_char "hex digit" isHexDigit))

-- | Parser for escaped characters
escaped_char :: Parser Char
escaped_char = ('"'  <$ parameterized_string "\\\"") <|>
               ('\\' <$ parameterized_string "\\\\") <|>
               ('/'  <$ parameterized_string "\\/") <|>
               ('\b' <$ parameterized_string "\\b") <|>
               ('\f' <$ parameterized_string "\\f") <|>
               ('\n' <$ parameterized_string "\\n") <|>
               ('\r' <$ parameterized_string "\\r") <|>
               ('\t' <$ parameterized_string "\\t") <|>
               (parameterized_string "\\u" *> escaped_unicode)

-- | Parser of a character that is not " or \\
non_special_char :: Parser Char
non_special_char = predicate_char "non-special character" ((&&) <$> (/= '"') <*> (/= '\\'))

-- | Parser of a string that is between double quotes (not considering any double quots that are scaped)
string_literal :: Parser String
string_literal = char '"' *> many (non_special_char <|> escaped_char) <* char '"'

-- | Parser of literal json string values
string :: Parser JsonValue
string = JsonString <$> string_literal

-- | Parser for white spaces
ws :: Parser String
ws = predicate_string "whitespace character" isSpace

-- | Creates a parser for a string of type "element1 sep1 element2 sep2 element3"
-- from a parser for separators (sep1, sep2) and and a parser form elements (element1, element2, element3).
separated_by :: Parser sep -> Parser el -> Parser [el]
separated_by sep element = (:) <$> element <*> many (sep *> element) <|> pure []

-- | Parser for json arrays
array :: Parser JsonValue
array = JsonArray <$> (char '[' *> ws *> (separated_by (ws *> char ',' <* ws) value) <* ws <* char ']')

-- | Parser for json objects
object :: Parser JsonValue
object =
  JsonObject <$>
  (char '{' *> ws *> separated_by (ws *> char ',' <* ws) pair <* ws <* char '}')
  where
    pair = liftA2 (,) (string_literal <* ws <* char ':' <* ws) value

-- | Parser for any json
value :: Parser JsonValue
value =
  Json.null <|> bool <|> number <|> string <|> array <|>
  object

-- | Apply parser to content of file
parse_file :: FilePath -> Parser a -> IO (Either ParserError a)
parse_file fileName parser = do
  input <- readFile fileName
  case runParser parser $ Input 0 input of
    Left e       -> return $ Left e
    Right (_, x) -> return $ Right x


{-------------}

test :: IO ()
test = do
  putStrLn "[INFO] JSON:"
  putStrLn testJsonText
  case runParser value $ Input 0 testJsonText of
    Right (input, actualJsonAst) -> do
      putStrLn ("[INFO] Parsed as: " ++ show actualJsonAst)
      putStrLn
        ("[INFO] Remaining input (codes): " ++ show (map ord $ inputStr input))
      if actualJsonAst == expectedJsonAst
        then putStrLn "[SUCCESS] Parser produced expected result."
        else do
          putStrLn
            ("[ERROR] Parser produced unexpected result. Expected result was: " ++
             show expectedJsonAst)
          exitFailure
    Left (ParserError loc msg) -> do
      putStrLn $
        "[ERROR] Parser failed at character " ++ show loc ++ ": " ++ msg
      exitFailure
  where
    testJsonText =
      unlines
        [ "{"
        , "    \"hello\": [false, true, null, 42, \"foo\\n\\u1234\\\"\", [1, -2, 3.1415, 4e-6, 5E6, 0.123e+1]],"
        , "    \"world\": null"
        , "}"
        ]
    expectedJsonAst =
      JsonObject
        [ ( "hello"
          , JsonArray
              [ JsonBool False
              , JsonBool True
              , JsonNull
              , JsonNumber 42
              , JsonString "foo\n\4660\""
              , JsonArray
                  [ JsonNumber 1.0
                  , JsonNumber (-2.0)
                  , JsonNumber 3.1415
                  , JsonNumber 4e-6
                  , JsonNumber 5000000
                  , JsonNumber 1.23
                  ]
              ])
        , ("world", JsonNull)
        ]

-- >>> test
-- [INFO] JSON:
-- {
--     "hello": [false, true, null, 42, "foo\n\u1234\"", [1, -2, 3.1415, 4e-6, 5E6, 0.123e+1]],
--     "world": null
-- }
-- <BLANKLINE>
-- [INFO] Parsed as: JsonObject [("hello",JsonArray [JsonBool False,JsonBool True,JsonNull,JsonNumber 42.0,JsonString "foo\n\4660\"",JsonArray [JsonNumber 1.0,JsonNumber (-2.0),JsonNumber 3.1415,JsonNumber 4.0e-6,JsonNumber 5000000.0,JsonNumber 1.23]]),("world",JsonNull)]
-- [INFO] Remaining input (codes): [10]
-- [SUCCESS] Parser produced expected result.
--