parsing terms!

dune-project

@@ -19,7 +19,7 @@
  (name proof_checker)
  (synopsis "A short synopsis")
  (description "A longer description")
- (depends ocaml dune fmlib_parse sedlex)
+ (depends ocaml dune fmlib_parse fmlib_std)
  (tags
   (topics "to describe" your project)))
 

lib/parser/dune

@@ -1,3 +1,3 @@
 (library
  (name pfparser)
- (libraries kernel sedlex fmlib_parse))
+ (libraries kernel fmlib_parse fmlib_std))

lib/parser/lexer.ml

@@ -0,0 +1,70 @@
+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

lib/parser/parse_test.ml

@@ -0,0 +1,14 @@
+open Fmlib_parse
+open Term_parser
+
+include
+  Parse_with_lexer.Make (State) (Token) (Final) (Semantic) (Lexer) (Term_parser)
+
+let state : state =
+  {
+    binders = [ "x"; "y"; "z" ];
+    constants = StringSet.of_list [ "Z" ];
+    functions = StringMap.of_list [ ("S", 1); ("plus", 2) ];
+  }
+
+let start = make Lexer.start (Term_parser.token_parser state)

lib/parser/parser.ml

@@ -1 +0,0 @@
-let x = 3

lib/parser/term_parser.ml

@@ -0,0 +1,67 @@
+open Fmlib_parse
+module StringSet = Set.Make (String)
+module StringMap = Map.Make (String)
+
+module State = struct
+  type t = {
+    binders : string list;
+    constants : StringSet.t;
+    functions : int StringMap.t;
+  }
+end
+
+module Token = Lexer.Token
+
+module Final = struct
+  type t = Kernel.Term.t
+end
+
+module Semantic = struct
+  type t = ArityMismatch
+end
+
+module C = struct
+  include Token_parser.Make (State) (Token) (Final) (Semantic)
+  open Kernel.Term
+  open State
+
+  let ident_p =
+    step "Expected identifier" (fun state _ -> function
+      | Token.Ident id -> Some (id, state) | _ -> None)
+
+  let expect tt s =
+    step ("Expected " ^ s) (fun state _ tt' ->
+        if tt = tt' then Some ((), state) else None)
+
+  let rec args_p () =
+    let* _ = expect Token.LParen "`('" in
+    let* args =
+      one_or_more_separated
+        (fun x -> return [ x ])
+        (fun acc _ t -> return (t :: acc))
+        (term_p ()) (expect Comma "comma")
+      |> map List.rev
+    in
+    let* _ = expect Token.RParen "`)'" in
+    return args
+
+  and term_p () =
+    let* ident = ident_p in
+    let* { binders; constants; functions } = get in
+    match List.find_index (( = ) ident) binders with
+    | Some x -> return @@ Var x
+    | None ->
+        if StringSet.mem ident constants then return @@ Const ident
+        else if StringMap.mem ident functions then
+          let* args = args_p () in
+          if List.length args <> StringMap.find ident functions then
+            fail ArityMismatch
+          else return @@ Function (ident, args)
+        else return @@ Free ident
+
+  let final = term_p
+end
+
+include C.Parser
+
+let token_parser state = C.make state @@ C.final ()

proof_checker.opam

@@ -13,6 +13,7 @@ depends: [
   "ocaml"
   "dune" {>= "3.16"}
   "fmlib_parse"
+  "fmlib_std"
   "sedlex"
   "odoc" {with-doc}
 ]