naive parser combinator written by purescript

json-parser.purs

module Parser where

import Prelude (($), (<>), (==), (>=), (<=), (&&), (/=), (||), (>>>), negate)
import Data.Show (class Show, show)
import Data.Tuple (Tuple(..))
import Data.Either (Either(..))
import Data.Array ((:), intercalate)
import Data.Foldable (foldl, foldr)
import Data.Maybe (Maybe(..))
import Data.String (codePointAt)
import Data.String.CodeUnits (splitAt)
import Data.Number (fromString)
import Data.Int (floor)
import Math ((%))

type Source = String
type ErrorMessage = String
type ParserResult a = Tuple (Either a ErrorMessage) Source
type Parser a = (Source -> ParserResult a)

-- constructor helper
value :: forall a . a -> Parser a
value v = \s -> Tuple (Left v) s

error :: forall a . ErrorMessage -> Parser a
error e = \s -> Tuple (Right e) s

-- functor map
map :: forall a b . (a -> b) -> Parser a -> Parser b
map f parser = \s -> case parser s of
  Tuple (Left v) s' -> value (f v) s'
  Tuple (Right e) s' -> error e s'

infixl 5 map as <$>

-- applicative apply
apply :: forall a b . Parser (a -> b) -> Parser a -> Parser b
apply pf pa = \s -> case pf s of
  Tuple (Left f) s'  -> case pa s' of
    Tuple (Left a) s''  -> value (f a) s''
    Tuple (Right e) s'' -> error e s''
  Tuple (Right e) s' -> error e s'

infixl 5 apply as <*>

-- monadic bind
bind :: forall a b . Parser a -> (a -> Parser b) -> Parser b
bind ma f = \s -> case ma s of
  Tuple (Left a) s' -> f a s'
  Tuple (Right e) s' -> error e s'

infixl 5 bind as >>=

either :: forall a . (Parser a) -> (Parser a) -> (Parser a)
either pa pb = \s -> case pa s of
  (Tuple (Left v) s') -> value v s'
  _ -> pb s

infixl 5 either as <|>

concat :: Parser String -> Parser String -> Parser String
concat p1 p2 = (<>) <$> p1 <*> p2

infixl 5 concat as <+>

ignoreFirst :: forall a b . Parser a -> Parser b -> Parser b
ignoreFirst pa pb = (\a b -> b) <$> pa <*> pb

infixl 5 ignoreFirst as *>

ignoreSecond :: forall a b . Parser a -> Parser b -> Parser a
ignoreSecond pa pb = (\a b -> a) <$> pa <*> pb

infixl 5 ignoreSecond as <*

-- consume the first char in source
item :: Parser String
item "" = error "EOF" ""
item s = case splitAt 1 s of
  { before, after } -> value before after

satisfy :: (String -> Boolean) -> Parser String
satisfy p = \s -> case item s of
  (Tuple (Left v) s') -> if p v then value v s' else error ("unexpected char: [" <> v <> "]") s'
  (Tuple (Right e) s') -> error e s'

digit :: Parser String
digit = satisfy (\c -> c >= "0" && c <= "9")

char :: String -> Parser String
char c = satisfy (\a -> a == c)

dot :: Parser String
dot = char "."

comma :: Parser String
comma = char ","

colon :: Parser String
colon = char ":"

not :: String -> Parser String
not c = satisfy (\a -> a /= c)

space :: Parser String
space = satisfy (\c -> (c == " ") || (c == "\r") || (c == "\n") || (c =="\t"))

many :: forall a . Parser a -> Parser (Array a)
many p = (:) <$> p <*> (\s -> many p s) <|> value []

some :: forall a . Parser a -> Parser (Array a)
some p = (:) <$> p <*> many p

string :: String -> Parser String
string "" = \s -> error "Can not mach empty string" ""
string str = case splitAt 1 str of
  { before, after } -> char before <+> (string after <|> value "")

concatString :: Array String -> String
concatString xs = foldl (<>) "" xs

stringListToInt :: Array String -> Parser Number
stringListToInt strList = case concatString >>> fromString $ strList of
  Just i -> value i
  Nothing -> error "Can't not parse string to number"

positive_integer :: Parser Number
positive_integer = some digit >>= stringListToInt

negative_integer :: Parser Number
negative_integer = negate <$> (char "-" *> positive_integer)

integer :: Parser Number
integer = negative_integer <|> positive_integer

stringToNumber :: String -> Parser Number
stringToNumber strList = case fromString strList of
  Just i -> value i
  Nothing -> error "Can't not parse string to number"

digits :: Parser String
digits = concatString <$> some digit

positive_float :: Parser Number
positive_float = (digits <+> dot <+> digits) >>= stringToNumber

negative_float :: Parser Number
negative_float = negate <$> (char "-" *> positive_float)

float :: Parser Number
float = negative_float <|> positive_float

number :: Parser Number
number = float <|> integer

separate :: forall a b . Parser a -> Parser b -> Parser (Array b)
separate s p = (:) <$> p <*> (many $ s *> p)

bracket :: forall a b c . Parser a -> Parser b -> Parser c -> Parser b
bracket o p c = o *> p <* c

arround :: forall a b . Parser a -> Parser b -> Parser b
arround a p = bracket (many a) p (many a)

spaceArround :: forall a . Parser a -> Parser a
spaceArround = arround space

string_literal :: Parser String
string_literal =
  let
    to_string = foldl (<>) ""
    quote = "\""
  in
    to_string <$> (char quote *> many (not quote) <* char quote)

data JSON = 
  JSON_Null | 
  JSON_Boolean Boolean | 
  JSON_Number Number | 
  JSON_String String | 
  JSON_Array (Array JSON) | 
  JSON_Object (Array (Tuple String JSON))

instance showJSON :: Show JSON where
  show JSON_Null = "null"
  show (JSON_Boolean b) = show b
  show (JSON_Number n) = if n % 1.0 == 0.0 then show $ floor n else show n
  show (JSON_String s) = show s
  show (JSON_Array xs) = show xs
  show (JSON_Object ps) = "{" <> showPairs ps <> "}"
    where
      showPair (Tuple k v) = "\"" <> k <> "\"" <> ":" <> show v
      showPairs ps' = intercalate "," $ foldr (\p list -> (showPair p):list) [] ps'

json :: Parser JSON
json source = spaceArround parser source
  where parser = json_null <|> json_boolean <|> json_number <|> json_string <|> json_array <|> json_object

json_null :: Parser JSON
json_null = (\_ -> JSON_Null) <$> string "null"

json_boolean :: Parser JSON
json_boolean = json_true <|> json_false
  where
    json_true  = (\_ -> JSON_Boolean true)  <$> string "true"
    json_false = (\_ -> JSON_Boolean false) <$> string "false"

json_number :: Parser JSON
json_number = (\n -> JSON_Number n) <$> number

json_string :: Parser JSON
json_string = (\str -> JSON_String str) <$> string_literal

json_array :: Parser JSON
json_array source = parse_array source
  where
    items = separate comma json <|> value []
    to_array = \xs -> JSON_Array xs
    parse_array = to_array <$> (char "[" *> spaceArround items <* char "]")

json_object :: Parser JSON
json_object source = to_object <$> (char "{" *> entries <* char "}") $ source
  where
    key' = spaceArround string_literal
    value' = spaceArround json
    colon' = spaceArround colon
    toTuple = \k _ v -> Tuple k v
    pair = toTuple <$> key' <*> colon' <*> value'
    pairs = separate comma pair
    entries = pairs <|> value []
    to_object = \xs -> JSON_Object xs