Parser.fm

T Parser.State
| Parser.State.make(pos:Nat, str: String, errs: List(Parser.Error));

T Parser.Error
| Parser.Error.new(pos: Nat, unx: Maybe(Parser.Item), exp: List(Parser.Item));
| Parser.Error.msg(pos: Nat, msgs: List(String));

T Parser.Item
| Parser.Item.tokens(xs: String);
| Parser.Item.label(xs: String);
| Parser.Item.eof;

T Parser.Reply<A: Type>
| Parser.Reply.val(state: Parser.State, value: A);
| Parser.Reply.err(state: Parser.State, error: Parser.Error);

Parser.Error.merge(x: Parser.Error, y: Parser.Error): Parser.Error
  case x:
  | case y:
    | case Nat.cmp(x.pos, y.pos):
      | y;
      | def unx = x.unx<>(y.unx,(x) Maybe.some<>(x));
        Parser.Error.new(x.pos, unx, List.concat<>(x.exp,y.exp));
      | x;;
    | y;;
  | case y:
    | x;
    | case Nat.cmp(x.pos, y.pos):
      | y;
      | Parser.Error.msg(x.pos, List.concat<>(x.msgs,y.msgs));
      | x;;;

Parser(A: Type): Type
  Parser.State -> Parser.Reply(A)

Parser.State.new(input: String) : Parser.State
  Parser.State.make(Nat.zero, input, List.nil<_>)

Parser.State.consumed(x: Parser.State, y: Parser.State): Bool
  case x: | case y: | Nat.gtn(y.pos,x.pos);;

Parser.State.merge(x: Parser.State, y: Parser.State): Parser.State
  case x: | case y: |
  case Nat.cmp(x.pos,y.pos):
  | y;
  | Parser.State.make(x.pos, x.str, List.concat<>(x.errs,y.errs));
  | x;;;

Parser.run<A: Type>(p: Parser(A), s: String): Parser.Reply(A)
  p(Parser.State.new(s))

// auto-backtracks when erroring
Parser.token<A: Type>(f: Char -> Maybe(A), es: List(Parser.Item)) : Parser(A)
  (s1) get pos str errs = s1
  case str:
  | def e = Parser.Error.new(pos,Maybe.some<>(Parser.Item.eof),es)
    Parser.Reply.err<>(s1,e);
  | case f(str.head):
    | def unx = Maybe.some<>(Parser.Item.tokens(String.pure(str.head)))
      Parser.Reply.err<>(s1,Parser.Error.new(pos,unx,es));
    | def s2 = Parser.State.make(Nat.succ(pos), str.tail, errs);
      Parser.Reply.val<>(s2,self.value);;

// auto-backtracks when erroring
Parser.tokens(match: String): Parser(String)
  (s1) get pos str errs = s1
  def len_m = String.length(match)
  get took rest = String.split_at(len_m,str)
  def len_t = String.length(took)
  def s2 = Parser.State.make(Nat.add(pos,len_t),rest,errs)
  def lbl = List.pure<>(Parser.Item.tokens(match));
  case Nat.ltn(len_t,len_m):
  | def unx = Maybe.some<>(Parser.Item.eof);
    Parser.Reply.err<>(s1,Parser.Error.new(pos,unx,lbl));
  | case String.eql(match,took):
    | Parser.Reply.val<>(s2,took);
    | def unx = Maybe.some<>(Parser.Item.tokens(took))
      Parser.Reply.err<>(s1,Parser.Error.new(pos,unx,lbl));;

Parser.try<A: Type>(p: Parser(A)): Parser(A)
  (s1)
  case p(s1):
  | Parser.Reply.val<>(self.state, self.value);
  | Parser.Reply.err<>(s1,self.error);

Parser.map<A: Type, B: Type>(f: A -> B, p: Parser(A)): Parser(B)
  (s1) case p(s1):
  | Parser.Reply.val<>(self.state,f(self.value));
  | Parser.Reply.err<>(self.state,self.error);

Parser.pure<A: Type>(a: A): Parser(A)
  (s1) Parser.Reply.val<>(s1,a)

Parser.ap<A: Type, B: Type>(pf: Parser(A -> B), pa: Parser(A)): Parser(B)
  (s1) case pf(s1) as f:
  | case pa(f.state) as a:
    | Parser.Reply.val<>(a.state,f.value(a.value));
    | Parser.Reply.err<>(a.state,a.error);;
  | Parser.Reply.err<>(f.state,f.error);

Parser.bind<A: Type, B: Type>(pa: Parser(A), pf: A -> Parser(B)): Parser(B)
  (s1) case pa(s1) as a:
  | pf(a.value,a.state);
  | Parser.Reply.err<>(a.state,a.error);

Parser.then<A: Type, B: Type>(pa: Parser(A), pb: Parser(B)): Parser(B)
  (s1) case pa(s1) as a:
  | pb(a.state);
  | Parser.Reply.err<>(a.state,a.error);

Parser.plus<A: Type>(px: Parser(A), py: Parser(A)): Parser(A)
  (s1) case px(s1) as x:
  | Parser.Reply.val<>(x.state,x.value);
  | case Parser.State.consumed(s1,x.state):
    | Parser.Reply.err<>(x.state,x.error);
    | case py(x.state) as y:
      | Parser.Reply.val<>(y.state,y.value);
      | Parser.Reply.err<>
        | Parser.State.merge(x.state,y.state);
        | Parser.Error.merge(x.error,y.error);;;;

Parser.take(lbl: String, n: Nat) : Parser(String)
  (s1)
  get pos str errs = s1
  get took rest = String.split_at(n,str)
  def len = String.length(took)
  def s2 = Parser.State.make(Nat.add(pos,len),rest,errs)
  case Nat.eql(len,n):
  | Parser.Reply.val<>(s2,took);
  | def l = List.pure<>(Parser.Item.label(lbl))
    def e = Parser.Error.new(Nat.add(pos,len),Maybe.some<>(Parser.Item.eof),l);
    Parser.Reply.err<>(s2,e);

Parser.take_while(f: Char -> Bool): Parser(String)
  (s1)
  get pos str errs = s1
  get took rest = String.span(f,str)
  def len = String.length(took)
  Parser.Reply.val<>(Parser.State.make(Nat.add(pos,len),rest,errs),took)

Parser.take_while1(lbl: String, f: Char -> Bool): Parser(String)
  (s1)
  get pos str errs = s1
  get took rest = String.span(f,str)
  def len = String.length(took)
  def s2 = Parser.State.make(Nat.add(pos,len),rest,errs)
  def l = List.pure<>(Parser.Item.label(lbl))
  case str:
  | Parser.Reply.err<>(s2,Parser.Error.new(pos,Maybe.some<>(Parser.Item.eof),l));
  | case len:
    | def unx = Maybe.some<>(Parser.Item.tokens(String.pure(str.head)))
      Parser.Reply.err<>(s2,Parser.Error.new(pos,unx,l));
    | Parser.Reply.val<>(s2,took);;

Parser.zero<A: Type>: Parser(A)
  (s1) get pos str errs = s1
  Parser.Reply.err<>(s1,Parser.Error.new(pos,Maybe.none<>, List.nil<>))

Parser.char(c: Char) : Parser(Char)
  Parser.token<>
  | (x) case U16.eql(c,x): | Maybe.some<>(c); | Maybe.none<>;;
  | List.pure<>(Parser.Item.tokens(String.pure(c)));

Parser.choice<A: Type>(ps : List(Parser(A))) : Parser(A)
  case ps:
  | Parser.zero<>;
  | Parser.plus<>(ps.head,Parser.choice<>(ps.tail));

Parser.any_char: Parser(Char)
  Parser.token<>(Maybe.some<>,List.pure<>(Parser.Item.label("any character")))

Parser.eof: Parser(Unit)
  (s1) get pos str errs = s1
  case str:
  | Parser.Reply.val<>(s1,Unit.new);
  | def unx = Maybe.some<>(Parser.Item.tokens(String.pure(str.head)))
    def err = Parser.Error.new(pos,unx,List.pure<>(Parser.Item.eof))
    Parser.Reply.err<>(s1,err);

Parser.fail<A: Type>(msg: String) : Parser(A)
  (s1) get pos str errs = s1
  Parser.Reply.err<>(s1,Parser.Error.msg(pos, List.pure<>(msg)))

Parser.label<A: Type>(lbl: String, p: Parser(A)) : Parser(A)
  (s1) case p(s1) as x:
  | Parser.Reply.val<>(x.state,x.value);
  | def exp = List.pure<>(Parser.Item.label(lbl))
    case x.error as e:
    | Parser.Reply.err<>(x.state,Parser.Error.new(e.pos,e.unx,exp));
    | Parser.Reply.err<>(x.state,Parser.Error.new(e.pos,Maybe.none<>,exp));;

Parser.optional<A: Type>(p: Parser(A)): Parser(Maybe(A))
  Parser.plus<>(Parser.map<,>(Maybe.some<>,p),Parser.pure<>(Maybe.none<>))

Parser.peek<A: Type>(p: Parser(A)): Parser(A)
  (s1) case p(s1):
  | Parser.Reply.val<>(s1,self.value);
  | Parser.Reply.err<>(self.state,self.error);

Parser.type(A: Type, r: Parser.Reply(A)) : Type
  case r: | A; | Parser.Error;

Parser.parse<A: Type>(p: Parser(A), s: String): Parser.type(A, Parser.run<A>(p,s))
  case Parser.run<A>(p,s) as x:
  | x.value;
  | x.error;
  : Parser.type(A,x.self);

Parser.Item.show(e: Parser.Item): String
  case e:
  | String.flatten(["tokens(","\"",e.xs,"\"",")"]);
  | String.flatten(["label(","\"",e.xs,"\"",")"]);
  | "end_of_input";
  : String;

Parser.Error.show(e: Parser.Error): String
  case e:
  | let unx = case e.unx: | "";
      | String.flatten(["unexpected: ", Parser.Item.show(e.unx.value), ", "]);
    let exp = List.show<>(Parser.Item.show, e.exp)
    String.flatten(["Error at ", Nat.show(e.pos),", ", unx, "expected: ", exp]);
  | let msgs = List.show<>((x) x, e.msgs)
    String.flatten(["Error at ", Nat.show(e.pos),", ", msgs]);

Parser.monad : Monad(Parser)
  Monad.new<Parser>(Parser.bind, Parser.pure)

//Parser.testIO : IO(Unit)
//  do IO {
//    IO.print(Parser.test);
//  }


Parser.one_of(xs : List(Char)): Parser(Char)
  Parser.choice<>(List.map<,>(Parser.char,xs))

Parser.many<A: Type>(p: Parser(A)) : Parser(List(A))
  do Parser {
    var x = Parser.optional<>(p);
    case x:
    | Parser.pure<>([]);
    | Parser.map<><>(List.cons<>(x.value),Parser.many<>(p));;
  }
// TODO: use Map?
Parser.decimal.digit : Parser(Nat)
  def char = ((x,y) Parser.then<Char,Nat>(Parser.char(x),Parser.pure<Nat>(y))) 
           :: Char -> Nat -> Parser(Nat)
  def ds = [char('0',0), char('1',1), char('2',2), char('3',3),char('4',4),
            char('5',5), char('6',6), char('7',7), char('8',8),char('9',9)]
  Parser.choice<>(ds)

Parser.decimal : Parser(Nat)
  do Parser {
    var ds  = Parser.many<>(Parser.decimal.digit);
    return Nat.from_base(10,ds);
  }

Parser.test: String
  def p = Parser.decimal
  case Parser.run<>(p,"123456789123456789") as x:
  | Nat.show(x.value);
  | Parser.Error.show(x.error);