Removed conversion script FastInf->libDAI because it is buggy (uses wrong permutation...
[libdai.git] / scripts / regenerate-properties
1 #!/usr/bin/perl
2 #
3 # This file is part of libDAI - http://www.libdai.org/
4 #
5 # Copyright (c) 2006-2011, The libDAI authors. All rights reserved.
6 #
7 # Use of this source code is governed by a BSD-style license that can be found in the LICENSE file.
8
9
10 use warnings;
11 use strict;
12
13 use Cwd 'abs_path';
14
15 @ARGV == 2 or die "Need 2 arguments";
16
17 my ($header_file,$source_file) = @ARGV;
18 @ARGV=();
19
20 # Regular expressions for nested brackets (uses perl 5.10 features)
21 my ($nested_angle_brackets) = qr/(<(?:[^<>]++|(?1))*>)/;
22 my ($nested_curly_brackets) = qr/({(?:[^{}]++|(?1))*})/;
23 my ($nested_parentheses) = qr/(\((?:[^()]++|(?1))*\))/;
24
25 # Patterns to match generated code blocks
26 my ($gen_code_start_pat, $gen_code_end_pat, $props_start_pat) =
27 (qr(/\*.*GENERATED CODE: DO NOT EDIT.*),
28 qr(/\*.*END OF GENERATED CODE.*\*/),
29 qr(/\*.*PROPERTIES));
30 # Actual delimiters to use for generated code blocks
31 my ($gen_code_start, $gen_code_end) =
32 ("/* {{{ GENERATED CODE: DO NOT EDIT. Created by\n".
33 " $0 $header_file $source_file\n*/\n",
34 "/* }}} END OF GENERATED CODE */\n");
35
36 # Strings to hold text of files
37 my $header_buffer="";
38 my $source_buffer="";
39
40 # ----------------------------------------------------------------
41 # Useful routines
42
43 # remove leading and trailing whitespace
44 sub stripws ($) {
45 my ($s) = @_;
46 $s =~ s/^\s*//s;
47 $s =~ s/\s*$//s;
48 return $s;
49 }
50
51 # split comments and non-comments, returning 2-element array
52 # of (uncommented part, comments)
53 my $comment_pat = qr#(/\*[^*]*\*+(?:[^/*][^*]*\*+)*/|//[^\n]*)|("(?:\\.|[^"\\])*"|'(?:\\.|[^'\\])*'|.[^/"'\\]*)#;
54 sub sepcomment ($) {
55 my ($c) = @_;
56 my ($u) = $c;
57 $u =~ s#$comment_pat#defined $2 ? $2 : ""#gse;
58 $c =~ s#$comment_pat#defined $1 ? $1 : ""#gse;
59 return ($u, $c);
60 }
61
62 # Run diff, return output
63 sub getdiff ($$) {
64 my ($a,$b) = @_;
65 my $diff="";
66 open DIFF, "diff -u \Q$a\E \Q$b\E |"
67 or die "Couldn't run diff";
68 while(<DIFF>) {
69 $diff .= $_;
70 }
71 close DIFF;
72 return $diff;
73 }
74
75 sub myrename ($$) {
76 my ($a,$b) = @_;
77 $b = abs_path $b;
78 rename($a, $b) or die "Couldn't rename $a to $b";
79 }
80
81 sub writefile ($$) {
82 my ($buf, $f) = @_;
83 open OUT, ">", $f or die "Couldn't open $f for writing";
84 print OUT $buf;
85 close OUT;
86 }
87
88 our ($buffer);
89
90 # Step through file, appending lines to buffer
91 # - Lines which match generated code blocks are omitted
92 # - Other lines are passed to the subroutine. They are added to buffer
93 # unless the subroutine returns 1 (e.g. if it has already added them)
94 sub process_file (&$) {
95 my ($sub, $file) = @_;
96 local ($buffer) = "";
97 # step through lines of file, appending each one to buffer
98 open IN, "<", $file or die "Couldn't open $file for reading";
99 while (<IN>) {
100 # delete anything between GENERATED CODE etc.
101 if (/$gen_code_end_pat/) {
102 die "Unmatched generated code block end at $file line $.";
103 } elsif (/$gen_code_start_pat/) {
104 my $s = $.;
105 my $found=0;
106 while (<IN>) {
107 chomp;
108 if (/$gen_code_end_pat/) {
109 $found=1;
110 last;
111 }
112 }
113 die "Unterminated generated code block at $file line $s"
114 unless $found;
115 next;
116 } else {
117 my ($res) = &$sub;
118 next if $res;
119 }
120 $buffer .= $_;
121 }
122 close IN;
123 return $buffer;
124 }
125
126 # Parse a PROPERTIES() block
127 sub process_properties ($$$) {
128 my ($file, $start_line, $props_text) = @_;
129 my ($errline)="$file:$start_line";
130 $props_text =~ s/^.*PROPERTIES\s*($nested_parentheses)//s
131 or die "Malformed PROPERTIES, $errline: expected PROPERTIES(args)";
132 my ($args) = $1;
133 $args =~ s/^\(//g;
134 $args =~ s/\)$//g;
135 my (@args) = split /,/, $args;
136 @args == 2 or die "PROPERTIES needs two arguments at $errline";
137 my ($struct_name, $class) = @args;
138
139 $props_text =~ m/^\s*($nested_curly_brackets)\s*$/s
140 or die "Malformed PROPERTIES, $errline: expected {} after PROPERTIES";
141 my ($body) = $1;
142 $body =~ s/^{(.*)}$/$1/s; # get rid of curly brackets
143 my (@stmts) = split /;\s*\n/s, $body; # split on ";"
144 my (@typedecls) = ();
145 my (@vars) = ();
146 foreach my $s (@stmts) {
147 my ($s, $cmt) = sepcomment $s;
148 $cmt = stripws $cmt;
149 if($s =~ /^\s*$/s) { # extra ";"
150 next;
151 } elsif($s =~ /DAI_ENUM|typedef/) {
152 push @typedecls, [stripws $s, $cmt];
153 } else {
154 $s =~ /^\s*[a-zA-Z_][\w:]+\s*$nested_angle_brackets?/
155 or die "Couldn't match statement $s in PROPERTIES at $errline";
156 my $type = stripws $&;
157 my $name = stripws $';
158 my $default = undef;
159 if($name =~ /^(.*)=(.*)$/) {
160 $name = stripws $1;
161 $default = stripws $2;
162 }
163 push @vars, [$type, $name, $default, $cmt];
164 }
165 }
166
167 my ($stext) = "";
168 my ($text) = <<EOF;
169 struct Properties {
170 EOF
171 my $indent = (' 'x12);
172 for my $d (@typedecls) {
173 my ($decl,$cmt) = @$d;
174 if($cmt ne '') {
175 $text .= join("\n", map { "$indent$_" } split /\n/s, $cmt)."\n";
176 }
177 $text .= "$indent$decl;\n"
178 }
179 for my $v (@vars) {
180 my ($type,$name,$default,$cmt) = @$v;
181 if($cmt ne '') {
182 $text .= join("\n", map { "$indent$_" } split /\n/s, $cmt)."\n"
183 }
184 $text .= "$indent$type $name;\n";
185 }
186
187 $text .= <<EOF;
188
189 /// Set members from PropertySet
190 /** \\throw UNKNOWN_PROPERTY if a Property key is not recognized
191 * \\throw NOT_ALL_PROPERTIES_SPECIFIED if an expected Property is missing
192 */
193 void set(const PropertySet &opts);
194 /// Get members into PropertySet
195 PropertySet get() const;
196 /// Convert to a string which can be parsed as a PropertySet
197 std::string toString() const;
198 } $struct_name;
199 EOF
200
201 $stext .= <<EOF;
202 namespace dai {
203
204 void ${class}::Properties::set(const PropertySet &opts)
205 {
206 const std::set<PropertyKey> &keys = opts.keys();
207 std::string errormsg;
208 for( std::set<PropertyKey>::const_iterator i = keys.begin(); i != keys.end(); i++ ) {
209 EOF
210 for my $v (@vars) {
211 my ($type,$name,$default,$cmt) = @$v;
212 $stext .= <<EOF;
213 if( *i == "$name" ) continue;
214 EOF
215 }
216 $stext .= <<EOF;
217 errormsg = errormsg + "$class: Unknown property " + *i + "\\n";
218 }
219 if( !errormsg.empty() )
220 DAI_THROWE(UNKNOWN_PROPERTY, errormsg);
221 EOF
222 for my $v (@vars) {
223 my ($type,$name,$default,$cmt) = @$v;
224 if(!defined $default) {
225 $stext .= <<EOF;
226 if( !opts.hasKey("$name") )
227 errormsg = errormsg + "$class: Missing property \\\"$name\\\" for method \\\"\Q$class\E\\\"\\n";
228 EOF
229 }
230
231 }
232 $stext .= <<EOF;
233 if( !errormsg.empty() )
234 DAI_THROWE(NOT_ALL_PROPERTIES_SPECIFIED,errormsg);
235 EOF
236 for my $v (@vars) {
237 my ($type,$name,$default,$cmt) = @$v;
238 if(defined $default) {
239 $stext .= <<EOF;
240 if( opts.hasKey("$name") ) {
241 $name = opts.getStringAs<$type>("$name");
242 } else {
243 $name = $default;
244 }
245 EOF
246 } else {
247 $stext .= <<EOF;
248 $name = opts.getStringAs<$type>("$name");
249 EOF
250 }
251 }
252
253 $stext .= <<EOF;
254 }
255 PropertySet ${class}::Properties::get() const {
256 PropertySet opts;
257 EOF
258
259 for my $v (@vars) {
260 my ($type,$name,$default,$cmt) = @$v;
261 # $text .= qq{opts.set("$name", $name);};
262 $stext .= <<EOF;
263 opts.set("$name", $name);
264 EOF
265
266 }
267 $stext .= <<EOF;
268 return opts;
269 }
270 string ${class}::Properties::toString() const {
271 stringstream s(stringstream::out);
272 s << "[";
273 EOF
274
275 my ($i)=0;
276 for my $v (@vars) {
277 my ($type,$name,$default,$cmt) = @$v;
278 $i++;
279 my $c = ($i<@vars)?" << \",\"":"";
280 $stext .= <<EOF;
281 s << "$name=" << $name$c;
282 EOF
283 }
284
285 $stext .= <<EOF;
286 s << "]";
287 return s.str();
288 }
289 } // end of namespace dai
290 EOF
291 return ($gen_code_start.$text.$gen_code_end, $gen_code_start.$stext.$gen_code_end);
292 }
293
294 # ----------------------------------------------------------------
295 # Main loop
296
297 $source_buffer = process_file { return 0; } $source_file;
298 $source_buffer =~ s/\n+$//s;
299
300 $header_buffer = process_file {
301 if (/$props_start_pat/) {
302 # when we see something resembling properties, record it, and when we
303 # get to the end, process and emit the generated code
304 my $start_line = $.;
305 my $props_text = $_;
306 while (<IN>) {
307 last if(m(\*/));
308 $props_text .= $_;
309 }
310 $buffer .= $props_text;
311 $buffer .= $_;
312 my ($htext, $stext) = process_properties($header_file, $start_line, $props_text);
313 $buffer .= $htext;
314 $source_buffer .= "\n\n\n".$stext;
315 return 1;
316 }
317 return 0;
318 } $header_file;
319
320 # Write new contents of files to temporary locations
321 my $header_tmp = "$header_file.new";
322 my $source_tmp = "$source_file.new";
323 writefile ($header_buffer, $header_tmp);
324 writefile ($source_buffer, $source_tmp);
325
326 # Get a diff of changes, show it to the user, and ask for confirmation
327 my ($diff);
328 $diff = getdiff ($header_file, $header_tmp);
329 $diff .= getdiff ($source_file, $source_tmp);
330
331 if($diff eq '') {
332 warn "No differences\n";
333 } else {
334 my $pager = $ENV{PAGER} || "less";
335 open PAGER, "|$pager";
336 print PAGER $diff;
337 close PAGER;
338
339 print STDERR "Replace old with new version? (y|N) ";
340 $_=<>;
341 if (/^y/i) {
342 myrename($header_tmp, $header_file);
343 myrename($source_tmp, $source_file);
344 } else {
345 warn "Aborted\n";
346 }
347 }