playing with parser combinators

Json.purs

module Data.Json (Json(..), JsonValue(..)) where

import Prelude

import Data.String (joinWith)
import Data.Tuple (Tuple(..))

data JsonValue
  = JsonString String
  | JsonNumber Number
  | JsonBool Boolean
  | JsonArray (Array JsonValue)
  | JsonObject (Array (Tuple String JsonValue))
  | JsonNull

instance showJsonValue :: Show JsonValue where
  show JsonNull = "null"
  show (JsonBool bool) = show bool
  show (JsonString s) = "\"" <> s <> "\""
  show (JsonNumber num) = show num
  show (JsonArray []) = "[]"
  show (JsonArray vals) = "[ " <> joinWith ", " (map show vals) <> " ]"
  show (JsonObject []) = "{}"
  show (JsonObject vals) =
    "{"
      <> joinWith ", "
        ( map
            ( \(Tuple key val) ->
                "\"" <> key <> "\"" <> ": " <> show val
            )
            vals
        )
      <> " }"

data Json
  = TopLevelObject (Array (Tuple String JsonValue))
  | TopLevelArray (Array JsonValue)

instance showJson :: Show Json where
  show (TopLevelObject vals) = show (JsonObject vals)
  show (TopLevelArray vals) = show (JsonArray vals)

Main.purs

module Main (main) where

import Prelude

import Data.Traversable (sequence)
import Effect (Effect, foreachE)
import Effect.Console (log)
import Parser (jsonParser)
import Parsing (runParser)

tests :: Array String
tests =
  [ "{}"
  , "{ }"
  , "{\t}"
  , "{\n}"
  , "{\"foo\":\"bar\"}"
  , "{\"foo\" :\"bar\"}"
  , "{\"foo\" : \"bar\"}"
  , "{\"foo\": 3.345}"
  , "{\"foo\": 32934}"
  , "{\"foo\": +3203}"
  , "{\"foo\" : -3}"
  , "{\"foo\": null}"
  , "{\"foo\": null }"
  , "{\"foo\": []}"
  , "{\"foo\": [ ]}"
  , "{\"foo\": [null, null] }"
  , "{\"foo\": [{}, {}] }"
  , "{\"foo\": [0, 0] }"
  , "{\"foo\": [0, 0, \"\", null] }"
  , "{\"foo\": [4.5, \"null\", \"sl\"] }"
  , "{\"foo\": [ \"ping\", \"sldkf\"] }"
  , "{\"foo\": [ null, null, true, false] }"
  , "{\"foo\": [ null, null] }"
  , "{\"foo\": [ null , 3 ] }"
  , "{\"foo\": [ null, null] }"
  , "{\"foo\": [ null, null ] }"
  , "{\"foo\": [\"s\\\"\"] }"
  , "{\"foo\": [\"s's\"] }"
  , "{\"foo\": [\"a\\\"a\"] }"
  , "{\"foo\": [\"a\n?a\"] }"
  , "{ \"id\": \"0001\",\n"
      <> "\"type\": \"donut\",\n"
      <> "\"name\": \"Cake\",\n"
      <> "\"ppu\": 0.55,\n"
      <> "\"batters\":\n"
      <> "{\n"
      <> "\"batter\": \n"
      <> "[\n"
      <> "{ \"id\": \"1001\", \"type\": \"Regular\" },\n"
      <> "{ \"id\": \"1002\", \"type\": \"Chocolate\" },\n"
      <> "{ \"id\": \"1003\", \"type\": \"Blueberry\" },\n"
      <> "{ \"id\": \"1004\", \"type\": \"Devil's Food\" }\n"
      <> "]\n"
      <> "},\n"
      <> "\"topping\":\n"
      <> "[\n"
      <> "{ \"id\": \"5001\", \"type\": \"None\" },\n"
      <> "{ \"id\": \"5002\", \"type\": \"Glazed\" },\n"
      <> "{ \"id\": \"5005\", \"type\": \"Sugar\" },\n"
      <> "{ \"id\": \"5007\", \"type\": \"Powdered Sugar\" },\n"
      <> "{ \"id\": \"5006\", \"type\": \"Chocolate with Sprinkles\" },\n"
      <> "{ \"id\": \"5003\", \"type\": \"Chocolate\" },\n"
      <> "{ \"id\": \"5004\", \"type\": \"Maple\" }\n"
      <> "]\n"
      <> "}"
  ]

main :: Effect Unit
main = do
  log "Running"
  foreachE tests \a -> do
    log $ a <> "\n" <> (show $ runParser a jsonParser) <> "\n"
  log $ show $ sequence $ map (\a -> runParser a jsonParser) tests

Parser.purs

module Parser where

import Prelude

import Control.Alternative ((<|>))
import Control.Lazy (defer)
import Data.Array ((:))
import Data.CodePoint.Unicode (isAlphaNum)
import Data.Json (Json(..), JsonValue(..))
import Data.Maybe (fromMaybe)
import Data.String (joinWith)
import Data.String.CodeUnits (toCharArray)
import Data.String.CodeUnits as CodeUnits
import Data.Tuple (Tuple(..))
import Parsing (Parser)
import Parsing.Combinators (choice, optionMaybe)
import Parsing.Combinators.Array (many)
import Parsing.String (anyChar, char, string)
import Parsing.String.Basic (alphaNum, number, oneOf, skipSpaces, takeWhile1)
import Parsing.Token (space)

jsonParser :: Parser String Json
jsonParser = do
  valToJson <$> (jsonObjectParser <|> jsonArrayParser)
  where
    valToJson (JsonObject ob) = TopLevelObject ob
    valToJson (JsonArray arr) = TopLevelArray arr
    -- TODO(nathan): Ideally this case should never be reached as errors should 
    -- already have been thrown earlier. Fix it later on
    valToJson _ = TopLevelObject mempty -- this should be okay 
  
  
  

jsonValueParser :: Parser String JsonValue
jsonValueParser =
  jsonNullParser
    <|> jsonBoolParser
    <|> jsonStringParser
    <|> jsonNumberParser
    <|> (defer \_ -> jsonArrayParser)
    <|> (defer \_ -> jsonObjectParser)

jsonNullParser :: Parser String JsonValue
jsonNullParser = do
  _ <- string "null"
  pure JsonNull

jsonBoolParser :: Parser String JsonValue
jsonBoolParser =
  (map (\_ -> JsonBool true) $ string "true") <|> (map (\_ -> JsonBool false) $ string "false")

jsonNumberParser :: Parser String JsonValue
jsonNumberParser = do
  n <- number
  pure $ JsonNumber n

jsonStringParser :: Parser String JsonValue
jsonStringParser = do
  _ <- char '\"'
  s <- many
    ( choice
        [ alphaNum
        , ((char '\\') *> anyChar)
        , oneOf $ toCharArray "~`!@#$%^&*()_+-={}[];':|/?.>,<"
        , space
        ]
    )
  _ <- char '\"'
  pure $ JsonString (joinWith "" $ map CodeUnits.singleton s)

jsonObjKeyParser :: Parser String String
jsonObjKeyParser = do
  _ <- char '\"'
  keyName <- takeWhile1 isAlphaNum
  _ <- char '\"'
  pure keyName

jsonArrayParser :: Parser String JsonValue
jsonArrayParser = do
  _ <- char '['
  skipSpaces
  singleItem <- optionMaybe jsonValueParser
  skipSpaces
  others <- many do
    _ <- char ','
    skipSpaces
    v <- jsonValueParser
    skipSpaces
    pure v
  skipSpaces
  _ <- char ']'
  pure $ JsonArray ((fromMaybe others (map (\i -> i : others) singleItem)))

jsonObjectParser :: Parser String JsonValue
jsonObjectParser = do
  _ <- char '{'
  skipSpaces
  first <- optionMaybe kvPair
  skipSpaces
  others <- many do
    _ <- char ','
    skipSpaces
    kvPair
  skipSpaces
  _ <- char '}'
  pure $ JsonObject $ fromMaybe others $ map (\i -> i : others) first
  where
  kvPair :: Parser String (Tuple String JsonValue)
  kvPair = do
    k <- jsonObjKeyParser
    skipSpaces
    _ <- char ':'
    skipSpaces
    v <- jsonValueParser
    pure (Tuple k v)

spago.dhall

{-
Welcome to a Spago project!
You can edit this file as you like.

Need help? See the following resources:
- Spago documentation: https://github.com/purescript/spago
- Dhall language tour: https://docs.dhall-lang.org/tutorials/Language-Tour.html

When creating a new Spago project, you can use
`spago init --no-comments` or `spago init -C`
to generate this file without the comments in this block.
-}
{ name = "my-project"
, dependencies =
  [ "console"
  , "effect"
  , "integers"
  , "lists"
  , "parsing"
  , "prelude"
  , "strings"
  , "tuples"
  ]
, packages = ./packages.dhall
, sources = [ "src/**/*.purs", "test/**/*.purs" ]
}