//! A simple parser combinator library.

let prelude = import! std.prelude
let { Functor, Applicative, Alternative, Monad } = prelude
let { id, flip } = import! std.function
let { Bool } = import! std.bool
let char @ { ? } = import! std.char
let int = import! std.int
let { Result } = import! std.result
let string = import! std.string
let { (<>) } = import! std.prelude
let list @ { List } = import! std.list
let { Option } = import! std.option

type OffsetString = { start : Int, end : Int, buffer : String }
type Position = Int
type Error = { position : Position, message : String }
type ParseResult a = Result Error { value : a, buffer : OffsetString }

/// `Parser` is a monad which parses a `String` into structured values
type Parser a =
    OffsetString
        -> ParseResult a

let parser : Parser a -> Parser a = id

let functor : Functor Parser = {
    map = \f m ->
        parser
            (\buffer ->
                let result = parser m buffer
                match result with
                | Ok a -> Ok { value = f a.value, buffer = a.buffer }
                | Err err -> Err err),
}

let { map } = functor

let applicative : Applicative Parser = {
    functor,

    apply = \f m ->
        parser
            (\buffer ->
                let result1 = parser f buffer
                match result1 with
                | Ok g ->
                    let result2 = parser m g.buffer
                    match result2 with
                    | Ok a -> Ok { value = g.value a.value, buffer = a.buffer }
                    | Err err -> Err err
                | Err err -> Err err),

    wrap = \value -> parser (\buffer -> Ok { value, buffer }),
}

let { (*>), (<*), wrap } = import! std.applicative

let alternative : Alternative Parser = {
    applicative,

    empty = parser (\stream -> Err { position = stream.start, message = "empty" }),

    or = \l r ->
        parser
            (\stream ->
                match parser l stream with
                | Ok a -> Ok a
                | Err _ -> parser r stream),
}

let { (<|>) } = import! std.alternative

let monad : Monad Parser = {
    applicative,

    flat_map = \f m ->
        parser
            (\buffer ->
                match parser m buffer with
                | Ok a -> parser (f a.value) a.buffer
                | Err err -> Err err),
}

let { flat_map } = import! std.monad

let uncons stream : OffsetString -> Option { char : Char, rest : OffsetString } =
    if stream.start == stream.end then None
    else
        let c = string.char_at stream.buffer stream.start
        let char_len = char.len_utf8 c
        Some
            {
                char = c,
                rest = {
                    start = stream.start + char_len,
                    end = stream.end,
                    buffer = stream.buffer,
                },
            }

let update_position c position : Char -> Position -> Position = position + char.len_utf8 c

/// Returns `message` as what was expected by `p`
#[infix(left, 0)]
let (<?>) p message : Parser a -> String -> Parser a =
    parser
        (\stream ->
            match p stream with
            | Ok x -> Ok x
            | Err _ -> Err { position = stream.start, message })

/// Parses any character. Only errors if the stream is out of input
let any : Parser Char =
    parser
        (\stream ->
            match uncons stream with
            | Some record ->
                let { char, rest } = record
                Ok { value = char, buffer = rest }
            | None -> Err { position = stream.start, message = "End of stream" })

/// Fails the parser with `message` as the cause
let fail message : String -> Parser a = parser (\stream -> Err { position = stream.start, message })

/// Succeeds if `predicate` returns `Some`, fails if `None` is returned
let satisfy_map predicate : (Char -> Option a) -> Parser a =
    let f c =
        match predicate c with
        | Some x -> wrap x
        | None -> fail ("Unexpected character " <> char.show.show c)
    flat_map f any

/// Succeeds if `predicate` returns True, fails if `False` is returned
let satisfy predicate : (Char -> Bool) -> Parser Char =
    satisfy_map (\c -> if predicate c then Some c else None)

/// Succeeds if the next token is `expected`
let token expected : Char -> Parser Char = satisfy (\c -> expected == c)

/// Succeds if the next token is a letter
let letter : Parser Char = satisfy char.is_alphabetic <?> "letter"

/// Succeds if the next token is a digit
let digit : Parser Char = satisfy (flip char.is_digit 10) <?> "digit"

/// Succeds if the next token is alphanumeric
let alpha_num : Parser Char = satisfy char.is_alphanumeric <?> "letter or digit"

/// Succeds if the next token is a space
let space : Parser Char = token ' '

/// Succeds if the next token is a tab
let tab : Parser Char = token '\t'

/// Parses one or more tokens passing `predicate` and returns the `String` between the start and
/// end of those tokens
let take1 predicate : (Char -> Bool) -> Parser String =
    parser
        (\stream ->
            let take_ stream2 =
                match uncons stream2 with
                | Some record ->
                    if predicate record.char then take_ record.rest
                    else if stream.start == stream2.start then
                        Err { position = stream.start, message = "Unexpected token" }
                    else
                        Ok
                            {
                                value = string.slice stream.buffer stream.start stream2.start,
                                buffer = stream2,
                            }
                | None ->
                    Ok
                        {
                            value = string.slice stream.buffer stream.start stream.end,
                            buffer = stream2,
                        }
            take_ stream)

/// Parses zero or more tokens passing `predicate` and returns the `String` between the start and
/// end of those tokens
let take predicate : (Char -> Bool) -> Parser String = take1 predicate <|> wrap ""

/// Parses using `p` and returns the `String` between the start and of what `p` parsed
let recognize p : Parser a -> Parser String =
    parser
        (\stream ->
            match parser p stream with
            | Ok a ->
                Ok
                    {
                        value = string.slice stream.buffer stream.start a.buffer.start,
                        buffer = a.buffer,
                    }
            | Err err -> Err err)

/// Skips over whitespace characters
let spaces = take char.is_whitespace

/// Creates a parser from a factory function. Useful to prevent mutually recursive parser from looping forever
let lazy_parser f : (() -> Parser a) -> Parser a = parser (\stream -> f () stream)

/// Parses `x` between `l` and `r`, returning the result of `x`
let between l r x : Parser a -> Parser b -> Parser c -> Parser c = l *> x <* r

rec
/// Parses with `p` zero or more times
let many p : Parser a -> Parser (List a) = many1 p <|> wrap Nil

/// Parses with `p` one or more times
let many1 p : Parser a -> Parser (List a) =
    do h = p
    map (\t -> Cons h t) (many p)
in
rec
/// Parses with `p` zero or more times, ignoring the result of the parser
let skip_many p : Parser a -> Parser () = skip_many1 p <|> wrap ()
/// Parses with `p` one or more times, ignoring the result of the parser
let skip_many1 p : Parser a -> Parser () =
    p
    skip_many p
in
/// Parses one of the characters of `s`
let one_of s : String -> Parser Char =
    satisfy
        (\first ->
            let len = string.len s
            let one_of_ i =
                if i == len then False
                else
                    let c = string.char_at s i
                    if first == c then True
                    else one_of_ (i + char.len_utf8 c)
            one_of_ 0)
        <|> fail ("Expected one of `" <> s <> "`")


/// Parses at least one element of `parser` separated by `sep`
let sep_by1 parser sep : Parser a -> Parser b -> Parser (List a) =
    do x = parser
    do xs = many (sep *> parser)
    wrap (Cons x xs)

/// Parses `parser` separated by `sep`
let sep_by parser sep : Parser a -> Parser b -> Parser (List a) = sep_by1 parser sep <|> wrap Nil

/// Like `sep_by1` but applies the function returned by `op` on the left fold of successive parses
let chainl1 p op : Parser a -> Parser (a -> a -> a) -> Parser a =
    do l = p
    let rest x =
        (
            do f = op
            do r = p
            rest (f x r))
            <|> wrap x
    rest l

/// Like `sep_by` but applies the function returned by `op` on the left fold of successive parses
let chainl p op v : Parser a -> Parser (a -> a -> a) -> a -> Parser a = chainl1 p op <|> wrap v


/// Parses `input` using `p`
let parse p input : Parser a -> String -> Result String a =
    match p { start = 0, end = string.len input, buffer = input } with
    | Ok ok -> Ok ok.value
    | Err err -> Err (int.show.show err.position <> ":" <> err.message)

{
    Position,
    Error,
    ParseResult,
    Parser,
    OffsetString,

    functor,
    applicative,
    alternative,
    monad,

    parser,

    any,
    between,
    token,
    many,
    many1,
    satisfy,
    satisfy_map,
    spaces,
    take1,
    take,
    lazy_parser,
    fail,
    recognize,
    skip_many,
    skip_many1,
    one_of,
    sep_by,
    sep_by1,
    chainl1,
    chainl,
    (<?>),

    alpha_num,
    letter,
    digit,
    space,
    tab,

    parse,
}