Formatter: Support comments

src/base/ErrorUtils.ml

@@ -26,7 +26,7 @@ type loc = {
   (* line number *)
   cnum : int; (* column number *)
 }
-[@@deriving sexp, equal]
+[@@deriving sexp, equal, compare]
 
 let toLoc (p : Lexing.position) : loc =
   {

src/base/ErrorUtils.mli

@@ -24,7 +24,7 @@ type loc = {
   (* line number *)
   cnum : int; (* column number *)
 }
-[@@deriving sexp, equal]
+[@@deriving sexp, equal, compare]
 
 val toLoc : Lexing.position -> loc
 val dummy_loc : loc

src/base/FrontEndParser.ml

@@ -87,4 +87,5 @@ module ScillaFrontEndParser (Literal : ScillaLiteral) = struct
   let parse_expr_from_stdin () = parse_stdin Parser.Incremental.exp_term
   let parse_lmodule filename = parse_file Parser.Incremental.lmodule filename
   let parse_cmodule filename = parse_file Parser.Incremental.cmodule filename
+  let get_comments () = Lexer.get_comments ()
 end

src/base/ScillaLexer.mll

@@ -29,6 +29,11 @@ module MkLexer (S : ParserUtil.Syn) = struct
 
   exception Error of string
 
+  let comments = ref []
+  let add_comment start_p s =
+    let loc = ErrorUtils.toLoc start_p in
+    comments := (loc, s) :: !comments
+  let get_comments () = List.rev !comments
 }
 
 let digit = ['0'-'9']
@@ -55,7 +60,7 @@ rule read =
 
   (* Whitespaces *)    
   | newline       { new_line lexbuf; read lexbuf }
-  | "(*"          { comment [lexbuf.lex_curr_p] lexbuf }
+  | "(*"          { comment (Buffer.create 50) [lexbuf.lex_start_p] lexbuf }
   | white         { read lexbuf }
 
   (* Numbers and hashes *)
@@ -148,16 +153,21 @@ and read_string buf =
   | eof { raise (Error ("String is not terminated")) }
 
 (* Nested comments, keeping a list of where comments open *)
-and comment braces =
+and comment buf braces =
   parse
-  | "(*"      { comment (lexbuf.lex_curr_p::braces) lexbuf}
+  | "(*"      { comment buf (lexbuf.lex_curr_p::braces) lexbuf }
   | "*)"      { match braces with
-                  _::[] -> read lexbuf
-                | _ -> comment (List.tl_exn braces) lexbuf }
-  | newline   { new_line lexbuf; comment braces lexbuf}
-  | _         { comment braces lexbuf}
-  | eof       { lexbuf.lex_curr_p <- List.hd_exn braces; raise (Error ("Comment unfinished"))}
+                  p::[] -> add_comment p (Buffer.contents buf);
+                           read lexbuf
+                | _ -> comment buf (List.tl_exn braces) lexbuf }
+  | newline   { new_line lexbuf;
+                Buffer.add_char buf '\n';
+                comment buf braces lexbuf }
+  | _         { Buffer.add_string buf (Lexing.lexeme lexbuf);
+                comment buf braces lexbuf }
+  | eof       { lexbuf.lex_curr_p <- List.hd_exn braces;
+                raise (Error ("Comment unfinished")) }
 
 {
 end
-}
+}

src/base/ScillaParser.mly

@@ -303,11 +303,11 @@ simple_exp :
 | LET; x = ID;
   t = ioption(type_annot)
   EQ; f = simple_exp; IN; e = exp
-  {(Let ( to_loc_id x (toLoc $startpos(x)), t, f, e), toLoc $startpos(f)) }
+  {(Let ( to_loc_id x (toLoc $startpos(x)), t, f, e), toLoc $startpos) }
 (* Function *)
 | FUN; LPAREN; iwt = id_with_typ; RPAREN; ARROW; e = exp
     { match iwt with
-      | (i, t) -> (Fun (i, t, e), toLoc $startpos(e) ) }
+      | (i, t) -> (Fun (i, t, e), toLoc $startpos ) }
 (* Application *)
 | f = sid;
   args = nonempty_list(sident)

src/base/TypeChecker.ml

@@ -324,16 +324,18 @@ module ScillaTypechecker (SR : Rep) (ER : Rep) = struct
         pure
         @@ ( TypedSyntax.Builtin ((fst b, q_ret_tag), ts, typed_actuals),
              (q_ret_typ, rep) )
-    | Let (i, topt, lhs, rhs) ->
+    | Let (i, topt, (lhs, lhs_rep), rhs) ->
         (* Poor man's error reporting *)
-        let%bind ((_, (ityp, _)) as checked_lhs) = type_expr lhs tenv in
+        let%bind ((_, (ityp, _)) as checked_lhs) =
+          type_expr (lhs, lhs_rep) tenv
+        in
         let%bind actual_typ =
           match topt with
           | Some tannot ->
               let%bind () =
                 fromR_TE
-                @@ assert_type_assignable ~lc:(ER.get_loc rep) ~expected:tannot
-                     ~actual:ityp.tp
+                @@ assert_type_assignable ~lc:(ER.get_loc lhs_rep)
+                     ~expected:tannot ~actual:ityp.tp
               in
               pure (mk_qual_tp tannot)
           | None -> pure ityp

src/base/dune

@@ -22,8 +22,8 @@
  (wrapped true)
  (libraries core core_unix core_unix.sys_unix num hex stdint angstrom
    polynomials cryptokit secp256k1 bitstring yojson fileutils scilla_crypto
-   menhirLib ocamlgraph pprint)
+   menhirLib ocamlgraph)
  (preprocess
-  (pps ppx_sexp_conv ppx_let ppx_deriving.show ppx_compare
-    ppx_string_interpolation bisect_ppx --conditional))
+  (pps ppx_sexp_conv ppx_let ppx_deriving.show ppx_compare bisect_ppx
+    --conditional))
  (synopsis "Scilla workbench implementation."))