KumaChan/stdlib/json/parser_impl.km

type ValueParserType Parser[Value,Error];

function Keyword:
    &(String) => Parser[unit,Error]
    &(keyword) => { consume (keyword, { Error { "expect '?'" keyword } }) };

function Chars:
    & { accept: List[Char] } => Parser[Char,Error]
    & { accept } =>
        let err := { Error 'unexpected character or EOF' },
        { choose (accept map &(char) =>
            ({ consume ([char].{String}, err) } map &(_) => char)) };

const Blank: Parser[unit,Error] :=
    { Chars { accept: { List (' '..\t..\r..\n) } } }
        . { map &(_) => () };

function WrappedList:[T]
    & { item:   Parser[T,Error],
        sep:    Parser[unit,Error],
        prefix: Parser[unit,Error],
        suffix: Parser[unit,Error] }
          =>    Parser[List[T],Error]
    & { item, sep, prefix, suffix } =>
        let item := (item with-ignored Blank),
        let sep := (sep with-ignored Blank),
        \ apply prefix,
        \ list := apply { repeat { item, sep } },
        \ apply suffix,
        { output list };

function ValueParser: &() => ValueParserType
    &() =>
    { choose [
        { throw { Error 'parser stuck' } },
        { make-lazy ObjectParser }, { make-lazy ArrayParser },
        StringParser, NumberParser, BoolParser, NullParser
    ] };

function ObjectParser: &() => ValueParserType
    &() =>
    let entry :=
        \ key := apply StringParser*,
        \ apply ({ Keyword ':' } with-ignored Blank),
        \ value := apply { ValueParser () },
        { output (key,value) },
    let entries := { WrappedList {
        item:   entry,
        sep:    { Keyword ',' },
        prefix: { Keyword '{' },
        suffix: { Keyword '}' }
    } },
    (entries map &(entries) => { Object { Map entries } });

function ArrayParser: &() => ValueParserType
    &() =>
    let items := { WrappedList {
        item:   { ValueParser () },
        sep:    { Keyword ',' },
        prefix: { Keyword '[' },
        suffix: { Keyword ']' }
    } },
    (items map &(items) => { Array items });

const NullParser: ValueParserType :=
    { Keyword 'null' }
        . { map &() => Null };

const TrueParser: ValueParserType :=
    { Keyword 'true' }
        . { map &() => { Bool Yes } };

const FalseParser: ValueParserType :=
    { Keyword 'false' }
        . { map &() => { Bool No } };

const BoolParser: ValueParserType :=
    { choose [TrueParser, FalseParser] };

const NumberParser: ValueParserType :=
    \ chars := apply { repeat { Chars { accept: { List '0123456789.Ee+-' } } } },
    switch { parse-float chars.{String} }:
    case Some x:
        { output { Number x } },
    case None:
        { throw { Error 'invalid number' } },
    end;

const StringParser: ValueParserType :=
    (StringParser* map &(string) => { |Value| string });

const StringParser*: Parser[self::String,Error] :=
    let err := { Error 'invalid string' },
    \ apply { consume ('"', err) },
    &(input) =>
        let proceed:
            &(Seq[Char], String) => Maybe[(Seq[Char],String)] :=
            &(chars, input) rec(proceed) =>
                \ (this, input) := get { shift input },
                \ (prev, _) := get { shift chars },
                let chars := (this cons chars),
                if ((this = `"`) and (prev != `\`)):
                    { Some (chars, input) },
                else:
                    { proceed (chars, input) },
        switch { proceed ((`"` cons Nil), input) }:
        case Some (chars, input):
            let raw := chars.{List}.{reverse}.{String},
            switch { unquote raw }:
            case Some content:
                let value := { |self::String| content },
                { Success (value, input) },
            case None:
                { Failure (err, input) },
            end,
        case None:
            { Failure (err, input) },
        end;