partsec.sml

datatype ('s, 'a) state = STATE of 's -> 's * 'a

type position =
    { line : int
    , pos  : int
    }

fun position_to_str {line, pos} =
    Int.toString line ^ ": " ^ Int.toString pos

type 'a tracked = (position, 'a) state

datatype block
    = BLOCK of substring
    | EOF

datatype ('cont, 'res) coroutine
    = AWAIT of 'cont
    | STOP  of 'res

and 'a parseResult
    = OK       of 'a
    | EXPECTED of string

and 'a parser = PARSER of (block -> 'a parser, 'a parseResult) coroutine tracked

fun mapState (f : 'a -> 'b) (STATE sa : ('s, 'a) state) : ('s, 'b) state =
    STATE (fn s =>
        case sa s of
            (s, a) => (s, f a))

fun returnState (value : 'a) : ('s, 'a) state =
    STATE (fn s => 
        (s, value))

fun mapCoroutine 
    (f : 'cont -> 'cont1)
    (g : 'res  -> 'res1)
    (c : ('cont, 'res) coroutine)
        : ('cont1, 'res1) coroutine =

    case c
     of AWAIT cont => AWAIT (f cont)
      | STOP  res  => STOP  (g res)

val get : ('s, 's) state =
    STATE (fn s => (s, s))

fun modify (f : 's -> 's) : ('s, unit) state =
    STATE (fn s => (f s, ()))

fun return (value : 'a) : 'a parser =
    PARSER (returnState (STOP (OK value)))

fun expected (msg : string) : 'a parser =
    PARSER (returnState (STOP (EXPECTED msg)))

infix matched_as
fun matched_as ((PARSER (STATE ma), amb) : 'a parser * ('a -> 'b parser)) : 'b parser =
    PARSER (STATE (fn position =>
        let 
            val (newPos, action) = ma position
        in
            case action
             of AWAIT xma => 
                (newPos, AWAIT (fn block =>
                    xma block matched_as amb
                ))

              | STOP (OK a) =>
                (case amb a of
                    PARSER (STATE sb) =>
                        sb newPos)

              | STOP (EXPECTED text) =>
                (newPos, STOP (EXPECTED text))

        end
    ))

infix wraped_with
fun wraped_with ((parser, f) : 'a parser * ('a -> 'b)) : 'b parser =
    parser matched_as (return o f)

infix catch
fun catch 
    ( (PARSER (STATE ma) , spmb) 
    : 'a parser          * (string * position -> 'a parser)
    ) 
        : 'a parser =

    PARSER (STATE (fn position =>
        let
            val (newPos, action) = ma position
        in
            case action
             of AWAIT xma =>
                (newPos, AWAIT (fn block =>
                    xma block catch spmb
                ))

              | STOP (OK a) =>
                (newPos, STOP (OK a))

              | STOP (EXPECTED text) =>
                (case spmb (text, newPos)
                  of PARSER (STATE sa) =>
                    sa position)
        end
    ))

infix being
fun being ((msg, parser) : string * 'a parser) : 'a parser =
    parser catch (fn (err, at) =>
        expected (msg ^ " (" ^ err ^ " at " ^ position_to_str at ^ ")")
    )

fun zeroOrMore (parser : 'a parser) : 'a list parser =
    (parser            matched_as (fn a  =>
     zeroOrMore parser matched_as (fn az =>

     return (a :: az))))
    
    catch (fn _ => return [])

fun oneOrMore (parser : 'a parser) : 'a list parser =
    parser            matched_as (fn a  =>
    zeroOrMore parser matched_as (fn az =>

    return (a :: az)))

fun maybe (parser : 'a parser) : 'a option parser =
    parser wraped_with SOME 
    catch (fn _ => return NONE)

val getPosition : position parser =
    PARSER (STATE (fn position =>
        (position, STOP (OK position))
    ))

fun any_of (parsers : 'a parser list) : 'a parser =
    let
        fun collect_errors errors parsers =
            case parsers
             of (parser :: rest) =>
                parser catch (fn error =>
                    collect_errors (error :: errors) rest
                )
              | [] =>
                expected (pack_errors errors)

        and pack_errors errors =
            let
                infix further_than
                fun further_than 
                    ( {line = l1, pos = p1}
                    , {line = l2, pos = p2}
                    ) =
                    l1 > l2 orelse (l1 = l2 andalso p1 > p2)

                fun take_furthest ((e2, at2), list) =
                    case list
                     of (e1, at1) :: rest =>
                        if at1 further_than at2
                        then list
                        else if at2 further_than at1
                            then (e2, at2) :: rest
                            else (e2, at2) :: list

                      | [] =>
                        [(e2, at2)]

                val far = foldl take_furthest [] errors

                fun error_to_str (e, at) = e ^ " at " ^ position_to_str at

                val text = 
                    "any of [" ^ String.concatWith ", " 
                        (map error_to_str far) ^ 
                    "]"
            in
                text
            end
    in
        collect_errors [] parsers
    end

infix or
fun or (l, r) = any_of [l, r]