A JSON parser in Haskell

module JSONParser where

import Control.Applicative (Alternative (..), optional)
import Control.Monad (replicateM)
import Data.Bits (shiftL)
import Data.Char (chr, digitToInt, isDigit, isHexDigit, ord)
import Data.Functor (($>))
import System.Exit (exitFailure)

data JValue
  =

    JNull

  | JBool Bool

  | JString String

  | JNumber {int :: Integer, frac :: [Int], exponent :: Integer}

  | JArray [JValue]

  | JObject [(String, JValue)]
  deriving (Eq)

newtype Parser i o = Parser {runParser :: i -> Maybe (i, o)}

instance Functor (Parser i) where
  fmap f parser = Parser $ fmap (fmap f) . runParser parser

instance Applicative (Parser i) where
  pure x = Parser $ pure . (,x)
  pf <*> po = Parser $ \input -> case runParser pf input of
    Nothing -> Nothing
    Just (rest, f) -> fmap f <$> runParser po rest

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

instance Monad (Parser i) where
  p >>= f = Parser $ \input -> case runParser p input of
    Nothing -> Nothing
    Just (rest, o) -> runParser (f o) rest

satisfy :: (a -> Bool) -> Parser [a] a
satisfy predicate = Parser $ \input -> case input of
  (x : xs) | predicate x -> Just (xs, x)
  _ -> Nothing

char :: Char -> Parser String Char
char c = satisfy (== c)

digit :: Parser String Int
digit = digitToInt <$> satisfy isDigit

string :: String -> Parser String String
string "" = pure ""
string (c : cs) = (:) <$> char c <*> string cs

jNull :: Parser String JValue
jNull = string "null" $> JNull

jBool :: Parser String JValue
jBool =
  string "true" $> JBool True
  <|> string "false" $> JBool False

jsonChar :: Parser String Char
jsonChar =
  string "\\\"" $> '"'
  <|> string "\\\\" $> '\\'
  <|> string "\\/" $> '/'
  <|> string "\\b" $> '\b'
  <|> string "\\f" $> '\f'
  <|> string "\\n" $> '\n'
  <|> string "\\r" $> '\r'
  <|> string "\\t" $> '\t'
  <|> unicodeChar
  <|> satisfy (\c -> not (c == '\"' || c == '\\' || isControl c))
  where
    unicodeChar =
      chr . fromIntegral . digitsToNumber 16 0
        <$> (string "\\u" *> replicateM 4 hexDigit)

    hexDigit = digitToInt <$> satisfy isHexDigit

    isControl c = c `elem` ['\0' .. '\31']

digitsToNumber :: Int -> Integer -> [Int] -> Integer
digitsToNumber base =
  foldl (\num d -> num * fromIntegral base + fromIntegral d)

jString :: Parser String JValue
jString = JString <$> (char '"' *> jString')
  where
    jString' = do
      optFirst <- optional jsonChar
      case optFirst of
        Nothing -> char '"' $> ""
        Just first | not (isSurrogate first) -> (first :) <$> jString'
        Just first -> do
          second <- jsonChar
          if isHighSurrogate first && isLowSurrogate second
            then (combineSurrogates first second :) <$> jString'
            else empty

    isHighSurrogate a =
      ord a >= highSurrogateLowerBound && ord a <= highSurrogateUpperBound
    isLowSurrogate a =
      ord a >= lowSurrogateLowerBound && ord a <= lowSurrogateUpperBound
    isSurrogate a = isHighSurrogate a || isLowSurrogate a

    combineSurrogates a b =
      chr $
        ((ord a - highSurrogateLowerBound) `shiftL` 10)
          + (ord b - lowSurrogateLowerBound)
          + 0x10000

    highSurrogateLowerBound = 0xD800
    highSurrogateUpperBound = 0xDBFF
    lowSurrogateLowerBound = 0xDC00
    lowSurrogateUpperBound = 0xDFFF

jNumber :: Parser String JValue
jNumber = jIntFracExp <|> jIntExp <|> jIntFrac <|> jInt
  where
    jInt = JNumber <$> jInt' <*> pure [] <*> pure 0
    jIntExp = JNumber <$> jInt' <*> pure [] <*> jExp
    jIntFrac = (\i f -> JNumber i f 0) <$> jInt' <*> jFrac
    jIntFracExp = (\ ~(JNumber i f _) e -> JNumber i f e) <$> jIntFrac <*> jExp

    jInt' = signInt <$> optional (char '-') <*> jUInt
    jUInt =
      (\d ds -> digitsToNumber 10 0 (d : ds)) <$> digit19 <*> digits
      <|> fromIntegral <$> digit

    jFrac = char '.' *> digits
    jExp =
      (char 'e' <|> char 'E')
        *> (signInt <$> optional (char '+' <|> char '-') <*> jUInt)

    digit19 = digitToInt <$> satisfy (\x -> isDigit x && x /= '0')
    digits = some digit

    signInt (Just '-') i = negate i
    signInt _ i = i

surroundedBy :: Parser i a -> Parser i b -> Parser i a
surroundedBy p1 p2 = p2 *> p1 <* p2

separatedBy :: Parser i v -> Parser i s -> Parser i [v]
separatedBy v s =
  (:) <$> v <*> many (s *> v)
  <|> pure []

between :: Parser i a -> Parser i a -> Parser i b -> Parser i b
between pl pr p = pl *> p <* pr

spaces :: Parser String String
spaces = many (char ' ' <|> char '\n' <|> char '\r' <|> char '\t')

jArray :: Parser String JValue
jArray = fmap JArray
  $ between (char '[') (char ']')
  $ jValue `separatedBy` char ',' `surroundedBy` spaces

jObject :: Parser String JValue
jObject = fmap JObject
  $ between (char '{') ( char '}')
  $ pair `separatedBy` char ',' `surroundedBy` spaces
  where
    pair =
      (\ ~(JString s) j -> (s, j))
        <$> (jString `surroundedBy` spaces)
        <* char ':'
        <*> jValue

jValue :: Parser String JValue
jValue = jValue' `surroundedBy` spaces
  where
    jValue' =
      jNull
        <|> jBool
        <|> jString
        <|> jNumber
        <|> jArray
        <|> jObject

parseJSON :: String -> Maybe JValue
parseJSON s = case runParser jValue s of
  Just ("", j) -> Just j
  _ -> Nothing

main :: IO ()
main =
  getContents >>= \input -> case parseJSON input of
    Just _ -> putStrLn "Parse okay"
    Nothing -> putStrLn "Parse failed" >> exitFailure