Parse scalar expressions with source spans

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)
+$(BUILD)/order.mk: $(MAKEFILE_LIST) $(SRC_ML) $(RT_ML) $(TEST_ML) $(GEN) | $(BUILD)
-	{ echo -n "LIB_ORDER = " ; $(OCAMLDEP) -sort $(LIB_ML) | sed -e 's|$(SRC_DIR)/\([^ ]*\)\.ml|$(BUILD)/\1.cmx|g' ; echo ; } > $@
+	{ 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

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

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)) }

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);
+  ignore (parse_source path)
-  frontend_unavailable ()
 
 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 ()
 

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

src/parse.mli

@@ -0,0 +1 @@
+val expression : string -> Syntax.expr

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> INT
+%token <bool> BOOL
+%token <string> STRING
+%token <string> 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 <Syntax.expr> 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 }

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

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" "<none>: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" "<none>: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" "<none>: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" "<none>: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)