Working JSON parser with a JSON pretty printer exe

This commit is contained in:
Abhinav Sarkar 2018-02-21 20:04:01 +05:30
commit b9a6240c37
9 changed files with 276 additions and 0 deletions

3
.gitignore vendored Normal file
View File

@ -0,0 +1,3 @@
.stack-work/
json-parser.cabal
*~

30
LICENSE Normal file
View File

@ -0,0 +1,30 @@
Copyright Abhinav Sarkar (c) 2018
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Abhinav Sarkar nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

3
README.md Normal file
View File

@ -0,0 +1,3 @@
# json-parser
Simple JSON parser written from scratch in Haskell. Meant for teaching/illustrative purposes only.

2
Setup.hs Normal file
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

11
app/Main.hs Normal file
View File

@ -0,0 +1,11 @@
module Main where
import JSONParser (parseJSON)
import Text.Pretty.Simple (pPrintNoColor)
main :: IO ()
main = do
s <- getContents
case parseJSON s of
Nothing -> error "JSON parsing failed"
Just j -> pPrintNoColor j

50
package.yaml Normal file
View File

@ -0,0 +1,50 @@
name: json-parser
version: 0.1.0.0
github: "abhin4v/hs-json-parser"
license: BSD3
author: "Abhinav Sarkar"
maintainer: "abhinav@abhinavsarkar.net"
copyright: "2018 Abhinav Sarkar"
extra-source-files:
- README.md
# Metadata used when publishing your package
# synopsis: Short description of your package
# category: Web
# To avoid duplicated efforts in documentation and dealing with the
# complications of embedding Haddock markup inside cabal files, it is
# common to point users to the README.md file.
description: Please see the README on Github at <https://github.com/abhin4v/hs-json-parser#readme>
dependencies:
- base >= 4.7 && < 5
library:
source-dirs: src
dependencies: []
exposed-modules:
- JSONParser
ghc-options:
- -Wall
executables:
ppj:
main: Main.hs
source-dirs: app
ghc-options: []
dependencies:
- json-parser
- pretty-simple
tests:
json-parser-test:
main: Spec.hs
source-dirs: test
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- json-parser

165
src/jsonparser.hs Normal file
View File

@ -0,0 +1,165 @@
module JSONParser where
import Control.Applicative (Alternative(..), optional)
import Control.Monad (replicateM)
import Data.Char (isDigit, isHexDigit, isSpace, isControl, chr, digitToInt)
import Data.Functor (($>))
import Data.List (intercalate)
newtype Parser i o = Parser { runParser :: i -> Maybe (i, o) }
instance Functor (Parser i) where
fmap f p = Parser $ fmap (fmap f) . runParser p
instance Applicative (Parser i) where
pure x = Parser $ pure . (\a -> (a, 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 Nothing
p1 <|> p2 = Parser $ \input -> runParser p1 input <|> runParser p2 input
satisfy :: (a -> Bool) -> Parser [a] a
satisfy p = Parser $ \i -> case i of
(x:xs) | p x -> Just (xs, x)
_ -> Nothing
char :: Char -> Parser String Char
char c = satisfy (== c)
digit :: Parser String Int
digit = digitToInt <$> satisfy isDigit
hexDigit :: Parser String Int
hexDigit = digitToInt <$> satisfy isHexDigit
string :: String -> Parser String String
string "" = pure ""
string (c:cs) = (:) <$> char c <*> string cs
space :: Parser String Char
space = satisfy isSpace
digits :: Parser String [Int]
digits = some digit
spaces :: Parser String String
spaces = many space
surroundedBy :: Parser String a -> Parser String b -> Parser String 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 []
data JValue = JNull
| JBool Bool
| JString String
| JNumber { significand :: Integer, exponent :: Integer}
| JArray [JValue]
| JObject [(String, JValue)]
deriving (Eq)
instance Show JValue where
show value = case value of
JNull -> "null"
JBool True -> "true"
JBool False -> "false"
JString s -> "\"" ++ s ++ "\""
JNumber s e -> if e == 0 then show s else show s ++ "e" ++ show e
JArray a -> "[" ++ intercalate ", " (map show a) ++ "]"
JObject o -> "{" ++ intercalate ", " (map (\(k, v) -> show k ++ ": " ++ show v) o) ++ "}"
jNull :: Parser String JValue
jNull = string "null" $> JNull
jBool :: Parser String JValue
jBool = string "true" $> JBool True
<|> string "false" $> JBool False
digitsToNumber :: Int -> Integer -> [Int] -> Integer
digitsToNumber base = foldl (\num d -> num * fromIntegral base + fromIntegral d)
jString :: Parser String JValue
jString = JString <$> (char '"' *> many jsonChar <* char '"')
where
jsonChar = satisfy (\c -> not (c == '\"' || c == '\\' || isControl c))
<|> string "\\\"" $> '"'
<|> string "\\\\" $> '\\'
<|> string "\\/" $> '/'
<|> string "\\b" $> '\b'
<|> string "\\f" $> '\f'
<|> string "\\n" $> '\n'
<|> string "\\r" $> '\r'
<|> string "\\t" $> '\t'
<|> chr . fromIntegral . digitsToNumber 16 0 <$> (string "\\u" *> replicateM 4 hexDigit)
digit19 :: Parser String Int
digit19 = digitToInt <$> satisfy (\x -> isDigit x && x /= '0')
jUInt :: Parser String Integer
jUInt = (\d ds -> digitsToNumber 10 0 (d:ds)) <$> digit19 <*> digits
<|> fromIntegral <$> digit
data Sign = Positive | Negative
jInt' :: Parser String (Sign, Integer)
jInt' = mkInt <$> optional (char '-') <*> jUInt
where
mkInt (Just '-') i = (Negative, i)
mkInt _ i = (Positive, i)
applySign :: (Sign, Integer) -> Integer
applySign (Negative, i) = negate i
applySign (Positive, i) = i
jFrac :: Parser String [Int]
jFrac = char '.' *> digits
jExp :: Parser String Integer
jExp = (char 'e' <|> char 'E') *> (mkExp <$> optional (char '+' <|> char '-') <*> jUInt)
where
mkExp (Just '-') i = negate i
mkExp _ i = i
jInt :: Parser String JValue
jInt = JNumber <$> (applySign <$> jInt') <*> pure 0
jIntExp :: Parser String JValue
jIntExp = JNumber <$> (applySign <$> jInt') <*> jExp
jIntFrac :: Parser String JValue
jIntFrac =
(\(sign, i) f -> JNumber (applySign (sign, digitsToNumber 10 i f)) (fromIntegral . negate . length $ f))
<$> jInt' <*> jFrac
jIntFracExp :: Parser String JValue
jIntFracExp = (\ ~(JNumber i e) e' -> JNumber i (e + e')) <$> jIntFrac <*> jExp
jNumber :: Parser String JValue
jNumber = jIntFracExp <|> jIntExp <|> jIntFrac <|> jInt
jArray :: Parser String JValue
jArray = JArray <$> (char '[' *> (jValue `separatedBy` char ',' `surroundedBy` spaces) <* char ']')
jObject :: Parser String JValue
jObject = JObject <$> (char '{' *> pair `separatedBy` char ',' <* char '}')
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

10
stack.yaml Normal file
View File

@ -0,0 +1,10 @@
resolver: lts-10.6
packages:
- .
# extra-deps: []
# flags: {}
# extra-package-dbs: []

2
test/Spec.hs Normal file
View File

@ -0,0 +1,2 @@
main :: IO ()
main = putStrLn "Test suite not yet implemented"