Working JSON parser with a JSON pretty printer exe

.gitignore

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

LICENSE

@@ -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.

README.md

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

Setup.hs

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

app/Main.hs

@@ -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

package.yaml

@@ -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

src/jsonparser.hs

@@ -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

stack.yaml

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

test/Spec.hs

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