From a036abb2279355517dd3e1a7b692bd34ce351592 Mon Sep 17 00:00:00 2001 From: milner Date: Tue, 10 Jan 2017 16:42:00 +0000 Subject: [PATCH] Parse scalar expressions with source spans --- Makefile | 11 +++-- src/diagnostic.mli | 2 +- src/lexer.mll | 87 +++++++++++++++++++++++++++++++++++++ src/main.ml | 15 ++++--- src/parse.ml | 17 ++++++++ src/parse.mli | 1 + src/parser.mly | 85 ++++++++++++++++++++++++++++++++++++ src/syntax.ml | 52 ++++++++++++++++++++++ test/test_main.ml | 105 +++++++++++++++++++++++++++++++++++++++++++++ 9 files changed, 363 insertions(+), 12 deletions(-) create mode 100644 src/lexer.mll create mode 100644 src/parse.ml create mode 100644 src/parse.mli create mode 100644 src/parser.mly create mode 100644 src/syntax.ml diff --git a/Makefile b/Makefile index 5fe9412..d38c75e 100644 --- a/Makefile +++ b/Makefile @@ -24,7 +24,7 @@ RT_ML = $(wildcard $(RUNTIME_DIR)/*.ml) TEST_ML = $(wildcard $(TEST_DIR)/*.ml) BENCH_ML = $(wildcard $(BENCH_DIR)/*.ml) -LIB_CMX = $(patsubst $(SRC_DIR)/%.ml,$(BUILD)/%.cmx,$(LIB_ML)) +LIB_CMX = $(patsubst $(SRC_DIR)/%.ml,$(BUILD)/%.cmx,$(LIB_ML)) $(patsubst %.ml,%.cmx,$(LIB_GEN_ML)) RT_CMX = $(patsubst $(RUNTIME_DIR)/%.ml,$(BUILD)/%.cmx,$(RT_ML)) TEST_CMX = $(patsubst $(TEST_DIR)/%.ml,$(BUILD)/%.cmx,$(TEST_ML)) @@ -91,11 +91,14 @@ $(BUILD)/%.cmi: $(BUILD)/%.mli | $(BUILD) $(OCAMLC) $(FLAGS) -c $< -o $@ GEN = +LIB_GEN_ML = ifneq ($(wildcard $(SRC_DIR)/lexer.mll),) GEN += $(BUILD)/lexer.ml +LIB_GEN_ML += $(BUILD)/lexer.ml endif ifneq ($(wildcard $(SRC_DIR)/parser.mly),) GEN += $(BUILD)/parser.ml $(BUILD)/parser.mli +LIB_GEN_ML += $(BUILD)/parser.ml endif $(BUILD)/lexer.ml: $(SRC_DIR)/lexer.mll | $(BUILD) @@ -110,7 +113,7 @@ DEP_INCLUDES = -I $(SRC_DIR) $(if $(wildcard $(RUNTIME_DIR)),-I $(RUNTIME_DIR),) INTERFACES = $(wildcard $(SRC_DIR)/*.mli) $(wildcard $(RUNTIME_DIR)/*.mli) $(wildcard $(TEST_DIR)/*.mli) -$(BUILD)/deps.d: $(SRC_ML) $(INTERFACES) $(RT_ML) $(TEST_ML) $(BENCH_ML) $(GEN) | $(BUILD) +$(BUILD)/deps.d: $(MAKEFILE_LIST) $(SRC_ML) $(INTERFACES) $(RT_ML) $(TEST_ML) $(BENCH_ML) $(GEN) | $(BUILD) $(OCAMLDEP) $(DEP_INCLUDES) $(SRC_ML) $(INTERFACES) $(RT_ML) $(TEST_ML) $(BENCH_ML) $(GEN) > $(BUILD)/deps.tmp sed -e 's|$(SRC_DIR)/|$(BUILD)/|g' -e 's|$(RUNTIME_DIR)/|$(BUILD)/|g' \ -e 's|$(TEST_DIR)/|$(BUILD)/|g' -e 's|$(BENCH_DIR)/|$(BUILD)/|g' \ @@ -119,8 +122,8 @@ $(BUILD)/deps.d: $(SRC_ML) $(INTERFACES) $(RT_ML) $(TEST_ML) $(BENCH_ML) $(GEN) -include $(BUILD)/deps.d -$(BUILD)/order.mk: $(SRC_ML) $(RT_ML) $(TEST_ML) | $(BUILD) - { echo -n "LIB_ORDER = " ; $(OCAMLDEP) -sort $(LIB_ML) | sed -e 's|$(SRC_DIR)/\([^ ]*\)\.ml|$(BUILD)/\1.cmx|g' ; echo ; } > $@ +$(BUILD)/order.mk: $(MAKEFILE_LIST) $(SRC_ML) $(RT_ML) $(TEST_ML) $(GEN) | $(BUILD) + { echo -n "LIB_ORDER = " ; $(OCAMLDEP) -sort $(LIB_ML) $(LIB_GEN_ML) | sed -e 's|$(SRC_DIR)/\([^ ]*\)\.ml|$(BUILD)/\1.cmx|g' -e 's|$(BUILD)/\([^ ]*\)\.ml|$(BUILD)/\1.cmx|g' ; echo ; } > $@ { echo -n "RT_ORDER = " ; $(OCAMLDEP) -sort $(RT_ML) | sed -e 's|$(RUNTIME_DIR)/\([^ ]*\)\.ml|$(BUILD)/\1.cmx|g' ; echo ; } >> $@ -include $(BUILD)/order.mk diff --git a/src/diagnostic.mli b/src/diagnostic.mli index 66b0310..e1c9dc1 100644 --- a/src/diagnostic.mli +++ b/src/diagnostic.mli @@ -8,7 +8,7 @@ exception Error of t val set_file : string -> unit val file : unit -> string -val error : Location.span -> ('a, unit, string, 'a) format4 -> 'a +val error : Location.span -> ('a, unit, string, 'b) format4 -> 'a val make : Location.span -> string -> t val to_string : t -> string val render : string option -> t -> string diff --git a/src/lexer.mll b/src/lexer.mll new file mode 100644 index 0000000..1be1e32 --- /dev/null +++ b/src/lexer.mll @@ -0,0 +1,87 @@ +{ +open Parser +open Location + +let error_at lexbuf message = + let span = span_of_lexing (Lexing.lexeme_start_p lexbuf) (Lexing.lexeme_end_p lexbuf) in + Diagnostic.error span "%s" message + +let error_between start stop message = + Diagnostic.error (span_of_lexing start stop) "%s" message + +let keyword = function + | "let" -> LET + | "in" -> IN + | "fun" -> FUN + | "if" -> IF + | "then" -> THEN + | "else" -> ELSE + | "true" -> BOOL true + | "false" -> BOOL false + | text -> IDENT text +} + +let digit = ['0'-'9'] +let alpha = ['a'-'z' 'A'-'Z' '_'] +let identifier = alpha (alpha | digit | '\'')* + +rule token = parse + | [' ' '\t' '\r'] { token lexbuf } + | '\n' { Lexing.new_line lexbuf; token lexbuf } + | "(*" { comment 1 (Lexing.lexeme_start_p lexbuf) lexbuf } + | digit+ { + let text = Lexing.lexeme lexbuf in + try INT (int_of_string text) + with Failure _ -> error_at lexbuf (Printf.sprintf "integer literal %s does not fit in a machine integer" text) + } + | '"' { + let start = Lexing.lexeme_start_p lexbuf in + string_literal (Buffer.create 16) start lexbuf + } + | identifier { keyword (Lexing.lexeme lexbuf) } + | "->" { ARROW } + | "|>" { PIPE } + | "&&" { AND } + | "||" { OR } + | "<=" { LE } + | ">=" { GE } + | "<>" { NE } + | "<" { LT } + | ">" { GT } + | "=" { EQ } + | "+" { PLUS } + | "-" { MINUS } + | "*" { STAR } + | "/" { SLASH } + | "(" { LPAREN } + | ")" { RPAREN } + | "," { COMMA } + | "." { DOT } + | "{" { LBRACE } + | "}" { RBRACE } + | ":" { COLON } + | ";" { SEMI } + | eof { EOF } + | _ { error_at lexbuf (Printf.sprintf "unexpected character %C" (Lexing.lexeme_char lexbuf 0)) } + +and comment depth start = parse + | "(*" { comment (depth + 1) start lexbuf } + | "*)" { if depth = 1 then token lexbuf else comment (depth - 1) start lexbuf } + | '\n' { Lexing.new_line lexbuf; comment depth start lexbuf } + | eof { error_between start (Lexing.lexeme_end_p lexbuf) "unterminated comment" } + | _ { comment depth start lexbuf } + +and string_literal buffer start = parse + | '"' { STRING (Buffer.contents buffer) } + | '\\' { escape buffer lexbuf; string_literal buffer start lexbuf } + | '\n' { error_between start (Lexing.lexeme_start_p lexbuf) "unterminated string literal" } + | eof { error_between start (Lexing.lexeme_end_p lexbuf) "unterminated string literal" } + | _ { Buffer.add_string buffer (Lexing.lexeme lexbuf); string_literal buffer start lexbuf } + +and escape buffer = parse + | 'n' { Buffer.add_char buffer '\n' } + | 't' { Buffer.add_char buffer '\t' } + | 'r' { Buffer.add_char buffer '\r' } + | '"' { Buffer.add_char buffer '"' } + | '\\' { Buffer.add_char buffer '\\' } + | _ { error_at lexbuf (Printf.sprintf "unknown escape sequence \\%s" (Lexing.lexeme lexbuf)) } diff --git a/src/main.ml b/src/main.ml index 7e6c0d1..6ecb3a2 100644 --- a/src/main.ml +++ b/src/main.ml @@ -85,25 +85,26 @@ let load_source path = Diagnostic.set_file path; Native.read_file path +let parse_source path = Parse.expression (load_source path) + let frontend_unavailable () = - Diagnostic.error Location.none "the delta source frontend is not implemented in this revision" + Diagnostic.error Location.none "the delta pipeline beyond parsing is not implemented in this revision" let check path = - ignore (load_source path); - frontend_unavailable () + ignore (parse_source path) let dump stage path = - ignore (load_source path); - ignore stage; + ignore (stage); + ignore (parse_source path); frontend_unavailable () let emit path output = - ignore (load_source path); + ignore (parse_source path); ignore output; frontend_unavailable () let build path output = - ignore (load_source path); + ignore (parse_source path); ignore output; frontend_unavailable () diff --git a/src/parse.ml b/src/parse.ml new file mode 100644 index 0000000..3ff2650 --- /dev/null +++ b/src/parse.ml @@ -0,0 +1,17 @@ +let one_line text = + match String.index_opt text '\n' with + | Some index -> String.sub text 0 index + | None -> text + +let unexpected text lexbuf = + let start = Lexing.lexeme_start_p lexbuf in + let stop = Lexing.lexeme_end_p lexbuf in + let token = + if start.Lexing.pos_cnum >= String.length text then "end of file" + else "`" ^ one_line (Lexing.lexeme lexbuf) ^ "`" + in + Diagnostic.error (Location.span_of_lexing start stop) "syntax error: unexpected %s" token + +let expression text = + let lexbuf = Lexing.from_string text in + try Parser.expr Lexer.token lexbuf with Parsing.Parse_error -> unexpected text lexbuf diff --git a/src/parse.mli b/src/parse.mli new file mode 100644 index 0000000..1408d12 --- /dev/null +++ b/src/parse.mli @@ -0,0 +1 @@ +val expression : string -> Syntax.expr diff --git a/src/parser.mly b/src/parser.mly new file mode 100644 index 0000000..a8ec0f2 --- /dev/null +++ b/src/parser.mly @@ -0,0 +1,85 @@ +%{ +open Syntax + +let here () = Location.span_of_lexing (Parsing.symbol_start_pos ()) (Parsing.symbol_end_pos ()) +%} + +%token INT +%token BOOL +%token STRING +%token IDENT +%token LET IN FUN IF THEN ELSE +%token ARROW PIPE AND OR +%token EQ NE LT LE GT GE +%token PLUS MINUS STAR SLASH +%token LPAREN RPAREN COMMA DOT LBRACE RBRACE COLON SEMI +%token EOF + +%start expr +%type expr + +%% + +expr: + | pipeline { $1 } + +pipeline: + | disjunction { $1 } + | pipeline PIPE disjunction { make (EApp ($3, $1)) (here ()) } + +disjunction: + | conjunction { $1 } + | disjunction OR conjunction { make (EBinop (Or, $1, $3)) (here ()) } + +conjunction: + | comparison { $1 } + | conjunction AND comparison { make (EBinop (And, $1, $3)) (here ()) } + +comparison: + | sum { $1 } + | sum EQ sum { make (EBinop (Eq, $1, $3)) (here ()) } + | sum NE sum { make (EBinop (Ne, $1, $3)) (here ()) } + | sum LT sum { make (EBinop (Lt, $1, $3)) (here ()) } + | sum LE sum { make (EBinop (Le, $1, $3)) (here ()) } + | sum GT sum { make (EBinop (Gt, $1, $3)) (here ()) } + | sum GE sum { make (EBinop (Ge, $1, $3)) (here ()) } + +sum: + | product { $1 } + | sum PLUS product { make (EBinop (Add, $1, $3)) (here ()) } + | sum MINUS product { make (EBinop (Sub, $1, $3)) (here ()) } + +product: + | unary { $1 } + | product STAR unary { make (EBinop (Mul, $1, $3)) (here ()) } + | product SLASH unary { make (EBinop (Div, $1, $3)) (here ()) } + +unary: + | application { $1 } + | MINUS unary { make (ENeg $2) (here ()) } + +application: + | atom { $1 } + | application atom { make (EApp ($1, $2)) (here ()) } + +atom: + | INT { make (EInt $1) (here ()) } + | BOOL { make (EBool $1) (here ()) } + | STRING { make (EString $1) (here ()) } + | IDENT { make (EVar $1) (here ()) } + | LPAREN RPAREN { make EUnit (here ()) } + | LPAREN expr RPAREN { $2 } + | LPAREN expr COMMA expr_list RPAREN { make (ETuple ($2 :: $4)) (here ()) } + | LBRACE record_fields RBRACE { make (ERecord $2) (here ()) } + | atom DOT IDENT { make (EField ($1, $3)) (here ()) } + | LET IDENT EQ expr IN expr { make (ELet ($2, $4, $6)) (here ()) } + | FUN IDENT ARROW expr { make (ELambda ($2, $4)) (here ()) } + | IF expr THEN expr ELSE expr { make (EIf ($2, $4, $6)) (here ()) } + +expr_list: + | expr { [ $1 ] } + | expr COMMA expr_list { $1 :: $3 } + +record_fields: + | IDENT EQ expr { [ ($1, $3) ] } + | IDENT EQ expr SEMI record_fields { ($1, $3) :: $5 } diff --git a/src/syntax.ml b/src/syntax.ml new file mode 100644 index 0000000..bddfa87 --- /dev/null +++ b/src/syntax.ml @@ -0,0 +1,52 @@ +type binop = + | Add + | Sub + | Mul + | Div + | Eq + | Ne + | Lt + | Le + | Gt + | Ge + | And + | Or + +type expr = { + e : expr_desc; + espan : Location.span; +} + +and expr_desc = + | EInt of int + | EBool of bool + | EString of string + | EUnit + | EVar of string + | ELet of string * expr * expr + | ELambda of string * expr + | EApp of expr * expr + | EIf of expr * expr * expr + | EBinop of binop * expr * expr + | ENeg of expr + | ETuple of expr list + | ERecord of (string * expr) list + | EField of expr * string + +let make e espan = { e = e; espan = espan } + +let binop_name = function + | Add -> "+" + | Sub -> "-" + | Mul -> "*" + | Div -> "/" + | Eq -> "=" + | Ne -> "<>" + | Lt -> "<" + | Le -> "<=" + | Gt -> ">" + | Ge -> ">=" + | And -> "&&" + | Or -> "||" + +let string_of_binop = binop_name diff --git a/test/test_main.ml b/test/test_main.ml index 3baedae..926b837 100644 --- a/test/test_main.ml +++ b/test/test_main.ml @@ -76,9 +76,114 @@ let diagnostic_cases = Diagnostic.set_file "" ); ] +let parse text = Parse.expression text + +let parse_error text = + try + ignore (parse text); + None + with Diagnostic.Error diagnostic -> Some diagnostic + +let parse_cases = + [ + ( "integer and operator spans are recorded", + fun () -> + let parsed = parse "1 + 20" in + check_equal_string "whole span" "1:1-1:7" (Location.to_string parsed.Syntax.espan); + match parsed.Syntax.e with + | Syntax.EBinop (Syntax.Add, left, right) -> + check_equal_string "left span" "1:1-1:2" (Location.to_string left.Syntax.espan); + check_equal_string "right span" "1:5-1:7" (Location.to_string right.Syntax.espan) + | _ -> fail "shape" "expected an addition" ); + ( "pipeline is right associative application", + fun () -> + match (parse "x |> f |> g").Syntax.e with + | Syntax.EApp (outer, inner) -> ( + check "outer argument is the inner application" + (match outer.Syntax.e with Syntax.EVar "g" -> true | _ -> false); + match inner.Syntax.e with + | Syntax.EApp (f, arg) -> + check "inner function is f" (match f.Syntax.e with Syntax.EVar "f" -> true | _ -> false); + check "source is x" (match arg.Syntax.e with Syntax.EVar "x" -> true | _ -> false) + | _ -> fail "shape" "expected an application on the left" ) + | _ -> fail "shape" "expected an application" ); + ( "let, lambda and conditional parse with spans", + fun () -> + match (parse "let f = fun n -> if n > 0 then n else - n in f 3").Syntax.e with + | Syntax.ELet (name, _, body) -> + check_equal_string "bound name" "f" name; + check "body is an application" (match body.Syntax.e with Syntax.EApp _ -> true | _ -> false) + | _ -> fail "shape" "expected a let expression" ); + ( "tuples and record insertion parse", + fun () -> + match (parse "(1, 2, 3)").Syntax.e with + | Syntax.ETuple [ _; _; _ ] -> check "tuple of three" true + | _ -> fail "shape" "expected a tuple"; + match (parse "{ customer = \"Ada\" }").Syntax.e with + | Syntax.ERecord [ ("customer", _) ] -> check "record with one field" true + | _ -> fail "shape" "expected a record" ); + ( "field projection binds tighter than application", + fun () -> + match (parse "f o.total").Syntax.e with + | Syntax.EApp (_, argument) -> + check "argument is a projection" (match argument.Syntax.e with Syntax.EField _ -> true | _ -> false) + | _ -> fail "shape" "expected an application" ); + ( "comparison binds looser than conjunction", + fun () -> + match (parse "a && b = c").Syntax.e with + | Syntax.EBinop (Syntax.And, _, right) -> + check "right side is a comparison" (match right.Syntax.e with Syntax.EBinop (Syntax.Eq, _, _) -> true | _ -> false) + | _ -> fail "shape" "expected a conjunction at the root" ); + ( "unexpected character reports a span", + fun () -> + match parse_error "let x = @" with + | None -> fail "lexical error" "expected a diagnostic" + | Some diagnostic -> + check_equal_string "message" ":1:9: error: unexpected character '@'" + (Diagnostic.to_string diagnostic) ); + ( "unterminated string reports the opening quote", + fun () -> + match parse_error "let s = \"abc" with + | None -> fail "string" "expected a diagnostic" + | Some diagnostic -> + check_equal_string "message" ":1:9: error: unterminated string literal" + (Diagnostic.to_string diagnostic); + check_equal_string "span starts at the opening quote" "1:9-1:13" + (Location.to_string diagnostic.Diagnostic.span) ); + ( "unterminated comment reports a span", + fun () -> + match parse_error "1 (* comment" with + | None -> fail "comment" "expected a diagnostic" + | Some diagnostic -> + check_equal_string "message" ":1:3: error: unterminated comment" + (Diagnostic.to_string diagnostic); + check_equal_string "span starts at the comment opener" "1:3-1:13" + (Location.to_string diagnostic.Diagnostic.span) ); + ( "integer literal overflow reports a span", + fun () -> + match parse_error "99999999999999999999999" with + | None -> fail "overflow" "expected a diagnostic" + | Some diagnostic -> + check "message is non empty" (String.length diagnostic.Diagnostic.message > 0); + check_equal_string "position" "1:1" (Location.pos_to_string diagnostic.Diagnostic.span.Location.start) ); + ( "missing else reports the offending token", + fun () -> + match parse_error "if a then b" with + | None -> fail "syntax" "expected a diagnostic" + | Some diagnostic -> + check_equal_string "message" ":1:12: error: syntax error: unexpected end of file" + (Diagnostic.to_string diagnostic) ); + ( "nested comments are skipped", + fun () -> + let parsed = parse "(* a (* b *) c *) 7" in + check "the expression after the comment is parsed" + (match parsed.Syntax.e with Syntax.EInt 7 -> true | _ -> false) ); + ] + let () = Test_harness.run_suite "location" location_cases; Test_harness.run_suite "ident" ident_cases; Test_harness.run_suite "diagnostic" diagnostic_cases; + Test_harness.run_suite "parse" parse_cases; Printf.printf "%d cases, %d failures\n" (Test_harness.case_count ()) (Test_harness.failure_count ()); exit (if Test_harness.failure_count () = 0 then 0 else 1)