Source file string_interp.ml

(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

open Import

type error =
  | Invalid_code_point
  | Unterminated_backslash
  | Unterminated_variable
  | Unmatched_paren
  | Invalid_syntax_of_var of string

type content =
  | String of string
  | Var of {
      lident : Longident.t;
      content : string;
      loffset : int;
      roffset : int;
    }

(* [Var (loffset, roffset)]
   For parens it used to be (2,-1)
   for non-parens it used to be (1,0) *)

(* Note the position is about code point *)
type pos = {
  lnum : int;
  offset : int;
  byte_bol : int;
      (* Note it actually needs to be in sync with OCaml's lexing semantics *)
}

type segment = { start : pos; finish : pos; content : content }

type cxt = {
  mutable segment_start : pos;
  buf : Buffer.t;
  s_len : int;
  mutable segments : segment list;
  pos_bol : int; (* record the abs position of current beginning line *)
  byte_bol : int;
  pos_lnum : int; (* record the line number *)
}

exception Error of pos * pos * error

let pp_error =
  let to_string = function
    | Invalid_code_point -> "Invalid code point"
    | Unterminated_backslash -> "\\ ended unexpectedly"
    | Unterminated_variable -> "$ unterminated"
    | Unmatched_paren -> "Unmatched paren"
    | Invalid_syntax_of_var s ->
        "`" ^ s ^ "' is not a valid syntax of interpolated identifer"
  in
  fun fmt err -> Format.pp_print_string fmt (to_string err)

let valid_lead_identifier_char = function
  | 'a' .. 'z' | '_' -> true
  | _ -> false

let valid_identifier_char = function
  | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '\'' | '.' -> true
  | _ -> false

(* Invariant: [valid_lead_identifier] has to be [valid_identifier] *)
let valid_identifier s =
  match String.length (String.trim s) with
  | 0 -> None
  | _n -> (
      match String.for_all s ~f:valid_identifier_char with
      | true -> (
          match Longident.parse s with li -> Some li | exception _ -> None)
      | false -> None)

(* FIXME: multiple line offset
   if there is no line offset. Note {|{j||} border will never trigger a new
   line *)
let update_position border { lnum; offset; byte_bol } (pos : Lexing.position) =
  match lnum with
  | 0 -> { pos with pos_cnum = pos.pos_cnum + border + offset }
  | _ ->
      (* When no newline, the column number is [border + offset] *)
      {
        pos with
        pos_lnum = pos.pos_lnum + lnum;
        pos_bol = pos.pos_cnum + border + byte_bol;
        pos_cnum = pos.pos_cnum + border + byte_bol + offset;
        (* when newline, the column number is [offset] *)
      }

let update border start finish (loc : Location.t) =
  {
    loc with
    loc_start = update_position border start loc.loc_start;
    loc_end = update_position border finish loc.loc_start;
  }

let pos_error cxt ~loc error =
  raise
    (Error
       ( cxt.segment_start,
         {
           lnum = cxt.pos_lnum;
           offset = loc - cxt.pos_bol;
           byte_bol = cxt.byte_bol;
         },
         error ))

let add_var_segment cxt ~loc ~loffset ~roffset =
  let content = Buffer.contents cxt.buf in
  Buffer.clear cxt.buf;
  let next_loc =
    { lnum = cxt.pos_lnum; offset = loc - cxt.pos_bol; byte_bol = cxt.byte_bol }
  in
  match valid_identifier content with
  | Some lident ->
      cxt.segments <-
        {
          start = cxt.segment_start;
          finish = next_loc;
          content = Var { content; loffset; roffset; lident };
        }
        :: cxt.segments;
      cxt.segment_start <- next_loc
  | None ->
      let cxt =
        match String.trim content with
        | "" ->
            (* Move the position back 2 characters "$(" if this is the empty
             interpolation. *)
            {
              cxt with
              segment_start =
                {
                  cxt.segment_start with
                  offset =
                    (match cxt.segment_start.offset with 0 -> 0 | n -> n - 3);
                  byte_bol =
                    (match cxt.segment_start.byte_bol with
                    | 0 -> 0
                    | n -> n - 3);
                };
              pos_bol = cxt.pos_bol + 3;
              byte_bol = cxt.byte_bol + 3;
            }
        | _ -> cxt
      in
      pos_error cxt ~loc (Invalid_syntax_of_var content)

let add_str_segment cxt loc =
  let content = Buffer.contents cxt.buf in
  Buffer.clear cxt.buf;
  let next_loc =
    { lnum = cxt.pos_lnum; offset = loc - cxt.pos_bol; byte_bol = cxt.byte_bol }
  in
  cxt.segments <-
    { start = cxt.segment_start; finish = next_loc; content = String content }
    :: cxt.segments;
  cxt.segment_start <- next_loc

let rec check_and_transform loc s byte_offset ({ s_len; buf; _ } as cxt) =
  match Int.equal byte_offset s_len with
  | true -> add_str_segment cxt loc
  | false -> (
      let current_char = s.[byte_offset] in
      match Melange_ffi.Utf8_string.classify current_char with
      | Single 92 (* '\\' *) ->
          let loc = loc + 1 in
          let offset = byte_offset + 1 in
          if offset >= s_len then pos_error cxt ~loc Unterminated_backslash
          else Buffer.add_char buf '\\';
          let cur_char = s.[offset] in
          Buffer.add_char buf cur_char;
          check_and_transform (loc + 1) s (offset + 1) cxt
      | Single 36 ->
          (* $ *)
          add_str_segment cxt loc;
          let offset = byte_offset + 1 in
          if offset >= s_len then pos_error ~loc cxt Unterminated_variable
          else
            let cur_char = s.[offset] in
            if cur_char = '(' then expect_var_paren (loc + 2) s (offset + 1) cxt
            else expect_simple_var (loc + 1) s offset cxt
      | Single _ | Leading _ | Cont _ ->
          Buffer.add_char buf current_char;
          check_and_transform (loc + 1) s (byte_offset + 1) cxt
      | Invalid -> pos_error ~loc cxt Invalid_code_point)

(* Lets keep identifier simple, so that we could generating a function easier
   in the future for example
   let f = [%fn{| $x + $y = $x_add_y |}] *)
and expect_simple_var loc s offset ({ buf; s_len; _ } as cxt) =
  match offset < s_len && valid_lead_identifier_char s.[offset] with
  | false -> pos_error cxt ~loc (Invalid_syntax_of_var String.empty)
  | true ->
      let v = ref offset in
      while !v < s_len && valid_identifier_char s.[!v] do
        (* TODO *)
        let cur_char = s.[!v] in
        Buffer.add_char buf cur_char;
        incr v
      done;
      let added_length = !v - offset in
      let loc = added_length + loc in
      add_var_segment cxt ~loc ~loffset:1 ~roffset:0;
      check_and_transform loc s (added_length + offset) cxt

and expect_var_paren loc s offset ({ buf; s_len; _ } as cxt) =
  let v = ref offset in
  while !v < s_len && s.[!v] <> ')' do
    let cur_char = s.[!v] in
    Buffer.add_char buf cur_char;
    incr v
  done;
  let added_length = !v - offset in
  let loc = added_length + 1 + loc in
  match !v < s_len && s.[!v] = ')' with
  | true ->
      add_var_segment cxt ~loc ~loffset:2 ~roffset:(-1);
      check_and_transform loc s (added_length + 1 + offset) cxt
  | false -> pos_error cxt ~loc Unmatched_paren

(* TODO: Allow identifers x.A.y *)

let border = String.length "{j|"

let rec handle_segments =
  let module Exp = Ast_helper.Exp in
  let concat_ident : Longident.t = Ldot (Lident "Stdlib", "^") in
  let escaped_js_delimiter =
    (* syntax not allowed at the user level *)
    Some "js"
  in
  let merge_loc (l : Location.t) (r : Location.t) =
    if l.loc_ghost then r
    else if r.loc_ghost then l
    else { loc_start = l.loc_start; loc_end = r.loc_end; loc_ghost = false }
  in
  let aux loc { start; finish; content } =
    match content with
    | String content ->
        let loc = update border start finish loc in
        Exp.constant (Pconst_string (content, loc, escaped_js_delimiter))
    | Var { loffset = soffset; roffset = foffset; content = _; lident } ->
        let loc =
          {
            loc with
            loc_start = update_position (soffset + border) start loc.loc_start;
            loc_end = update_position (foffset + border) finish loc.loc_start;
          }
        in
        Exp.ident ~loc { loc; txt = lident }
  in
  let concat_exp a_loc x ~(lhs : expression) =
    let loc = merge_loc a_loc lhs.pexp_loc in
    Exp.apply
      (Exp.ident { txt = concat_ident; loc })
      [ (Nolabel, lhs); (Nolabel, aux loc x) ]
  in
  fun loc rev_segments ->
    match rev_segments with
    | [] -> Exp.constant (Pconst_string ("", loc, escaped_js_delimiter))
    | [ segment ] -> aux loc segment (* string literal *)
    | { content = String ""; _ } :: rest -> handle_segments loc rest
    | a :: rest -> concat_exp loc a ~lhs:(handle_segments loc rest)

let transform =
  let unescaped_j_delimiter = "j" in
  let transform (e : expression) s ~delim =
    match String.equal delim unescaped_j_delimiter with
    | true ->
        let s_len = String.length s in
        let cxt =
          {
            segment_start = { lnum = 0; offset = 0; byte_bol = 0 };
            buf = Buffer.create (s_len * 2);
            s_len;
            segments = [];
            pos_lnum = 0;
            byte_bol = 0;
            pos_bol = 0;
          }
        in
        check_and_transform 0 s 0 cxt;
        handle_segments e.pexp_loc cxt.segments
    | false -> e
  in
  fun ~loc ~delim expr s ->
    try transform expr s ~delim
    with Error (start, pos, error) ->
      let loc = update border start pos loc in
      Location.raise_errorf ~loc "%a" pp_error error

module Private = struct
  type nonrec segment = segment = {
    start : pos;
    finish : pos;
    content : content;
  }

  let transform_test s =
    let s_len = String.length s in
    let cxt =
      {
        segment_start = { lnum = 0; offset = 0; byte_bol = 0 };
        buf = Buffer.create (s_len * 2);
        s_len;
        segments = [];
        pos_lnum = 0;
        byte_bol = 0;
        pos_bol = 0;
      }
    in
    check_and_transform 0 s 0 cxt;
    List.rev cxt.segments
end