diff --git a/dune-project b/dune-project index c6a93db..27fa664 100644 --- a/dune-project +++ b/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))) diff --git a/lib/parser/dune b/lib/parser/dune index 05b635d..c51156e 100644 --- a/lib/parser/dune +++ b/lib/parser/dune @@ -1,3 +1,3 @@ (library (name pfparser) - (libraries kernel sedlex fmlib_parse)) + (libraries kernel fmlib_parse fmlib_std)) diff --git a/lib/parser/lexer.ml b/lib/parser/lexer.ml new file mode 100644 index 0000000..e2b2851 --- /dev/null +++ b/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 diff --git a/lib/parser/parse_test.ml b/lib/parser/parse_test.ml new file mode 100644 index 0000000..d2b1311 --- /dev/null +++ b/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) diff --git a/lib/parser/parser.ml b/lib/parser/parser.ml deleted file mode 100644 index 179d429..0000000 --- a/lib/parser/parser.ml +++ /dev/null @@ -1 +0,0 @@ -let x = 3 diff --git a/lib/parser/term_parser.ml b/lib/parser/term_parser.ml new file mode 100644 index 0000000..761533e --- /dev/null +++ b/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 () diff --git a/proof_checker.opam b/proof_checker.opam index 49ad67c..c37c1d0 100644 --- a/proof_checker.opam +++ b/proof_checker.opam @@ -13,6 +13,7 @@ depends: [ "ocaml" "dune" {>= "3.16"} "fmlib_parse" + "fmlib_std" "sedlex" "odoc" {with-doc} ]