open Fun
open Fmlib_parse

module Token = struct
  type tt =
    | Ident of string
    | LParen
    | RParen
    | Comma
    | Wedge
    | Vee
    | RArrow
    | LRArrow
    | Dot
    | Forall
    | Exists
    | EOF

  type t = tt
end

module Token_plus = struct
  type t = Position.range * Token.t
end

module C = struct
  include Fmlib_parse.Character.Make (Unit) (Token_plus) (Fmlib_std.Void)

  let ( <$> ) = map
  let ( *> ) t p = const t <$> p

  let whitespace =
    one_of_chars " \n\t" "unreachable" |> skip_zero_or_more |> no_expectations

  let punctuation =
    List.map
      (fun (t, s) -> t *> string s)
      Token.
        [
          (LParen, "(");
          (RParen, ")");
          (Comma, ",");
          (Dot, ".");
          (Wedge, "∧");
          (Vee, "∨");
          (RArrow, "→");
          (LRArrow, "↔");
          (Forall, "∀");
          (Exists, "∃");
        ]

  let alpha c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') || c = '_'
  let numeric c = c >= '0' && c <= '9'
  let alphanumeric c = alpha c || numeric c

  let identifier =
    (fun s -> Token.Ident s) <$> word alpha alphanumeric "Expected identifier"

  let token = choices identifier punctuation
  let final = lexer whitespace Token.EOF token
end

include C.Parser

let start = C.make_partial Position.start () C.final

let restart lex =
  assert (has_succeeded lex);
  assert (not (has_consumed_end lex));
  C.make_partial (position lex) () C.final |> transfer_lookahead lex