Working JSON parser with a JSON pretty printer exe
This commit is contained in:
commit
b9a6240c37
3
.gitignore
vendored
Normal file
3
.gitignore
vendored
Normal file
@ -0,0 +1,3 @@
|
|||||||
|
.stack-work/
|
||||||
|
json-parser.cabal
|
||||||
|
*~
|
30
LICENSE
Normal file
30
LICENSE
Normal 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
3
README.md
Normal file
@ -0,0 +1,3 @@
|
|||||||
|
# json-parser
|
||||||
|
|
||||||
|
Simple JSON parser written from scratch in Haskell. Meant for teaching/illustrative purposes only.
|
11
app/Main.hs
Normal file
11
app/Main.hs
Normal 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
50
package.yaml
Normal 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
165
src/jsonparser.hs
Normal 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
10
stack.yaml
Normal file
@ -0,0 +1,10 @@
|
|||||||
|
resolver: lts-10.6
|
||||||
|
|
||||||
|
packages:
|
||||||
|
- .
|
||||||
|
|
||||||
|
# extra-deps: []
|
||||||
|
|
||||||
|
# flags: {}
|
||||||
|
|
||||||
|
# extra-package-dbs: []
|
2
test/Spec.hs
Normal file
2
test/Spec.hs
Normal file
@ -0,0 +1,2 @@
|
|||||||
|
main :: IO ()
|
||||||
|
main = putStrLn "Test suite not yet implemented"
|
Loading…
Reference in New Issue
Block a user