Skip to content

Commit

Permalink
[macro] make MacroStringTools.formatString work during init macros too
Browse files Browse the repository at this point in the history
  • Loading branch information
@kLabz
kLabz committed Oct 3, 2023
1 parent 5675e97 commit eb40b07
Show file tree
Hide file tree
Showing 3 changed files with 101 additions and 99 deletions.
97 changes: 97 additions & 0 deletions src/context/common.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1317,3 +1317,100 @@ let get_entry_point com =
let e = Option.get com.main in (* must be present at this point *)
(snd path, c, e)
) com.main_class

let format_string com s p process_expr =
let e = ref None in
let pmin = ref p.pmin in
let min = ref (p.pmin + 1) in
let add_expr (enext,p) len =
min := !min + len;
let enext = process_expr enext p in
match !e with
| None -> e := Some enext
| Some prev ->
e := Some (EBinop (OpAdd,prev,enext),punion (pos prev) p)
in
let add enext len =
let p = { p with pmin = !min; pmax = !min + len } in
add_expr (enext,p) len
in
let add_sub start pos =
let len = pos - start in
if len > 0 || !e = None then add (EConst (String (String.sub s start len,SDoubleQuotes))) len
in
let len = String.length s in
let rec parse start pos =
if pos = len then add_sub start pos else
let c = String.unsafe_get s pos in
let pos = pos + 1 in
if c = '\'' then begin
incr pmin;
incr min;
end;
if c <> '$' || pos = len then parse start pos else
match String.unsafe_get s pos with
| '$' ->
(* double $ *)
add_sub start pos;
parse (pos + 1) (pos + 1)
| '{' ->
parse_group start pos '{' '}' "brace"
| 'a'..'z' | 'A'..'Z' | '_' ->
add_sub start (pos - 1);
incr min;
let rec loop i =
if i = len then i else
let c = String.unsafe_get s i in
match c with
| 'a'..'z' | 'A'..'Z' | '0'..'9' | '_' -> loop (i+1)
| _ -> i
in
let iend = loop (pos + 1) in
let len = iend - pos in
add (EConst (Ident (String.sub s pos len))) len;
parse (pos + len) (pos + len)
| _ ->
(* keep as-it *)
parse start pos
and parse_group start pos gopen gclose gname =
add_sub start (pos - 1);
let rec loop groups i =
if i = len then
match groups with
| [] -> die "" __LOC__
| g :: _ -> Error.raise_typing_error ("Unclosed " ^ gname) { p with pmin = !pmin + g + 1; pmax = !pmin + g + 2 }
else
let c = String.unsafe_get s i in
if c = gopen then
loop (i :: groups) (i + 1)
else if c = gclose then begin
let groups = List.tl groups in
if groups = [] then i else loop groups (i + 1)
end else
loop groups (i + 1)
in
let send = loop [pos] (pos + 1) in
let slen = send - pos - 1 in
let scode = String.sub s (pos + 1) slen in
min := !min + 2;
begin
let e =
let ep = { p with pmin = !pmin + pos + 2; pmax = !pmin + send + 1 } in
let error msg pos =
if Lexer.string_is_whitespace scode then Error.raise_typing_error "Expression cannot be empty" ep
else Error.raise_typing_error msg pos
in
match ParserEntry.parse_expr_string com.defines scode ep error true with
| ParseSuccess(data,_,_) -> data
| ParseError(_,(msg,p),_) -> error (Parser.error_msg msg) p
in
add_expr e slen
end;
min := !min + 1;
parse (send + 1) (send + 1)
in
parse 0 0;
match !e with
| None -> die "" __LOC__
| Some e -> e

5 changes: 1 addition & 4 deletions src/typing/macroContext.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -262,7 +262,7 @@ let make_macro_com_api com p =
!macro_enable_cache
);
format_string = (fun s p ->
Interp.exc_string "unsupported"
Common.format_string com s p (fun e p -> (e,p))
);
cast_or_unify = (fun t e p ->
Interp.exc_string "unsupported"
Expand Down Expand Up @@ -525,9 +525,6 @@ and promote_com_api com_api ctx p =
MacroApi.current_module = (fun() ->
ctx.m.curmod
);
MacroApi.format_string = (fun s p ->
ctx.g.do_format_string ctx s p
);
MacroApi.cast_or_unify = (fun t e p ->
typing_timer ctx true (fun () ->
try
Expand Down
98 changes: 3 additions & 95 deletions src/typing/typer.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -729,104 +729,12 @@ and type_vars ctx vl p =
mk (TMeta((Meta.MergeBlock,[],p), e)) e.etype e.epos

and format_string ctx s p =
let e = ref None in
let pmin = ref p.pmin in
let min = ref (p.pmin + 1) in
let add_expr (enext,p) len =
min := !min + len;
let enext = if ctx.in_display && DisplayPosition.display_position#enclosed_in p then
Common.format_string ctx.com s p (fun enext p ->
if ctx.in_display && DisplayPosition.display_position#enclosed_in p then
Display.ExprPreprocessing.process_expr ctx.com (enext,p)
else
enext,p
in
match !e with
| None -> e := Some enext
| Some prev ->
e := Some (EBinop (OpAdd,prev,enext),punion (pos prev) p)
in
let add enext len =
let p = { p with pmin = !min; pmax = !min + len } in
add_expr (enext,p) len
in
let add_sub start pos =
let len = pos - start in
if len > 0 || !e = None then add (EConst (String (String.sub s start len,SDoubleQuotes))) len
in
let len = String.length s in
let rec parse start pos =
if pos = len then add_sub start pos else
let c = String.unsafe_get s pos in
let pos = pos + 1 in
if c = '\'' then begin
incr pmin;
incr min;
end;
if c <> '$' || pos = len then parse start pos else
match String.unsafe_get s pos with
| '$' ->
(* double $ *)
add_sub start pos;
parse (pos + 1) (pos + 1)
| '{' ->
parse_group start pos '{' '}' "brace"
| 'a'..'z' | 'A'..'Z' | '_' ->
add_sub start (pos - 1);
incr min;
let rec loop i =
if i = len then i else
let c = String.unsafe_get s i in
match c with
| 'a'..'z' | 'A'..'Z' | '0'..'9' | '_' -> loop (i+1)
| _ -> i
in
let iend = loop (pos + 1) in
let len = iend - pos in
add (EConst (Ident (String.sub s pos len))) len;
parse (pos + len) (pos + len)
| _ ->
(* keep as-it *)
parse start pos
and parse_group start pos gopen gclose gname =
add_sub start (pos - 1);
let rec loop groups i =
if i = len then
match groups with
| [] -> die "" __LOC__
| g :: _ -> raise_typing_error ("Unclosed " ^ gname) { p with pmin = !pmin + g + 1; pmax = !pmin + g + 2 }
else
let c = String.unsafe_get s i in
if c = gopen then
loop (i :: groups) (i + 1)
else if c = gclose then begin
let groups = List.tl groups in
if groups = [] then i else loop groups (i + 1)
end else
loop groups (i + 1)
in
let send = loop [pos] (pos + 1) in
let slen = send - pos - 1 in
let scode = String.sub s (pos + 1) slen in
min := !min + 2;
begin
let e =
let ep = { p with pmin = !pmin + pos + 2; pmax = !pmin + send + 1 } in
let error msg pos =
if Lexer.string_is_whitespace scode then raise_typing_error "Expression cannot be empty" ep
else raise_typing_error msg pos
in
match ParserEntry.parse_expr_string ctx.com.defines scode ep error true with
| ParseSuccess(data,_,_) -> data
| ParseError(_,(msg,p),_) -> error (Parser.error_msg msg) p
in
add_expr e slen
end;
min := !min + 1;
parse (send + 1) (send + 1)
in
parse 0 0;
match !e with
| None -> die "" __LOC__
| Some e -> e
)

and type_block ctx el with_type p =
let merge acc e = match e.eexpr with
Expand Down

0 comments on commit eb40b07

Please sign in to comment.