jsonparser-with-error-reporting.hs

-- start snippet imports
{-# LANGUAGE DeriveGeneric, TupleSections #-}
{-# LANGUAGE LambdaCase, MultiWayIf #-}
module JSONParser where

import Control.Applicative (Alternative(..))
import Control.Monad (replicateM)
import Data.Bits (shiftL)
import Data.Char (isDigit, isHexDigit, isSpace, chr, ord, digitToInt)
import Data.Functor (($>))
import Data.List (intercalate)
import Data.List.Split (split, dropFinalBlank, keepDelimsR, onSublist)
import qualified Data.List.NonEmpty as NEL
import GHC.Generics (Generic)
import Numeric (showHex)
import Prelude hiding (lines)
import Text.Printf (printf)
import Test.QuickCheck hiding (Positive, Negative)
-- end snippet imports

-- start snippet type
data JValue = JNull
            | JBool Bool
            | JString String
            | JNumber { int :: Integer, frac :: [Int], exponent :: Integer }
            | JArray [JValue]
            | JObject [(String, JValue)]
            deriving (Eq, Generic)
-- end snippet type

-- start snippet show-instance
instance Show JValue where
  show value = case value of
    JNull          -> "null"
    JBool True     -> "true"
    JBool False    -> "false"
    JString s      -> showJSONString s
    JNumber s [] 0 -> show s
    JNumber s f 0  -> show s ++ "." ++ concatMap show f
    JNumber s [] e -> show s ++ "e" ++ show e
    JNumber s f e  -> show s ++ "." ++ concatMap show f ++ "e" ++ show e
    JArray a       -> "[" ++ intercalate ", " (map show a) ++ "]"
    JObject o      -> "{" ++ intercalate ", " (map showKV o) ++ "}"
    where
      showKV (k, v) = showJSONString k ++ ": " ++ show v

showJSONString :: String -> String
showJSONString s = "\"" ++ concatMap showJSONChar s ++ "\""

isControl :: Char -> Bool
isControl c = c `elem` ['\0' .. '\31']

showJSONChar :: Char -> String
showJSONChar c = case c of
  '\'' -> "'"
  '\"' -> "\\\""
  '\\' -> "\\\\"
  '/'  -> "\\/"
  '\b' -> "\\b"
  '\f' -> "\\f"
  '\n' -> "\\n"
  '\r' -> "\\r"
  '\t' -> "\\t"
  _ | isControl c -> "\\u" ++ showJSONNonASCIIChar c
  _ -> [c]
  where
    showJSONNonASCIIChar c =
      let a = "0000" ++ showHex (ord c) "" in drop (length a - 4) a
-- end snippet show-instance

-- start snippet scalargens
jNullGen :: Gen JValue
jNullGen = pure JNull

jBoolGen :: Gen JValue
jBoolGen = JBool <$> arbitrary

jNumberGen :: Gen JValue
jNumberGen = JNumber <$> arbitrary <*> listOf (choose (0, 9)) <*> arbitrary
-- end snippet scalargens

-- start snippet stringgen
jsonStringGen :: Gen String
jsonStringGen =
  concat <$> listOf (oneof [ vectorOf 1 arbitraryUnicodeChar
                           , escapedUnicodeChar ])
  where
    escapedUnicodeChar = ("\\u" ++) <$> vectorOf 4 (elements hexDigitLetters)
    hexDigitLetters    = ['0'..'9'] ++ ['a'..'f'] ++ ['A'..'F']

jStringGen :: Gen JValue
jStringGen = JString <$> jsonStringGen
-- end snippet stringgen

-- start snippet compositegens
jArrayGen :: Int -> Gen JValue
jArrayGen = fmap JArray . scale (`div` 2) . listOf . jValueGen . (`div` 2)

jObjectGen :: Int -> Gen JValue
jObjectGen = fmap JObject . scale (`div` 2) . listOf . objKV . (`div` 2)
  where
    objKV n = (,) <$> jsonStringGen <*> jValueGen n
-- end snippet compositegens

-- start snippet valuegen
jValueGen :: Int -> Gen JValue
jValueGen n = if n < 5
  then frequency [(4, oneof scalarGens), (1, oneof (compositeGens n))]
  else frequency [(1, oneof scalarGens), (4, oneof (compositeGens n))]
  where
    scalarGens      = [jNullGen , jBoolGen , jNumberGen , jStringGen]
    compositeGens n = [jArrayGen n, jObjectGen n]
-- end snippet valuegen

-- start snippet value-arbitrary
instance Arbitrary JValue where
  arbitrary = sized jValueGen
  shrink    = genericShrink
-- end snippet value-arbitrary

-- start snippet stringify
jsonWhitespaceGen :: Gen String
jsonWhitespaceGen =
  scale (round . sqrt . fromIntegral)
  . listOf
  . elements
  $ [' ' , '\n' , '\r' , '\t']

stringify :: JValue -> Gen String
stringify = pad . go
  where
    surround l r j = l ++ j ++ r
    pad gen = surround <$> jsonWhitespaceGen <*> jsonWhitespaceGen <*> gen
    commaSeparated = pad . pure . intercalate ","

    go value = case value of
      JArray elements ->
        mapM (pad . stringify) elements
          >>= fmap (surround "[" "]") . commaSeparated
      JObject kvs ->
        mapM stringifyKV kvs >>= fmap (surround "{" "}") . commaSeparated
      _           -> return $ show value

    stringifyKV (k, v) =
      surround <$> pad (pure $ showJSONString k) <*> stringify v <*> pure ":"
-- end snippet stringify

-- start snippet parse-result
data ParseResult a = Error [String] | Result a
-- end snippet parse-result

-- start snippet parse-result-instances
instance Show a => Show (ParseResult a) where
  show (Result res) = show res
  show (Error errs) = formatErrors (reverse errs)
    where
      formatErrors []         = error "No errors to format"
      formatErrors [err]      = err
      formatErrors (err:errs) =
        err <> delim <> intercalate delim (map (concatMap padNewline) errs)

      delim = "\n→ "
      padNewline '\n' = '\n':replicate (length delim - 1) ' '
      padNewline c    = [c]

instance Functor ParseResult where
  fmap _ (Error errs) = Error errs
  fmap f (Result res) = Result (f res)

instance Applicative ParseResult where
  pure = Result
  Error  errs <*> _   = Error errs
  Result f <*> result = fmap f result
-- end snippet parse-result-instances

-- start snippet parser1
newtype Parser1 i o =
  Parser1 { runParser1 :: i -> ParseResult (i, o) }
-- end snippet parser1

-- start snippet parser1-instances
instance Functor (Parser1 i) where
  fmap f parser = Parser1 $ fmap (fmap f) . runParser1 parser

instance Applicative (Parser1 i) where
  pure x    = Parser1 $ pure . (, x)
  pf <*> pa = Parser1 $ \input -> case runParser1 pf input of
    Error err        -> Error err
    Result (rest, f) -> fmap f <$> runParser1 pa rest

instance Alternative (Parser1 i) where
  empty = Parser1 $ const $ Error ["Unknown error."]
  parser1 <|> parser2 = Parser1 $ \input ->
    case runParser1 parser1 input of
      Result res -> Result res
      Error _    -> runParser1 parser2 input

instance Monad (Parser1 i) where
  parser >>= f = Parser1 $ \input -> case runParser1 parser input of
    Error errs            -> Error errs
    Result (rest, output) -> runParser1 (f output) rest
-- end snippet parser1-instances

-- start snippet parser-error1
parseError1 :: String -> ParseResult a
parseError1 err = Error [err]

throw1 :: String -> Parser1 String o
throw1 = Parser1 . const . parseError1
-- end snippet parser-error1

-- start snippet char-string-parsers1
satisfy1 ::
  (Char -> Bool) -> (Char -> String) -> Parser1 String Char
satisfy1 predicate mkError = Parser1 $ \case
  (c:cs) | predicate c -> Result (cs, c)
  (c:_)                -> parseError1 (mkError c)
  _                    -> parseError1 "Empty input"

char1 :: Char -> Parser1 String Char
char1 c = satisfy1 (== c) $ printf "Expected '%v', got '%v'" c

string1 :: String -> Parser1 String String
string1 ""     = pure ""
string1 (c:cs) = (:) <$> char1 c <*> string1 cs
-- end snippet char-string-parsers1

-- start snippet bool-parser1
jBool1 :: Parser1 String JValue
jBool1 =   string1 "true"  $> JBool True
       <|> string1 "false" $> JBool False
-- end snippet bool-parser1

-- start snippet bool-parser2
lookahead1 :: Parser1 String Char
lookahead1 = Parser1 $ \case
  input@(c:_) -> Result (input, c)
  _           -> parseError1 "Empty input"

jBool2 :: Parser1 String JValue
jBool2 = do
  c <- lookahead1
  JBool <$> case c of
    't' -> string1 "true"  $> True
    'f' -> string1 "false" $> False
    _   -> throw1 $
      printf "Expected: 't' for true or 'f' for false; got '%v'" c
-- end snippet bool-parser2

-- start snippet list-zipper
data ListZipper a =
  ListZipper {
    lzLeft  :: [a]
  , lzFocus :: a
  , lzRight :: [a]
  } deriving (Show)

list2zipper :: NEL.NonEmpty a -> ListZipper a
list2zipper list = ListZipper [] (NEL.head list) (NEL.tail list)

lzMoveRight :: ListZipper a -> ListZipper a
lzMoveRight (ListZipper l f [])     = ListZipper l f []
lzMoveRight (ListZipper l f (x:xs)) = ListZipper (f:l) x xs

lzMoveLeft :: ListZipper a -> ListZipper a
lzMoveLeft (ListZipper [] f r)     = ListZipper [] f r
lzMoveLeft (ListZipper (x:xs) f r) = ListZipper xs x (f:r)

zipper2list :: ListZipper a -> NEL.NonEmpty a
zipper2list (ListZipper l f r) = NEL.fromList $ reverse l ++ f:r
-- end snippet list-zipper

-- start snippet text-zipper-1
data TextZipper a =
  TextZipper {
    tzLeft  :: a
  , tzRight :: a
  , tzAbove :: [a]
  , tzBelow :: [a]
  }

instance Show a => Show (TextZipper a) where
  show (TextZipper left right above below) =
    "TextZipper{left=" <> show left
      <> ", right=" <> show right
      <> ", above=" <> show above
      <> ", below=" <> show below
      <> "}"

textZipper :: [String] -> TextZipper String
textZipper []           = TextZipper "" "" [] []
textZipper (first:rest) = TextZipper "" first [] rest

currentPosition :: TextZipper String -> (Int, Int)
currentPosition zipper =
  (length (tzAbove zipper) + 1, length (tzLeft zipper) + 1)

currentChar :: TextZipper String -> Maybe Char
currentChar zipper = case tzRight zipper of
  []    -> Nothing
  (c:_) -> Just c

lines :: String -> [String]
lines = (split . dropFinalBlank . keepDelimsR . onSublist) "\n"
-- end snippet text-zipper-1

-- start snippet move-by-one
moveByOne :: TextZipper String -> TextZipper String
moveByOne zipper
  -- not at end of line
  | not $ null (tzRight zipper) =
      zipper { tzLeft  = head (tzRight zipper) : tzLeft zipper
             , tzRight = tail $ tzRight zipper
             }
  -- at end of line but not at end of input
  | not $ null (tzBelow zipper) =
      zipper { tzAbove = tzLeft zipper : tzAbove zipper
             , tzBelow = tail $ tzBelow zipper
             , tzLeft  = ""
             , tzRight = head $ tzBelow zipper
             }
  -- at end of input
  | otherwise = zipper

move :: TextZipper String -> TextZipper String
move zipper = let zipper' = moveByOne zipper
  in case currentChar zipper' of
       Just _  -> zipper'
       Nothing -> moveByOne zipper'
-- end snippet move-by-one

-- start snippet move-back-by-one
moveBackByOne :: TextZipper String -> TextZipper String
moveBackByOne zipper
  -- not at start of line
  | not $ null (tzLeft zipper) =
      zipper { tzLeft  = tail $ tzLeft zipper
             , tzRight = head (tzLeft zipper) : tzRight zipper
             }
  -- at start of line but not at start of input
  | not $ null (tzAbove zipper) =
      zipper { tzAbove = tail $ tzAbove zipper
             , tzBelow = tzRight zipper : tzBelow zipper
             , tzLeft  = head $ tzAbove zipper
             , tzRight = ""
             }
  -- at start of input
  | otherwise = zipper
-- end snippet move-back-by-one

-- start snippet parser-1
newtype Parser i o = Parser {
    runParser_ :: TextZipper i -> ParseResult (TextZipper i, o)
  }

runParser :: Parser String o -> String -> ParseResult (String, o)
runParser parser input =
  case runParser_ parser (textZipper $ lines input) of
    Error errs             -> Error errs
    Result (restZ, output) -> Result (leftOver restZ, output)
  where
    leftOver tz = concat (tzRight tz : tzBelow tz)
-- end snippet parser-1

-- start snippet parser-2
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 <*> pa = Parser $ \input -> case runParser_ pf input of
    Error err        -> Error err
    Result (rest, f) -> fmap f <$> runParser_ pa rest

instance Monad (Parser i) where
  parser >>= f = Parser $ \input -> case runParser_ parser input of
    Error err        -> Error err
    Result (rest, o) -> runParser_ (f o) rest
-- end snippet parser-2

-- start snippet add-position
addPosition :: String -> TextZipper String -> String
addPosition err zipper =
  let (ln, cn) = currentPosition zipper
      err'     = printf (err <> " at line %d, column %d: ") ln cn
      left     = reverse $ tzLeft zipper
      right    = tzRight zipper
      left'    = showStr $ drop (length left - ctxLen) left
      right'   = showStr $ take ctxLen right
      line     = left' <> right'
  in printf (err' <> "%s\n%s↑")
            line
            (replicate (length err' + length left') ' ')
  where
    ctxLen = 6
    showStr = concatMap showCharForErrorMsg

showCharForErrorMsg :: Char -> String
showCharForErrorMsg c = case c of
  '\b' -> "\\b"
  '\f' -> "\\f"
  '\n' -> "\\n"
  '\r' -> "\\r"
  '\t' -> "\\t"
  ' '  -> "·"
  _ | isControl c -> "\\" <> show (ord c)
  _ -> [c]
-- end snippet add-position

-- start snippet parser-error
parseError :: String -> TextZipper String -> ParseResult a
parseError err zipper = Error [addPosition err zipper]

throw :: String -> Parser String o
throw = Parser . parseError

elseThrow :: Parser String o -> String -> Parser String o
elseThrow parser err = Parser $ \input ->
  case runParser_ parser input of
    Result (rest, a) -> Result (rest, a)
    Error errs       -> Error (addPosition err input : errs)
-- end snippet parser-error

-- start snippet basic-parsers
lookahead :: Parser String Char
lookahead = Parser $ \input -> case currentChar input of
  Just c  -> Result (input, c)
  Nothing -> parseError "Empty input" input

safeLookahead :: Parser String (Maybe Char)
safeLookahead = Parser $ \input -> case currentChar input of
  Just c  -> Result (input, Just c)
  Nothing -> Result (input, Nothing)

satisfy :: (Char -> Bool) -> String -> Parser String Char
satisfy predicate expectation = Parser $ \input -> case currentChar input of
  Just c | predicate c -> Result (move input, c)
  Just c               -> flip parseError input $
    expectation <> ", got '" <> showCharForErrorMsg c <> "'"
  _                    -> flip parseError input $
    expectation <> ", but the input is empty"

char :: Char -> Parser String Char
char c = satisfy (== c) $ printf "Expected '%v'" $ showCharForErrorMsg c

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

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

-- start snippet null-bool-parser
jNull :: Parser String JValue
jNull = string "null" $> JNull

jBool :: Parser String JValue
jBool = do
  c <- lookahead
  JBool <$> case c of
    't' -> string "true"  $> True
    'f' -> string "false" $> False
    _   -> throw $
      errorMsgForChar "Expected: 't' for true or 'f' for false; got '%v'" c

errorMsgForChar :: String -> Char -> String
errorMsgForChar err c = printf err $ showCharForErrorMsg c
-- end snippet null-bool-parser

-- start snippet char-parser
jsonChar :: Parser String (Char, Int)
jsonChar = lookahead >>= \case
  '\\' -> char '\\' *> escapedChar
  _    -> (,1) <$> otherChar
  where
    escapedChar = lookahead >>= \case
      '"'  -> ('"',  2) <$ char '"'
      '\\' -> ('\\', 2) <$ char '\\'
      '/'  -> ( '/', 2) <$ char  '/'
      'b'  -> ('\b', 2) <$ char 'b'
      'f'  -> ('\f', 2) <$ char 'f'
      'n'  -> ('\n', 2) <$ char 'n'
      'r'  -> ('\r', 2) <$ char 'r'
      't'  -> ('\t', 2) <$ char 't'
      'u'  -> (,6) <$> (char 'u' *> unicodeChar)
      c    -> throw $ errorMsgForChar "Invalid escaped character: '%v'" c

    unicodeChar =
      chr . fromIntegral . digitsToNumber 16 0 <$> replicateM 4 hexDigit

    hexDigit = digitToInt <$>
      satisfy isHexDigit "Expected a hex digit"

    otherChar = satisfy (not . isQuoteEscapeOrControl)
      "Did not except '\"', '\\' or control characters"

    isQuoteEscapeOrControl c = c == '\"' || c == '\\' || isControl c

digitsToNumber :: Int -> Integer -> [Int] -> Integer
digitsToNumber base =
  foldl (\num digit -> num * fromIntegral base + fromIntegral digit)
-- end snippet char-parser

-- start snippet string-parser1
jString :: Parser String JValue
jString = JString <$> (char '"' *> jString')
-- end snippet string-parser1

-- start snippet string-parser2
jString' :: Parser String String
jString' = do
  c <- lookahead `elseThrow` "Expected rest of a string"
  if c == '"'
  then "" <$ char '"'
  else jFirstChar
-- end snippet string-parser2

-- start snippet string-parser3
jFirstChar :: Parser String String
jFirstChar = do
  (first, count) <- jsonChar
  if | not (isSurrogate first) -> (first:) <$> jString'
     | isHighSurrogate first   -> jSecondChar first
     | otherwise               -> do
         pushback count
         throw
           . errorMsgForChar "Expected a high surrogate character, got '%v'"
           $ first

pushback :: Int -> Parser String ()
pushback count = Parser $ \input ->
  Result (iterate moveBackByOne input !! count, ())
-- end snippet string-parser3

-- start snippet string-parser4
jSecondChar :: Char -> Parser String String
jSecondChar first = do
  (second, count) <- jsonChar `elseThrow`
    "Expected a second character of a surrogate pair"
  if isLowSurrogate second
  then (combineSurrogates first second :) <$> jString'
  else do
    pushback count
    throw
      . errorMsgForChar "Expected a low surrogate character, got '%v'"
      $ second
-- end snippet string-parser4

-- start snippet string-parser-helper
highSurrogateLowerBound, highSurrogateUpperBound :: Int
highSurrogateLowerBound = 0xD800
highSurrogateUpperBound = 0xDBFF

lowSurrogateLowerBound, lowSurrogateUpperBound :: Int
lowSurrogateLowerBound  = 0xDC00
lowSurrogateUpperBound  = 0xDFFF

isHighSurrogate, isLowSurrogate, isSurrogate :: Char -> Bool
isHighSurrogate a =
  ord a >= highSurrogateLowerBound && ord a <= highSurrogateUpperBound
isLowSurrogate a  =
  ord a >= lowSurrogateLowerBound && ord a <= lowSurrogateUpperBound
isSurrogate a     = isHighSurrogate a || isLowSurrogate a

combineSurrogates :: Char -> Char -> Char
combineSurrogates a b = chr $
  ((ord a - highSurrogateLowerBound) `shiftL` 10)
  + (ord b - lowSurrogateLowerBound) + 0x10000
-- end snippet string-parser-helper

-- start snippet string-parser-test
prop_genParseJString :: Property
prop_genParseJString =
  forAllShrink jStringGen shrink $ \js ->
    case runParser jString (show js) of
      Error _       -> False
      Result (_, o) -> o == js
-- end snippet string-parser-test

-- start snippet int-parser
jUInt :: Parser String Integer
jUInt = (`elseThrow` "Expected an unsigned integer") $
  lookahead >>= \case
    '0'           -> fromIntegral <$> digit
    c | isDigit c -> digitsToNumber 10 0 <$> digits
    c             -> throw $ printf "Expected a digit, got '%v'" c

jInt :: Parser String Integer
jInt = (`elseThrow` "Expected a signed integer") $
  lookahead >>= \case
    '-' -> negate <$> (char '-' *> jUInt)
    _   -> jUInt

digits :: Parser String [Int]
digits = ((:) <$> digit <*> digits') `elseThrow` "Expected digits"
  where
    digits' = safeLookahead >>= \case
      Just c | isDigit c -> (:) <$> digit <*> digits'
      _                  -> return []
-- end snippet int-parser

-- start snippet fracexp-parser
jFrac :: Parser String [Int]
jFrac = (char '.' *> digits) `elseThrow` "Expected a fraction"

jExp :: Char -> Parser String Integer
jExp c = (char c *> jExp') `elseThrow` "Expected an exponent"
  where
    jExp' = lookahead >>= \case
      '-' -> negate <$> (char '-' *> jUInt)
      '+' -> char '+' *> jUInt
      _   -> jUInt
-- end snippet fracexp-parser

-- start snippet number-parser
jNumber :: Parser String JValue
jNumber = do
  i <- jInt
  safeLookahead >>= \case
    Just '.' -> do
      f <- jFrac
      safeLookahead >>= \case
        Just c' | isExpSym c' -> JNumber i f <$> jExp c' -- int+frac+exp
        _                     -> pure $ JNumber i f 0    -- int+frac
    Just c | isExpSym c       -> JNumber i [] <$> jExp c -- int+exp
    _                         -> pure $ JNumber i [] 0   -- int
  where
    isExpSym c = c == 'e' || c == 'E'
-- end snippet number-parser

-- start snippet number-parser-test
prop_genParseJNumber :: Property
prop_genParseJNumber =
  forAllShrink jNumberGen shrink $ \jn ->
    case runParser jNumber (show jn) of
      Error _       -> False
      Result (_, o) -> o == jn
-- end snippet number-parser-test

-- start snippet array-parser-helper
surroundedBy :: Parser i a -> Parser i b -> Parser i a
surroundedBy parser1 parser2 = parser2 *> parser1 <* parser2

separatedBy :: Parser String v -> Char -> String -> Parser String [v]
separatedBy parser sepChar errMsg = do
  res <- parser  `elseThrow` errMsg
  safeLookahead >>= \case
    Just c | c == sepChar ->
      (res:) <$> (char sepChar *> separatedBy parser sepChar errMsg)
    _ -> return [res]

spaces :: Parser String String
spaces = safeLookahead >>= \case
  Just c | isWhitespace c -> (:) <$> char c <*> spaces
  _                       -> return ""
  where
    isWhitespace c = c == ' ' || c == '\n' || c == '\r' || c == '\t'

-- end snippet array-parser-helper

-- start snippet array-parser
jArray :: Parser String JValue
jArray = JArray <$> do
  _ <- char '[' <* spaces
  c <- lookahead `elseThrow` "Expected a JSON value or ']'"
  case c of
    ']' -> [] <$ char ']'
    _   -> separatedBy jValue ',' "Expected a JSON value" <* 
              satisfy (== ']') "Expected ',' or ']'"
-- end snippet array-parser

-- start snippet array-parser-test
prop_genParseJArray :: Property
prop_genParseJArray =
  forAllShrink (sized jArrayGen) shrink $ \ja -> do
    jas <- dropWhile isSpace <$> stringify ja
    return . counterexample (show jas) $ case runParser jArray jas of
      Error _       -> False
      Result (_, o) -> o == ja
-- end snippet array-parser-test

-- start snippet object-parser
jObject :: Parser String JValue
jObject = JObject <$> do
  _ <- char '{' <* spaces
  c <- lookahead `elseThrow` "Expected a JSON value or '}'"
  case c of
    '}' -> [] <$ char '}'
    _   -> separatedBy pair ',' "Expected an object key-value pair" <*
             satisfy (== '}') "Expected ',' or '}'"
  where
    pair = (\ ~(JString s) j -> (s, j)) <$> key <*  char ':' <*> value
    key = (jString `surroundedBy` spaces) `elseThrow` "Expected an object key"
    value = jValue `elseThrow` "Expected an object value"
-- end snippet object-parser

-- start snippet object-parser-test
prop_genParseJObject :: Property
prop_genParseJObject =
  forAllShrink (sized jObjectGen) shrink $ \jo -> do
    jos <- dropWhile isSpace <$> stringify jo
    return . counterexample (show jos) $ case runParser jObject jos of
      Error _       -> False
      Result (_, o) -> o == jo
-- end snippet object-parser-test

-- start snippet value-parser
jValue :: Parser String JValue
jValue = jValue' `surroundedBy` spaces
  where
    jValue' = lookahead >>= \case
      'n'  -> jNull   `elseThrow` "Expected null"
      't'  -> jBool   `elseThrow` "Expected true"
      'f'  -> jBool   `elseThrow` "Expected false"
      '\"' -> jString `elseThrow` "Expected a string"
      '['  -> jArray  `elseThrow` "Expected an array"
      '{'  -> jObject `elseThrow` "Expected an object"
      c | c == '-' || isDigit c ->
        jNumber `elseThrow` "Expected a number"
      c    -> throw $ printf "Unexpected character: '%v'"
                    $ showCharForErrorMsg c
-- end snippet value-parser

-- start snippet parsejson
parseJSON :: String -> Either String JValue
parseJSON s = case runParser jValue s of
  Result ("", j) -> Right j
  Result (i, _)  -> Left $ "Leftover input: " <> i
  err@(Error _)  -> Left $ show err

printResult :: Either String JValue -> IO ()
printResult = putStrLn . either ("ERROR:\n" <>) (("RESULT:\n" <>) . show)
-- end snippet parsejson

-- start snippet parsejson-test
prop_genParseJSON :: Property
prop_genParseJSON = forAllShrink (sized jValueGen) shrink $ \value -> do
  json <- stringify value
  return . counterexample (show json) . (== Right value) . parseJSON $ json
-- end snippet parsejson-test

-- start snippet run-test
runTests :: IO ()
runTests = do
  putStrLn "== prop_genParseJString =="
  quickCheck prop_genParseJString

  putStrLn "== prop_genParseJNumber =="
  quickCheck prop_genParseJNumber

  putStrLn "== prop_genParseJArray =="
  quickCheck prop_genParseJArray

  putStrLn "== prop_genParseJObject =="
  quickCheck prop_genParseJObject

  putStrLn "== prop_genParseJSON =="
  quickCheck prop_genParseJSON
-- end snippet run-test