Merge branch 'dev-format'

src/errors.ml

@@ -53,3 +53,4 @@ type type_error =
   | InvalidIdentifier                   of Range.t * string
   | ConflictInSignature                 of Range.t * string
   | DuplicatedLabel                     of Range.t * label
+  | NullaryFormatString                 of Range.t

src/lexer.mll

@@ -1,4 +1,5 @@
 {
+  open MyUtil
   open Syntax
   open Parser
   open Errors
@@ -9,6 +10,29 @@
 
   let raise_error e =
     raise (Error(e))
+
+
+  let hole_of_char = function
+    | 'c' -> HoleC
+    | 'f' -> HoleF
+    | 'e' -> HoleE
+    | 'g' -> HoleG
+    | 's' -> HoleS
+    | 'p' -> HoleP
+    | 'w' -> HoleW
+    | _   -> assert false
+
+
+  let int_of_string_or_empty = function
+    | "" -> None
+    | s  -> Some(int_of_string s)
+
+
+  let flush_buffer strbuf =
+    let s = Buffer.contents strbuf in
+    Buffer.clear strbuf;
+    FormatConst(s)
+
 }
 
 let space = [' ' '\t']
@@ -22,6 +46,8 @@ let latin = (small | capital)
 let identifier = (small (digit | latin | "_")*)
 let constructor = (capital (digit | latin | "_")*)
 let nssymbol = ['&' '|' '=' '/' '+' '-' '.']
+let fmtdigits = (("-" digit+) | (digit*))
+let hole = ['c' 'f' 'e' 'g' 's' 'p' 'w']
 
 rule token = parse
   | space { token lexbuf }
@@ -151,6 +177,13 @@ rule token = parse
       STRING(rng, s)
     }
 
+  | "f\'" {
+      let posL = Range.from_lexbuf lexbuf in
+      let strbuf = Buffer.create 128 in
+      let (rng, fmtelemacc) = format_literal posL strbuf Alist.empty lexbuf in
+      FORMAT(rng, Alist.to_list fmtelemacc)
+    }
+
   | "$\'" {
       let posL = Range.from_lexbuf lexbuf in
       let strbuf = Buffer.create 16 in
@@ -184,6 +217,60 @@ and string_literal posL strbuf = parse
   | "\\\'" { Buffer.add_char strbuf '\''; string_literal posL strbuf lexbuf }
   | _ as c { Buffer.add_char strbuf c; string_literal posL strbuf lexbuf }
 
+and format_literal posL strbuf acc = parse
+  | break  { raise_error (SeeBreakInStringLiteral(posL)) }
+  | eof    { raise_error (SeeEndOfFileInStringLiteral(posL)) }
+
+  | "\'" {
+      let posR = Range.from_lexbuf lexbuf in
+      let elem = flush_buffer strbuf in
+      (Range.unite posL posR, Alist.extend acc elem)
+    }
+
+  | "\\\'" { Buffer.add_char strbuf '\''; format_literal posL strbuf acc lexbuf }
+
+  | "~~" {
+      let elem = flush_buffer strbuf in
+      format_literal posL strbuf (Alist.append acc [elem; FormatTilde]) lexbuf
+    }
+
+  | "~n" {
+      let elem = flush_buffer strbuf in
+      format_literal posL strbuf (Alist.append acc [elem; FormatBreak]) lexbuf
+    }
+  | ("~" (fmtdigits as s1) (hole as c)) {
+      let elem = flush_buffer strbuf in
+      let hole = hole_of_char c in
+      let control =
+        {
+          field_width = int_of_string_or_empty s1;
+          precision   = None;
+          padding     = None;
+        }
+      in
+      format_literal posL strbuf (Alist.append acc [elem; FormatHole(hole, control)]) lexbuf
+    }
+
+  | ("~" (fmtdigits as s1) "." (fmtdigits as s2) (hole as c)) {
+      let elem = flush_buffer strbuf in
+      let hole = hole_of_char c in
+      let control =
+        {
+          field_width = int_of_string_or_empty s1;
+          precision   = int_of_string_or_empty s2;
+          padding     = None;
+        }
+      in
+      format_literal posL strbuf (Alist.append acc [elem; FormatHole(hole, control)]) lexbuf
+    }
+
+  | "\\\"" {
+      let elem = flush_buffer strbuf in
+      format_literal posL strbuf (Alist.append acc [elem; FormatDQuote]) lexbuf
+    }
+
+  | _ as c { Buffer.add_char strbuf c; format_literal posL strbuf acc lexbuf }
+
 and string_block num_start posL strbuf = parse
   | ("`" +) {
       let posR = Range.from_lexbuf lexbuf in

src/logging.ml

@@ -300,3 +300,7 @@ let report_type_error (e : type_error) : unit =
       Format.printf "%a: label '%s' is used more than once in a binding\n"
         Range.pp rng
         label
+
+  | NullaryFormatString(rng) ->
+      Format.printf "%a: nullary format string\n"
+        Range.pp rng

src/outputErlangCode.ml

@@ -97,6 +97,34 @@ let rec traverse_binding_list (gmap : global_name_map) (spacepath : space_name A
 let unit_atom = "ok"
 
 
+let stringify_hole = function
+  | HoleC -> "c"
+  | HoleF -> "f"
+  | HoleE -> "e"
+  | HoleG -> "g"
+  | HoleS -> "s"
+  | HoleP -> "p"
+  | HoleW -> "w"
+
+
+let stringify_format_element = function
+  | FormatBreak    -> (0, "~n")
+  | FormatTilde    -> (0, "~~")
+  | FormatDQuote   -> (0, "\\\"")
+  | FormatConst(s) -> (0, s)
+
+  | FormatHole(hole, control) ->
+      let ch = stringify_hole hole in
+      let s =
+        match (control.field_width, control.precision) with
+        | (Some(n1), Some(n2)) -> Printf.sprintf "%d.%d" n1 n2
+        | (Some(n1), None)     -> Printf.sprintf "%d" n1
+        | (None, Some(n2))     -> Printf.sprintf ".%d" n2
+        | (None, None)         -> ""
+      in
+      (1, Printf.sprintf "~%s%s" s ch)
+
+
 let stringify_base_constant (bc : base_constant) =
   match bc with
   | Unit        -> unit_atom
@@ -117,6 +145,12 @@ let stringify_base_constant (bc : base_constant) =
   | String(s)         -> Printf.sprintf "\"%s\"" (String.escaped s)
   | Char(uchar)       -> Printf.sprintf "%d" (Uchar.to_int uchar)
 
+  | FormatString(fmtelems) ->
+      let pairs = fmtelems |> List.map stringify_format_element in
+      let s = pairs |> List.map (fun (_, s) -> s) |> String.concat "" in
+      let arity = pairs |> List.fold_left (fun arity (n, _) -> arity + n) 0 in
+      Printf.sprintf "{\"%s\", %d}" s arity
+
 
 let get_module_string (gmap : global_name_map) (gname : global_name) : string =
   match gmap |> GlobalNameMap.find_opt gname with

src/parser.mly

@@ -53,6 +53,7 @@
 %token<Range.t * int> INT
 %token<Range.t * float> FLOAT
 %token<Range.t * string> BINARY STRING STRING_BLOCK
+%token<Range.t * Syntax.format_element list> FORMAT
 %token<Range.t * Uchar.t> CHAR
 %token EOI
 
@@ -548,6 +549,10 @@ exprbot:
         let (rng, s) = strlit in
         (rng, BaseConst(String(s)))
       }
+  | fmtlit=FORMAT {
+        let (rng, fmtelems) = fmtlit in
+        (rng, BaseConst(FormatString(fmtelems)))
+      }
   | charlit=CHAR {
         let (rng, uchar) = charlit in
         (rng, BaseConst(Char(uchar)))

src/primitives.ml

@@ -15,6 +15,27 @@ let decode_option_function_with_default =
   "decode_option_with_default"
 
 
+let vid_option = TypeID.Variant.fresh "option"
+
+
+let vid_list = TypeID.Variant.fresh "list"
+
+
+let vid_format = TypeID.Variant.fresh "format"
+
+
+let option_type (rng : Range.t) (ty : ('a, 'b) typ) : ('a, 'b) typ =
+  (rng, DataType(TypeID.Variant(vid_option), [ty]))
+
+
+let list_type (rng : Range.t) (ty : ('a, 'b) typ) : ('a, 'b) typ =
+  (rng, DataType(TypeID.Variant(vid_list), [ty]))
+
+
+let format_type (rng : Range.t) (ty : ('a, 'b) typ) : ('a, 'b) typ =
+  (rng, DataType(TypeID.Variant(vid_format), [ty]))
+
+
 let fresh_bound () =
   let bid = BoundID.fresh () in
   KindStore.register_bound_id bid UniversalKind;
@@ -26,6 +47,7 @@ let u = (dr, BaseType(UnitType))
 let b = (dr, BaseType(BoolType))
 let i = (dr, BaseType(IntType))
 let f = (dr, BaseType(FloatType))
+let c = (dr, BaseType(CharType))
 let ( @-> ) tydoms tycod = (dr, FuncType(tydoms, LabelAssoc.empty, FixedRow(LabelAssoc.empty), tycod))
 let eff tyrcv ty0 = (dr, EffType(Effect(tyrcv), ty0))
 let pid tyrcv = (dr, PidType(Pid(tyrcv)))
@@ -59,6 +81,11 @@ let typrintdebug : poly_type =
   [typaram] @-> u
 
 
+let tyformat : poly_type =
+  let typaram = fresh_bound () in
+  [format_type dr typaram; typaram] @-> list_type dr c
+
+
 type source_definition = {
   identifier  : string;
   typ         : poly_type;
@@ -132,6 +159,17 @@ let primitive_definitions = [
       code        = "io:format(\"~p~n\", [X]), ok";
     };
   };
+  {
+    source = Some{
+      identifier = "format";
+      typ        = tyformat;
+    };
+    target = {
+      target_name = "format";
+      parameters  = ["{Fmt, Arity}"; "Arg"];
+      code        = "Args = case Arity of 1 -> [Arg]; _ -> tuple_to_list(Arg) end, lists:flatten(io_lib:format(Fmt, Args))"
+    };
+  };
   {
     source = Some{
       identifier = "float";
@@ -190,20 +228,6 @@ let make_constructor_id ctor =
   | Some(ctorid) -> ctorid
 
 
-let vid_option = TypeID.Variant.fresh "option"
-
-
-let vid_list = TypeID.Variant.fresh "list"
-
-
-let option_type (rng : Range.t) (ty : ('a, 'b) typ) : ('a, 'b) typ =
-  (rng, DataType(TypeID.Variant(vid_option), [ty]))
-
-
-let list_type (rng : Range.t) (ty : ('a, 'b) typ) : ('a, 'b) typ =
-  (rng, DataType(TypeID.Variant(vid_list), [ty]))
-
-
 let add_variant_types vntdefs (tyenv, gmap) =
   let tyenv : Typeenv.t =
     vntdefs |> List.fold_left (fun tyenv vntdef ->
@@ -276,6 +300,12 @@ let initial_environment =
              because `ListNil` and `ListCons` are provided for type `untyped_ast`. *)
         ])
       end;
+      begin
+        let bid = BoundID.fresh () in
+        KindStore.register_bound_id bid UniversalKind;
+        ("format", vid_format, [bid], [
+        ])
+      end;
     ]
     |> add_operators [
       ("&&", tylogic, "and");

src/primitives.mli

@@ -30,4 +30,6 @@ val option_type : Range.t -> ('a, 'b) typ -> ('a, 'b) typ
 
 val list_type : Range.t -> ('a, 'b) typ -> ('a, 'b) typ
 
+val format_type : Range.t -> ('a, 'b) typ -> ('a, 'b) typ
+
 val initial_environment : Typeenv.t * global_name_map

src/syntax.ml

@@ -72,6 +72,34 @@ type base_type =
   | CharType
 [@@deriving show { with_path = false; } ]
 
+(* `format_*` are the types for representing format string literals.
+   For the detail of format strings, see:
+   http://erlang.org/doc/man/io.html *)
+type format_hole =
+  | HoleC  (* Characters. *)
+  | HoleF  (* `[-]ddd.ddd` for floating-point numbers. *)
+  | HoleE  (* `[-]d.ddde+-ddd` for floating-point numbers. *)
+  | HoleG  (* Same as `HoleF` for `[0.1, 10000)` and same as `HoleE` otherwise. *)
+  | HoleS  (* Strings. *)
+  | HoleP
+  | HoleW
+[@@deriving show {with_path = false; } ]
+
+type format_control = {
+  field_width : int option;
+  precision   : int option;
+  padding     : char option;
+}
+[@@deriving show {with_path = false; } ]
+
+type format_element =
+  | FormatTilde
+  | FormatBreak
+  | FormatDQuote
+  | FormatConst of string
+  | FormatHole  of format_hole * format_control
+[@@deriving show {with_path = false; } ]
+
 type base_constant =
   | Unit
   | Bool           of bool
@@ -82,6 +110,7 @@ type base_constant =
   | String         of string
   | Char           of Uchar.t
       [@printer (fun ppf uchar -> Format.fprintf ppf "Char(%a)" pp_uchar uchar)]
+  | FormatString   of format_element list
 [@@deriving show { with_path = false; } ]
 
 type manual_kind =