Merge pull request #117 from engboris/lexer

Use sedlex instead of ocamllex

Author: engboris

bin/isgen.ml

@@ -1,8 +1,13 @@
 open Base
 
 let rec loop env =
-  let lexbuf = Lexing.from_channel Stdlib.stdin in
-  let d = Stellogen.Sgen_parser.declaration Stellogen.Sgen_lexer.read lexbuf in
+  let lexbuf = Sedlexing.Utf8.from_channel Stdlib.stdin in
+  let lexer = Sedlexing.with_tokenizer Stellogen.Sgen_lexer.read lexbuf in
+  let parser =
+    MenhirLib.Convert.Simplified.traditional2revised
+      Stellogen.Sgen_parser.declaration
+  in
+  let d = parser lexer in
   let wrapped_env =
     Stellogen.Sgen_eval.eval_decl ~typecheckonly:false ~notyping:false env d
   in

bin/lscrun.ml

@@ -2,14 +2,20 @@ open Base
 open Cmdliner
 open Lsc.Lsc_ast
 open Lsc.Lsc_err
-open Lsc.Lsc_parser
-open Lsc.Lsc_lexer
 open Out_channel
 
 let parse_and_eval input_file unfincomp linear showtrace =
-  let lexbuf = Lexing.from_channel (Stdlib.open_in input_file) in
-  lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = input_file };
-  let mcs = constellation_file read lexbuf in
+  let lexbuf = Sedlexing.Utf8.from_channel (Stdlib.open_in input_file) in
+  let start_pos filename =
+    { Lexing.pos_fname = filename; pos_lnum = 1; pos_bol = 0; pos_cnum = 0 }
+  in
+  Sedlexing.set_position lexbuf (start_pos input_file);
+  let lexer = Sedlexing.with_tokenizer Lsc.Lsc_lexer.read lexbuf in
+  let parser =
+    MenhirLib.Convert.Simplified.traditional2revised
+      Lsc.Lsc_parser.constellation_file
+  in
+  let mcs = parser lexer in
   let result =
     match exec ~linear ~showtrace mcs with
     | Ok result -> result

bin/sgen.ml

@@ -1,11 +1,13 @@
 open Base
 open Cmdliner
 open Stellogen.Sgen_eval
-open Lexing
 
 let parse_and_eval input_file typecheckonly notyping =
-  let lexbuf = Lexing.from_channel (Stdlib.open_in input_file) in
-  lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = input_file };
+  let lexbuf = Sedlexing.Utf8.from_channel (Stdlib.open_in input_file) in
+  let start_pos filename =
+    { Lexing.pos_fname = filename; pos_lnum = 1; pos_bol = 0; pos_cnum = 0 }
+  in
+  Sedlexing.set_position lexbuf (start_pos input_file);
   let p = Stellogen.Sgen_parsing.parse_with_error lexbuf in
   let _ = eval_program ~typecheckonly ~notyping p in
   ()

dune-project

@@ -19,7 +19,7 @@
  (name stellogen)
  (synopsis "Stellogen is a minimalistic and logic-agnostic programming
 language based on term unification.")
- (depends base menhir (alcotest :with-test))
+ (depends base menhir (alcotest :with-test) sedlex)
  (tags
   ("transcendental syntax" "logic programming" "constraint programming" "resolution logic" "unification" "self-assembly")))
 

src/lsc/dune

@@ -1,6 +1,8 @@
 (library
  (name lsc)
- (libraries base common)
+ (libraries base common menhirLib)
+ (preprocess
+  (pps sedlex.ppx))
  (modules lsc_err lsc_ast unification lsc_parser lsc_lexer))
 
 (env
@@ -11,6 +13,4 @@
 (menhir
  (modules ../common/common_parser lsc_parser)
  (merge_into lsc_parser)
- (flags --dump --explain))
-
-(ocamllex lsc_lexer)
+ (flags --table --dump --explain))

src/lsc/lsc_lexer.ml

@@ -0,0 +1,92 @@
+open Sedlexing
+open Lsc_parser
+
+exception SyntaxError of string
+
+let buf = Sedlexing.Utf8.from_channel
+
+let is_func_start = [%sedlex.regexp? 'a' .. 'z' | '0' .. '9']
+
+let is_func_rest =
+  [%sedlex.regexp? 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '?']
+
+let is_var_start = [%sedlex.regexp? 'A' .. 'Z']
+
+let is_var_rest =
+  [%sedlex.regexp? 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' | '-']
+
+let space = [%sedlex.regexp? Plus (' ' | '\t')]
+
+let newline = [%sedlex.regexp? '\r' | '\n' | "\r\n"]
+
+let rec read_string buf lexbuf =
+  match%sedlex lexbuf with
+  | '"' -> SYM ("\"" ^ Buffer.contents buf ^ "\"")
+  | '\\', '/' ->
+    Buffer.add_char buf '/';
+    read_string buf lexbuf
+  | '\\', '\\' ->
+    Buffer.add_char buf '\\';
+    read_string buf lexbuf
+  | '\\', 'b' ->
+    Buffer.add_char buf '\b';
+    read_string buf lexbuf
+  | '\\', 'f' ->
+    Buffer.add_char buf '\012';
+    read_string buf lexbuf
+  | '\\', 'n' ->
+    Buffer.add_char buf '\n';
+    read_string buf lexbuf
+  | '\\', 'r' ->
+    Buffer.add_char buf '\r';
+    read_string buf lexbuf
+  | '\\', 't' ->
+    Buffer.add_char buf '\t';
+    read_string buf lexbuf
+  | Plus (Compl ('"' | '\\')) ->
+    Buffer.add_string buf (Utf8.lexeme lexbuf);
+    read_string buf lexbuf
+  | eof -> raise (SyntaxError "String is not terminated")
+  | _ -> raise (SyntaxError ("Illegal string character: " ^ Utf8.lexeme lexbuf))
+
+and comment lexbuf =
+  match%sedlex lexbuf with
+  | newline | eof -> read lexbuf
+  | _ ->
+    ignore (Sedlexing.next lexbuf);
+    comment lexbuf
+
+and comments lexbuf =
+  match%sedlex lexbuf with
+  | "'''" -> read lexbuf
+  | _ ->
+    ignore (Sedlexing.next lexbuf);
+    comments lexbuf
+
+and read lexbuf =
+  match%sedlex lexbuf with
+  | is_var_start, Star is_var_rest -> VAR (Utf8.lexeme lexbuf)
+  | is_func_start, Star is_func_rest -> SYM (Utf8.lexeme lexbuf)
+  | '\'' -> comment lexbuf
+  | "'''" -> comments lexbuf
+  | '_' -> PLACEHOLDER
+  | '.' -> DOT
+  | '|' -> BAR
+  | '[' -> LBRACK
+  | ']' -> RBRACK
+  | '(' -> LPAR
+  | ')' -> RPAR
+  | ',' -> COMMA
+  | '@' -> AT
+  | '&' -> AMP
+  | '+' -> PLUS
+  | '-' -> MINUS
+  | ':' -> CONS
+  | ';' -> SEMICOLON
+  | '"' -> read_string (Buffer.create 128) lexbuf
+  | space | newline -> read lexbuf
+  | eof -> EOF
+  | _ ->
+    raise
+      (SyntaxError
+         ("Unexpected character '" ^ Utf8.lexeme lexbuf ^ "' during lexing") )

src/lsc/lsc_lexer.mll

@@ -2,11 +2,11 @@
 open Lsc_ast
 %}
 
+%token <string> VAR
+%token <string> SYM
 %token BAR
 %token NEQ
 %token COMMA
-%token <string> VAR
-%token <string> SYM
 %token PLUS MINUS
 %token CONS
 %token SEMICOLON

src/lsc/lsc_parser.mly

@@ -1,6 +1,8 @@
 (library
  (name stellogen)
- (libraries base common))
+ (libraries base common menhirLib)
+ (preprocess
+  (pps sedlex.ppx)))
 
 (env
  (dev
@@ -10,6 +12,4 @@
 (menhir
  (modules ../common/common_parser lsc_parser sgen_parser)
  (merge_into sgen_parser)
- (flags --explain --dump))
-
-(ocamllex sgen_lexer)
+ (flags --table --explain --dump))

src/stellogen/dune

@@ -500,9 +500,13 @@ let rec eval_decl ~typecheckonly ~notyping env :
   | Use path ->
     let path = List.map path ~f:string_of_ray in
     let formatted_filename = String.concat ~sep:"/" path ^ ".sg" in
-    let lexbuf = Lexing.from_channel (Stdlib.open_in formatted_filename) in
-    lexbuf.lex_curr_p <-
-      { lexbuf.lex_curr_p with pos_fname = formatted_filename };
+    let lexbuf =
+      Sedlexing.Utf8.from_channel (Stdlib.open_in formatted_filename)
+    in
+    let start_pos filename =
+      { Lexing.pos_fname = filename; pos_lnum = 1; pos_bol = 0; pos_cnum = 0 }
+    in
+    Sedlexing.set_position lexbuf (start_pos formatted_filename);
     let p = Sgen_parsing.parse_with_error lexbuf in
     let* env = eval_program ~typecheckonly ~notyping p in
     Ok env