Parse scalar expressions with source spans

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);
-  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 ()
 

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