File: xstrp4_here.ml

package info (click to toggle)
xstrp4 1.8.2-3
  • links: PTS, VCS
  • area: main
  • in suites: bookworm, bullseye, sid
  • size: 128 kB
  • sloc: ml: 249; makefile: 119
file content (183 lines) | stat: -rw-r--r-- 4,342 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
(* $Id$
 * ----------------------------------------------------------------------
 *
 *)

open Xstrp4_here_types
open Camlp4.PreCast
open Syntax

let camlp4loc (loc1,loc2) =
  Loc.merge
    (Loc.of_lexing_position loc1)
    (Loc.of_lexing_position loc2)
    

class camlp4reloc reloc = 
object 
  inherit Ast.map 

  method loc _ = reloc 
end

let interpolated_expr lexbuf _loc =
  (* Parse [lexbuf], and generate the syntax tree for the corresponding expression.
   *)

  let rec parse_here_expr() =
    let tok = Xstrp4_here_lexer.token lexbuf in
      match tok with
	  Textend -> []
	| x       -> x :: parse_here_expr ()
  in

  let rec normalize_literals =
    (* - Concat adjacent literals
     * - Remove empty literals
     *)
    function
	[] -> 
	  []
      | Literal("",_) :: tl -> 
	  normalize_literals tl
      | Literal(s1,(p1,_)) :: (Literal(s2,(_,p2))) :: tl -> 
	  normalize_literals((Literal(s1^s2,(p1,p2)))::tl)
      | hd :: tl ->
	  hd :: (normalize_literals tl)
  in

  let fix_position p =
    { Lexing.pos_fname = Loc.file_name _loc;
      Lexing.pos_lnum = p.Lexing.pos_lnum + Loc.start_line _loc - 1;
      Lexing.pos_cnum = p.Lexing.pos_cnum + Loc.start_off _loc;
      Lexing.pos_bol  = p.Lexing.pos_bol  + Loc.start_bol _loc;
    }
  in		   

  let fix_positions =
    function
	Literal(s, (p1, p2)) -> 
	  Literal(s, (fix_position p1, fix_position p2))
      | Variable(sl, fmt, (p1, p2)) ->
	  Variable(sl, fmt, (fix_position p1, fix_position p2))
      | other -> 
	  other
  in

  let toklist =
    List.map fix_positions (normalize_literals (parse_here_expr ())) in

  let toklist_ast =
    List.map
      (function
	   Literal(s,lexloc) -> 
	     let _loc = camlp4loc lexloc in
	     <:expr< $str:s$ >>	
	 | Variable (id,fmt,lexloc) -> 
	     let _loc = camlp4loc lexloc in 
       (* Relocate the ident to the new location *)
       let id = (new camlp4reloc _loc)#ident id in
	     let node =  
        match fmt with
          | "%s" -> 
            <:expr< $id:id$ >>
          | ("%d"|"%i") -> 
            <:expr< Pervasives.string_of_int $id:id$ >>
          | _ ->
            <:expr< Printf.sprintf $str:fmt$ $id:id$ >>
	     in
	     node
	 | Textend -> failwith "Xstrp4.here_expr")
      toklist
  in

  let rec mk_list_ast l =
    match l with 
	[] -> <:expr@here< [] >>
      | x :: l' ->
	  let ast_l' = mk_list_ast l' in
	  <:expr@here< [ $x$ :: $ast_l'$ ] >>
  in

  let string_mod_ast =    <:expr@here< $uid:"String"$ >> in
  let concat_val_ast =    <:expr@here< $lid:"concat"$ >> in
  let string_concat_ast = <:expr@here< $string_mod_ast$ . $concat_val_ast$ >> in
  let concat_ast =        <:expr@here< $string_concat_ast$ $str:""$ >> in
  let list_ast =          mk_list_ast toklist_ast in
  let result_ast =        <:expr@here< $concat_ast$ $list_ast$ >> in

  match toklist with
      [] ->
	<:expr@here< $str:""$ >>
    | [Literal s] ->
	List.hd toklist_ast   (* = <:expr< $str:s$ >> *)
    | _ ->
	(* General case: *)
	result_ast
;;


let here_expr _loc _loc_name s =
  let lexbuf = Lexing.from_string s in
  interpolated_expr lexbuf _loc
;;

let interpolated_file filename _loc =
  let pathname =
    if Filename.is_implicit filename then
      Filename.concat (Filename.dirname (Loc.file_name _loc)) filename 
    else
      filename
  in
  let f = open_in pathname in
  let lexbuf = Lexing.from_channel f in
  let _loc =
    Loc.of_tuple
      (pathname, 1, 0, 0, 1, 0, 0, false) in
  interpolated_expr lexbuf _loc
;;


let included_file filename _loc =
  let pathname =
    if Filename.is_implicit filename then
      Filename.concat (Filename.dirname (Loc.file_name _loc)) filename 
    else
      filename
  in
  let f = open_in pathname in
  let n = in_channel_length f in
  let s = Bytes.create n in
  really_input f s 0 n;
  close_in f;
  let s = Bytes.to_string s in
  <:expr< $str:s$ >>
;;


let interpolation = Gram.Entry.mk "interpolation";;

EXTEND Gram
  interpolation:
    [[ s = STRING -> 
	 let lexbuf = Lexing.from_string s in
	 interpolated_expr lexbuf _loc
     ]];

  expr: AFTER "simple"
    [[ "interpolate"; "file"; s = STRING -> interpolated_file s _loc
     | "interpolate"; expr = interpolation -> expr
     | "include_file"; s = STRING -> included_file s _loc
     ]];

END
;;


Quotation.add
  "here"
  Syntax.Quotation.DynAst.expr_tag
  here_expr
;;